The code below examplifies how to modify the Armpit Scheme prompt. It re-defines the (prompt) function to call (version), to get a version number, and (gc), to find the number of free bytes, and prints those out on the current-output-port (the number of free bytes is divided by eight so that the number of free cons cells is actually displayed). Once the code has been evaluated, the system prompt becomes that produced by this user-defined (prompt) function rather than the built-in (prompt) primitive.
; Armpit Scheme Prompt Example
; tested on LPC-H2214, LPC-H2888, CS-E9302, TCT-Hammer, TI-Beagle
; example prompt
(begin
(define prst
(string-append "aps" (substring (version) 2 7) ">"))
(define (prompt) (write (ash (gc) -3)) (display prst)))
The code below examplifies writing to and reading from files, listing files, erasing all files and unlocking the file system (if it remained locked due to a multitasking crash). It is the same as in prior versions.
; Armpit Scheme File Example
; tested on LPC-H2214, LPC-H2888, CS-E9302, STM32-H103, LM3S1968-EVB, TI-Beagle
; unlock file system (optional - file system may get locked during read/write errors)
(unlock)
; erase all files (optional - may take a few seconds)
(erase)
; list all files
(files)
; write some data to a file named zag
(let ((port (open-output-file "zag")))
(if (zero? port) #f
(begin
(write "hello" port)
(write '(1 2 3) port)
(write 3.4e-2 port)
(write (make-vector 500 123456) port)
(close-output-port port))))
; list all files
(files)
; read and display data from a file named zag
(let ((port (open-input-file "zag")))
(if (zero? port) #f
(let loop ((val (read port)))
(if (eof-object? val)
(close-input-port port)
(begin
(if (not (vector? val))
(write val)
(begin
(write (vector-length val))
(write (vector-ref val 0))
(write (vector-ref val (- (vector-length val) 1)))))
(newline)
(loop (read port)))))))
The code below exemplifies common gpio operations in Armpit Scheme 00.0186 and is the same as in prior versions.
; Armpit Scheme GPIO Example
; tested on LCDDemo-2158, LPC-H2214, LPC-H2888, CS-E9302, TI-Beagle
; LPC-H2103, Tiny2106, SFE-Logomatic V1.0 and V2.0 LPC-H2214
; define GPIO ports and offsets
; ledport <- gpio0
(begin
(define ledport #xE002800) ; IO0 port (PIN = #x00, SET = #x04, DIR = #x08, CLR = #x0C)
(define pin-status #x00) ; IOxPIN register offset
(define pin-set #x04) ; IOxSET register offset
(define pin-clear #x0C)) ; IOxCLR register offset
; Tiny213x, LPC-H2148, LCDDemo-2158, LPC2478-STK
; ledport <- gpio1
(begin
(define ledport #xE002801) ; IO1 port (PIN = #x00, SET = #x04, DIR = #x08, CLR = #x0C)
(define pin-status #x00) ; IOxPIN register offset
(define pin-set #x04) ; IOxSET register offset
(define pin-clear #x0C)) ; IOxCLR register offset
; LPC-H2888
; define GPIO ports and offsets
(begin
(define ledport #x8000308) ; GPIO PORT 2, PINS_2
(define pin-status #x00) ; Pins_2
(define pin-set #x14) ; Mode0s_2
(define pin-clear #x18)) ; Mode0c_2
; SAM7-H256
; define GPIO ports and offsets
(begin
(define ledport #xFFFFF40) ; PIOA (SODR = #x30, CODR = #x34, ODSR = #x38)
(define pin-status #x38) ; PIOA_ODSR
(define pin-set #x30) ; PIOA_SODR
(define pin-clear #x34)) ; PIOA_CODR
; STM32-H103
; define GPIO ports and offsets
(begin
(define ledport #x4001100) ; GPIO PORT C
(define pin-status #x0C) ; output data register (ODR)
(define pin-set #x10) ; bit set register (BSR)
(define pin-clear #x14)) ; bit reset register (BRR)
; STR-H711
; define GPIO ports and offsets -- version 00.0136
(begin
(define ledport #xE000400) ; IOPORT1
(define pin-status #x0C)) ; Pin Data Register offset (PD)
; CS-E9302
; define GPIO ports and offsets
(begin
(define ledport #x8084002) ; GPIO PORT E
(define pin-status #x00)) ; Data Register offset
; TCT-Hammer
; define GPIO ports and offsets
(begin
(define ledport #x5600005) ; GPIO PORT F
(define pin-status #x04)) ; Data Register offset
; LM3S1968-EVB
; define GPIO ports and offsets
(begin
(define ledport #x4002600) ; GPIO PORT G
(define pin-status #x03fc)) ; all io mask
; LM3S6965-EVB
; define GPIO ports and offsets
(begin
(define ledport #x4002500) ; GPIO PORT F
(define pin-status #x03fc)) ; all io mask
; TI-Beagle
; define GPIO ports and offsets
(begin
(define ledport #x4905600) ; GPIO PORT 5
(define pin-status #x3C) ; output data register (DATAOUT)
(define pin-set #x94) ; bit set register (SETDATAOUT)
(define pin-clear #x90)) ; bit clear register (CLEARDATAOUT)
;------------- Semi-Common Code Starts -------------
; LPC-H2103, Tiny2106, Tiny213x, SFE-Logomatic V1.0 and V2.0, LPC-H2148,
; LCDDemo-2158, LPC-H2214, LPC-H2888, SAM7-H256, STM32-H103, LPC2478-STK, TI-Beagle
; functions to set and clear a pin on a gpio port
(begin
(define (set-pin port pin)
(write (ash 1 (min pin 29)) port pin-set))
(define (clear-pin port pin)
(write (ash 1 (min pin 29)) port pin-clear)))
; STR-H711, CS-E9302, TCT-Hammer, LM3S1968-EVB, LM3S6965-EVB
; functions to set and clear a pin on a gpio port
(begin
(define (set-pin port pin)
(write (logior (ash 1 pin) (read port pin-status)) port pin-status))
(define (clear-pin port pin)
(write (logxor (ash 1 pin) (read port pin-status)) port pin-status)))
;------------- Common Code Starts -------------
; function to check the status of a pin on a gpio port
(define (is-set? port pin)
(not (zero? (logand (read port pin-status) (ash 1 (min pin 29))))))
; function to toggle a pin on a gpio port
(define (toggle port pin)
(if (is-set? port pin)
(clear-pin port pin)
(set-pin port pin)))
;------------- Common Code Ends -------------
; toggle MCU board's LED(s)
(toggle ledport 26) ; LPC-H2103 green led
(toggle ledport 23) ; Tiny2106 red led
(toggle ledport 24) ; Tiny2106 yellow led
(toggle ledport 25) ; Tiny2106 green led
(toggle ledport 21) ; Tiny213x red led
(toggle ledport 22) ; Tiny213x yellow led
(toggle ledport 23) ; Tiny213x green led
(toggle ledport 2) ; SFE-Logomatic V1.0 and V2.0 green led
(toggle ledport 11) ; SFE-Logomatic V1.0 and V2.0 red led
(toggle ledport 24) ; LPC-H2148 green led
(toggle ledport 25) ; LCDDemo-2158 green led
(toggle ledport 30) ; LPC-H2214 red led
(toggle ledport 13) ; LPC2478-STK yellow led
(toggle ledport 1) ; LPC-H2888 red led
(toggle ledport 8) ; SAM7-H256 green led
(toggle ledport 8) ; STR-H711 green led
(toggle ledport 0) ; CS-E9302 green led
(toggle ledport 1) ; CS-E9302 red led
(toggle ledport 0) ; TCT-Hammer red led
(toggle ledport 12) ; STM32-H103 green led
(toggle ledport 2) ; LM3S1968-EVB green led
(toggle ledport 0) ; LM3S6965-EVB green led
(toggle ledport 22) ; TI-Beagle USR0 green led
(toggle ledport 21) ; TI-Beagle USR1 green led
This example expands on that from prior versions by adding some level of thread-error processing. The Scheme interrupt service routine can catch a ctrl-c which appears as interrupt -3 but is only guaranteed if no threads (other than top-level) are running (a thread-ID mechanism would be necessary to route ctrl-c to the top-level thread only). A local version of the _catch error-handling function is inserted in the environment of thunks to be threaded that displays the error encoutered (if any) and dequeues the thread (via 'forget-me) on error. The remainder of the example (timer initialization, LED toggling) is similar to that in previous versions.
; Armpit MultiTasking Example [requires the GPIO example, above]
; Tested on LPC-H2214, LPC-H2888, CS-E9302, TCT-Hammer, TI-Beagle
; Tiny2106, Tiny213x, SFE-Logomatic V1.0 and V2.0, LPC-H2148, LCDDemo-2158, LPC-H2214, LPC2478-STK
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #xE000400) ; T0 (IR = #x00, TCR = #x04, TC = #x08, PR = #x0C, MCR = #x14, MR0 = #x18)
(define timer0-int 4) ; timer0 interrupt number
(define timer-period #x18) ; TxMR0 offset
(define timer-count #x08) ; TxTC offset
(define (stop timer)
(write 0 timer #x04)) ; disable timer via TxTCR
(define (restart timer)
(write 2 timer #x04) ; reset timer via TxTCR
(write 1 timer #x04)) ; enable and start timer via TxTCR
(write 59 timer0 #x0C) ; set timer0 period to 1 us (for 60MHz clk) via T0PR
(write 5 timer0 #x14) ; set timer0 to generate interrupt and stop on MR0 match via T0MCR
(stop timer0)
(write 10000 timer0 timer-period))
; LPC-H2888
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x8002000) ; Timer0 base address
(define timer0-int 5) ; timer0 interrupt (bit) number
(define timer-period #x00) ; offset to TnLoad
(define timer-count #x04) ; offset to TnValue
(define (stop timer)
(write 0 timer #x08)) ; disable timer via TnControl
(define (restart timer)
(write 2344 timer0 timer-period)
(write #xc8 timer #x08)) ; start timer via TnControl (60 MHz / 256 clock)
(stop timer0))
; SAM7-H256
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #xFFFA000) ; TC0 port (CCR = #x00, CMR = #x04, CV = #x10, RC = #x1C, IER = #x24)
(define timer0-int 12) ; timer0 interrupt (bit) number
(define timer-period #x1C) ; TCx_RC offset
(define timer-count #x10) ; TCx_CV offset
(define (stop timer)
(write 2 timer #x00)) ; stop timer via TCx_CCR
(define (restart timer)
(write 5 timer #x00)) ; enable, reset and start timer via TCx_CCR
(write #x1000 #xFFFFFC0 #x10) ; Enable clock/power for timer0 (bit 12) via PMC_PCER
(write #xC042 timer0 #x04) ; wave mode, stop on cap RC, clock/32 (2/3 us for 48MHz clk) via TC0_CMR
(write #x10 timer0 #x24) ; Enable interrupt on RC match via TC0_IER
(stop timer0)
(write 15000 timer0 timer-period))
; STR-H711
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #xE000900) ; TIMER0
(define timer0-int 0) ; timer0 interrupt (bit) number
(define timer-period #x08) ; TIMn_OCAR offset
(define timer-count #x10) ; TIMn_CNTR offset (resets to FFFC)
(define (stop timer)
(write 0 timer #x14)) ; disable timer via TIMn_CR1
(define (restart timer)
(write #x8000 timer #x14) ; start timer via TIMn_CR1
(write 0 timer timer-count)) ; reset timer count
(write #x402F timer0 #x18) ; period=1us (for 48 MHz clk) and generate interrupt on match via TIMn_CR2
(stop timer0)
(write 10000 timer0 timer-period))
; CS-E9302
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x8081000) ; Timer1 base address
(define timer0-int 4) ; timer0 interrupt (bit) number
(define timer-period #x00) ; offset to Timer1Load
(define timer-count #x04) ; offset to Timer1Value
(define (stop timer)
(write 0 timer #x08)) ; disable timer via TimerNControl
(define (restart timer)
(write #xC8 timer #x08)) ; start timer via TimerNControl (500kHz clock)
(stop timer0)
(write 5000 timer0 timer-period))
; TCT-Hammer (Samsung S3C2410)
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x5100000) ; TCFG0, Timer 0-4 config base address
(define timer0-int 10) ; timer0 interrupt (bit) number
(define timer-period #x0c) ; offset to TCNTB0
(define timer-count #x14) ; offset to TCNTO0
(write 49 timer0 #x00) ; TCFG0 set prescaler to 50 => 1MHz
(write 0 timer0 #x04) ; TCFG1 set divider to 2 => 500 kHz
(define (stop timer)
(write 0 timer #x08)) ; disable timer via TCON (disables all timers)
(define (restart timer)
(write #x02 timer #x08) ; reload timer0 period via TCON
(write #x01 timer #x08)) ; start timer0 via TCON
(stop timer0)
(write 5000 timer0 timer-period))
; STM32-H103
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x40012c0)
(define timer0-int 24) ; timer0 interrupt (bit) number
(define timer-period #x2c)
(define timer-count #x24)
(define (restart timer)
(write #x0d timer #x00))
(define (stop timer) #t)
(write 0 timer0 #x0c)
(write 71 timer0 #x28)
(write 10000 timer0 timer-period)
(write #x0d timer0 #x00)
(write 1 timer0 #x14)
(write 71 timer0 #x28)
(write 10000 timer0 timer-period)
(write 1 timer0 #x0c))
; LM3S1968-EVB, LM3S6965-EVB, IDM-LM3S1958
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x4003000)
(define timer0-int 19) ; timer0 interrupt (bit) number
(define timer-control #x0C)
(define timer-config #x00)
(define timer-mode #x04)
(define timer-period #x28)
(define timer-imask #x18)
(define timer-count #x48)
(define (stop timer)
(write #x00 timer timer-control))
(define (restart timer)
(write #x01 timer timer-control))
(stop timer0)
(write #x00 timer0 timer-config)
(write #x01 timer0 timer-mode)
(write 500000 timer0 timer-period)
(write #x01 timer0 timer-imask))
; TI-Beagle
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x4831800) ; GPTimer1 base address
(define timer0-int 37) ; GPTimer1 interrupt (bit) number
(define timer-control #x24)
(define timer-config #x10)
(define timer-period #x38)
(define timer-imask #x1c)
(define timer-count #x28)
(define (stop timer)
(write #x00 timer timer-control))
(define (restart timer)
(write #x00 timer timer-count)
(write #x41 timer timer-control))
(stop timer0)
(write #x08 timer0 timer-config)
(write 500000 timer0 timer-period)
(write #x01 timer0 timer-imask))
;------------- Common Code Starts -------------
; Initialize the process queue
(define *queue* '())
; Set Scheme callback to switch queued thunks on Timer 0 interrupts
; note 1: although it is installed at the timer0 offset #x010000, this callback
; is used for all Scheme interrupts.
; note 2: 'case may be used instead of 'cond if interrupt (eg. timer0-int)
; is specified directly as a number (eg. 4)
; note 3: 'throw is used to catch ctrl-c, however, it does not stop the process running
; at the REP but, rather, the thread that happened to be running when ctrl-c
; occured (it is the REP if no other threads were spawned). Avoid using ctrl-c
; when threading.
(write
(lambda (int)
(cond
((= int timer0-int)
(call/cc
(lambda (resume)
(restart timer0)
(if (null? *queue*)
(resume #t)
((car *queue*) (set! *queue* (append (cdr *queue*) (list resume))))))))
(else (throw 'ISR int))))
timer0 #x010000)
; Start timer 0
(restart timer0)
; read the timer count (to check proper operation, read it a few times)
(read timer0 timer-count)
; function to forget current thread
(define (forget-me)
(if (not (null? *queue*))
(begin
(stop timer0)
(let ((p (car *queue*)))
(set! *queue* (cdr *queue*))
(restart timer0)
(p #t)))))
; function to spawn a new thunk (task)
(define (spawn thunk)
(stop timer0)
(set! *queue*
(cons
(lambda ()
(thunk)
(forget-me))
*queue*))
(restart timer0))
; simple error handler that de-queues a thread
(define (thread-error-handler e)
(write e)
(forget-me))
; function to toggle a gpio pin every "ticks" countdown ticks
(define (toggler port pin ticks)
(define _catch thread-error-handler)
(lambda ()
(let go ((n ticks))
(if (> n 0)
(go (- n 1))
(begin
(toggle port pin)
(go ticks))))))
;------------- Within-thread error throw examples -------------
; a function defining a thunk that throws an error from within a thread
(define (threrr1 err ticks)
(define _catch thread-error-handler)
(lambda ()
(let go ((n ticks))
(if (> n 0)
(go (- n 1))
(throw err n)))))
; another function defining a thunk that throws an error from within a thread
(define (threrr2 ticks)
(define _catch thread-error-handler)
(lambda ()
(let go ((n ticks))
(if (> n 0)
(go (- n 1))
(zut 10 20)))))
; a third function defining a thunk that throws an error from within a thread
(define (threrr3 ticks _catch)
(lambda ()
(let go ((n ticks))
(if (> n 0)
(go (- n 1))
(zap 10 20)))))
(spawn (threrr1 'coucou 10000)) ; throw a thread error (dequeues thread)
(spawn (threrr2 10000)) ; throw a thread error (dequeues thread)
(spawn (threrr3 10000 thread-error-handler)) ; throw a thread error (dequeues thread)
;------------- Common Code Ends -------------
; spawn toggler on MCU board's LED(s)
(spawn (toggler ledport 23 2000)) ; Tiny2106 red led
(spawn (toggler ledport 24 1000)) ; Tiny2106 yellow led
(spawn (toggler ledport 25 500)) ; Tiny2106 green led
(spawn (toggler ledport 21 2000)) ; Tiny213x red led
(spawn (toggler ledport 22 1000)) ; Tiny213x yellow led
(spawn (toggler ledport 23 500)) ; Tiny213x green led
(spawn (toggler ledport 11 2000)) ; SFE-Logomatic V1.0 and V2.0 red led
(spawn (toggler ledport 2 1000)) ; SFE-Logomatic V1.0 and V2.0 green led
(spawn (toggler ledport 24 1000)) ; LPC-H2148 green led
(spawn (toggler ledport 25 1000)) ; LCDDemo LPC2158 green led
(spawn (toggler ledport 30 1000)) ; LPC-H2214 red led
(spawn (toggler ledport 13 1000)) ; LPC2478-STK yellow led
(spawn (toggler ledport 1 1000)) ; LPC-H2888 red LED
(spawn (toggler ledport 8 1000)) ; SAM7-H256 green led
(spawn (toggler ledport 8 1000)) ; STR-H711 green led
(spawn (toggler ledport 0 2000)) ; CS-E9302 green LED
(spawn (toggler ledport 1 1000)) ; CS-E9302 red LED
(spawn (toggler ledport 0 5000)) ; TCT-Hammer red LED
(spawn (toggler ledport 12 1000)) ; STM32-H103 green led
(spawn (toggler ledport 2 2000)) ; LM3S1968-EVB green led
(spawn (toggler ledport 0 2000)) ; LM3S6965-EVB green led
(spawn (toggler ledport 22 2000)) ; TI-Beagle USR0 green led
(spawn (toggler ledport 21 4000)) ; TI-Beagle USR1 green led
This example has not yet been adapted to this version.
The code below is the Runge-Kutta solution of a system of Ordinary Differential Equations (ODEs) representing a simple oscillator that is given on page 44 of the Revised^5 Report on the Algorithmic Language Scheme (r5rs). A helper function to drive the code is given at the end. This example is the same as in all prior versions of Armpit Scheme.
; Armpit Scheme Runge-Kutta Example (R5RS p. 44)
; Tested on Tiny2138, SFE-Logomatic, LPC-H2148, LCDDemo-2158, Tiny2106,
; LPC-H2214, SAM7-H256, STR-H711, LPC-H2888, CS-E9302,
; LM3S1968-EVB, TI-Beagle
(define integrate-system
(lambda (system-derivative initial-state h)
(let ((next (runge-kutta-4 system-derivative h)))
(letrec ((states
(cons initial-state
(delay (map-streams next states)))))
states))))
; There is no need to paste this in two chunks to avoid errors anymore
(define runge-kutta-4
(lambda (f h)
(let ((*h (scale-vector h))
(*2 (scale-vector 2))
(*1/2 (scale-vector (/ 1 2)))
(*1/6 (scale-vector (/ 1 6))))
(lambda (y)
(let* ((k0 (*h (f y)))
(k1 (*h (f (add-vectors y (*1/2 k0)))))
(k2 (*h (f (add-vectors y (*1/2 k1)))))
(k3 (*h (f (add-vectors y k2)))))
(add-vectors
y (*1/6 (add-vectors k0 (*2 k1) (*2 k2) k3))))))))
(define elementwise
(lambda (f)
(lambda vectors
(generate-vector
(vector-length (car vectors))
(lambda (i)
(apply f
(map (lambda (v) (vector-ref v i))
vectors)))))))
(define generate-vector
(lambda (size proc)
(let ((ans (make-vector size)))
(letrec ((loop
(lambda (i)
(cond ((= i size) ans)
(else
(vector-set! ans i (proc i))
(loop (+ i 1)))))))
(loop 0)))))
(define add-vectors (elementwise +))
(define scale-vector
(lambda (s)
(elementwise (lambda (x) (* x s)))))
(define map-streams
(lambda (f s)
(cons (f (head s))
(delay (map-streams f (tail s))))))
(define head car)
(define tail
(lambda (stream) (force (cdr stream))))
(define damped-oscillator
(lambda (R L C)
(lambda (state)
(let ((Vc (vector-ref state 0))
(I1 (vector-ref state 1)))
(vector (- 0 (+ (/ Vc (* R C)) (/ I1 C)))
(/ Vc L))))))
(define the-states
(integrate-system
(damped-oscillator 10000 1000 .001)
'#(1 0)
.01))
; function to compute the solution for a given time span
(define oscillate
(lambda (steps)
(let loop ((n steps) (r the-states))
(and (>= n 0)
(write (- steps n))
(write (head r))
(newline)
(loop (- n 1) (tail r))))))
; compute the solution
(oscillate 10)
(oscillate 50)
(oscillate 100)
The code below provides two examples of Fast Fourier Transform computation in Armpit Scheme 00.0186. Both examples use the complex numbers new to this snapshot. The first example is adapted for complex numbers from the FFT example provided in the Gambit-C Scheme benchmarks here, and side-effects the input data vector. The second example is adapted from a Scheme Workshop entry by John David Stone and preserves the input data vector.
; Armpit Scheme FFT Example
; Tested on LPC-H2214, LPC-H2888, CS-E9302, TI-Beagle
; Example 1: FFT adapted from Gambit-C Scheme benchmarks
; modified for complex numbers
; define pi
(define pi (* 4 (atan 1)))
; forward FFT function
(define (four2 data)
(let ((n (vector-length data)))
(let loop1 ((i 0) (j 0))
(if (< i n)
(begin
(if (< i j)
(let ((temp (vector-ref data i)))
(vector-set! data i (vector-ref data j))
(vector-set! data j temp)))
(let loop2 ((m (ash n -1)) (j j))
(if (and (>= m 2) (>= j m))
(loop2 (ash m -1) (- j m))
(loop1 (+ i 1) (+ j m)))))))
(let loop3 ((mmax 1))
(if (< mmax n)
(let ((wp (- (make-polar 1 (/ pi mmax)) 1)))
(let loop4 ((w 1.0) (m 0))
(if (< m mmax)
(begin
(let loop5 ((i m))
(if (< i n)
(let* ((j (+ i mmax))
(temp (* w (vector-ref data j))))
(vector-set! data j (- (vector-ref data i) temp))
(vector-set! data i (+ (vector-ref data i) temp))
(loop5 (+ j mmax)))))
(loop4 (+ (* w wp) w) (+ m 1)))))
(loop3 (* mmax 2)))))))
; simple data set, 32 real values
(define data
(let ((d (make-vector 32)))
(let loop ((n 0))
(if (> n 31) d
(begin
(vector-set! d n (+ 1/3 (cos (* (/ 2 32) 2 pi n))))
(loop (+ n 1)))))))
; forward transform -- this side-effects data
(four2 data)
; view result
data
; Example 2: FFT adapted from Scheme Workshop code by John David Stone
; define pi
(define pi (* 4 (atan 1)))
(define fft
(let ((unshuffle
(lambda (seq)
(let loop ((rest seq)
(evens '())
(odds '()))
(if (null? rest)
(cons (reverse evens) (reverse odds))
(loop (cddr rest)
(cons (car rest) evens)
(cons (cadr rest) odds)))))))
(lambda (sequence)
(let ((len (length sequence)))
(if (= len 1)
sequence
(let ((nth-root (make-polar 1 (/ (* 2 pi) len)))
(half-len (quotient len 2))
(packs (unshuffle sequence)))
(let loop ((step 0)
(root 1)
(evens (fft (car packs)))
(odds (fft (cdr packs)))
(front '())
(rear '()))
(if (= step half-len)
(append (reverse front) (reverse rear))
(loop (+ step 1)
(* root nth-root)
(cdr evens)
(cdr odds)
(cons (+ (car evens) (* root (car odds)))
front)
(cons (- (car evens) (* root (car odds)))
rear))))))))))
; simple data set, 32 real values
(define data2
(let ((d (make-vector 32)))
(let loop ((n 0))
(if (> n 31) (vector->list d)
(begin
(vector-set! d n (+ 1/3 (cos (* (/ 2 32) 2 pi n))))
(loop (+ n 1)))))))
; perform FFT
(fft data2)
; get magnitude of Fourier components
(map magnitude (fft data2))
This Expert System example is the same as that of version from 00.0098 onwards except for the addition of the fact (female jill) in the fact-base.
; Armpit Scheme Expert System Example
; Tested on LPC-H2214, LPC-H2888, CS-E9302, TI-Beagle
; utility function for printed output
(define (writeln . expr)
(display-all expr))
; utility function for printed output
(define (display-all lst)
(if (null? lst)
(newline)
(begin
(display (car lst))
(display-all (cdr lst)))))
; initial function that defines what to do when query fails
(define (fail) #f)
; current depth of chaining over rules
(define chain-depth 0)
; function to delay evaluation of alternatives
(define (cdelay fn)
(let ((hold-fail fail))
(set! fail
(lambda ()
(set! fail hold-fail)
(fn)))))
; function to pick one of several alternatives
(define (amb . expr-list)
(call/cc
(lambda (return)
(for-each
(lambda (expr)
(cdelay (lambda () (return expr))))
expr-list)
(fail))))
; helper macro to temporarily set the value of a variable
(define-syntax set
(syntax-rules ()
((_ var val)
(let ((local-save var))
(cdelay (lambda () (set! var local-save) (amb)))
(set! var val)))))
; function to temporarily set the value of a variable
(define (bind! var expr)
(eval `(set ,var ',expr)))
; function to identify whether a variable is bound
; uses (interaction-environment) to define 'new' vars
(define (bound? var)
(or (defined? var)
(eval `(define ,var 'UNASSIGNED) (interaction-environment)))
(not (eq? (eval var) 'UNASSIGNED)))
; function to identify whether an expression is a variable
(define (variable? expr)
(and
(symbol? expr)
(eq? #\?
(string-ref (symbol->string expr) 0))))
; function to identify whether an expression is a rule
(define (rule? expr)
(and (pair? expr)
(equal? (cadr expr) ':-)))
; function to substitute variable-bindings into an expression
(define (subst-bindings form)
(cond ((pair? form)
(cons (subst-bindings (car form))
(subst-bindings (cdr form))))
((variable? form)
(if (bound? form)
(subst-bindings (eval form))
form))
(else form)))
; function to unify two expressions
(define (unify pattern1 pattern2)
(cond
((equal? pattern1 pattern2) #t)
((and (pair? pattern1) (pair? pattern2))
(and
(unify (car pattern1) (car pattern2))
(unify (cdr pattern1) (cdr pattern2))))
((variable? pattern1)
(if (bound? pattern1)
(unify (eval pattern1) pattern2)
(and
(no-self-ref? pattern1 pattern2)
(bind! pattern1 pattern2))))
((variable? pattern2)
(unify pattern2 pattern1))
(else (amb))))
; function to identify whether self-references exist in an expression
(define (no-self-ref? var expr)
(cond ((equal? var expr) (amb))
((pair? expr)
(and (no-self-ref? var (car expr))
(no-self-ref? var (cdr expr))))
((variable? expr)
(or (not (bound? expr))
(no-self-ref? var (eval expr))))
(else #t)))
; function to evaluate a knowledge-base query
(define (qeval query kb)
(or (eq? query #t)
(let ((kb-item (apply amb kb)))
(if (rule? kb-item)
(let ((clean-rule (rename-vars kb-item)))
(unify query (car clean-rule))
(set chain-depth (+ 1 chain-depth))
(and-query (cddr clean-rule) kb))
(unify query kb-item)))))
; function to evaluate an and query
(define (and-query pattern-list kb)
(or (null? pattern-list)
(and (qeval (car pattern-list) kb)
(and-query (cdr pattern-list) kb))))
; function to rename the variables in an expression
(define (rename-vars expr)
(cond
((pair? expr)
(cons
(rename-vars (car expr))
(rename-vars (cdr expr))))
((variable? expr)
(string->symbol
(string-append
(symbol->string expr)
(number->string chain-depth))))
(else expr)))
; function to find all true resolutions of a query
(define (all query . kbase)
(let ((kb (if (null? kbase) *knowledge-base* (car kbase))))
(and (qeval query kb)
(writeln (subst-bindings query))
(amb))))
; a basic fact base for testing
(define *fact-base*
'((parent john joe)
(parent john jim)
(parent julie joe)
(parent jill jim)
(parent julie john)
(parent jim bill)
(parent jim jill)
(parent joe alice)
(parent joe linda)
(male john)
(male joe)
(male jim)
(male bill)
(female jill)
(female julie)
(female alice)
(female linda)))
; a basic rule base for testing
(define *rule-base*
'(((mother ?x ?y) :- (female ?x) (parent ?x ?y))
((father ?x ?y) :- (male ?x) (parent ?x ?y))
((daughter ?x ?y) :- (female ?x) (parent ?y ?x))
((son ?x ?y) :- (male ?x) (parent ?y ?x))
((grandparent ?x ?z) :- (parent ?x ?y) (parent ?y ?z))
((grandmother ?x ?z) :- (mother ?x ?y) (parent ?y ?z))
((grandfather ?x ?z) :- (father ?x ?y) (parent ?y ?z))))
; define the knowledge base used for testing
(define *knowledge-base*
(append *fact-base* *rule-base*))
; examples of basic queries
(all '(father ?x ?y))
(all '(father ?x ?x))
(all '(mother ?x ?y))
(all '(parent ?x joe))
(all '(grandparent ?x alice))
(all '(grandfather ?x alice))
(all '(grandfather ?x linda))
(all '(?x jim ?y))
(all '(grandparent ?x ?x))
(all '(son ?x ?y))
(all '(son jim ?x))
(all '(son ?x jim))
(all '(daughter ?x joe))
(all '(?x ?y ?z)) ; find every ternary relation that can be infered
This is an example of how to use the 8-digit LCD on the Future Designs LCDDemo-LPC2158 MCU board. It is the same as in previous versions (but runs in a more stable manner).
; Armpit Scheme I2C Communication to LCD Example
; Tested on LCDDemo-2158
; define useful ports
; pinsel <- PINSEL0 port (0 = #x00, 1 = #x04, 2 = #x14)
; i2c <- I2C0 port (CONSET = #x00, STAT = #x04, SCLH = #x10, SCLL = #x14, CONCLR = #x18)
(begin
(define i2c #xE001C00)
(define pinsel #xE002C00)
(define lcd '#(#x38)))
; configure MCU pins for I2C0 operation
; 1- configure P0.2 and P0.3 as I2C via PINSEL0
; 2- set I2C high clock period to 0.783 us (60 MHz pclck, 400kb/s) via I2C0SCLH
; 3- set I2C low period to 1.716 us (60 MHz pclck, 400kb/s) via I2C0SCLL
; 4- clear STA and SI via I2C0CONCLR
; 5- enable I2C on port 0, both master and slave (set I2EN, AA) via I2C0CONSET
(begin
(write (logior #x50 (logand #xFFFFFF0F (read pinsel 0))) pinsel 0)
(write 47 i2c #x10)
(write 103 i2c #x14)
(write #x28 i2c #x18)
(write #x44 i2c #x00))
; function to write data/commands to LCD via I2C
(define (write-lcd val)
(write val i2c lcd 3)) ; write 3 bytes to lcd address
; write-lcd (above) may break when multitasking.
; A multitasking-safe(r) (serialized) version is below (commented).
; It is designed to work with the multitasking/GPIO example above.
; function to write data/commands to LCD via I2C
;(define (write-lcd val)
; (stop timer0)
; (write val i2c lcd 3) ; write 3 bytes to lcd address
; (restart timer0))
; configure LCD
(write-lcd #xcce070) ; mode set (bias 1/3, enabled), select dev 0, no blnk
; light-up all LCD segments
(let loop ((pos 0))
(if (> pos 7) #t
(begin
(write-lcd (logior #xffff (ash pos 18)))
(loop (+ pos 1)))))
; clear LCD segments
(let loop ((pos 0))
(if (> pos 7) #t
(begin
(write-lcd (ash pos 18))
(loop (+ pos 1)))))
; display 3 letters
(begin
(write-lcd #x0Ce426) ; write letter A at digit 3
(write-lcd #x08e427) ; write letter B at digit 2
(write-lcd #x048007)) ; write letter C at digit 1
; display a lambda
(write-lcd (logior #x000000 (logior (ash 1 #x4) (logior (ash 1 #x6) (ash 1 #xb)))))
; bit <-> segment mapping for this LCD
;
; .C
; 000000000
; D4 8 91
; D 4 8 9 1
; D 4 8 9 1
; D 489 1
; 5555 AAAA
; E 67B 2
; E 6 7 B 2
; E 6 7 B 2
; E6 7 B2
; FFFFFFFFF
; '3
The five code examples below illustrate how to use the function (install ...) to store Scheme objects in RAM above the heap. It is an update from prior versions where object tags are those of snapshot 00.0186 (the new vector tag, string tag, variable tag and primitive tag are used in the examples), 'exact? is used to differentiate between integer and floats (rationals and complex numbers are not used in the examples), and (/ 7.) is used to obtain a float (rather than (/ 7)).
; Example 1: Storing a single integer or float
; --------------------------------------------
; function to split an Armpit Scheme 30-bit number (int/float)
; into 2 halfwords, with the appropriate 2-bit tag (for integer or float, tested with exact?)
; in the lsb of the lower halfword
(define (split-num num)
(cons
(logand #xffff (logior (ash num 2) (if (exact? num) #x01 #x02)))
(logand #xffff (ash num -14))))
; build a vector of half-words representing the number 30
(define v30
(let ((n30 (split-num 30)))
(vector 0 0 (car n30) (cdr n30))))
; store the number 30 above the heap
(define n (install v30))
; perform checks -- n is the address of 30, (car n) is the value stored
; (n itself does not refer to a proper list!)
(car n) ; -> 30
(+ (car n) 20) ; -> 50
(set-car! n 2.25) ; modify the content of the object stored above the heap
(sqrt (car n)) ; -> 1.5
; Example 2: Storing a vector of numbers
; --------------------------------------
; function to split the 32-bit tag of a vector (vector-length
; in bits 32-8 and #x4F in bits 7-0) into 2 halfwords
(define (vector-tag vlen)
(cons
(logand #xffff (logior (ash vlen 8) #x4f))
(logand #xffff (ash vlen -8))))
; function to convert a vector of numbers into a vector
; of corresponding halfwords, with the appropriate tag
(define (vector->obj vec)
(let* ((vl (vector-length vec))
(tag (vector-tag vl))
(vobj (make-vector (+ 4 (ash vl 1)))))
(vector-set! vobj 0 0)
(vector-set! vobj 1 0)
(vector-set! vobj 2 (car tag))
(vector-set! vobj 3 (cdr tag))
(let loop ((n 0))
(if (>= n vl) vobj
(begin
(let ((num (split-num (vector-ref vec n))))
(vector-set! vobj (+ 4 (ash n 1)) (car num))
(vector-set! vobj (+ 5 (ash n 1)) (cdr num)))
(loop (+ n 1)))))))
; Store a vector of numbers above the heap
(define numvec
(install (vector->obj '#(3 2 1 1.5 -1.23456 -1e3))))
; perform checks:
numvec ; -> #(3 2 1 1.5 -1.23456 -1e3)
(vector-ref numvec 4) ; -> -1.23456
(vector-set! numvec 3 (/ 7.)) ; modify object contents
numvec ; -> #(3 2 1 1.42857e-1 -1.23456 -1e3)
; Example 3: Storing a string
; ---------------------------
; function to split the 32-bit tag of a string (string-length
; in bits 32-8 and #x5F in bits 7-0) into 2 halfwords
(define (string-tag slen)
(cons
(logand #xffff (logior (ash slen 8) #x5F))
(logand #xffff (ash slen -8))))
; function to convert a string into a vector
; of corresponding halfwords, with the appropriate tag
(define (string->obj str)
(let* ((sl (string-length str))
(tag (string-tag sl))
(vobj (make-vector (+ 4 (ash (+ sl 1) -1)))))
(vector-set! vobj 0 0)
(vector-set! vobj 1 0)
(vector-set! vobj 2 (car tag))
(vector-set! vobj 3 (cdr tag))
(let loop ((n 0))
(if (> n sl) vobj
(begin
(vector-set!
vobj
(+ 4 (ash n -1))
(logior
(char->integer (string-ref str n))
(ash (char->integer (string-ref str (+ n 1))) 8)))
(loop (+ n 2)))))))
; Store a string above the heap
(define greeting
(install (string->obj "hello")))
; perform checks:
greeting ; -> "hello"
(string-ref greeting 4) ; -> #\o
(string-set! greeting 0 #\H) ; modify object contents
greeting ; -> "Hello"
; Example 4: Storing a list of numbers
; ------------------------------------
; function to convert a list of numbers into a vector
; of corresponding halfwords. The car and cdr of a cons cell are
; represented by a total of 4 halfwords. The cdr is either scheme null (#x0f)
; or the offset of the next cell (lnk) from the start of the list-cell halfwords.
(define (list->obj lst)
(let ((vobj (make-vector (+ 2 (ash (max (length lst) 1) 2)))))
(vector-set! vobj 0 0)
(vector-set! vobj 1 0)
(let loop ((n 2) (ls lst))
(if (null? ls)
(begin
(vector-set! vobj (- n 2) #x0f)
(vector-set! vobj (- n 1) #x00)
vobj)
(begin
(let ((num (split-num (car ls))))
(vector-set! vobj n (car num))
(vector-set! vobj (+ n 1) (cdr num)))
(let ((lnk (+ 1 (ash n -1))))
(vector-set! vobj (+ n 2) (logior (ash 1 29) (logand #xffff lnk)))
(vector-set! vobj (+ n 3) 0))
(loop (+ n 4) (cdr ls)))))))
; Store a list of numbers above the heap
(define numlst
(install (list->obj '(3 2 1 1.5 -1.23456 -1e3))))
; perform checks:
numlst ; -> (3 2 1 1.5 -1.23456 -1e3)
(cdddr numlst) ; -> (1.5 -1.23456 -1e3)
(set-car! (cdddr numlst) 1000) ; modify object contents
numlst ; -> (3 2 1 1000 -1.23456 -1e3)
; Example 5: Storing an assembled primitive
; -----------------------------------------
; Consider the simple Assembly function below and its machine code.
; The function takes nothing as input and returns #t:
; @ ARM Thumb2
; @ -------- ---------
; set sv1, #t @ E3A0401F 041FF04F
; set pc, cnt @ E1A0F001 468F
; define halfword vector for the above primitive (as variable) with no inputs:
(define vcod '#(#xAF 0 #xEF 0 #x401F #xE3A0 #xF001 #xE1A0)) ; ARM
(define vcod '#(#xAF 0 #xEF 0 #xF04F #x041F #x468F #xBF00)) ; Thumb2 (#xBF00 is nop)
; store primitive above heap and define as function true:
(define true (install vcod))
; perform checks:
true ; -> #<primitive>
(true) ; -> #t
The code below is a partial assembler for an ARM assembly language with a slight Scheme flavor (ArmSchembly). It is an update from examples developed for previous versions of Armpit Scheme for this version's new object tags and adds instructions like 'msr, 'mrs and 'adr (eg. to load constants stored at specified forward address labels) but removes all previously implemented Thumb-2 pre-functionality. The code is designed to be written to a file named "assembler" and is followed by examples (bssq and bssoc that implement the functionality of assq and assoc).
; open the output file
(define p (open-output-file "assembler"))
; function to display an assembled code vector in hexadecimal
(write
'(define (bspl vcod)
(let loop ((n 0) (m (vector-length vcod)))
(if (>= n m) #t
(begin
(display
(string-append
"#x"
(substring (number->string (vector-ref vcod n) 16) 4 8)))
(display
(string-append
"#x"
(substring (number->string (vector-ref vcod (+ n 1)) 16) 4 8)))
(loop (+ n 2) m)))))
p)
; define instructions, macros ...
(write
'(begin
(define ARM #t)
(define *labels* '())
(define *syms*
'((#null . #x0f) (#t . #x1f) (#f . #x2f) (#c0 . #x3f) (#i0 . #x01) (#f0 . #x02) (#s0 . #x5f)))
(define *registers*
'((fre . 0) (cnt . 1) (rva . 2) (rvb . 3)
(sv1 . 4) (sv2 . 5) (sv3 . 6) (sv4 . 7)
(sv5 . 8) (env . 9) (dts . 10) (glv . 11)
(rvc . 12) (sp . 13) (lnk . 14) (pc . 15)
(spsr . 4) (cpsr . 0)))
(define *ARMops*
'((and . #x00) (eor . #x02) (sub . #x04) (rsb . #x06)
(add . #x08) (adc . #x0a) (sbc . #x0c) (rsc . #x0e)
(mrs . #x10) (tst . #x11) (msr . #x12) (teq . #x13)
(cmp . #x15) (cmn . #x17) (orr . #x18) (mov . #x1a)
(bic . #x1c) (mvn . #x1e) (str . #x58) (ldr . #x59)
(adr . #x28)
(strb . #x5c) (ldrb . #x5d) (strh . #x18) (ldrh . #x19)
(swp . #x10)
(stm . #x88) (ldm . #x89)
(mul . #x00) (mla . #x02) (umull . #x08) (umlal . #x0a) (smull . #x0c) (smlal . #x0e)
(swi . #xf0) (b . #xa0) (bl . #xb0)))
(define *ARMmacros*
'(cons list save restore raw->int int->raw raw->chr chr->raw snoc!
call set! eq? null? car cdr caar cadr cdar cddr caaar cadar cdddr set-car! set-cdr!
vcrfi vcsti
lsl lsr asr ror))
(define *shifts* '((lsl . #x00) (lsr . #x02) (asr . #x04) (ror . #x06)))
(define *conds* '((eq . #x00) (ne . #x01) (pl . #x05) (mi . #x04)))
(define *amode4* '((da . #x08) (ia . #x00) (db . #x18) (ib . #x10))))
p)
; define utility functions
(write
'(begin
(define (sym? sym) (assq sym *syms*))
(define (symcode sym) (code sym *syms* #x00))
(define (macro? expr) (memq (car expr) *ARMmacros*))
(define (reg? sym) (assq sym *registers*))
(define (regcode sym) (code sym *registers* #x00))
(define (shift? sym) (assq sym *shifts*))
(define (shiftcode sym) (code sym *shifts* #x00))
(define (cond? sym) (assq sym *conds*))
(define (condcode sym) (code sym *conds* #x0e))
(define (opcode sym) (code sym *ARMops* #x00))
(define (amode4code sym) (code sym *amode4* #x00))
(define (code sym lst dflt)
(let ((c (assq sym lst)))
(if (null? c) dflt (cdr c))))
(define (aval sym)
(cond
((reg? sym) (regcode sym))
((sym? sym) (symcode sym))
(else (eval sym)))))
p)
; define some needed tags
(write
'(begin
(define variable_tag #xaf)
(define syntax_tag #x8f)
(define primitive_tag #xef))
p)
; main assembly function
(write
'(define (assemble typ narg elist)
(let* ((code1 (asjt elist))
(vcod (make-vector (+ 4 (ash (length code1) 1)))))
(vector-set! vcod 0 (if (eq? typ 'var) variable_tag syntax_tag))
(vector-set! vcod 1 0)
(vector-set! vcod 2 (logior (ash narg 8) primitive_tag))
(vector-set! vcod 3 0)
(let loop ((n 4) (code code1))
(if (null? code)
vcod
(begin
(vector-set! vcod n (logand #xffff (cdar code)))
(if (zero? (logand #xf0000 (caar code)))
(vector-set!
vcod (+ n 1)
(logior
(ash (caar code) 12)
(logand #x0fff (ash (cdar code) -16))))
(vector-set! vcod (+ n 1) (logand #xffff (caar code))))
(loop (+ n 2) (cdr code)))))))
p)
; inline jump target addresses
(write
'(define (asjt elist)
(let loop ((n 0) (code (asln elist)))
(if (null? code) code
(cons
(let ((opc (logand (cdar code) #xf000000)))
(if (or (eq? opc #xa000000) (eq? opc #xb000000))
(let ((adr
(cdr (list-ref *labels* (logand (cdar code) #xffffff)))))
(if (null? adr)
(car code)
(cons (caar code) (logior opc (logand (- adr 2 n) #xffffff)))))
(if (eq? (logand (cdar code) #xfff0000) #x28f0000)
(let ((adr
(cdr (list-ref *labels* (logand (cdar code) #xfff)))))
(if (null? adr)
(car code)
(cons (caar code)
(logior (logand (cdar code) #xffff000)
(imm8adr (logand (ash (- adr 2 n) 2) #xfff))))))
(car code))))
(loop (+ n 1) (cdr code))))))
p)
; imm8adr ror shift is ARM 2-bits (see different imm8r restriction below)
; (because number to shift is equal or less than 0xfff and has #b00 as lsb)
(write
'(define (imm8adr val)
(let loop ((n 16) (v val))
(if (zero? (logand #xffffff (ash v -8)))
(if (and (zero? (logand v #x03)) (< n 16))
(logior (ash (remainder (- n 1) 16) 8) (logand (ash v -2) #xff))
(logior (ash (remainder n 16) 8) (logand v #xff)))
(loop (- n 1) (logand #xfffffff (ash v -2))))))
p)
; assign line numbers to labels in *labels* (long jumps are placed at end)
(write
'(define (asln elist)
(set! *labels* '())
(let ((code1
(let loop1 ((n 0) (code (aslm elist)))
(if (null? code) code
(if (not (pair? (car code)))
(begin
(let loop2 ((lbls *labels*))
(if (eq? (car code) (caar lbls))
(set-cdr! (car lbls) n)
(loop2 (cdr lbls))))
(loop1 n (cdr code)))
(cons (car code)
(loop1 (+ n 1) (cdr code))))))))
(let loop ((n (length code1)) (code code1) (labels *labels*))
(if (null? labels) code
(if (null? (cdar labels))
(begin
(set-cdr! (car labels) n)
(loop
(+ n 2)
(append
code
(list
(cons #x0E #x51FF004)
(cons
(logand #x0f (ash (eval (caar labels)) -26))
(logand #x0fffffff (+ (ash (eval (caar labels)) 2) 4)))))
(cdr labels)))
(loop n code (cdr labels)))))))
p)
; expand macros, find labels (store them in *labels*), assemble swi
(write
'(define (aslm elist)
(if (null? elist)
elist
(append
(let ((expr (car elist)))
(cond
((not (pair? expr))
(if (not (assq expr *labels*))
(set! *labels* (append *labels* (list (list expr)))))
(list expr))
((not (symbol? (car expr)))
(list (cons (logior #xf0000 (car expr)) (cdr expr))))
((macro? expr) (aslm (mexpand expr)))
((and (or (cond? (car expr)) (eq? (car expr) 's)) (macro? (cdr expr)))
(aslm (addprefix (car expr) (mexpand (cdr expr)))))
(else (list (as1 expr)))))
(aslm (cdr elist)))))
p)
; add conditional prefix to expanded macros
; note: do not add prefix to save, cons and list (due to internal bl)
(write
'(define (addprefix prefix elist)
(if (null? elist) elist
(cons
(cons prefix (car elist))
(addprefix prefix (cdr elist)))))
p)
; expand a macro (part 1)
; (split in 2 parts to fit within readbuffer of chips running native USB: 1936 bytes max)
(write
'(define (mexpand expr)
(case (car expr)
((cons)
(list
'(bl _cons)
`(! ia stm rva ,(caddr expr) ,(cadddr expr))
`(sub ,(cadr expr) rva 8)
'(orr fre rva 2)))
((list)
(list
'(bl _list)
`(! ia stm rva ,(caddr expr) rvc)
`(sub ,(cadr expr) rva 8)
'(orr fre rva 2)))
((save)
(apply
append
(map (lambda (reg) (list '(bl _save) `(set-car! dts ,reg))) (reverse (cdr expr)))))
((restore)
(map (lambda (reg) `(ia ldm dts ,reg dts)) (reverse (cdr expr))))
((int->raw) (list `(mov ,(cadr expr) asr ,(caddr expr) 2)))
((raw->int)
(list `(set! ,(cadr expr) #i0) `(orr ,(cadr expr) ,(cadr expr) lsl ,(caddr expr) 2)))
((chr->raw) (list `(lsr ,(cadr expr) ,(caddr expr) 8)))
((raw->chr)
(list `(set! ,(cadr expr) #c0) `(orr ,(cadr expr) ,(cadr expr) lsl ,(caddr expr) 8)))
((snoc!)
(list `(ia ldm ,(cadddr expr) ,(cadr expr) ,(caddr expr))))
((call) (list '(set! cnt pc) `(b ,(cadr expr))))
(else (mexpand2 expr))))
p)
; expand a macro (part 2)
(write
'(define (mexpand2 expr)
(case (car expr)
((set!) (list `(mov ,@(cdr expr))))
((eq?) (list `(teq ,@(cdr expr))))
((null?) (list `(eq? ,(cadr expr) #null)))
((car) (list `(ldr ,@(cdr expr))))
((cdr) (list `(ldr ,@(cdr expr) 4)))
((caar) (list `(ldr ,@(cdr expr)) `(ldr ,(cadr expr) ,(cadr expr))))
((cadr) (list `(ldr ,@(cdr expr) 4) `(ldr ,(cadr expr) ,(cadr expr))))
((cdar) (list `(ldr ,@(cdr expr)) `(ldr ,(cadr expr) ,(cadr expr) 4)))
((cddr) (list `(ldr ,@(cdr expr) 4) `(ldr ,(cadr expr) ,(cadr expr) 4)))
((caaar) (list `(ldr ,@(cdr expr)) `(ldr ,(cadr expr) ,(cadr expr)) `(ldr ,(cadr expr) ,(cadr expr))))
((cadar) (list `(ldr ,@(cdr expr)) `(ldr ,(cadr expr) ,(cadr expr) 4) `(ldr ,(cadr expr) ,(cadr expr))))
((cdddr) (list `(ldr ,@(cdr expr) 4) `(ldr ,(cadr expr) ,(cadr expr) 4) `(ldr ,(cadr expr) ,(cadr expr) 4)))
((set-car!) (list `(str ,(caddr expr) ,(cadr expr))))
((set-cdr!) (list `(str ,(caddr expr) ,(cadr expr) 4)))
((vcrfi)
(list `(ldr ,(cadr expr) ,(caddr expr) ,(+ 4 (ash (cadddr expr) 2)))))
((vcsti)
(list `(str ,(cadddr expr) ,(cadr expr) ,(+ 4 (ash (caddr expr) 2)))))
((lsl lsr asr ror)
(list `(mov ,(cadr expr) ,(car expr) ,@(cddr expr))))
(else #f)))
p)
; assemble basic instructions
; mov mvn tst teq cmp cmn and eor sub rsb add adc sbc rsc mrs msr orr bic
; ldr str ldrb strb ldrh strh ldm stm mul mla umull umlal smull smlal b bl
; swi swp
(write
'(define (as1 expr)
(let ((op (car expr))
(argl (cdr expr)))
(if (memq op '(eq ne pl mi s ! ^ ia ib da db))
(aspr op (as1 argl))
(cons
#xe
(logior
(ash (opcode op) 20)
(case op
((swi) (aval (car argl)))
((b bl) (asbrnch op (car argl)))
((adr) (asadr op (car argl) (cadr argl)))
(else
(let* ((args (garg op argl))
(Rd (car args))
(Rm (cadr args))
(rest (cddr args)))
(logior
(ash (aval Rd) 12)
(logior
(ash (aval Rm) 16)
(case op
((lsl lsr asr ror) (amode1 rest))
((ldr str ldrb strb) (amode2 rest))
((ldrh strh) (amode3 rest))
((ldm stm) (reglist rest))
((mul mla umull umlal smull smlal) (asmul rest))
((swp) (logior #x90 (aval (car rest))))
((msr) (logior (regcode (car rest)) (ash (regcode (cadr rest)) 20)))
((mrs) (ash (regcode (car rest)) 20))
(else (operand2 rest)))))))))))))
p)
; prefixed expressions
; conditionals (eq, ne ...), flag update (s), reg update (!), sp update (ia, db, ...)
(write
'(define (aspr op axpr)
(case op
((eq ne pl mi) (cons (condcode op) (cdr axpr)))
((s) (cons (car axpr) (logior (cdr axpr) (ash #x01 20))))
((!) (cons (car axpr) (logior (cdr axpr) (ash #x02 20))))
((^) (cons (car axpr) (logior (cdr axpr) (ash #x04 20))))
((ia ib da db) (cons (car axpr) (logxor (cdr axpr) (ash (amode4code op) 20))))))
p)
; reformat the arguments-list
(write
'(define (garg op expr)
(case op
((mul tst teq cmp cmn ldm stm) (cons #x00 expr))
((mla) (cons (car (cdddr expr)) expr))
((lsl lsr asr ror) (append expr '(#x0f)))
((mov mvn) (append (list (car expr) #x00) (cdr expr)))
((swp) (list (car expr) (caddr expr) (cadr expr)))
((msr) `(#x0f ,@(cdr expr) ,(car expr)))
((mrs) (list (car expr) #x0f (cadr expr)))
(else expr)))
p)
; assemble branch instructions
; b bl
(write
'(define (asbrnch op lbl)
(if (not (assq lbl *labels*))
(set! *labels* (append *labels* (list (list lbl)))))
(let loop ((n 0) (lbls *labels*))
(if (eq? lbl (caar lbls))
n
(loop (+ n 1) (cdr lbls)))))
p)
; adr
(write
'(define (asadr op Rd lbl)
(if (not (assq lbl *labels*))
(set! *labels* (append *labels* (list (list lbl)))))
(let loop ((n 0) (lbls *labels*))
(if (eq? lbl (caar lbls))
(logior n (logior #xf0000 (ash (regcode Rd) 12)))
(loop (+ n 1) (cdr lbls)))))
p)
; mov mvn tst teq cmp cmn
(write
'(define (operand2 expr)
(let ((op1 (car expr)))
(logior
(ash (if (or (reg? op1) (shift? op1)) 0 #x20) 20)
(if (not (shift? op1))
(if (or (reg? op1) (sym? op1))
(aval op1)
(imm8r op1))
(logior
(aval (cadr expr))
(let ((sval (caddr expr)))
(logior
(ash (aval sval) (if (reg? sval) 8 7))
(ash (logior (shiftcode op1) (if (reg? sval) 1 0)) 4))))))))
p)
; imm8r ror shift is 4-bits (rather than ARM 2-bits)
; (because armpit can't clear just the upper 2-bits within the loop below)
(write
'(define (imm8r val)
(let loop ((n 16) (v val))
(if (zero? (logand #xffffff (ash v -8)))
(logior (ash (remainder n 16) 8) (logand v #xff))
(loop (- n 2) (logand #xfffffff (ash v -4))))))
p)
; lsl lsr asr ror
(write
'(define (amode1 expr)
(logior
(aval (car expr))
(ash (aval (cadr expr)) 12)))
p)
; ldr str ldrb strb
(write
'(define (amode2 expr)
(if (null? expr)
#x00
(let ((op1 (car expr)))
(if (not (or (reg? op1) (shift? op1)))
(aval op1)
(logior
(ash #x20 20)
(if (reg? op1)
(aval op1)
(logior
(ash (aval (caddr expr)) 7)
(logior
(ash (shiftcode op1) 4)
(aval (cadr expr))))))))))
p)
; ldrh strh
(write
'(define (amode3 expr)
(logior
#xb0
(if (null? expr)
(ash #x04 20)
(logior
(aval (car expr))
(if (reg? (car expr)) 0 #x400000)))))
p)
; ldm stm
(write
'(define (reglist expr)
(if (null? expr) #x00
(logior
(ash 1 (aval (car expr)))
(reglist (cdr expr)))))
p)
; mul mla umull umlal smull smlal
(write
'(define (asmul expr)
(logior
#x90
(logior
(aval (car expr))
(ash (aval (cadr expr)) 8))))
p)
; close the file
(close-output-port p)
; Examples:
; ---------
; load the ARMSchembler
(load "assembler")
; assemble and install a copy of built-in function assq
(define bssq
(install
(assemble 'var 2
'(assq
(null? sv2)
(ne caar sv3 sv2)
(ne eq? sv3 sv1)
(ne cdr sv2 sv2)
(ne b assq)
(null? sv2)
(eq set! sv1 #f)
(ne car sv1 sv2)
(set! pc cnt)))))
; assemble and install a copy of built-in function assoc
(define bssoc
(install
(assemble 'var 2 ; sv1 <- key, sv2 <- a-list
'((save sv1 cnt) ; dts <- (key cnt ...)
assoc0
(null? sv2) ; is binding-list null?
(eq set! sv1 #f) ; if so, sv1 <- #f
(eq b assoxt) ; if so, jump to exit with #f
(car sv1 dts) ; sv1 <- key
(save sv2) ; dts <- (binding-list key cnt ...)
(caar sv2 sv2) ; sv2 <- key
(call equal?) ; sv1 <- #t/#f, from (equal? sv1 sv2)
(restore sv2) ; sv2 <- binding-list, dts <- (key cnt ...)
(eq? sv1 #t) ; was a binding found?
(ne cdr sv2 sv2) ; if not, sv2 <- rest-of-binding-list
(ne b assoc0) ; if not, jump to continue searching
(car sv1 sv2) ; sv1 <- winning binding
assoxt
(cdr dts dts) ; dts <- (cnt ...)
(restore cnt) ; cnt <- cnt, dts <- (...)
(set! pc cnt))))) ; return
; perform checks
(define q 1)
(bssq q '((b f) (1 3) (a s))) ; -> (1 3)
(bssoc q '((b f) (1 3) (a s))) ; -> (1 3)
(define z '(3 2))
(bssq z '(((3 2) f) (1 3) (a s))) ; -> #f
(bssoc z '(((3 2) f) (1 3) (a s))) ; -> ((3 2) f)
; define and install atak (Takeuchi function in ArmSchembly)
(define atak
(install
(assemble
'var 3 ; sv1 <- x, sv2 <- y, sv3 <- z
'(takin ; [internal entry]
(cmp sv2 sv1) ; done?
(pl set! sv1 sv3) ; if so, sv1 <- z, result
(pl set! pc cnt) ; if so, return
(save sv1 sv2 sv3 cnt) ; dts <- (x y z cnt ...)
(sub sv1 sv1 4) ; sv1 <- (- x 1)
(call takin) ; sv1 <- xnew = (tak sv1 sv2 sv3)
(snoc! sv3 sv4 dts) ; sv3 <- x, sv4 <- (y z cnt ...)
(snoc! sv4 sv5 sv4) ; sv4 <- y, sv5 <- (z cnt ...)
(car sv2 sv5) ; sv2 <- z
(save sv1) ; dts <- (xnew x y z cnt ...)
(sub sv1 sv4 4) ; sv1 <- (- y 1)
(call takin) ; sv1 <- ynew = (tak sv1 sv2 sv3)
(cdr sv4 dts) ; sv4 <- (x y z cnt ...)
(snoc! sv2 sv4 sv4) ; sv2 <- x, sv4 <- (y z cnt ...)
(snoc! sv3 sv4 sv4) ; sv3 <- y, sv4 <- (z cnt ...)
(car sv4 sv4) ; sv4 <- z
(save sv1) ; dts <- (ynew xnew x y z cnt ...)
(sub sv1 sv4 4) ; sv1 <- (- z 1)
(call takin) ; sv1 <- znew = (tak sv1 sv2 sv3)
(set! sv3 sv1) ; sv3 <- znew
(restore sv1 sv2) ; sv1 <- xnew, sv2 <- ynew, dts <- (x y z cnt ...)
(cdddr dts dts) ; dts <- (cnt ...)
(restore cnt) ; cnt <- cnt, dts <- (...)
(b takin))))) ; jump to compute (tak sv1 sv2 sv3)
; check
(atak 18 12 6) ; -> 7
This example is currently under development (unmodified from prior version).
; Display the current input port (eg. CS-E9302)
(current-input-port) ; -> ((134791168) . #(1 #<primitive> #<primitive> #<primitive> #<primitive>
#t #<primitive> #<primitive> #<primitive>))
; Display the current output port (eg. CS-E9302)
(current-output-port) ; -> ((134791168) . #(2 #<primitive> #<primitive> #<primitive> #<primitive>))
This example is currently under development (unmodified from prior version).
; List Currently Defined Machine Code ISRs (eg. CS-E9302)
_ISR ; -> #(0 0 0 0 #<primitive> #<primitive> 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 #<primitive> 0 #<primitive> 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #<primitive> 0 0 0 0)
; Define timer base address
(define timer0 #x8081000) ; CS-E9302
; List Currently Defined Scheme ISR (for all interrupts)
(read timer0 #x010000) ; -> ()