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- fixnum-type 2swap cons
558 cons drop continuation-type
561 : continuation->pstack-list
564 : continuation->rstack-list
567 : restore-param-stack ( continuation -- obj_stack )
568 continuation->pstack-list
571 ( Allocate stack space first using psp!,
572 then copy objects from list. )
575 object-stack-base @ psp0 + + psp!
579 car drop 2- 0 swap do
582 PSP0 object-stack-base @ + i + 2 + !
583 PSP0 object-stack-base @ + i + 1 + !
591 : restore-return-stack ( continuation -- )
593 R> -rot \ store top of return stack on PS
594 continuation->rstack-list
597 \ TODO: Implement body of return stack restoration
599 >R \ restore original top of return stack
602 : restore-continuation ( continuation -- )
603 \ TODO: replace current parameter and return stacks with
604 \ contents of continuation object.
609 ." ====== PARAM STACK RESTORED ======" cr
618 \ ---- Primitives ---- {{{
620 : make-primitive ( cfa -- )
627 rot primitive-proc-type ( var prim )
628 global-env obj@ define-var
631 : ensure-arg-count ( args n -- )
633 drop nil objeq? false = if
634 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
638 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
645 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
647 drop nil objeq? false = if
648 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
652 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
655 2dup cdr 2swap car ( ... t1 n args' arg1 )
656 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
658 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
666 : push-args-to-stack ( args -- arg1 arg2 ... argn )
676 : add-fa-checks ( cfa n -- cfa' )
677 here current @ 1+ dup @ , !
681 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
682 ['] push-args-to-stack ,
683 ['] lit , , ['] execute ,
687 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
688 here current @ 1+ dup @ , !
695 dup ( cfa t1 t2 ... tn n m )
700 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
706 ['] lit , , ['] ensure-arg-type-and-count ,
708 ['] push-args-to-stack ,
709 ['] lit , , ['] execute ,
715 : make-fa-primitive ( cfa n -- )
716 add-fa-checks make-primitive ;
718 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
719 add-fa-type-checks make-primitive ;
722 bold fg red ." Incorrect argument type." reset-term cr
726 : ensure-arg-type ( arg type -- arg )
728 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
735 \ ---- Macros ---- {{{
739 ( Look up macro in macro table. Returns nil if
741 : lookup-macro ( name_symbol -- proc )
743 symbol-type istype? invert if
744 \ Early exit if argument is not a symbol
766 : make-macro ( name_symbol params body env -- )
769 2swap ( proc name_symbol )
776 2over 2over ( proc name table name table )
778 2swap 2drop ( proc table )
790 macro-table obj@ cons
799 variable stored-parse-idx
800 create parse-str 161 allot
801 variable parse-str-span
803 create parse-idx-stack 10 allot
804 variable parse-idx-sp
805 parse-idx-stack parse-idx-sp !
808 parse-idx @ parse-idx-sp @ !
813 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
817 parse-idx-sp @ @ parse-idx ! ;
821 '\n' parse-str parse-str-span @ + !
822 1 parse-str-span +! ;
825 4 parse-str parse-str-span @ + !
826 1 parse-str-span +! ;
833 current-input-port obj@ console-i/o-port obj@ objeq? if
834 parse-str 160 expect cr
835 span @ parse-str-span !
837 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
838 drop swap parse-str-span !
840 parse-str-span @ 0= and if append-eof then
851 : charavailable? ( -- bool )
852 parse-str-span @ parse-idx @ > ;
854 : nextchar ( -- char )
855 charavailable? false = if getline then
856 parse-str parse-idx @ + @ ;
859 : whitespace? ( -- bool )
871 nextchar [char] ( = or
872 nextchar [char] ) = or
875 : commentstart? ( -- bool )
876 nextchar [char] ; = ;
880 false \ Indicates whether or not we're eating a comment
883 dup whitespace? or commentstart? or
885 dup nextchar '\n' = and if
886 invert \ Stop eating comment
888 dup false = commentstart? and if
889 invert \ Begin eating comment
904 nextchar [char] - = ;
907 nextchar [char] + = ;
909 : fixnum? ( -- bool )
935 : flonum? ( -- bool )
942 \ Record starting parse idx:
943 \ Want to detect whether any characters (following +/-) were eaten.
950 [char] . nextchar = if
957 [char] e nextchar = [char] E nextchar = or if
965 drop pop-parse-idx false exit
973 \ This is a real number if characters were
974 \ eaten and the next characer is a delimiter.
975 parse-idx @ < delim? and
980 : ratnum? ( -- bool )
988 pop-parse-idx false exit
997 [char] / nextchar <> if
998 pop-parse-idx false exit
1004 pop-parse-idx false exit
1013 delim? pop-parse-idx
1016 : boolean? ( -- bool )
1017 nextchar [char] # <> if false exit then
1022 nextchar [char] t <>
1023 nextchar [char] f <>
1024 and if pop-parse-idx false exit then
1036 : str-equiv? ( str -- bool )
1053 delim? false = if drop false then
1058 : character? ( -- bool )
1059 nextchar [char] # <> if false exit then
1064 nextchar [char] \ <> if pop-parse-idx false exit then
1068 S" newline" str-equiv? if pop-parse-idx true exit then
1069 S" space" str-equiv? if pop-parse-idx true exit then
1070 S" tab" str-equiv? if pop-parse-idx true exit then
1072 charavailable? false = if pop-parse-idx false exit then
1078 nextchar [char] ( = ;
1080 : string? ( -- bool )
1081 nextchar [char] " = ;
1083 : readfixnum ( -- fixnum )
1094 10 * nextchar [char] 0 - +
1103 : readflonum ( -- flonum )
1105 dup 0< swap abs i->f
1107 [char] . nextchar = if
1113 nextchar [char] 0 - i->f ( f exp d )
1114 over f/ rot f+ ( exp f' )
1115 swap 10.0 f* ( f' exp' )
1122 [char] e nextchar = [char] E nextchar = or if
1125 readfixnum drop i->f
1136 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1143 fixnum-type swap fixnum-type
1144 cons drop ratnum-type
1148 : readratnum ( -- ratnum )
1149 readfixnum inc-parse-idx readfixnum
1153 : readbool ( -- bool-obj )
1156 nextchar [char] f = if
1167 : readchar ( -- char-obj )
1171 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1172 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1173 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1175 nextchar character-type
1180 : readstring ( -- charlist )
1185 nextchar [char] " <>
1187 nextchar [char] \ = if
1190 [char] n of '\n' endof
1191 [char] " of [char] " endof
1197 inc-parse-idx character-type
1200 ( firstchar prevchar thischar )
1203 2drop 2swap 2drop 2dup ( thischar thischar )
1205 ( firstchar thischar prevchar )
1206 2over 2swap set-cdr! ( firstchar thischar )
1210 \ Discard previous character
1216 ." No delimiter following right double quote. Aborting." cr
1228 : readsymbol ( -- charlist )
1229 delim? if nil exit then
1231 nextchar inc-parse-idx character-type
1238 : readpair ( -- pairobj )
1242 nextchar [char] ) = if
1247 ." No delimiter following right paren. Aborting." cr
1256 \ Read first pair element
1261 nextchar [char] . = if
1266 ." No delimiter following '.'. Aborting." cr
1280 \ Parse a scheme expression
1315 nextchar [char] " <> if
1316 bold red ." Missing closing double-quote." reset-term cr
1334 nextchar [char] ) <> if
1335 bold red ." Missing closing paren." reset-term cr
1344 nextchar [char] ' = if
1346 quote-symbol recurse nil cons cons exit
1349 nextchar [char] ` = if
1351 quasiquote-symbol recurse nil cons cons exit
1354 nextchar [char] , = if
1356 nextchar [char] @ = if
1358 unquote-splicing-symbol recurse nil cons cons exit
1360 unquote-symbol recurse nil cons cons exit
1370 nextchar [char] ) = if
1372 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1375 \ Anything else is parsed as a symbol
1376 readsymbol charlist>symbol
1378 \ Replace λ with lambda
1379 2dup λ-symbol objeq? if
1388 \ ---- Syntax ---- {{{
1390 : self-evaluating? ( obj -- obj bool )
1391 boolean-type istype? if true exit then
1392 fixnum-type istype? if true exit then
1393 flonum-type istype? if true exit then
1394 ratnum-type istype? if true exit then
1395 character-type istype? if true exit then
1396 string-type istype? if true exit then
1397 nil-type istype? if true exit then
1398 none-type istype? if true exit then
1403 : tagged-list? ( obj tag-obj -- obj bool )
1405 pair-type istype? false = if
1411 : quote? ( obj -- obj bool )
1412 quote-symbol tagged-list? ;
1414 : quote-body ( quote-obj -- quote-body-obj )
1417 : variable? ( obj -- obj bool )
1418 symbol-type istype? ;
1420 : definition? ( obj -- obj bool )
1421 define-symbol tagged-list? ;
1423 : definition-var ( obj -- var )
1426 : definition-val ( obj -- val )
1429 : assignment? ( obj -- obj bool )
1430 set!-symbol tagged-list? ;
1432 : assignment-var ( obj -- var )
1435 : assignment-val ( obj -- val )
1438 : macro-definition? ( obj -- obj bool )
1439 define-macro-symbol tagged-list? ;
1441 : macro-definition-name ( exp -- mname )
1444 : macro-definition-params ( exp -- params )
1447 : macro-definition-body ( exp -- body )
1450 : if? ( obj -- obj bool )
1451 if-symbol tagged-list? ;
1453 : if-predicate ( ifobj -- pred )
1456 : if-consequent ( ifobj -- conseq )
1459 : if-alternative ( ifobj -- alt|none )
1467 : false? ( boolobj -- boolean )
1468 boolean-type istype? if
1469 false boolean-type objeq?
1475 : true? ( boolobj -- bool )
1478 : lambda? ( obj -- obj bool )
1479 lambda-symbol tagged-list? ;
1481 : lambda-parameters ( obj -- params )
1484 : lambda-body ( obj -- body )
1487 : application? ( obj -- obj bool )
1490 : operator ( obj -- operator )
1493 : operands ( obj -- operands )
1496 : nooperands? ( operands -- bool )
1499 : first-operand ( operands -- operand )
1502 : rest-operands ( operands -- other-operands )
1505 : procedure-params ( proc -- params )
1506 drop pair-type car ;
1508 : procedure-body ( proc -- body )
1509 drop pair-type cdr car ;
1511 : procedure-env ( proc -- body )
1512 drop pair-type cdr cdr car ;
1514 ( Ensure terminating symbol arg name is handled
1515 specially to allow for variadic procedures. )
1516 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1518 2over nil? false = if
1519 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1526 symbol-type istype? if
1536 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1543 recurse ( argvals argnames argvals'' argnames'' )
1544 2rot car 2swap cons ( argvals argvals'' argnames' )
1545 2rot car 2rot cons ( argnames' argvals' )
1551 \ ---- Analyze ---- {{{
1553 : evaluate-eproc ( eproc env --- res )
1564 2drop \ get rid of null
1568 \ Final element of eproc list is primitive procedure
1569 drop \ dump type signifier
1571 goto \ jump straight to primitive procedure (executor)
1574 : self-evaluating-executor ( exp env -- exp )
1577 : analyze-self-evaluating ( exp --- eproc )
1578 ['] self-evaluating-executor primitive-proc-type
1582 : quote-executor ( exp env -- exp )
1585 : analyze-quoted ( exp -- eproc )
1588 ['] quote-executor primitive-proc-type
1592 : variable-executor ( var env -- val )
1595 : analyze-variable ( exp -- eproc )
1596 ['] variable-executor primitive-proc-type
1600 : definition-executor ( var val-eproc env -- ok )
1601 2swap 2over ( var env val-eproc env )
1602 evaluate-eproc 2swap ( var val env )
1607 : analyze-definition ( exp -- eproc )
1609 2swap definition-val analyze
1611 ['] definition-executor primitive-proc-type
1615 : assignment-executor ( var val-eproc env -- ok )
1616 2swap 2over ( var env val-eproc env )
1617 evaluate-eproc 2swap ( var val env )
1622 : analyze-assignment ( exp -- eproc )
1624 2swap assignment-val analyze ( var val-eproc )
1626 ['] assignment-executor primitive-proc-type
1630 : sequence-executor ( eproc-list env -- res )
1634 2dup cdr ( env elist elist-rest)
1637 -2rot car 2over ( elist-rest env elist-head env )
1638 evaluate-eproc ( elist-rest env head-res )
1639 2drop 2swap ( env elist-rest )
1643 ['] evaluate-eproc goto
1647 : (analyze-sequence) ( explist -- eproc-list )
1656 : analyze-sequence ( explist -- eproc )
1658 ['] sequence-executor primitive-proc-type
1663 : macro-definition-executor ( name params bproc env -- ok )
1664 make-macro ok-symbol
1667 : analyze-macro-definition ( exp -- eproc )
1668 2dup macro-definition-name
1669 2swap 2dup macro-definition-params
1670 2swap macro-definition-body analyze-sequence
1672 ['] macro-definition-executor primitive-proc-type
1673 nil cons cons cons cons
1676 : if-executor ( cproc aproc pproc env -- res )
1677 2swap 2over ( cproc aproc env pproc env -- res )
1686 ['] evaluate-eproc goto
1689 : analyze-if ( exp -- eproc )
1690 2dup if-consequent analyze
1691 2swap 2dup if-alternative analyze
1692 2swap if-predicate analyze
1694 ['] if-executor primitive-proc-type
1695 nil cons cons cons cons
1698 : lambda-executor ( params bproc env -- res )
1700 ( Although this is packaged up as a regular compound procedure,
1701 the "body" element contains an _eproc_ to be evaluated in an
1702 environment resulting from extending env with the parameter
1706 : analyze-lambda ( exp -- eproc )
1707 2dup lambda-parameters
1711 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1716 ['] lambda-executor primitive-proc-type
1720 : operand-eproc-list ( operands -- eprocs )
1728 : evaluate-operand-eprocs ( env aprocs -- vals )
1732 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1733 -2rot cdr recurse ( thisval restvals )
1738 : apply ( vals proc )
1740 primitive-proc-type of
1744 compound-proc-type of
1745 2dup procedure-body ( argvals proc bproc )
1746 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1747 -2rot procedure-env ( bproc argnames argvals procenv )
1753 extend-env ( bproc env )
1755 ['] evaluate-eproc goto
1758 continuation-type of
1759 \ TODO: Apply continuation
1762 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1766 : application-executor ( operator-proc arg-procs env -- res )
1767 2rot 2over ( aprocs env fproc env )
1768 evaluate-eproc ( aprocs env proc )
1770 -2rot 2swap ( proc env aprocs )
1771 evaluate-operand-eprocs ( proc vals )
1778 : analyze-application ( exp -- eproc )
1779 2dup operator analyze
1780 2swap operands operand-eproc-list
1782 ['] application-executor primitive-proc-type
1786 :noname ( exp --- eproc )
1788 self-evaluating? if analyze-self-evaluating exit then
1790 quote? if analyze-quoted exit then
1792 variable? if analyze-variable exit then
1794 definition? if analyze-definition exit then
1796 assignment? if analyze-assignment exit then
1798 macro-definition? if analyze-macro-definition exit then
1800 if? if analyze-if exit then
1802 lambda? if analyze-lambda exit then
1804 application? if analyze-application exit then
1806 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1812 \ ---- Macro Expansion ---- {{{
1814 ( Simply evaluates the given procedure with expbody as its argument. )
1815 : macro-eval ( proc expbody -- result )
1817 2dup procedure-body ( expbody proc bproc )
1818 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1819 -2rot procedure-env ( bproc argnames expbody procenv )
1825 extend-env ( bproc env )
1827 ['] evaluate-eproc goto
1830 : expand-macro ( exp -- result )
1831 pair-type istype? invert if exit then
1833 2dup car symbol-type istype? invert if 2drop exit then
1835 lookup-macro nil? if 2drop exit then
1837 2over cdr macro-eval
1839 2dup no-match-symbol objeq? if
1845 R> drop ['] expand goto-deferred
1848 : expand-definition ( exp -- result )
1852 2swap definition-val expand
1853 nil ( define var val' nil )
1857 : expand-assignment ( exp -- result )
1861 2swap assignment-val expand
1862 nil ( define var val' nil )
1866 : expand-list ( exp -- res )
1874 : macro-definition-nameparams
1877 : expand-define-macro ( exp -- res )
1878 define-macro-symbol 2swap
1879 2dup macro-definition-nameparams
1880 2swap macro-definition-body expand-list
1884 : expand-lambda ( exp -- res )
1886 2dup lambda-parameters
1887 2swap lambda-body expand-list
1891 : expand-if ( exp -- res )
1894 2dup if-predicate expand
1895 2swap 2dup if-consequent expand
1896 2swap if-alternative none? if
1904 : expand-application ( exp -- res )
1905 2dup operator expand
1906 2swap operands expand-list
1910 :noname ( exp -- result )
1913 self-evaluating? if exit then
1917 definition? if expand-definition exit then
1919 assignment? if expand-assignment exit then
1921 macro-definition? if expand-define-macro exit then
1923 lambda? if expand-lambda exit then
1925 if? if expand-if exit then
1927 application? if expand-application exit then
1933 :noname ( exp env -- res )
1934 2swap expand analyze 2swap evaluate-eproc
1937 \ ---- Print ---- {{{
1939 : printfixnum ( fixnum -- ) drop 0 .R ;
1941 : printflonum ( flonum -- ) drop f. ;
1943 : printratnum ( ratnum -- )
1945 car print ." /" cdr print
1948 : printbool ( bool -- )
1956 : printchar ( charobj -- )
1959 9 of ." #\tab" endof
1960 bl of ." #\space" endof
1961 '\n' of ." #\newline" endof
1967 : (printstring) ( stringobj -- )
1968 nil? if 2drop exit then
1972 '\n' of ." \n" drop endof
1973 [char] \ of ." \\" drop endof
1974 [char] " of [char] \ emit [char] " emit drop endof
1980 : printstring ( stringobj -- )
1985 : printsymbol ( symbolobj -- )
1986 nil-type istype? if 2drop exit then
1992 : printnil ( nilobj -- )
1995 : printpair ( pairobj -- )
1999 nil-type istype? if 2drop exit then
2000 pair-type istype? if space recurse exit then
2004 : printprim ( primobj -- )
2005 2drop ." <primitive procedure>" ;
2007 : printcomp ( primobj -- )
2008 2drop ." <compound procedure>" ;
2010 : printcont ( primobj --)
2011 2drop ." <continuation>" ;
2013 : printnone ( noneobj -- )
2014 2drop ." Unspecified return value" ;
2016 : printport ( port -- )
2020 fixnum-type istype? if printfixnum exit then
2021 flonum-type istype? if printflonum exit then
2022 ratnum-type istype? if printratnum exit then
2023 boolean-type istype? if printbool exit then
2024 character-type istype? if printchar exit then
2025 string-type istype? if printstring exit then
2026 symbol-type istype? if printsymbol exit then
2027 nil-type istype? if printnil exit then
2028 pair-type istype? if ." (" printpair ." )" exit then
2029 primitive-proc-type istype? if printprim exit then
2030 compound-proc-type istype? if printcomp exit then
2031 continuation-type istype? if printcont exit then
2032 none-type istype? if printnone exit then
2033 port-type istype? if printport exit then
2035 except-message: ." tried to print object with unknown type." recoverable-exception throw
2040 \ ---- Garbage Collection ---- {{{
2042 ( Notes on garbage collection:
2043 This is a mark-sweep garbage collector, invoked by cons.
2044 The roots of the object tree used by the marking routine
2045 include all objects in the parameter stack, and several
2046 other fixed roots such as global-env, symbol-table, macro-table,
2047 and the console-i/o-port.
2049 NO OTHER OBJECTS WILL BE MARKED!
2051 This places implicit restrictions on when cons can be invoked.
2052 Invoking cons when live objects are stored on the return stack
2053 or in other variables than the above will result in possible
2054 memory corruption if the cons triggers the GC. )
2057 : pairlike? ( obj -- obj bool )
2058 pair-type istype? if true exit then
2059 string-type istype? if true exit then
2060 symbol-type istype? if true exit then
2061 compound-proc-type istype? if true exit then
2062 port-type istype? if true exit then
2067 : pairlike-marked? ( obj -- obj bool )
2068 over nextfrees + @ 0=
2071 : mark-pairlike ( obj -- obj )
2072 over nextfrees + 0 swap !
2081 : gc-mark-obj ( obj -- )
2083 pairlike? invert if 2drop exit then
2084 pairlike-marked? if 2drop exit then
2095 scheme-memsize nextfree !
2096 0 scheme-memsize 1- do
2097 nextfrees i + @ 0<> if
2098 nextfree @ nextfrees i + !
2104 \ Following a GC, this gives the amount of free memory
2108 nextfrees i + @ 0= if 1+ then
2112 \ Debugging word - helps spot memory that is retained
2115 nextfrees i + @ 0<> if
2127 symbol-table obj@ gc-mark-obj
2128 macro-table obj@ gc-mark-obj
2129 console-i/o-port obj@ gc-mark-obj
2130 global-env obj@ gc-mark-obj
2132 depth object-stack-base @ do
2141 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2142 ; is collect-garbage
2149 \ ---- Loading files ---- {{{
2151 : load ( addr n -- finalResult )
2156 ok-symbol ( port res )
2160 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2162 2over read-port ( port res obj )
2167 2dup EOF character-type objeq? if
2168 2drop 2swap close-port
2172 2swap 2drop ( port obj )
2174 global-env obj@ eval ( port res )
2180 \ ---- Standard Library ---- {{{
2182 include scheme-primitives.4th
2184 init-object-stack-base
2185 s" scheme-library.scm" load 2drop
2191 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2192 : repl-body ( -- bool )
2193 cr bold fg green ." > " reset-term
2197 2dup EOF character-type objeq? if
2199 bold fg blue ." Moriturus te saluto." reset-term cr
2203 global-env obj@ eval
2205 fg cyan ." ; " print reset-term
2213 init-object-stack-base
2215 \ Display welcome message
2216 welcome-symbol nil cons global-env obj@ eval 2drop
2221 recoverable-exception of false endof
2222 unrecoverable-exception of true endof