Standard examples, including GPIO actuation, multitasking, runge-kutta and expert systems, are the same as those for version 00.0137.
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.
; 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 rvb)
'(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) ; -> ()