4 include term-colours.4th
7 include catch-throw.4th
33 make-type boolean-type
34 make-type character-type
40 make-type primitive-proc-type
41 make-type compound-proc-type
43 : istype? ( obj type -- obj bool )
48 \ ---- Exceptions ---- {{{
50 variable nextexception
53 create nextexception @ ,
62 make-exception recoverable-exception
63 make-exception unrecoverable-exception
65 : throw reset-term throw ;
69 \ ---- List-structured memory ---- {{{
71 20000 constant scheme-memsize
73 create car-cells scheme-memsize allot
74 create car-type-cells scheme-memsize allot
75 create cdr-cells scheme-memsize allot
76 create cdr-type-cells scheme-memsize allot
78 create nextfrees scheme-memsize allot
89 nextfrees nextfree @ + @
92 nextfree @ scheme-memsize >= if
96 nextfree @ scheme-memsize >= if
97 except-message: ." Out of memory!" unrecoverable-exception throw
101 : cons ( car-obj cdr-obj -- pair-obj )
102 cdr-type-cells nextfree @ + !
103 cdr-cells nextfree @ + !
104 car-type-cells nextfree @ + !
105 car-cells nextfree @ + !
111 : car ( pair-obj -- car-obj )
113 dup car-cells + @ swap
117 : cdr ( pair-obj -- car-obj )
119 dup cdr-cells + @ swap
123 : set-car! ( obj pair-obj -- )
125 rot swap car-type-cells + !
129 : set-cdr! ( obj pair-obj -- )
131 rot swap cdr-type-cells + !
136 : nil? nil-type istype? ;
139 : none? none-type istype? ;
141 : objvar create nil swap , , ;
143 : value@ ( objvar -- val ) @ ;
144 : type@ ( objvar -- type ) 1+ @ ;
145 : value! ( newval objvar -- ) ! ;
146 : type! ( newtype objvar -- ) 1+ ! ;
147 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
148 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
150 : objeq? ( obj obj -- bool )
153 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
154 >R >R ( a1 a2 b1 b2 )
155 2swap ( b1 b2 a1 a2 )
156 R> R> ( b1 b2 a1 a2 c1 c2 )
160 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
161 2swap ( a1 a2 c1 c2 b1 b2 )
162 >R >R ( a1 a2 c1 c2 )
163 2swap ( c1 c2 a1 a2 )
167 : 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
173 \ ---- Pre-defined symbols ---- {{{
177 : duplicate-charlist ( charlist -- copy )
179 2dup car 2swap cdr recurse cons
182 : charlist-equiv ( charlist charlist -- bool )
191 2drop 2drop true exit
193 2drop 2drop false exit
198 2drop 2drop false exit
205 car drop -rot car drop = if
206 cdr 2swap cdr recurse
212 : charlist>symbol ( charlist -- symbol-obj )
231 drop symbol-type 2dup
232 symbol-table obj@ cons
237 : cstr>charlist ( addr n -- charlist )
241 2dup drop @ character-type 2swap
249 : create-symbol ( -- )
257 does> dup @ swap 1+ @
260 create-symbol quote quote-symbol
261 create-symbol quasiquote quasiquote-symbol
262 create-symbol unquote unquote-symbol
263 create-symbol unquote-splicing unquote-splicing-symbol
264 create-symbol define define-symbol
265 create-symbol define-macro define-macro-symbol
266 create-symbol set! set!-symbol
267 create-symbol ok ok-symbol
268 create-symbol if if-symbol
269 create-symbol lambda lambda-symbol
270 create-symbol λ λ-symbol
271 create-symbol eof eof-symbol
272 create-symbol no-match no-match-symbol
274 \ Symbol to be bound to welcome message procedure by library
275 create-symbol welcome welcome-symbol
279 \ ---- Port I/O ---- {{{
281 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
283 : fileport>fid ( fileport -- fid )
284 drop pair-type car drop ;
286 : get-last-peek ( fileport -- char/nil )
289 : set-last-peek ( char/nil fileport -- )
290 drop pair-type set-cdr!
293 : fid>fileport ( fid -- fileport )
294 fixnum-type nil cons drop port-type ;
296 : open-input-file ( addr n -- fileport )
297 r/o open-file drop fid>fileport
300 : close-port ( fileport -- )
301 fileport>fid close-file drop
304 objvar console-i/o-port
305 0 fixnum-type nil cons drop port-type console-i/o-port obj!
307 objvar current-input-port
308 console-i/o-port obj@ current-input-port obj!
310 : read-char ( port -- char )
311 2dup get-last-peek nil? if
313 2dup console-i/o-port obj@ objeq? if
317 fileport>fid pad 1 rot read-file 0= if
328 : peek-char ( port -- char )
329 2dup get-last-peek nil? if
331 2dup 2rot set-last-peek
337 variable read-line-buffer-span
338 variable read-line-buffer-offset
340 ( Hack to save original read-line while we transition to new one. )
341 : orig-read-line immediate
344 : read-line ( port -- string )
349 0 read-line-buffer-offset !
351 2over nil 2swap set-last-peek
353 2drop nil nil cons exit
356 1 read-line-buffer-offset !
360 2dup console-i/o-port obj@ objeq? if
362 pad read-line-buffer-offset @ + 200 expect cr
363 span @ read-line-buffer-offset @ + read-line-buffer-span !
365 pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
366 drop swap read-line-buffer-offset @ + read-line-buffer-span !
372 read-line-buffer-span @ 0>
374 pad read-line-buffer-span @ 1- + @ character-type 2swap cons
375 -1 read-line-buffer-span +!
379 nil cons drop string-type
385 : read-port ( fileport -- obj )
386 current-input-port obj!
389 : read-console ( -- obj )
390 console-i/o-port obj@ read-port ;
394 \ ---- Environments ---- {{{
396 : enclosing-env ( env -- env )
399 : first-frame ( env -- frame )
402 : make-frame ( vars vals -- frame )
405 : frame-vars ( frame -- vars )
408 : frame-vals ( frame -- vals )
411 : add-binding ( var val frame -- )
412 2swap 2over frame-vals cons
414 2swap 2over frame-vars cons
418 : extend-env ( vars vals env -- env )
428 : get-vars-vals-frame ( var frame -- bool )
429 2dup frame-vars vars obj!
433 vars obj@ nil objeq? false =
435 2dup vars obj@ car objeq? if
440 vars obj@ cdr vars obj!
441 vals obj@ cdr vals obj!
447 : get-vars-vals ( var env -- vars? vals? bool )
452 2over 2over first-frame
453 get-vars-vals-frame if
455 vars obj@ vals obj@ true
471 : lookup-var ( var env -- val )
476 except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception throw
480 : set-var ( var val env -- )
481 >R >R 2swap R> R> ( val var env )
484 2swap 2drop ( val vals )
487 except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw
495 : define-var ( var val env -- )
498 2over env obj@ ( var val var env )
500 2swap 2drop ( var val vals )
505 first-frame ( var val frame )
512 : make-procedure ( params body env -- proc )
515 drop compound-proc-type
519 nil nil nil extend-env
524 \ ---- Primitives ---- {{{
526 : make-primitive ( cfa -- )
533 rot primitive-proc-type ( var prim )
534 global-env obj@ define-var
537 : ensure-arg-count ( args n -- )
539 drop nil objeq? false = if
540 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
544 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
551 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
553 drop nil objeq? false = if
554 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
558 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
561 2dup cdr 2swap car ( ... t1 n args' arg1 )
562 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
564 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
572 : push-args-to-stack ( args -- arg1 arg2 ... argn )
582 : add-fa-checks ( cfa n -- cfa' )
583 here current @ 1+ dup @ , !
587 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
588 ['] push-args-to-stack ,
589 ['] lit , , ['] execute ,
593 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
594 here current @ 1+ dup @ , !
601 dup ( cfa t1 t2 ... tn n m )
606 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
612 ['] lit , , ['] ensure-arg-type-and-count ,
614 ['] push-args-to-stack ,
615 ['] lit , , ['] execute ,
621 : make-fa-primitive ( cfa n -- )
622 add-fa-checks make-primitive ;
624 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
625 add-fa-type-checks make-primitive ;
628 bold fg red ." Incorrect argument type." reset-term cr
632 : ensure-arg-type ( arg type -- arg )
634 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
641 \ ---- Macros ---- {{{
645 ( Look up macro in macro table. Returns nil if
647 : lookup-macro ( name_symbol -- proc )
649 symbol-type istype? invert if
650 \ Early exit if argument is not a symbol
672 : make-macro ( name_symbol params body env -- )
675 2swap ( proc name_symbol )
682 2over 2over ( proc name table name table )
684 2swap 2drop ( proc table )
696 macro-table obj@ cons
705 variable stored-parse-idx
706 create parse-str 161 allot
707 variable parse-str-span
709 create parse-idx-stack 10 allot
710 variable parse-idx-sp
711 parse-idx-stack parse-idx-sp !
714 parse-idx @ parse-idx-sp @ !
719 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
723 parse-idx-sp @ @ parse-idx ! ;
727 '\n' parse-str parse-str-span @ + !
728 1 parse-str-span +! ;
731 4 parse-str parse-str-span @ + !
732 1 parse-str-span +! ;
739 current-input-port obj@ console-i/o-port obj@ objeq? if
740 parse-str 160 expect cr
741 span @ parse-str-span !
743 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
744 drop swap parse-str-span !
746 parse-str-span @ 0= and if append-eof then
757 : charavailable? ( -- bool )
758 parse-str-span @ parse-idx @ > ;
760 : nextchar ( -- char )
761 charavailable? false = if getline then
762 parse-str parse-idx @ + @ ;
765 : whitespace? ( -- bool )
777 nextchar [char] ( = or
778 nextchar [char] ) = or
781 : commentstart? ( -- bool )
782 nextchar [char] ; = ;
786 false \ Indicates whether or not we're eating a comment
789 dup whitespace? or commentstart? or
791 dup nextchar '\n' = and if
792 invert \ Stop eating comment
794 dup false = commentstart? and if
795 invert \ Begin eating comment
810 nextchar [char] - = ;
813 nextchar [char] + = ;
815 : fixnum? ( -- bool )
841 : flonum? ( -- bool )
848 \ Record starting parse idx:
849 \ Want to detect whether any characters (following +/-) were eaten.
856 [char] . nextchar = if
863 [char] e nextchar = [char] E nextchar = or if
871 drop pop-parse-idx false exit
879 \ This is a real number if characters were
880 \ eaten and the next characer is a delimiter.
881 parse-idx @ < delim? and
886 : ratnum? ( -- bool )
894 pop-parse-idx false exit
903 [char] / nextchar <> if
904 pop-parse-idx false exit
910 pop-parse-idx false exit
922 : boolean? ( -- bool )
923 nextchar [char] # <> if false exit then
930 and if pop-parse-idx false exit then
942 : str-equiv? ( str -- bool )
959 delim? false = if drop false then
964 : character? ( -- bool )
965 nextchar [char] # <> if false exit then
970 nextchar [char] \ <> if pop-parse-idx false exit then
974 S" newline" str-equiv? if pop-parse-idx true exit then
975 S" space" str-equiv? if pop-parse-idx true exit then
976 S" tab" str-equiv? if pop-parse-idx true exit then
978 charavailable? false = if pop-parse-idx false exit then
984 nextchar [char] ( = ;
986 : string? ( -- bool )
987 nextchar [char] " = ;
989 : readfixnum ( -- fixnum )
1000 10 * nextchar [char] 0 - +
1009 : readflonum ( -- flonum )
1011 dup 0< swap abs i->f
1013 [char] . nextchar = if
1019 nextchar [char] 0 - i->f ( f exp d )
1020 over f/ rot f+ ( exp f' )
1021 swap 10.0 f* ( f' exp' )
1028 [char] e nextchar = [char] E nextchar = or if
1031 readfixnum drop i->f
1042 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1049 fixnum-type swap fixnum-type
1050 cons drop ratnum-type
1054 : readratnum ( -- ratnum )
1055 readfixnum inc-parse-idx readfixnum
1059 : readbool ( -- bool-obj )
1062 nextchar [char] f = if
1073 : readchar ( -- char-obj )
1077 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1078 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1079 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1081 nextchar character-type
1086 : readstring ( -- charlist )
1091 nextchar [char] " <>
1093 nextchar [char] \ = if
1096 [char] n of '\n' endof
1097 [char] " of [char] " endof
1103 inc-parse-idx character-type
1106 ( firstchar prevchar thischar )
1109 2drop 2swap 2drop 2dup ( thischar thischar )
1111 ( firstchar thischar prevchar )
1112 2over 2swap set-cdr! ( firstchar thischar )
1116 \ Discard previous character
1122 ." No delimiter following right double quote. Aborting." cr
1134 : readsymbol ( -- charlist )
1135 delim? if nil exit then
1137 nextchar inc-parse-idx character-type
1144 : readpair ( -- pairobj )
1148 nextchar [char] ) = if
1153 ." No delimiter following right paren. Aborting." cr
1162 \ Read first pair element
1167 nextchar [char] . = if
1172 ." No delimiter following '.'. Aborting." cr
1186 \ Parse a scheme expression
1221 nextchar [char] " <> if
1222 bold red ." Missing closing double-quote." reset-term cr
1240 nextchar [char] ) <> if
1241 bold red ." Missing closing paren." reset-term cr
1250 nextchar [char] ' = if
1252 quote-symbol recurse nil cons cons exit
1255 nextchar [char] ` = if
1257 quasiquote-symbol recurse nil cons cons exit
1260 nextchar [char] , = if
1262 nextchar [char] @ = if
1264 unquote-splicing-symbol recurse nil cons cons exit
1266 unquote-symbol recurse nil cons cons exit
1276 \ Anything else is parsed as a symbol
1277 readsymbol charlist>symbol
1279 \ Replace λ with lambda
1280 2dup λ-symbol objeq? if
1289 \ ---- Eval ---- {{{
1291 : self-evaluating? ( obj -- obj bool )
1292 boolean-type istype? if true exit then
1293 fixnum-type istype? if true exit then
1294 flonum-type istype? if true exit then
1295 ratnum-type istype? if true exit then
1296 character-type istype? if true exit then
1297 string-type istype? if true exit then
1298 nil-type istype? if true exit then
1299 none-type istype? if true exit then
1304 : tagged-list? ( obj tag-obj -- obj bool )
1306 pair-type istype? false = if
1312 : quote? ( obj -- obj bool )
1313 quote-symbol tagged-list? ;
1315 : quote-body ( quote-obj -- quote-body-obj )
1318 : quasiquote? ( obj -- obj bool )
1319 quasiquote-symbol tagged-list? ;
1321 : unquote? ( obj -- obj bool )
1322 unquote-symbol tagged-list? ;
1324 : unquote-splicing? ( obj -- obj bool )
1325 unquote-splicing-symbol tagged-list? ;
1327 : eval-unquote ( env obj -- res )
1331 except-message: ." no arguments to unquote." recoverable-exception throw
1336 except-message: ." too many arguments to unquote." recoverable-exception throw
1339 2drop car 2swap eval
1342 ( Create a new list from elements of l1 consed on to l2 )
1343 : join-lists ( l2 l1 -- l3 )
1344 nil? if 2drop exit then
1351 defer eval-quasiquote-item
1352 : eval-quasiquote-pair ( env obj -- res )
1353 2over 2over ( env obj env obj )
1355 cdr eval-quasiquote-item
1357 -2rot car ( cdritem env objcar )
1359 unquote-splicing? if
1360 eval-unquote ( cdritems caritem )
1368 eval-quasiquote-item ( cdritems caritem )
1383 pair-type istype? if
1384 eval-quasiquote-pair exit
1388 ; is eval-quasiquote-item
1390 : eval-quasiquote ( obj env -- res )
1391 2swap cdr ( env args )
1394 except-message: ." no arguments to quasiquote." recoverable-exception throw
1397 2dup cdr ( env args args-cdr )
1399 except-message: ." too many arguments to quasiquote." recoverable-exception throw
1402 2drop car ( env arg )
1404 eval-quasiquote-item
1407 : variable? ( obj -- obj bool )
1408 symbol-type istype? ;
1410 : definition? ( obj -- obj bool )
1411 define-symbol tagged-list? ;
1413 : definition-var ( obj -- var )
1416 : definition-val ( obj -- val )
1419 : eval-definition ( obj env -- res )
1422 definition-val 2swap
1425 2swap definition-var 2swap
1433 : assignment? ( obj -- obj bool )
1434 set!-symbol tagged-list? ;
1436 : assignment-var ( obj -- var )
1439 : assignment-val ( obj -- val )
1442 : eval-assignment ( obj env -- res )
1444 2over 2over ( env obj env obj )
1445 assignment-val 2swap ( env obj valexp env )
1446 eval ( env obj val )
1448 2swap assignment-var 2swap ( env var val )
1450 2rot ( var val env )
1456 : macro-definition? ( obj -- obj bool )
1457 define-macro-symbol tagged-list? ;
1459 : macro-definition-name ( exp -- mname )
1462 : macro-definition-params ( exp -- params )
1465 : macro-definition-body ( exp -- body )
1469 : eval-define-macro ( obj env -- res )
1472 2dup macro-definition-name 2swap ( name obj )
1473 2dup macro-definition-params 2swap ( name params obj )
1474 macro-definition-body ( name params body )
1476 env obj@ ( name params body env )
1484 : if? ( obj -- obj bool )
1485 if-symbol tagged-list? ;
1487 : if-predicate ( ifobj -- pred )
1490 : if-consequent ( ifobj -- conseq )
1493 : if-alternative ( ifobj -- alt|none )
1501 : false? ( boolobj -- boolean )
1502 boolean-type istype? if
1503 false boolean-type objeq?
1509 : true? ( boolobj -- bool )
1512 : lambda? ( obj -- obj bool )
1513 lambda-symbol tagged-list? ;
1515 : lambda-parameters ( obj -- params )
1518 : lambda-body ( obj -- body )
1521 : eval-sequence ( explist env -- finalexp env )
1522 ( Evaluates all bar the final expressions in
1523 an an expression list. The final expression
1524 is returned to allow for tail optimization. )
1526 2swap ( env explist )
1528 \ Abort on empty list
1535 2dup cdr ( env explist nextexplist )
1538 -2rot car 2over ( nextexplist env exp env )
1540 2drop \ discard result
1541 2swap ( env nextexplist )
1544 2drop car 2swap ( finalexp env )
1547 : application? ( obj -- obj bool )
1550 : operator ( obj -- operator )
1553 : operands ( obj -- operands )
1556 : nooperands? ( operands -- bool )
1559 : first-operand ( operands -- operand )
1562 : rest-operands ( operands -- other-operands )
1565 : list-of-vals ( args env -- vals )
1571 2over 2over first-operand 2swap eval
1572 -2rot rest-operands 2swap recurse
1577 : procedure-params ( proc -- params )
1578 drop pair-type car ;
1580 : procedure-body ( proc -- body )
1581 drop pair-type cdr car ;
1583 : procedure-env ( proc -- body )
1584 drop pair-type cdr cdr car ;
1586 ( Ensure terminating symbol arg name is handled
1587 specially to allow for variadic procedures. )
1588 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1590 2over nil? false = if
1591 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1598 symbol-type istype? if
1608 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1615 recurse ( argvals argnames argvals'' argnames'' )
1616 2rot car 2swap cons ( argvals argvals'' argnames' )
1617 2rot car 2rot cons ( argnames' argvals' )
1621 : apply ( proc argvals -- result )
1623 primitive-proc-type of
1627 compound-proc-type of
1628 2dup procedure-body ( argvals proc body )
1629 -2rot 2dup procedure-params ( body argvals proc argnames )
1630 -2rot procedure-env ( body argnames argvals procenv )
1636 extend-env ( body env )
1640 R> drop ['] eval goto-deferred \ Tail call optimization
1643 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1647 :noname ( obj env -- result )
1652 fg yellow ." Evaluating: " bold 2dup print reset-term
1653 space fg green ." PS: " bold depth . reset-term
1654 space fg blue ." RS: " bold RSP@ RSP0 - . reset-term cr
1669 2swap eval-quasiquote
1679 2swap eval-definition
1684 2swap eval-assignment
1688 macro-definition? if
1689 2swap eval-define-macro
1705 ['] eval goto-deferred
1709 2dup lambda-parameters
1717 2over 2over ( env exp env exp )
1718 operator ( env exp env opname )
1720 2swap eval ( env exp proc )
1722 -2rot ( proc env exp )
1723 operands 2swap ( proc operands env )
1724 list-of-vals ( proc argvals )
1730 except-message: ." tried to evaluate object with unknown type." recoverable-exception throw
1737 : evaluate-eproc ( eproc env --- res )
1748 2drop \ get rid of null
1752 \ Final element of eproc list is primitive procedure
1753 drop \ dump type signifier
1754 goto \ jump straight to primitive procedure (executor)
1757 : self-evaluating-executor ( exp env -- exp )
1760 : analyze-self-evaluating ( exp --- eproc )
1761 ['] self-evaluating-executor primitive-proc-type
1765 : quote-executor ( exp env -- exp )
1768 : analyze-quoted ( exp -- eproc )
1771 ['] quote-executor primitive-proc-type
1775 : variable-executor ( var env -- val )
1778 : analyze-variable ( exp -- eproc )
1779 ['] variable-executor primitive-proc-type
1783 : definition-executor ( var val-eproc env -- ok )
1784 2swap 2over ( var env val-eproc env )
1785 evaluate-eproc 2swap ( var val env )
1790 : analyze-definition ( exp -- eproc )
1792 2swap definition-val analyze
1794 ['] definition-executor primitive-proc-type
1798 : assignment-executor ( var val-eproc env -- ok )
1799 2swap 2over ( var env val-eproc env )
1800 evaluate-eproc 2swap ( var val env )
1805 : analyze-assignment ( exp -- eproc )
1807 2swap assignment-val analyze ( var val-eproc )
1809 ['] assignment-executor primitive-proc-type
1813 : if-executor ( cproc aproc pproc env -- res )
1814 2swap 2over ( cproc aproc env pproc env -- res )
1826 : analyze-if ( exp -- eproc )
1827 2dup if-predicate analyze
1828 2swap 2dup if-consequent analyze
1829 2swap if-alternative analyze
1831 ['] if-executor primitive-proc-type
1832 nil cons cons cons cons
1835 : sequence-executor ( eproc-list env -- res )
1839 2dup cdr ( env elist elist-rest)
1843 -2rot car 2over ( elist-rest env elist-head env )
1844 evaluate-eproc ( elist-rest env head-res )
1845 2drop 2swap ( env elist-rest )
1849 ['] evaluate-eproc goto
1853 : (analyze-sequence) ( explist -- eproc-list )
1862 : analyze-sequence ( explist -- eproc )
1864 ['] sequence-executor primitive-proc-type
1868 : lambda-executor ( params bproc env -- res )
1870 ( Although this is packaged up as a regular compound procedure,
1871 the "body" element contains an _eproc_ to be evaluated in an
1872 environment resulting from extending env with the parameter
1876 : analyze-lambda ( exp -- eproc )
1877 2dup lambda-parameters
1881 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1886 ['] lambda-executor primitive-proc-type
1890 : operand-eproc-list ( operands -- eprocs )
1898 : evaluate-operand-eprocs ( env aprocs -- vals )
1900 2over 2over car evaluate-eproc ( env aprocs thisres )
1904 : application-executor ( operator-proc arg-procs env -- res )
1905 2rot 2over ( aprocs env fproc env )
1906 evaluate-eproc ( aprocs env proc )
1907 2swap -2rot 2over 2swap ( proc env env aprocs )
1908 evaluate-operand-eprocs ( proc env vals )
1910 2rot ( env vals proc )
1913 primitive-proc-type of
1917 compound-proc-type of
1918 2dup procedure-body ( argvals proc body )
1919 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1920 -2rot procedure-env ( bproc argnames argvals procenv )
1926 extend-env ( bproc env )
1928 ['] evaluate-eproc goto
1931 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1935 : analyze-application ( exp -- eproc )
1936 2dup operator analyze
1937 2swap operands operand-eproc-list
1939 ['] application-executor
1943 :noname ( exp --- eproc )
1946 analyze-self-evaluating
1983 \ ---- Macro Expansion ---- {{{
1985 ( Simply evaluates the given procedure with expbody as its argument. )
1986 : macro-eval ( proc expbody -- result )
1988 2dup procedure-body ( expbody proc procbody )
1989 -2rot 2dup procedure-params ( procbody expbody proc argnames )
1990 -2rot procedure-env ( procbody argnames expbody procenv )
1996 extend-env eval-sequence eval
1999 : expand-macro ( exp -- result )
2000 pair-type istype? invert if exit then
2001 2dup car symbol-type istype? invert if 2drop exit then
2003 lookup-macro nil? if
2006 2over cdr macro-eval
2008 2dup no-match-symbol objeq? if
2014 R> drop ['] expand goto-deferred
2017 : expand-quasiquote-item ( exp -- result )
2021 unquote-symbol 2swap cdr car expand nil cons cons
2025 unquote-splicing? if
2026 unquote-splicing-symbol 2swap cdr car expand nil cons cons
2030 pair-type istype? if
2037 : expand-quasiquote ( exp -- result )
2038 quasiquote-symbol 2swap cdr
2040 expand-quasiquote-item
2044 : expand-definition ( exp -- result )
2048 2swap definition-val expand
2049 nil ( define var val' nil )
2053 : expand-assignment ( exp -- result )
2057 2swap assignment-val expand
2058 nil ( define var val' nil )
2062 : expand-list ( exp -- res )
2070 : macro-definition-nameparams
2073 : expand-define-macro ( exp -- res )
2074 define-macro-symbol 2swap
2075 2dup macro-definition-nameparams
2076 2swap macro-definition-body expand-list
2080 : expand-lambda ( exp -- res )
2082 2dup lambda-parameters
2083 2swap lambda-body expand-list
2087 : expand-if ( exp -- res )
2090 2dup if-predicate expand
2091 2swap 2dup if-consequent expand
2092 2swap if-alternative none? if
2100 : expand-application ( exp -- res )
2101 2dup operator expand
2102 2swap operands expand-list
2106 :noname ( exp -- result )
2109 self-evaluating? if exit then
2113 quasiquote? if expand-quasiquote exit then
2115 definition? if expand-definition exit then
2117 assignment? if expand-assignment exit then
2119 macro-definition? if expand-define-macro exit then
2121 lambda? if expand-lambda exit then
2123 if? if expand-if exit then
2125 application? if expand-application exit then
2131 \ ---- Print ---- {{{
2133 : printfixnum ( fixnum -- ) drop 0 .R ;
2135 : printflonum ( flonum -- ) drop f. ;
2137 : printratnum ( ratnum -- )
2139 car print ." /" cdr print
2142 : printbool ( bool -- )
2150 : printchar ( charobj -- )
2153 9 of ." #\tab" endof
2154 bl of ." #\space" endof
2155 '\n' of ." #\newline" endof
2161 : (printstring) ( stringobj -- )
2162 nil? if 2drop exit then
2166 '\n' of ." \n" drop endof
2167 [char] \ of ." \\" drop endof
2168 [char] " of [char] \ emit [char] " emit drop endof
2174 : printstring ( stringobj -- )
2179 : printsymbol ( symbolobj -- )
2180 nil-type istype? if 2drop exit then
2186 : printnil ( nilobj -- )
2189 : printpair ( pairobj -- )
2193 nil-type istype? if 2drop exit then
2194 pair-type istype? if space recurse exit then
2198 : printprim ( primobj -- )
2199 2drop ." <primitive procedure>" ;
2201 : printcomp ( primobj -- )
2202 2drop ." <compound procedure>" ;
2204 : printnone ( noneobj -- )
2205 2drop ." Unspecified return value" ;
2207 : printport ( port -- )
2211 fixnum-type istype? if printfixnum exit then
2212 flonum-type istype? if printflonum exit then
2213 ratnum-type istype? if printratnum exit then
2214 boolean-type istype? if printbool exit then
2215 character-type istype? if printchar exit then
2216 string-type istype? if printstring exit then
2217 symbol-type istype? if printsymbol exit then
2218 nil-type istype? if printnil exit then
2219 pair-type istype? if ." (" printpair ." )" exit then
2220 primitive-proc-type istype? if printprim exit then
2221 compound-proc-type istype? if printcomp exit then
2222 none-type istype? if printnone exit then
2223 port-type istype? if printport exit then
2225 except-message: ." tried to print object with unknown type." recoverable-exception throw
2230 \ ---- Garbage Collection ---- {{{
2235 variable gc-stack-depth
2238 depth gc-stack-depth !
2242 false gc-enabled ! ;
2247 : pairlike? ( obj -- obj bool )
2248 pair-type istype? if true exit then
2249 string-type istype? if true exit then
2250 symbol-type istype? if true exit then
2251 compound-proc-type istype? if true exit then
2252 port-type istype? if true exit then
2257 : pairlike-marked? ( obj -- obj bool )
2258 over nextfrees + @ 0=
2261 : mark-pairlike ( obj -- obj )
2262 over nextfrees + 0 swap !
2271 : gc-mark-obj ( obj -- )
2273 pairlike? invert if 2drop exit then
2274 pairlike-marked? if 2drop exit then
2285 scheme-memsize nextfree !
2286 0 scheme-memsize 1- do
2287 nextfrees i + @ 0<> if
2288 nextfree @ nextfrees i + !
2294 \ Following a GC, this gives the amount of free memory
2298 nextfrees i + @ 0= if 1+ then
2302 \ Debugging word - helps spot memory that is retained
2305 nextfrees i + @ 0<> if
2317 symbol-table obj@ gc-mark-obj
2318 macro-table obj@ gc-mark-obj
2319 console-i/o-port obj@ gc-mark-obj
2320 global-env obj@ gc-mark-obj
2322 depth gc-stack-depth @ do
2331 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2332 ; is collect-garbage
2336 \ ---- Loading files ---- {{{
2338 : load ( addr n -- finalResult )
2343 ok-symbol ( port res )
2346 2over read-port ( port res obj )
2348 2dup EOF character-type objeq? if
2349 2drop 2swap close-port
2353 2swap 2drop ( port obj )
2357 global-env obj@ eval ( port res )
2363 \ ---- Standard Library ---- {{{
2365 include scheme-primitives.4th
2367 \ s" scheme-library.scm" load 2drop
2373 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2374 : repl-body ( -- bool )
2375 cr bold fg green ." > " reset-term
2379 2dup EOF character-type objeq? if
2381 bold fg blue ." Moriturus te saluto." reset-term cr
2387 global-env obj@ eval
2389 fg cyan ." ; " print reset-term
2399 \ Display welcome message
2400 \ welcome-symbol nil cons global-env obj@ eval 2drop
2405 recoverable-exception of false endof
2406 unrecoverable-exception of true endof