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 : stack-list-len ( stack-list -- n )
571 : restore-param-stack ( continuation -- obj_stack )
572 continuation->pstack-list
575 ( Allocate stack space first using psp!,
576 then copy objects from list. )
579 object-stack-base @ psp0 + + psp!
583 car drop 2- 0 swap do
586 PSP0 object-stack-base @ + i + 2 + !
587 PSP0 object-stack-base @ + i + 1 + !
595 : list->pad ( list n -- )
597 pad + 1- \ final dest addr
598 pad \ initial dest addr
608 : restore-return-stack ( continuation -- )
610 continuation->rstack-list
612 2dup stack-list-len -rot ( n stack-list )
613 2dup cdr 2swap stack-list-len ( n list n )
617 dup RSP0 + RSP! \ expand return stack to accommodate entries
622 pad i + @ RSP0 i 1+ + !
626 : restore-continuation ( continuation -- )
627 \ TODO: replace current parameter and return stacks with
628 \ contents of continuation object.
641 \ ---- Primitives ---- {{{
643 : make-primitive ( cfa -- )
650 rot primitive-proc-type ( var prim )
651 global-env obj@ define-var
654 : ensure-arg-count ( 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
668 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
670 drop nil objeq? false = if
671 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
675 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
678 2dup cdr 2swap car ( ... t1 n args' arg1 )
679 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
681 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
689 : push-args-to-stack ( args -- arg1 arg2 ... argn )
699 : add-fa-checks ( cfa n -- cfa' )
700 here current @ 1+ dup @ , !
704 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
705 ['] push-args-to-stack ,
706 ['] lit , , ['] execute ,
710 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
711 here current @ 1+ dup @ , !
718 dup ( cfa t1 t2 ... tn n m )
723 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
729 ['] lit , , ['] ensure-arg-type-and-count ,
731 ['] push-args-to-stack ,
732 ['] lit , , ['] execute ,
738 : make-fa-primitive ( cfa n -- )
739 add-fa-checks make-primitive ;
741 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
742 add-fa-type-checks make-primitive ;
745 bold fg red ." Incorrect argument type." reset-term cr
749 : ensure-arg-type ( arg type -- arg )
751 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
758 \ ---- Macros ---- {{{
762 ( Look up macro in macro table. Returns nil if
764 : lookup-macro ( name_symbol -- proc )
766 symbol-type istype? invert if
767 \ Early exit if argument is not a symbol
789 : make-macro ( name_symbol params body env -- )
792 2swap ( proc name_symbol )
799 2over 2over ( proc name table name table )
801 2swap 2drop ( proc table )
813 macro-table obj@ cons
822 variable stored-parse-idx
823 create parse-str 161 allot
824 variable parse-str-span
826 create parse-idx-stack 10 allot
827 variable parse-idx-sp
828 parse-idx-stack parse-idx-sp !
831 parse-idx @ parse-idx-sp @ !
836 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
840 parse-idx-sp @ @ parse-idx ! ;
844 '\n' parse-str parse-str-span @ + !
845 1 parse-str-span +! ;
848 4 parse-str parse-str-span @ + !
849 1 parse-str-span +! ;
856 current-input-port obj@ console-i/o-port obj@ objeq? if
857 parse-str 160 expect cr
858 span @ parse-str-span !
860 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
861 drop swap parse-str-span !
863 parse-str-span @ 0= and if append-eof then
874 : charavailable? ( -- bool )
875 parse-str-span @ parse-idx @ > ;
877 : nextchar ( -- char )
878 charavailable? false = if getline then
879 parse-str parse-idx @ + @ ;
882 : whitespace? ( -- bool )
894 nextchar [char] ( = or
895 nextchar [char] ) = or
898 : commentstart? ( -- bool )
899 nextchar [char] ; = ;
903 false \ Indicates whether or not we're eating a comment
906 dup whitespace? or commentstart? or
908 dup nextchar '\n' = and if
909 invert \ Stop eating comment
911 dup false = commentstart? and if
912 invert \ Begin eating comment
927 nextchar [char] - = ;
930 nextchar [char] + = ;
932 : fixnum? ( -- bool )
958 : flonum? ( -- bool )
965 \ Record starting parse idx:
966 \ Want to detect whether any characters (following +/-) were eaten.
973 [char] . nextchar = if
980 [char] e nextchar = [char] E nextchar = or if
988 drop pop-parse-idx false exit
996 \ This is a real number if characters were
997 \ eaten and the next characer is a delimiter.
998 parse-idx @ < delim? and
1003 : ratnum? ( -- bool )
1011 pop-parse-idx false exit
1020 [char] / nextchar <> if
1021 pop-parse-idx false exit
1027 pop-parse-idx false exit
1036 delim? pop-parse-idx
1039 : boolean? ( -- bool )
1040 nextchar [char] # <> if false exit then
1045 nextchar [char] t <>
1046 nextchar [char] f <>
1047 and if pop-parse-idx false exit then
1059 : str-equiv? ( str -- bool )
1076 delim? false = if drop false then
1081 : character? ( -- bool )
1082 nextchar [char] # <> if false exit then
1087 nextchar [char] \ <> if pop-parse-idx false exit then
1091 S" newline" str-equiv? if pop-parse-idx true exit then
1092 S" space" str-equiv? if pop-parse-idx true exit then
1093 S" tab" str-equiv? if pop-parse-idx true exit then
1095 charavailable? false = if pop-parse-idx false exit then
1101 nextchar [char] ( = ;
1103 : string? ( -- bool )
1104 nextchar [char] " = ;
1106 : readfixnum ( -- fixnum )
1117 10 * nextchar [char] 0 - +
1126 : readflonum ( -- flonum )
1128 dup 0< swap abs i->f
1130 [char] . nextchar = if
1136 nextchar [char] 0 - i->f ( f exp d )
1137 over f/ rot f+ ( exp f' )
1138 swap 10.0 f* ( f' exp' )
1145 [char] e nextchar = [char] E nextchar = or if
1148 readfixnum drop i->f
1159 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1166 fixnum-type swap fixnum-type
1167 cons drop ratnum-type
1171 : readratnum ( -- ratnum )
1172 readfixnum inc-parse-idx readfixnum
1176 : readbool ( -- bool-obj )
1179 nextchar [char] f = if
1190 : readchar ( -- char-obj )
1194 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1195 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1196 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1198 nextchar character-type
1203 : readstring ( -- charlist )
1208 nextchar [char] " <>
1210 nextchar [char] \ = if
1213 [char] n of '\n' endof
1214 [char] " of [char] " endof
1220 inc-parse-idx character-type
1223 ( firstchar prevchar thischar )
1226 2drop 2swap 2drop 2dup ( thischar thischar )
1228 ( firstchar thischar prevchar )
1229 2over 2swap set-cdr! ( firstchar thischar )
1233 \ Discard previous character
1239 ." No delimiter following right double quote. Aborting." cr
1251 : readsymbol ( -- charlist )
1252 delim? if nil exit then
1254 nextchar inc-parse-idx character-type
1261 : readpair ( -- pairobj )
1265 nextchar [char] ) = if
1270 ." No delimiter following right paren. Aborting." cr
1279 \ Read first pair element
1284 nextchar [char] . = if
1289 ." No delimiter following '.'. Aborting." cr
1303 \ Parse a scheme expression
1338 nextchar [char] " <> if
1339 bold red ." Missing closing double-quote." reset-term cr
1357 nextchar [char] ) <> if
1358 bold red ." Missing closing paren." reset-term cr
1367 nextchar [char] ' = if
1369 quote-symbol recurse nil cons cons exit
1372 nextchar [char] ` = if
1374 quasiquote-symbol recurse nil cons cons exit
1377 nextchar [char] , = if
1379 nextchar [char] @ = if
1381 unquote-splicing-symbol recurse nil cons cons exit
1383 unquote-symbol recurse nil cons cons exit
1393 nextchar [char] ) = if
1395 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1398 \ Anything else is parsed as a symbol
1399 readsymbol charlist>symbol
1401 \ Replace λ with lambda
1402 2dup λ-symbol objeq? if
1411 \ ---- Syntax ---- {{{
1413 : self-evaluating? ( obj -- obj bool )
1414 boolean-type istype? if true exit then
1415 fixnum-type istype? if true exit then
1416 flonum-type istype? if true exit then
1417 ratnum-type istype? if true exit then
1418 character-type istype? if true exit then
1419 string-type istype? if true exit then
1420 nil-type istype? if true exit then
1421 none-type istype? if true exit then
1426 : tagged-list? ( obj tag-obj -- obj bool )
1428 pair-type istype? false = if
1434 : quote? ( obj -- obj bool )
1435 quote-symbol tagged-list? ;
1437 : quote-body ( quote-obj -- quote-body-obj )
1440 : variable? ( obj -- obj bool )
1441 symbol-type istype? ;
1443 : definition? ( obj -- obj bool )
1444 define-symbol tagged-list? ;
1446 : definition-var ( obj -- var )
1449 : definition-val ( obj -- val )
1452 : assignment? ( obj -- obj bool )
1453 set!-symbol tagged-list? ;
1455 : assignment-var ( obj -- var )
1458 : assignment-val ( obj -- val )
1461 : macro-definition? ( obj -- obj bool )
1462 define-macro-symbol tagged-list? ;
1464 : macro-definition-name ( exp -- mname )
1467 : macro-definition-params ( exp -- params )
1470 : macro-definition-body ( exp -- body )
1473 : if? ( obj -- obj bool )
1474 if-symbol tagged-list? ;
1476 : if-predicate ( ifobj -- pred )
1479 : if-consequent ( ifobj -- conseq )
1482 : if-alternative ( ifobj -- alt|none )
1490 : false? ( boolobj -- boolean )
1491 boolean-type istype? if
1492 false boolean-type objeq?
1498 : true? ( boolobj -- bool )
1501 : lambda? ( obj -- obj bool )
1502 lambda-symbol tagged-list? ;
1504 : lambda-parameters ( obj -- params )
1507 : lambda-body ( obj -- body )
1510 : application? ( obj -- obj bool )
1513 : operator ( obj -- operator )
1516 : operands ( obj -- operands )
1519 : nooperands? ( operands -- bool )
1522 : first-operand ( operands -- operand )
1525 : rest-operands ( operands -- other-operands )
1528 : procedure-params ( proc -- params )
1529 drop pair-type car ;
1531 : procedure-body ( proc -- body )
1532 drop pair-type cdr car ;
1534 : procedure-env ( proc -- body )
1535 drop pair-type cdr cdr car ;
1537 ( Ensure terminating symbol arg name is handled
1538 specially to allow for variadic procedures. )
1539 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1541 2over nil? false = if
1542 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1549 symbol-type istype? if
1559 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1566 recurse ( argvals argnames argvals'' argnames'' )
1567 2rot car 2swap cons ( argvals argvals'' argnames' )
1568 2rot car 2rot cons ( argnames' argvals' )
1574 \ ---- Analyze ---- {{{
1576 : evaluate-eproc ( eproc env --- res )
1587 2drop \ get rid of null
1591 \ Final element of eproc list is primitive procedure
1592 drop \ dump type signifier
1594 goto \ jump straight to primitive procedure (executor)
1597 : self-evaluating-executor ( exp env -- exp )
1600 : analyze-self-evaluating ( exp --- eproc )
1601 ['] self-evaluating-executor primitive-proc-type
1605 : quote-executor ( exp env -- exp )
1608 : analyze-quoted ( exp -- eproc )
1611 ['] quote-executor primitive-proc-type
1615 : variable-executor ( var env -- val )
1618 : analyze-variable ( exp -- eproc )
1619 ['] variable-executor primitive-proc-type
1623 : definition-executor ( var val-eproc env -- ok )
1624 2swap 2over ( var env val-eproc env )
1625 evaluate-eproc 2swap ( var val env )
1630 : analyze-definition ( exp -- eproc )
1632 2swap definition-val analyze
1634 ['] definition-executor primitive-proc-type
1638 : assignment-executor ( var val-eproc env -- ok )
1639 2swap 2over ( var env val-eproc env )
1640 evaluate-eproc 2swap ( var val env )
1645 : analyze-assignment ( exp -- eproc )
1647 2swap assignment-val analyze ( var val-eproc )
1649 ['] assignment-executor primitive-proc-type
1653 : sequence-executor ( eproc-list env -- res )
1657 2dup cdr ( env elist elist-rest)
1660 -2rot car 2over ( elist-rest env elist-head env )
1661 evaluate-eproc ( elist-rest env head-res )
1662 2drop 2swap ( env elist-rest )
1666 ['] evaluate-eproc goto
1670 : (analyze-sequence) ( explist -- eproc-list )
1679 : analyze-sequence ( explist -- eproc )
1681 ['] sequence-executor primitive-proc-type
1686 : macro-definition-executor ( name params bproc env -- ok )
1687 make-macro ok-symbol
1690 : analyze-macro-definition ( exp -- eproc )
1691 2dup macro-definition-name
1692 2swap 2dup macro-definition-params
1693 2swap macro-definition-body analyze-sequence
1695 ['] macro-definition-executor primitive-proc-type
1696 nil cons cons cons cons
1699 : if-executor ( cproc aproc pproc env -- res )
1700 2swap 2over ( cproc aproc env pproc env -- res )
1709 ['] evaluate-eproc goto
1712 : analyze-if ( exp -- eproc )
1713 2dup if-consequent analyze
1714 2swap 2dup if-alternative analyze
1715 2swap if-predicate analyze
1717 ['] if-executor primitive-proc-type
1718 nil cons cons cons cons
1721 : lambda-executor ( params bproc env -- res )
1723 ( Although this is packaged up as a regular compound procedure,
1724 the "body" element contains an _eproc_ to be evaluated in an
1725 environment resulting from extending env with the parameter
1729 : analyze-lambda ( exp -- eproc )
1730 2dup lambda-parameters
1734 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1739 ['] lambda-executor primitive-proc-type
1743 : operand-eproc-list ( operands -- eprocs )
1751 : evaluate-operand-eprocs ( env aprocs -- vals )
1755 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1756 -2rot cdr recurse ( thisval restvals )
1761 : apply ( vals proc )
1763 primitive-proc-type of
1767 compound-proc-type of
1768 2dup procedure-body ( argvals proc bproc )
1769 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1770 -2rot procedure-env ( bproc argnames argvals procenv )
1776 extend-env ( bproc env )
1778 ['] evaluate-eproc goto
1781 continuation-type of
1782 \ TODO: Apply continuation
1785 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1789 : application-executor ( operator-proc arg-procs env -- res )
1790 2rot 2over ( aprocs env fproc env )
1791 evaluate-eproc ( aprocs env proc )
1793 -2rot 2swap ( proc env aprocs )
1794 evaluate-operand-eprocs ( proc vals )
1801 : analyze-application ( exp -- eproc )
1802 2dup operator analyze
1803 2swap operands operand-eproc-list
1805 ['] application-executor primitive-proc-type
1809 :noname ( exp --- eproc )
1811 self-evaluating? if analyze-self-evaluating exit then
1813 quote? if analyze-quoted exit then
1815 variable? if analyze-variable exit then
1817 definition? if analyze-definition exit then
1819 assignment? if analyze-assignment exit then
1821 macro-definition? if analyze-macro-definition exit then
1823 if? if analyze-if exit then
1825 lambda? if analyze-lambda exit then
1827 application? if analyze-application exit then
1829 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1835 \ ---- Macro Expansion ---- {{{
1837 ( Simply evaluates the given procedure with expbody as its argument. )
1838 : macro-eval ( proc expbody -- result )
1840 2dup procedure-body ( expbody proc bproc )
1841 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1842 -2rot procedure-env ( bproc argnames expbody procenv )
1848 extend-env ( bproc env )
1850 ['] evaluate-eproc goto
1853 : expand-macro ( exp -- result )
1854 pair-type istype? invert if exit then
1856 2dup car symbol-type istype? invert if 2drop exit then
1858 lookup-macro nil? if 2drop exit then
1860 2over cdr macro-eval
1862 2dup no-match-symbol objeq? if
1868 R> drop ['] expand goto-deferred
1871 : expand-definition ( exp -- result )
1875 2swap definition-val expand
1876 nil ( define var val' nil )
1880 : expand-assignment ( exp -- result )
1884 2swap assignment-val expand
1885 nil ( define var val' nil )
1889 : expand-list ( exp -- res )
1897 : macro-definition-nameparams
1900 : expand-define-macro ( exp -- res )
1901 define-macro-symbol 2swap
1902 2dup macro-definition-nameparams
1903 2swap macro-definition-body expand-list
1907 : expand-lambda ( exp -- res )
1909 2dup lambda-parameters
1910 2swap lambda-body expand-list
1914 : expand-if ( exp -- res )
1917 2dup if-predicate expand
1918 2swap 2dup if-consequent expand
1919 2swap if-alternative none? if
1927 : expand-application ( exp -- res )
1928 2dup operator expand
1929 2swap operands expand-list
1933 :noname ( exp -- result )
1936 self-evaluating? if exit then
1940 definition? if expand-definition exit then
1942 assignment? if expand-assignment exit then
1944 macro-definition? if expand-define-macro exit then
1946 lambda? if expand-lambda exit then
1948 if? if expand-if exit then
1950 application? if expand-application exit then
1956 :noname ( exp env -- res )
1957 2swap expand analyze 2swap evaluate-eproc
1960 \ ---- Print ---- {{{
1962 : printfixnum ( fixnum -- ) drop 0 .R ;
1964 : printflonum ( flonum -- ) drop f. ;
1966 : printratnum ( ratnum -- )
1968 car print ." /" cdr print
1971 : printbool ( bool -- )
1979 : printchar ( charobj -- )
1982 9 of ." #\tab" endof
1983 bl of ." #\space" endof
1984 '\n' of ." #\newline" endof
1990 : (printstring) ( stringobj -- )
1991 nil? if 2drop exit then
1995 '\n' of ." \n" drop endof
1996 [char] \ of ." \\" drop endof
1997 [char] " of [char] \ emit [char] " emit drop endof
2003 : printstring ( stringobj -- )
2008 : printsymbol ( symbolobj -- )
2009 nil-type istype? if 2drop exit then
2015 : printnil ( nilobj -- )
2018 : printpair ( pairobj -- )
2022 nil-type istype? if 2drop exit then
2023 pair-type istype? if space recurse exit then
2027 : printprim ( primobj -- )
2028 2drop ." <primitive procedure>" ;
2030 : printcomp ( primobj -- )
2031 2drop ." <compound procedure>" ;
2033 : printcont ( primobj --)
2034 2drop ." <continuation>" ;
2036 : printnone ( noneobj -- )
2037 2drop ." Unspecified return value" ;
2039 : printport ( port -- )
2043 fixnum-type istype? if printfixnum exit then
2044 flonum-type istype? if printflonum exit then
2045 ratnum-type istype? if printratnum exit then
2046 boolean-type istype? if printbool exit then
2047 character-type istype? if printchar exit then
2048 string-type istype? if printstring exit then
2049 symbol-type istype? if printsymbol exit then
2050 nil-type istype? if printnil exit then
2051 pair-type istype? if ." (" printpair ." )" exit then
2052 primitive-proc-type istype? if printprim exit then
2053 compound-proc-type istype? if printcomp exit then
2054 continuation-type istype? if printcont exit then
2055 none-type istype? if printnone exit then
2056 port-type istype? if printport exit then
2058 except-message: ." tried to print object with unknown type." recoverable-exception throw
2063 \ ---- Garbage Collection ---- {{{
2065 ( Notes on garbage collection:
2066 This is a mark-sweep garbage collector, invoked by cons.
2067 The roots of the object tree used by the marking routine
2068 include all objects in the parameter stack, and several
2069 other fixed roots such as global-env, symbol-table, macro-table,
2070 and the console-i/o-port.
2072 NO OTHER OBJECTS WILL BE MARKED!
2074 This places implicit restrictions on when cons can be invoked.
2075 Invoking cons when live objects are stored on the return stack
2076 or in other variables than the above will result in possible
2077 memory corruption if the cons triggers the GC. )
2080 : pairlike? ( obj -- obj bool )
2081 pair-type istype? if true exit then
2082 string-type istype? if true exit then
2083 symbol-type istype? if true exit then
2084 compound-proc-type istype? if true exit then
2085 port-type istype? if true exit then
2090 : pairlike-marked? ( obj -- obj bool )
2091 over nextfrees + @ 0=
2094 : mark-pairlike ( obj -- obj )
2095 over nextfrees + 0 swap !
2104 : gc-mark-obj ( obj -- )
2106 pairlike? invert if 2drop exit then
2107 pairlike-marked? if 2drop exit then
2118 scheme-memsize nextfree !
2119 0 scheme-memsize 1- do
2120 nextfrees i + @ 0<> if
2121 nextfree @ nextfrees i + !
2127 \ Following a GC, this gives the amount of free memory
2131 nextfrees i + @ 0= if 1+ then
2135 \ Debugging word - helps spot memory that is retained
2138 nextfrees i + @ 0<> if
2150 symbol-table obj@ gc-mark-obj
2151 macro-table obj@ gc-mark-obj
2152 console-i/o-port obj@ gc-mark-obj
2153 global-env obj@ gc-mark-obj
2155 depth object-stack-base @ do
2164 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2165 ; is collect-garbage
2172 \ ---- Loading files ---- {{{
2174 : load ( addr n -- finalResult )
2179 ok-symbol ( port res )
2183 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2185 2over read-port ( port res obj )
2190 2dup EOF character-type objeq? if
2191 2drop 2swap close-port
2195 2swap 2drop ( port obj )
2197 global-env obj@ eval ( port res )
2203 \ ---- Standard Library ---- {{{
2205 include scheme-primitives.4th
2207 init-object-stack-base
2208 s" scheme-library.scm" load 2drop
2214 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2215 : repl-body ( -- bool )
2216 cr bold fg green ." > " reset-term
2220 2dup EOF character-type objeq? if
2222 bold fg blue ." Moriturus te saluto." reset-term cr
2226 global-env obj@ eval
2228 fg cyan ." ; " print reset-term
2236 init-object-stack-base
2238 \ Display welcome message
2239 welcome-symbol nil cons global-env obj@ eval 2drop
2244 recoverable-exception of false endof
2245 unrecoverable-exception of true endof