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
554 : make-continuation ( -- continuation true-obj )
555 \ true-obj allows calling code to detect whether
556 \ it is being called immediately following make-continuation
557 \ or by a restore-continuation.
561 cons drop continuation-type
566 : continuation->pstack-list
569 : continuation->rstack-list
572 : stack-list-len ( stack-list -- n )
576 : restore-param-stack ( continuation -- obj_stack )
577 continuation->pstack-list
580 ( Allocate stack space first using psp!,
581 then copy objects from list. )
584 object-stack-base @ psp0 + + psp!
588 stack-list-len 1- 0 swap do
591 PSP0 object-stack-base @ + i 2* + 2 + !
592 PSP0 object-stack-base @ + i 2* + 1 + !
600 : restore-return-stack ( continuation -- )
602 continuation->rstack-list
604 2dup cdr 2swap stack-list-len ( list n )
606 dup RSP0 + RSP! \ expand return stack to accommodate entries
610 1- \ initial offset n-1
614 2dup cdr 2swap car drop
621 : restore-continuation-with-arg ( continuation obj -- )
623 >R >R \ Store obj on return stack
625 2dup >R >R \ Store copy of continuation on return stack
629 R> R> \ Pop continuation from return stack
631 R> R> \ Pop obj from return stack
635 false boolean-type \ Add flag signifying continuation restore
644 \ ---- Primitives ---- {{{
646 : make-primitive ( cfa -- )
653 rot primitive-proc-type ( var prim )
654 global-env obj@ define-var
657 : ensure-arg-count ( args n -- )
659 drop nil objeq? false = if
660 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
664 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
671 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
673 drop nil objeq? false = if
674 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
678 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
681 2dup cdr 2swap car ( ... t1 n args' arg1 )
682 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
684 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
692 : push-args-to-stack ( args -- arg1 arg2 ... argn )
702 : add-fa-checks ( cfa n -- cfa' )
703 here current @ 1+ dup @ , !
707 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
708 ['] push-args-to-stack ,
709 ['] lit , , ['] execute ,
713 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
714 here current @ 1+ dup @ , !
721 dup ( cfa t1 t2 ... tn n m )
726 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
732 ['] lit , , ['] ensure-arg-type-and-count ,
734 ['] push-args-to-stack ,
735 ['] lit , , ['] execute ,
741 : make-fa-primitive ( cfa n -- )
742 add-fa-checks make-primitive ;
744 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
745 add-fa-type-checks make-primitive ;
748 bold fg red ." Incorrect argument type." reset-term cr
752 : ensure-arg-type ( arg type -- arg )
754 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
761 \ ---- Macros ---- {{{
765 ( Look up macro in macro table. Returns nil if
767 : lookup-macro ( name_symbol -- proc )
769 symbol-type istype? invert if
770 \ Early exit if argument is not a symbol
792 : make-macro ( name_symbol params body env -- )
795 2swap ( proc name_symbol )
802 2over 2over ( proc name table name table )
804 2swap 2drop ( proc table )
816 macro-table obj@ cons
825 variable stored-parse-idx
826 create parse-str 161 allot
827 variable parse-str-span
829 create parse-idx-stack 10 allot
830 variable parse-idx-sp
831 parse-idx-stack parse-idx-sp !
834 parse-idx @ parse-idx-sp @ !
839 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
843 parse-idx-sp @ @ parse-idx ! ;
847 '\n' parse-str parse-str-span @ + !
848 1 parse-str-span +! ;
851 4 parse-str parse-str-span @ + !
852 1 parse-str-span +! ;
859 current-input-port obj@ console-i/o-port obj@ objeq? if
860 parse-str 160 expect cr
861 span @ parse-str-span !
863 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
864 drop swap parse-str-span !
866 parse-str-span @ 0= and if append-eof then
877 : charavailable? ( -- bool )
878 parse-str-span @ parse-idx @ > ;
880 : nextchar ( -- char )
881 charavailable? false = if getline then
882 parse-str parse-idx @ + @ ;
885 : whitespace? ( -- bool )
897 nextchar [char] ( = or
898 nextchar [char] ) = or
901 : commentstart? ( -- bool )
902 nextchar [char] ; = ;
906 false \ Indicates whether or not we're eating a comment
909 dup whitespace? or commentstart? or
911 dup nextchar '\n' = and if
912 invert \ Stop eating comment
914 dup false = commentstart? and if
915 invert \ Begin eating comment
930 nextchar [char] - = ;
933 nextchar [char] + = ;
935 : fixnum? ( -- bool )
961 : flonum? ( -- bool )
968 \ Record starting parse idx:
969 \ Want to detect whether any characters (following +/-) were eaten.
976 [char] . nextchar = if
983 [char] e nextchar = [char] E nextchar = or if
991 drop pop-parse-idx false exit
999 \ This is a real number if characters were
1000 \ eaten and the next characer is a delimiter.
1001 parse-idx @ < delim? and
1006 : ratnum? ( -- bool )
1014 pop-parse-idx false exit
1023 [char] / nextchar <> if
1024 pop-parse-idx false exit
1030 pop-parse-idx false exit
1039 delim? pop-parse-idx
1042 : boolean? ( -- bool )
1043 nextchar [char] # <> if false exit then
1048 nextchar [char] t <>
1049 nextchar [char] f <>
1050 and if pop-parse-idx false exit then
1062 : str-equiv? ( str -- bool )
1079 delim? false = if drop false then
1084 : character? ( -- bool )
1085 nextchar [char] # <> if false exit then
1090 nextchar [char] \ <> if pop-parse-idx false exit then
1094 S" newline" str-equiv? if pop-parse-idx true exit then
1095 S" space" str-equiv? if pop-parse-idx true exit then
1096 S" tab" str-equiv? if pop-parse-idx true exit then
1098 charavailable? false = if pop-parse-idx false exit then
1104 nextchar [char] ( = ;
1106 : string? ( -- bool )
1107 nextchar [char] " = ;
1109 : readfixnum ( -- fixnum )
1120 10 * nextchar [char] 0 - +
1129 : readflonum ( -- flonum )
1131 dup 0< swap abs i->f
1133 [char] . nextchar = if
1139 nextchar [char] 0 - i->f ( f exp d )
1140 over f/ rot f+ ( exp f' )
1141 swap 10.0 f* ( f' exp' )
1148 [char] e nextchar = [char] E nextchar = or if
1151 readfixnum drop i->f
1162 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1169 fixnum-type swap fixnum-type
1170 cons drop ratnum-type
1174 : readratnum ( -- ratnum )
1175 readfixnum inc-parse-idx readfixnum
1179 : readbool ( -- bool-obj )
1182 nextchar [char] f = if
1193 : readchar ( -- char-obj )
1197 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1198 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1199 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1201 nextchar character-type
1206 : readstring ( -- charlist )
1211 nextchar [char] " <>
1213 nextchar [char] \ = if
1216 [char] n of '\n' endof
1217 [char] " of [char] " endof
1223 inc-parse-idx character-type
1226 ( firstchar prevchar thischar )
1229 2drop 2swap 2drop 2dup ( thischar thischar )
1231 ( firstchar thischar prevchar )
1232 2over 2swap set-cdr! ( firstchar thischar )
1236 \ Discard previous character
1242 ." No delimiter following right double quote. Aborting." cr
1254 : readsymbol ( -- charlist )
1255 delim? if nil exit then
1257 nextchar inc-parse-idx character-type
1264 : readpair ( -- pairobj )
1268 nextchar [char] ) = if
1273 ." No delimiter following right paren. Aborting." cr
1282 \ Read first pair element
1287 nextchar [char] . = if
1292 ." No delimiter following '.'. Aborting." cr
1306 \ Parse a scheme expression
1341 nextchar [char] " <> if
1342 bold red ." Missing closing double-quote." reset-term cr
1360 nextchar [char] ) <> if
1361 bold red ." Missing closing paren." reset-term cr
1370 nextchar [char] ' = if
1372 quote-symbol recurse nil cons cons exit
1375 nextchar [char] ` = if
1377 quasiquote-symbol recurse nil cons cons exit
1380 nextchar [char] , = if
1382 nextchar [char] @ = if
1384 unquote-splicing-symbol recurse nil cons cons exit
1386 unquote-symbol recurse nil cons cons exit
1396 nextchar [char] ) = if
1398 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1401 \ Anything else is parsed as a symbol
1402 readsymbol charlist>symbol
1404 \ Replace λ with lambda
1405 2dup λ-symbol objeq? if
1414 \ ---- Syntax ---- {{{
1416 : self-evaluating? ( obj -- obj bool )
1417 boolean-type istype? if true exit then
1418 fixnum-type istype? if true exit then
1419 flonum-type istype? if true exit then
1420 ratnum-type istype? if true exit then
1421 character-type istype? if true exit then
1422 string-type istype? if true exit then
1423 nil-type istype? if true exit then
1424 none-type istype? if true exit then
1429 : tagged-list? ( obj tag-obj -- obj bool )
1431 pair-type istype? false = if
1437 : quote? ( obj -- obj bool )
1438 quote-symbol tagged-list? ;
1440 : quote-body ( quote-obj -- quote-body-obj )
1443 : variable? ( obj -- obj bool )
1444 symbol-type istype? ;
1446 : definition? ( obj -- obj bool )
1447 define-symbol tagged-list? ;
1449 : definition-var ( obj -- var )
1452 : definition-val ( obj -- val )
1455 : assignment? ( obj -- obj bool )
1456 set!-symbol tagged-list? ;
1458 : assignment-var ( obj -- var )
1461 : assignment-val ( obj -- val )
1464 : macro-definition? ( obj -- obj bool )
1465 define-macro-symbol tagged-list? ;
1467 : macro-definition-name ( exp -- mname )
1470 : macro-definition-params ( exp -- params )
1473 : macro-definition-body ( exp -- body )
1476 : if? ( obj -- obj bool )
1477 if-symbol tagged-list? ;
1479 : if-predicate ( ifobj -- pred )
1482 : if-consequent ( ifobj -- conseq )
1485 : if-alternative ( ifobj -- alt|none )
1493 : false? ( boolobj -- boolean )
1494 boolean-type istype? if
1495 false boolean-type objeq?
1501 : true? ( boolobj -- bool )
1504 : lambda? ( obj -- obj bool )
1505 lambda-symbol tagged-list? ;
1507 : lambda-parameters ( obj -- params )
1510 : lambda-body ( obj -- body )
1513 : application? ( obj -- obj bool )
1516 : operator ( obj -- operator )
1519 : operands ( obj -- operands )
1522 : nooperands? ( operands -- bool )
1525 : first-operand ( operands -- operand )
1528 : rest-operands ( operands -- other-operands )
1531 : procedure-params ( proc -- params )
1532 drop pair-type car ;
1534 : procedure-body ( proc -- body )
1535 drop pair-type cdr car ;
1537 : procedure-env ( proc -- body )
1538 drop pair-type cdr cdr car ;
1540 ( Ensure terminating symbol arg name is handled
1541 specially to allow for variadic procedures. )
1542 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1544 2over nil? false = if
1545 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1552 symbol-type istype? if
1562 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1569 recurse ( argvals argnames argvals'' argnames'' )
1570 2rot car 2swap cons ( argvals argvals'' argnames' )
1571 2rot car 2rot cons ( argnames' argvals' )
1577 \ ---- Analyze ---- {{{
1579 : evaluate-eproc ( eproc env --- res )
1590 2drop \ get rid of null
1594 \ Final element of eproc list is primitive procedure
1595 drop \ dump type signifier
1597 goto \ jump straight to primitive procedure (executor)
1600 : self-evaluating-executor ( exp env -- exp )
1603 : analyze-self-evaluating ( exp --- eproc )
1604 ['] self-evaluating-executor primitive-proc-type
1608 : quote-executor ( exp env -- exp )
1611 : analyze-quoted ( exp -- eproc )
1614 ['] quote-executor primitive-proc-type
1618 : variable-executor ( var env -- val )
1621 : analyze-variable ( exp -- eproc )
1622 ['] variable-executor primitive-proc-type
1626 : definition-executor ( var val-eproc env -- ok )
1627 2swap 2over ( var env val-eproc env )
1628 evaluate-eproc 2swap ( var val env )
1633 : analyze-definition ( exp -- eproc )
1635 2swap definition-val analyze
1637 ['] definition-executor primitive-proc-type
1641 : assignment-executor ( var val-eproc env -- ok )
1642 2swap 2over ( var env val-eproc env )
1643 evaluate-eproc 2swap ( var val env )
1648 : analyze-assignment ( exp -- eproc )
1650 2swap assignment-val analyze ( var val-eproc )
1652 ['] assignment-executor primitive-proc-type
1656 : sequence-executor ( eproc-list env -- res )
1660 2dup cdr ( env elist elist-rest)
1663 -2rot car 2over ( elist-rest env elist-head env )
1664 evaluate-eproc ( elist-rest env head-res )
1665 2drop 2swap ( env elist-rest )
1669 ['] evaluate-eproc goto
1673 : (analyze-sequence) ( explist -- eproc-list )
1682 : analyze-sequence ( explist -- eproc )
1684 ['] sequence-executor primitive-proc-type
1689 : macro-definition-executor ( name params bproc env -- ok )
1690 make-macro ok-symbol
1693 : analyze-macro-definition ( exp -- eproc )
1694 2dup macro-definition-name
1695 2swap 2dup macro-definition-params
1696 2swap macro-definition-body analyze-sequence
1698 ['] macro-definition-executor primitive-proc-type
1699 nil cons cons cons cons
1702 : if-executor ( cproc aproc pproc env -- res )
1703 2swap 2over ( cproc aproc env pproc env -- res )
1712 ['] evaluate-eproc goto
1715 : analyze-if ( exp -- eproc )
1716 2dup if-consequent analyze
1717 2swap 2dup if-alternative analyze
1718 2swap if-predicate analyze
1720 ['] if-executor primitive-proc-type
1721 nil cons cons cons cons
1724 : lambda-executor ( params bproc env -- res )
1726 ( Although this is packaged up as a regular compound procedure,
1727 the "body" element contains an _eproc_ to be evaluated in an
1728 environment resulting from extending env with the parameter
1732 : analyze-lambda ( exp -- eproc )
1733 2dup lambda-parameters
1737 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1742 ['] lambda-executor primitive-proc-type
1746 : operand-eproc-list ( operands -- eprocs )
1754 : evaluate-operand-eprocs ( env aprocs -- vals )
1758 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1759 -2rot cdr recurse ( thisval restvals )
1764 : apply ( vals proc )
1766 primitive-proc-type of
1770 compound-proc-type of
1771 2dup procedure-body ( argvals proc bproc )
1772 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1773 -2rot procedure-env ( bproc argnames argvals procenv )
1779 extend-env ( bproc env )
1781 ['] evaluate-eproc goto
1784 continuation-type of
1787 except-message: ." Continuations expect exactly 1 argument."
1788 recoverable-exception throw
1794 except-message: ." Continuations expect exactly 1 argument."
1795 recoverable-exception throw
1800 restore-continuation-with-arg
1803 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1807 : application-executor ( operator-proc arg-procs env -- res )
1808 2rot 2over ( aprocs env fproc env )
1809 evaluate-eproc ( aprocs env proc )
1811 -2rot 2swap ( proc env aprocs )
1812 evaluate-operand-eprocs ( proc vals )
1819 : analyze-application ( exp -- eproc )
1820 2dup operator analyze
1821 2swap operands operand-eproc-list
1823 ['] application-executor primitive-proc-type
1827 :noname ( exp --- eproc )
1829 self-evaluating? if analyze-self-evaluating exit then
1831 quote? if analyze-quoted exit then
1833 variable? if analyze-variable exit then
1835 definition? if analyze-definition exit then
1837 assignment? if analyze-assignment exit then
1839 macro-definition? if analyze-macro-definition exit then
1841 if? if analyze-if exit then
1843 lambda? if analyze-lambda exit then
1845 application? if analyze-application exit then
1847 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1853 \ ---- Macro Expansion ---- {{{
1855 ( Simply evaluates the given procedure with expbody as its argument. )
1856 : macro-eval ( proc expbody -- result )
1858 2dup procedure-body ( expbody proc bproc )
1859 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1860 -2rot procedure-env ( bproc argnames expbody procenv )
1866 extend-env ( bproc env )
1868 ['] evaluate-eproc goto
1871 : expand-macro ( exp -- result )
1872 pair-type istype? invert if exit then
1874 2dup car symbol-type istype? invert if 2drop exit then
1876 lookup-macro nil? if 2drop exit then
1878 2over cdr macro-eval
1880 2dup no-match-symbol objeq? if
1886 R> drop ['] expand goto-deferred
1889 : expand-definition ( exp -- result )
1893 2swap definition-val expand
1894 nil ( define var val' nil )
1898 : expand-assignment ( exp -- result )
1902 2swap assignment-val expand
1903 nil ( define var val' nil )
1907 : expand-list ( exp -- res )
1915 : macro-definition-nameparams
1918 : expand-define-macro ( exp -- res )
1919 define-macro-symbol 2swap
1920 2dup macro-definition-nameparams
1921 2swap macro-definition-body expand-list
1925 : expand-lambda ( exp -- res )
1927 2dup lambda-parameters
1928 2swap lambda-body expand-list
1932 : expand-if ( exp -- res )
1935 2dup if-predicate expand
1936 2swap 2dup if-consequent expand
1937 2swap if-alternative none? if
1945 : expand-application ( exp -- res )
1946 2dup operator expand
1947 2swap operands expand-list
1951 :noname ( exp -- result )
1954 self-evaluating? if exit then
1958 definition? if expand-definition exit then
1960 assignment? if expand-assignment exit then
1962 macro-definition? if expand-define-macro exit then
1964 lambda? if expand-lambda exit then
1966 if? if expand-if exit then
1968 application? if expand-application exit then
1974 :noname ( exp env -- res )
1975 2swap expand analyze 2swap evaluate-eproc
1978 \ ---- Print ---- {{{
1980 : printfixnum ( fixnum -- ) drop 0 .R ;
1982 : printflonum ( flonum -- ) drop f. ;
1984 : printratnum ( ratnum -- )
1986 car print ." /" cdr print
1989 : printbool ( bool -- )
1997 : printchar ( charobj -- )
2000 9 of ." #\tab" endof
2001 bl of ." #\space" endof
2002 '\n' of ." #\newline" endof
2008 : (printstring) ( stringobj -- )
2009 nil? if 2drop exit then
2013 '\n' of ." \n" drop endof
2014 [char] \ of ." \\" drop endof
2015 [char] " of [char] \ emit [char] " emit drop endof
2021 : printstring ( stringobj -- )
2026 : printsymbol ( symbolobj -- )
2027 nil-type istype? if 2drop exit then
2033 : printnil ( nilobj -- )
2036 : printpair ( pairobj -- )
2040 nil-type istype? if 2drop exit then
2041 pair-type istype? if space recurse exit then
2045 : printprim ( primobj -- )
2046 2drop ." <primitive procedure>" ;
2048 : printcomp ( primobj -- )
2049 2drop ." <compound procedure>" ;
2051 : printcont ( primobj --)
2052 2drop ." <continuation>" ;
2054 : printnone ( noneobj -- )
2055 2drop ." Unspecified return value" ;
2057 : printport ( port -- )
2061 fixnum-type istype? if printfixnum exit then
2062 flonum-type istype? if printflonum exit then
2063 ratnum-type istype? if printratnum exit then
2064 boolean-type istype? if printbool exit then
2065 character-type istype? if printchar exit then
2066 string-type istype? if printstring exit then
2067 symbol-type istype? if printsymbol exit then
2068 nil-type istype? if printnil exit then
2069 pair-type istype? if ." (" printpair ." )" exit then
2070 primitive-proc-type istype? if printprim exit then
2071 compound-proc-type istype? if printcomp exit then
2072 continuation-type istype? if printcont exit then
2073 none-type istype? if printnone exit then
2074 port-type istype? if printport exit then
2076 except-message: ." tried to print object with unknown type." recoverable-exception throw
2081 \ ---- Garbage Collection ---- {{{
2083 ( Notes on garbage collection:
2084 This is a mark-sweep garbage collector, invoked by cons.
2085 The roots of the object tree used by the marking routine
2086 include all objects in the parameter stack, and several
2087 other fixed roots such as global-env, symbol-table, macro-table,
2088 and the console-i/o-port.
2090 NO OTHER OBJECTS WILL BE MARKED!
2092 This places implicit restrictions on when cons can be invoked.
2093 Invoking cons when live objects are stored on the return stack
2094 or in other variables than the above will result in possible
2095 memory corruption if the cons triggers the GC. )
2098 : pairlike? ( obj -- obj bool )
2099 pair-type istype? if true exit then
2100 string-type istype? if true exit then
2101 symbol-type istype? if true exit then
2102 compound-proc-type istype? if true exit then
2103 port-type istype? if true exit then
2104 continuation-type istype? if true exit then
2109 : pairlike-marked? ( obj -- obj bool )
2110 over nextfrees + @ 0=
2113 : mark-pairlike ( obj -- obj )
2114 over nextfrees + 0 swap !
2123 : gc-mark-obj ( obj -- )
2125 pairlike? invert if 2drop exit then
2126 pairlike-marked? if 2drop exit then
2137 scheme-memsize nextfree !
2138 0 scheme-memsize 1- do
2139 nextfrees i + @ 0<> if
2140 nextfree @ nextfrees i + !
2146 \ Following a GC, this gives the amount of free memory
2150 nextfrees i + @ 0= if 1+ then
2154 \ Debugging word - helps spot memory that is retained
2157 nextfrees i + @ 0<> if
2169 symbol-table obj@ gc-mark-obj
2170 macro-table obj@ gc-mark-obj
2171 console-i/o-port obj@ gc-mark-obj
2172 global-env obj@ gc-mark-obj
2174 depth object-stack-base @ do
2183 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2184 ; is collect-garbage
2188 \ ---- Loading files ---- {{{
2190 : load ( addr n -- finalResult )
2195 ok-symbol ( port res )
2199 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2201 2over read-port ( port res obj )
2206 2dup EOF character-type objeq? if
2207 2drop 2swap close-port
2211 2swap 2drop ( port obj )
2213 global-env obj@ eval ( port res )
2219 \ ---- Standard Library ---- {{{
2221 include scheme-primitives.4th
2223 init-object-stack-base
2224 s" scheme-library.scm" load 2drop
2230 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2231 : repl-body ( -- bool )
2232 cr bold fg green ." > " reset-term
2236 2dup EOF character-type objeq? if
2238 bold fg blue ." Moriturus te saluto." reset-term cr
2242 global-env obj@ eval
2244 fg cyan ." ; " print reset-term
2252 init-object-stack-base
2254 \ Display welcome message
2255 welcome-symbol nil cons global-env obj@ eval 2drop
2260 recoverable-exception of false endof
2261 unrecoverable-exception of true endof