commit b9d4fedff63d9d04240fe1c9d43632104c8d7640 Spenser Truex <truex@equwal.com> 2026-10-04 10:15:37 +0000 R7RS items 6 and 8: primitive arity checks; define is unspecified
NOTES.md | 8 +++++--- README.md | 2 +- conformance.txt | 2 +- host.lisp | 4 ++-- lisp.fs | 20 +++++++++++++++----- prelude.scm | 19 +++++++++++++++++++ r7rs-tests.scm | 12 ++++++++++++ tests/r7rs/results.txt | 4 ++-- 8 files changed, 57 insertions(+), 14 deletions(-)
diff --git a/NOTES.md b/NOTES.md index 255c378..e9360e8 100644 --- a/NOTES.md +++ b/NOTES.md @@ -114,7 +114,7 @@ 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` | 380/380 | +| 4 Scheme | our own regression suite `r7rs-tests.scm` via `host.lisp test` | 390/390 | - 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: @@ -194,9 +194,11 @@ Our own suite below stays local: a reported sieve program, string cases and thos 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. +- Primitives check their argument count (a table in `prelude.scm`); a wrong count raises + `wrong number of arguments`. Closures check theirs (`too few arguments`, `too many arguments`). - 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). +- `define` returns an unspecified value. The REPL echoes the name of a top-level `define` or + `define-syntax` as a convenience; the name is not the value. ## Implementation diff --git a/README.md b/README.md index 340e7b7..3cf9d0a 100644 --- a/README.md +++ b/README.md @@ -52,7 +52,7 @@ 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` (380/380 at publication) +- Our regression suite: see `conformance.txt` (390/390 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) diff --git a/conformance.txt b/conformance.txt index 39e5184..e6b2d93 100644 --- a/conformance.txt +++ b/conformance.txt @@ -1 +1 @@ -conformance: 380 passed, 0 failed, 380 total +conformance: 390 passed, 0 failed, 390 total diff --git a/host.lisp b/host.lisp index ad3fc95..ec7feec 100644 --- a/host.lisp +++ b/host.lisp @@ -170,7 +170,7 @@ followed by a space or the end of the line. A backslash inside code (e.g. in .\" (defun load-target () "Layer 2 + 3: send lisp.fs, then the Forth that prims.lisp compiles to." - (forth "") + (forth "" :timeout 30) (forth-lines (with-open-file (s (here "lisp.fs")) (loop for l = (read-line s nil) while l collect l))) (forth-lines (compile-file-to-forth (here "prims.lisp"))) @@ -233,7 +233,7 @@ followed by a space or the end of the line. A backslash inside code (e.g. in .\" (defun demo () (connect) (format t "~%=== Layer 1: host Lisp compiles Lisp to Forth and runs it on the chip ===~%") - (forth "") + (forth "" :timeout 30) (dolist (line (compile-file-to-forth (here "demo.lisp"))) (format t "[compiled] ~a~%" line) (forth line)) diff --git a/lisp.fs b/lisp.fs index 002f5ca..ab47113 100644 --- a/lisp.fs +++ b/lisp.fs @@ -127,6 +127,7 @@ 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 define intern constant s-define token define-syntax intern constant s-defsyn token else intern constant s-else token => intern constant s-=> @@ -334,10 +335,13 @@ token => intern constant s-=> 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! ; +: arity? ( f args -- f args ) over cdr dup 0= if drop exit then unfix over listlen + over 255 and over > if s" wrong number of arguments" err then + swap 8 rshift 255 and dup 255 = if 2drop exit then > if s" wrong number of arguments" err then ; : 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 fixnum? if arity? swap car unfix cells prims + @ execute -1 exit then over car swap rot cdr dup >r cdr frame bind r> car swap seq ; : apply ( f args -- v ) applyc if exit then (eval) ; : eval ( x env -- v ) @@ -360,8 +364,8 @@ token => intern constant s-=> : f-lambda ( x env ) >r cdr dup car swap cdr r> closure -1 ; : f-begin ( x env ) swap cdr swap seq ; : f-define ( x env ) swap cdr dup car sym? if - dup car >r cdr car over (eval) r@ rot def-bind r> -1 exit then - dup car car >r dup car cdr swap cdr 2 pick closure r@ rot def-bind r> -1 ; + dup car >r cdr car over (eval) r@ rot def-bind rdrop unspec -1 exit then + dup car car >r dup car cdr swap cdr 2 pick closure r@ rot def-bind rdrop unspec -1 ; : f-set ( x env ) swap cdr dup car >r cdr car over (eval) swap r@ swap where ?dup if cdr! else r@ cdr! then rdrop unspec -1 ; : lbind ( binds env eenv -- env' ) \ evaluate each (name expr) in eenv, bind onto env @@ -496,6 +500,8 @@ token => intern constant s-=> : 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 ; +: p-arity! ( args -- v ) arg3 num 8 lshift swap num or fix swap cdr + dup proc? 0= if s" not a primitive" err then cdr! unspec ; : 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 @@ -540,8 +546,12 @@ token => intern constant s-=> ' 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 +' p-recset defprim %record-set! ' p-reset defprim %repl-reset ' p-arity! defprim %arity! -: repl begin 0 raw ! ." > " read 0 eval dup unspec = if drop else print then cr again ; +: echo ( v form -- v' ) \ for a top-level (define name ...), show the name instead of nothing + over unspec <> if drop exit then dup pair? 0= if drop exit then + dup car dup s-define = swap s-defsyn = or 0= if drop exit then + cdr car dup pair? if car then nip ; +: repl begin 0 raw ! ." > " read dup >r 0 eval r> echo dup unspec = if drop else print then cr again ; ' repl 'repl ! : lisp ( -- ) sp@ ssave ! rp@ rsave ! 1 lpos ! 0 llen ! -1 pk ! cr repl ; diff --git a/prelude.scm b/prelude.scm index a2c432d..8ce6a9e 100644 --- a/prelude.scm +++ b/prelude.scm @@ -310,3 +310,22 @@ (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))))))) + +; ---- item 6: primitives check their argument count: (name min max), max 255 = any ---- +(for-each (lambda (a) (%arity! (car a) (cadr a) (caddr a))) + '((+ 0 255) (- 1 255) (* 0 255) (/ 1 255) (quotient 2 2) (remainder 2 2) (modulo 2 2) + (= 1 255) (< 1 255) (> 1 255) (<= 1 255) (>= 1 255) (eq? 2 2) (eqv? 2 2) + (car 1 1) (cdr 1 1) (cons 2 2) (null? 1 1) (pair? 1 1) (symbol? 1 1) (procedure? 1 1) (boolean? 1 1) + (exact 1 1) (inexact 1 1) (number? 1 1) (real? 1 1) (complex? 1 1) (integer? 1 1) (rational? 1 1) + (exact? 1 1) (inexact? 1 1) (exact-integer? 1 1) (%numerator 1 1) (%denominator 1 1) + (nan? 1 1) (infinite? 1 1) (%ftruncate 1 1) (%fsqrt 1 1) + (apply 2 255) (display 1 2) (write 1 2) (newline 0 1) + (string? 1 1) (vector? 1 1) (bytevector? 1 1) (char? 1 1) (char->integer 1 1) (integer->char 1 1) + (string-length 1 1) (vector-length 1 1) (bytevector-length 1 1) + (string-ref 2 2) (string-set! 3 3) (vector-ref 2 2) (vector-set! 3 3) + (bytevector-u8-ref 2 2) (bytevector-u8-set! 3 3) (make-string 1 2) (make-vector 1 2) (make-bytevector 1 2) + (%string->list 3 3) (%vector->list 3 3) (%bytevector->list 1 1) + (list->string 1 1) (list->vector 1 1) (list->bytevector 1 1) + (%substring 3 3) (%string-append2 2 2) (%string-compare 2 2) (string->symbol 1 1) (symbol->string 1 1) + (set-car! 2 2) (set-cdr! 2 2) (%macro 1 1) (%callcc 1 1) (%make-record 1 255) (%record? 1 1) + (%record-type 1 1) (%record-ref 2 2) (%record-set! 3 3) (%arity! 3 3))) diff --git a/r7rs-tests.scm b/r7rs-tests.scm index 0e99b8f..6461a75 100644 --- a/r7rs-tests.scm +++ b/r7rs-tests.scm @@ -410,3 +410,15 @@ y ==> (a . 4) (quote (a ... b)) ==> (a ... b) (quote (1 . 2)) ==> (1 . 2) (length (quote (rest ...))) ==> 2 +; item 6: primitives check their argument count +(car 1 2) ==> wrong number of arguments +(cons 1) ==> wrong number of arguments +(apply +) ==> wrong number of arguments +(vector-ref (vector 1)) ==> wrong number of arguments +(guard (e (#t (quote caught))) (car)) ==> caught +((lambda (x) x)) ==> too few arguments +; item 8: define returns an unspecified value; the REPL only echoes the name +(let ((v (begin (define dv 5)))) (eq? v (quote dv))) ==> #f +(begin (define dw 6)) ==> +(define dz 7) ==> dz +(define (dfn a) a) ==> dfn diff --git a/tests/r7rs/results.txt b/tests/r7rs/results.txt index cbece2a..93e3f91 100644 --- a/tests/r7rs/results.txt +++ b/tests/r7rs/results.txt @@ -257,8 +257,6 @@ 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))) @@ -285,3 +283,5 @@ failures: => 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> +[6.11 Exceptions] (test 'caught-d (guard (condition ((assq 'c condition) 'caught-c) ((assq 'd condition) 'caught-d)) (list (sqrt 8) (guard (condition ((assq 'a condition) => cdr) + => out of memory