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 : list->pad ( list -- n )
593 2dup car drop -rot \ keep length of list on stack
594 2dup cdr 2swap car drop \ get length from list
596 pad + 1- \ final dest addr
597 pad \ initial dest addr
607 : restore-return-stack ( continuation -- )
611 continuation->rstack-list
614 RSP0 + RSP! \ expand return stack to accommodate entries
618 pad i + @ RSP0 i 1+ + !
624 : restore-continuation ( continuation -- )
625 \ TODO: replace current parameter and return stacks with
626 \ contents of continuation object.
631 ." ====== PARAM STACK RESTORED ======" cr
640 \ ---- Primitives ---- {{{
642 : make-primitive ( cfa -- )
649 rot primitive-proc-type ( var prim )
650 global-env obj@ define-var
653 : ensure-arg-count ( args n -- )
655 drop nil objeq? false = if
656 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
660 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
667 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
669 drop nil objeq? false = if
670 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
674 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
677 2dup cdr 2swap car ( ... t1 n args' arg1 )
678 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
680 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
688 : push-args-to-stack ( args -- arg1 arg2 ... argn )
698 : add-fa-checks ( cfa n -- cfa' )
699 here current @ 1+ dup @ , !
703 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
704 ['] push-args-to-stack ,
705 ['] lit , , ['] execute ,
709 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
710 here current @ 1+ dup @ , !
717 dup ( cfa t1 t2 ... tn n m )
722 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
728 ['] lit , , ['] ensure-arg-type-and-count ,
730 ['] push-args-to-stack ,
731 ['] lit , , ['] execute ,
737 : make-fa-primitive ( cfa n -- )
738 add-fa-checks make-primitive ;
740 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
741 add-fa-type-checks make-primitive ;
744 bold fg red ." Incorrect argument type." reset-term cr
748 : ensure-arg-type ( arg type -- arg )
750 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
757 \ ---- Macros ---- {{{
761 ( Look up macro in macro table. Returns nil if
763 : lookup-macro ( name_symbol -- proc )
765 symbol-type istype? invert if
766 \ Early exit if argument is not a symbol
788 : make-macro ( name_symbol params body env -- )
791 2swap ( proc name_symbol )
798 2over 2over ( proc name table name table )
800 2swap 2drop ( proc table )
812 macro-table obj@ cons
821 variable stored-parse-idx
822 create parse-str 161 allot
823 variable parse-str-span
825 create parse-idx-stack 10 allot
826 variable parse-idx-sp
827 parse-idx-stack parse-idx-sp !
830 parse-idx @ parse-idx-sp @ !
835 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
839 parse-idx-sp @ @ parse-idx ! ;
843 '\n' parse-str parse-str-span @ + !
844 1 parse-str-span +! ;
847 4 parse-str parse-str-span @ + !
848 1 parse-str-span +! ;
855 current-input-port obj@ console-i/o-port obj@ objeq? if
856 parse-str 160 expect cr
857 span @ parse-str-span !
859 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
860 drop swap parse-str-span !
862 parse-str-span @ 0= and if append-eof then
873 : charavailable? ( -- bool )
874 parse-str-span @ parse-idx @ > ;
876 : nextchar ( -- char )
877 charavailable? false = if getline then
878 parse-str parse-idx @ + @ ;
881 : whitespace? ( -- bool )
893 nextchar [char] ( = or
894 nextchar [char] ) = or
897 : commentstart? ( -- bool )
898 nextchar [char] ; = ;
902 false \ Indicates whether or not we're eating a comment
905 dup whitespace? or commentstart? or
907 dup nextchar '\n' = and if
908 invert \ Stop eating comment
910 dup false = commentstart? and if
911 invert \ Begin eating comment
926 nextchar [char] - = ;
929 nextchar [char] + = ;
931 : fixnum? ( -- bool )
957 : flonum? ( -- bool )
964 \ Record starting parse idx:
965 \ Want to detect whether any characters (following +/-) were eaten.
972 [char] . nextchar = if
979 [char] e nextchar = [char] E nextchar = or if
987 drop pop-parse-idx false exit
995 \ This is a real number if characters were
996 \ eaten and the next characer is a delimiter.
997 parse-idx @ < delim? and
1002 : ratnum? ( -- bool )
1010 pop-parse-idx false exit
1019 [char] / nextchar <> if
1020 pop-parse-idx false exit
1026 pop-parse-idx false exit
1035 delim? pop-parse-idx
1038 : boolean? ( -- bool )
1039 nextchar [char] # <> if false exit then
1044 nextchar [char] t <>
1045 nextchar [char] f <>
1046 and if pop-parse-idx false exit then
1058 : str-equiv? ( str -- bool )
1075 delim? false = if drop false then
1080 : character? ( -- bool )
1081 nextchar [char] # <> if false exit then
1086 nextchar [char] \ <> if pop-parse-idx false exit then
1090 S" newline" str-equiv? if pop-parse-idx true exit then
1091 S" space" str-equiv? if pop-parse-idx true exit then
1092 S" tab" str-equiv? if pop-parse-idx true exit then
1094 charavailable? false = if pop-parse-idx false exit then
1100 nextchar [char] ( = ;
1102 : string? ( -- bool )
1103 nextchar [char] " = ;
1105 : readfixnum ( -- fixnum )
1116 10 * nextchar [char] 0 - +
1125 : readflonum ( -- flonum )
1127 dup 0< swap abs i->f
1129 [char] . nextchar = if
1135 nextchar [char] 0 - i->f ( f exp d )
1136 over f/ rot f+ ( exp f' )
1137 swap 10.0 f* ( f' exp' )
1144 [char] e nextchar = [char] E nextchar = or if
1147 readfixnum drop i->f
1158 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1165 fixnum-type swap fixnum-type
1166 cons drop ratnum-type
1170 : readratnum ( -- ratnum )
1171 readfixnum inc-parse-idx readfixnum
1175 : readbool ( -- bool-obj )
1178 nextchar [char] f = if
1189 : readchar ( -- char-obj )
1193 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1194 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1195 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1197 nextchar character-type
1202 : readstring ( -- charlist )
1207 nextchar [char] " <>
1209 nextchar [char] \ = if
1212 [char] n of '\n' endof
1213 [char] " of [char] " endof
1219 inc-parse-idx character-type
1222 ( firstchar prevchar thischar )
1225 2drop 2swap 2drop 2dup ( thischar thischar )
1227 ( firstchar thischar prevchar )
1228 2over 2swap set-cdr! ( firstchar thischar )
1232 \ Discard previous character
1238 ." No delimiter following right double quote. Aborting." cr
1250 : readsymbol ( -- charlist )
1251 delim? if nil exit then
1253 nextchar inc-parse-idx character-type
1260 : readpair ( -- pairobj )
1264 nextchar [char] ) = if
1269 ." No delimiter following right paren. Aborting." cr
1278 \ Read first pair element
1283 nextchar [char] . = if
1288 ." No delimiter following '.'. Aborting." cr
1302 \ Parse a scheme expression
1337 nextchar [char] " <> if
1338 bold red ." Missing closing double-quote." reset-term cr
1356 nextchar [char] ) <> if
1357 bold red ." Missing closing paren." reset-term cr
1366 nextchar [char] ' = if
1368 quote-symbol recurse nil cons cons exit
1371 nextchar [char] ` = if
1373 quasiquote-symbol recurse nil cons cons exit
1376 nextchar [char] , = if
1378 nextchar [char] @ = if
1380 unquote-splicing-symbol recurse nil cons cons exit
1382 unquote-symbol recurse nil cons cons exit
1392 nextchar [char] ) = if
1394 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1397 \ Anything else is parsed as a symbol
1398 readsymbol charlist>symbol
1400 \ Replace λ with lambda
1401 2dup λ-symbol objeq? if
1410 \ ---- Syntax ---- {{{
1412 : self-evaluating? ( obj -- obj bool )
1413 boolean-type istype? if true exit then
1414 fixnum-type istype? if true exit then
1415 flonum-type istype? if true exit then
1416 ratnum-type istype? if true exit then
1417 character-type istype? if true exit then
1418 string-type istype? if true exit then
1419 nil-type istype? if true exit then
1420 none-type istype? if true exit then
1425 : tagged-list? ( obj tag-obj -- obj bool )
1427 pair-type istype? false = if
1433 : quote? ( obj -- obj bool )
1434 quote-symbol tagged-list? ;
1436 : quote-body ( quote-obj -- quote-body-obj )
1439 : variable? ( obj -- obj bool )
1440 symbol-type istype? ;
1442 : definition? ( obj -- obj bool )
1443 define-symbol tagged-list? ;
1445 : definition-var ( obj -- var )
1448 : definition-val ( obj -- val )
1451 : assignment? ( obj -- obj bool )
1452 set!-symbol tagged-list? ;
1454 : assignment-var ( obj -- var )
1457 : assignment-val ( obj -- val )
1460 : macro-definition? ( obj -- obj bool )
1461 define-macro-symbol tagged-list? ;
1463 : macro-definition-name ( exp -- mname )
1466 : macro-definition-params ( exp -- params )
1469 : macro-definition-body ( exp -- body )
1472 : if? ( obj -- obj bool )
1473 if-symbol tagged-list? ;
1475 : if-predicate ( ifobj -- pred )
1478 : if-consequent ( ifobj -- conseq )
1481 : if-alternative ( ifobj -- alt|none )
1489 : false? ( boolobj -- boolean )
1490 boolean-type istype? if
1491 false boolean-type objeq?
1497 : true? ( boolobj -- bool )
1500 : lambda? ( obj -- obj bool )
1501 lambda-symbol tagged-list? ;
1503 : lambda-parameters ( obj -- params )
1506 : lambda-body ( obj -- body )
1509 : application? ( obj -- obj bool )
1512 : operator ( obj -- operator )
1515 : operands ( obj -- operands )
1518 : nooperands? ( operands -- bool )
1521 : first-operand ( operands -- operand )
1524 : rest-operands ( operands -- other-operands )
1527 : procedure-params ( proc -- params )
1528 drop pair-type car ;
1530 : procedure-body ( proc -- body )
1531 drop pair-type cdr car ;
1533 : procedure-env ( proc -- body )
1534 drop pair-type cdr cdr car ;
1536 ( Ensure terminating symbol arg name is handled
1537 specially to allow for variadic procedures. )
1538 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1540 2over nil? false = if
1541 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1548 symbol-type istype? if
1558 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1565 recurse ( argvals argnames argvals'' argnames'' )
1566 2rot car 2swap cons ( argvals argvals'' argnames' )
1567 2rot car 2rot cons ( argnames' argvals' )
1573 \ ---- Analyze ---- {{{
1575 : evaluate-eproc ( eproc env --- res )
1586 2drop \ get rid of null
1590 \ Final element of eproc list is primitive procedure
1591 drop \ dump type signifier
1593 goto \ jump straight to primitive procedure (executor)
1596 : self-evaluating-executor ( exp env -- exp )
1599 : analyze-self-evaluating ( exp --- eproc )
1600 ['] self-evaluating-executor primitive-proc-type
1604 : quote-executor ( exp env -- exp )
1607 : analyze-quoted ( exp -- eproc )
1610 ['] quote-executor primitive-proc-type
1614 : variable-executor ( var env -- val )
1617 : analyze-variable ( exp -- eproc )
1618 ['] variable-executor primitive-proc-type
1622 : definition-executor ( var val-eproc env -- ok )
1623 2swap 2over ( var env val-eproc env )
1624 evaluate-eproc 2swap ( var val env )
1629 : analyze-definition ( exp -- eproc )
1631 2swap definition-val analyze
1633 ['] definition-executor primitive-proc-type
1637 : assignment-executor ( var val-eproc env -- ok )
1638 2swap 2over ( var env val-eproc env )
1639 evaluate-eproc 2swap ( var val env )
1644 : analyze-assignment ( exp -- eproc )
1646 2swap assignment-val analyze ( var val-eproc )
1648 ['] assignment-executor primitive-proc-type
1652 : sequence-executor ( eproc-list env -- res )
1656 2dup cdr ( env elist elist-rest)
1659 -2rot car 2over ( elist-rest env elist-head env )
1660 evaluate-eproc ( elist-rest env head-res )
1661 2drop 2swap ( env elist-rest )
1665 ['] evaluate-eproc goto
1669 : (analyze-sequence) ( explist -- eproc-list )
1678 : analyze-sequence ( explist -- eproc )
1680 ['] sequence-executor primitive-proc-type
1685 : macro-definition-executor ( name params bproc env -- ok )
1686 make-macro ok-symbol
1689 : analyze-macro-definition ( exp -- eproc )
1690 2dup macro-definition-name
1691 2swap 2dup macro-definition-params
1692 2swap macro-definition-body analyze-sequence
1694 ['] macro-definition-executor primitive-proc-type
1695 nil cons cons cons cons
1698 : if-executor ( cproc aproc pproc env -- res )
1699 2swap 2over ( cproc aproc env pproc env -- res )
1708 ['] evaluate-eproc goto
1711 : analyze-if ( exp -- eproc )
1712 2dup if-consequent analyze
1713 2swap 2dup if-alternative analyze
1714 2swap if-predicate analyze
1716 ['] if-executor primitive-proc-type
1717 nil cons cons cons cons
1720 : lambda-executor ( params bproc env -- res )
1722 ( Although this is packaged up as a regular compound procedure,
1723 the "body" element contains an _eproc_ to be evaluated in an
1724 environment resulting from extending env with the parameter
1728 : analyze-lambda ( exp -- eproc )
1729 2dup lambda-parameters
1733 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1738 ['] lambda-executor primitive-proc-type
1742 : operand-eproc-list ( operands -- eprocs )
1750 : evaluate-operand-eprocs ( env aprocs -- vals )
1754 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1755 -2rot cdr recurse ( thisval restvals )
1760 : apply ( vals proc )
1762 primitive-proc-type of
1766 compound-proc-type of
1767 2dup procedure-body ( argvals proc bproc )
1768 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1769 -2rot procedure-env ( bproc argnames argvals procenv )
1775 extend-env ( bproc env )
1777 ['] evaluate-eproc goto
1780 continuation-type of
1781 \ TODO: Apply continuation
1784 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1788 : application-executor ( operator-proc arg-procs env -- res )
1789 2rot 2over ( aprocs env fproc env )
1790 evaluate-eproc ( aprocs env proc )
1792 -2rot 2swap ( proc env aprocs )
1793 evaluate-operand-eprocs ( proc vals )
1800 : analyze-application ( exp -- eproc )
1801 2dup operator analyze
1802 2swap operands operand-eproc-list
1804 ['] application-executor primitive-proc-type
1808 :noname ( exp --- eproc )
1810 self-evaluating? if analyze-self-evaluating exit then
1812 quote? if analyze-quoted exit then
1814 variable? if analyze-variable exit then
1816 definition? if analyze-definition exit then
1818 assignment? if analyze-assignment exit then
1820 macro-definition? if analyze-macro-definition exit then
1822 if? if analyze-if exit then
1824 lambda? if analyze-lambda exit then
1826 application? if analyze-application exit then
1828 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1834 \ ---- Macro Expansion ---- {{{
1836 ( Simply evaluates the given procedure with expbody as its argument. )
1837 : macro-eval ( proc expbody -- result )
1839 2dup procedure-body ( expbody proc bproc )
1840 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1841 -2rot procedure-env ( bproc argnames expbody procenv )
1847 extend-env ( bproc env )
1849 ['] evaluate-eproc goto
1852 : expand-macro ( exp -- result )
1853 pair-type istype? invert if exit then
1855 2dup car symbol-type istype? invert if 2drop exit then
1857 lookup-macro nil? if 2drop exit then
1859 2over cdr macro-eval
1861 2dup no-match-symbol objeq? if
1867 R> drop ['] expand goto-deferred
1870 : expand-definition ( exp -- result )
1874 2swap definition-val expand
1875 nil ( define var val' nil )
1879 : expand-assignment ( exp -- result )
1883 2swap assignment-val expand
1884 nil ( define var val' nil )
1888 : expand-list ( exp -- res )
1896 : macro-definition-nameparams
1899 : expand-define-macro ( exp -- res )
1900 define-macro-symbol 2swap
1901 2dup macro-definition-nameparams
1902 2swap macro-definition-body expand-list
1906 : expand-lambda ( exp -- res )
1908 2dup lambda-parameters
1909 2swap lambda-body expand-list
1913 : expand-if ( exp -- res )
1916 2dup if-predicate expand
1917 2swap 2dup if-consequent expand
1918 2swap if-alternative none? if
1926 : expand-application ( exp -- res )
1927 2dup operator expand
1928 2swap operands expand-list
1932 :noname ( exp -- result )
1935 self-evaluating? if exit then
1939 definition? if expand-definition exit then
1941 assignment? if expand-assignment exit then
1943 macro-definition? if expand-define-macro exit then
1945 lambda? if expand-lambda exit then
1947 if? if expand-if exit then
1949 application? if expand-application exit then
1955 :noname ( exp env -- res )
1956 2swap expand analyze 2swap evaluate-eproc
1959 \ ---- Print ---- {{{
1961 : printfixnum ( fixnum -- ) drop 0 .R ;
1963 : printflonum ( flonum -- ) drop f. ;
1965 : printratnum ( ratnum -- )
1967 car print ." /" cdr print
1970 : printbool ( bool -- )
1978 : printchar ( charobj -- )
1981 9 of ." #\tab" endof
1982 bl of ." #\space" endof
1983 '\n' of ." #\newline" endof
1989 : (printstring) ( stringobj -- )
1990 nil? if 2drop exit then
1994 '\n' of ." \n" drop endof
1995 [char] \ of ." \\" drop endof
1996 [char] " of [char] \ emit [char] " emit drop endof
2002 : printstring ( stringobj -- )
2007 : printsymbol ( symbolobj -- )
2008 nil-type istype? if 2drop exit then
2014 : printnil ( nilobj -- )
2017 : printpair ( pairobj -- )
2021 nil-type istype? if 2drop exit then
2022 pair-type istype? if space recurse exit then
2026 : printprim ( primobj -- )
2027 2drop ." <primitive procedure>" ;
2029 : printcomp ( primobj -- )
2030 2drop ." <compound procedure>" ;
2032 : printcont ( primobj --)
2033 2drop ." <continuation>" ;
2035 : printnone ( noneobj -- )
2036 2drop ." Unspecified return value" ;
2038 : printport ( port -- )
2042 fixnum-type istype? if printfixnum exit then
2043 flonum-type istype? if printflonum exit then
2044 ratnum-type istype? if printratnum exit then
2045 boolean-type istype? if printbool exit then
2046 character-type istype? if printchar exit then
2047 string-type istype? if printstring exit then
2048 symbol-type istype? if printsymbol exit then
2049 nil-type istype? if printnil exit then
2050 pair-type istype? if ." (" printpair ." )" exit then
2051 primitive-proc-type istype? if printprim exit then
2052 compound-proc-type istype? if printcomp exit then
2053 continuation-type istype? if printcont exit then
2054 none-type istype? if printnone exit then
2055 port-type istype? if printport exit then
2057 except-message: ." tried to print object with unknown type." recoverable-exception throw
2062 \ ---- Garbage Collection ---- {{{
2064 ( Notes on garbage collection:
2065 This is a mark-sweep garbage collector, invoked by cons.
2066 The roots of the object tree used by the marking routine
2067 include all objects in the parameter stack, and several
2068 other fixed roots such as global-env, symbol-table, macro-table,
2069 and the console-i/o-port.
2071 NO OTHER OBJECTS WILL BE MARKED!
2073 This places implicit restrictions on when cons can be invoked.
2074 Invoking cons when live objects are stored on the return stack
2075 or in other variables than the above will result in possible
2076 memory corruption if the cons triggers the GC. )
2079 : pairlike? ( obj -- obj bool )
2080 pair-type istype? if true exit then
2081 string-type istype? if true exit then
2082 symbol-type istype? if true exit then
2083 compound-proc-type istype? if true exit then
2084 port-type istype? if true exit then
2089 : pairlike-marked? ( obj -- obj bool )
2090 over nextfrees + @ 0=
2093 : mark-pairlike ( obj -- obj )
2094 over nextfrees + 0 swap !
2103 : gc-mark-obj ( obj -- )
2105 pairlike? invert if 2drop exit then
2106 pairlike-marked? if 2drop exit then
2117 scheme-memsize nextfree !
2118 0 scheme-memsize 1- do
2119 nextfrees i + @ 0<> if
2120 nextfree @ nextfrees i + !
2126 \ Following a GC, this gives the amount of free memory
2130 nextfrees i + @ 0= if 1+ then
2134 \ Debugging word - helps spot memory that is retained
2137 nextfrees i + @ 0<> if
2149 symbol-table obj@ gc-mark-obj
2150 macro-table obj@ gc-mark-obj
2151 console-i/o-port obj@ gc-mark-obj
2152 global-env obj@ gc-mark-obj
2154 depth object-stack-base @ do
2163 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2164 ; is collect-garbage
2171 \ ---- Loading files ---- {{{
2173 : load ( addr n -- finalResult )
2178 ok-symbol ( port res )
2182 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2184 2over read-port ( port res obj )
2189 2dup EOF character-type objeq? if
2190 2drop 2swap close-port
2194 2swap 2drop ( port obj )
2196 global-env obj@ eval ( port res )
2202 \ ---- Standard Library ---- {{{
2204 include scheme-primitives.4th
2206 init-object-stack-base
2207 s" scheme-library.scm" load 2drop
2213 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2214 : repl-body ( -- bool )
2215 cr bold fg green ." > " reset-term
2219 2dup EOF character-type objeq? if
2221 bold fg blue ." Moriturus te saluto." reset-term cr
2225 global-env obj@ eval
2227 fg cyan ." ; " print reset-term
2235 init-object-stack-base
2237 \ Display welcome message
2238 welcome-symbol nil cons global-env obj@ eval 2drop
2243 recoverable-exception of false endof
2244 unrecoverable-exception of true endof