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 ( continuation -- )
617 \ TODO: replace current parameter and return stacks with
618 \ contents of continuation object.
631 \ ---- Primitives ---- {{{
633 : make-primitive ( cfa -- )
640 rot primitive-proc-type ( var prim )
641 global-env obj@ define-var
644 : ensure-arg-count ( args n -- )
646 drop nil objeq? false = if
647 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
651 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
658 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
660 drop nil objeq? false = if
661 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
665 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
668 2dup cdr 2swap car ( ... t1 n args' arg1 )
669 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
671 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
679 : push-args-to-stack ( args -- arg1 arg2 ... argn )
689 : add-fa-checks ( cfa n -- cfa' )
690 here current @ 1+ dup @ , !
694 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
695 ['] push-args-to-stack ,
696 ['] lit , , ['] execute ,
700 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
701 here current @ 1+ dup @ , !
708 dup ( cfa t1 t2 ... tn n m )
713 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
719 ['] lit , , ['] ensure-arg-type-and-count ,
721 ['] push-args-to-stack ,
722 ['] lit , , ['] execute ,
728 : make-fa-primitive ( cfa n -- )
729 add-fa-checks make-primitive ;
731 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
732 add-fa-type-checks make-primitive ;
735 bold fg red ." Incorrect argument type." reset-term cr
739 : ensure-arg-type ( arg type -- arg )
741 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
748 \ ---- Macros ---- {{{
752 ( Look up macro in macro table. Returns nil if
754 : lookup-macro ( name_symbol -- proc )
756 symbol-type istype? invert if
757 \ Early exit if argument is not a symbol
779 : make-macro ( name_symbol params body env -- )
782 2swap ( proc name_symbol )
789 2over 2over ( proc name table name table )
791 2swap 2drop ( proc table )
803 macro-table obj@ cons
812 variable stored-parse-idx
813 create parse-str 161 allot
814 variable parse-str-span
816 create parse-idx-stack 10 allot
817 variable parse-idx-sp
818 parse-idx-stack parse-idx-sp !
821 parse-idx @ parse-idx-sp @ !
826 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
830 parse-idx-sp @ @ parse-idx ! ;
834 '\n' parse-str parse-str-span @ + !
835 1 parse-str-span +! ;
838 4 parse-str parse-str-span @ + !
839 1 parse-str-span +! ;
846 current-input-port obj@ console-i/o-port obj@ objeq? if
847 parse-str 160 expect cr
848 span @ parse-str-span !
850 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
851 drop swap parse-str-span !
853 parse-str-span @ 0= and if append-eof then
864 : charavailable? ( -- bool )
865 parse-str-span @ parse-idx @ > ;
867 : nextchar ( -- char )
868 charavailable? false = if getline then
869 parse-str parse-idx @ + @ ;
872 : whitespace? ( -- bool )
884 nextchar [char] ( = or
885 nextchar [char] ) = or
888 : commentstart? ( -- bool )
889 nextchar [char] ; = ;
893 false \ Indicates whether or not we're eating a comment
896 dup whitespace? or commentstart? or
898 dup nextchar '\n' = and if
899 invert \ Stop eating comment
901 dup false = commentstart? and if
902 invert \ Begin eating comment
917 nextchar [char] - = ;
920 nextchar [char] + = ;
922 : fixnum? ( -- bool )
948 : flonum? ( -- bool )
955 \ Record starting parse idx:
956 \ Want to detect whether any characters (following +/-) were eaten.
963 [char] . nextchar = if
970 [char] e nextchar = [char] E nextchar = or if
978 drop pop-parse-idx false exit
986 \ This is a real number if characters were
987 \ eaten and the next characer is a delimiter.
988 parse-idx @ < delim? and
993 : ratnum? ( -- bool )
1001 pop-parse-idx false exit
1010 [char] / nextchar <> if
1011 pop-parse-idx false exit
1017 pop-parse-idx false exit
1026 delim? pop-parse-idx
1029 : boolean? ( -- bool )
1030 nextchar [char] # <> if false exit then
1035 nextchar [char] t <>
1036 nextchar [char] f <>
1037 and if pop-parse-idx false exit then
1049 : str-equiv? ( str -- bool )
1066 delim? false = if drop false then
1071 : character? ( -- bool )
1072 nextchar [char] # <> if false exit then
1077 nextchar [char] \ <> if pop-parse-idx false exit then
1081 S" newline" str-equiv? if pop-parse-idx true exit then
1082 S" space" str-equiv? if pop-parse-idx true exit then
1083 S" tab" str-equiv? if pop-parse-idx true exit then
1085 charavailable? false = if pop-parse-idx false exit then
1091 nextchar [char] ( = ;
1093 : string? ( -- bool )
1094 nextchar [char] " = ;
1096 : readfixnum ( -- fixnum )
1107 10 * nextchar [char] 0 - +
1116 : readflonum ( -- flonum )
1118 dup 0< swap abs i->f
1120 [char] . nextchar = if
1126 nextchar [char] 0 - i->f ( f exp d )
1127 over f/ rot f+ ( exp f' )
1128 swap 10.0 f* ( f' exp' )
1135 [char] e nextchar = [char] E nextchar = or if
1138 readfixnum drop i->f
1149 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1156 fixnum-type swap fixnum-type
1157 cons drop ratnum-type
1161 : readratnum ( -- ratnum )
1162 readfixnum inc-parse-idx readfixnum
1166 : readbool ( -- bool-obj )
1169 nextchar [char] f = if
1180 : readchar ( -- char-obj )
1184 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1185 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1186 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1188 nextchar character-type
1193 : readstring ( -- charlist )
1198 nextchar [char] " <>
1200 nextchar [char] \ = if
1203 [char] n of '\n' endof
1204 [char] " of [char] " endof
1210 inc-parse-idx character-type
1213 ( firstchar prevchar thischar )
1216 2drop 2swap 2drop 2dup ( thischar thischar )
1218 ( firstchar thischar prevchar )
1219 2over 2swap set-cdr! ( firstchar thischar )
1223 \ Discard previous character
1229 ." No delimiter following right double quote. Aborting." cr
1241 : readsymbol ( -- charlist )
1242 delim? if nil exit then
1244 nextchar inc-parse-idx character-type
1251 : readpair ( -- pairobj )
1255 nextchar [char] ) = if
1260 ." No delimiter following right paren. Aborting." cr
1269 \ Read first pair element
1274 nextchar [char] . = if
1279 ." No delimiter following '.'. Aborting." cr
1293 \ Parse a scheme expression
1328 nextchar [char] " <> if
1329 bold red ." Missing closing double-quote." reset-term cr
1347 nextchar [char] ) <> if
1348 bold red ." Missing closing paren." reset-term cr
1357 nextchar [char] ' = if
1359 quote-symbol recurse nil cons cons exit
1362 nextchar [char] ` = if
1364 quasiquote-symbol recurse nil cons cons exit
1367 nextchar [char] , = if
1369 nextchar [char] @ = if
1371 unquote-splicing-symbol recurse nil cons cons exit
1373 unquote-symbol recurse nil cons cons exit
1383 nextchar [char] ) = if
1385 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1388 \ Anything else is parsed as a symbol
1389 readsymbol charlist>symbol
1391 \ Replace λ with lambda
1392 2dup λ-symbol objeq? if
1401 \ ---- Syntax ---- {{{
1403 : self-evaluating? ( obj -- obj bool )
1404 boolean-type istype? if true exit then
1405 fixnum-type istype? if true exit then
1406 flonum-type istype? if true exit then
1407 ratnum-type istype? if true exit then
1408 character-type istype? if true exit then
1409 string-type istype? if true exit then
1410 nil-type istype? if true exit then
1411 none-type istype? if true exit then
1416 : tagged-list? ( obj tag-obj -- obj bool )
1418 pair-type istype? false = if
1424 : quote? ( obj -- obj bool )
1425 quote-symbol tagged-list? ;
1427 : quote-body ( quote-obj -- quote-body-obj )
1430 : variable? ( obj -- obj bool )
1431 symbol-type istype? ;
1433 : definition? ( obj -- obj bool )
1434 define-symbol tagged-list? ;
1436 : definition-var ( obj -- var )
1439 : definition-val ( obj -- val )
1442 : assignment? ( obj -- obj bool )
1443 set!-symbol tagged-list? ;
1445 : assignment-var ( obj -- var )
1448 : assignment-val ( obj -- val )
1451 : macro-definition? ( obj -- obj bool )
1452 define-macro-symbol tagged-list? ;
1454 : macro-definition-name ( exp -- mname )
1457 : macro-definition-params ( exp -- params )
1460 : macro-definition-body ( exp -- body )
1463 : if? ( obj -- obj bool )
1464 if-symbol tagged-list? ;
1466 : if-predicate ( ifobj -- pred )
1469 : if-consequent ( ifobj -- conseq )
1472 : if-alternative ( ifobj -- alt|none )
1480 : false? ( boolobj -- boolean )
1481 boolean-type istype? if
1482 false boolean-type objeq?
1488 : true? ( boolobj -- bool )
1491 : lambda? ( obj -- obj bool )
1492 lambda-symbol tagged-list? ;
1494 : lambda-parameters ( obj -- params )
1497 : lambda-body ( obj -- body )
1500 : application? ( obj -- obj bool )
1503 : operator ( obj -- operator )
1506 : operands ( obj -- operands )
1509 : nooperands? ( operands -- bool )
1512 : first-operand ( operands -- operand )
1515 : rest-operands ( operands -- other-operands )
1518 : procedure-params ( proc -- params )
1519 drop pair-type car ;
1521 : procedure-body ( proc -- body )
1522 drop pair-type cdr car ;
1524 : procedure-env ( proc -- body )
1525 drop pair-type cdr cdr car ;
1527 ( Ensure terminating symbol arg name is handled
1528 specially to allow for variadic procedures. )
1529 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1531 2over nil? false = if
1532 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1539 symbol-type istype? if
1549 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1556 recurse ( argvals argnames argvals'' argnames'' )
1557 2rot car 2swap cons ( argvals argvals'' argnames' )
1558 2rot car 2rot cons ( argnames' argvals' )
1564 \ ---- Analyze ---- {{{
1566 : evaluate-eproc ( eproc env --- res )
1577 2drop \ get rid of null
1581 \ Final element of eproc list is primitive procedure
1582 drop \ dump type signifier
1584 goto \ jump straight to primitive procedure (executor)
1587 : self-evaluating-executor ( exp env -- exp )
1590 : analyze-self-evaluating ( exp --- eproc )
1591 ['] self-evaluating-executor primitive-proc-type
1595 : quote-executor ( exp env -- exp )
1598 : analyze-quoted ( exp -- eproc )
1601 ['] quote-executor primitive-proc-type
1605 : variable-executor ( var env -- val )
1608 : analyze-variable ( exp -- eproc )
1609 ['] variable-executor primitive-proc-type
1613 : definition-executor ( var val-eproc env -- ok )
1614 2swap 2over ( var env val-eproc env )
1615 evaluate-eproc 2swap ( var val env )
1620 : analyze-definition ( exp -- eproc )
1622 2swap definition-val analyze
1624 ['] definition-executor primitive-proc-type
1628 : assignment-executor ( var val-eproc env -- ok )
1629 2swap 2over ( var env val-eproc env )
1630 evaluate-eproc 2swap ( var val env )
1635 : analyze-assignment ( exp -- eproc )
1637 2swap assignment-val analyze ( var val-eproc )
1639 ['] assignment-executor primitive-proc-type
1643 : sequence-executor ( eproc-list env -- res )
1647 2dup cdr ( env elist elist-rest)
1650 -2rot car 2over ( elist-rest env elist-head env )
1651 evaluate-eproc ( elist-rest env head-res )
1652 2drop 2swap ( env elist-rest )
1656 ['] evaluate-eproc goto
1660 : (analyze-sequence) ( explist -- eproc-list )
1669 : analyze-sequence ( explist -- eproc )
1671 ['] sequence-executor primitive-proc-type
1676 : macro-definition-executor ( name params bproc env -- ok )
1677 make-macro ok-symbol
1680 : analyze-macro-definition ( exp -- eproc )
1681 2dup macro-definition-name
1682 2swap 2dup macro-definition-params
1683 2swap macro-definition-body analyze-sequence
1685 ['] macro-definition-executor primitive-proc-type
1686 nil cons cons cons cons
1689 : if-executor ( cproc aproc pproc env -- res )
1690 2swap 2over ( cproc aproc env pproc env -- res )
1699 ['] evaluate-eproc goto
1702 : analyze-if ( exp -- eproc )
1703 2dup if-consequent analyze
1704 2swap 2dup if-alternative analyze
1705 2swap if-predicate analyze
1707 ['] if-executor primitive-proc-type
1708 nil cons cons cons cons
1711 : lambda-executor ( params bproc env -- res )
1713 ( Although this is packaged up as a regular compound procedure,
1714 the "body" element contains an _eproc_ to be evaluated in an
1715 environment resulting from extending env with the parameter
1719 : analyze-lambda ( exp -- eproc )
1720 2dup lambda-parameters
1724 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1729 ['] lambda-executor primitive-proc-type
1733 : operand-eproc-list ( operands -- eprocs )
1741 : evaluate-operand-eprocs ( env aprocs -- vals )
1745 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1746 -2rot cdr recurse ( thisval restvals )
1751 : apply ( vals proc )
1753 primitive-proc-type of
1757 compound-proc-type of
1758 2dup procedure-body ( argvals proc bproc )
1759 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1760 -2rot procedure-env ( bproc argnames argvals procenv )
1766 extend-env ( bproc env )
1768 ['] evaluate-eproc goto
1771 continuation-type of
1772 \ TODO: Apply continuation
1775 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1779 : application-executor ( operator-proc arg-procs env -- res )
1780 2rot 2over ( aprocs env fproc env )
1781 evaluate-eproc ( aprocs env proc )
1783 -2rot 2swap ( proc env aprocs )
1784 evaluate-operand-eprocs ( proc vals )
1791 : analyze-application ( exp -- eproc )
1792 2dup operator analyze
1793 2swap operands operand-eproc-list
1795 ['] application-executor primitive-proc-type
1799 :noname ( exp --- eproc )
1801 self-evaluating? if analyze-self-evaluating exit then
1803 quote? if analyze-quoted exit then
1805 variable? if analyze-variable exit then
1807 definition? if analyze-definition exit then
1809 assignment? if analyze-assignment exit then
1811 macro-definition? if analyze-macro-definition exit then
1813 if? if analyze-if exit then
1815 lambda? if analyze-lambda exit then
1817 application? if analyze-application exit then
1819 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1825 \ ---- Macro Expansion ---- {{{
1827 ( Simply evaluates the given procedure with expbody as its argument. )
1828 : macro-eval ( proc expbody -- result )
1830 2dup procedure-body ( expbody proc bproc )
1831 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1832 -2rot procedure-env ( bproc argnames expbody procenv )
1838 extend-env ( bproc env )
1840 ['] evaluate-eproc goto
1843 : expand-macro ( exp -- result )
1844 pair-type istype? invert if exit then
1846 2dup car symbol-type istype? invert if 2drop exit then
1848 lookup-macro nil? if 2drop exit then
1850 2over cdr macro-eval
1852 2dup no-match-symbol objeq? if
1858 R> drop ['] expand goto-deferred
1861 : expand-definition ( exp -- result )
1865 2swap definition-val expand
1866 nil ( define var val' nil )
1870 : expand-assignment ( exp -- result )
1874 2swap assignment-val expand
1875 nil ( define var val' nil )
1879 : expand-list ( exp -- res )
1887 : macro-definition-nameparams
1890 : expand-define-macro ( exp -- res )
1891 define-macro-symbol 2swap
1892 2dup macro-definition-nameparams
1893 2swap macro-definition-body expand-list
1897 : expand-lambda ( exp -- res )
1899 2dup lambda-parameters
1900 2swap lambda-body expand-list
1904 : expand-if ( exp -- res )
1907 2dup if-predicate expand
1908 2swap 2dup if-consequent expand
1909 2swap if-alternative none? if
1917 : expand-application ( exp -- res )
1918 2dup operator expand
1919 2swap operands expand-list
1923 :noname ( exp -- result )
1926 self-evaluating? if exit then
1930 definition? if expand-definition exit then
1932 assignment? if expand-assignment exit then
1934 macro-definition? if expand-define-macro exit then
1936 lambda? if expand-lambda exit then
1938 if? if expand-if exit then
1940 application? if expand-application exit then
1946 :noname ( exp env -- res )
1947 2swap expand analyze 2swap evaluate-eproc
1950 \ ---- Print ---- {{{
1952 : printfixnum ( fixnum -- ) drop 0 .R ;
1954 : printflonum ( flonum -- ) drop f. ;
1956 : printratnum ( ratnum -- )
1958 car print ." /" cdr print
1961 : printbool ( bool -- )
1969 : printchar ( charobj -- )
1972 9 of ." #\tab" endof
1973 bl of ." #\space" endof
1974 '\n' of ." #\newline" endof
1980 : (printstring) ( stringobj -- )
1981 nil? if 2drop exit then
1985 '\n' of ." \n" drop endof
1986 [char] \ of ." \\" drop endof
1987 [char] " of [char] \ emit [char] " emit drop endof
1993 : printstring ( stringobj -- )
1998 : printsymbol ( symbolobj -- )
1999 nil-type istype? if 2drop exit then
2005 : printnil ( nilobj -- )
2008 : printpair ( pairobj -- )
2012 nil-type istype? if 2drop exit then
2013 pair-type istype? if space recurse exit then
2017 : printprim ( primobj -- )
2018 2drop ." <primitive procedure>" ;
2020 : printcomp ( primobj -- )
2021 2drop ." <compound procedure>" ;
2023 : printcont ( primobj --)
2024 2drop ." <continuation>" ;
2026 : printnone ( noneobj -- )
2027 2drop ." Unspecified return value" ;
2029 : printport ( port -- )
2033 fixnum-type istype? if printfixnum exit then
2034 flonum-type istype? if printflonum exit then
2035 ratnum-type istype? if printratnum exit then
2036 boolean-type istype? if printbool exit then
2037 character-type istype? if printchar exit then
2038 string-type istype? if printstring exit then
2039 symbol-type istype? if printsymbol exit then
2040 nil-type istype? if printnil exit then
2041 pair-type istype? if ." (" printpair ." )" exit then
2042 primitive-proc-type istype? if printprim exit then
2043 compound-proc-type istype? if printcomp exit then
2044 continuation-type istype? if printcont exit then
2045 none-type istype? if printnone exit then
2046 port-type istype? if printport exit then
2048 except-message: ." tried to print object with unknown type." recoverable-exception throw
2053 \ ---- Garbage Collection ---- {{{
2055 ( Notes on garbage collection:
2056 This is a mark-sweep garbage collector, invoked by cons.
2057 The roots of the object tree used by the marking routine
2058 include all objects in the parameter stack, and several
2059 other fixed roots such as global-env, symbol-table, macro-table,
2060 and the console-i/o-port.
2062 NO OTHER OBJECTS WILL BE MARKED!
2064 This places implicit restrictions on when cons can be invoked.
2065 Invoking cons when live objects are stored on the return stack
2066 or in other variables than the above will result in possible
2067 memory corruption if the cons triggers the GC. )
2070 : pairlike? ( obj -- obj bool )
2071 pair-type istype? if true exit then
2072 string-type istype? if true exit then
2073 symbol-type istype? if true exit then
2074 compound-proc-type istype? if true exit then
2075 port-type istype? if true exit then
2080 : pairlike-marked? ( obj -- obj bool )
2081 over nextfrees + @ 0=
2084 : mark-pairlike ( obj -- obj )
2085 over nextfrees + 0 swap !
2094 : gc-mark-obj ( obj -- )
2096 pairlike? invert if 2drop exit then
2097 pairlike-marked? if 2drop exit then
2108 scheme-memsize nextfree !
2109 0 scheme-memsize 1- do
2110 nextfrees i + @ 0<> if
2111 nextfree @ nextfrees i + !
2117 \ Following a GC, this gives the amount of free memory
2121 nextfrees i + @ 0= if 1+ then
2125 \ Debugging word - helps spot memory that is retained
2128 nextfrees i + @ 0<> if
2140 symbol-table obj@ gc-mark-obj
2141 macro-table obj@ gc-mark-obj
2142 console-i/o-port obj@ gc-mark-obj
2143 global-env obj@ gc-mark-obj
2145 depth object-stack-base @ do
2154 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2155 ; is collect-garbage
2162 \ ---- Loading files ---- {{{
2164 : load ( addr n -- finalResult )
2169 ok-symbol ( port res )
2173 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2175 2over read-port ( port res obj )
2180 2dup EOF character-type objeq? if
2181 2drop 2swap close-port
2185 2swap 2drop ( port obj )
2187 global-env obj@ eval ( port res )
2193 \ ---- Standard Library ---- {{{
2195 include scheme-primitives.4th
2197 init-object-stack-base
2198 s" scheme-library.scm" load 2drop
2204 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2205 : repl-body ( -- bool )
2206 cr bold fg green ." > " reset-term
2210 2dup EOF character-type objeq? if
2212 bold fg blue ." Moriturus te saluto." reset-term cr
2216 global-env obj@ eval
2218 fg cyan ." ; " print reset-term
2226 init-object-stack-base
2228 \ Display welcome message
2229 welcome-symbol nil cons global-env obj@ eval 2drop
2234 recoverable-exception of false endof
2235 unrecoverable-exception of true endof