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- 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 stack-list-len 1- 0 swap do
586 PSP0 object-stack-base @ + i 2* + 2 + !
587 PSP0 object-stack-base @ + i 2* + 1 + !
595 : restore-return-stack ( continuation -- )
597 continuation->rstack-list
599 2dup cdr 2swap stack-list-len ( list n )
601 dup RSP0 + RSP! \ expand return stack to accommodate entries
605 1- \ initial offset n-1
609 2dup cdr 2swap car drop
616 : restore-continuation-with-arg ( continuation obj -- )
618 >R >R \ Store obj on return stack
620 2dup >R >R \ Store copy of continuation on return stack
624 R> R> \ Pop continuation from return stack
626 R> R> \ Pop obj from return stack
635 \ ---- Primitives ---- {{{
637 : make-primitive ( cfa -- )
644 rot primitive-proc-type ( var prim )
645 global-env obj@ define-var
648 : ensure-arg-count ( args n -- )
650 drop nil objeq? false = if
651 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
655 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
662 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
664 drop nil objeq? false = if
665 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
669 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
672 2dup cdr 2swap car ( ... t1 n args' arg1 )
673 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
675 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
683 : push-args-to-stack ( args -- arg1 arg2 ... argn )
693 : add-fa-checks ( cfa n -- cfa' )
694 here current @ 1+ dup @ , !
698 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
699 ['] push-args-to-stack ,
700 ['] lit , , ['] execute ,
704 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
705 here current @ 1+ dup @ , !
712 dup ( cfa t1 t2 ... tn n m )
717 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
723 ['] lit , , ['] ensure-arg-type-and-count ,
725 ['] push-args-to-stack ,
726 ['] lit , , ['] execute ,
732 : make-fa-primitive ( cfa n -- )
733 add-fa-checks make-primitive ;
735 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
736 add-fa-type-checks make-primitive ;
739 bold fg red ." Incorrect argument type." reset-term cr
743 : ensure-arg-type ( arg type -- arg )
745 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
752 \ ---- Macros ---- {{{
756 ( Look up macro in macro table. Returns nil if
758 : lookup-macro ( name_symbol -- proc )
760 symbol-type istype? invert if
761 \ Early exit if argument is not a symbol
783 : make-macro ( name_symbol params body env -- )
786 2swap ( proc name_symbol )
793 2over 2over ( proc name table name table )
795 2swap 2drop ( proc table )
807 macro-table obj@ cons
816 variable stored-parse-idx
817 create parse-str 161 allot
818 variable parse-str-span
820 create parse-idx-stack 10 allot
821 variable parse-idx-sp
822 parse-idx-stack parse-idx-sp !
825 parse-idx @ parse-idx-sp @ !
830 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
834 parse-idx-sp @ @ parse-idx ! ;
838 '\n' parse-str parse-str-span @ + !
839 1 parse-str-span +! ;
842 4 parse-str parse-str-span @ + !
843 1 parse-str-span +! ;
850 current-input-port obj@ console-i/o-port obj@ objeq? if
851 parse-str 160 expect cr
852 span @ parse-str-span !
854 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
855 drop swap parse-str-span !
857 parse-str-span @ 0= and if append-eof then
868 : charavailable? ( -- bool )
869 parse-str-span @ parse-idx @ > ;
871 : nextchar ( -- char )
872 charavailable? false = if getline then
873 parse-str parse-idx @ + @ ;
876 : whitespace? ( -- bool )
888 nextchar [char] ( = or
889 nextchar [char] ) = or
892 : commentstart? ( -- bool )
893 nextchar [char] ; = ;
897 false \ Indicates whether or not we're eating a comment
900 dup whitespace? or commentstart? or
902 dup nextchar '\n' = and if
903 invert \ Stop eating comment
905 dup false = commentstart? and if
906 invert \ Begin eating comment
921 nextchar [char] - = ;
924 nextchar [char] + = ;
926 : fixnum? ( -- bool )
952 : flonum? ( -- bool )
959 \ Record starting parse idx:
960 \ Want to detect whether any characters (following +/-) were eaten.
967 [char] . nextchar = if
974 [char] e nextchar = [char] E nextchar = or if
982 drop pop-parse-idx false exit
990 \ This is a real number if characters were
991 \ eaten and the next characer is a delimiter.
992 parse-idx @ < delim? and
997 : ratnum? ( -- bool )
1005 pop-parse-idx false exit
1014 [char] / nextchar <> if
1015 pop-parse-idx false exit
1021 pop-parse-idx false exit
1030 delim? pop-parse-idx
1033 : boolean? ( -- bool )
1034 nextchar [char] # <> if false exit then
1039 nextchar [char] t <>
1040 nextchar [char] f <>
1041 and if pop-parse-idx false exit then
1053 : str-equiv? ( str -- bool )
1070 delim? false = if drop false then
1075 : character? ( -- bool )
1076 nextchar [char] # <> if false exit then
1081 nextchar [char] \ <> if pop-parse-idx false exit then
1085 S" newline" str-equiv? if pop-parse-idx true exit then
1086 S" space" str-equiv? if pop-parse-idx true exit then
1087 S" tab" str-equiv? if pop-parse-idx true exit then
1089 charavailable? false = if pop-parse-idx false exit then
1095 nextchar [char] ( = ;
1097 : string? ( -- bool )
1098 nextchar [char] " = ;
1100 : readfixnum ( -- fixnum )
1111 10 * nextchar [char] 0 - +
1120 : readflonum ( -- flonum )
1122 dup 0< swap abs i->f
1124 [char] . nextchar = if
1130 nextchar [char] 0 - i->f ( f exp d )
1131 over f/ rot f+ ( exp f' )
1132 swap 10.0 f* ( f' exp' )
1139 [char] e nextchar = [char] E nextchar = or if
1142 readfixnum drop i->f
1153 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1160 fixnum-type swap fixnum-type
1161 cons drop ratnum-type
1165 : readratnum ( -- ratnum )
1166 readfixnum inc-parse-idx readfixnum
1170 : readbool ( -- bool-obj )
1173 nextchar [char] f = if
1184 : readchar ( -- char-obj )
1188 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1189 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1190 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1192 nextchar character-type
1197 : readstring ( -- charlist )
1202 nextchar [char] " <>
1204 nextchar [char] \ = if
1207 [char] n of '\n' endof
1208 [char] " of [char] " endof
1214 inc-parse-idx character-type
1217 ( firstchar prevchar thischar )
1220 2drop 2swap 2drop 2dup ( thischar thischar )
1222 ( firstchar thischar prevchar )
1223 2over 2swap set-cdr! ( firstchar thischar )
1227 \ Discard previous character
1233 ." No delimiter following right double quote. Aborting." cr
1245 : readsymbol ( -- charlist )
1246 delim? if nil exit then
1248 nextchar inc-parse-idx character-type
1255 : readpair ( -- pairobj )
1259 nextchar [char] ) = if
1264 ." No delimiter following right paren. Aborting." cr
1273 \ Read first pair element
1278 nextchar [char] . = if
1283 ." No delimiter following '.'. Aborting." cr
1297 \ Parse a scheme expression
1332 nextchar [char] " <> if
1333 bold red ." Missing closing double-quote." reset-term cr
1351 nextchar [char] ) <> if
1352 bold red ." Missing closing paren." reset-term cr
1361 nextchar [char] ' = if
1363 quote-symbol recurse nil cons cons exit
1366 nextchar [char] ` = if
1368 quasiquote-symbol recurse nil cons cons exit
1371 nextchar [char] , = if
1373 nextchar [char] @ = if
1375 unquote-splicing-symbol recurse nil cons cons exit
1377 unquote-symbol recurse nil cons cons exit
1387 nextchar [char] ) = if
1389 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1392 \ Anything else is parsed as a symbol
1393 readsymbol charlist>symbol
1395 \ Replace λ with lambda
1396 2dup λ-symbol objeq? if
1405 \ ---- Syntax ---- {{{
1407 : self-evaluating? ( obj -- obj bool )
1408 boolean-type istype? if true exit then
1409 fixnum-type istype? if true exit then
1410 flonum-type istype? if true exit then
1411 ratnum-type istype? if true exit then
1412 character-type istype? if true exit then
1413 string-type istype? if true exit then
1414 nil-type istype? if true exit then
1415 none-type istype? if true exit then
1420 : tagged-list? ( obj tag-obj -- obj bool )
1422 pair-type istype? false = if
1428 : quote? ( obj -- obj bool )
1429 quote-symbol tagged-list? ;
1431 : quote-body ( quote-obj -- quote-body-obj )
1434 : variable? ( obj -- obj bool )
1435 symbol-type istype? ;
1437 : definition? ( obj -- obj bool )
1438 define-symbol tagged-list? ;
1440 : definition-var ( obj -- var )
1443 : definition-val ( obj -- val )
1446 : assignment? ( obj -- obj bool )
1447 set!-symbol tagged-list? ;
1449 : assignment-var ( obj -- var )
1452 : assignment-val ( obj -- val )
1455 : macro-definition? ( obj -- obj bool )
1456 define-macro-symbol tagged-list? ;
1458 : macro-definition-name ( exp -- mname )
1461 : macro-definition-params ( exp -- params )
1464 : macro-definition-body ( exp -- body )
1467 : if? ( obj -- obj bool )
1468 if-symbol tagged-list? ;
1470 : if-predicate ( ifobj -- pred )
1473 : if-consequent ( ifobj -- conseq )
1476 : if-alternative ( ifobj -- alt|none )
1484 : false? ( boolobj -- boolean )
1485 boolean-type istype? if
1486 false boolean-type objeq?
1492 : true? ( boolobj -- bool )
1495 : lambda? ( obj -- obj bool )
1496 lambda-symbol tagged-list? ;
1498 : lambda-parameters ( obj -- params )
1501 : lambda-body ( obj -- body )
1504 : application? ( obj -- obj bool )
1507 : operator ( obj -- operator )
1510 : operands ( obj -- operands )
1513 : nooperands? ( operands -- bool )
1516 : first-operand ( operands -- operand )
1519 : rest-operands ( operands -- other-operands )
1522 : procedure-params ( proc -- params )
1523 drop pair-type car ;
1525 : procedure-body ( proc -- body )
1526 drop pair-type cdr car ;
1528 : procedure-env ( proc -- body )
1529 drop pair-type cdr cdr car ;
1531 ( Ensure terminating symbol arg name is handled
1532 specially to allow for variadic procedures. )
1533 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1535 2over nil? false = if
1536 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1543 symbol-type istype? if
1553 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1560 recurse ( argvals argnames argvals'' argnames'' )
1561 2rot car 2swap cons ( argvals argvals'' argnames' )
1562 2rot car 2rot cons ( argnames' argvals' )
1568 \ ---- Analyze ---- {{{
1570 : evaluate-eproc ( eproc env --- res )
1581 2drop \ get rid of null
1585 \ Final element of eproc list is primitive procedure
1586 drop \ dump type signifier
1588 goto \ jump straight to primitive procedure (executor)
1591 : self-evaluating-executor ( exp env -- exp )
1594 : analyze-self-evaluating ( exp --- eproc )
1595 ['] self-evaluating-executor primitive-proc-type
1599 : quote-executor ( exp env -- exp )
1602 : analyze-quoted ( exp -- eproc )
1605 ['] quote-executor primitive-proc-type
1609 : variable-executor ( var env -- val )
1612 : analyze-variable ( exp -- eproc )
1613 ['] variable-executor primitive-proc-type
1617 : definition-executor ( var val-eproc env -- ok )
1618 2swap 2over ( var env val-eproc env )
1619 evaluate-eproc 2swap ( var val env )
1624 : analyze-definition ( exp -- eproc )
1626 2swap definition-val analyze
1628 ['] definition-executor primitive-proc-type
1632 : assignment-executor ( var val-eproc env -- ok )
1633 2swap 2over ( var env val-eproc env )
1634 evaluate-eproc 2swap ( var val env )
1639 : analyze-assignment ( exp -- eproc )
1641 2swap assignment-val analyze ( var val-eproc )
1643 ['] assignment-executor primitive-proc-type
1647 : sequence-executor ( eproc-list env -- res )
1651 2dup cdr ( env elist elist-rest)
1654 -2rot car 2over ( elist-rest env elist-head env )
1655 evaluate-eproc ( elist-rest env head-res )
1656 2drop 2swap ( env elist-rest )
1660 ['] evaluate-eproc goto
1664 : (analyze-sequence) ( explist -- eproc-list )
1673 : analyze-sequence ( explist -- eproc )
1675 ['] sequence-executor primitive-proc-type
1680 : macro-definition-executor ( name params bproc env -- ok )
1681 make-macro ok-symbol
1684 : analyze-macro-definition ( exp -- eproc )
1685 2dup macro-definition-name
1686 2swap 2dup macro-definition-params
1687 2swap macro-definition-body analyze-sequence
1689 ['] macro-definition-executor primitive-proc-type
1690 nil cons cons cons cons
1693 : if-executor ( cproc aproc pproc env -- res )
1694 2swap 2over ( cproc aproc env pproc env -- res )
1703 ['] evaluate-eproc goto
1706 : analyze-if ( exp -- eproc )
1707 2dup if-consequent analyze
1708 2swap 2dup if-alternative analyze
1709 2swap if-predicate analyze
1711 ['] if-executor primitive-proc-type
1712 nil cons cons cons cons
1715 : lambda-executor ( params bproc env -- res )
1717 ( Although this is packaged up as a regular compound procedure,
1718 the "body" element contains an _eproc_ to be evaluated in an
1719 environment resulting from extending env with the parameter
1723 : analyze-lambda ( exp -- eproc )
1724 2dup lambda-parameters
1728 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1733 ['] lambda-executor primitive-proc-type
1737 : operand-eproc-list ( operands -- eprocs )
1745 : evaluate-operand-eprocs ( env aprocs -- vals )
1749 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1750 -2rot cdr recurse ( thisval restvals )
1755 : apply ( vals proc )
1757 primitive-proc-type of
1761 compound-proc-type of
1762 2dup procedure-body ( argvals proc bproc )
1763 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1764 -2rot procedure-env ( bproc argnames argvals procenv )
1770 extend-env ( bproc env )
1772 ['] evaluate-eproc goto
1775 continuation-type of
1778 except-message: ." Continuations expect exactly 1 argument."
1779 recoverable-exception throw
1785 except-message: ." Continuations expect exactly 1 argument."
1786 recoverable-exception throw
1791 restore-continuation-with-arg
1794 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1798 : application-executor ( operator-proc arg-procs env -- res )
1799 2rot 2over ( aprocs env fproc env )
1800 evaluate-eproc ( aprocs env proc )
1802 -2rot 2swap ( proc env aprocs )
1803 evaluate-operand-eprocs ( proc vals )
1810 : analyze-application ( exp -- eproc )
1811 2dup operator analyze
1812 2swap operands operand-eproc-list
1814 ['] application-executor primitive-proc-type
1818 :noname ( exp --- eproc )
1820 self-evaluating? if analyze-self-evaluating exit then
1822 quote? if analyze-quoted exit then
1824 variable? if analyze-variable exit then
1826 definition? if analyze-definition exit then
1828 assignment? if analyze-assignment exit then
1830 macro-definition? if analyze-macro-definition exit then
1832 if? if analyze-if exit then
1834 lambda? if analyze-lambda exit then
1836 application? if analyze-application exit then
1838 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1844 \ ---- Macro Expansion ---- {{{
1846 ( Simply evaluates the given procedure with expbody as its argument. )
1847 : macro-eval ( proc expbody -- result )
1849 2dup procedure-body ( expbody proc bproc )
1850 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1851 -2rot procedure-env ( bproc argnames expbody procenv )
1857 extend-env ( bproc env )
1859 ['] evaluate-eproc goto
1862 : expand-macro ( exp -- result )
1863 pair-type istype? invert if exit then
1865 2dup car symbol-type istype? invert if 2drop exit then
1867 lookup-macro nil? if 2drop exit then
1869 2over cdr macro-eval
1871 2dup no-match-symbol objeq? if
1877 R> drop ['] expand goto-deferred
1880 : expand-definition ( exp -- result )
1884 2swap definition-val expand
1885 nil ( define var val' nil )
1889 : expand-assignment ( exp -- result )
1893 2swap assignment-val expand
1894 nil ( define var val' nil )
1898 : expand-list ( exp -- res )
1906 : macro-definition-nameparams
1909 : expand-define-macro ( exp -- res )
1910 define-macro-symbol 2swap
1911 2dup macro-definition-nameparams
1912 2swap macro-definition-body expand-list
1916 : expand-lambda ( exp -- res )
1918 2dup lambda-parameters
1919 2swap lambda-body expand-list
1923 : expand-if ( exp -- res )
1926 2dup if-predicate expand
1927 2swap 2dup if-consequent expand
1928 2swap if-alternative none? if
1936 : expand-application ( exp -- res )
1937 2dup operator expand
1938 2swap operands expand-list
1942 :noname ( exp -- result )
1945 self-evaluating? if exit then
1949 definition? if expand-definition exit then
1951 assignment? if expand-assignment exit then
1953 macro-definition? if expand-define-macro exit then
1955 lambda? if expand-lambda exit then
1957 if? if expand-if exit then
1959 application? if expand-application exit then
1965 :noname ( exp env -- res )
1966 2swap expand analyze 2swap evaluate-eproc
1969 \ ---- Print ---- {{{
1971 : printfixnum ( fixnum -- ) drop 0 .R ;
1973 : printflonum ( flonum -- ) drop f. ;
1975 : printratnum ( ratnum -- )
1977 car print ." /" cdr print
1980 : printbool ( bool -- )
1988 : printchar ( charobj -- )
1991 9 of ." #\tab" endof
1992 bl of ." #\space" endof
1993 '\n' of ." #\newline" endof
1999 : (printstring) ( stringobj -- )
2000 nil? if 2drop exit then
2004 '\n' of ." \n" drop endof
2005 [char] \ of ." \\" drop endof
2006 [char] " of [char] \ emit [char] " emit drop endof
2012 : printstring ( stringobj -- )
2017 : printsymbol ( symbolobj -- )
2018 nil-type istype? if 2drop exit then
2024 : printnil ( nilobj -- )
2027 : printpair ( pairobj -- )
2031 nil-type istype? if 2drop exit then
2032 pair-type istype? if space recurse exit then
2036 : printprim ( primobj -- )
2037 2drop ." <primitive procedure>" ;
2039 : printcomp ( primobj -- )
2040 2drop ." <compound procedure>" ;
2042 : printcont ( primobj --)
2043 2drop ." <continuation>" ;
2045 : printnone ( noneobj -- )
2046 2drop ." Unspecified return value" ;
2048 : printport ( port -- )
2052 fixnum-type istype? if printfixnum exit then
2053 flonum-type istype? if printflonum exit then
2054 ratnum-type istype? if printratnum exit then
2055 boolean-type istype? if printbool exit then
2056 character-type istype? if printchar exit then
2057 string-type istype? if printstring exit then
2058 symbol-type istype? if printsymbol exit then
2059 nil-type istype? if printnil exit then
2060 pair-type istype? if ." (" printpair ." )" exit then
2061 primitive-proc-type istype? if printprim exit then
2062 compound-proc-type istype? if printcomp exit then
2063 continuation-type istype? if printcont exit then
2064 none-type istype? if printnone exit then
2065 port-type istype? if printport exit then
2067 except-message: ." tried to print object with unknown type." recoverable-exception throw
2072 \ ---- Garbage Collection ---- {{{
2074 ( Notes on garbage collection:
2075 This is a mark-sweep garbage collector, invoked by cons.
2076 The roots of the object tree used by the marking routine
2077 include all objects in the parameter stack, and several
2078 other fixed roots such as global-env, symbol-table, macro-table,
2079 and the console-i/o-port.
2081 NO OTHER OBJECTS WILL BE MARKED!
2083 This places implicit restrictions on when cons can be invoked.
2084 Invoking cons when live objects are stored on the return stack
2085 or in other variables than the above will result in possible
2086 memory corruption if the cons triggers the GC. )
2089 : pairlike? ( obj -- obj bool )
2090 pair-type istype? if true exit then
2091 string-type istype? if true exit then
2092 symbol-type istype? if true exit then
2093 compound-proc-type istype? if true exit then
2094 port-type istype? if true exit then
2099 : pairlike-marked? ( obj -- obj bool )
2100 over nextfrees + @ 0=
2103 : mark-pairlike ( obj -- obj )
2104 over nextfrees + 0 swap !
2113 : gc-mark-obj ( obj -- )
2115 pairlike? invert if 2drop exit then
2116 pairlike-marked? if 2drop exit then
2127 scheme-memsize nextfree !
2128 0 scheme-memsize 1- do
2129 nextfrees i + @ 0<> if
2130 nextfree @ nextfrees i + !
2136 \ Following a GC, this gives the amount of free memory
2140 nextfrees i + @ 0= if 1+ then
2144 \ Debugging word - helps spot memory that is retained
2147 nextfrees i + @ 0<> if
2159 symbol-table obj@ gc-mark-obj
2160 macro-table obj@ gc-mark-obj
2161 console-i/o-port obj@ gc-mark-obj
2162 global-env obj@ gc-mark-obj
2164 depth object-stack-base @ do
2173 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2174 ; is collect-garbage
2178 \ ---- Loading files ---- {{{
2180 : load ( addr n -- finalResult )
2185 ok-symbol ( port res )
2189 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2191 2over read-port ( port res obj )
2196 2dup EOF character-type objeq? if
2197 2drop 2swap close-port
2201 2swap 2drop ( port obj )
2203 global-env obj@ eval ( port res )
2209 \ ---- Standard Library ---- {{{
2211 include scheme-primitives.4th
2213 init-object-stack-base
2214 s" scheme-library.scm" load 2drop
2220 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2221 : repl-body ( -- bool )
2222 cr bold fg green ." > " reset-term
2226 2dup EOF character-type objeq? if
2228 bold fg blue ." Moriturus te saluto." reset-term cr
2232 global-env obj@ eval
2234 fg cyan ." ; " print reset-term
2242 init-object-stack-base
2244 \ Display welcome message
2245 welcome-symbol nil cons global-env obj@ eval 2drop
2250 recoverable-exception of false endof
2251 unrecoverable-exception of true endof