4 include term-colours.4th
7 include catch-throw.4th
33 make-type boolean-type
34 make-type character-type
40 make-type primitive-proc-type
41 make-type compound-proc-type
42 make-type continuation-type
44 : istype? ( obj type -- obj bool )
49 \ ---- Exceptions ---- {{{
51 variable nextexception
54 create nextexception @ ,
63 make-exception recoverable-exception
64 make-exception unrecoverable-exception
66 : throw reset-term cr throw ;
70 \ ---- List-structured memory ---- {{{
72 20000 constant scheme-memsize
74 create car-cells scheme-memsize allot
75 create car-type-cells scheme-memsize allot
76 create cdr-cells scheme-memsize allot
77 create cdr-type-cells scheme-memsize allot
79 create nextfrees scheme-memsize allot
90 nextfrees nextfree @ + @
93 nextfree @ scheme-memsize >= if
97 nextfree @ scheme-memsize >= if
98 except-message: ." Out of memory!" unrecoverable-exception throw
102 : cons ( car-obj cdr-obj -- pair-obj )
103 cdr-type-cells nextfree @ + !
104 cdr-cells nextfree @ + !
105 car-type-cells nextfree @ + !
106 car-cells nextfree @ + !
112 : car ( pair-obj -- car-obj )
114 dup car-cells + @ swap
118 : cdr ( pair-obj -- car-obj )
120 dup cdr-cells + @ swap
124 : set-car! ( obj pair-obj -- )
126 rot swap car-type-cells + !
130 : set-cdr! ( obj pair-obj -- )
132 rot swap cdr-type-cells + !
136 variable object-stack-base
137 : init-object-stack-base
138 depth object-stack-base ! ;
141 : nil? nil-type istype? ;
144 : none? none-type istype? ;
146 : objvar create nil swap , , ;
148 : value@ ( objvar -- val ) @ ;
149 : type@ ( objvar -- type ) 1+ @ ;
150 : value! ( newval objvar -- ) ! ;
151 : type! ( newtype objvar -- ) 1+ ! ;
152 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
153 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
155 : objeq? ( obj obj -- bool )
158 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
159 >R >R ( a1 a2 b1 b2 )
160 2swap ( b1 b2 a1 a2 )
161 R> R> ( b1 b2 a1 a2 c1 c2 )
165 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
166 2swap ( a1 a2 c1 c2 b1 b2 )
167 >R >R ( a1 a2 c1 c2 )
168 2swap ( c1 c2 a1 a2 )
172 : 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
178 \ ---- Pre-defined symbols ---- {{{
182 : duplicate-charlist ( charlist -- copy )
184 2dup car 2swap cdr recurse cons
187 : charlist-equiv ( charlist charlist -- bool )
196 2drop 2drop true exit
198 2drop 2drop false exit
203 2drop 2drop false exit
210 car drop -rot car drop = if
211 cdr 2swap cdr recurse
217 : charlist>symbol ( charlist -- symbol-obj )
236 drop symbol-type 2dup
237 symbol-table obj@ cons
242 : cstr>charlist ( addr n -- charlist )
246 2dup drop @ character-type 2swap
254 : create-symbol ( -- )
262 does> dup @ swap 1+ @
265 create-symbol quote quote-symbol
266 create-symbol quasiquote quasiquote-symbol
267 create-symbol unquote unquote-symbol
268 create-symbol unquote-splicing unquote-splicing-symbol
269 create-symbol define define-symbol
270 create-symbol define-macro define-macro-symbol
271 create-symbol set! set!-symbol
272 create-symbol ok ok-symbol
273 create-symbol if if-symbol
274 create-symbol lambda lambda-symbol
275 create-symbol λ λ-symbol
276 create-symbol eof eof-symbol
277 create-symbol no-match no-match-symbol
279 \ Symbol to be bound to welcome message procedure by library
280 create-symbol welcome welcome-symbol
284 \ ---- Port I/O ---- {{{
286 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
288 : fileport>fid ( fileport -- fid )
289 drop pair-type car drop ;
291 : get-last-peek ( fileport -- char/nil )
294 : set-last-peek ( char/nil fileport -- )
295 drop pair-type set-cdr!
298 : fid>fileport ( fid -- fileport )
299 fixnum-type nil cons drop port-type ;
301 : open-input-file ( addr n -- fileport )
302 r/o open-file drop fid>fileport
305 : close-port ( fileport -- )
306 fileport>fid close-file drop
309 objvar console-i/o-port
310 0 fixnum-type nil cons drop port-type console-i/o-port obj!
312 objvar current-input-port
313 console-i/o-port obj@ current-input-port obj!
315 : read-char ( port -- char )
316 2dup get-last-peek nil? if
318 2dup console-i/o-port obj@ objeq? if
322 fileport>fid pad 1 rot read-file 0= if
333 : peek-char ( port -- char )
334 2dup get-last-peek nil? if
336 2dup 2rot set-last-peek
342 variable read-line-buffer-span
343 variable read-line-buffer-offset
345 ( Hack to save original read-line while we transition to new one. )
346 : orig-read-line immediate
349 : read-line ( port -- string )
354 0 read-line-buffer-offset !
356 2over nil 2swap set-last-peek
358 2drop nil nil cons exit
361 1 read-line-buffer-offset !
365 2dup console-i/o-port obj@ objeq? if
367 pad read-line-buffer-offset @ + 200 expect cr
368 span @ read-line-buffer-offset @ + read-line-buffer-span !
370 pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
371 drop swap read-line-buffer-offset @ + read-line-buffer-span !
377 read-line-buffer-span @ 0>
379 pad read-line-buffer-span @ 1- + @ character-type 2swap cons
380 -1 read-line-buffer-span +!
384 nil cons drop string-type
390 : read-port ( fileport -- obj )
391 current-input-port obj!
394 : read-console ( -- obj )
395 console-i/o-port obj@ read-port ;
399 \ ---- Environments ---- {{{
401 : enclosing-env ( env -- env )
404 : first-frame ( env -- frame )
407 : make-frame ( vars vals -- frame )
410 : add-frame-to-env ( frame env -- env )
413 : frame-vars ( frame -- vars )
416 : frame-vals ( frame -- vals )
419 : add-binding ( var val frame -- )
420 2swap 2over frame-vals cons
422 2swap 2over frame-vars cons
426 : extend-env ( vars vals env -- env )
428 2swap add-frame-to-env
431 : get-vals-frame ( var frame -- vals | nil )
433 2swap frame-vals ( var vars vals )
439 -2rot ( vals var vars )
440 2over 2over car objeq? if
452 : get-vals ( var env -- vals | nil )
457 2over 2over first-frame
458 get-vals-frame nil? false = if
459 2swap 2drop 2swap 2drop
471 objvar var \ Used only for error messages
472 : lookup-var ( var env -- val )
476 except-message: ." tried to read unbound variable '" var obj@ print ." '."
477 recoverable-exception throw
483 : set-var ( var val env -- )
484 2rot 2dup var obj! ( val env var )
485 2swap ( val var env )
487 except-message: ." tried to set unbound variable '" var obj@ print ." '."
488 recoverable-exception throw
496 : define-var ( var val env -- )
497 first-frame ( var val frame )
498 2rot 2swap 2over 2over ( val var frame var frame )
500 get-vals-frame nil? if
505 ( val var frame vals )
506 2swap 2drop 2swap 2drop
511 : make-procedure ( params body env -- proc )
514 drop compound-proc-type
518 nil nil nil extend-env
523 \ ---- Continuations ---- {{{
525 : cons-return-stack ( -- listobj )
531 i 1+ @ fixnum-type 2swap cons
534 rsp@ 1- rsp0 - fixnum-type 2swap cons
537 : cons-param-stack ( -- listobj )
540 depth 2- object-stack-base @ = if
544 depth 2- object-stack-base @ do
551 depth 2- fixnum-type 2swap cons
558 cons drop continuation-type
561 : continuation->pstack-list
564 : continuation->rstack-list
567 : restore-param-stack ( continuation -- obj_stack )
568 continuation->pstack-list
571 ( Allocate stack space first using psp!,
572 then copy objects from list. )
575 object-stack-base @ psp0 + + psp!
579 car drop 2- 0 swap do
582 PSP0 object-stack-base @ + i + 2 + !
583 PSP0 object-stack-base @ + i + 1 + !
591 : restore-return-stack ( continuation -- )
592 R> \ store top of return stack on PS
593 continuation->rstack-list
596 ( Allocate stack space first using rsp!,
597 then copy objects from list. )
612 >R \ restore original top of return stack
615 : restore-continuation ( continuation -- )
616 \ TODO: replace current parameter and return stacks with
617 \ contents of continuation object.
627 \ ---- Primitives ---- {{{
629 : make-primitive ( cfa -- )
636 rot primitive-proc-type ( var prim )
637 global-env obj@ define-var
640 : ensure-arg-count ( args n -- )
642 drop nil objeq? false = if
643 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
647 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
654 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
656 drop nil objeq? false = if
657 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
661 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
664 2dup cdr 2swap car ( ... t1 n args' arg1 )
665 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
667 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
675 : push-args-to-stack ( args -- arg1 arg2 ... argn )
685 : add-fa-checks ( cfa n -- cfa' )
686 here current @ 1+ dup @ , !
690 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
691 ['] push-args-to-stack ,
692 ['] lit , , ['] execute ,
696 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
697 here current @ 1+ dup @ , !
704 dup ( cfa t1 t2 ... tn n m )
709 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
715 ['] lit , , ['] ensure-arg-type-and-count ,
717 ['] push-args-to-stack ,
718 ['] lit , , ['] execute ,
724 : make-fa-primitive ( cfa n -- )
725 add-fa-checks make-primitive ;
727 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
728 add-fa-type-checks make-primitive ;
731 bold fg red ." Incorrect argument type." reset-term cr
735 : ensure-arg-type ( arg type -- arg )
737 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
744 \ ---- Macros ---- {{{
748 ( Look up macro in macro table. Returns nil if
750 : lookup-macro ( name_symbol -- proc )
752 symbol-type istype? invert if
753 \ Early exit if argument is not a symbol
775 : make-macro ( name_symbol params body env -- )
778 2swap ( proc name_symbol )
785 2over 2over ( proc name table name table )
787 2swap 2drop ( proc table )
799 macro-table obj@ cons
808 variable stored-parse-idx
809 create parse-str 161 allot
810 variable parse-str-span
812 create parse-idx-stack 10 allot
813 variable parse-idx-sp
814 parse-idx-stack parse-idx-sp !
817 parse-idx @ parse-idx-sp @ !
822 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
826 parse-idx-sp @ @ parse-idx ! ;
830 '\n' parse-str parse-str-span @ + !
831 1 parse-str-span +! ;
834 4 parse-str parse-str-span @ + !
835 1 parse-str-span +! ;
842 current-input-port obj@ console-i/o-port obj@ objeq? if
843 parse-str 160 expect cr
844 span @ parse-str-span !
846 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
847 drop swap parse-str-span !
849 parse-str-span @ 0= and if append-eof then
860 : charavailable? ( -- bool )
861 parse-str-span @ parse-idx @ > ;
863 : nextchar ( -- char )
864 charavailable? false = if getline then
865 parse-str parse-idx @ + @ ;
868 : whitespace? ( -- bool )
880 nextchar [char] ( = or
881 nextchar [char] ) = or
884 : commentstart? ( -- bool )
885 nextchar [char] ; = ;
889 false \ Indicates whether or not we're eating a comment
892 dup whitespace? or commentstart? or
894 dup nextchar '\n' = and if
895 invert \ Stop eating comment
897 dup false = commentstart? and if
898 invert \ Begin eating comment
913 nextchar [char] - = ;
916 nextchar [char] + = ;
918 : fixnum? ( -- bool )
944 : flonum? ( -- bool )
951 \ Record starting parse idx:
952 \ Want to detect whether any characters (following +/-) were eaten.
959 [char] . nextchar = if
966 [char] e nextchar = [char] E nextchar = or if
974 drop pop-parse-idx false exit
982 \ This is a real number if characters were
983 \ eaten and the next characer is a delimiter.
984 parse-idx @ < delim? and
989 : ratnum? ( -- bool )
997 pop-parse-idx false exit
1006 [char] / nextchar <> if
1007 pop-parse-idx false exit
1013 pop-parse-idx false exit
1022 delim? pop-parse-idx
1025 : boolean? ( -- bool )
1026 nextchar [char] # <> if false exit then
1031 nextchar [char] t <>
1032 nextchar [char] f <>
1033 and if pop-parse-idx false exit then
1045 : str-equiv? ( str -- bool )
1062 delim? false = if drop false then
1067 : character? ( -- bool )
1068 nextchar [char] # <> if false exit then
1073 nextchar [char] \ <> if pop-parse-idx false exit then
1077 S" newline" str-equiv? if pop-parse-idx true exit then
1078 S" space" str-equiv? if pop-parse-idx true exit then
1079 S" tab" str-equiv? if pop-parse-idx true exit then
1081 charavailable? false = if pop-parse-idx false exit then
1087 nextchar [char] ( = ;
1089 : string? ( -- bool )
1090 nextchar [char] " = ;
1092 : readfixnum ( -- fixnum )
1103 10 * nextchar [char] 0 - +
1112 : readflonum ( -- flonum )
1114 dup 0< swap abs i->f
1116 [char] . nextchar = if
1122 nextchar [char] 0 - i->f ( f exp d )
1123 over f/ rot f+ ( exp f' )
1124 swap 10.0 f* ( f' exp' )
1131 [char] e nextchar = [char] E nextchar = or if
1134 readfixnum drop i->f
1145 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1152 fixnum-type swap fixnum-type
1153 cons drop ratnum-type
1157 : readratnum ( -- ratnum )
1158 readfixnum inc-parse-idx readfixnum
1162 : readbool ( -- bool-obj )
1165 nextchar [char] f = if
1176 : readchar ( -- char-obj )
1180 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1181 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1182 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1184 nextchar character-type
1189 : readstring ( -- charlist )
1194 nextchar [char] " <>
1196 nextchar [char] \ = if
1199 [char] n of '\n' endof
1200 [char] " of [char] " endof
1206 inc-parse-idx character-type
1209 ( firstchar prevchar thischar )
1212 2drop 2swap 2drop 2dup ( thischar thischar )
1214 ( firstchar thischar prevchar )
1215 2over 2swap set-cdr! ( firstchar thischar )
1219 \ Discard previous character
1225 ." No delimiter following right double quote. Aborting." cr
1237 : readsymbol ( -- charlist )
1238 delim? if nil exit then
1240 nextchar inc-parse-idx character-type
1247 : readpair ( -- pairobj )
1251 nextchar [char] ) = if
1256 ." No delimiter following right paren. Aborting." cr
1265 \ Read first pair element
1270 nextchar [char] . = if
1275 ." No delimiter following '.'. Aborting." cr
1289 \ Parse a scheme expression
1324 nextchar [char] " <> if
1325 bold red ." Missing closing double-quote." reset-term cr
1343 nextchar [char] ) <> if
1344 bold red ." Missing closing paren." reset-term cr
1353 nextchar [char] ' = if
1355 quote-symbol recurse nil cons cons exit
1358 nextchar [char] ` = if
1360 quasiquote-symbol recurse nil cons cons exit
1363 nextchar [char] , = if
1365 nextchar [char] @ = if
1367 unquote-splicing-symbol recurse nil cons cons exit
1369 unquote-symbol recurse nil cons cons exit
1379 nextchar [char] ) = if
1381 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1384 \ Anything else is parsed as a symbol
1385 readsymbol charlist>symbol
1387 \ Replace λ with lambda
1388 2dup λ-symbol objeq? if
1397 \ ---- Syntax ---- {{{
1399 : self-evaluating? ( obj -- obj bool )
1400 boolean-type istype? if true exit then
1401 fixnum-type istype? if true exit then
1402 flonum-type istype? if true exit then
1403 ratnum-type istype? if true exit then
1404 character-type istype? if true exit then
1405 string-type istype? if true exit then
1406 nil-type istype? if true exit then
1407 none-type istype? if true exit then
1412 : tagged-list? ( obj tag-obj -- obj bool )
1414 pair-type istype? false = if
1420 : quote? ( obj -- obj bool )
1421 quote-symbol tagged-list? ;
1423 : quote-body ( quote-obj -- quote-body-obj )
1426 : variable? ( obj -- obj bool )
1427 symbol-type istype? ;
1429 : definition? ( obj -- obj bool )
1430 define-symbol tagged-list? ;
1432 : definition-var ( obj -- var )
1435 : definition-val ( obj -- val )
1438 : assignment? ( obj -- obj bool )
1439 set!-symbol tagged-list? ;
1441 : assignment-var ( obj -- var )
1444 : assignment-val ( obj -- val )
1447 : macro-definition? ( obj -- obj bool )
1448 define-macro-symbol tagged-list? ;
1450 : macro-definition-name ( exp -- mname )
1453 : macro-definition-params ( exp -- params )
1456 : macro-definition-body ( exp -- body )
1459 : if? ( obj -- obj bool )
1460 if-symbol tagged-list? ;
1462 : if-predicate ( ifobj -- pred )
1465 : if-consequent ( ifobj -- conseq )
1468 : if-alternative ( ifobj -- alt|none )
1476 : false? ( boolobj -- boolean )
1477 boolean-type istype? if
1478 false boolean-type objeq?
1484 : true? ( boolobj -- bool )
1487 : lambda? ( obj -- obj bool )
1488 lambda-symbol tagged-list? ;
1490 : lambda-parameters ( obj -- params )
1493 : lambda-body ( obj -- body )
1496 : application? ( obj -- obj bool )
1499 : operator ( obj -- operator )
1502 : operands ( obj -- operands )
1505 : nooperands? ( operands -- bool )
1508 : first-operand ( operands -- operand )
1511 : rest-operands ( operands -- other-operands )
1514 : procedure-params ( proc -- params )
1515 drop pair-type car ;
1517 : procedure-body ( proc -- body )
1518 drop pair-type cdr car ;
1520 : procedure-env ( proc -- body )
1521 drop pair-type cdr cdr car ;
1523 ( Ensure terminating symbol arg name is handled
1524 specially to allow for variadic procedures. )
1525 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1527 2over nil? false = if
1528 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1535 symbol-type istype? if
1545 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1552 recurse ( argvals argnames argvals'' argnames'' )
1553 2rot car 2swap cons ( argvals argvals'' argnames' )
1554 2rot car 2rot cons ( argnames' argvals' )
1560 \ ---- Analyze ---- {{{
1562 : evaluate-eproc ( eproc env --- res )
1573 2drop \ get rid of null
1577 \ Final element of eproc list is primitive procedure
1578 drop \ dump type signifier
1580 goto \ jump straight to primitive procedure (executor)
1583 : self-evaluating-executor ( exp env -- exp )
1586 : analyze-self-evaluating ( exp --- eproc )
1587 ['] self-evaluating-executor primitive-proc-type
1591 : quote-executor ( exp env -- exp )
1594 : analyze-quoted ( exp -- eproc )
1597 ['] quote-executor primitive-proc-type
1601 : variable-executor ( var env -- val )
1604 : analyze-variable ( exp -- eproc )
1605 ['] variable-executor primitive-proc-type
1609 : definition-executor ( var val-eproc env -- ok )
1610 2swap 2over ( var env val-eproc env )
1611 evaluate-eproc 2swap ( var val env )
1616 : analyze-definition ( exp -- eproc )
1618 2swap definition-val analyze
1620 ['] definition-executor primitive-proc-type
1624 : assignment-executor ( var val-eproc env -- ok )
1625 2swap 2over ( var env val-eproc env )
1626 evaluate-eproc 2swap ( var val env )
1631 : analyze-assignment ( exp -- eproc )
1633 2swap assignment-val analyze ( var val-eproc )
1635 ['] assignment-executor primitive-proc-type
1639 : sequence-executor ( eproc-list env -- res )
1643 2dup cdr ( env elist elist-rest)
1646 -2rot car 2over ( elist-rest env elist-head env )
1647 evaluate-eproc ( elist-rest env head-res )
1648 2drop 2swap ( env elist-rest )
1652 ['] evaluate-eproc goto
1656 : (analyze-sequence) ( explist -- eproc-list )
1665 : analyze-sequence ( explist -- eproc )
1667 ['] sequence-executor primitive-proc-type
1672 : macro-definition-executor ( name params bproc env -- ok )
1673 make-macro ok-symbol
1676 : analyze-macro-definition ( exp -- eproc )
1677 2dup macro-definition-name
1678 2swap 2dup macro-definition-params
1679 2swap macro-definition-body analyze-sequence
1681 ['] macro-definition-executor primitive-proc-type
1682 nil cons cons cons cons
1685 : if-executor ( cproc aproc pproc env -- res )
1686 2swap 2over ( cproc aproc env pproc env -- res )
1695 ['] evaluate-eproc goto
1698 : analyze-if ( exp -- eproc )
1699 2dup if-consequent analyze
1700 2swap 2dup if-alternative analyze
1701 2swap if-predicate analyze
1703 ['] if-executor primitive-proc-type
1704 nil cons cons cons cons
1707 : lambda-executor ( params bproc env -- res )
1709 ( Although this is packaged up as a regular compound procedure,
1710 the "body" element contains an _eproc_ to be evaluated in an
1711 environment resulting from extending env with the parameter
1715 : analyze-lambda ( exp -- eproc )
1716 2dup lambda-parameters
1720 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1725 ['] lambda-executor primitive-proc-type
1729 : operand-eproc-list ( operands -- eprocs )
1737 : evaluate-operand-eprocs ( env aprocs -- vals )
1741 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1742 -2rot cdr recurse ( thisval restvals )
1747 : apply ( vals proc )
1749 primitive-proc-type of
1753 compound-proc-type of
1754 2dup procedure-body ( argvals proc bproc )
1755 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1756 -2rot procedure-env ( bproc argnames argvals procenv )
1762 extend-env ( bproc env )
1764 ['] evaluate-eproc goto
1767 continuation-type of
1768 \ TODO: Apply continuation
1771 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1775 : application-executor ( operator-proc arg-procs env -- res )
1776 2rot 2over ( aprocs env fproc env )
1777 evaluate-eproc ( aprocs env proc )
1779 -2rot 2swap ( proc env aprocs )
1780 evaluate-operand-eprocs ( proc vals )
1787 : analyze-application ( exp -- eproc )
1788 2dup operator analyze
1789 2swap operands operand-eproc-list
1791 ['] application-executor primitive-proc-type
1795 :noname ( exp --- eproc )
1797 self-evaluating? if analyze-self-evaluating exit then
1799 quote? if analyze-quoted exit then
1801 variable? if analyze-variable exit then
1803 definition? if analyze-definition exit then
1805 assignment? if analyze-assignment exit then
1807 macro-definition? if analyze-macro-definition exit then
1809 if? if analyze-if exit then
1811 lambda? if analyze-lambda exit then
1813 application? if analyze-application exit then
1815 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1821 \ ---- Macro Expansion ---- {{{
1823 ( Simply evaluates the given procedure with expbody as its argument. )
1824 : macro-eval ( proc expbody -- result )
1826 2dup procedure-body ( expbody proc bproc )
1827 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1828 -2rot procedure-env ( bproc argnames expbody procenv )
1834 extend-env ( bproc env )
1836 ['] evaluate-eproc goto
1839 : expand-macro ( exp -- result )
1840 pair-type istype? invert if exit then
1842 2dup car symbol-type istype? invert if 2drop exit then
1844 lookup-macro nil? if 2drop exit then
1846 2over cdr macro-eval
1848 2dup no-match-symbol objeq? if
1854 R> drop ['] expand goto-deferred
1857 : expand-definition ( exp -- result )
1861 2swap definition-val expand
1862 nil ( define var val' nil )
1866 : expand-assignment ( exp -- result )
1870 2swap assignment-val expand
1871 nil ( define var val' nil )
1875 : expand-list ( exp -- res )
1883 : macro-definition-nameparams
1886 : expand-define-macro ( exp -- res )
1887 define-macro-symbol 2swap
1888 2dup macro-definition-nameparams
1889 2swap macro-definition-body expand-list
1893 : expand-lambda ( exp -- res )
1895 2dup lambda-parameters
1896 2swap lambda-body expand-list
1900 : expand-if ( exp -- res )
1903 2dup if-predicate expand
1904 2swap 2dup if-consequent expand
1905 2swap if-alternative none? if
1913 : expand-application ( exp -- res )
1914 2dup operator expand
1915 2swap operands expand-list
1919 :noname ( exp -- result )
1922 self-evaluating? if exit then
1926 definition? if expand-definition exit then
1928 assignment? if expand-assignment exit then
1930 macro-definition? if expand-define-macro exit then
1932 lambda? if expand-lambda exit then
1934 if? if expand-if exit then
1936 application? if expand-application exit then
1942 :noname ( exp env -- res )
1943 2swap expand analyze 2swap evaluate-eproc
1946 \ ---- Print ---- {{{
1948 : printfixnum ( fixnum -- ) drop 0 .R ;
1950 : printflonum ( flonum -- ) drop f. ;
1952 : printratnum ( ratnum -- )
1954 car print ." /" cdr print
1957 : printbool ( bool -- )
1965 : printchar ( charobj -- )
1968 9 of ." #\tab" endof
1969 bl of ." #\space" endof
1970 '\n' of ." #\newline" endof
1976 : (printstring) ( stringobj -- )
1977 nil? if 2drop exit then
1981 '\n' of ." \n" drop endof
1982 [char] \ of ." \\" drop endof
1983 [char] " of [char] \ emit [char] " emit drop endof
1989 : printstring ( stringobj -- )
1994 : printsymbol ( symbolobj -- )
1995 nil-type istype? if 2drop exit then
2001 : printnil ( nilobj -- )
2004 : printpair ( pairobj -- )
2008 nil-type istype? if 2drop exit then
2009 pair-type istype? if space recurse exit then
2013 : printprim ( primobj -- )
2014 2drop ." <primitive procedure>" ;
2016 : printcomp ( primobj -- )
2017 2drop ." <compound procedure>" ;
2019 : printcont ( primobj --)
2020 2drop ." <continuation>" ;
2022 : printnone ( noneobj -- )
2023 2drop ." Unspecified return value" ;
2025 : printport ( port -- )
2029 fixnum-type istype? if printfixnum exit then
2030 flonum-type istype? if printflonum exit then
2031 ratnum-type istype? if printratnum exit then
2032 boolean-type istype? if printbool exit then
2033 character-type istype? if printchar exit then
2034 string-type istype? if printstring exit then
2035 symbol-type istype? if printsymbol exit then
2036 nil-type istype? if printnil exit then
2037 pair-type istype? if ." (" printpair ." )" exit then
2038 primitive-proc-type istype? if printprim exit then
2039 compound-proc-type istype? if printcomp exit then
2040 continuation-type istype? if printcont exit then
2041 none-type istype? if printnone exit then
2042 port-type istype? if printport exit then
2044 except-message: ." tried to print object with unknown type." recoverable-exception throw
2049 \ ---- Garbage Collection ---- {{{
2051 ( Notes on garbage collection:
2052 This is a mark-sweep garbage collector, invoked by cons.
2053 The roots of the object tree used by the marking routine
2054 include all objects in the parameter stack, and several
2055 other fixed roots such as global-env, symbol-table, macro-table,
2056 and the console-i/o-port.
2058 NO OTHER OBJECTS WILL BE MARKED!
2060 This places implicit restrictions on when cons can be invoked.
2061 Invoking cons when live objects are stored on the return stack
2062 or in other variables than the above will result in possible
2063 memory corruption if the cons triggers the GC. )
2066 : pairlike? ( obj -- obj bool )
2067 pair-type istype? if true exit then
2068 string-type istype? if true exit then
2069 symbol-type istype? if true exit then
2070 compound-proc-type istype? if true exit then
2071 port-type istype? if true exit then
2076 : pairlike-marked? ( obj -- obj bool )
2077 over nextfrees + @ 0=
2080 : mark-pairlike ( obj -- obj )
2081 over nextfrees + 0 swap !
2090 : gc-mark-obj ( obj -- )
2092 pairlike? invert if 2drop exit then
2093 pairlike-marked? if 2drop exit then
2104 scheme-memsize nextfree !
2105 0 scheme-memsize 1- do
2106 nextfrees i + @ 0<> if
2107 nextfree @ nextfrees i + !
2113 \ Following a GC, this gives the amount of free memory
2117 nextfrees i + @ 0= if 1+ then
2121 \ Debugging word - helps spot memory that is retained
2124 nextfrees i + @ 0<> if
2136 symbol-table obj@ gc-mark-obj
2137 macro-table obj@ gc-mark-obj
2138 console-i/o-port obj@ gc-mark-obj
2139 global-env obj@ gc-mark-obj
2141 depth object-stack-base @ do
2150 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2151 ; is collect-garbage
2157 \ ---- Loading files ---- {{{
2159 : load ( addr n -- finalResult )
2164 ok-symbol ( port res )
2168 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2170 2over read-port ( port res obj )
2175 2dup EOF character-type objeq? if
2176 2drop 2swap close-port
2180 2swap 2drop ( port obj )
2182 global-env obj@ eval ( port res )
2188 \ ---- Standard Library ---- {{{
2190 include scheme-primitives.4th
2192 init-object-stack-base
2193 s" scheme-library.scm" load 2drop
2199 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2200 : repl-body ( -- bool )
2201 cr bold fg green ." > " reset-term
2205 2dup EOF character-type objeq? if
2207 bold fg blue ." Moriturus te saluto." reset-term cr
2211 global-env obj@ eval
2213 fg cyan ." ; " print reset-term
2221 init-object-stack-base
2223 \ Display welcome message
2224 welcome-symbol nil cons global-env obj@ eval 2drop
2229 recoverable-exception of false endof
2230 unrecoverable-exception of true endof