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 : variable? ( obj -- obj bool )
1319 symbol-type istype? ;
1321 : definition? ( obj -- obj bool )
1322 define-symbol tagged-list? ;
1324 : definition-var ( obj -- var )
1327 : definition-val ( obj -- val )
1330 : eval-definition ( obj env -- res )
1333 definition-val 2swap
1336 2swap definition-var 2swap
1344 : assignment? ( obj -- obj bool )
1345 set!-symbol tagged-list? ;
1347 : assignment-var ( obj -- var )
1350 : assignment-val ( obj -- val )
1353 : eval-assignment ( obj env -- res )
1355 2over 2over ( env obj env obj )
1356 assignment-val 2swap ( env obj valexp env )
1357 eval ( env obj val )
1359 2swap assignment-var 2swap ( env var val )
1361 2rot ( var val env )
1367 : macro-definition? ( obj -- obj bool )
1368 define-macro-symbol tagged-list? ;
1370 : macro-definition-name ( exp -- mname )
1373 : macro-definition-params ( exp -- params )
1376 : macro-definition-body ( exp -- body )
1380 : eval-define-macro ( obj env -- res )
1383 2dup macro-definition-name 2swap ( name obj )
1384 2dup macro-definition-params 2swap ( name params obj )
1385 macro-definition-body ( name params body )
1387 env obj@ ( name params body env )
1395 : if? ( obj -- obj bool )
1396 if-symbol tagged-list? ;
1398 : if-predicate ( ifobj -- pred )
1401 : if-consequent ( ifobj -- conseq )
1404 : if-alternative ( ifobj -- alt|none )
1412 : false? ( boolobj -- boolean )
1413 boolean-type istype? if
1414 false boolean-type objeq?
1420 : true? ( boolobj -- bool )
1423 : lambda? ( obj -- obj bool )
1424 lambda-symbol tagged-list? ;
1426 : lambda-parameters ( obj -- params )
1429 : lambda-body ( obj -- body )
1432 : eval-sequence ( explist env -- finalexp env )
1433 ( Evaluates all bar the final expressions in
1434 an an expression list. The final expression
1435 is returned to allow for tail optimization. )
1437 2swap ( env explist )
1439 \ Abort on empty list
1446 2dup cdr ( env explist nextexplist )
1449 -2rot car 2over ( nextexplist env exp env )
1451 2drop \ discard result
1452 2swap ( env nextexplist )
1455 2drop car 2swap ( finalexp env )
1458 : application? ( obj -- obj bool )
1461 : operator ( obj -- operator )
1464 : operands ( obj -- operands )
1467 : nooperands? ( operands -- bool )
1470 : first-operand ( operands -- operand )
1473 : rest-operands ( operands -- other-operands )
1476 : list-of-vals ( args env -- vals )
1482 2over 2over first-operand 2swap eval
1483 -2rot rest-operands 2swap recurse
1488 : procedure-params ( proc -- params )
1489 drop pair-type car ;
1491 : procedure-body ( proc -- body )
1492 drop pair-type cdr car ;
1494 : procedure-env ( proc -- body )
1495 drop pair-type cdr cdr car ;
1497 ( Ensure terminating symbol arg name is handled
1498 specially to allow for variadic procedures. )
1499 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1501 2over nil? false = if
1502 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1509 symbol-type istype? if
1519 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1526 recurse ( argvals argnames argvals'' argnames'' )
1527 2rot car 2swap cons ( argvals argvals'' argnames' )
1528 2rot car 2rot cons ( argnames' argvals' )
1532 : apply ( proc argvals -- result )
1534 primitive-proc-type of
1538 compound-proc-type of
1539 2dup procedure-body ( argvals proc body )
1540 -2rot 2dup procedure-params ( body argvals proc argnames )
1541 -2rot procedure-env ( body argnames argvals procenv )
1547 extend-env ( body env )
1551 R> drop ['] eval goto-deferred \ Tail call optimization
1554 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1558 :noname ( obj env -- result )
1563 fg yellow ." Evaluating: " bold 2dup print reset-term
1564 space fg green ." PS: " bold depth . reset-term
1565 space fg blue ." RS: " bold RSP@ RSP0 - . reset-term cr
1585 2swap eval-definition
1590 2swap eval-assignment
1594 macro-definition? if
1595 2swap eval-define-macro
1611 ['] eval goto-deferred
1615 2dup lambda-parameters
1623 2over 2over ( env exp env exp )
1624 operator ( env exp env opname )
1626 2swap eval ( env exp proc )
1628 -2rot ( proc env exp )
1629 operands 2swap ( proc operands env )
1630 list-of-vals ( proc argvals )
1636 except-message: ." tried to evaluate object with unknown type." recoverable-exception throw
1643 : evaluate-eproc ( eproc env --- res )
1654 2drop \ get rid of null
1658 \ Final element of eproc list is primitive procedure
1659 drop \ dump type signifier
1663 goto \ jump straight to primitive procedure (executor)
1666 : self-evaluating-executor ( exp env -- exp )
1669 : analyze-self-evaluating ( exp --- eproc )
1670 ['] self-evaluating-executor primitive-proc-type
1674 : quote-executor ( exp env -- exp )
1677 : analyze-quoted ( exp -- eproc )
1680 ['] quote-executor primitive-proc-type
1684 : variable-executor ( var env -- val )
1687 : analyze-variable ( exp -- eproc )
1688 ['] variable-executor primitive-proc-type
1692 : definition-executor ( var val-eproc env -- ok )
1693 2swap 2over ( var env val-eproc env )
1694 evaluate-eproc 2swap ( var val env )
1699 : analyze-definition ( exp -- eproc )
1701 2swap definition-val analyze
1703 ['] definition-executor primitive-proc-type
1707 : assignment-executor ( var val-eproc env -- ok )
1708 2swap 2over ( var env val-eproc env )
1709 evaluate-eproc 2swap ( var val env )
1714 : analyze-assignment ( exp -- eproc )
1716 2swap assignment-val analyze ( var val-eproc )
1718 ['] assignment-executor primitive-proc-type
1722 : if-executor ( cproc aproc pproc env -- res )
1723 2swap 2over ( cproc aproc env pproc env -- res )
1735 : analyze-if ( exp -- eproc )
1736 2dup if-predicate analyze
1737 2swap 2dup if-consequent analyze
1738 2swap if-alternative analyze
1740 ['] if-executor primitive-proc-type
1741 nil cons cons cons cons
1744 : sequence-executor ( eproc-list env -- res )
1748 2dup cdr ( env elist elist-rest)
1752 -2rot car 2over ( elist-rest env elist-head env )
1753 evaluate-eproc ( elist-rest env head-res )
1754 2drop 2swap ( env elist-rest )
1758 ['] evaluate-eproc goto
1762 : (analyze-sequence) ( explist -- eproc-list )
1771 : analyze-sequence ( explist -- eproc )
1773 ['] sequence-executor primitive-proc-type
1777 : lambda-executor ( params bproc env -- res )
1779 ( Although this is packaged up as a regular compound procedure,
1780 the "body" element contains an _eproc_ to be evaluated in an
1781 environment resulting from extending env with the parameter
1785 : analyze-lambda ( exp -- eproc )
1786 2dup lambda-parameters
1790 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1795 ['] lambda-executor primitive-proc-type
1799 : operand-eproc-list ( operands -- eprocs )
1807 : evaluate-operand-eprocs ( env aprocs -- vals )
1811 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1812 -2rot cdr recurse ( thisval restvals )
1817 : application-executor ( operator-proc arg-procs env -- res )
1818 2rot 2over ( aprocs env fproc env )
1819 evaluate-eproc ( aprocs env proc )
1821 -2rot 2swap ( proc env aprocs )
1822 evaluate-operand-eprocs ( proc vals )
1827 primitive-proc-type of
1831 compound-proc-type of
1832 2dup procedure-body ( argvals proc body )
1833 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1834 -2rot procedure-env ( bproc argnames argvals procenv )
1840 extend-env ( bproc env )
1842 ['] evaluate-eproc goto
1845 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1849 : analyze-application ( exp -- eproc )
1850 2dup operator analyze
1851 2swap operands operand-eproc-list
1853 ['] application-executor primitive-proc-type
1857 :noname ( exp --- eproc )
1860 analyze-self-evaluating
1900 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1905 \ ---- Macro Expansion ---- {{{
1907 ( Simply evaluates the given procedure with expbody as its argument. )
1908 : macro-eval ( proc expbody -- result )
1910 2dup procedure-body ( expbody proc procbody )
1911 -2rot 2dup procedure-params ( procbody expbody proc argnames )
1912 -2rot procedure-env ( procbody argnames expbody procenv )
1918 extend-env eval-sequence eval
1921 : expand-macro ( exp -- result )
1922 pair-type istype? invert if exit then
1923 2dup car symbol-type istype? invert if 2drop exit then
1925 lookup-macro nil? if
1928 2over cdr macro-eval
1930 2dup no-match-symbol objeq? if
1936 R> drop ['] expand goto-deferred
1939 : expand-definition ( exp -- result )
1943 2swap definition-val expand
1944 nil ( define var val' nil )
1948 : expand-assignment ( exp -- result )
1952 2swap assignment-val expand
1953 nil ( define var val' nil )
1957 : expand-list ( exp -- res )
1965 : macro-definition-nameparams
1968 : expand-define-macro ( exp -- res )
1969 define-macro-symbol 2swap
1970 2dup macro-definition-nameparams
1971 2swap macro-definition-body expand-list
1975 : expand-lambda ( exp -- res )
1977 2dup lambda-parameters
1978 2swap lambda-body expand-list
1982 : expand-if ( exp -- res )
1985 2dup if-predicate expand
1986 2swap 2dup if-consequent expand
1987 2swap if-alternative none? if
1995 : expand-application ( exp -- res )
1996 2dup operator expand
1997 2swap operands expand-list
2001 :noname ( exp -- result )
2004 self-evaluating? if exit then
2008 definition? if expand-definition exit then
2010 assignment? if expand-assignment exit then
2012 macro-definition? if expand-define-macro exit then
2014 lambda? if expand-lambda exit then
2016 if? if expand-if exit then
2018 application? if expand-application exit then
2024 \ ---- Print ---- {{{
2026 : printfixnum ( fixnum -- ) drop 0 .R ;
2028 : printflonum ( flonum -- ) drop f. ;
2030 : printratnum ( ratnum -- )
2032 car print ." /" cdr print
2035 : printbool ( bool -- )
2043 : printchar ( charobj -- )
2046 9 of ." #\tab" endof
2047 bl of ." #\space" endof
2048 '\n' of ." #\newline" endof
2054 : (printstring) ( stringobj -- )
2055 nil? if 2drop exit then
2059 '\n' of ." \n" drop endof
2060 [char] \ of ." \\" drop endof
2061 [char] " of [char] \ emit [char] " emit drop endof
2067 : printstring ( stringobj -- )
2072 : printsymbol ( symbolobj -- )
2073 nil-type istype? if 2drop exit then
2079 : printnil ( nilobj -- )
2082 : printpair ( pairobj -- )
2086 nil-type istype? if 2drop exit then
2087 pair-type istype? if space recurse exit then
2091 : printprim ( primobj -- )
2092 2drop ." <primitive procedure>" ;
2094 : printcomp ( primobj -- )
2095 2drop ." <compound procedure>" ;
2097 : printnone ( noneobj -- )
2098 2drop ." Unspecified return value" ;
2100 : printport ( port -- )
2104 fixnum-type istype? if printfixnum exit then
2105 flonum-type istype? if printflonum exit then
2106 ratnum-type istype? if printratnum exit then
2107 boolean-type istype? if printbool exit then
2108 character-type istype? if printchar exit then
2109 string-type istype? if printstring exit then
2110 symbol-type istype? if printsymbol exit then
2111 nil-type istype? if printnil exit then
2112 pair-type istype? if ." (" printpair ." )" exit then
2113 primitive-proc-type istype? if printprim exit then
2114 compound-proc-type istype? if printcomp exit then
2115 none-type istype? if printnone exit then
2116 port-type istype? if printport exit then
2118 except-message: ." tried to print object with unknown type." recoverable-exception throw
2123 \ ---- Garbage Collection ---- {{{
2128 variable gc-stack-depth
2131 depth gc-stack-depth !
2135 false gc-enabled ! ;
2140 : pairlike? ( obj -- obj bool )
2141 pair-type istype? if true exit then
2142 string-type istype? if true exit then
2143 symbol-type istype? if true exit then
2144 compound-proc-type istype? if true exit then
2145 port-type istype? if true exit then
2150 : pairlike-marked? ( obj -- obj bool )
2151 over nextfrees + @ 0=
2154 : mark-pairlike ( obj -- obj )
2155 over nextfrees + 0 swap !
2164 : gc-mark-obj ( obj -- )
2166 pairlike? invert if 2drop exit then
2167 pairlike-marked? if 2drop exit then
2178 scheme-memsize nextfree !
2179 0 scheme-memsize 1- do
2180 nextfrees i + @ 0<> if
2181 nextfree @ nextfrees i + !
2187 \ Following a GC, this gives the amount of free memory
2191 nextfrees i + @ 0= if 1+ then
2195 \ Debugging word - helps spot memory that is retained
2198 nextfrees i + @ 0<> if
2210 symbol-table obj@ gc-mark-obj
2211 macro-table obj@ gc-mark-obj
2212 console-i/o-port obj@ gc-mark-obj
2213 global-env obj@ gc-mark-obj
2215 depth gc-stack-depth @ do
2224 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2225 ; is collect-garbage
2229 \ ---- Loading files ---- {{{
2231 : load ( addr n -- finalResult )
2236 ok-symbol ( port res )
2239 2over read-port ( port res obj )
2241 2dup EOF character-type objeq? if
2242 2drop 2swap close-port
2246 2swap 2drop ( port obj )
2250 global-env obj@ eval ( port res )
2256 \ ---- Standard Library ---- {{{
2258 include scheme-primitives.4th
2260 \ s" scheme-library.scm" load 2drop
2266 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2267 : repl-body ( -- bool )
2268 cr bold fg green ." > " reset-term
2272 2dup EOF character-type objeq? if
2274 bold fg blue ." Moriturus te saluto." reset-term cr
2280 global-env obj@ eval
2282 fg cyan ." ; " print reset-term
2292 \ Display welcome message
2293 \ welcome-symbol nil cons global-env obj@ eval 2drop
2298 recoverable-exception of false endof
2299 unrecoverable-exception of true endof