commit cc3012c9c697cb5bf485403f42b22a7b71e719ae Spenser Truex <truex@equwal.com> 2026-10-04 17:09:56 +0000 String ports and import; GC leak fix; heap rebalance
conformance.txt | 2 +- docs/background.md | 53 ++++++++++++++++++++++++++++++++++ docs/build-docs.py | 4 +++ docs/forthlisp-cheatsheet.txt | 67 +++++++++++++++++++++---------------------- lisp.fs | 55 +++++++++++++++++++++++------------ prelude.scm | 58 +++++++++++++++++++++++++++++++++++++ r7rs-tests.scm | 25 ++++++++++++++++ tests/r7rs/results.txt | 23 ++------------- tests/r7rs/skip.scm | 1 - 9 files changed, 213 insertions(+), 75 deletions(-)
diff --git a/conformance.txt b/conformance.txt index e6b2d93..5d0422f 100644 --- a/conformance.txt +++ b/conformance.txt @@ -1 +1 @@ -conformance: 390 passed, 0 failed, 390 total +conformance: 409 passed, 0 failed, 409 total diff --git a/docs/background.md b/docs/background.md new file mode 100644 index 0000000..768cc00 --- /dev/null +++ b/docs/background.md @@ -0,0 +1,53 @@ +# Background (outline: jose writes the prose) + +<!-- TEMPLATE. Replace each "TODO (jose)" with your own text. Keep the facts and sources. --> + +## Threaded code, and why this kernel is indirect-threaded + +TODO (jose): intro paragraph. + +- Term from James R. Bell, 1973: [CACM 16(6)](https://dl.acm.org/doi/10.1145/362248.362270) +- Variants (direct, indirect, subroutine, token): [Ertl, threaded code](https://www.complang.tuwien.ac.at/forth/threaded-code.html); [Rodriguez, Moving Forth part 1](https://www.bradrodriguez.com/papers/moving1.htm) +- Facts from this repo: + - the kernel is ITC; colon definitions are lists of code-field addresses (`kernel.lisp`); + - the on-chip compiler only appends cells (`,`); every instruction comes from the host assembler. +- Cost: one extra load per executed word ("double indirection", Rodriguez). +- TODO (jose): your view of subroutine threading on a Cortex-M. + +## NEXT on two machines + +TODO (jose): paragraph. + +- Thumb-2 NEXT, exactly as `kernel.lisp` emits it: `ldr.w r7,[r4],#4` / `ldr.w r0,[r7]` / `bx r0` +- Registers: r4 IP, r5 data-stack pointer, r6 TOS, r7 W, sp return stack +- Z80: 16-bit cells, 64 KiB, 8-bit ALU. The register map is in `z80/NOTES.md`. +- Rodriguez: direct threading shortens a Z80 NEXT from 11 to 7 instructions ([Moving Forth part 1](https://www.bradrodriguez.com/papers/moving1.htm)) +- TODO (jose): STM32 vs Z80 comparison table (cell size, address space, integers, floats, emulator). + +## SBCL as an assembler breadboard + +TODO (jose): paragraph. + +- Source: [Khuong, SBCL: the ultimate assembly code breadboard](https://pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/): `sb-assem`, `define-vop`, assemble, disassemble and run in one REPL session +- SBCL backends target only real SBCL ports ([`src/compiler/`](https://github.com/sbcl/sbcl/tree/master/src/compiler)). Here, only the `sb-assem` segments and labels are reused; the encoders are plain Lisp functions, tested against GNU as. +- Finding: SBCL 2.6.9 `emit-back-patch` resolved only the first of adjacent references to one label. The assembler keeps its own fixup list, with a regression test. + +## Lisp in flight software + +TODO (jose): paragraph. + +- Galileo magnetometer, 1993: an RCA 1802 with 2 KiB RAM and 2 KiB ROM, and a corrupted byte. A Lisp-built Forth environment and simulator delivered the patch in about 3 months of part-time work ([Lisping at JPL](https://flownet.com/gat/jpl-lisp.html); [gll-mag-patch](https://github.com/rongarret/gll-mag-patch): `compiler-test`, `compile-patch`, `Patches/test results`) +- Deep Space 1 Remote Agent, 1999: a race condition missed on the ground was diagnosed through a REPL on the spacecraft ([Lisping at JPL](https://flownet.com/gat/jpl-lisp.html)). Model checking reproduced it afterwards ([Havelund, NTRS 20000055731](https://ntrs.nasa.gov/api/citations/20000055731/downloads/20000055731.pdf); [NTRS 20210001175](https://ntrs.nasa.gov/citations/20210001175)) +- Lessons to state in your words: + - build the simulator first; + - prove the toolchain reproduces known bytes; + - keep a live REPL; + - expect concurrency bugs to survive testing. + +## R7RS-small, and where this Scheme stands + +TODO (jose): paragraph. + +- [r7rs.org](https://r7rs.org/); [final report](https://small.r7rs.org/attachment/r7rs.pdf), ratified 2013 +- Suite: [chibi-scheme tests/r7rs-tests.scm](https://github.com/ashinn/chibi-scheme/blob/master/tests/r7rs-tests.scm), vendored unmodified. The counts are in "Test results by layer"; `skip.scm` names a reason for every skip. +- Known gaps: syntax-rules not hygienic; call/cc escape-only; single floats; no bignums, Unicode or file ports. diff --git a/docs/build-docs.py b/docs/build-docs.py index efb6af7..40f4383 100755 --- a/docs/build-docs.py +++ b/docs/build-docs.py @@ -292,6 +292,10 @@ def main(): notes = read("NOTES.md") if notes: body.append(md(notes, toc, "spec-", base=3)) + bg = read("docs/background.md") + if bg: + bg = "\n".join(l for l in bg.split("\n") if "TODO (jose)" not in l and not l.startswith("<!--")) + sec(3, "Background (outline, with sources)", md(bg.split("\n", 1)[1], [], "bg-", base=4)) sec(3, "Special forms (from lisp.fs)", forms_section()) sec(3, "Primitives (from prims.lisp)", prims_section()) sec(3, "Library procedures (from prelude.scm)", prelude_section()) diff --git a/docs/forthlisp-cheatsheet.txt b/docs/forthlisp-cheatsheet.txt index 63d43ea..42efcd4 100644 --- a/docs/forthlisp-cheatsheet.txt +++ b/docs/forthlisp-cheatsheet.txt @@ -11,45 +11,44 @@ SWITCHING Ctrl-C quit QEMU DATA - 42 -7 exact integers, 31 bits, no overflow check - #t #f booleans; only #f is false ('() is true) - 'a '(1 2 . 3) symbols, lists, dotted pairs - "a b\n" #(1 2 3) strings, vectors + 42 -7 1/3 2.5 exact integers (31 bits; overflow is an error), rationals, + single-precision floats + #t #f booleans; only #f is false ('() is true) + #\a "a b\n" characters (bytes), strings + #(1 2 3) #u8(1 2) vectors, bytevectors + 'a '(1 2 . 3) symbols, lists, dotted pairs -SPECIAL FORMS +SPECIAL FORMS AND MACROS (define x 10) (define (f a . rest) ...) (set! x 11) - (lambda (x) ...) (lambda args ...) (begin e1 e2) - (if c a b) (when c ...) (unless c ...) (and ...) (or ...) - (cond (test e) (test => proc) (else e)) (case k ((1 2) e) (else e)) - (let ((x 1)) ...) (let* ...) (letrec ...) (letrec* ...) - (let loop ((i 0)) (if (< i 10) (loop (+ i 1)) i)) named let - (do ((i 0 (+ i 1))) ((= i 5) 'done) body) + (lambda (x) ...) (if c a b) (cond ...) (case ...) (and ...) (or ...) + (let ...) (let* ...) (letrec ...) (do ...) (when ...) (unless ...) + (define-syntax m (syntax-rules () ((_ x) ...))) not hygienic + `(a ,b ,@c) (delay x) (force p) (guard (e (#t ...)) body) + (parameterize ((p v)) ...) (define-record-type ...) (case-lambda ...) + (let-values (((q r) (floor/ 7 2))) ...) (call/cc ...) escape-only -PROCEDURES - + - * quotient remainder modulo abs max min gcd lcm square - = < > <= >= zero? positive? negative? odd? even? - eq? eqv? equal? not car cdr cons set-car! set-cdr! caar cadr cdar cddr caddr - list length append reverse list-tail list-ref list-copy make-list - memq memv member assq assv assoc map for-each apply - null? pair? list? symbol? number? integer? boolean? procedure? - string? string-length string-append string=? string->list list->string`n make-vector vector vector-ref vector-set! vector-length vector->list`n sqrt (exact floor) floor round display write newline - -EXAMPLES TO TYPE +EXAMPLES TO TYPE (each one is checked on the emulated chip) (define (fact n) (if (< n 2) 1 (* n (fact (- n 1))))) - (fact 10) => 3628800 - (map (lambda (n) (* n n)) '(1 2 3 4)) => (1 4 9 16) - (map + '(1 2 3) '(10 20 30)) => (11 22 33) + (fact 10) => 3628800 + (map + '(1 2 3) '(10 20 30)) => (11 22 33) + (/ 6 4) => 3/2 + (+ 1/2 0.25) => 0.75 + (sqrt 16) => 4 + (round 7/2) => 4 + (string-append "ab" "cd") => "abcd" + (vector-ref #(1 2 3) 2) => 3 + (char-upcase #\a) => #\A + (let ((x 5)) `(x ,x ,@(list 1 2))) => (x 5 1 2) + (call/cc (lambda (k) (+ 1 (k 42)))) => 42 + (guard (e ((string? e) e)) (raise "oops")) => "oops" + (guard (e (#t (error-object-message e))) (car 5)) => "not a pair" + (let-values (((q r) (floor/ 17 5))) (list q r)) => (3 2) + (force (delay (* 6 7))) => 42 (let loop ((i 0)) (if (< i 10000) (loop (+ i 1)) i)) => 10000 - (assq 'b '((a 1) (b 2))) => (b 2) - (apply + 1 2 '(3 4)) => 10 - (vector-ref (make-vector 3 7) 1) => 7 - (string-append "a " "b") => "a b" + (+ 1073741823 1) => overflow LIMITS - 64 KiB heap (8191 cells), garbage collected at any time + 60 KiB cons heap, 12 KiB string/vector heap, 10 KiB symbol names tail calls run in constant stack; deep non-tail recursion: too deep - no chars, floats, macros, call/cc; vector-ref walks a list - Errors (unbound variable, not a pair, too deep, ...) return to > - -FORTH SIDE (after (forth)) - 1 2 + . => 3 words list Forth words + continuations are escape-only; syntax-rules is not hygienic + Errors print a message and return to > unless a handler catches them diff --git a/lisp.fs b/lisp.fs index ab47113..5444c93 100644 --- a/lisp.fs +++ b/lisp.fs @@ -14,27 +14,27 @@ \ 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). -61440 constant heapsize +65536 constant heapsize heapsize buffer: heap heapsize 64 / buffer: marks \ one bit per 8-byte cell 12288 constant bsize \ blob heap for strings, vectors, bytevectors bsize buffer: bheap 0 variable btop -10240 constant namesize +6144 constant namesize namesize buffer: names 64 buffer: tok 128 cells buffer: prims 32 cells buffer: forms \ special-form handlers 2048 constant linesize \ one REPL line; an expression may span lines linesize buffer: lbuf -0 variable lpos 0 variable llen +0 variable lpos 0 variable llen 0 variable srcbox 0 variable spos 0 variable free 0 variable ntop 0 variable syms 0 variable nprims 0 variable nforms -1 variable pk 0 variable rsave 0 variable ssave 0 variable raw \ 1 while display prints strings without quotes 0 variable 'eval 0 variable 'read 0 variable 'repl 0 variable 'print -4 constant #f 12 constant #t 20 constant unspec 28 constant unbound +4 constant #f 12 constant #t 20 constant unspec 28 constant unbound 100 constant eofv : fixnum? ( v -- f ) 1 and 0<> ; : sym? ( v -- f ) 7 and 2 = ; @@ -58,11 +58,11 @@ linesize buffer: lbuf : bool ( f -- v ) if #t else #f then ; : (eval) 'eval @ execute ; : (read) 'read @ execute ; : (print) 'print @ execute ; -: repl-reset ( -- ) rsave @ 0= if quit then +: repl-reset ( -- ) 0 srcbox ! 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 ! +: errv ( irritant addr len -- ) 0 emit-hook ! '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 ; @@ -92,7 +92,7 @@ linesize buffer: lbuf dup bdst +! then nip bsrc +! repeat bdst @ btop ! ; -: gc marks heapsize 64 / 0 fill syms @ mark +: gc marks heapsize 64 / 0 fill syms @ mark srcbox @ mark rsave @ if ssave @ sp@ scan rsave @ rp@ scan then sweep bcompact ; : cons ( a d -- p ) free @ 0= if gc free @ 0= if s" out of memory" err then then free @ dup car free ! tuck cdr! tuck car! ; @@ -126,7 +126,7 @@ 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 raise intern constant s-raise token *winders* intern constant s-winders token %oport intern constant s-oport token define intern constant s-define token define-syntax intern constant s-defsyn token else intern constant s-else token => intern constant s-=> @@ -188,11 +188,12 @@ token => intern constant s-=> \ --- reader: lines come from the kernel's accept, which handles BS and DEL --- : refill lbuf linesize accept llen ! 0 lpos ! cr ; : getc ( -- c ) pk @ dup 0< 0= if -1 pk ! exit then drop + srcbox @ ?dup if spos @ over blen < if bdat spos @ + c@ 1 spos +! else drop 256 then exit then lpos @ llen @ > if refill then lpos @ llen @ = if 1 lpos +! 10 exit then lbuf lpos @ + c@ 1 lpos +! ; -: skipws begin getc dup 59 = if drop begin getc 10 = until 32 then dup 33 < while drop repeat pk ! ; -: delim? ( c -- f ) dup 33 < over 40 = or over 41 = or swap 59 = or ; +: skipws begin getc dup 59 = if drop begin getc dup 10 = swap 256 = or until 32 then dup 33 < while drop repeat pk ! ; +: delim? ( c -- f ) dup 33 < over 40 = or over 41 = or over 256 = or swap 59 = or ; : rdtok ( n -- addr len ) begin getc dup delim? 0= while over 63 < if over tok + c! 1+ else drop then repeat pk ! tok swap ; : digits ( addr len -- u true | false ) dup 0= if 2drop false exit then @@ -230,7 +231,7 @@ token => intern constant s-=> 2dup s" #t" compare if 2drop #t exit then 2dup s" #true" compare if 2drop #t exit then 2dup s" #f" compare if 2drop #f exit then 2dup s" #false" compare if 2drop #f exit then intern ; -: rdstr ( -- list ) getc dup 34 = if drop 0 exit then +: rdstr ( -- list ) getc dup 34 = if drop 0 exit then dup 256 = if s" unexpected end of input" err then dup 92 = if drop getc dup 110 = if drop 10 then dup 116 = if drop 9 then then mkchar recurse cons ; : cname ( addr len -- code | -1 ) @@ -244,11 +245,12 @@ token => intern constant s-=> : rdchar ( -- v ) getc tok c! 1 rdtok dup 1 = if drop c@ mkchar exit then cname dup 0< if drop s" bad character name" err then mkchar ; : rdlist ( -- list ) skipws getc - dup 41 = if drop 0 exit then + dup 41 = if drop 0 exit then dup 256 = if s" unexpected end of input" err 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 256 = if drop eofv exit then 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 @@ -301,6 +303,7 @@ 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 eofv = if drop ." #<eof>" 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 @@ -412,6 +415,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-import ( x env ) 2drop unspec -1 ; : 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 @@ -426,15 +430,21 @@ token => intern constant s-=> ' 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 +' f-syntax-rules defform syntax-rules ' f-import defform import \ --- primitives written in Forth; prims.lisp adds the rest --- : defprim ( xt "name" -- ) token intern >r nprims @ dup 1+ nprims ! tuck cells prims + ! fix 0 cons 6 or r> cdr! ; : spread ( list -- list' ) dup cdr 0= if car exit then dup car swap cdr recurse cons ; : p-apply ( args -- v ) dup car swap cdr spread apply ; -: p-display ( args -- v ) 1 raw ! car print 0 raw ! unspec ; -: p-write ( args -- v ) car print unspec ; +: rfield ( rec i -- v ) swap cdr bdat swap 1+ cells + @ ; +: rfield! ( v rec i -- ) swap cdr bdat swap 1+ cells + ! ; +0 variable curport +: capture ( c -- ) mkchar curport @ 0 rfield cons curport @ 0 rfield! ; \ emit-hook for string ports +: >port ( port -- ) dup rectag box? if dup cdr bdat @ s-oport = if curport ! ['] capture emit-hook ! exit then then drop ; +: >console ( -- ) 0 emit-hook ! 0 curport ! ; +: p-display ( args -- v ) dup cdr if dup cdr car >port then 1 raw ! car print 0 raw ! >console unspec ; +: p-write ( args -- v ) dup cdr if dup cdr car >port then car print >console unspec ; 0 variable fsz : arg2 ( args -- a b ) dup car swap cdr car ; : arg3 ( args -- a b c ) dup car swap cdr dup car swap cdr car ; @@ -487,7 +497,14 @@ token => intern constant s-=> : p-s>sym ( args -- v ) car strtag chk dup blen 63 min >r bdat tok r@ move tok r> intern ; : p-sym>s ( args -- v ) car dup sym? 0= if s" not a symbol" err then name dup strtag newbox dup >r bdat swap move r> ; -: p-newline ( args -- v ) drop cr unspec ; +: p-newline ( args -- v ) dup if car >port else drop then cr >console unspec ; +: p-pread ( args -- v ) car pk @ >r -1 pk ! dup 0 rfield srcbox ! dup 1 rfield unfix spos ! + read pk @ dup 0< 0= swap 256 <> and if -1 spos +! then + swap spos @ fix swap 1 rfield! 0 srcbox ! r> pk ! ; +: p-unsrc ( args -- v ) drop 0 srcbox ! unspec ; +: p-rcons ( args -- v ) drop read ; +: p-eof ( args -- v ) drop eofv ; +: p-eof? ( args -- v ) car eofv = bool ; : 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! ; @@ -542,7 +559,8 @@ token => intern constant s-=> ' p-l>s defprim list->string ' p-l>v defprim list->vector ' p-l>bv defprim list->bytevector ' p-substr defprim %substring ' p-sapp defprim %string-append2 ' p-scmp defprim %string-compare ' 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-newline defprim newline ' p-pread defprim %pread ' p-unsrc defprim %unsrc +' p-rcons defprim %read-console ' p-eof defprim eof-object ' p-eof? defprim eof-object? ' 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 @@ -552,6 +570,7 @@ token => intern constant s-=> 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 begin 0 raw ! 0 s-handlers cdr! 0 s-winders cdr! \ an escape to the prompt leaves no handlers or winders + ." > " 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 8ce6a9e..31839cf 100644 --- a/prelude.scm +++ b/prelude.scm @@ -329,3 +329,61 @@ (%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))) + +; ---- item 9: libraries are accepted (import is ignored); ports ---- +(define (open-output-string) (%make-record '%oport '())) +(define (get-output-string p) (list->string (reverse (%record-ref p 0)))) +(define (open-input-string s) (%make-record '%iport s 0)) +(define %console-out (%make-record '%console-out)) +(define %console-in (%make-record '%console-in)) +(define (current-output-port) %console-out) +(define (current-error-port) %console-out) +(define (current-input-port) %console-in) +(define (output-port? p) (and (%record? p) (memq (%record-type p) '(%oport %console-out)) #t)) +(define (input-port? p) (and (%record? p) (memq (%record-type p) '(%iport %console-in)) #t)) +(define (port? p) (or (input-port? p) (output-port? p))) +(define (textual-port? p) (port? p)) +(define (binary-port? p) #f) +(define (input-port-open? p) (input-port? p)) +(define (output-port-open? p) (output-port? p)) +(define (close-port p) #t) +(define (close-input-port p) #t) +(define (close-output-port p) #t) +(define (flush-output-port . p) #t) +(define (write-char c . p) (apply display c p)) +(define (write-string s . p) (apply display s p)) +(define (write-shared x . p) (apply write x p)) +(define (write-simple x . p) (apply write x p)) +(define (%ip p) (if (and (pair? p) (eq? (%record-type (car p)) '%iport)) (car p) (error "only string input ports are supported"))) +(define (peek-char . p) + (let* ((ip (%ip p)) (s (%record-ref ip 0)) (i (%record-ref ip 1))) + (if (>= i (string-length s)) (eof-object) (string-ref s i)))) +(define (read-char . p) + (let* ((ip (%ip p)) (c (peek-char ip))) + (if (not (eof-object? c)) (%record-set! ip 1 (+ (%record-ref ip 1) 1))) + c)) +(define (char-ready? . p) #t) +(define (read-line . p) + (let ((ip (%ip p))) + (let loop ((acc '())) + (let ((c (read-char ip))) + (cond ((eof-object? c) (if (null? acc) c (list->string (reverse acc)))) + ((char=? c #\newline) (list->string (reverse acc))) + (else (loop (cons c acc)))))))) +(define (read-string k . p) + (let ((ip (%ip p))) + (let loop ((k k) (acc '())) + (if (= k 0) (list->string (reverse acc)) + (let ((c (read-char ip))) + (if (eof-object? c) (if (null? acc) c (list->string (reverse acc))) (loop (- k 1) (cons c acc)))))))) +(define (read . p) + (if (null? p) (%read-console) + (let ((ip (%ip p))) (dynamic-wind (lambda () #f) (lambda () (%pread ip)) (lambda () (%unsrc)))))) +(define (read-error? e) + (and (error-object? e) (member (error-object-message e) '("unexpected )" "unexpected end of input" "bad character name")) #t)) +(define (file-error? e) (and (error-object? e) (equal? (error-object-message e) "no file system") #t)) +(define (open-input-file f) (raise (%make-error "no file system" (list f)))) +(define (open-output-file f) (raise (%make-error "no file system" (list f)))) +(define (file-exists? f) #f) +(for-each (lambda (a) (%arity! (car a) (cadr a) (caddr a))) + '((%pread 1 1) (%unsrc 0 0) (%read-console 0 0) (eof-object 0 0) (eof-object? 1 1))) diff --git a/r7rs-tests.scm b/r7rs-tests.scm index 6461a75..7d2157c 100644 --- a/r7rs-tests.scm +++ b/r7rs-tests.scm @@ -422,3 +422,28 @@ y ==> (a . 4) (begin (define dw 6)) ==> (define dz 7) ==> dz (define (dfn a) a) ==> dfn +; item 9: import accepted; string ports, console ports, eof +(import (scheme base)) ==> +(import (scheme base) (scheme write)) ==> +(let ((p (open-output-string))) (write 'abc p) (display " x" p) (get-output-string p)) ==> "abc x" +(let ((p (open-output-string))) (write-char #\z p) (write-string "yy" p) (write 1/2 p) (get-output-string p)) ==> "zyy1/2" +(let ((p (open-input-string "hi there"))) (list (read-char p) (peek-char p) (read-char p))) ==> (#\h #\i #\i) +(read-line (open-input-string "line one\nline two")) ==> "line one" +(read (open-input-string "(a b . c)")) ==> (a b . c) +(let ((p (open-input-string "1 2"))) (list (read p) (read p) (eof-object? (read p)))) ==> (1 2 #t) +(eof-object? (eof-object)) ==> #t +(read-string 3 (open-input-string "abcdef")) ==> "abc" +(guard (e ((read-error? e) 'bad)) (read (open-input-string ")"))) ==> bad +(guard (e ((file-error? e) 'nofile)) (open-input-file "x")) ==> nofile +(output-port? (current-output-port)) ==> #t +(begin (write-string "hey" (current-output-port)) 'done) ==> heydone +(+ 1 2) ==> 3 +; regression: an uncaught error inside with-exception-handler must not leave the handler installed + +(with-exception-handler (lambda (e) 0) (lambda () (car 1))) + +(car 5) ==> not a pair + +(dynamic-wind (lambda () #f) (lambda () (car 1)) (lambda () #f)) + +(length *winders*) ==> 0 diff --git a/tests/r7rs/results.txt b/tests/r7rs/results.txt index 93e3f91..54eced3 100644 --- a/tests/r7rs/results.txt +++ b/tests/r7rs/results.txt @@ -1,8 +1,7 @@ -r7rs suite: 603 passed, 140 failed, 389 skipped, 1132 total -setup forms skipped: 15 +r7rs suite: 617 passed, 126 failed, 389 skipped, 1132 total +setup forms skipped: 14 skipped tests by reason: - 0 no libraries: (import ...) not supported 12 no bignums: fixnums are 31-bit, beyond that is an overflow error 0 no number->string 9 uses f, skipped: no number->string @@ -265,23 +264,5 @@ failures: => 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> -[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 diff --git a/tests/r7rs/skip.scm b/tests/r7rs/skip.scm index b18c769..02f6e32 100644 --- a/tests/r7rs/skip.scm +++ b/tests/r7rs/skip.scm @@ -6,7 +6,6 @@ ; (nonlatin1 "" "reason") forms with a character beyond Latin-1 ; (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-numeric-syntax" "no string->number / number->string") (head "test-precision" "no inexact reals") (head "test-read-error" "no read procedure or ports")