Program examples for this snapshot are similar to those of the previous snapshot, given here but with modifications outlined in the ChangeLog. For example, logior, logxor, logand, lognot and ash have been modified to bitwise-ior, bitwise-xor, bitwise-and, bitwise-not and bitwise-arithmetic-shift. For multitasking examples, the scheme interrupt service routine is now written to index 0 of the global vector obtained by (_GLV) rather than offset #x10000 of timer0 (i.e. use (vector-set! (_GLV) 0 scheme-isr) instead of (write scheme-isr timer0 #x010000)). I2C examples are not presented because the .bin and .hex files of this distribution do not include the i2c subsystem (i2c examples will be presented in a separate web page once a working i2c interface library module driver is developed and tested -- alternatively, one could re-assemble the ArmPit Scheme source with i2c support enabled and use updated versions of prior examples). Similarly, ARMSchembler (on-chip) and compiler examples remain to be updated at this time (but still work in guile) and will be presented in a separate web page when adapted to this snapshot. A linker (and utility) library example is provided however, to help install off-chip produced code into systems running this ArmPit Scheme snapshot.
The code below examplifies how to modify the Armpit Scheme prompt. It re-defines the (prompt) function to to get a version number, and uses (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 using a bitwise-arithmetic-shift 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 (bitwise-arithmetic-shift (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 except that the size of the vector written to file has been decreased so that it can be read even with a (relatively) small readbuffer.
; 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 140 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.0241. It is updated from prior versions to include 3 of the 4 new boards (the 4th board: STR91X-M, does not have user LEDs) and to use bitwise-x functions for shift and bit-setting/testing operations.
; 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
; Blueboard-1768
; ledport <- gpio1
(begin
(define ledport #x2009C02) ; IO1 port
(define pin-status #x14) ; FIOxPIN register offset
(define pin-set #x18) ; FIOxSET register offset
(define pin-clear #x1C)) ; FIOxCLR 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)
; STM32-DOT-BOARD
; define GPIO ports and offsets
(begin
(define ledport #x4001080) ; GPIO PORT A
(define pin-status #x0C) ; output data register (ODR)
(define pin-set #x10) ; bit set register (BSR)
(define pin-clear #x14)) ; bit reset register (BRR)
; LPC-P1343
; define GPIO ports and offsets
(begin
(define ledport #x5003000) ; GPIO3
(define pin-status #x3FFC)) ; all io mask
; STR-H711
; define GPIO ports and offsets
(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
; Blueboard-1768, STM32-DOT-BOARD
; functions to set and clear a pin on a gpio port
(begin
(define (set-pin port pin)
(write (bitwise-arithmetic-shift #vu8(1 0 0 0) pin) port (- pin-set)))
(define (clear-pin port pin)
(write (bitwise-arithmetic-shift #vu8(1 0 0 0) pin) port (- pin-clear))))
; STR-H711, CS-E9302, TCT-Hammer, LM3S1968-EVB, LM3S6965-EVB, LPC-P1343
; functions to set and clear a pin on a gpio port
(begin
(define (set-pin port pin)
(write (bitwise-copy-bit (read port (- pin-status)) pin 1) port (- pin-status)))
(define (clear-pin port pin)
(write (bitwise-copy-bit (read port (- pin-status)) pin 0) port (- pin-status))))
;------------- Common Code Starts -------------
; function to check the status of a pin on a gpio port
(define (is-set? port pin)
(bitwise-bit-set? (read port (- pin-status)) pin))
; 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 29) ; Blueboard-1768
(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 0) ; LPC-P1343 1st red led
(toggle ledport 1) ; LPC-P1343 2nd red led
(toggle ledport 2) ; LPC-P1343 3rd red led
(toggle ledport 12) ; STM32-H103 green led
(toggle ledport 8) ; STM32-DOT-BOARD 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 thread-ids. The spwaner now allocates unique thread-ids to newly spawned processes and the LED toggler can spawn new threads or just continue with the current thread. The example further includes two of the 4 new boards (those that are not SMALL-MEMORY and that have user LEDs). Also, the scheme ISR (called on timer interrupts) is stored on the (_GLV). 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))
; Blueboard-1768
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x4000400) ; T0 (IR=#x00, TCR=#x04, TC=#x08, PR=#x0C, MCR=#x14, MR0=#x18)
(define timer0-int 1) ; timer0 interrupt number
(define timer-period #x18) ; TnMR0 offset
(define timer-count #x08) ; TnTC offset
(define (stop timer)
(write 0 timer #x04)) ; disable timer via TnTCR
(define (restart timer)
(write 2 timer #x04) ; reset timer via TnTCR
(write 1 timer #x04)) ; enable and start timer via TnTCR
(write 47 timer0 #x0C) ; set timer0 period to 1 us (for 48MHz pclk) via TnPR
(write 1 timer0 #x14) ; set timer0 to generate interrupt and stop on MR0 match via TnMCR
(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, STM32-DOT-BOARD
; define ports and offsets, functions to stop, start timer, and configure timer
(begin
(define timer0 #x4000000) ; timer 2
(define timer0-int 28) ; timer 2 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 and thread-id
(begin
(define *queue* '())
(define *thread-id* 0))
; Set Scheme callback to switch queued thunks on Timer 0 interrupts
; note: 'case may be used instead of 'cond if interrupt (eg. timer0-int)
; is specified directly as a number (eg. 4).
(vector-set!
(_GLV) 0
(lambda (int)
(cond
((= int timer0-int)
(call/cc
(lambda (resume)
(restart timer0)
(if (null? *queue*)
(resume #t)
(let ((p (car *queue*)))
(set! *queue* (append (cdr *queue*) (list (cons *thread-id* resume))))
(set! *thread-id* (car p))
((cdr p) #t))))))
(else
(if (zero? *thread-id*)
(throw 'ISR int)
(write (cons int *thread-id*)))))))
; 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*))
(set! *thread-id* (car p))
(restart timer0)
((cdr p) #t)))))
; function that returns an unsused thread-id for new thread
; (called with timer stopped)
(define (new-tid)
(let* ((tids (cons *thread-id* (map car *queue*)))
(mxti (apply max tids)))
(if (< mxti 536870911)
(+ mxti 1)
(let loop ((n 0))
(if (not (memq n tids))
n
(loop (+ n 1)))))))
; function to spawn a new thunk (task)
(define (spawn thunk)
(stop timer0)
(set! *queue*
(cons
(cons
(new-tid)
(lambda ()
(thunk)
(forget-me)))
*queue*))
(let ((n (caar *queue*)))
(restart timer0)
n))
; simple error handler that de-queues a thread
(define (thread-error-handler e)
(stop timer0)
(write *thread-id*)
(write e)
(restart timer0)
(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))))))
; re-spawning toggler (choose this one or the one above)
(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)
(spawn (toggler port pin 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 29 1000)) ; Blueboard-1768 red 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 8 1000)) ; STM32-DOT-BOARD 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 expands on the above multitasking example by adding interrupt handling for a second timer (timer1). A vector of Scheme ISRs is defined and a simple main Scheme ISR that reads the routine to run from this vector (using the interrupt number as an index) is installed. A thread-switching ISR is then placed at the timer0 interrupt position and a LED toggling function is placed at the timer1 interrupt position. A default ISR is placed in all other positions. This makes it possible to context-switch over various threads while also toggling an LED at a fixed frequency.
; Armpit MultiTasking Example 2 [requires the Multitasking example, above]
; Tested on Blueboard-1768
; define ports and offsets, functions to stop, start timer1, and configure timer1
(begin
(define timer1 #x4000800) ; timer1 base register (IR=#x00, TCR=#x04, TC=#x08, PR=#x0C, MCR=#x14, MR0=#x18)
(define timer1-int 2) ; timer1 interrupt number
(write 47999 timer1 #x0C) ; set timer1 period to 1 ms (for 48MHz pclk) via TnPR
(write 1 timer1 #x14) ; set timer1 to generate interrupt and stop on MR0 match via TnMCR
(stop timer1)
(write 1000 timer1 timer-period)) ; 1 Hz (1000 ms) interrupt frequency
; define the default ISR
(define (default-isr int)
(lambda (int)
(if (zero? *thread-id*)
(throw 'ISR int)
(write (cons int *thread-id*)))))
; define the vector of Scheme ISRs (initiaized to the default ISR)
(define scheme-isr (make-vector 48 default-isr))
; install the main Scheme ISR on the _GLV
(vector-set! (_GLV) 0 (lambda (int) ((vector-ref scheme-isr int) int)))
; set timer0 interrupt to perform context-switching in ISR vector
(vector-set!
scheme-isr timer0-int
(lambda (int)
(call/cc
(lambda (resume)
(restart timer0)
(if (null? *queue*)
(resume #t)
(let ((p (car *queue*)))
(set! *queue* (append (cdr *queue*) (list (cons *thread-id* resume))))
(set! *thread-id* (car p))
((cdr p) #t)))))))
; set timer1 interrupt to toggle LED in ISR vector
(vector-set!
scheme-isr timer1-int
(lambda (int)
(toggle ledport 29)
(restart timer1)))
; start the timers
(begin
(restart timer1)
(restart timer0))
; read the timer counts (to check proper operation, read them a few times)
(cons (read timer0 timer-count) (read timer1 timer-count))
; spawn an arbitrary process (here a toggler)
(spawn (toggler ledport 29 1000)) ; Blueboard-1768 red led
; unset timer1 isr (re-set to default) if desired
(vector-set! scheme-isr timer1-int default-isr)
This example adapts the multitasking example presented above to MCUs with small amounts of RAM and an ARM (rather than Cortex-M3) core (i.e. Tiny2131, LPC-H2103). A Cortex-M3 example follows in the next section.
; Armpit Scheme Multitasking Example [does not need gpio example above]
; FOR SMALL MEMORY MCUs with ARM core (not Cortex-M3)
; Tested on Tiny2131, LPC-H2103
; define useful ports, offsets, and configure timer0
(begin
(define tmr0 #xE000400)
(write 59 tmr0 #x0C)
(write 5 tmr0 #x14)
(write 2 tmr0 #x04)
(write 10000 tmr0 #x18))
; function to add item at tail of list
(define (enqu q thnk)
(if (eq? q '()) (cons thnk q) (cons (car q) (enqu (cdr q) thnk))))
; Initialize the process queue
(define *q* '())
; Set Scheme callback
(vector-set!
(_GLV) 0
(lambda ()
(call/cc
(lambda (rsme)
(write 2 tmr0 #x04)
(write 1 tmr0 #x04)
(if (eq? *q* '()) (rsme #t))
((car *q*) (set! *q* (enqu (cdr *q*) rsme)))))))
; Start timer 0
(write 1 tmr0 #x04)
; read the timer count (a few times to verify operation)
(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))
(begin
(write pin port (if (= 0 (bitwise-and (read port #x00) pin)) #x04 #x0C))
(go tcks))))
(lambda () (go tcks)))
; spawn togglers on MCU board's LEDs (can spawn only a few of these)
(spwn (tglr #xE002801 (ash 1 23) 500)) ; Tiny2131 green led
(spwn (tglr #xE002801 (ash 1 22) 1000)) ; Tiny2131 yellow led
(spwn (tglr #xE002801 (ash 1 21) 2000)) ; Tiny2131 red led
(spwn (tglr #xE002800 (ash 1 26) 1000)) ; LPC-H2103 green led
This example adapts the multitasking example presented above to MCUs with small amounts of RAM and a Cortex-M3 (rather than ARM) core (i.e. LPC-P1343). The SysTick timer is used to drive the multitasking.
; Armpit Scheme Multitasking Example [does not need gpio example above]
; FOR SMALL MEMORY MCUs with Cortex-M3 core (not ARM7TDMI)
; Tested on LPC-P1343
; function to add item at tail of list
(define (enqu q thnk)
(if (eq? q '()) (cons thnk q) (cons (car q) (enqu (cdr q) thnk))))
; Initialize the process queue
(define *q* '())
; Set scheme callback for systick timer
(vector-set!
(_GLV) 0
(lambda (int)
(call/cc
(lambda (rsme)
(write 0 #xe000e00 #x18)
(write 7 #xe000e00 #x10)
(if (eq? *q* '()) (rsme #t))
((car *q*) (set! *q* (enqu (cdr *q*) rsme)))))))
; Start systick timer interrupts
(write 7 #xe000e00 #x10)
; read the timer count
(read #xe000e00 #x18)
; function to spawn a new thunk (for infinite loops only: does not dequeue tasks)
(define (spwn thnk)
(write 0 #xe000e00 #x10)
(set! *q* (cons thnk *q*))
(write 7 #xe000e00 #x10))
; function to toggle a gpio pin every "tcks" tick
(define (tglr port pin tcks)
(define (go n)
(if (> n 0)
(go (- n 1))
(begin
(write (if (= 0 (read port (bitwise-arithmetic-shift pin 2))) #xff #x00)
port (bitwise-arithmetic-shift pin 2))
(go tcks))))
(lambda () (go tcks)))
; spawn togglers on MCU board's LEDs (can spawn only few of these)
(spwn (tglr #x5003000 (ash 1 0) 500)) ; LPC-P1343, 1st red led
(spwn (tglr #x5003000 (ash 1 1) 1000)) ; LPC-P1343, 2nd red led
(spwn (tglr #x5003000 (ash 1 2) 2000)) ; LPC-P1343, 3rd red led
The code below adapts the first library example given in section 7.3 of r6rs to ArmPit Scheme. The modifications are mainly related to the lack of "rename", "only" and "prefix" forms in this snapshot.
; Armpit Scheme Party Library Example
; Tested on SFE-Logomatic V2.0
; build the stack library
(library
(stack)
(export stack:make stack:push! stack:pop! stack:empty!)
(import (rnrs))
(define (stack:make) (list '()))
(define (stack:push! s v) (set-car! s (cons v (car s))))
(define (stack:pop! s)
(let ((v (caar s)))
(set-car! s (cdar s))
v))
(define (stack:empty! s) (set-car! s '())))
; build the balloons library
(library
(balloons)
(export balloon:make balloon:push balloon:pop)
(import (rnrs))
(define (balloon:make w h) (cons w h))
(define (balloon:push b amt)
(cons (- (car b) amt) (+ (cdr b) amt)))
(define (balloon:pop b) (display "Boom! ")
(display (* (car b) (cdr b)))
(newline)))
; build the party library
(library
(party)
(export make push push! make-party pop!)
(import (rnrs) (stack) (balloons))
(define make balloon:make)
(define push balloon:push)
(define push! stack:push!)
(define (make-party)
(let ((s (stack:make)))
(push! s (balloon:make 10 10))
(push! s (balloon:make 12 9))
s))
(define (pop! p)
(balloon:pop (stack:pop! p))))
; list all libraries
(map (lambda (e) (list (vector-ref (vector-ref e 0) 0))) (vector-ref (_GLV) 12))
; import the party library
(import (party))
; have a party (test program)
(begin
(define p (make-party))
(pop! p) ; displays "Boom! 108"
(push! p (push (make 5 5) 1))
(pop! p)) ; displays "Boom! 24"
; de-import all libraries
(import)
; erase the party library from flash (re-list all libs to check)
(erase -1)
; erase all libs from flash (re-list all libs to check)
(erase -536870912)
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 is the library version of the Runge-Kutta example presented above. It is adapted from the library example presented in Appendix D of the r6rs. The code has been modified from the r6rs example to use delay/force as in the r5rs example rather than lambdas (as in the r6rs example) because the former leads to markedly faster execution in the ArmPit Scheme interpreter (the same was observed in guile 1.7.1 for a non-library based implementation).
; Armpit Scheme Runge-Kutta Library Example (R6RS Appendix D)
; Tested on SFE-Logomatic V2.0
; build the runge-kutta library
(library
(runge-kutta)
(export integrate-system head tail)
(import)
;; library body
(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))))
(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)
;; y is a system state
(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)))))
; list all libraries (as a check)
(map (lambda (e) (list (vector-ref (vector-ref e 0) 0))) (vector-ref (_GLV) 12))
; import the runge-kutta library
(import (runge-kutta))
(define damped-oscillator
(lambda (R L C)
(lambda (state)
(let ((Vc (vector-ref state 0))
(Il (vector-ref state 1)))
(vector (- 0 (+ (/ Vc (* R C)) (/ Il 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.0241. The examples are similar to those of previous snapshots but "ash" as been replaced by "bitwise-arithmetic-shift". 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 SFE-Logomatic V2.0
; 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 (bitwise-arithmetic-shift n -1)) (j j))
(if (and (>= m 2) (>= j m))
(loop2 (bitwise-arithmetic-shift 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 versions from 00.0098 onwards except for the addition of the fact (female jill) in the fact-base (performed at 00.0186) and the user-space definition of the "defined?" function (performed at 00.0215). The latter function has however been re-written in a form compatible with inclusion in a library, for generality (it is included in the linker-and-utility library example given later).
; Armpit Scheme Expert System Example
; Tested on SFE-Logomatic V2.0
; utility function to check whether a symbol is defined
(define (defined? sym)
(let ((is-defined #f)
(old_catch (eval '_catch (interaction-environment))))
(call/cc
(lambda (inner_catch)
(eval `(begin
(set! _catch ,inner_catch)
,sym)
(interaction-environment))
(set! is-defined #t)))
(eval `(set! _catch ,old_catch) (interaction-environment))
is-defined))
; 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 example presents a library containing useful code to deal with libraries, verify that a symbol is defined, copy a portion of a bytevector into another and link (and install) ARMSchembled code vectors. It is partly an update of functions defined in prior snapshots that are adapted here to the present release, or adapted to functioning within the closed environment confines of a library (eg. library functions are closed over that library's environment, not the user environment). A note of caution: the library form below contains just below 2KB of characters which is the size of the readbuffer on several MCUs (cf. the table of read buffer sizes at the end of the ChangeLog), thus, it may not be advisable to, say, add more comments to it, before pasting it into a running system.
; Armpit Scheme Linker and Utility Library Example
; tested on SFE-Logomatic V2.0
; build the linker/utility library
(library
(linker)
(export defined? libs erase-libs bytevector-copy!
link lib-link unpack-to-lib unpack-above-heap)
(import)
;; function to list all libs
(define (libs)
(map (lambda (e) (list (vector-ref (vector-ref e 0) 0))) (vector-ref (_GLV) 12)))
;; function to erase all libs
(define (erase-libs)
(erase -536870912))
(define (defined? sym)
(let ((is-defined #f)
(old_catch (eval '_catch (interaction-environment))))
(call/cc
(lambda (inner_catch)
(eval `(begin
(set! _catch ,inner_catch)
,sym)
(interaction-environment))
(set! is-defined #t)))
(eval `(set! _catch ,old_catch) (interaction-environment))
is-defined))
(define (bytevector-copy! src sst tgt tst k)
(if (> sst tst)
(let loop ((n 0))
(if (>= n k) #t
(begin
(bytevector-u8-set! tgt (+ tst n) (bytevector-u8-ref src (+ sst n)))
(loop (+ n 1)))))
(let loop ((n (- k 1)))
(if (< n 0) #t
(begin
(bytevector-u8-set! tgt (+ tst n) (bytevector-u8-ref src (+ sst n)))
(loop (- n 1)))))))
(define (link cvec)
(let ((code (vector-ref cvec 0)))
;; link the symbols used by the compiled code
(map
(lambda (lvar)
(let ((n (car lvar))
(s (string->symbol (cdr (assq (cdr lvar) (vector-ref cvec 2))))))
(bytevector-u16-native-set! code n (bitwise-ior (bitwise-arithmetic-shift s 2) #x0f)) ; synt/var
(bytevector-u16-native-set! code (+ n 2) (bitwise-arithmetic-shift s -14))))
(vector-ref cvec 1))
;; link the long jumps
(map
(lambda (ljmp)
(bytevector-copy!
(address-of (eval (string->symbol (cdr ljmp)) (interaction-environment)) 4) 0 code (car ljmp) 4))
(vector-ref cvec 3))
code))
(define (unpack-to-lib obj)
(if (vector? obj)
(unpack (link obj) -1)
(unpack obj -1)))
(define (unpack-above-heap obj)
(if (vector? obj)
(unpack (link obj) 1)
(unpack obj 1)))
(define (lib-link cvec)
(unpack (link cvec) -1))
) ;; end of library
; import the linker/utility library
(import (linker))
; list all libraries
(libs)
; perform a test
(defined? 'link) ; -> #t
; perform another test
(defined? 'blah-blah) ; -> #f
; perform a third test
(begin
(define blah-blah "Hello!")
(defined? 'blah-blah)) ; -> #t