lisp.fs (34675 bytes)
1 \ lisp.fs -- an R7RS-small subset Scheme in Forth (our own kernel) for the STM32F446 (128 KiB RAM). 2 \ Values are 32-bit. Low 3 bits: xx1 fixnum (31-bit signed), 000 pair (0 is '()), 3 \ 010 symbol, 100 immediate (#f #t, unspecified, unbound, box tags, special-form markers, 4 \ characters), 110 procedure or box. 5 \ Pairs, symbols and procedures are 8-byte cells in `heap`: car word, cdr word. 6 \ Symbol: car = fixnum offset of its counted name in `names`, cdr = global value. 7 \ Procedure: car = fixnum primitive number, or a closure's parameters; closure cdr = (body . env). 8 \ Box: a 110 cell whose car is a box tag. Strings, vectors and bytevectors keep their contents 9 \ in a contiguous blob in `bheap`; the box's cdr holds the blob's data address. A blob header 10 \ names its one owner box, so the GC can slide live blobs down and fix the owner's cdr. 11 \ Rule: never hold a blob address across an allocation (cons, newbox); re-fetch it from the box. 12 \ A character is an immediate: (code+1) << 12 | 4. 13 \ An environment is an alist of (symbol . value) bindings in front of the globals. 14 \ GC: mark-sweep, run when cons finds the free list empty. Roots: the symbol list, plus 15 \ every word on the data and return stacks that looks like a heap reference (conservative). 16 17 65536 constant heapsize 18 heapsize buffer: heap 19 heapsize 64 / buffer: marks \ one bit per 8-byte cell 20 12288 constant bsize \ blob heap for strings, vectors, bytevectors 21 bsize buffer: bheap 22 0 variable btop 23 6144 constant namesize 24 namesize buffer: names 25 64 buffer: tok 26 128 cells buffer: prims 27 32 cells buffer: forms \ special-form handlers 28 2048 constant linesize \ one REPL line; an expression may span lines 29 linesize buffer: lbuf 30 0 variable lpos 0 variable llen 0 variable srcbox 0 variable spos 31 0 variable free 0 variable ntop 0 variable syms 0 variable nprims 0 variable nforms 32 -1 variable pk 33 0 variable rsave 0 variable ssave 34 0 variable raw \ 1 while display prints strings without quotes 35 0 variable 'eval 0 variable 'read 0 variable 'repl 0 variable 'print 36 37 4 constant #f 12 constant #t 20 constant unspec 28 constant unbound 100 constant eofv 38 39 : fixnum? ( v -- f ) 1 and 0<> ; 40 : sym? ( v -- f ) 7 and 2 = ; 41 : pair? ( v -- f ) dup 7 and 0= swap 0<> and ; 42 : special? ( v -- f ) dup 7 and 4 = swap dup 131 > swap 4096 < and and ; \ forms: (k+16)*8+4 43 : char? ( v -- f ) dup 7 and 4 = swap 4095 > and ; 44 : mkchar ( code -- v ) 1+ 12 lshift 4 or ; 45 : charcode ( v -- code ) 12 rshift 1- ; 46 : fix ( n -- v ) 2* 1 or ; 47 : unfix ( v -- n ) 1 arshift ; 48 : addr ( v -- a ) 7 bic heap + ; 49 : car ( v -- v ) addr @ ; 50 : cdr ( v -- v ) addr cell+ @ ; 51 : car! ( v p -- ) addr ! ; 52 : cdr! ( v p -- ) addr cell+ ! ; 53 36 constant strtag 44 constant vectag 68 constant bvtag 54 76 constant mactag 84 constant conttag 92 constant rectag \ macro, continuation, record 55 : box? ( v tag -- f ) over 7 and 6 = if swap car = else 2drop false then ; 56 : proc? ( v -- f ) dup 7 and 6 = if car 7 and 4 <> else drop false then ; \ boxes have an immediate tag in car 57 : truth ( v -- f ) #f <> ; 58 : bool ( f -- v ) if #t else #f then ; 59 : (eval) 'eval @ execute ; : (read) 'read @ execute ; : (print) 'print @ execute ; 60 61 : repl-reset ( -- ) 0 srcbox ! rsave @ 0= if quit then 62 1 lpos ! 0 llen ! -1 pk ! ssave @ sp! rsave @ rp! 'repl @ execute ; 63 0 variable 'raise-error \ set below: ( i a n -- i a n ) raises a Scheme error object if a handler exists 64 0 variable inerr \ set while building that object, so an error inside it is not raised again 65 : errv ( irritant addr len -- ) 0 emit-hook ! 'raise-error @ ?dup if execute then 0 inerr ! 66 type dup unspec <> if ." : " (print) else drop then cr repl-reset ; 67 : err ( addr len -- ) unspec -rot errv ; 68 : pair ( v -- v ) dup pair? 0= if s" not a pair" err then ; 69 : num ( v -- n ) dup fixnum? 0= if s" not a number" err then unfix ; 70 71 \ --- garbage collector --- 72 : mbit ( v -- addr mask ) 3 rshift dup 3 rshift marks + swap 7 and 1 swap lshift ; 73 : marked? ( v -- f ) 7 bic mbit swap c@ and 0<> ; 74 : ref? ( w -- f ) \ tag 000, 010 or 110 and inside the heap 75 dup 7 and dup 4 = swap 1 and or 0= swap 7 bic dup 7 > swap heapsize u< and and ; 76 : mark ( v -- ) begin dup ref? while 77 dup marked? if drop exit then dup 7 bic mbit swap cbis! 78 dup vectag box? if dup cdr ?dup if dup 4 - @ 2 rshift 0 ?do dup i cells + @ recurse loop drop then then 79 dup car recurse cdr repeat drop ; 80 : scan ( hi lo -- ) begin 2dup u> while dup @ mark cell+ repeat 2drop ; 81 : sweep 0 free ! heapsize 8 - begin dup 7 > while 82 dup marked? 0= if free @ over heap + ! dup free ! then 8 - repeat drop ; 83 0 variable bsrc 0 variable bdst 84 : blive? ( hdr -- f ) dup @ dup marked? if cdr swap 8 + = else 2drop false then ; 85 : bcompact \ slide live blobs down, fix each owner's data address 86 0 bsrc ! 0 bdst ! 87 begin bsrc @ btop @ < while 88 bheap bsrc @ + dup 4 + @ aligned 8 + 89 over blive? if 90 over bheap bdst @ + 2 pick move 91 bheap bdst @ + dup 8 + swap @ cdr! 92 dup bdst +! 93 then nip bsrc +! 94 repeat bdst @ btop ! ; 95 : gc marks heapsize 64 / 0 fill syms @ mark srcbox @ mark 96 rsave @ if ssave @ sp@ scan rsave @ rp@ scan then sweep bcompact ; 97 : cons ( a d -- p ) free @ 0= if gc free @ 0= if s" out of memory" err then then 98 free @ dup car free ! tuck cdr! tuck car! ; 99 : balloc ( n box -- ) over aligned 8 + dup btop @ + bsize > if gc dup btop @ + bsize > if 100 s" out of memory" err then then 101 bheap btop @ + >r btop +! dup r@ ! over r@ 4 + ! r@ 8 + rot 0 fill r> 8 + swap cdr! ; 102 : newbox ( n tag -- box ) 0 cons 6 or tuck balloc ; 103 : blen ( box -- n ) cdr 4 - @ ; 104 : bdat ( box -- addr ) cdr ; 105 : chk ( v tag -- v ) over over box? 0= if s" wrong type" err then drop ; 106 : listlen ( list -- n ) 0 swap begin dup pair? while swap 1+ swap cdr repeat drop ; 107 : l>s ( list -- str ) dup listlen strtag newbox swap 0 swap begin dup pair? while 108 dup car charcode 3 pick bdat 3 pick + c! swap 1+ swap cdr repeat 2drop ; 109 : l>bv ( list -- bv ) dup listlen bvtag newbox swap 0 swap begin dup pair? while 110 dup car unfix 3 pick bdat 3 pick + c! swap 1+ swap cdr repeat 2drop ; 111 : l>v ( list -- vec ) dup listlen cells vectag newbox swap 0 swap begin dup pair? while 112 dup car 3 pick bdat 3 pick cells + ! swap 1+ swap cdr repeat 2drop ; 113 114 \ --- symbols --- 115 : name ( sym -- addr len ) car unfix names + count ; 116 : intern ( addr len -- sym ) 117 syms @ begin dup while 118 >r 2dup r@ car name compare if 2drop r> car exit then r> cdr 119 repeat drop 120 ntop @ over + 1+ namesize > if s" symbol space full" err then 121 ntop @ >r dup r@ names + c! dup 1+ ntop +! r@ names + 1+ swap move 122 r> fix unbound cons 2 or dup syms @ cons syms ! ; 123 124 0 ntop ! 0 syms ! 0 nprims ! 0 nforms ! gc 125 token quote intern constant s-quote 126 token quasiquote intern constant s-qq token unquote intern constant s-uq 127 token unquote-splicing intern constant s-uqs token %syntax-rules intern constant s-%sr 128 token *handlers* intern constant s-handlers token %make-error intern constant s-mkerr 129 token raise intern constant s-raise token *winders* intern constant s-winders token %oport intern constant s-oport 130 token define intern constant s-define token define-syntax intern constant s-defsyn 131 token else intern constant s-else 132 token => intern constant s-=> 133 134 \ --- numbers: 31-bit fixnums (overflow is an error), exact rationals, single-precision flonums --- 135 \ A rational is a 110 cell: car rattag, cdr (numerator . denominator), normalized, denominator > 1. 136 \ A flonum is a 110 cell: car flotag, cdr the IEEE-754 single bits (the kernel's FPU words). 137 52 constant rattag 60 constant flotag 138 : rat? ( v -- f ) rattag box? ; 139 : flo? ( v -- f ) flotag box? ; 140 : numeric? ( v -- f ) dup fixnum? over rat? or swap flo? or ; 141 : ovf s" overflow" err ; 142 : fits? ( n -- f ) dup 1073741823 > swap -1073741824 < or 0= ; 143 : >fix ( n -- v ) dup fits? 0= if ovf then fix ; 144 : *c ( a b -- n ) m* over 0< if 1+ then if ovf then dup fits? 0= if ovf then ; 145 : +c ( a b -- n ) + dup fits? 0= if ovf then ; 146 : -c ( a b -- n ) - dup fits? 0= if ovf then ; 147 : flo ( bits -- v ) flotag swap cons 6 or ; 148 : gcd ( a b -- g ) abs swap abs begin dup while tuck mod repeat drop ; 149 : mkrat ( n d -- v ) dup 0= if s" division by zero" err then 150 dup 0< if negate swap negate swap then 151 2dup gcd tuck / >r / r> 152 dup 1 = if drop >fix exit then 153 >r >fix r> >fix cons rattag swap cons 6 or ; 154 : numden ( v -- n d ) dup fixnum? if unfix 1 exit then 155 dup rat? if cdr dup car unfix swap cdr unfix exit then s" not an exact number" err ; 156 0 variable n1 0 variable d1 0 variable n2 0 variable d2 157 : nd2 ( a b -- ) numden d2 ! n2 ! numden d1 ! n1 ! ; 158 : >float ( v -- bits ) dup fixnum? if unfix s>f exit then dup flo? if cdr exit then 159 dup rat? if cdr dup car unfix s>f swap cdr unfix s>f f/ exit then s" not a number" err ; 160 : inex? ( a b -- f ) flo? swap flo? or ; 161 : fl2 ( a b -- af bf ) >float swap >float swap ; 162 : add2 ( a b -- v ) 2dup inex? if fl2 f+ flo exit then 163 2dup and 1 and if unfix swap unfix +c fix exit then 164 nd2 n1 @ d2 @ *c n2 @ d1 @ *c +c d1 @ d2 @ *c mkrat ; 165 : sub2 ( a b -- v ) 2dup inex? if fl2 f- flo exit then 166 2dup and 1 and if unfix swap unfix swap -c fix exit then 167 nd2 n1 @ d2 @ *c n2 @ d1 @ *c -c d1 @ d2 @ *c mkrat ; 168 : mul2 ( a b -- v ) 2dup inex? if fl2 f* flo exit then 169 2dup and 1 and if unfix swap unfix *c fix exit then 170 nd2 n1 @ n2 @ *c d1 @ d2 @ *c mkrat ; 171 : div2 ( a b -- v ) 2dup inex? if fl2 f/ flo exit then 172 nd2 n2 @ 0= if s" division by zero" err then n1 @ d2 @ *c d1 @ n2 @ *c mkrat ; 173 : lt2 ( a b -- f ) 2dup inex? if fl2 f< exit then 174 2dup and 1 and if < exit then nd2 n1 @ d2 @ *c n2 @ d1 @ *c < ; 175 : eq2 ( a b -- f ) 2dup inex? if fl2 f= exit then nd2 n1 @ n2 @ = d1 @ d2 @ = and ; 176 : eqv ( a b -- f ) 2dup = if 2drop true exit then 177 2dup flo? swap flo? and if cdr swap cdr = exit then 178 2dup rat? swap rat? and if cdr swap cdr 2dup car swap car = >r cdr swap cdr = r> and exit then 179 2drop false ; 180 : fint? ( bits -- f ) dup 23 rshift 255 and dup 255 = if 2drop false exit then 181 150 >= if drop true exit then dup f>s s>f f= ; 182 : fexact ( bits -- v ) dup $7F800000 and $7F800000 = if s" no exact representation" err then 183 1 swap begin dup fint? 0= while $40000000 f* swap 2* swap over 1073741824 u> if ovf then repeat 184 dup $7FFFFFFF and $4E800000 f< 0= if ovf then f>s swap mkrat ; 185 : exact ( v -- v ) dup flo? if cdr fexact exit then dup numeric? 0= if s" not a number" err then ; 186 : inexact ( v -- v ) dup flo? if exit then >float flo ; 187 188 \ --- reader: lines come from the kernel's accept, which handles BS and DEL --- 189 : refill lbuf linesize accept llen ! 0 lpos ! cr ; 190 : getc ( -- c ) pk @ dup 0< 0= if -1 pk ! exit then drop 191 srcbox @ ?dup if spos @ over blen < if bdat spos @ + c@ 1 spos +! else drop 256 then exit then 192 lpos @ llen @ > if refill then 193 lpos @ llen @ = if 1 lpos +! 10 exit then 194 lbuf lpos @ + c@ 1 lpos +! ; 195 : skipws begin getc dup 59 = if drop begin getc dup 10 = swap 256 = or until 32 then dup 33 < while drop repeat pk ! ; 196 : delim? ( c -- f ) dup 33 < over 40 = or over 41 = or over 256 = or swap 59 = or ; 197 : rdtok ( n -- addr len ) begin getc dup delim? 0= while 198 over 63 < if over tok + c! 1+ else drop then repeat pk ! tok swap ; 199 : digits ( addr len -- u true | false ) dup 0= if 2drop false exit then 200 0 -rot over + swap do dup 107374182 > if drop false unloop exit then 201 10 * i c@ 48 - dup 9 u> if 2drop false unloop exit then + loop true ; 202 : num? ( addr len -- v true | false ) 203 over c@ 45 = if swap 1+ swap 1- digits if negate >fix true else false then exit then 204 over c@ 43 = if swap 1+ swap 1- then digits if >fix true else false then ; 205 0 variable fm 0 variable fe 0 variable fsaw 0 variable fneg 0 variable fpt 206 : dig? ( c -- f ) 48 - 10 u< ; 207 : /1 ( a n -- a+1 n-1 ) swap 1+ swap 1- ; 208 : adddig ( d -- ) s>f fm @ $41200000 f* f+ fm ! ; 209 : rdflo ( addr len -- v true | false ) 210 2dup s" +inf.0" compare if 2drop $7F800000 flo true exit then 211 2dup s" -inf.0" compare if 2drop $FF800000 flo true exit then 212 2dup s" +nan.0" compare if 2drop $7FC00000 flo true exit then 213 0 fm ! 0 fe ! 0 fsaw ! 0 fneg ! 0 fpt ! 214 over c@ 45 = if -1 fneg ! /1 else over c@ 43 = if /1 then then 215 begin dup if over c@ dig? else 0 then while over c@ 48 - adddig -1 fsaw ! /1 repeat 216 dup if over c@ 46 = if -1 fpt ! /1 217 begin dup if over c@ dig? else 0 then while over c@ 48 - adddig -1 fe +! -1 fsaw ! /1 repeat then then 218 fsaw @ 0= if 2drop false exit then 219 dup if over c@ 32 or 101 = if -1 fpt ! /1 num? 0= if false exit then unfix fe +! 0 0 220 else 2drop false exit then then 221 2drop fpt @ 0= if ovf then \ only digits, yet num? refused it: too big for a fixnum 222 fm @ fe @ dup 0< if negate 0 ?do $41200000 f/ loop else 0 ?do $41200000 f* loop then 223 fneg @ if $80000000 or then flo true ; 224 : slash ( addr len -- i | -1 ) 0 begin 2dup > while 2 pick over + c@ 47 = if nip nip exit then 1+ repeat 2drop drop -1 ; 225 : rdrat ( addr len -- v true | false ) 2dup slash dup 0< if drop 2drop false exit then 226 >r over r@ num? 0= if rdrop 2drop false exit then 227 -rot swap r@ 1+ + swap r> 1+ - digits 0= if drop false exit then 228 swap unfix swap mkrat true ; 229 : atom ( addr len -- v ) 2dup num? if nip nip exit then 230 2dup rdrat if nip nip exit then 2dup rdflo if nip nip exit then 231 2dup s" #t" compare if 2drop #t exit then 2dup s" #true" compare if 2drop #t exit then 232 2dup s" #f" compare if 2drop #f exit then 2dup s" #false" compare if 2drop #f exit then 233 intern ; 234 : rdstr ( -- list ) getc dup 34 = if drop 0 exit then dup 256 = if s" unexpected end of input" err then 235 dup 92 = if drop getc dup 110 = if drop 10 then dup 116 = if drop 9 then then 236 mkchar recurse cons ; 237 : cname ( addr len -- code | -1 ) 238 2dup s" space" compare if 2drop 32 exit then 2dup s" newline" compare if 2drop 10 exit then 239 2dup s" tab" compare if 2drop 9 exit then 2dup s" null" compare if 2drop 0 exit then 240 2dup s" alarm" compare if 2drop 7 exit then 2dup s" backspace" compare if 2drop 8 exit then 241 2dup s" delete" compare if 2drop 127 exit then 2dup s" escape" compare if 2drop 27 exit then 242 2dup s" return" compare if 2drop 13 exit then 243 over c@ 120 = if base @ >r 16 base ! /1 number r> base ! if exit then -1 exit then 244 2drop -1 ; 245 : rdchar ( -- v ) getc tok c! 1 rdtok dup 1 = if drop c@ mkchar exit then 246 cname dup 0< if drop s" bad character name" err then mkchar ; 247 : rdlist ( -- list ) skipws getc 248 dup 41 = if drop 0 exit then dup 256 = if s" unexpected end of input" err then 249 dup 46 = if drop getc dup delim? if drop (read) skipws getc drop exit then \ a lone . is the dot 250 pk ! 46 tok c! 1 rdtok atom recurse cons exit then \ ... .5 start a token 251 pk ! (read) recurse cons ; 252 : read ( -- v ) skipws getc 253 dup 256 = if drop eofv exit then 254 dup 40 = if drop rdlist exit then 255 dup 39 = if drop s-quote recurse 0 cons cons exit then 256 dup 96 = if drop s-qq recurse 0 cons cons exit then 257 dup 44 = if drop getc dup 64 = if drop s-uqs else pk ! s-uq then recurse 0 cons cons exit then 258 dup 41 = if drop s" unexpected )" err then 259 dup 34 = if drop rdstr l>s exit then 260 dup 35 = if drop getc dup 40 = if drop rdlist l>v exit then 261 dup 92 = if drop rdchar exit then 262 dup 117 = if drop getc drop getc drop rdlist l>bv exit then \ #u8( 263 pk ! 35 tok c! 1 rdtok atom exit then 264 pk ! 0 rdtok atom ; 265 ' read 'read ! 266 267 \ --- printer --- 268 : pint ( n -- ) dup 0< if 45 emit negate then 0 <# #s #> type ; 269 : pdigits ( E addr len -- ) rot dup -5 < over 9 > or if 270 >r over c@ emit 46 emit 1- swap 1+ swap dup if type else 2drop 48 emit then 101 emit r> pint exit then 271 dup 0< if ." 0." negate 1- 0 ?do 48 emit loop type exit then 272 1+ 2dup < if over - >r type r> 0 ?do 48 emit loop ." .0" exit then 273 >r over r@ type swap r@ + swap r> - 46 emit dup if type else 2drop 48 emit then ; 274 : pflo ( bits -- ) \ ponytail: 7 significant digits from float scaling; the last digit can be off by one, 275 \ so output need not read back to the same float. Shortest round-trip printing needs 64-bit digit generation. 276 dup $7F800000 and $7F800000 = if dup $7FFFFF and if drop ." +nan.0" exit then 277 0< if ." -inf.0" else ." +inf.0" then exit then 278 dup 0< if 45 emit $7FFFFFFF and then 279 dup 0= if drop ." 0.0" exit then 280 0 swap begin dup $4B189680 f< 0= while $41200000 f/ swap 1+ swap repeat 281 begin dup $49742400 f< while $41200000 f* swap 1- swap repeat 282 $3F000000 f+ f>s dup 9999999 > if 10 / swap 1+ swap then 283 swap 6 + swap 0 <# #s #> 284 begin dup 1 > if 2dup + 1- c@ 48 = else 0 then while 1- repeat pdigits ; 285 : pnum ( v -- ) unfix pint ; 286 : pchar ( v -- ) charcode raw @ if emit exit then ." #\" 287 dup 32 = if drop ." space" exit then dup 10 = if drop ." newline" exit then 288 dup 9 = if drop ." tab" exit then dup 0= if drop ." null" exit then emit ; 289 : pstr ( box -- ) raw @ if dup bdat swap blen type exit then 290 34 emit dup blen 0 ?do dup bdat i + c@ 291 dup 34 = over 92 = or if 92 emit then dup 10 = if drop 92 emit 110 emit else emit then loop drop 34 emit ; 292 : pvec ( box -- ) ." #(" dup blen 2 rshift 0 ?do i if space then dup bdat i cells + @ (print) loop drop 41 emit ; 293 : pbv ( box -- ) ." #u8(" dup blen 0 ?do i if space then dup bdat i + c@ pint loop drop 41 emit ; 294 : print ( v -- ) 295 dup fixnum? if pnum exit then 296 dup 0= if drop ." ()" exit then 297 dup sym? if name type exit then 298 dup #t = if drop ." #t" exit then 299 dup #f = if drop ." #f" exit then 300 dup char? if pchar exit then 301 dup strtag box? if pstr exit then 302 dup vectag box? if pvec exit then 303 dup bvtag box? if pbv exit then 304 dup rat? if cdr dup car pnum 47 emit cdr pnum exit then 305 dup flo? if cdr pflo exit then 306 dup eofv = if drop ." #<eof>" exit then 307 dup mactag box? if drop ." #<macro>" exit then 308 dup conttag box? if drop ." #<continuation>" exit then 309 dup rectag box? if ." #<record " cdr bdat @ recurse ." >" exit then 310 dup proc? if drop ." #<procedure>" exit then 311 dup special? if drop ." #<syntax>" exit then 312 dup pair? 0= if drop exit then 313 40 emit begin dup car recurse cdr 314 dup 0= if drop 41 emit exit then 315 dup pair? 0= if ." . " recurse 41 emit exit then space again ; 316 ' print 'print ! 317 318 \ --- environments --- 319 : where ( sym env -- binding | 0 ) 320 begin dup while 2dup car car = if nip car exit then cdr repeat 2drop 0 ; 321 : lookup ( sym env -- v ) over swap where ?dup if nip cdr exit then 322 dup cdr dup unbound <> if nip exit then drop s" unbound variable" errv ; 323 : frame ( env -- env' ) #f #f cons swap cons ; \ a dummy binding that internal defines can follow 324 : bind ( params args env -- env' ) 325 begin 2 pick pair? while over pair? 0= if s" too few arguments" err then 326 2 pick car 2 pick car cons swap cons rot cdr rot cdr rot repeat 327 rot dup 0= if drop swap if s" too many arguments" err then exit then 328 rot cons swap cons ; 329 : def-bind ( val sym env -- ) dup 0= if drop cdr! exit then 330 >r swap cons r@ car r@ cdr cons r@ cdr! r> car! ; 331 : closure ( params body env -- proc ) cons cons 6 or ; 332 : evlis ( list env -- list' ) over 0= if drop exit then 333 over car over (eval) >r swap cdr swap recurse r> swap cons ; 334 335 \ --- eval: handlers return ( x env 0 ) for a tail call or ( v -1 ) for a value --- 336 : seq ( body env -- x env 0 | v -1 ) over 0= if 2drop unspec -1 exit then 337 begin over cdr while over car over (eval) drop swap cdr swap repeat swap car swap 0 ; 338 0 variable kval 0 variable krp 339 : throwk ( v k -- ) dup cdr #f = if s" continuation called outside its extent (escape-only)" err then 340 swap kval ! cdr dup cdr unfix krp ! car unfix sp! kval @ krp @ rp! ; 341 : arity? ( f args -- f args ) over cdr dup 0= if drop exit then unfix over listlen 342 over 255 and over > if s" wrong number of arguments" err then 343 swap 8 rshift 255 and dup 255 = if 2drop exit then > if s" wrong number of arguments" err then ; 344 : applyc ( f args -- x env 0 | v -1 ) 345 over conttag box? if car swap throwk then 346 over proc? 0= if s" not a procedure" err then 347 over car fixnum? if arity? swap car unfix cells prims + @ execute -1 exit then 348 over car swap rot cdr dup >r cdr frame bind r> car swap seq ; 349 : apply ( f args -- v ) applyc if exit then (eval) ; 350 : eval ( x env -- v ) 351 begin 352 rp@ rsave @ 3500 - u< sp@ ssave @ 3500 - u< or if s" too deep" err then \ 4 KiB stacks 353 over sym? if lookup exit then 354 over pair? 0= if drop exit then 355 over car over recurse 356 dup mactag box? if cdr rot 0 cons apply swap 0 else 357 dup special? if 3 rshift 16 - cells forms + @ execute 358 else -rot swap cdr swap evlis applyc then then 359 until ; 360 ' eval 'eval ! 361 362 : defform ( xt "name" -- ) nforms @ cells forms + ! 363 nforms @ 16 + 3 lshift 4 or token intern cdr! 1 nforms +! ; 364 365 : f-quote ( x env ) drop cdr car -1 ; 366 : f-if ( x env ) >r cdr dup car r@ (eval) truth if cdr car else cdr cdr dup if car else drop unspec then then r> 0 ; 367 : f-lambda ( x env ) >r cdr dup car swap cdr r> closure -1 ; 368 : f-begin ( x env ) swap cdr swap seq ; 369 : f-define ( x env ) swap cdr dup car sym? if 370 dup car >r cdr car over (eval) r@ rot def-bind rdrop unspec -1 exit then 371 dup car car >r dup car cdr swap cdr 2 pick closure r@ rot def-bind rdrop unspec -1 ; 372 : f-set ( x env ) swap cdr dup car >r cdr car over (eval) swap r@ swap where 373 ?dup if cdr! else r@ cdr! then rdrop unspec -1 ; 374 : lbind ( binds env eenv -- env' ) \ evaluate each (name expr) in eenv, bind onto env 375 begin 2 pick while 2 pick car dup car swap cdr car 2 pick (eval) cons 376 rot cons swap rot cdr -rot repeat drop nip ; 377 : lbind* ( binds env -- env' ) begin over while 378 over car dup car swap cdr car 2 pick (eval) cons swap cons swap cdr swap repeat nip ; 379 : cars ( list -- list' ) dup 0= if exit then dup car car swap cdr recurse cons ; 380 : evargs ( binds env -- vals ) over 0= if drop exit then 381 over car cdr car over (eval) >r swap cdr swap recurse r> swap cons ; 382 : namedlet ( env rest -- x env 0 ) 383 dup cdr car 2 pick evargs >r 384 dup car unbound cons >r 385 swap frame r@ swap cons 386 over cdr car cars rot cdr cdr 2 pick closure 387 dup r> cdr! nip r> applyc ; 388 : f-let ( x env ) swap cdr dup car sym? if namedlet exit then 389 dup car rot dup frame swap lbind swap cdr swap seq ; 390 : f-let* ( x env ) swap cdr dup car rot frame lbind* swap cdr swap seq ; 391 : prebind ( binds env -- env' ) begin over while over car car unbound cons swap cons swap cdr swap repeat nip ; 392 : setall ( binds env -- ) begin over while 393 over car cdr car over (eval) 2 pick car car 2 pick where cdr! swap cdr swap repeat 2drop ; 394 : f-letrec ( x env ) swap cdr dup car rot frame over swap prebind tuck setall swap cdr swap seq ; 395 : f-cond ( x env ) swap cdr begin dup while 396 dup car car s-else = if car cdr swap seq exit then 397 dup car car 2 pick (eval) dup truth if 398 swap car cdr dup 0= if drop nip -1 exit then 399 dup car s-=> = if cdr car 2 pick (eval) rot drop swap 0 cons applyc exit then 400 nip swap seq exit then 401 drop cdr repeat 2drop unspec -1 ; 402 : memq ( v list -- f ) begin dup pair? while 2dup car = if 2drop true exit then cdr repeat 2drop false ; 403 : f-case ( x env ) swap cdr dup car 2 pick (eval) swap cdr begin dup while 404 dup car car dup s-else = swap 3 pick swap memq or if 405 car cdr dup car s-=> = if cdr car 2 pick (eval) rot drop swap 0 cons applyc exit then 406 nip swap seq exit then 407 cdr repeat drop 2drop unspec -1 ; 408 : f-and ( x env ) swap cdr dup 0= if 2drop #t -1 exit then 409 begin dup cdr while dup car 2 pick (eval) truth 0= if 2drop #f -1 exit then cdr repeat car swap 0 ; 410 : f-or ( x env ) swap cdr dup 0= if 2drop #f -1 exit then 411 begin dup cdr while dup car 2 pick (eval) dup truth if nip nip -1 exit then drop cdr repeat car swap 0 ; 412 : f-when ( x env ) >r cdr dup car r@ (eval) truth if cdr r> seq else drop rdrop unspec -1 then ; 413 : f-unless ( x env ) >r cdr dup car r@ (eval) truth if drop rdrop unspec -1 else cdr r> seq then ; 414 : seqall ( body env -- ) begin over while over car over (eval) drop swap cdr swap repeat 2drop ; 415 : stepvals ( vars env -- vals ) over 0= if drop exit then 416 over car cdr cdr dup if car over (eval) else drop over car car over lookup then 417 >r swap cdr swap recurse r> swap cons ; 418 : f-import ( x env ) 2drop unspec -1 ; 419 : f-syntax-rules ( x env ) drop cdr 0 cons s-%sr cdr swap apply -1 ; 420 : f-do ( x env ) swap cdr swap over car over dup frame swap lbind 421 begin 2 pick cdr car car over (eval) truth 0= while 422 2 pick cdr cdr over seqall 423 2 pick car over stepvals nip 2 pick car cars swap 2 pick frame bind 424 repeat nip swap cdr car cdr swap seq ; 425 426 ' f-quote defform quote ' f-if defform if ' f-lambda defform lambda 427 ' f-begin defform begin ' f-define defform define ' f-set defform set! 428 ' f-let defform let ' f-let* defform let* ' f-letrec defform letrec 429 ' f-letrec defform letrec* ' f-cond defform cond ' f-case defform case 430 ' f-and defform and ' f-or defform or ' f-when defform when 431 ' f-unless defform unless ' f-do defform do 432 ' f-define defform define-syntax ' f-let defform let-syntax ' f-letrec defform letrec-syntax 433 ' f-syntax-rules defform syntax-rules ' f-import defform import 434 435 \ --- primitives written in Forth; prims.lisp adds the rest --- 436 : defprim ( xt "name" -- ) token intern >r nprims @ dup 1+ nprims ! 437 tuck cells prims + ! fix 0 cons 6 or r> cdr! ; 438 : spread ( list -- list' ) dup cdr 0= if car exit then dup car swap cdr recurse cons ; 439 : p-apply ( args -- v ) dup car swap cdr spread apply ; 440 : rfield ( rec i -- v ) swap cdr bdat swap 1+ cells + @ ; 441 : rfield! ( v rec i -- ) swap cdr bdat swap 1+ cells + ! ; 442 0 variable curport 443 : capture ( c -- ) mkchar curport @ 0 rfield cons curport @ 0 rfield! ; \ emit-hook for string ports 444 : >port ( port -- ) dup rectag box? if dup cdr bdat @ s-oport = if curport ! ['] capture emit-hook ! exit then then drop ; 445 : >console ( -- ) 0 emit-hook ! 0 curport ! ; 446 : p-display ( args -- v ) dup cdr if dup cdr car >port then 1 raw ! car print 0 raw ! >console unspec ; 447 : p-write ( args -- v ) dup cdr if dup cdr car >port then car print >console unspec ; 448 0 variable fsz 449 : arg2 ( args -- a b ) dup car swap cdr car ; 450 : arg3 ( args -- a b c ) dup car swap cdr dup car swap cdr car ; 451 : ix ( box i size -- addr ) >r over blen r@ / over u> 0= if s" index out of range" err then r> * swap bdat + ; 452 : range ( box s e size -- box s e ) >r 2dup > if s" bad range" err then 453 over 0< if s" bad range" err then 2 pick blen r> / over < if s" bad range" err then ; 454 : p-string? ( args -- v ) car strtag box? bool ; 455 : p-vector? ( args -- v ) car vectag box? bool ; 456 : p-bv? ( args -- v ) car bvtag box? bool ; 457 : p-char? ( args -- v ) car char? bool ; 458 : p-c>i ( args -- v ) car dup char? 0= if s" not a character" err then charcode fix ; 459 : p-i>c ( args -- v ) car num mkchar ; 460 : p-slen ( args -- v ) car strtag chk blen fix ; 461 : p-vlen ( args -- v ) car vectag chk blen 2 rshift fix ; 462 : p-bvlen ( args -- v ) car bvtag chk blen fix ; 463 : p-sref ( args -- v ) arg2 num swap strtag chk swap 1 ix c@ mkchar ; 464 : p-sset ( args -- v ) arg3 charcode >r num swap strtag chk swap 1 ix r> swap c! unspec ; 465 : p-vref ( args -- v ) arg2 num swap vectag chk swap 4 ix @ ; 466 : p-vset ( args -- v ) arg3 >r num swap vectag chk swap 4 ix r> swap ! unspec ; 467 : p-bvref ( args -- v ) arg2 num swap bvtag chk swap 1 ix c@ fix ; 468 : p-bvset ( args -- v ) arg3 num >r num swap bvtag chk swap 1 ix r> swap c! unspec ; 469 : fillbox ( k tag c size -- box ) \ a new box of k elements, each c; c stays on the stack (a GC root) 470 fsz ! -rot over fsz @ * swap newbox swap 0 ?do 471 dup bdat i fsz @ * + 2 pick fsz @ 1 = if swap c! else swap ! then loop nip ; 472 : opt ( args default -- x ) over cdr if drop cdr car else nip then ; 473 : p-mkstr ( args -- v ) dup car num swap 32 mkchar opt charcode strtag swap 1 fillbox ; 474 : p-mkvec ( args -- v ) dup car num swap #f opt vectag swap 4 fillbox ; 475 : p-mkbv ( args -- v ) dup car num swap 1 opt unfix bvtag swap 1 fillbox ; 476 : >list ( box s e size -- list ) \ elements s..e-1 as a list: chars, values or byte fixnums 477 >r 0 swap begin 2 pick over < while 1- 478 3 pick bdat over r@ * + r@ 1 = if c@ else @ then 479 4 pick strtag box? if mkchar else 4 pick bvtag box? if fix then then 480 rot cons swap repeat drop nip nip rdrop ; 481 : p-s>l ( args -- v ) arg3 num >r num r> 2 pick strtag chk drop 1 range 1 >list ; 482 : p-v>l ( args -- v ) arg3 num >r num r> 2 pick vectag chk drop 4 range 4 >list ; 483 : p-bv>l ( args -- v ) car bvtag chk 0 over blen 1 >list ; 484 : p-l>s ( args -- v ) car l>s ; 485 : p-l>v ( args -- v ) car l>v ; 486 : p-l>bv ( args -- v ) car l>bv ; 487 : ssub ( box s e -- str ) 1 range over - dup strtag newbox >r rot bdat rot + r@ bdat rot move r> ; 488 : p-substr ( args -- v ) arg3 num >r num r> 2 pick strtag chk drop ssub ; 489 : p-sapp ( args -- v ) arg2 strtag chk swap strtag chk swap 490 over blen over blen + strtag newbox >r 491 over bdat r@ bdat 3 pick blen move 492 dup bdat r@ bdat 3 pick blen + 2 pick blen move 2drop r> ; 493 : scmp ( a b -- n ) over blen over blen min 0 ?do over bdat i + c@ over bdat i + c@ - ?dup if 494 nip nip 0< if -1 else 1 then unloop exit then loop 495 blen swap blen swap - dup 0< if drop -1 else 0> if 1 else 0 then then ; 496 : p-scmp ( args -- v ) arg2 strtag chk swap strtag chk swap scmp fix ; 497 : p-s>sym ( args -- v ) car strtag chk dup blen 63 min >r bdat tok r@ move tok r> intern ; 498 : p-sym>s ( args -- v ) car dup sym? 0= if s" not a symbol" err then 499 name dup strtag newbox dup >r bdat swap move r> ; 500 : p-newline ( args -- v ) dup if car >port else drop then cr >console unspec ; 501 : p-pread ( args -- v ) car pk @ >r -1 pk ! dup 0 rfield srcbox ! dup 1 rfield unfix spos ! 502 read pk @ dup 0< 0= swap 256 <> and if -1 spos +! then 503 swap spos @ fix swap 1 rfield! 0 srcbox ! r> pk ! ; 504 : p-unsrc ( args -- v ) drop 0 srcbox ! unspec ; 505 : p-rcons ( args -- v ) drop read ; 506 : p-eof ( args -- v ) drop eofv ; 507 : p-eof? ( args -- v ) car eofv = bool ; 508 : p-set-car ( args -- v ) dup cdr car swap car pair car! unspec ; 509 : p-set-cdr ( args -- v ) dup cdr car swap car pair cdr! unspec ; 510 : p-forth ( args -- ) drop ssave @ sp! rsave @ rp! ; 511 : p-macro ( args -- v ) car mactag swap cons 6 or ; 512 : p-callcc ( args -- v ) \ escape-only: k returns from this call while the call is active 513 car sp@ 4 + fix rp@ fix cons conttag swap cons 6 or tuck 0 cons apply swap #f swap cdr! ; 514 : p-mkrec ( args -- v ) l>v rectag swap cons 6 or ; 515 : p-rec? ( args -- v ) car rectag box? bool ; 516 : p-rectype ( args -- v ) car rectag chk cdr bdat @ ; 517 : p-recref ( args -- v ) arg2 num 1+ swap rectag chk cdr swap 4 ix @ ; 518 : p-recset ( args -- v ) arg3 >r num 1+ swap rectag chk cdr swap 4 ix r> swap ! unspec ; 519 : p-reset ( args -- ) drop repl-reset ; 520 : p-arity! ( args -- v ) arg3 num 8 lshift swap num or fix swap cdr 521 dup proc? 0= if s" not a primitive" err then cdr! unspec ; 522 : raise-error ( i a n -- i a n ) \ with a Scheme handler installed, raise an error object 523 inerr @ if exit then s-handlers cdr pair? 0= if exit then rsave @ 0= if exit then 524 -1 inerr ! 2 pick 2 pick 2 pick 525 dup strtag newbox >r r@ bdat swap move r> ( i a n i str ) 526 swap dup unspec = if drop 0 else 0 cons then ( i a n str irritants ) 527 0 cons cons s-mkerr cdr swap apply ( i a n error-object ) 528 0 inerr ! s-raise cdr swap 0 cons apply drop ; 529 ' raise-error 'raise-error ! 530 : p-exact ( args -- v ) car exact ; 531 : p-inexact ( args -- v ) car inexact ; 532 : p-eqv ( args -- v ) dup car swap cdr car eqv bool ; 533 : p-number? ( args -- v ) car numeric? bool ; 534 : p-integer? ( args -- v ) car dup fixnum? if drop #t exit then dup flo? if cdr fint? bool exit then drop #f ; 535 : p-rational? ( args -- v ) car dup flo? if cdr $7F800000 and $7F800000 <> bool exit then dup fixnum? swap rat? or bool ; 536 : p-exact? ( args -- v ) car dup numeric? 0= if s" not a number" err then dup fixnum? swap rat? or bool ; 537 : p-inexact? ( args -- v ) car dup numeric? 0= if s" not a number" err then flo? bool ; 538 : p-exint? ( args -- v ) car fixnum? bool ; 539 : p-num ( args -- v ) car numden drop >fix ; 540 : p-den ( args -- v ) car numden nip >fix ; 541 : p-nan? ( args -- v ) car dup flo? if cdr dup $7F800000 and $7F800000 = swap $7FFFFF and 0<> and bool exit then drop #f ; 542 : p-ftrunc ( args -- v ) car cdr dup fint? if flo exit then f>s s>f flo ; \ toward zero 543 : p-fsqrt ( args -- v ) car >float fsqrt flo ; 544 : p-inf? ( args -- v ) car dup flo? if cdr $7FFFFFFF and $7F800000 = bool exit then drop #f ; 545 ' p-exact defprim exact ' p-inexact defprim inexact ' p-eqv defprim eqv? 546 ' p-number? defprim number? ' p-number? defprim real? ' p-number? defprim complex? 547 ' p-integer? defprim integer? ' p-rational? defprim rational? 548 ' p-exact? defprim exact? ' p-inexact? defprim inexact? ' p-exint? defprim exact-integer? 549 ' p-ftrunc defprim %ftruncate ' p-fsqrt defprim %fsqrt 550 ' p-num defprim %numerator ' p-den defprim %denominator ' p-nan? defprim nan? ' p-inf? defprim infinite? 551 ' p-apply defprim apply ' p-display defprim display ' p-write defprim write 552 ' p-string? defprim string? ' p-vector? defprim vector? ' p-bv? defprim bytevector? 553 ' p-char? defprim char? ' p-c>i defprim char->integer ' p-i>c defprim integer->char 554 ' p-slen defprim string-length ' p-vlen defprim vector-length ' p-bvlen defprim bytevector-length 555 ' p-sref defprim string-ref ' p-sset defprim string-set! ' p-vref defprim vector-ref 556 ' p-vset defprim vector-set! ' p-bvref defprim bytevector-u8-ref ' p-bvset defprim bytevector-u8-set! 557 ' p-mkstr defprim make-string ' p-mkvec defprim make-vector ' p-mkbv defprim make-bytevector 558 ' p-s>l defprim %string->list ' p-v>l defprim %vector->list ' p-bv>l defprim %bytevector->list 559 ' p-l>s defprim list->string ' p-l>v defprim list->vector ' p-l>bv defprim list->bytevector 560 ' p-substr defprim %substring ' p-sapp defprim %string-append2 ' p-scmp defprim %string-compare 561 ' p-s>sym defprim string->symbol ' p-sym>s defprim symbol->string 562 ' p-newline defprim newline ' p-pread defprim %pread ' p-unsrc defprim %unsrc 563 ' 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! 564 ' p-forth defprim forth 565 ' p-macro defprim %macro ' p-callcc defprim %callcc ' p-mkrec defprim %make-record 566 ' p-rec? defprim %record? ' p-rectype defprim %record-type ' p-recref defprim %record-ref 567 ' p-recset defprim %record-set! ' p-reset defprim %repl-reset ' p-arity! defprim %arity! 568 569 : echo ( v form -- v' ) \ for a top-level (define name ...), show the name instead of nothing 570 over unspec <> if drop exit then dup pair? 0= if drop exit then 571 dup car dup s-define = swap s-defsyn = or 0= if drop exit then 572 cdr car dup pair? if car then nip ; 573 : repl begin 0 raw ! 0 s-handlers cdr! 0 s-winders cdr! \ an escape to the prompt leaves no handlers or winders 574 ." > " read dup >r 0 eval r> echo dup unspec = if drop else print then cr again ; 575 ' repl 'repl ! 576 : lisp ( -- ) sp@ ssave ! rp@ rsave ! 1 lpos ! 0 llen ! -1 pk ! cr repl ;