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). Armpit Scheme files are stored in FLASH memory, either on-chip or off-chip depending on the MCU board. A vector of 500 elements is written to file to check that FLASH page boundaries are properly treated (a more thorough check would verify all values in the vector). The example is otherwise the same as that for snapshots 00.0137 and 00.0152.
; Armpit Scheme File Example
; tested on Tiny2131, LPC-H2103, Tiny2138, SFE-Logomatic, LPC-H2148,
; LCDDemo-2158, Tiny2106, LPC-H2214, STR-H711, SAM7-H256,
; LPC-H2888, CS-E9302, STM32-H103, LM3S1968-EVB
; 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.0160. The code starts with MCU-specific port and offset definitions. This is followed by semi-common code that defines the set-pin and clear-pin functions for MCUs that have separate set and clear registers and for those that have a common set-and-clear register. Code for testing if a pin is set or not is common to all MCUs as is the function toggle. They are followed by calls to toggle that will turn LEDs on and off on the target boards. Note that the LED pin ports have been powered-up and the LED pin functions have have been set to GPIO output during the Armpit Scheme hardware-initialization cycle (before the armpit> prompt gets displayed). The example is the same as that for snapshots 00.0137 and 00.0152 except for the addition of new boards (SFE-Logomatic V2.0, LPC2478-STK, TCT-Hammer, LM3S6965-EVB). The 5th new board (IDM-L35, LM3S1958) would work like the LM3S1968-EVB but doe not have user LEDs for the user to toggle (it has a 3.5 inch LCD though).
; Armpit Scheme GPIO Example
; tested on Tiny2131, LPC-H2103, Tiny2138, SFE-Logomatic, LPC-H2148,
; LCDDemo-2158, Tiny2106, LPC-H2214, SAM7-H256, STR-H711
; LPC-H2888, CS-E9302, STM32-H103, LM3S1968-EVB
; 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
;------------- 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
; 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
This example is the same as in snapshots 00.0137 and 00.0152 except that the interrupt number of the timer interrupt is added in the variables and in the scheme interrupt routine. It also adds new boards. Timer ports, start/stop functions and configurations are given as MCU-specific blocks at the beginning of the code. This is followed by the program proper that is common to all MCUs. This example uses the LED definitions from the GPIO example above.
; Armpit MultiTasking Example [requires the GPIO example, above]
; Tested on Tiny2138, SFE-Logomatic, LPC-H2148, LCDDemo-2158, Tiny2106,
; LPC-H2214, SAM7-H256, STR-H711, LPC-H2888, CS-E9302,
; STM32-H103, LM3S1968-EVB
; 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))
;------------- 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)
(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 (write 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 spawn a new thunk (task)
(define (spawn thunk)
(stop timer0)
(set! *queue*
(cons
(lambda ()
(thunk)
((car *queue*) (set! *queue* (cdr *queue*))))
*queue*))
(restart timer0))
; function to toggle a gpio pin every "ticks" countdown ticks
(define (toggler port pin ticks)
(lambda ()
(let go ((n ticks))
(if (> n 0)
(go (- n 1))
(begin
(toggle port pin)
(go ticks))))))
;------------- 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
This example adapts the multitasking code given above to MCUs with a small amount of RAM (eg. 8kB). It does not require the GPIO example. The optional interrupt number in the Scheme callback is not used. This example is the same as in snapshots 00.0137 and 00.0152.
; Armpit Scheme Multitasking Example [does not need gpio example above]
; FOR SMALL MEMORY MCUs
; Tested on Tiny2131, LPC-H2103
; define useful ports and configure timer0
(begin
(define tmr0 #xE000400)
(define gio0 #xE002800)
(define gio1 #xE002801)
(write 59 tmr0 #x0C)
(write 5 tmr0 #x14)
(write 2 tmr0 #x04)
(write 10000 tmr0 #x18))
; Initialize the process queue
(define *q* '())
; Set timer 0 callback and set interrupts to every 10ms (10000 microsec)
(write
(lambda ()
(call/cc
(lambda (rsme)
(write 2 tmr0 #x04)
(write 1 tmr0 #x04)
(if (null? *q*) (rsme #t))
((car *q*) (set! *q* (append (cdr *q*) (cons rsme '())))))))
tmr0 #x010000)
; Start timer 0
(write 1 tmr0 #x04)
; read the timer count
(read tmr0 #x08)
; function to spawn a new thunk (for infinite loops only: does not dequeue tasks)
(define (spwn thnk)
(write 0 tmr0 #x04)
(set! *q* (cons thnk *q*))
(write 1 tmr0 #x04))
; function to toggle a gpio pin every "tcks" tick
(define (tglr port pin tcks)
(define (go n)
(if (> n 0)
(go (- n 1))
((lambda ()
(write pin port
(if (= 0 (logand (read port #x00) pin)) #x04 #x0C))
(go tcks)))))
(lambda () (go tcks)))
; spawn togglers on MCU board's LEDs
(spwn (tglr gio1 (ash 1 23) 500)) ; Tiny2131 green led
(spwn (tglr gio1 (ash 1 22) 1000)) ; Tiny2131 yellow led
(spwn (tglr gio1 (ash 1 21) 2000)) ; Tiny2131 red led
(spwn (tglr gio0 (ash 1 26) 1000)) ; LPC-H2103 green led
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
(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)
This Expert System example is the same as that of version from 00.0098 onwards.
; Armpit Scheme Expert System Example
; Tested on Tiny2106, LPC-H2214, SAM7-H256, STR-H711, LPC-H2888,
; CS-E9302, LM3S1968-EVB
; 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 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 everything that can be infered
This is an example of how to use the 8-digit LCD on the Future Designs LCDDemo-LPC2158 MCU board. The I2C subsystem in this version of Armpit Scheme is not fully functional and does not always recover nicely from communication errors. This example mainly functions properly but may also hang. The I2C subsystem will be re-instated in a future version of the code.
; 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
The five code examples below illustrate how to use the function (install ...) to store Scheme objects in RAM above the heap. This function takes a vector of 16-bit integers (binary half-words) representing the object to install as input and returns the address at which the object was installed as output. Since an address is returned, the stored object will be considered to be a compound object (list, string, vector, primitive) by Armpit Scheme (an immediate can be stored but has to be referred to as the car of the returned address). The output address is to be used as input to Scheme's (define ...) function. Each pair of 16-bit half-words in the input vector corresponds to one 32-bit Armpit Scheme item (an integer, a character, an address ...) and they are stored in the vector in little-endian format. The first two half-words in the vector are used to indicate whether a function (primitive) object should be treated as variable or syntax (input arguments evaluated or not) and are set to 0 for other object types (non-primitives). The remaining half-words (from index 2 on) represent the object itself which may start with a tag (for strings, vectors and primitives) or not (for other objects). If the object to be stored is a list of cons cells, the cells' cdrs in the vector will each need to hold the address of the next list cell and this address is unknown untill (install ...) is called. To circumvent this problem, the vector can store offset (relative) addresses when needed and they are indicated to the function (install ...) by placing a 1 in bit 29 of the least significant half-word of the offset address item stored in the vector.
; Example 1: Storing a single number
; ----------------------------------
; function to split an Armpit Scheme 30-bit number
; into 2 halfwords, with the appropriate 2-bit tag (for integer or float)
; in the lsb of the lower halfword
(define (split-num num)
(cons
(logand #xffff (logior (ash num 2) (if (integer? 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 #x4B in bits 7-0) into 2 halfwords
(define (vector-tag vlen)
(cons
(logand #xffff (logior (ash vlen 8) #x4b))
(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 #x53 in bits 7-0) into 2 halfwords
(define (string-tag slen)
(cons
(logand #xffff (logior (ash slen 8) #x53))
(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 '#(#x27 0 #xEB 0 #x401F #xE3A0 #xF001 #xE1A0)) ; ARM
(define vcod '#(#x27 0 #xEB 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 Scheme flavor (ArmSchembly). It is written in Armpit Scheme and runs on-chip provided that sufficient RAM is available (64kB for very small assemblies). The assembler is sufficient for simple ARM functions but not for Thumb2 where it is missing 16-bit instructions (such as: set pc, cnt -> #x468F). An example application to the assembly and installation above the heap of copies of Armpit Scheme's assq and assoc functions is given at the end of the code (ARM only, not Thumb2). ArmSchembly is a prefixed language in that suffixed ARM assembly expressions, such as ldmia ... or bne ..., are expressed in prefixed form instead, as (ia ldm ...) and (ne b ...), respectively. Similarly, an expression with shift, such as: add sv1, sv3, sv2, lsl #4 would be expressed as: (add sv1 sv3 lsl sv2 4), where lsl is placed in "prefix" location relative to the shifted register. The code is currently both preliminary and partial, and therefore it is highly adviseable to compare the output of the assemble function below (a vector of halfwords) with the output of an independent ARM assembler, such as gas (the GNU ARM assembler), prior to installing and testing the resulting user-defined primitive.
This code has been updated from version 00.0152 to account for modifications in the built-in _cons and _list functions (reflected here in the function mexpand).
; define instructions, macros ...
(begin
(define ARM #t)
(define *labels* '())
(define *syms*
'((#null . #x0f) (#t . #x1f) (#f . #x2f) (#c0 . #x3f) (#i0 . #x01) (#f0 . #x02)))
(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)))
(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 . #x11) (str . #x58) (ldr . #x59)
(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 *T2ops*
'(
(and . #x00) (eor . #x08) (sub . #x1a) (rsb . #x1c)
(add . #x10) (adc . #x14) (sbc . #x16)
(orr . #x04) (orn . #x06) (bic . #x02)
(mov . #x04) (mvn . #x06)
(lsl . #x1a0) (lsr . #x1a2) (asr . #x1a4) (ror . #x1a6)
(tst . #x01) (teq . #x09) (cmp . #x1b) (cmn . #x11)
(str . #x184) (ldr . #x185) (strb . #x188) (ldrb . #x189)
(stm . #x88) (ldm . #x89)
(mul . #x1b0) (mla . #x1b0) (umull . #x1ba) (umlal . #x1be) (smull . #x1b8) (smlal . #x1bc)
(swi . #xf0) (b . #x100) (bl . #x100)
(clz . #x1ab)
(sdiv . #x1b9) (udiv . #x1bb)))
(define *T2macros*
'(cons list save restore raw->int int->raw raw->chr chr->raw snoc!
call set! eq? null? car cdr caar cadr cdar cddr set-car! set-cdr!))
(define *ARMmacros*
(append *T2macros* '(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))))
; define utility functions
(begin
(define (sym? sym) (assq sym *syms*))
(define (symcode sym) (code sym *syms* #x00))
(define (macro? expr) (memq (car expr) (if ARM *ARMmacros* *T2macros*)))
(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 (if ARM *ARMops* *T2ops*) #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)))))
; main assembly function
(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) #x27 #x17))
(vector-set! vcod 1 0)
(vector-set! vcod 2 (logior (ash narg 8) #xEB))
(vector-set! vcod 3 0)
(let loop ((n 4) (code code1))
(if (null? code) vcod
(begin
(vector-set! vcod n (logand #xffff (cdar code)))
(vector-set!
vcod (+ n 1)
(logior
(ash (caar code) 12)
(logand #x0fff (ash (cdar code) -16))))
(loop (+ n 2) (cdr code)))))))
; inline jump target addresses
(define (asjt elist)
(let loop ((n 0) (code (asln elist)))
(if (null? code) code
(cons
(let ((opc (logand (cdar code) (if ARM #xf000000 #x1c3ff800))))
(if (or (and ARM (or (eq? opc #xa000000) (eq? opc #xb000000)))
(and (not ARM)
(or (eq? opc #x1000a800) (eq? opc #x1000b800) (eq? opc #x1000f800))))
(let ((adr
(cdr (list-ref *labels* (logand (cdar code) (if ARM #xffffff #x7ff))))))
(if (null? adr)
(car code)
(cons
(caar code)
(logior
opc
(if ARM
(logand (- adr 2 n) #xffffff)
(logior
(logand (- adr 2 n) #x7ff)
(logxor
(if (zero? (logand opc #x1000)) #x3c00000 #x00)
(ash (logand (- adr 2 n) #x3ff800) 5))))))))
(car code)))
(loop (+ n 1) (cdr code))))))
; assign line numbers to labels in *labels* (long jumps are placed at end)
(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 (if ARM #x51FF004 #xF85FF004))
(cons
(logand #x0f (ash (eval (caar labels)) -26))
(logand #x0fffffff (+ (ash (eval (caar labels)) 2) 4)))))
(cdr labels)))
(loop n code (cdr labels)))))))
; expand macros, find labels (store them in *labels*), assemble T2's if-then and svc/swi
(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))
((macro? expr) (aslm (mexpand expr)))
((and (cond? (car expr)) (macro? (cdr expr)))
(aslm (addprefix (car expr) (mexpand (cdr expr)))))
((eq? 'it (car expr))
(if ARM '() (list (cons #xb (asit (cdr expr))))))
((and (not ARM) (eq? 'swi (car expr)))
(list (cons #xb (logior #xf00df00 (cadr expr)))))
(else (list (as1 expr)))))
(aslm (cdr elist)))))
; assemble T2 it (if-then)
(define (asit expr)
(logior
#xf00bf00
(logior
(ash (condcode (car expr)) 4)
(let loop ((n 3) (cnd1 (logand #x01 (condcode (car expr)))) (mask 0) (xyz (cdr expr)))
(if (null? xyz)
(logior mask (ash 1 n))
(loop (- n 1) cnd1
(logior mask (ash (if (eq? (car xyz) '#t) cnd1 (- 1 cnd1)) n)) (cdr xyz)))))))
; add conditional prefix to expanded macros
; note: do not add prefix to save, cons and list (due to internal bl)
(define (addprefix prefix elist)
(if (null? elist) elist
(cons
(cons prefix (car elist))
(addprefix prefix (cdr elist)))))
; expand a macro
(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) (list '(bl _save) `(set-car! dts ,(cadr expr))))
((restore) (list `(ia ldm dts ,(cadr expr) dts)))
((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))))
((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)))
((set-car!) (list `(str ,(caddr expr) ,(cadr expr))))
((set-cdr!) (list `(str ,(caddr expr) ,(cadr expr) 4)))
((lsl lsr asr ror)
(list `(mov ,(cadr expr) ,(car expr) ,@(cddr expr))))
(else #f)))
; 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
; clz sdiv udiv
(define (as1 expr)
(let ((op (car expr)))
(if (memq op '(eq ne pl mi s ! ia ib da db))
(aspr op (as1 (cdr expr)))
(if (and (not ARM) (eq? op 'swi))
(cons #xd (logior #xf00bf00 (ash (aval (cadr expr)) 16)))
(cons
#xe
(logior
(ash (opcode op) 20)
(case op
((swi) (aval (cadr expr)))
((b bl) (asbrnch op (cadr expr)))
(else
(let* ((args (garg op expr))
(Rd (car args))
(Rm (cadr args))
(rest (cddr args)))
(logior
(ash (aval Rd) (if ARM 12 8))
(logior
(ash (aval Rm) 16)
(case op
((lsl lsr asr ror clz) (amode1 op rest))
((ldr str ldrb strb) (amode2 expr rest))
((ldrh strh) (amode3 rest))
((ldm stm) (reglist rest))
((mul mla umull umlal smull smlal sdiv udiv) (asmul op rest))
((swp) (logior #x90 (aval (car rest))))
(else (operand2 rest))))))))))))))
; prefixed expressions
; conditionals (eq, ne ...), flag update (s), reg update (!), sp update (ia, db, ...)
(define (aspr op axpr)
(case op
((eq ne pl mi)
(if ARM
(cons (condcode op) (cdr axpr))
(if (eq? (logand (cdr axpr) #x1ff0ff00) #x1000b800)
(cons (car axpr) (logior (logxor (cdr axpr) #x1000) (ash (condcode op) 22)))
axpr)))
((s) (cons (car axpr) (logior (cdr axpr) (ash 1 20))))
((!) (cons (car axpr) (logior (cdr axpr) (ash #x02 20))))
((ia ib da db) (cons (car axpr) (logxor (cdr axpr) (ash (amode4code op) 20))))))
; reformat the arguments-list
(define (garg op expr)
(case op
((mul sdiv udiv)
(if ARM (cons #x00 (cdr expr)) (append (cdr expr) '(#x0f))))
((mla)
(if ARM (cons (car (cddddr expr)) (cdr expr)) (cdr expr)))
((lsl lsr asr ror) (append (cdr expr) '(#x0f)))
((smull umull smlal umlal)
(if ARM (cdr expr) (append (cddr expr) (list (cadr expr)))))
((tst teq cmp cmn) (cons (if ARM #x00 #x0f) (cdr expr)))
((ldm stm) (cons #x00 (cdr expr)))
((mov mvn) (append (list (cadr expr) (if ARM #x00 #xf)) (cddr expr)))
((swp) (list (cadr expr) (cadddr expr) (caddr expr)))
((ldr str) (if ARM (cdr expr) (cons #x00 (cddr expr))))
((clz) (append (cdr expr) (list (caddr expr) '#x0f)))
(else (cdr expr))))
; assemble branch instructions
; b bl
(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))
(if ARM n (logior (cdr (assq op '((b . #xb800) (bl . #xf800)))) n))
(loop (+ n 1) (cdr lbls)))))
; mov mvn tst teq cmp cmn
(define (operand2 expr)
(let ((op1 (car expr)))
(logior
(ash (if (or (reg? op1) (shift? op1)) (if ARM 0 #xa0) (if ARM #x20 #x100)) 20)
(if (not (shift? op1))
(aval op1)
(logior
(aval (cadr expr))
(let* ((shft (caddr expr))
(sval (if ARM shft (logior (logand shft #x3) (logand #x3c0 (ash shft 4))))))
(logior
(ash (aval sval) (if (reg? sval) 8 (if ARM 7 6)))
(ash (logior (shiftcode op1) (if (reg? sval) 1 0)) (if ARM 4 3)))))))))
; lsl lsr asr ror clz
(define (amode1 op expr)
(logior
(if (eq? op 'clz) #x80 0)
(logior
(aval (car expr))
(ash (aval (cadr expr)) 12))))
; ldr str ldrb strb
(define (amode2 prev expr)
(logior
(if ARM 0 (ash (aval (cadr prev)) 12))
(if (null? expr)
(if ARM #x00 #x800000)
(let ((op1 (car expr)))
(if (not (or (reg? op1) (shift? op1)))
(logior (if ARM #x00 #x800000) (aval op1))
(logior
(ash (if ARM #x20 0) 20)
(if (reg? op1)
(aval op1)
(logior
(ash (aval (caddr expr)) (if ARM 7 4))
(logior
(ash (shiftcode op1) (if ARM 4 8))
(aval (cadr expr)))))))))))
; ldrh strh
(define (amode3 expr)
(logior
#xb0
(if (null? expr)
(ash #x04 20)
(logior
(aval (car expr))
(if (reg? (car expr)) 0 (ash #x04 20))))))
; ldm stm
(define (reglist expr)
(if (null? expr) #x00
(logior
(ash 1 (aval (car expr)))
(reglist (cdr expr)))))
; mul mla umull umlal smull smlal
; sdiv, udiv
(define (asmul op expr)
(logior
(if ARM #x90 #x00)
(logior
(aval (car expr))
(logior
(if (memq op '(udiv sdiv)) #xf0 #x00)
(ash (aval (cadr expr)) (if ARM 8 12))))))
; Examples:
; ---------
; assemble and install a copy of built-in function assq
(define bssq
(install
(assemble 'var 2
'(assq
(null? sv2)
(it ne #t #t)
(ne caar sv3 sv2)
(ne eq? sv3 sv1)
(it ne)
(ne cdr sv2 sv2)
(ne b assq)
(set! sv3 sv1)
(null? sv2)
(it eq #f)
(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
'((save cnt) ; dts <- (cnt ...)
(save sv1) ; dts <- (key cnt ...)
assoc0
(null? sv2) ; is binding-list null?
(it eq)
(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?
(it ne)
(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)
(bssoc q '((b f) (1 3) (a s))) ; -> (1 3)
(define z '(3 2))
(bssoc z '(((3 2) f) (1 3) (a s))) ; -> ((3 2) f)
This example is currently under development.
; 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.
; 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) ; -> ()