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
43 : istype? ( obj type -- obj bool )
48 \ ---- Exceptions ---- {{{
50 variable nextexception
53 create nextexception @ ,
62 make-exception recoverable-exception
63 make-exception unrecoverable-exception
65 : throw reset-term throw ;
69 \ ---- List-structured memory ---- {{{
71 20000 constant scheme-memsize
73 create car-cells scheme-memsize allot
74 create car-type-cells scheme-memsize allot
75 create cdr-cells scheme-memsize allot
76 create cdr-type-cells scheme-memsize allot
78 create nextfrees scheme-memsize allot
89 nextfrees nextfree @ + @
92 nextfree @ scheme-memsize >= if
96 nextfree @ scheme-memsize >= if
97 except-message: ." Out of memory!" unrecoverable-exception throw
101 : cons ( car-obj cdr-obj -- pair-obj )
102 cdr-type-cells nextfree @ + !
103 cdr-cells nextfree @ + !
104 car-type-cells nextfree @ + !
105 car-cells nextfree @ + !
111 : car ( pair-obj -- car-obj )
113 dup car-cells + @ swap
117 : cdr ( pair-obj -- car-obj )
119 dup cdr-cells + @ swap
123 : set-car! ( obj pair-obj -- )
125 rot swap car-type-cells + !
129 : set-cdr! ( obj pair-obj -- )
131 rot swap cdr-type-cells + !
136 : nil? nil-type istype? ;
139 : none? none-type istype? ;
141 : objvar create nil swap , , ;
143 : value@ ( objvar -- val ) @ ;
144 : type@ ( objvar -- type ) 1+ @ ;
145 : value! ( newval objvar -- ) ! ;
146 : type! ( newtype objvar -- ) 1+ ! ;
147 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
148 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
150 : objeq? ( obj obj -- bool )
153 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
154 >R >R ( a1 a2 b1 b2 )
155 2swap ( b1 b2 a1 a2 )
156 R> R> ( b1 b2 a1 a2 c1 c2 )
160 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
161 2swap ( a1 a2 c1 c2 b1 b2 )
162 >R >R ( a1 a2 c1 c2 )
163 2swap ( c1 c2 a1 a2 )
167 : 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
173 \ ---- Pre-defined symbols ---- {{{
177 : duplicate-charlist ( charlist -- copy )
179 2dup car 2swap cdr recurse cons
182 : charlist-equiv ( charlist charlist -- bool )
191 2drop 2drop true exit
193 2drop 2drop false exit
198 2drop 2drop false exit
205 car drop -rot car drop = if
206 cdr 2swap cdr recurse
212 : charlist>symbol ( charlist -- symbol-obj )
231 drop symbol-type 2dup
232 symbol-table obj@ cons
237 : cstr>charlist ( addr n -- charlist )
241 2dup drop @ character-type 2swap
249 : create-symbol ( -- )
257 does> dup @ swap 1+ @
260 create-symbol quote quote-symbol
261 create-symbol quasiquote quasiquote-symbol
262 create-symbol unquote unquote-symbol
263 create-symbol unquote-splicing unquote-splicing-symbol
264 create-symbol define define-symbol
265 create-symbol define-macro define-macro-symbol
266 create-symbol set! set!-symbol
267 create-symbol ok ok-symbol
268 create-symbol if if-symbol
269 create-symbol lambda lambda-symbol
270 create-symbol λ λ-symbol
271 create-symbol eof eof-symbol
272 create-symbol no-match no-match-symbol
274 \ Symbol to be bound to welcome message procedure by library
275 create-symbol welcome welcome-symbol
279 \ ---- Port I/O ---- {{{
281 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
283 : fileport>fid ( fileport -- fid )
284 drop pair-type car drop ;
286 : get-last-peek ( fileport -- char/nil )
289 : set-last-peek ( char/nil fileport -- )
290 drop pair-type set-cdr!
293 : fid>fileport ( fid -- fileport )
294 fixnum-type nil cons drop port-type ;
296 : open-input-file ( addr n -- fileport )
297 r/o open-file drop fid>fileport
300 : close-port ( fileport -- )
301 fileport>fid close-file drop
304 objvar console-i/o-port
305 0 fixnum-type nil cons drop port-type console-i/o-port obj!
307 objvar current-input-port
308 console-i/o-port obj@ current-input-port obj!
310 : read-char ( port -- char )
311 2dup get-last-peek nil? if
313 2dup console-i/o-port obj@ objeq? if
317 fileport>fid pad 1 rot read-file 0= if
328 : peek-char ( port -- char )
329 2dup get-last-peek nil? if
331 2dup 2rot set-last-peek
337 variable read-line-buffer-span
338 variable read-line-buffer-offset
340 ( Hack to save original read-line while we transition to new one. )
341 : orig-read-line immediate
344 : read-line ( port -- string )
349 0 read-line-buffer-offset !
351 2over nil 2swap set-last-peek
353 2drop nil nil cons exit
356 1 read-line-buffer-offset !
360 2dup console-i/o-port obj@ objeq? if
362 pad read-line-buffer-offset @ + 200 expect cr
363 span @ read-line-buffer-offset @ + read-line-buffer-span !
365 pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
366 drop swap read-line-buffer-offset @ + read-line-buffer-span !
372 read-line-buffer-span @ 0>
374 pad read-line-buffer-span @ 1- + @ character-type 2swap cons
375 -1 read-line-buffer-span +!
379 nil cons drop string-type
385 : read-port ( fileport -- obj )
386 current-input-port obj!
389 : read-console ( -- obj )
390 console-i/o-port obj@ read-port ;
394 \ ---- Environments ---- {{{
396 : enclosing-env ( env -- env )
399 : first-frame ( env -- frame )
402 : make-frame ( vars vals -- frame )
405 : frame-vars ( frame -- vars )
408 : frame-vals ( frame -- vals )
411 : add-binding ( var val frame -- )
412 2swap 2over frame-vals cons
414 2swap 2over frame-vars cons
418 : extend-env ( vars vals env -- env )
428 : get-vars-vals-frame ( var frame -- bool )
429 2dup frame-vars vars obj!
433 vars obj@ nil objeq? false =
435 2dup vars obj@ car objeq? if
440 vars obj@ cdr vars obj!
441 vals obj@ cdr vals obj!
447 : get-vars-vals ( var env -- vars? vals? bool )
452 2over 2over first-frame
453 get-vars-vals-frame if
455 vars obj@ vals obj@ true
471 : lookup-var ( var env -- val )
476 except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception throw
480 : set-var ( var val env -- )
481 >R >R 2swap R> R> ( val var env )
484 2swap 2drop ( val vals )
487 except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw
495 : define-var ( var val env -- )
498 2over env obj@ ( var val var env )
500 2swap 2drop ( var val vals )
505 first-frame ( var val frame )
512 : make-procedure ( params body env -- proc )
515 drop compound-proc-type
519 nil nil nil extend-env
524 \ ---- Primitives ---- {{{
526 : make-primitive ( cfa -- )
533 rot primitive-proc-type ( var prim )
534 global-env obj@ define-var
537 : ensure-arg-count ( args n -- )
539 drop nil objeq? false = if
540 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
544 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
551 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
553 drop nil objeq? false = if
554 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
558 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
561 2dup cdr 2swap car ( ... t1 n args' arg1 )
562 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
564 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
572 : push-args-to-stack ( args -- arg1 arg2 ... argn )
582 : add-fa-checks ( cfa n -- cfa' )
583 here current @ 1+ dup @ , !
587 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
588 ['] push-args-to-stack ,
589 ['] lit , , ['] execute ,
593 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
594 here current @ 1+ dup @ , !
601 dup ( cfa t1 t2 ... tn n m )
606 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
612 ['] lit , , ['] ensure-arg-type-and-count ,
614 ['] push-args-to-stack ,
615 ['] lit , , ['] execute ,
621 : make-fa-primitive ( cfa n -- )
622 add-fa-checks make-primitive ;
624 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
625 add-fa-type-checks make-primitive ;
628 bold fg red ." Incorrect argument type." reset-term cr
632 : ensure-arg-type ( arg type -- arg )
634 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
641 \ ---- Macros ---- {{{
645 ( Look up macro in macro table. Returns nil if
647 : lookup-macro ( name_symbol -- proc )
649 symbol-type istype? invert if
650 \ Early exit if argument is not a symbol
672 : make-macro ( name_symbol params body env -- )
675 2swap ( proc name_symbol )
682 2over 2over ( proc name table name table )
684 2swap 2drop ( proc table )
696 macro-table obj@ cons
705 variable stored-parse-idx
706 create parse-str 161 allot
707 variable parse-str-span
709 create parse-idx-stack 10 allot
710 variable parse-idx-sp
711 parse-idx-stack parse-idx-sp !
714 parse-idx @ parse-idx-sp @ !
719 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
723 parse-idx-sp @ @ parse-idx ! ;
727 '\n' parse-str parse-str-span @ + !
728 1 parse-str-span +! ;
731 4 parse-str parse-str-span @ + !
732 1 parse-str-span +! ;
739 current-input-port obj@ console-i/o-port obj@ objeq? if
740 parse-str 160 expect cr
741 span @ parse-str-span !
743 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
744 drop swap parse-str-span !
746 parse-str-span @ 0= and if append-eof then
757 : charavailable? ( -- bool )
758 parse-str-span @ parse-idx @ > ;
760 : nextchar ( -- char )
761 charavailable? false = if getline then
762 parse-str parse-idx @ + @ ;
765 : whitespace? ( -- bool )
777 nextchar [char] ( = or
778 nextchar [char] ) = or
781 : commentstart? ( -- bool )
782 nextchar [char] ; = ;
786 false \ Indicates whether or not we're eating a comment
789 dup whitespace? or commentstart? or
791 dup nextchar '\n' = and if
792 invert \ Stop eating comment
794 dup false = commentstart? and if
795 invert \ Begin eating comment
810 nextchar [char] - = ;
813 nextchar [char] + = ;
815 : fixnum? ( -- bool )
841 : flonum? ( -- bool )
848 \ Record starting parse idx:
849 \ Want to detect whether any characters (following +/-) were eaten.
856 [char] . nextchar = if
863 [char] e nextchar = [char] E nextchar = or if
871 drop pop-parse-idx false exit
879 \ This is a real number if characters were
880 \ eaten and the next characer is a delimiter.
881 parse-idx @ < delim? and
886 : ratnum? ( -- bool )
894 pop-parse-idx false exit
903 [char] / nextchar <> if
904 pop-parse-idx false exit
910 pop-parse-idx false exit
922 : boolean? ( -- bool )
923 nextchar [char] # <> if false exit then
930 and if pop-parse-idx false exit then
942 : str-equiv? ( str -- bool )
959 delim? false = if drop false then
964 : character? ( -- bool )
965 nextchar [char] # <> if false exit then
970 nextchar [char] \ <> if pop-parse-idx false exit then
974 S" newline" str-equiv? if pop-parse-idx true exit then
975 S" space" str-equiv? if pop-parse-idx true exit then
976 S" tab" str-equiv? if pop-parse-idx true exit then
978 charavailable? false = if pop-parse-idx false exit then
984 nextchar [char] ( = ;
986 : string? ( -- bool )
987 nextchar [char] " = ;
989 : readfixnum ( -- fixnum )
1000 10 * nextchar [char] 0 - +
1009 : readflonum ( -- flonum )
1011 dup 0< swap abs i->f
1013 [char] . nextchar = if
1019 nextchar [char] 0 - i->f ( f exp d )
1020 over f/ rot f+ ( exp f' )
1021 swap 10.0 f* ( f' exp' )
1028 [char] e nextchar = [char] E nextchar = or if
1031 readfixnum drop i->f
1042 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1049 fixnum-type swap fixnum-type
1050 cons drop ratnum-type
1054 : readratnum ( -- ratnum )
1055 readfixnum inc-parse-idx readfixnum
1059 : readbool ( -- bool-obj )
1062 nextchar [char] f = if
1073 : readchar ( -- char-obj )
1077 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1078 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1079 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1081 nextchar character-type
1086 : readstring ( -- charlist )
1091 nextchar [char] " <>
1093 nextchar [char] \ = if
1096 [char] n of '\n' endof
1097 [char] " of [char] " endof
1103 inc-parse-idx character-type
1106 ( firstchar prevchar thischar )
1109 2drop 2swap 2drop 2dup ( thischar thischar )
1111 ( firstchar thischar prevchar )
1112 2over 2swap set-cdr! ( firstchar thischar )
1116 \ Discard previous character
1122 ." No delimiter following right double quote. Aborting." cr
1134 : readsymbol ( -- charlist )
1135 delim? if nil exit then
1137 nextchar inc-parse-idx character-type
1144 : readpair ( -- pairobj )
1148 nextchar [char] ) = if
1153 ." No delimiter following right paren. Aborting." cr
1162 \ Read first pair element
1167 nextchar [char] . = if
1172 ." No delimiter following '.'. Aborting." cr
1186 \ Parse a scheme expression
1221 nextchar [char] " <> if
1222 bold red ." Missing closing double-quote." reset-term cr
1240 nextchar [char] ) <> if
1241 bold red ." Missing closing paren." reset-term cr
1250 nextchar [char] ' = if
1252 quote-symbol recurse nil cons cons exit
1255 nextchar [char] ` = if
1257 quasiquote-symbol recurse nil cons cons exit
1260 nextchar [char] , = if
1262 nextchar [char] @ = if
1264 unquote-splicing-symbol recurse nil cons cons exit
1266 unquote-symbol recurse nil cons cons exit
1276 \ Anything else is parsed as a symbol
1277 readsymbol charlist>symbol
1279 \ Replace λ with lambda
1280 2dup λ-symbol objeq? if
1289 \ ---- Eval ---- {{{
1291 : self-evaluating? ( obj -- obj bool )
1292 boolean-type istype? if true exit then
1293 fixnum-type istype? if true exit then
1294 flonum-type istype? if true exit then
1295 ratnum-type istype? if true exit then
1296 character-type istype? if true exit then
1297 string-type istype? if true exit then
1298 nil-type istype? if true exit then
1299 none-type istype? if true exit then
1304 : tagged-list? ( obj tag-obj -- obj bool )
1306 pair-type istype? false = if
1312 : quote? ( obj -- obj bool )
1313 quote-symbol tagged-list? ;
1315 : quote-body ( quote-obj -- quote-body-obj )
1318 : quasiquote? ( obj -- obj bool )
1319 quasiquote-symbol tagged-list? ;
1321 : unquote? ( obj -- obj bool )
1322 unquote-symbol tagged-list? ;
1324 : unquote-splicing? ( obj -- obj bool )
1325 unquote-splicing-symbol tagged-list? ;
1327 : eval-unquote ( env obj -- res )
1331 except-message: ." no arguments to unquote." recoverable-exception throw
1336 except-message: ." too many arguments to unquote." recoverable-exception throw
1339 2drop car 2swap eval
1342 ( Create a new list from elements of l1 consed on to l2 )
1343 : join-lists ( l2 l1 -- l3 )
1344 nil? if 2drop exit then
1351 defer eval-quasiquote-item
1352 : eval-quasiquote-pair ( env obj -- res )
1353 2over 2over ( env obj env obj )
1355 cdr eval-quasiquote-item
1357 -2rot car ( cdritem env objcar )
1359 unquote-splicing? if
1360 eval-unquote ( cdritems caritem )
1368 eval-quasiquote-item ( cdritems caritem )
1383 pair-type istype? if
1384 eval-quasiquote-pair exit
1388 ; is eval-quasiquote-item
1390 : eval-quasiquote ( obj env -- res )
1391 2swap cdr ( env args )
1394 except-message: ." no arguments to quasiquote." recoverable-exception throw
1397 2dup cdr ( env args args-cdr )
1399 except-message: ." too many arguments to quasiquote." recoverable-exception throw
1402 2drop car ( env arg )
1404 eval-quasiquote-item
1407 : variable? ( obj -- obj bool )
1408 symbol-type istype? ;
1410 : definition? ( obj -- obj bool )
1411 define-symbol tagged-list? ;
1413 : definition-var ( obj -- var )
1416 : definition-val ( obj -- val )
1419 : eval-definition ( obj env -- res )
1422 definition-val 2swap
1425 2swap definition-var 2swap
1433 : assignment? ( obj -- obj bool )
1434 set!-symbol tagged-list? ;
1436 : assignment-var ( obj -- var )
1439 : assignment-val ( obj -- val )
1442 : eval-assignment ( obj env -- res )
1444 2over 2over ( env obj env obj )
1445 assignment-val 2swap ( env obj valexp env )
1446 eval ( env obj val )
1448 2swap assignment-var 2swap ( env var val )
1450 2rot ( var val env )
1456 : macro-definition? ( obj -- obj bool )
1457 define-macro-symbol tagged-list? ;
1459 : macro-definition-name ( exp -- mname )
1462 : macro-definition-params ( exp -- params )
1465 : macro-definition-body ( exp -- body )
1469 : eval-define-macro ( obj env -- res )
1472 2dup macro-definition-name 2swap ( name obj )
1473 2dup macro-definition-params 2swap ( name params obj )
1474 macro-definition-body ( name params body )
1476 env obj@ ( name params body env )
1484 : if? ( obj -- obj bool )
1485 if-symbol tagged-list? ;
1487 : if-predicate ( ifobj -- pred )
1490 : if-consequent ( ifobj -- conseq )
1493 : if-alternative ( ifobj -- alt|none )
1501 : false? ( boolobj -- boolean )
1502 boolean-type istype? if
1503 false boolean-type objeq?
1509 : true? ( boolobj -- bool )
1512 : lambda? ( obj -- obj bool )
1513 lambda-symbol tagged-list? ;
1515 : lambda-parameters ( obj -- params )
1518 : lambda-body ( obj -- body )
1521 : eval-sequence ( explist env -- finalexp env )
1522 ( Evaluates all bar the final expressions in
1523 an an expression list. The final expression
1524 is returned to allow for tail optimization. )
1526 2swap ( env explist )
1528 \ Abort on empty list
1535 2dup cdr ( env explist nextexplist )
1538 -2rot car 2over ( nextexplist env exp env )
1540 2drop \ discard result
1541 2swap ( env nextexplist )
1544 2drop car 2swap ( finalexp env )
1547 : application? ( obj -- obj bool )
1550 : operator ( obj -- operator )
1553 : operands ( obj -- operands )
1556 : nooperands? ( operands -- bool )
1559 : first-operand ( operands -- operand )
1562 : rest-operands ( operands -- other-operands )
1565 : list-of-vals ( args env -- vals )
1571 2over 2over first-operand 2swap eval
1572 -2rot rest-operands 2swap recurse
1577 : procedure-params ( proc -- params )
1578 drop pair-type car ;
1580 : procedure-body ( proc -- body )
1581 drop pair-type cdr car ;
1583 : procedure-env ( proc -- body )
1584 drop pair-type cdr cdr car ;
1586 ( Ensure terminating symbol arg name is handled
1587 specially to allow for variadic procedures. )
1588 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1590 2over nil? false = if
1591 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1598 symbol-type istype? if
1608 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1615 recurse ( argvals argnames argvals'' argnames'' )
1616 2rot car 2swap cons ( argvals argvals'' argnames' )
1617 2rot car 2rot cons ( argnames' argvals' )
1621 : apply ( proc argvals -- result )
1623 primitive-proc-type of
1627 compound-proc-type of
1628 2dup procedure-body ( argvals proc body )
1629 -2rot 2dup procedure-params ( body argvals proc argnames )
1630 -2rot procedure-env ( body argnames argvals procenv )
1636 extend-env ( body env )
1640 R> drop ['] eval goto-deferred \ Tail call optimization
1643 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1647 :noname ( obj env -- result )
1652 fg yellow ." Evaluating: " bold 2dup print reset-term
1653 space fg green ." PS: " bold depth . reset-term
1654 space fg blue ." RS: " bold RSP@ RSP0 - . reset-term cr
1669 2swap eval-quasiquote
1679 2swap eval-definition
1684 2swap eval-assignment
1688 macro-definition? if
1689 2swap eval-define-macro
1705 ['] eval goto-deferred
1709 2dup lambda-parameters
1717 2over 2over ( env exp env exp )
1718 operator ( env exp env opname )
1720 2swap eval ( env exp proc )
1722 -2rot ( proc env exp )
1723 operands 2swap ( proc operands env )
1724 list-of-vals ( proc argvals )
1730 except-message: ." tried to evaluate object with unknown type." recoverable-exception throw
1737 : evaluate-eproc ( env eproc --- res )
1745 2drop \ get rid of null
1747 \ Final element of eproc list is primitive procedure
1748 drop \ dump type signifier
1749 goto \ jump straight to primitive procedure (executor)
1752 : self-evaluating-executor ( env exp -- exp )
1755 : analyze-self-evaluating ( exp --- eproc )
1756 ['] self-evaluating-executor primitive-proc-type
1760 : quote-executor ( env exp -- exp )
1763 : analyze-quoted ( exp -- eproc )
1766 ['] quote-executor primitive-proc-type
1770 : variable-executor ( env var -- val )
1773 : analyze-variable ( exp -- eproc )
1774 ['] variable-executor primitive-proc-type
1778 : definition-executor ( env var val-eproc -- ok )
1779 2rot 2dup 2rot ( var env env val-eproc )
1780 evaluate-eproc 2swap ( var val env )
1785 : analyze-definition ( exp -- eproc )
1787 2swap definition-val analyze
1789 ['] definition-executor primitive-proc-type
1793 : assignment-executor ( env var val-eproc -- ok )
1794 2rot 2dup 2rot ( var env env val-eproc )
1795 evaluate-eproc 2swap ( var val env )
1800 : analyze-assignment ( exp -- eproc )
1802 2swap assignment-val analyze ( var val-eproc )
1804 ['] assignment-executor primitive-proc-type
1808 : if-executor ( env pproc cproc aproc -- res )
1809 2rot 3 2pick 2swap ( env cproc aproc env pproc )
1812 2drop evaluate-eproc
1814 2swap 2drop evaluate-eproc
1818 : analyze-if ( exp -- eproc )
1819 2dup if-predicate analyze
1820 2swap 2dup if-consequent analyze
1821 2swap if-alternative analyze
1823 ['] if-executor primitive-proc-type
1824 nil cons cons cons cons
1827 :noname ( exp --- eproc )
1830 analyze-self-evaluating
1862 \ ---- Macro Expansion ---- {{{
1864 ( Simply evaluates the given procedure with expbody as its argument. )
1865 : macro-eval ( proc expbody -- result )
1867 2dup procedure-body ( expbody proc procbody )
1868 -2rot 2dup procedure-params ( procbody expbody proc argnames )
1869 -2rot procedure-env ( procbody argnames expbody procenv )
1875 extend-env eval-sequence eval
1878 : expand-macro ( exp -- result )
1879 pair-type istype? invert if exit then
1880 2dup car symbol-type istype? invert if 2drop exit then
1882 lookup-macro nil? if
1885 2over cdr macro-eval
1887 2dup no-match-symbol objeq? if
1893 R> drop ['] expand goto-deferred
1896 : expand-quasiquote-item ( exp -- result )
1900 unquote-symbol 2swap cdr car expand nil cons cons
1904 unquote-splicing? if
1905 unquote-splicing-symbol 2swap cdr car expand nil cons cons
1909 pair-type istype? if
1916 : expand-quasiquote ( exp -- result )
1917 quasiquote-symbol 2swap cdr
1919 expand-quasiquote-item
1923 : expand-definition ( exp -- result )
1927 2swap definition-val expand
1928 nil ( define var val' nil )
1932 : expand-assignment ( exp -- result )
1936 2swap assignment-val expand
1937 nil ( define var val' nil )
1941 : expand-list ( exp -- res )
1949 : macro-definition-nameparams
1952 : expand-define-macro ( exp -- res )
1953 define-macro-symbol 2swap
1954 2dup macro-definition-nameparams
1955 2swap macro-definition-body expand-list
1959 : expand-lambda ( exp -- res )
1961 2dup lambda-parameters
1962 2swap lambda-body expand-list
1966 : expand-if ( exp -- res )
1969 2dup if-predicate expand
1970 2swap 2dup if-consequent expand
1971 2swap if-alternative none? if
1979 : expand-application ( exp -- res )
1980 2dup operator expand
1981 2swap operands expand-list
1985 :noname ( exp -- result )
1988 self-evaluating? if exit then
1992 quasiquote? if expand-quasiquote exit then
1994 definition? if expand-definition exit then
1996 assignment? if expand-assignment exit then
1998 macro-definition? if expand-define-macro exit then
2000 lambda? if expand-lambda exit then
2002 if? if expand-if exit then
2004 application? if expand-application exit then
2010 \ ---- Print ---- {{{
2012 : printfixnum ( fixnum -- ) drop 0 .R ;
2014 : printflonum ( flonum -- ) drop f. ;
2016 : printratnum ( ratnum -- )
2018 car print ." /" cdr print
2021 : printbool ( bool -- )
2029 : printchar ( charobj -- )
2032 9 of ." #\tab" endof
2033 bl of ." #\space" endof
2034 '\n' of ." #\newline" endof
2040 : (printstring) ( stringobj -- )
2041 nil? if 2drop exit then
2045 '\n' of ." \n" drop endof
2046 [char] \ of ." \\" drop endof
2047 [char] " of [char] \ emit [char] " emit drop endof
2053 : printstring ( stringobj -- )
2058 : printsymbol ( symbolobj -- )
2059 nil-type istype? if 2drop exit then
2065 : printnil ( nilobj -- )
2068 : printpair ( pairobj -- )
2072 nil-type istype? if 2drop exit then
2073 pair-type istype? if space recurse exit then
2077 : printprim ( primobj -- )
2078 2drop ." <primitive procedure>" ;
2080 : printcomp ( primobj -- )
2081 2drop ." <compound procedure>" ;
2083 : printnone ( noneobj -- )
2084 2drop ." Unspecified return value" ;
2086 : printport ( port -- )
2090 fixnum-type istype? if printfixnum exit then
2091 flonum-type istype? if printflonum exit then
2092 ratnum-type istype? if printratnum exit then
2093 boolean-type istype? if printbool exit then
2094 character-type istype? if printchar exit then
2095 string-type istype? if printstring exit then
2096 symbol-type istype? if printsymbol exit then
2097 nil-type istype? if printnil exit then
2098 pair-type istype? if ." (" printpair ." )" exit then
2099 primitive-proc-type istype? if printprim exit then
2100 compound-proc-type istype? if printcomp exit then
2101 none-type istype? if printnone exit then
2102 port-type istype? if printport exit then
2104 except-message: ." tried to print object with unknown type." recoverable-exception throw
2109 \ ---- Garbage Collection ---- {{{
2114 variable gc-stack-depth
2117 depth gc-stack-depth !
2121 false gc-enabled ! ;
2126 : pairlike? ( obj -- obj bool )
2127 pair-type istype? if true exit then
2128 string-type istype? if true exit then
2129 symbol-type istype? if true exit then
2130 compound-proc-type istype? if true exit then
2131 port-type istype? if true exit then
2136 : pairlike-marked? ( obj -- obj bool )
2137 over nextfrees + @ 0=
2140 : mark-pairlike ( obj -- obj )
2141 over nextfrees + 0 swap !
2150 : gc-mark-obj ( obj -- )
2152 pairlike? invert if 2drop exit then
2153 pairlike-marked? if 2drop exit then
2164 scheme-memsize nextfree !
2165 0 scheme-memsize 1- do
2166 nextfrees i + @ 0<> if
2167 nextfree @ nextfrees i + !
2173 \ Following a GC, this gives the amount of free memory
2177 nextfrees i + @ 0= if 1+ then
2181 \ Debugging word - helps spot memory that is retained
2184 nextfrees i + @ 0<> if
2196 symbol-table obj@ gc-mark-obj
2197 macro-table obj@ gc-mark-obj
2198 console-i/o-port obj@ gc-mark-obj
2199 global-env obj@ gc-mark-obj
2201 depth gc-stack-depth @ do
2210 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2211 ; is collect-garbage
2215 \ ---- Loading files ---- {{{
2217 : load ( addr n -- finalResult )
2222 ok-symbol ( port res )
2225 2over read-port ( port res obj )
2227 2dup EOF character-type objeq? if
2228 2drop 2swap close-port
2232 2swap 2drop ( port obj )
2236 global-env obj@ eval ( port res )
2242 \ ---- Standard Library ---- {{{
2244 include scheme-primitives.4th
2246 \ s" scheme-library.scm" load 2drop
2252 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2253 : repl-body ( -- bool )
2254 cr bold fg green ." > " reset-term
2258 2dup EOF character-type objeq? if
2260 bold fg blue ." Moriturus te saluto." reset-term cr
2266 global-env obj@ eval
2268 fg cyan ." ; " print reset-term
2278 \ Display welcome message
2279 \ welcome-symbol nil cons global-env obj@ eval 2drop
2284 recoverable-exception of false endof
2285 unrecoverable-exception of true endof