commit 20c10fa27b8f75505ec853c1a95260b8136de540 Spenser Truex <truex@equwal.com> 2026-10-04 09:49:46 +0000 R7RS items 4 and 5: macros, call/cc, exceptions, raisable errors
NOTES.md | 35 +++++++-- README.md | 8 +- conformance.txt | 2 +- host.lisp | 12 +-- lisp.fs | 60 ++++++++++++-- prelude.scm | 208 ++++++++++++++++++++++++++++++++++++++++++++++++- r7rs-tests.scm | 65 ++++++++++++++++ tests/r7rs/results.txt | 105 +++++++++++++------------ tests/r7rs/shim.scm | 4 +- tests/r7rs/skip.scm | 27 ------- 10 files changed, 423 insertions(+), 103 deletions(-)
diff --git a/NOTES.md b/NOTES.md index c562a8f..255c378 100644 --- a/NOTES.md +++ b/NOTES.md @@ -114,14 +114,16 @@ What this design takes from them: | 1-2 assembler | `asm-test.lisp`: every encoder form vs `arm-none-eabi-as` (incl. FPv4-SP), plus repeated label references | 105/105 | | 3 kernel | `forth-tests.txt` via `host.lisp ktest`, fresh boot | 71/71 | | 4 Scheme | chibi-scheme's R7RS suite, `tests/r7rs/`, via `host.lisp suite` | see `tests/r7rs/results.txt` | -| 4 Scheme | our own regression suite `r7rs-tests.scm` via `host.lisp test` | 317/317 | +| 4 Scheme | our own regression suite `r7rs-tests.scm` via `host.lisp test` | 380/380 | - Kernel image: about 10.4 KiB of flash, 197 words (FPU words `f+ f- f* f/ s>f f>s fsqrt f< f=`). - RAM after `lisp.fs`, `prims.lisp` and `prelude.scm` load: - - cons heap 48 KiB (6143 cells); - - blob heap 16 KiB; - - symbol names 4 KiB; - - 23.5 KiB free (`unused` = 24112). + - cons heap 60 KiB (7679 cells); + - blob heap 12 KiB; + - symbol names 10 KiB; + - 5.9 KiB of dictionary free (`unused` = 5928). + The prelude grew with item 4. At 48 KiB of heap, the 20000-iteration tail-call test spent + most of its time in GC. - The kernel prints `Redefine NAME.` when a definition shadows an existing word, and `host.lisp` stops the load on it. A list-length word named `llen` once silently captured the reader's `llen` variable in every later word. @@ -146,7 +148,9 @@ What this design takes from them: answering, every later test counts as failed. - First run on the own stack: 244 passed, 78 failed, 810 skipped, 1132 total. After item 1 (numbers): 302 passed, 119 failed, 711 skipped. After item 2 (characters, strings, vectors, bytevectors): 486 passed, 123 failed, 523 skipped. After item 3 (sqrt, - rounding): 500 passed, 109 failed, 523 skipped. It found two + rounding): 500 passed, 109 failed, 523 skipped. After items 4 and 5 (macros, call/cc, + dynamic-wind, exceptions, raisable primitive errors, values, promises, parameters, records): + 603 passed, 140 failed, 389 skipped. It found two bugs, now fixed and covered by local regression tests: `list?` looped on a circular list, and `case` lacked `=>`. @@ -173,8 +177,23 @@ Our own suite below stays local: a reported sieve program, string cases and thos The GC compacts live blobs. Missing from the string library: `string-fill!`, `string-copy!`, case conversion of whole strings, and `-ci` string comparisons. - `sqrt` is exact for exact squares (`(sqrt 1/4)` is `1/2`) and inexact otherwise. A negative argument gives `+nan.0`, because there are no complex numbers. `exact-integer-sqrt` returns a list `(s r)` until multiple values exist. `floor`, `ceiling`, `truncate` and `round` (half to even) handle rationals and floats. No `exp`, `log` or trigonometry yet. -- No `define-syntax`/`syntax-rules`, `quasiquote`, `delay`/`force`, `call/cc`, `dynamic-wind`, `values`, exceptions, `guard`, parameters, records, libraries (`import`), ports beyond the console. -- Errors print a message and return to the prompt; they are not raisable objects. +- Macros: `define-syntax`, `let-syntax`, `letrec-syntax` and `syntax-rules` (with literals, `_`, + nested ellipses, custom ellipsis, `(... ...)`) are **not hygienic**. A template symbol means + whatever it means where the expansion lands. `quasiquote`, `delay`, `delay-force`, `guard`, + `parameterize`, `define-record-type`, `case-lambda`, `let-values` and `define-values` are + procedural macros in `prelude.scm`. `let-values` binds left to right, like `let*-values`. +- `call/cc` is **escape-only**. A continuation works while its `call/cc` is still active. + Calling it later is an error. There is no re-entry and no generators. `dynamic-wind` runs the + *after* thunks when an escape leaves its extent. +- Exceptions: `raise`, `raise-continuable`, `with-exception-handler`, `guard`, `error` and + error objects. Errors from primitives (`car` of a non-pair, a vector index out of range, an + unbound variable, ...) raise error objects when a handler is installed. Uncaught errors print + their message and irritants and return to the prompt. A `guard` with no matching clause + re-raises in the dynamic environment of the `guard`, not of the original `raise`. `too deep` + and `out of memory` are never raisable, because recovering needs the stack or heap they + report as exhausted. +- Symbols are never garbage collected. Their names share a 10 KiB buffer. +- No libraries (`import`) and no ports beyond the console yet. - Primitives check argument types but not arity; extra arguments are ignored. - Recursion depth is bounded by the 4 KiB stacks: non-tail recursion raises `too deep` between 150 and 200 levels (measured with `(d 150)` and `(d 200)`). - `define` returns the defined symbol (R7RS leaves the value unspecified). diff --git a/README.md b/README.md index 6abd36a..340e7b7 100644 --- a/README.md +++ b/README.md @@ -52,8 +52,8 @@ Needs SBCL, `qemu-system-arm`, `arm-none-eabi-as`/`objcopy` (for the assembler t ## Test counts (STM32F446 target, QEMU) -- Our regression suite: see `conformance.txt` (317/317 at publication) -- chibi-scheme R7RS suite: see `tests/r7rs/results.txt` (500 passed, 109 failed, 523 skipped +- Our regression suite: see `conformance.txt` (380/380 at publication) +- chibi-scheme R7RS suite: see `tests/r7rs/results.txt` (603 passed, 140 failed, 389 skipped of 1132 at publication; every skip names its reason) ## Limits @@ -61,8 +61,8 @@ Needs SBCL, `qemu-system-arm`, `arm-none-eabi-as`/`objcopy` (for the assembler t - Fixnums are 31-bit; overflow is an error, and there are no bignums. - Inexact reals are IEEE single precision (the M4F FPU); R7RS expects double. - Characters are bytes; there is no Unicode. -- No `define-syntax`, `call/cc`, `dynamic-wind`, exceptions, parameters, records, - libraries or ports yet. `NOTES.md` lists every deviation. +- `syntax-rules` is not hygienic, and `call/cc` is escape-only. There are no libraries and no + ports beyond the console yet. `NOTES.md` lists every deviation. ## Influences diff --git a/conformance.txt b/conformance.txt index a5ff538..39e5184 100644 --- a/conformance.txt +++ b/conformance.txt @@ -1 +1 @@ -conformance: 317 passed, 0 failed, 317 total +conformance: 380 passed, 0 failed, 380 total diff --git a/host.lisp b/host.lisp index ac116bc..ad3fc95 100644 --- a/host.lisp +++ b/host.lisp @@ -156,7 +156,7 @@ followed by a space or the end of the line. A backslash inside code (e.g. in .\" (show reply) (string-trim '(#\Newline #\Space) (subseq reply 0 (- (length reply) 2))))) -(defun lisp-eval (expr &key (timeout 10)) +(defun lisp-eval (expr &key (timeout 60)) "Send EXPR to the target Lisp REPL. Return the printed result." (send expr) (lisp-prompt :timeout timeout)) @@ -188,9 +188,11 @@ followed by a space or the end of the line. A backslash inside code (e.g. in .\" (send "lisp") (lisp-prompt) (let ((*log* nil)) - (dolist (l (file-lines "prelude.scm")) - (let ((r (lisp-eval l))) - (when (search "error" r) (error "prelude: ~a gave ~a" l r)))))) + (dolist (form (split-forms (with-open-file (s (here "prelude.scm")) + (let ((str (make-string (file-length s)))) (subseq str 0 (read-sequence str s)))))) + (let* ((l (one-line form)) (r (lisp-eval l :timeout 30))) + (when (or (search "unbound variable" r) (search "not a " r) (search "too deep" r) (search "out of memory" r)) + (error "prelude: ~a gave ~a" (subseq l 0 (min 80 (length l))) r)))))) (defun ktest (name) "Layer 3: run NAME (lines of INPUT ==> OUTPUT) on a freshly booted kernel. Return failures." @@ -221,7 +223,7 @@ followed by a space or the end of the line. A backslash inside code (e.g. in .\" (let* ((k (search "==>" l)) (e (string-trim " " (subseq l 0 k))) (want (if k (string-trim " " (subseq l (+ k 3))) nil)) - (got (lisp-eval e))) + (got (lisp-eval e :timeout 60))) (if (or (null want) (string= got want)) (incf pass) (progn (incf fail) (format t "FAIL ~a => ~a (want ~a)~%" e got want))))) diff --git a/lisp.fs b/lisp.fs index 30a8e5d..002f5ca 100644 --- a/lisp.fs +++ b/lisp.fs @@ -14,18 +14,18 @@ \ GC: mark-sweep, run when cons finds the free list empty. Roots: the symbol list, plus \ every word on the data and return stacks that looks like a heap reference (conservative). -49152 constant heapsize +61440 constant heapsize heapsize buffer: heap heapsize 64 / buffer: marks \ one bit per 8-byte cell -16384 constant bsize \ blob heap for strings, vectors, bytevectors +12288 constant bsize \ blob heap for strings, vectors, bytevectors bsize buffer: bheap 0 variable btop -4096 constant namesize +10240 constant namesize namesize buffer: names 64 buffer: tok 128 cells buffer: prims 32 cells buffer: forms \ special-form handlers -512 constant linesize \ one REPL line; an expression may span lines +2048 constant linesize \ one REPL line; an expression may span lines linesize buffer: lbuf 0 variable lpos 0 variable llen 0 variable free 0 variable ntop 0 variable syms 0 variable nprims 0 variable nforms @@ -51,14 +51,20 @@ linesize buffer: lbuf : car! ( v p -- ) addr ! ; : cdr! ( v p -- ) addr cell+ ! ; 36 constant strtag 44 constant vectag 68 constant bvtag +76 constant mactag 84 constant conttag 92 constant rectag \ macro, continuation, record : box? ( v tag -- f ) over 7 and 6 = if swap car = else 2drop false then ; : proc? ( v -- f ) dup 7 and 6 = if car 7 and 4 <> else drop false then ; \ boxes have an immediate tag in car : truth ( v -- f ) #f <> ; : bool ( f -- v ) if #t else #f then ; : (eval) 'eval @ execute ; : (read) 'read @ execute ; : (print) 'print @ execute ; -: err ( addr len -- ) type cr rsave @ 0= if quit then +: repl-reset ( -- ) rsave @ 0= if quit then 1 lpos ! 0 llen ! -1 pk ! ssave @ sp! rsave @ rp! 'repl @ execute ; +0 variable 'raise-error \ set below: ( i a n -- i a n ) raises a Scheme error object if a handler exists +0 variable inerr \ set while building that object, so an error inside it is not raised again +: errv ( irritant addr len -- ) 'raise-error @ ?dup if execute then 0 inerr ! + type dup unspec <> if ." : " (print) else drop then cr repl-reset ; +: err ( addr len -- ) unspec -rot errv ; : pair ( v -- v ) dup pair? 0= if s" not a pair" err then ; : num ( v -- n ) dup fixnum? 0= if s" not a number" err then unfix ; @@ -117,6 +123,10 @@ linesize buffer: lbuf 0 ntop ! 0 syms ! 0 nprims ! 0 nforms ! gc token quote intern constant s-quote +token quasiquote intern constant s-qq token unquote intern constant s-uq +token unquote-splicing intern constant s-uqs token %syntax-rules intern constant s-%sr +token *handlers* intern constant s-handlers token %make-error intern constant s-mkerr +token raise intern constant s-raise token else intern constant s-else token => intern constant s-=> @@ -234,11 +244,14 @@ token => intern constant s-=> cname dup 0< if drop s" bad character name" err then mkchar ; : rdlist ( -- list ) skipws getc dup 41 = if drop 0 exit then - dup 46 = if drop (read) skipws getc drop exit then + dup 46 = if drop getc dup delim? if drop (read) skipws getc drop exit then \ a lone . is the dot + pk ! 46 tok c! 1 rdtok atom recurse cons exit then \ ... .5 start a token pk ! (read) recurse cons ; : read ( -- v ) skipws getc dup 40 = if drop rdlist exit then dup 39 = if drop s-quote recurse 0 cons cons exit then + dup 96 = if drop s-qq recurse 0 cons cons exit then + dup 44 = if drop getc dup 64 = if drop s-uqs else pk ! s-uq then recurse 0 cons cons exit then dup 41 = if drop s" unexpected )" err then dup 34 = if drop rdstr l>s exit then dup 35 = if drop getc dup 40 = if drop rdlist l>v exit then @@ -287,6 +300,9 @@ token => intern constant s-=> dup bvtag box? if pbv exit then dup rat? if cdr dup car pnum 47 emit cdr pnum exit then dup flo? if cdr pflo exit then + dup mactag box? if drop ." #<macro>" exit then + dup conttag box? if drop ." #<continuation>" exit then + dup rectag box? if ." #<record " cdr bdat @ recurse ." >" exit then dup proc? if drop ." #<procedure>" exit then dup special? if drop ." #<syntax>" exit then dup pair? 0= if drop exit then @@ -299,7 +315,7 @@ token => intern constant s-=> : where ( sym env -- binding | 0 ) begin dup while 2dup car car = if nip car exit then cdr repeat 2drop 0 ; : lookup ( sym env -- v ) over swap where ?dup if nip cdr exit then - dup cdr dup unbound <> if nip exit then drop ." unbound variable: " name type s" " err ; + dup cdr dup unbound <> if nip exit then drop s" unbound variable" errv ; : frame ( env -- env' ) #f #f cons swap cons ; \ a dummy binding that internal defines can follow : bind ( params args env -- env' ) begin 2 pick pair? while over pair? 0= if s" too few arguments" err then @@ -315,7 +331,11 @@ token => intern constant s-=> \ --- eval: handlers return ( x env 0 ) for a tail call or ( v -1 ) for a value --- : seq ( body env -- x env 0 | v -1 ) over 0= if 2drop unspec -1 exit then begin over cdr while over car over (eval) drop swap cdr swap repeat swap car swap 0 ; +0 variable kval 0 variable krp +: throwk ( v k -- ) dup cdr #f = if s" continuation called outside its extent (escape-only)" err then + swap kval ! cdr dup cdr unfix krp ! car unfix sp! kval @ krp @ rp! ; : applyc ( f args -- x env 0 | v -1 ) + over conttag box? if car swap throwk then over proc? 0= if s" not a procedure" err then over car fixnum? if swap car unfix cells prims + @ execute -1 exit then over car swap rot cdr dup >r cdr frame bind r> car swap seq ; @@ -326,8 +346,9 @@ token => intern constant s-=> over sym? if lookup exit then over pair? 0= if drop exit then over car over recurse + dup mactag box? if cdr rot 0 cons apply swap 0 else dup special? if 3 rshift 16 - cells forms + @ execute - else -rot swap cdr swap evlis applyc then + else -rot swap cdr swap evlis applyc then then until ; ' eval 'eval ! @@ -387,6 +408,7 @@ token => intern constant s-=> : stepvals ( vars env -- vals ) over 0= if drop exit then over car cdr cdr dup if car over (eval) else drop over car car over lookup then >r swap cdr swap recurse r> swap cons ; +: f-syntax-rules ( x env ) drop cdr 0 cons s-%sr cdr swap apply -1 ; : f-do ( x env ) swap cdr swap over car over dup frame swap lbind begin 2 pick cdr car car over (eval) truth 0= while 2 pick cdr cdr over seqall @@ -399,6 +421,8 @@ token => intern constant s-=> ' f-letrec defform letrec* ' f-cond defform cond ' f-case defform case ' f-and defform and ' f-or defform or ' f-when defform when ' f-unless defform unless ' f-do defform do +' f-define defform define-syntax ' f-let defform let-syntax ' f-letrec defform letrec-syntax +' f-syntax-rules defform syntax-rules \ --- primitives written in Forth; prims.lisp adds the rest --- : defprim ( xt "name" -- ) token intern >r nprims @ dup 1+ nprims ! @@ -463,6 +487,23 @@ token => intern constant s-=> : p-set-car ( args -- v ) dup cdr car swap car pair car! unspec ; : p-set-cdr ( args -- v ) dup cdr car swap car pair cdr! unspec ; : p-forth ( args -- ) drop ssave @ sp! rsave @ rp! ; +: p-macro ( args -- v ) car mactag swap cons 6 or ; +: p-callcc ( args -- v ) \ escape-only: k returns from this call while the call is active + car sp@ 4 + fix rp@ fix cons conttag swap cons 6 or tuck 0 cons apply swap #f swap cdr! ; +: p-mkrec ( args -- v ) l>v rectag swap cons 6 or ; +: p-rec? ( args -- v ) car rectag box? bool ; +: p-rectype ( args -- v ) car rectag chk cdr bdat @ ; +: p-recref ( args -- v ) arg2 num 1+ swap rectag chk cdr swap 4 ix @ ; +: p-recset ( args -- v ) arg3 >r num 1+ swap rectag chk cdr swap 4 ix r> swap ! unspec ; +: p-reset ( args -- ) drop repl-reset ; +: raise-error ( i a n -- i a n ) \ with a Scheme handler installed, raise an error object + inerr @ if exit then s-handlers cdr pair? 0= if exit then rsave @ 0= if exit then + -1 inerr ! 2 pick 2 pick 2 pick + dup strtag newbox >r r@ bdat swap move r> ( i a n i str ) + swap dup unspec = if drop 0 else 0 cons then ( i a n str irritants ) + 0 cons cons s-mkerr cdr swap apply ( i a n error-object ) + 0 inerr ! s-raise cdr swap 0 cons apply drop ; +' raise-error 'raise-error ! : p-exact ( args -- v ) car exact ; : p-inexact ( args -- v ) car inexact ; : p-eqv ( args -- v ) dup car swap cdr car eqv bool ; @@ -497,6 +538,9 @@ token => intern constant s-=> ' p-s>sym defprim string->symbol ' p-sym>s defprim symbol->string ' p-newline defprim newline ' p-set-car defprim set-car! ' p-set-cdr defprim set-cdr! ' p-forth defprim forth +' p-macro defprim %macro ' p-callcc defprim %callcc ' p-mkrec defprim %make-record +' p-rec? defprim %record? ' p-rectype defprim %record-type ' p-recref defprim %record-ref +' p-recset defprim %record-set! ' p-reset defprim %repl-reset : repl begin 0 raw ! ." > " read 0 eval dup unspec = if drop else print then cr again ; ' repl 'repl ! diff --git a/prelude.scm b/prelude.scm index f647ed7..a2c432d 100644 --- a/prelude.scm +++ b/prelude.scm @@ -103,4 +103,210 @@ (define (char-ci<? . cs) (%chain %cicmp negative? cs)) (define (char-ci>? . cs) (%chain %cicmp positive? cs)) (define (char-ci<=? . cs) (%chain %cicmp (lambda (n) (<= n 0)) cs)) -(define (char-ci>=? . cs) (%chain %cicmp (lambda (n) (>= n 0)) cs)) \ No newline at end of file +(define (char-ci>=? . cs) (%chain %cicmp (lambda (n) (>= n 0)) cs)) +; ---- item 4: syntax, control and data abstractions, written as procedural macros ---- +; A macro is a box made by %macro around a procedure from the whole form to its expansion; +; eval expands it before evaluating. syntax-rules builds such a procedure (not hygienic). +(define (cadddr x) (car (cdddr x))) +(define (cdddr x) (cdr (cddr x))) +(define (cddddr x) (cdr (cdddr x))) + +(define (%qq x depth) + (cond ((vector? x) (list 'list->vector (%qq (vector->list x) depth))) + ((not (pair? x)) (list 'quote x)) + ((eq? (car x) 'unquote) + (if (= depth 0) (cadr x) (list 'list ''unquote (%qq (cadr x) (- depth 1))))) + ((eq? (car x) 'quasiquote) (list 'list ''quasiquote (%qq (cadr x) (+ depth 1)))) + ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing) (= depth 0)) + (list 'append (cadr (car x)) (%qq (cdr x) depth))) + (else (list 'cons (%qq (car x) depth) (%qq (cdr x) depth))))) +(define-syntax quasiquote (%macro (lambda (f) (%qq (cadr f) 0)))) + +; syntax-rules: match patterns (with ellipsis, literals, _) and fill templates. +(define (%sr-vars pat lits ell) + (cond ((symbol? pat) (if (or (memq pat lits) (eq? pat ell) (eq? pat '_)) '() (list pat))) + ((pair? pat) (append (%sr-vars (car pat) lits ell) (%sr-vars (cdr pat) lits ell))) + ((vector? pat) (%sr-vars (vector->list pat) lits ell)) + (else '()))) +(define (%sr-match pat form lits ell b) + (cond ((not b) #f) + ((symbol? pat) + (cond ((memq pat lits) (if (eq? pat form) b #f)) + ((eq? pat '_) b) + (else (cons (cons pat form) b)))) + ((and (pair? pat) (pair? (cdr pat)) (eq? (cadr pat) ell)) + (let* ((tail (cddr pat)) (tn (let loop ((t tail) (n 0)) (if (pair? t) (loop (cdr t) (+ n 1)) n))) + (fn (let loop ((f form) (n 0)) (if (pair? f) (loop (cdr f) (+ n 1)) n)))) + (if (< fn tn) #f + (let loop ((f form) (k (- fn tn)) (ms '())) + (if (> k 0) + (let ((m (%sr-match (car pat) (car f) lits ell (list (cons '%ok #t))))) + (if m (loop (cdr f) (- k 1) (cons m ms)) #f)) + (let ((ms (reverse ms))) + (%sr-match tail f lits ell + (append (map (lambda (v) (cons v (cons '%seq (map (lambda (m) (cdr (assq v m))) ms)))) + (%sr-vars (car pat) lits ell)) + b)))))))) + ((pair? pat) (and (pair? form) (%sr-match (cdr pat) (cdr form) lits ell (%sr-match (car pat) (car form) lits ell b)))) + ((null? pat) (if (null? form) b #f)) + ((vector? pat) (and (vector? form) (%sr-match (vector->list pat) (vector->list form) lits ell b))) + (else (if (equal? pat form) b #f)))) +(define (%sr-seq? v) (and (pair? v) (eq? (car v) '%seq))) +(define (%sr-expand t b ell) + (cond ((symbol? t) (let ((p (assq t b))) (if p (cdr p) t))) + ((and (pair? t) (eq? (car t) ell) (pair? (cdr t))) (%sr-expand (cadr t) '() '%no-ellipsis)) + ((and (pair? t) (pair? (cdr t)) (eq? (cadr t) ell)) + (let* ((vars (filter (lambda (v) (let ((p (assq v b))) (and p (%sr-seq? (cdr p))))) (%sr-vars (car t) '() ell))) + (n (if (null? vars) 0 (length (cddr (assq (car vars) b)))))) + (let loop ((i (- n 1)) (acc (%sr-expand (cddr t) b ell))) + (if (< i 0) acc + (loop (- i 1) + (cons (%sr-expand (car t) (append (map (lambda (v) (cons v (list-ref (cddr (assq v b)) i))) vars) b) ell) acc)))))) + ((pair? t) (cons (%sr-expand (car t) b ell) (%sr-expand (cdr t) b ell))) + ((vector? t) (list->vector (%sr-expand (vector->list t) b ell))) + (else t))) +(define (filter ok? l) (cond ((null? l) '()) ((ok? (car l)) (cons (car l) (filter ok? (cdr l)))) (else (filter ok? (cdr l))))) +(define (%syntax-rules spec) + (let* ((ell (if (symbol? (car spec)) (car spec) '...)) + (spec (if (symbol? (car spec)) (cdr spec) spec)) + (lits (car spec)) (rules (cdr spec))) + (%macro (lambda (form) + (let loop ((rs rules)) + (if (null? rs) (error "no syntax-rules pattern matches" form) + (let ((b (%sr-match (cdar (car rs)) (cdr form) lits ell (list (cons '%ok #t))))) + (if b (%sr-expand (cadr (car rs)) b ell) (loop (cdr rs)))))))))) + +; dynamic-wind (escape-only continuations: unwinding runs the after thunks; there is no re-entry) +(define *winders* '()) +(define (dynamic-wind before thunk after) + (before) + (set! *winders* (cons (cons before after) *winders*)) + (let ((v (thunk))) (set! *winders* (cdr *winders*)) (after) v)) +(define (%unwind-to saved) + (let loop () (if (and (pair? *winders*) (not (eq? *winders* saved))) + (let ((w (car *winders*))) (set! *winders* (cdr *winders*)) ((cdr w)) (loop))))) +(define (values . xs) (if (and (pair? xs) (null? (cdr xs))) (car xs) (%make-record '%values xs))) +(define (%values? v) (and (%record? v) (eq? (%record-type v) '%values))) +(define (call-with-values producer consumer) + (let ((v (producer))) (if (%values? v) (apply consumer (%record-ref v 0)) (consumer v)))) +(define (call-with-current-continuation f) + (let ((saved *winders*)) + (%callcc (lambda (k) (f (lambda vals (%unwind-to saved) (k (apply values vals)))))))) +(define call/cc call-with-current-continuation) + +; exceptions +(define *handlers* '()) +(define (%make-error msg irritants) (%make-record '%error-object msg irritants)) +(define (error-object? x) (and (%record? x) (eq? (%record-type x) '%error-object))) +(define (error-object-message e) (%record-ref e 0)) +(define (error-object-irritants e) (%record-ref e 1)) +(define (read-error? x) #f) +(define (file-error? x) #f) +(define (%uncaught obj) + (if (error-object? obj) + (begin (display (error-object-message obj)) + (for-each (lambda (i) (display " ") (write i)) (error-object-irritants obj))) + (begin (display "uncaught exception: ") (write obj))) + (newline) (%repl-reset)) +(define (%with-handlers hs thunk) + (let ((old *handlers*)) (dynamic-wind (lambda () (set! *handlers* hs)) thunk (lambda () (set! *handlers* old))))) +(define (with-exception-handler h thunk) (%with-handlers (cons h *handlers*) thunk)) +(define (raise-continuable obj) + (if (null? *handlers*) (%uncaught obj) + (let ((h (car *handlers*))) (%with-handlers (cdr *handlers*) (lambda () (h obj)))))) +(define (raise obj) + (raise-continuable obj) + (%uncaught (%make-error "handler returned from raise" (list obj)))) +(define (error msg . irritants) (raise (%make-error msg irritants))) +(define (%guard handler thunk) + ((call/cc (lambda (k) + (with-exception-handler (lambda (c) (k (lambda () (handler c)))) + (lambda () (let ((v (thunk))) (lambda () v)))))))) +(define-syntax guard + (%macro (lambda (f) + (let ((var (car (cadr f))) (clauses (cdr (cadr f)))) + (list '%guard + (list 'lambda (list var) (cons 'cond (append clauses (list (list 'else (list 'raise-continuable var)))))) + (cons 'lambda (cons '() (cddr f)))))))) + +; promises +(define (%make-promise done v) (%make-record '%promise (list done v))) +(define (promise? x) (and (%record? x) (eq? (%record-type x) '%promise))) +(define (make-promise v) (if (promise? v) v (%make-promise #t v))) +(define (force p) + (if (not (promise? p)) p + (let ((s (%record-ref p 0))) + (if (car s) (cadr s) + (let* ((v ((cadr s))) (s2 (%record-ref p 0))) + (cond ((car s2) (cadr s2)) + ((promise? v) (%record-set! p 0 (%record-ref v 0)) (force p)) + (else (%record-set! p 0 (list #t v)) v))))))) +(define-syntax delay (%macro (lambda (f) (list '%make-promise #f (list 'lambda '() (list '%make-promise #t (cadr f))))))) +(define-syntax delay-force (%macro (lambda (f) (list '%make-promise #f (list 'lambda '() (cadr f)))))) + +; parameters +(define (make-parameter v . conv) + (let* ((c (if (pair? conv) (car conv) (lambda (x) x))) (cell (list (c v)))) + (lambda args (cond ((null? args) (car cell)) ((eq? (car args) '%set) (set-car! cell (cadr args))) (else c))))) +(define (%parameterize ps vs thunk) + (let ((new (map (lambda (p v) ((p '%conv) v)) ps vs)) (old (map (lambda (p) (p)) ps))) + (dynamic-wind (lambda () (for-each (lambda (p v) (p '%set v)) ps new)) thunk + (lambda () (for-each (lambda (p v) (p '%set v)) ps old))))) +(define-syntax parameterize + (%macro (lambda (f) (list '%parameterize (cons 'list (map car (cadr f))) (cons 'list (map cadr (cadr f))) + (cons 'lambda (cons '() (cddr f))))))) + +; multiple-value binding forms (let-values binds left to right, like let*-values) +(define (%lv bindings body) + (if (null? bindings) (cons 'let (cons '() body)) + (list 'call-with-values (list 'lambda '() (cadr (car bindings))) + (list 'lambda (car (car bindings)) (%lv (cdr bindings) body))))) +(define-syntax let-values (%macro (lambda (f) (%lv (cadr f) (cddr f))))) +(define-syntax let*-values (%macro (lambda (f) (%lv (cadr f) (cddr f))))) +(define-syntax define-values + (%macro (lambda (f) + (let ((vars (cadr f)) (tmps (map (lambda (v) (string->symbol (string-append "%t-" (symbol->string v)))) (cadr f)))) + (cons 'begin (append (map (lambda (v) (list 'define v #f)) vars) + (list (list 'call-with-values (list 'lambda '() (caddr f)) + (cons 'lambda (cons tmps (map (lambda (v t) (list 'set! v t)) vars tmps)))) + '(if #f #f)))))))) +(define (floor/ n d) (let ((q (floor (/ n d)))) (values q (- n (* d q))))) +(define (truncate/ n d) (values (quotient n d) (remainder n d))) +(define (floor-quotient n d) (floor (/ n d))) +(define (floor-remainder n d) (modulo n d)) +(define (truncate-quotient n d) (quotient n d)) +(define (truncate-remainder n d) (remainder n d)) +(define (exact-integer-sqrt n) (let ((s (%isqrt n))) (values s (- n (* s s))))) + +; records +(define-syntax define-record-type + (%macro (lambda (f) + (let* ((type (cadr f)) (ctor (caddr f)) (pred (cadddr f)) (fields (cddddr f)) (names (map car fields)) + (idx (lambda (n) (let loop ((l names) (i 0)) (if (eq? (car l) n) i (loop (cdr l) (+ i 1))))))) + (cons 'begin + (append (list (list 'define type (list 'quote type))) + (if (pair? ctor) + (list (list 'define (car ctor) + (list 'lambda (cdr ctor) + (cons '%make-record (cons (list 'quote type) (map (lambda (n) (if (memq n (cdr ctor)) n #f)) names)))))) + '()) + (list (list 'define pred (list 'lambda '(x) (list 'and '(%record? x) (list 'eq? '(%record-type x) (list 'quote type)))))) + (apply append + (map (lambda (fd) + (let ((i (idx (car fd)))) + (cons (list 'define (cadr fd) (list 'lambda '(r) (list '%record-ref 'r i))) + (if (pair? (cddr fd)) (list (list 'define (caddr fd) (list 'lambda '(r v) (list '%record-set! 'r i 'v)))) '())))) + fields)) + (list (list 'quote type)))))))) + +; case-lambda +(define (%arity formals) (let loop ((f formals) (n 0)) (cond ((null? f) n) ((pair? f) (loop (cdr f) (+ n 1))) (else (- -1 n))))) +(define (%case-lambda clauses) + (lambda args + (let ((n (length args))) + (let loop ((cs clauses)) + (cond ((null? cs) (error "no case-lambda clause matches" n)) + ((let ((a (caar cs))) (if (< a 0) (>= n (- -1 a)) (= n a))) (apply (cdar cs) args)) + (else (loop (cdr cs)))))))) +(define-syntax case-lambda + (%macro (lambda (f) (list '%case-lambda (cons 'list (map (lambda (c) (list 'cons (list 'quote (%arity (car c))) (cons 'lambda c))) (cdr f))))))) diff --git a/r7rs-tests.scm b/r7rs-tests.scm index fc9bd95..0e99b8f 100644 --- a/r7rs-tests.scm +++ b/r7rs-tests.scm @@ -345,3 +345,68 @@ y ==> (a . 4) (ceiling -7/2) ==> -3 (truncate -7/2) ==> -3 (floor 5) ==> 5 +; item 4: quasiquote, macros, promises, values, call/cc, dynamic-wind, exceptions, parameters, records +`(1 ,(+ 1 1) ,@(list 3 4)) ==> (1 2 3 4) +`(a b) ==> (a b) +(let ((x 5)) `(x ,x)) ==> (x 5) +(let ((xs '(1 2))) `(0 ,@xs 3 . 4)) ==> (0 1 2 3 . 4) +(define-syntax swap! (syntax-rules () ((_ a b) (let ((tmp a)) (set! a b) (set! b tmp))))) +(let ((x 1) (y 2)) (swap! x y) (list x y)) ==> (2 1) +(define-syntax my-or (syntax-rules () ((_) #f) ((_ e) e) ((_ e r ...) (let ((t e)) (if t t (my-or r ...)))))) +(my-or #f #f 3) ==> 3 +(my-or) ==> #f +(define-syntax my-let* (syntax-rules () ((_ () body ...) (let () body ...)) ((_ ((x v) rest ...) body ...) (let ((x v)) (my-let* (rest ...) body ...))))) +(my-let* ((a 1) (b (+ a 1))) (* a b)) ==> 2 +(define-syntax for (syntax-rules (in) ((_ x in lst body ...) (for-each (lambda (x) body ...) lst)))) +(let ((s 0)) (for x in '(1 2 3) (set! s (+ s x))) s) ==> 6 +(let-syntax ((foo (syntax-rules () ((_ x) (* x 10))))) (foo 4)) ==> 40 +(force (delay (+ 1 2))) ==> 3 +(define count 0) ==> count +(define pr (delay (begin (set! count (+ count 1)) count))) ==> pr +(list (force pr) (force pr)) ==> (1 1) +(promise? (make-promise 5)) ==> #t +(force (make-promise 5)) ==> 5 +(force 7) ==> 7 +(call-with-values (lambda () (values 1 2)) +) ==> 3 +(call-with-values (lambda () 5) (lambda (x) (* x x))) ==> 25 +(let-values (((a b) (values 1 2)) ((c) (values 3))) (list a b c)) ==> (1 2 3) +(let-values (((q r) (floor/ 7 2))) (list q r)) ==> (3 1) +(let-values (((q r) (truncate/ -7 2))) (list q r)) ==> (-3 -1) +(let-values (((s r) (exact-integer-sqrt 17))) (list s r)) ==> (4 1) +(define-values (dq dr) (floor/ 17 5)) ==> +(list dq dr) ==> (3 2) +(call/cc (lambda (k) (+ 1 (k 42)))) ==> 42 +(+ 1 (call-with-current-continuation (lambda (k) 2))) ==> 3 +(call/cc (lambda (k) (for-each (lambda (x) (if (> x 2) (k x))) '(1 2 3 4)) 'none)) ==> 3 +(let ((path '())) (dynamic-wind (lambda () (set! path (cons 'in path))) (lambda () (set! path (cons 'body path))) (lambda () (set! path (cons 'out path)))) (reverse path)) ==> (in body out) +(let ((path '())) (call/cc (lambda (k) (dynamic-wind (lambda () (set! path (cons 'in path))) (lambda () (k 'x)) (lambda () (set! path (cons 'out path)))))) (reverse path)) ==> (in out) +(guard (e (#t (list 'caught e))) (raise 'boom)) ==> (caught boom) +(guard (e ((symbol? e) 'sym) ((string? e) 'str)) (raise "x")) ==> str +(guard (e ((error-object? e) (error-object-message e))) (error "bad thing" 1 2)) ==> "bad thing" +(guard (e ((error-object? e) (error-object-irritants e))) (error "bad" 1 2)) ==> (1 2) +(with-exception-handler (lambda (e) 10) (lambda () (+ 1 (raise-continuable 'oops)))) ==> 11 +(guard (e (#t 'outer)) (guard (e2 ((string? e2) 'inner)) (raise 'sym))) ==> outer +(guard (e (#t (list 'v e))) (+ 1 2)) ==> 3 +(error "plain" 'x) ==> plain x +(define pa (make-parameter 10)) ==> pa +(pa) ==> 10 +(parameterize ((pa 20)) (pa)) ==> 20 +(pa) ==> 10 +(define pb (make-parameter 5 (lambda (x) (* x 2)))) ==> pb +(pb) ==> 10 +(parameterize ((pb 3)) (pb)) ==> 6 +(define-record-type point (make-point x y) point? (x point-x set-point-x!) (y point-y)) +(point-x (make-point 1 2)) ==> 1 +(let ((p (make-point 1 2))) (set-point-x! p 9) (point-x p)) ==> 9 +(point? (make-point 1 2)) ==> #t +(point? 5) ==> #f +(define cl (case-lambda ((x) 'one) ((x y) 'two) ((x . r) 'many))) ==> cl +(list (cl 1) (cl 1 2) (cl 1 2 3)) ==> (one two many) +; item 5: primitive errors are raisable error objects +(guard (e (#t 'caught)) (car 5)) ==> caught +(guard (e ((error-object? e) (error-object-message e))) (vector-ref (vector 1) 9)) ==> "index out of range" +(guard (e ((error-object? e) (list (error-object-message e) (error-object-irritants e)))) undefined-thing) ==> ("unbound variable" (undefined-thing)) +(car 5) ==> not a pair +(quote (a ... b)) ==> (a ... b) +(quote (1 . 2)) ==> (1 . 2) +(length (quote (rest ...))) ==> 2 diff --git a/tests/r7rs/results.txt b/tests/r7rs/results.txt index 912484d..cbece2a 100644 --- a/tests/r7rs/results.txt +++ b/tests/r7rs/results.txt @@ -1,53 +1,16 @@ -r7rs suite: 500 passed, 109 failed, 523 skipped, 1132 total -setup forms skipped: 48 +r7rs suite: 603 passed, 140 failed, 389 skipped, 1132 total +setup forms skipped: 15 skipped tests by reason: 0 no libraries: (import ...) not supported - 37 no multiple values - 3 uses means, skipped: no multiple values - 10 no delay/force - 1 uses integers, skipped: no delay/force - 1 uses stream-filter, skipped: no delay/force - 0 no parameters - 0 uses radix, skipped: no parameters - 9 uses f, skipped: uses radix, skipped: no parameters - 6 no quasiquote - 0 no case-lambda - 5 uses any-arity, skipped: no case-lambda - 4 uses rest-arity, skipped: no case-lambda - 4 uses dead-clause, skipped: no case-lambda - 16 no define-syntax / syntax-rules - 0 uses be-like-begin1, skipped: no define-syntax / syntax-rules - 0 uses be-like-begin2, skipped: no define-syntax / syntax-rules - 0 uses be-like-begin3, skipped: no define-syntax / syntax-rules - 3 uses elli-esc-1, skipped: no define-syntax / syntax-rules - 1 uses part-2, skipped: no define-syntax / syntax-rules - 2 uses part-2x, skipped: no define-syntax / syntax-rules - 1 uses underscore, skipped: no define-syntax / syntax-rules - 1 uses count-to-2, skipped: no define-syntax / syntax-rules - 1 uses count-to-2_, skipped: no define-syntax / syntax-rules - 0 uses jabberwocky, skipped: no define-syntax / syntax-rules - 2 no let-syntax - 0 no records - 2 uses pare?, skipped: no records - 1 uses kar, skipped: no records - 1 uses kdr, skipped: no records - 1 uses set-kar!, skipped: no records + 12 no bignums: fixnums are 31-bit, beyond that is an overflow error + 0 no number->string + 9 uses f, skipped: no number->string 25 no complex numbers 11 no #e #i #x #b #o #d number prefixes - 6 no bignums: fixnums are 31-bit, beyond that is an overflow error - 4 no string->number + 6 no string->number 36 no Unicode: characters and strings are bytes; the serial link is Latin-1 - 3 no call/cc - 4 no exceptions: test-error needs raise/guard - 1 uses compose, skipped: uses f, skipped: uses radix, skipped: no parameters - 2 uses list-length, skipped: no call/cc - 14 no exceptions - 4 uses something-went-wrong, skipped: no exceptions - 2 uses test-exception-handler-1, skipped: uses something-went-wrong, skipped: no exceptions - 2 uses test-exception-handler-2, skipped: uses something-went-wrong, skipped: no exceptions - 2 uses test-exception-handler-3, skipped: no exceptions - 6 uses test-exception-handler-4, skipped: no exceptions + 1 uses compose, skipped: uses f, skipped: no number->string 3 no eval / environments 63 no ports beyond the console 73 no read procedure or ports @@ -58,16 +21,40 @@ skipped tests by reason: 13 no system interface failures: -[4.2 Derived expression types] (test '(list 3 4) (quasiquote (list (unquote (+ 1 2)) 4)) ) - => unbound variable: quasiquote -[5 Program structure] (test '(2 1) (let ((x 1) (y 2)) (define-syntax swap! (syntax-rules () ((swap! a b) (let ((tmp a)) (set! a b) (set! b tmp))))) (swap! x y) (list x y))) - => unbound variable: define-syntax +[4.2 Derived expression types] (let*-values (((a b c) (means '(8 5 99 1 22)))) (test 27 a) (test 9.728 b) (test 1800/497 c)) + => unbound variable: exp +[4.2 Derived expression types] (let*-values (((root rem) (exact-integer-sqrt (expt 2 140)))) (test 0 rem) (test (expt 2 140) (square root))) + => unbound variable: expt +[4.3 Macros] (test 'now (let-syntax ((when (syntax-rules () ((when test stmt1 stmt2 ...) (if test (begin stmt1 stmt2 ...)))))) (let ((if #t)) (when if (set! if 'now)) if))) + => not a procedure +[4.3 Macros] (test 'outer (let ((x 'outer)) (let-syntax ((m (syntax-rules () ((m) x)))) (let ((x 'inner)) (m))))) + => <<fail inner>> +[4.3 Macros] (test 7 (letrec-syntax ((my-or (syntax-rules () ((my-or) #f) ((my-or e) e) ((my-or e1 e2 ...) (let ((temp e1)) (if temp temp (my-or e2 ...))))))) (let ((x #f) ( + => not a procedure +[4.3 Macros] (test '(100 ...) (elli-esc-1 100)) + => <<fail (x ...)>> +[4.3 Macros] (test '(... 100 200) (elli-esc-1 100 200)) + => <<fail (... x y)>> +[4.3 Macros] (test 'ok (let ((=> #f)) (cond (#t => 'ok)))) + => not a procedure +[4.3 Macros] (let () (define-syntax foo (syntax-rules () ((foo bar y) (define-syntax bar (syntax-rules () ((bar x) 'y)))))) (foo bar x) (test 'x (bar 1))) + => <<fail 1>> +[4.3 Macros] (let-syntax ((m (syntax-rules () ((m x) (let-syntax ((n (syntax-rules (k) ((n x) 'bound-identifier=?) ((n y) 'free-identifier=?)))) (n z)))))) (test 'bound-iden + => <<fail free-identifier=?>> +[4.3 Macros] (let () (define-syntax elli-lit-1 (syntax-rules ... (...) ((_ x) '(x ...)))) (test '(100 ...) (elli-lit-1 100))) + => <<fail ()>> +[5 Program structure] (test 3 (let () (define-values x (values 1 2)) (apply + x))) + => too many arguments +[5 Program structure] (test 10 (let () (define-values (x y . z) (values 1 2 3 4)) (+ x y (car z) (cadr z)))) + => too many arguments [6.2 Numbers] (test #t (rational? 1.7976931348623157e308)) => <<fail #f>> [6.2 Numbers] (let ((a (- (expt 2 1000) 1)) (b (inexact (expt 2 1000))) (c (+ (expt 2 1000) 1))) (test #t (if (and (= a b) (= b c)) (= a c) #t))) => unbound variable: expt [6.2 Numbers] (let* ((a (/ 10.0 single-float-epsilon)) (j (exact a))) (test #t (if (and (<= a j) (< j (+ j 1))) (not (<= (+ j 1) a)) #t))) => overflow +[6.2 Numbers] (test-values (values 2.0 -1.0) (truncate/ -5.0 -2)) + => not a number [6.2 Numbers] (test -1.0 (remainder -13 -4.0)) => not a number [6.2 Numbers] (test 288.0 (lcm 32.0 -36)) @@ -270,9 +257,31 @@ failures: => unbound variable: bytevector-copy! [6.9 Bytevectors] (test #u8(1 2 3 1 2) (let ((bv (bytevector 1 2 3 4 5))) (bytevector-copy! bv 3 bv 0 2) bv)) => unbound variable: bytevector-copy! +[6.10 Control Features] (test-error (apply +)) + => <<fail no-error>> [6.10 Control Features] (test '(1 4 27 256 3125) (map (lambda (n) (expt n n)) '(1 2 3 4 5))) => unbound variable: expt [6.10 Control Features] (test #(1 4 27 256 3125) (vector-map (lambda (n) (expt n n)) '#(1 2 3 4 5))) => unbound variable: expt [6.10 Control Features] (test '(0 1 4 9 16) (let ((v (make-list 5))) (vector-for-each (lambda (i) (list-set! v i (* i i))) '#(0 1 2 3 4)) v)) => unbound variable: list-set! +[6.10 Control Features] (test '(connect talk1 disconnect connect talk2 disconnect) (let ((path '()) (c #f)) (let ((add (lambda (s) (set! path (cons s path))))) (dynamic-wind (lambda () + => continuation called outside its extent (escape-only) +[6.11 Exceptions] (test #t (file-error? (guard (exn (else exn)) (open-input-file " no such file ")))) + => <<fail #f>> +[6.11 Exceptions] (test #t (read-error? (guard (exn (else exn)) (read (open-input-string ")"))))) + => <<fail #f>> +[6.11 Exceptions] (test #t (read-error? (guard (exn (else exn)) (read (open-input-string "\""))))) + => <<fail #f>> +[6.11 Exceptions] (test 'caught-another-exception (test-exception-handler-2 -1)) + => handler returned from raise an-error +[6.11 Exceptions] (let* ((out (open-output-string)) (value (with-exception-handler (lambda (con) (cond ((not (list? con)) (raise con)) ((list? con) (display (car con) out)) (else + => handler returned from raise #<record %error-object> +[6.11 Exceptions] (let* ((out (open-output-string)) (value (test-exception-handler-3 0 out))) (test 'exception value) (test "condition: an-error!" (get-output-string out))) + => handler returned from raise #<record %error-object> +[6.11 Exceptions] (let* ((out (open-output-string)) (value (test-exception-handler-4 1 out))) (test "" (get-output-string out)) (test 'positive value)) + => handler returned from raise #<record %error-object> +[6.11 Exceptions] (let* ((out (open-output-string)) (value (test-exception-handler-4 -1 out))) (test "" (get-output-string out)) (test 'negative value)) + => handler returned from raise #<record %error-object> +[6.11 Exceptions] (let* ((out (open-output-string)) (value (test-exception-handler-4 0 out))) (test "reraised 0!" (get-output-string out)) (test 'zero value)) + => handler returned from raise #<record %error-object> diff --git a/tests/r7rs/shim.scm b/tests/r7rs/shim.scm index 01e7031..de7e0dc 100644 --- a/tests/r7rs/shim.scm +++ b/tests/r7rs/shim.scm @@ -5,4 +5,6 @@ (define (test-end . o) #t) (define (%report ok got) (if ok (display "<<pass>>") (begin (display "<<fail ") (write got) (display ">>")))) (define (test . args) (let ((expected (if (= (length args) 3) (cadr args) (car args))) (got (if (= (length args) 3) (caddr args) (cadr args)))) (%report (equal? expected got) got))) -(define (test-assert . args) (let ((got (car (reverse args)))) (%report (if got #t #f) got))) \ No newline at end of file +(define (test-assert . args) (let ((got (car (reverse args)))) (%report (if got #t #f) got))) +(define-syntax test-error (syntax-rules () ((_ e) (%report (guard (c (#t #t)) e #f) 'no-error)) ((_ n e) (%report (guard (c (#t #t)) e #f) 'no-error)))) +(define-syntax test-values (syntax-rules () ((_ x e) (test (call-with-values (lambda () x) list) (call-with-values (lambda () e) list))) ((_ n x e) (test (call-with-values (lambda () x) list) (call-with-values (lambda () e) list))))) diff --git a/tests/r7rs/skip.scm b/tests/r7rs/skip.scm index 0526439..b18c769 100644 --- a/tests/r7rs/skip.scm +++ b/tests/r7rs/skip.scm @@ -7,44 +7,17 @@ ; (literal "KIND" "reason") forms with a number literal of KIND: bignum float ratio complex prefix ; Remove an entry when the feature lands; the skip count must only go down. (head "import" "no libraries: (import ...) not supported") -(head "test-error" "no exceptions: test-error needs raise/guard") -(head "test-values" "no multiple values") (head "test-numeric-syntax" "no string->number / number->string") (head "test-precision" "no inexact reals") (head "test-read-error" "no read procedure or ports") (head "test-write-syntax" "no ports: write to string") -(head "define-syntax" "no define-syntax / syntax-rules") -(head "let-syntax" "no let-syntax") -(head "define-record-type" "no records") -(section "4.3 Macros" "no define-syntax / syntax-rules") -(section "6.11 Exceptions" "no exceptions") (section "6.12 Environments and evaluation" "no eval / environments") (section "6.13 Input and output" "no ports beyond the console") (section "6.14 System interface" "no system interface") (section "Read syntax" "no read procedure or ports") (section "Numeric syntax" "no string->number") -(match "let*-values" "no multiple values") -(match "let-values" "no multiple values") -(match "call-with-values" "no multiple values") -(match "(values" "no multiple values") -(match "call-with-current-continuation" "no call/cc") -(match "call/cc" "no call/cc") -(match "dynamic-wind" "no dynamic-wind") -(match "delay" "no delay/force") -(match "make-promise" "no delay/force") -(match "parameterize" "no parameters") -(match "make-parameter" "no parameters") -(match "`" "no quasiquote") -(match "case-lambda" "no case-lambda") (match "string->number" "no string->number") (match "number->string" "no number->string") -(match "guard" "no exceptions") -(match "error-object" "no exceptions") -(match "raise" "no exceptions") -(match "with-exception-handler" "no exceptions") -(match "exact-integer-sqrt" "no multiple values") -(match "floor/" "no multiple values") -(match "truncate/" "no multiple values") (literal "bignum" "no bignums: fixnums are 31-bit, beyond that is an overflow error") (literal "complex" "no complex numbers") (literal "prefix" "no #e #i #x #b #o #d number prefixes")