lisp.fs (12768 bytes)
1 \ lisp.fs -- layer 4: a small Scheme written in Forth words, loaded through the Z80 Forth. 2 \ Values are 16-bit. A heap object is one 4-byte cell (car, cdr) plus a type byte: 3 \ 1 pair 2 symbol (car: counted name, cdr: global value) 3 closure ((params . body) . env) 4 \ 4 primitive (car: xt) 5 number (32-bit: car low, cdr high) 6 string (car: char list) 5 \ 7 vector (car: element list) 8 macro (car: transformer closure). Bit 7: GC mark. 6 \ Immediates: () = 0, #f = 2, #t = 4, unspecified = 6, unbound = 8. 7 8 : tuck swap over ; 9 : -rot rot rot ; 10 : 2swap rot >r rot r> ; 11 : 0<> 0= 0= ; 12 : abs dup 0< if negate then ; 13 : dnegate invert swap invert swap 1 0 d+ ; 14 : d- dnegate d+ ; 15 : dabs dup 0< if dnegate then ; 16 : d= rot = >r = r> and ; 17 : d< rot 2dup = if 2drop u< else > nip nip then ; 18 : d> 2swap d< ; 19 : d<= d> 0= ; 20 : d>= d< 0= ; 21 : d* >r swap >r 2dup um* 2swap r> * swap r> * + + ; 22 : mu/mod >r 0 r@ um/mod r> swap >r um/mod r> ; 23 24 0 constant nil 25 2 constant false 26 4 constant true 27 6 constant unspec 28 8 constant unbound 29 : bool if true else false then ; 30 31 \ ---- heap and garbage collector (mark-sweep; stacks are scanned conservatively) 32 7000 constant #cells 33 create heap0 #cells 4 * 4 + allot 34 heap0 3 + -4 and constant heap 35 create types #cells allot 36 variable free 37 variable symlist 38 variable errobj 39 variable errmsg 40 variable errlen 41 variable display? 42 : cell# heap - 2/ 2/ ; 43 : type@ cell# types + c@ 127 and ; 44 : heap? dup heap - #cells 4 * u< over 3 and 0= and if cell# types + c@ 127 and 0<> else drop 0 then ; 45 : car @ ; 46 : cdr 2 + @ ; 47 : cadr cdr car ; 48 : cddr cdr cdr ; 49 : caddr cddr car ; 50 : set-cdr 2 + ! ; 51 : typ? over heap? if swap type@ = else 2drop 0 then ; 52 : pair? 1 typ? ; 53 : lerror errlen ! errmsg ! errobj ! -100 throw ; 54 : mark 55 begin dup heap? while 56 dup cell# types + dup c@ dup 128 and if 2drop drop exit then 57 128 or swap c! 58 dup type@ dup 1 = over 3 = or swap 8 = or if dup car recurse cdr else 59 dup type@ 2 = if cdr else 60 dup type@ dup 6 = swap 7 = or if car else drop 0 then then then 61 repeat drop ; 62 : scan-data sp@ begin dup while dup @ mark 2 + repeat drop ; 63 : scan-return rp@ begin dup r0 u< while dup @ mark 2 + repeat drop ; 64 : sweep 0 free ! 0 65 begin dup #cells < while 66 dup types + dup c@ dup 128 and 67 if 127 and swap c! else drop 0 swap c! dup 4 * heap + free @ over set-cdr free ! then 68 1+ repeat drop ; 69 : gc symlist @ mark scan-data scan-return sweep ; 70 : alloc free @ 0= if gc free @ 0= if 0 s" out of memory" lerror then then 71 free @ dup cdr free ! tuck cell# types + c! ; 72 : mk2 alloc tuck set-cdr tuck ! ; 73 : cons 1 mk2 ; 74 : mknum 5 mk2 ; 75 : num@ dup car swap cdr ; 76 : num? 5 typ? ; 77 : n@ dup num? 0= if s" not a number" lerror then num@ ; 78 : >num dup 0< mknum ; 79 : snoc 0 cons over if tuck swap set-cdr else nip nip dup then ; 80 : len 0 swap begin dup pair? while swap 1+ swap cdr repeat drop ; 81 types #cells 0 fill 82 sweep 83 84 \ ---- symbols 85 : sym-name car count ; 86 : name= sym-name rot over = if s= else 2drop drop 0 then ; 87 : mksym here >r dup c, here swap dup allot cmove r> unbound 2 mk2 dup symlist @ cons symlist ! ; 88 : intern symlist @ begin dup while >r 2dup r@ car name= if 2drop r> car exit then r> cdr repeat drop mksym ; 89 s" quote" intern constant 'quote 90 s" if" intern constant 'if 91 s" define" intern constant 'define 92 s" set!" intern constant 'set! 93 s" lambda" intern constant 'lambda 94 s" begin" intern constant 'begin 95 s" define-macro" intern constant 'define-macro 96 97 \ ---- environments: a list of frames, each frame an alist; globals live in the symbol 98 : assq begin dup while 2dup car car = if nip car exit then cdr repeat nip ; 99 : lookup begin dup while 2dup car assq ?dup if nip nip cdr exit then cdr repeat 100 drop dup cdr dup unbound = if drop s" unbound variable" lerror then nip ; 101 : set-var begin dup while 2dup car assq ?dup if nip nip set-cdr exit then cdr repeat drop set-cdr ; 102 : define-var dup if >r swap cons r@ car cons r> ! else drop set-cdr then ; 103 104 \ ---- evaluator; eval-step returns ( x' env' 0 ) for a tail call or ( v -1 ) when done 105 variable 'eval 106 : eval* 'eval @ execute ; 107 : evlis 0 0 2swap begin over while over car over eval* >r 2swap r> snoc 2swap swap cdr swap repeat 2drop drop ; 108 : bind over 0= if 2drop 0 exit then 109 over 2 typ? if cons 0 cons exit then 110 over car over car cons >r cdr swap cdr swap recurse r> swap cons ; 111 : eval-body begin over cdr while over car over eval* drop swap cdr swap repeat swap car swap ; 112 : closure-env over car car swap bind over cdr cons swap car cdr swap ; 113 : apply-proc over 4 typ? if swap car execute exit then 114 over 3 typ? if closure-env eval-body eval* exit then 115 drop s" not a procedure" lerror ; 116 : expand car swap 0 cons apply-proc ; 117 : replace dup pair? 0= if 0 cons 'begin swap cons then 118 2dup car swap ! cdr swap set-cdr ; 119 : macro-of dup 2 typ? if cdr dup 8 typ? if exit then then drop 0 ; 120 : do-if >r cdr dup car r@ eval* false = if cddr dup if car else drop unspec then else cadr then r> ; 121 : define-form dup car dup pair? if dup car >r cdr swap cdr cons 'lambda swap cons r> swap exit then swap cadr ; 122 : do-define >r cdr define-form r@ eval* over r> define-var ; 123 : do-set >r cdr dup cadr r@ eval* swap car r> set-var unspec ; 124 : do-defmacro >r cdr dup cadr r> eval* 0 8 mk2 swap car tuck set-cdr ; 125 : eval-step 126 over heap? 0= if drop -1 exit then 127 over 2 typ? if lookup -1 exit then 128 over pair? 0= if drop -1 exit then 129 over car 130 dup 'quote = if 2drop cadr -1 exit then 131 dup 'if = if drop do-if 0 exit then 132 dup 'define = if drop do-define -1 exit then 133 dup 'set! = if drop do-set -1 exit then 134 dup 'lambda = if drop swap cdr swap 3 mk2 -1 exit then 135 dup 'begin = if drop swap cdr dup 0= if 2drop unspec -1 exit then swap eval-body 0 exit then 136 dup 'define-macro = if drop do-defmacro -1 exit then 137 dup macro-of ?dup if nip >r over r> expand >r over r> replace 0 exit then 138 drop over car over eval* >r swap cdr swap evlis r> swap 139 over 3 typ? if closure-env eval-body 0 exit then 140 apply-proc -1 ; 141 : eval begin eval-step until ; 142 ' eval 'eval ! 143 144 \ ---- printer 145 : ud. 10 mu/mod 2dup or if recurse else 2drop then 48 + emit ; 146 : .num dup 0< if 45 emit dnegate then ud. ; 147 : .string display? @ if car begin dup while dup car car emit cdr repeat drop exit then 148 34 emit car begin dup while dup car car dup 34 = over 92 = or if 92 emit then emit cdr repeat drop 34 emit ; 149 : print 150 dup nil = if drop ." ()" exit then 151 dup false = if drop ." #f" exit then 152 dup true = if drop ." #t" exit then 153 dup unspec = if drop exit then 154 dup heap? 0= if drop ." #<?>" exit then 155 dup type@ 156 dup 5 = if drop num@ .num exit then 157 dup 2 = if drop sym-name type exit then 158 dup 6 = if drop .string exit then 159 dup 7 = if drop 35 emit car recurse exit then 160 dup 8 = if 2drop ." #<macro>" exit then 161 dup 1 = if drop 40 emit dup car recurse cdr 162 begin dup pair? while 32 emit dup car recurse cdr repeat 163 dup if ." . " recurse else drop then 41 emit exit then 164 2drop ." #<procedure>" ; 165 166 \ ---- reader 167 : adv 1 >in +! ; 168 : skip-ws begin more? if in-char dup 59 = if drop #tib @ >in ! 0 else 33 < then else 0 then while adv repeat ; 169 : delim? dup 33 < over 40 = or over 41 = or over 34 = or swap 59 = or ; 170 : token tib >in @ + 0 begin more? if in-char delim? 0= else 0 then while 1+ adv repeat ; 171 : snumber over c@ 45 = dup >r if 1- swap 1+ swap then dup 0= if 2drop r> drop 0 exit then 172 0 0 2swap begin dup while over c@ 48 - dup 10 u< 0= if 2drop 2drop drop r> drop 0 exit then 173 >r 2swap 10 0 d* r> 0 d+ 2swap 1- swap 1+ swap repeat 174 2drop r> if dnegate then mknum -1 ; 175 : read-atom token 2dup snumber if nip nip exit then intern ; 176 variable 'read 177 : read* 'read @ execute ; 178 : dot? in-char 46 = if >in @ 1+ #tib @ < if tib >in @ 1+ + c@ delim? else -1 then else 0 then ; 179 : read-tail 0 0 begin skip-ws more? 0= if 0 s" unbalanced (" lerror then in-char 41 <> while 180 dot? if adv read* swap set-cdr skip-ws adv exit then 181 read* snoc repeat adv drop ; 182 : read-hash adv in-char 40 = if adv read-tail 0 7 mk2 exit then 183 token drop c@ 116 = if true else false then ; 184 : read-string adv 0 0 begin more? if in-char 34 <> else 0 then while 185 in-char 92 = if adv in-char 110 = if 10 else in-char then else in-char then adv >num snoc repeat 186 adv drop 0 6 mk2 ; 187 : read skip-ws in-char 188 dup 40 = if drop adv read-tail exit then 189 dup 39 = if drop adv read* 0 cons 'quote swap cons exit then 190 dup 34 = if drop read-string exit then 191 dup 35 = if drop read-hash exit then 192 dup 41 = if drop adv 0 s" unexpected )" lerror then 193 drop read-atom ; 194 ' read 'read ! 195 196 \ ---- primitives: each takes the evaluated argument list and returns a value 197 : prim: parse-name intern >r 4 alloc tuck ! r> set-cdr ; 198 : pcar car dup pair? 0= if s" car: not a pair" lerror then car ; 199 : pcdr car dup pair? 0= if s" cdr: not a pair" lerror then cdr ; 200 : pcons dup car swap cadr cons ; 201 : pset-car dup cadr swap car ! unspec ; 202 : pset-cdr dup cadr swap car set-cdr unspec ; 203 : eqv 2dup = if 2drop -1 exit then over num? over num? and if num@ rot num@ d= exit then 2drop 0 ; 204 : equal 2dup eqv if 2drop -1 exit then 205 over pair? over pair? and if over car over car recurse if cdr swap cdr recurse exit then 2drop 0 exit then 206 over heap? over heap? and if over type@ over type@ = if over type@ dup 6 = swap 7 = or if car swap car recurse exit then then then 207 2drop 0 ; 208 : peq dup car swap cadr = bool ; 209 : peqv dup car swap cadr eqv bool ; 210 : pequal dup car swap cadr equal bool ; 211 : pnot car false = bool ; 212 : pnull car 0= bool ; 213 : ppair car pair? bool ; 214 : psymbol car 2 typ? bool ; 215 : pproc car dup 3 typ? swap 4 typ? or bool ; 216 : pnumber car num? bool ; 217 : pstring car 6 typ? bool ; 218 : pvector? car 7 typ? bool ; 219 : pboolean car dup true = swap false = or bool ; 220 : p+ 0 0 rot begin dup while >r r@ car n@ d+ r> cdr repeat drop mknum ; 221 : p* 1 0 rot begin dup while >r r@ car n@ d* r> cdr repeat drop mknum ; 222 : p- dup cdr 0= if car n@ dnegate mknum exit then 223 dup car n@ rot cdr begin dup while >r r@ car n@ d- r> cdr repeat drop mknum ; 224 : chain >r begin dup cdr while dup car n@ 2 pick cadr n@ r@ execute 0= if drop r> drop false exit then cdr repeat 225 drop r> drop true ; 226 : p= ['] d= chain ; 227 : p< ['] d< chain ; 228 : p> ['] d> chain ; 229 : p<= ['] d<= chain ; 230 : p>= ['] d>= chain ; 231 : divargs dup car n@ rot cadr n@ over 0< <> if 2drop 0 s" divisor out of 16-bit range" lerror then 232 dup 0= if 0 s" division by zero" lerror then ; 233 : sdiv over >r dup >r abs >r dabs r> mu/mod r> r@ xor 0< if dnegate then rot r> 0< if negate then -rot ; 234 : pquotient divargs sdiv mknum nip ; 235 : premainder divargs sdiv 2drop >num ; 236 : pmodulo divargs dup >r sdiv 2drop dup if dup 0< r@ 0< <> if r@ + then then r> drop >num ; 237 : mklist 0 rot begin dup while >r over swap cons r> 1- repeat drop nip ; 238 : pmake-vector dup car n@ drop swap cdr dup if car else drop unspec then mklist 0 7 mk2 ; 239 : pvector 0 7 mk2 ; 240 : nth begin dup while swap cdr swap 1- repeat drop ; 241 : pvector-ref dup car car swap cadr n@ drop nth car ; 242 : pvector-set dup caddr swap dup car car swap cadr n@ drop nth ! unspec ; 243 : pvector-length car car len >num ; 244 : plist->vector car 0 7 mk2 ; 245 : pstring-length car car len >num ; 246 : pdisplay car -1 display? ! print 0 display? ! unspec ; 247 : pwrite car print unspec ; 248 : pnewline drop cr unspec ; 249 : spread dup cdr 0= if car exit then dup car swap cdr recurse cons ; 250 : papply dup car swap cdr spread apply-proc ; 251 : pforth drop -200 throw ; 252 : proom drop 0 free @ begin dup while swap 1+ swap cdr repeat drop >num ; 253 ' pcar prim: car 254 ' pcdr prim: cdr 255 ' pcons prim: cons 256 ' pset-car prim: set-car! 257 ' pset-cdr prim: set-cdr! 258 ' peq prim: eq? 259 ' peqv prim: eqv? 260 ' pequal prim: equal? 261 ' pnot prim: not 262 ' pnull prim: null? 263 ' ppair prim: pair? 264 ' psymbol prim: symbol? 265 ' pproc prim: procedure? 266 ' pnumber prim: number? 267 ' pnumber prim: integer? 268 ' pstring prim: string? 269 ' pvector? prim: vector? 270 ' pboolean prim: boolean? 271 ' p+ prim: + 272 ' p* prim: * 273 ' p- prim: - 274 ' p= prim: = 275 ' p< prim: < 276 ' p> prim: > 277 ' p<= prim: <= 278 ' p>= prim: >= 279 ' pquotient prim: quotient 280 ' premainder prim: remainder 281 ' pmodulo prim: modulo 282 ' pmake-vector prim: make-vector 283 ' pvector prim: vector 284 ' pvector-ref prim: vector-ref 285 ' pvector-set prim: vector-set! 286 ' pvector-length prim: vector-length 287 : pinner car car ; 288 ' pinner prim: vector->list 289 ' plist->vector prim: list->vector 290 ' pinner prim: string->list 291 ' pstring-length prim: string-length 292 ' pdisplay prim: display 293 ' pwrite prim: write 294 ' pnewline prim: newline 295 ' papply prim: apply 296 ' pforth prim: forth 297 ' proom prim: room 298 : plist ; 299 ' plist prim: list 300 301 \ ---- REPL: one or more expressions per line; (forth) returns to the Forth prompt 302 : .lerror dup -100 = if drop ." error: " errmsg @ errlen @ type space errobj @ print else ." error " . then ; 303 : eval-line begin skip-ws more? while read cr nil eval 0 display? ! print repeat ; 304 : lisp begin cr ." > " refill ['] eval-line catch ?dup if dup -200 = if drop exit then cr .lerror then again ;