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 cr 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
84 create nextfrees scheme-memsize allot
95 nextfrees nextfree @ + @
98 nextfree @ scheme-memsize >= if
104 nextfree @ scheme-memsize >= if
105 except-message: ." Out of memory!" unrecoverable-exception throw
109 : cons ( car-obj cdr-obj -- pair-obj )
110 cdr-type-cells nextfree @ + !
111 cdr-cells nextfree @ + !
112 car-type-cells nextfree @ + !
113 car-cells nextfree @ + !
119 : car ( pair-obj -- car-obj )
121 dup car-cells + @ swap
125 : cdr ( pair-obj -- car-obj )
127 dup cdr-cells + @ swap
131 : set-car! ( obj pair-obj -- )
133 rot swap car-type-cells + !
137 : set-cdr! ( obj pair-obj -- )
139 rot swap cdr-type-cells + !
144 : nil? nil-type istype? ;
147 : none? none-type istype? ;
149 : objvar create nil swap , , ;
151 : value@ ( objvar -- val ) @ ;
152 : type@ ( objvar -- type ) 1+ @ ;
153 : value! ( newval objvar -- ) ! ;
154 : type! ( newtype objvar -- ) 1+ ! ;
155 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
156 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
158 : objeq? ( obj obj -- bool )
161 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
162 >R >R ( a1 a2 b1 b2 )
163 2swap ( b1 b2 a1 a2 )
164 R> R> ( b1 b2 a1 a2 c1 c2 )
168 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
169 2swap ( a1 a2 c1 c2 b1 b2 )
170 >R >R ( a1 a2 c1 c2 )
171 2swap ( c1 c2 a1 a2 )
175 : 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
181 \ ---- Pre-defined symbols ---- {{{
185 : duplicate-charlist ( charlist -- copy )
187 2dup car 2swap cdr recurse cons
190 : charlist-equiv ( charlist charlist -- bool )
199 2drop 2drop true exit
201 2drop 2drop false exit
206 2drop 2drop false exit
213 car drop -rot car drop = if
214 cdr 2swap cdr recurse
220 : charlist>symbol ( charlist -- symbol-obj )
239 drop symbol-type 2dup
240 symbol-table obj@ cons
245 : cstr>charlist ( addr n -- charlist )
249 2dup drop @ character-type 2swap
257 : create-symbol ( -- )
265 does> dup @ swap 1+ @
268 create-symbol quote quote-symbol
269 create-symbol quasiquote quasiquote-symbol
270 create-symbol unquote unquote-symbol
271 create-symbol unquote-splicing unquote-splicing-symbol
272 create-symbol define define-symbol
273 create-symbol define-macro define-macro-symbol
274 create-symbol set! set!-symbol
275 create-symbol ok ok-symbol
276 create-symbol if if-symbol
277 create-symbol lambda lambda-symbol
278 create-symbol λ λ-symbol
279 create-symbol eof eof-symbol
280 create-symbol no-match no-match-symbol
282 \ Symbol to be bound to welcome message procedure by library
283 create-symbol welcome welcome-symbol
287 \ ---- Port I/O ---- {{{
289 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
291 : fileport>fid ( fileport -- fid )
292 drop pair-type car drop ;
294 : get-last-peek ( fileport -- char/nil )
297 : set-last-peek ( char/nil fileport -- )
298 drop pair-type set-cdr!
301 : fid>fileport ( fid -- fileport )
302 fixnum-type nil cons drop port-type ;
304 : open-input-file ( addr n -- fileport )
305 r/o open-file drop fid>fileport
308 : close-port ( fileport -- )
309 fileport>fid close-file drop
312 objvar console-i/o-port
313 0 fixnum-type nil cons drop port-type console-i/o-port obj!
315 objvar current-input-port
316 console-i/o-port obj@ current-input-port obj!
318 : read-char ( port -- char )
319 2dup get-last-peek nil? if
321 2dup console-i/o-port obj@ objeq? if
325 fileport>fid pad 1 rot read-file 0= if
336 : peek-char ( port -- char )
337 2dup get-last-peek nil? if
339 2dup 2rot set-last-peek
345 variable read-line-buffer-span
346 variable read-line-buffer-offset
348 ( Hack to save original read-line while we transition to new one. )
349 : orig-read-line immediate
352 : read-line ( port -- string )
357 0 read-line-buffer-offset !
359 2over nil 2swap set-last-peek
361 2drop nil nil cons exit
364 1 read-line-buffer-offset !
368 2dup console-i/o-port obj@ objeq? if
370 pad read-line-buffer-offset @ + 200 expect cr
371 span @ read-line-buffer-offset @ + read-line-buffer-span !
373 pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
374 drop swap read-line-buffer-offset @ + read-line-buffer-span !
380 read-line-buffer-span @ 0>
382 pad read-line-buffer-span @ 1- + @ character-type 2swap cons
383 -1 read-line-buffer-span +!
387 nil cons drop string-type
393 : read-port ( fileport -- obj )
394 current-input-port obj!
397 : read-console ( -- obj )
398 console-i/o-port obj@ read-port ;
402 \ ---- Environments ---- {{{
404 : enclosing-env ( env -- env )
407 : first-frame ( env -- frame )
410 : make-frame ( vars vals -- frame )
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 )
436 : get-vars-vals-frame ( var frame -- bool )
437 2dup frame-vars vars obj!
441 vars obj@ nil objeq? false =
443 2dup vars obj@ car objeq? if
448 vars obj@ cdr vars obj!
449 vals obj@ cdr vals obj!
455 : get-vars-vals ( var env -- vars? vals? bool )
460 2over 2over first-frame
461 get-vars-vals-frame if
463 vars obj@ vals obj@ true
479 : lookup-var ( var env -- val )
484 except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception throw
488 : set-var ( var val env -- )
489 >R >R 2swap R> R> ( val var env )
492 2swap 2drop ( val vals )
495 except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw
503 : define-var ( var val env -- )
506 2over env obj@ ( var val var env )
508 2swap 2drop ( var val vals )
513 first-frame ( var val frame )
520 : make-procedure ( params body env -- proc )
523 drop compound-proc-type
527 nil nil nil extend-env
532 \ ---- Primitives ---- {{{
534 : make-primitive ( cfa -- )
541 rot primitive-proc-type ( var prim )
542 global-env obj@ define-var
545 : ensure-arg-count ( args n -- )
547 drop nil objeq? false = if
548 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
552 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
559 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
561 drop nil objeq? false = if
562 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
566 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
569 2dup cdr 2swap car ( ... t1 n args' arg1 )
570 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
572 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
580 : push-args-to-stack ( args -- arg1 arg2 ... argn )
590 : add-fa-checks ( cfa n -- cfa' )
591 here current @ 1+ dup @ , !
595 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
596 ['] push-args-to-stack ,
597 ['] lit , , ['] execute ,
601 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
602 here current @ 1+ dup @ , !
609 dup ( cfa t1 t2 ... tn n m )
614 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
620 ['] lit , , ['] ensure-arg-type-and-count ,
622 ['] push-args-to-stack ,
623 ['] lit , , ['] execute ,
629 : make-fa-primitive ( cfa n -- )
630 add-fa-checks make-primitive ;
632 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
633 add-fa-type-checks make-primitive ;
636 bold fg red ." Incorrect argument type." reset-term cr
640 : ensure-arg-type ( arg type -- arg )
642 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
649 \ ---- Macros ---- {{{
653 ( Look up macro in macro table. Returns nil if
655 : lookup-macro ( name_symbol -- proc )
657 symbol-type istype? invert if
658 \ Early exit if argument is not a symbol
680 : make-macro ( name_symbol params body env -- )
683 2swap ( proc name_symbol )
690 2over 2over ( proc name table name table )
692 2swap 2drop ( proc table )
704 macro-table obj@ cons
713 variable stored-parse-idx
714 create parse-str 161 allot
715 variable parse-str-span
717 create parse-idx-stack 10 allot
718 variable parse-idx-sp
719 parse-idx-stack parse-idx-sp !
722 parse-idx @ parse-idx-sp @ !
727 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
731 parse-idx-sp @ @ parse-idx ! ;
735 '\n' parse-str parse-str-span @ + !
736 1 parse-str-span +! ;
739 4 parse-str parse-str-span @ + !
740 1 parse-str-span +! ;
747 current-input-port obj@ console-i/o-port obj@ objeq? if
748 parse-str 160 expect cr
749 span @ parse-str-span !
751 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
752 drop swap parse-str-span !
754 parse-str-span @ 0= and if append-eof then
765 : charavailable? ( -- bool )
766 parse-str-span @ parse-idx @ > ;
768 : nextchar ( -- char )
769 charavailable? false = if getline then
770 parse-str parse-idx @ + @ ;
773 : whitespace? ( -- bool )
785 nextchar [char] ( = or
786 nextchar [char] ) = or
789 : commentstart? ( -- bool )
790 nextchar [char] ; = ;
794 false \ Indicates whether or not we're eating a comment
797 dup whitespace? or commentstart? or
799 dup nextchar '\n' = and if
800 invert \ Stop eating comment
802 dup false = commentstart? and if
803 invert \ Begin eating comment
818 nextchar [char] - = ;
821 nextchar [char] + = ;
823 : fixnum? ( -- bool )
849 : flonum? ( -- bool )
856 \ Record starting parse idx:
857 \ Want to detect whether any characters (following +/-) were eaten.
864 [char] . nextchar = if
871 [char] e nextchar = [char] E nextchar = or if
879 drop pop-parse-idx false exit
887 \ This is a real number if characters were
888 \ eaten and the next characer is a delimiter.
889 parse-idx @ < delim? and
894 : ratnum? ( -- bool )
902 pop-parse-idx false exit
911 [char] / nextchar <> if
912 pop-parse-idx false exit
918 pop-parse-idx false exit
930 : boolean? ( -- bool )
931 nextchar [char] # <> if false exit then
938 and if pop-parse-idx false exit then
950 : str-equiv? ( str -- bool )
967 delim? false = if drop false then
972 : character? ( -- bool )
973 nextchar [char] # <> if false exit then
978 nextchar [char] \ <> if pop-parse-idx false exit then
982 S" newline" str-equiv? if pop-parse-idx true exit then
983 S" space" str-equiv? if pop-parse-idx true exit then
984 S" tab" str-equiv? if pop-parse-idx true exit then
986 charavailable? false = if pop-parse-idx false exit then
992 nextchar [char] ( = ;
994 : string? ( -- bool )
995 nextchar [char] " = ;
997 : readfixnum ( -- fixnum )
1008 10 * nextchar [char] 0 - +
1017 : readflonum ( -- flonum )
1019 dup 0< swap abs i->f
1021 [char] . nextchar = if
1027 nextchar [char] 0 - i->f ( f exp d )
1028 over f/ rot f+ ( exp f' )
1029 swap 10.0 f* ( f' exp' )
1036 [char] e nextchar = [char] E nextchar = or if
1039 readfixnum drop i->f
1050 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1057 fixnum-type swap fixnum-type
1058 cons drop ratnum-type
1062 : readratnum ( -- ratnum )
1063 readfixnum inc-parse-idx readfixnum
1067 : readbool ( -- bool-obj )
1070 nextchar [char] f = if
1081 : readchar ( -- char-obj )
1085 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1086 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1087 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1089 nextchar character-type
1094 : readstring ( -- charlist )
1099 nextchar [char] " <>
1101 nextchar [char] \ = if
1104 [char] n of '\n' endof
1105 [char] " of [char] " endof
1111 inc-parse-idx character-type
1114 ( firstchar prevchar thischar )
1117 2drop 2swap 2drop 2dup ( thischar thischar )
1119 ( firstchar thischar prevchar )
1120 2over 2swap set-cdr! ( firstchar thischar )
1124 \ Discard previous character
1130 ." No delimiter following right double quote. Aborting." cr
1142 : readsymbol ( -- charlist )
1143 delim? if nil exit then
1145 nextchar inc-parse-idx character-type
1152 : readpair ( -- pairobj )
1156 nextchar [char] ) = if
1161 ." No delimiter following right paren. Aborting." cr
1170 \ Read first pair element
1175 nextchar [char] . = if
1180 ." No delimiter following '.'. Aborting." cr
1194 \ Parse a scheme expression
1229 nextchar [char] " <> if
1230 bold red ." Missing closing double-quote." reset-term cr
1248 nextchar [char] ) <> if
1249 bold red ." Missing closing paren." reset-term cr
1258 nextchar [char] ' = if
1260 quote-symbol recurse nil cons cons exit
1263 nextchar [char] ` = if
1265 quasiquote-symbol recurse nil cons cons exit
1268 nextchar [char] , = if
1270 nextchar [char] @ = if
1272 unquote-splicing-symbol recurse nil cons cons exit
1274 unquote-symbol recurse nil cons cons exit
1284 nextchar [char] ) = if
1286 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1289 \ Anything else is parsed as a symbol
1290 readsymbol charlist>symbol
1292 \ Replace λ with lambda
1293 2dup λ-symbol objeq? if
1302 \ ---- Syntax ---- {{{
1304 : self-evaluating? ( obj -- obj bool )
1305 boolean-type istype? if true exit then
1306 fixnum-type istype? if true exit then
1307 flonum-type istype? if true exit then
1308 ratnum-type istype? if true exit then
1309 character-type istype? if true exit then
1310 string-type istype? if true exit then
1311 nil-type istype? if true exit then
1312 none-type istype? if true exit then
1317 : tagged-list? ( obj tag-obj -- obj bool )
1319 pair-type istype? false = if
1325 : quote? ( obj -- obj bool )
1326 quote-symbol tagged-list? ;
1328 : quote-body ( quote-obj -- quote-body-obj )
1331 : variable? ( obj -- obj bool )
1332 symbol-type istype? ;
1334 : definition? ( obj -- obj bool )
1335 define-symbol tagged-list? ;
1337 : definition-var ( obj -- var )
1340 : definition-val ( obj -- val )
1343 : assignment? ( obj -- obj bool )
1344 set!-symbol tagged-list? ;
1346 : assignment-var ( obj -- var )
1349 : assignment-val ( obj -- val )
1352 : macro-definition? ( obj -- obj bool )
1353 define-macro-symbol tagged-list? ;
1355 : macro-definition-name ( exp -- mname )
1358 : macro-definition-params ( exp -- params )
1361 : macro-definition-body ( exp -- body )
1364 : if? ( obj -- obj bool )
1365 if-symbol tagged-list? ;
1367 : if-predicate ( ifobj -- pred )
1370 : if-consequent ( ifobj -- conseq )
1373 : if-alternative ( ifobj -- alt|none )
1381 : false? ( boolobj -- boolean )
1382 boolean-type istype? if
1383 false boolean-type objeq?
1389 : true? ( boolobj -- bool )
1392 : lambda? ( obj -- obj bool )
1393 lambda-symbol tagged-list? ;
1395 : lambda-parameters ( obj -- params )
1398 : lambda-body ( obj -- body )
1401 : application? ( obj -- obj bool )
1404 : operator ( obj -- operator )
1407 : operands ( obj -- operands )
1410 : nooperands? ( operands -- bool )
1413 : first-operand ( operands -- operand )
1416 : rest-operands ( operands -- other-operands )
1419 : procedure-params ( proc -- params )
1420 drop pair-type car ;
1422 : procedure-body ( proc -- body )
1423 drop pair-type cdr car ;
1425 : procedure-env ( proc -- body )
1426 drop pair-type cdr cdr car ;
1428 ( Ensure terminating symbol arg name is handled
1429 specially to allow for variadic procedures. )
1430 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1432 2over nil? false = if
1433 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1440 symbol-type istype? if
1450 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1457 recurse ( argvals argnames argvals'' argnames'' )
1458 2rot car 2swap cons ( argvals argvals'' argnames' )
1459 2rot car 2rot cons ( argnames' argvals' )
1465 \ ---- Analyze ---- {{{
1467 : evaluate-eproc ( eproc env --- res )
1478 2drop \ get rid of null
1482 \ Final element of eproc list is primitive procedure
1483 drop \ dump type signifier
1485 goto \ jump straight to primitive procedure (executor)
1488 : self-evaluating-executor ( exp env -- exp )
1491 : analyze-self-evaluating ( exp --- eproc )
1492 ['] self-evaluating-executor primitive-proc-type
1496 : quote-executor ( exp env -- exp )
1499 : analyze-quoted ( exp -- eproc )
1502 ['] quote-executor primitive-proc-type
1506 : variable-executor ( var env -- val )
1509 : analyze-variable ( exp -- eproc )
1510 ['] variable-executor primitive-proc-type
1514 : definition-executor ( var val-eproc env -- ok )
1515 2swap 2over ( var env val-eproc env )
1516 evaluate-eproc 2swap ( var val env )
1521 : analyze-definition ( exp -- eproc )
1523 2swap definition-val analyze
1525 ['] definition-executor primitive-proc-type
1529 : assignment-executor ( var val-eproc env -- ok )
1530 2swap 2over ( var env val-eproc env )
1531 evaluate-eproc 2swap ( var val env )
1536 : analyze-assignment ( exp -- eproc )
1538 2swap assignment-val analyze ( var val-eproc )
1540 ['] assignment-executor primitive-proc-type
1544 : sequence-executor ( eproc-list env -- res )
1548 2dup cdr ( env elist elist-rest)
1551 -2rot car 2over ( elist-rest env elist-head env )
1552 evaluate-eproc ( elist-rest env head-res )
1553 2drop 2swap ( env elist-rest )
1557 ['] evaluate-eproc goto
1561 : (analyze-sequence) ( explist -- eproc-list )
1570 : analyze-sequence ( explist -- eproc )
1572 ['] sequence-executor primitive-proc-type
1577 : macro-definition-executor ( name params bproc env -- ok )
1578 make-macro ok-symbol
1581 : analyze-macro-definition ( exp -- eproc )
1582 2dup macro-definition-name
1583 2swap 2dup macro-definition-params
1584 2swap macro-definition-body analyze-sequence
1586 ['] macro-definition-executor primitive-proc-type
1587 nil cons cons cons cons
1590 : if-executor ( cproc aproc pproc env -- res )
1591 2swap 2over ( cproc aproc env pproc env -- res )
1600 ['] evaluate-eproc goto
1603 : analyze-if ( exp -- eproc )
1604 2dup if-consequent analyze
1605 2swap 2dup if-alternative analyze
1606 2swap if-predicate analyze
1608 ['] if-executor primitive-proc-type
1609 nil cons cons cons cons
1612 : lambda-executor ( params bproc env -- res )
1614 ( Although this is packaged up as a regular compound procedure,
1615 the "body" element contains an _eproc_ to be evaluated in an
1616 environment resulting from extending env with the parameter
1620 : analyze-lambda ( exp -- eproc )
1621 2dup lambda-parameters
1625 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1630 ['] lambda-executor primitive-proc-type
1634 : operand-eproc-list ( operands -- eprocs )
1642 : evaluate-operand-eprocs ( env aprocs -- vals )
1646 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1647 -2rot cdr recurse ( thisval restvals )
1652 : apply ( vals proc )
1654 primitive-proc-type of
1658 compound-proc-type of
1659 2dup procedure-body ( argvals proc bproc )
1660 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1661 -2rot procedure-env ( bproc argnames argvals procenv )
1667 extend-env ( bproc env )
1669 ['] evaluate-eproc goto
1672 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1676 : application-executor ( operator-proc arg-procs env -- res )
1677 2rot 2over ( aprocs env fproc env )
1678 evaluate-eproc ( aprocs env proc )
1680 -2rot 2swap ( proc env aprocs )
1681 evaluate-operand-eprocs ( proc vals )
1688 : analyze-application ( exp -- eproc )
1689 2dup operator analyze
1690 2swap operands operand-eproc-list
1692 ['] application-executor primitive-proc-type
1696 :noname ( exp --- eproc )
1698 self-evaluating? if analyze-self-evaluating exit then
1700 quote? if analyze-quoted exit then
1702 variable? if analyze-variable exit then
1704 definition? if analyze-definition exit then
1706 assignment? if analyze-assignment exit then
1708 macro-definition? if analyze-macro-definition exit then
1710 if? if analyze-if exit then
1712 lambda? if analyze-lambda exit then
1714 application? if analyze-application exit then
1716 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1722 \ ---- Macro Expansion ---- {{{
1724 ( Simply evaluates the given procedure with expbody as its argument. )
1725 : macro-eval ( proc expbody -- result )
1727 2dup procedure-body ( expbody proc bproc )
1728 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1729 -2rot procedure-env ( bproc argnames expbody procenv )
1735 extend-env ( bproc env )
1737 ['] evaluate-eproc goto
1740 : expand-macro ( exp -- result )
1741 pair-type istype? invert if exit then
1743 2dup car symbol-type istype? invert if 2drop exit then
1745 lookup-macro nil? if 2drop exit then
1747 2over cdr macro-eval
1749 2dup no-match-symbol objeq? if
1755 R> drop ['] expand goto-deferred
1758 : expand-definition ( exp -- result )
1762 2swap definition-val expand
1763 nil ( define var val' nil )
1767 : expand-assignment ( exp -- result )
1771 2swap assignment-val expand
1772 nil ( define var val' nil )
1776 : expand-list ( exp -- res )
1784 : macro-definition-nameparams
1787 : expand-define-macro ( exp -- res )
1788 define-macro-symbol 2swap
1789 2dup macro-definition-nameparams
1790 2swap macro-definition-body expand-list
1794 : expand-lambda ( exp -- res )
1796 2dup lambda-parameters
1797 2swap lambda-body expand-list
1801 : expand-if ( exp -- res )
1804 2dup if-predicate expand
1805 2swap 2dup if-consequent expand
1806 2swap if-alternative none? if
1814 : expand-application ( exp -- res )
1815 2dup operator expand
1816 2swap operands expand-list
1820 :noname ( exp -- result )
1823 self-evaluating? if exit then
1827 definition? if expand-definition exit then
1829 assignment? if expand-assignment exit then
1831 macro-definition? if expand-define-macro exit then
1833 lambda? if expand-lambda exit then
1835 if? if expand-if exit then
1837 application? if expand-application exit then
1843 :noname ( exp env -- res )
1844 2swap expand analyze 2swap evaluate-eproc
1847 \ ---- Print ---- {{{
1849 : printfixnum ( fixnum -- ) drop 0 .R ;
1851 : printflonum ( flonum -- ) drop f. ;
1853 : printratnum ( ratnum -- )
1855 car print ." /" cdr print
1858 : printbool ( bool -- )
1866 : printchar ( charobj -- )
1869 9 of ." #\tab" endof
1870 bl of ." #\space" endof
1871 '\n' of ." #\newline" endof
1877 : (printstring) ( stringobj -- )
1878 nil? if 2drop exit then
1882 '\n' of ." \n" drop endof
1883 [char] \ of ." \\" drop endof
1884 [char] " of [char] \ emit [char] " emit drop endof
1890 : printstring ( stringobj -- )
1895 : printsymbol ( symbolobj -- )
1896 nil-type istype? if 2drop exit then
1902 : printnil ( nilobj -- )
1905 : printpair ( pairobj -- )
1909 nil-type istype? if 2drop exit then
1910 pair-type istype? if space recurse exit then
1914 : printprim ( primobj -- )
1915 2drop ." <primitive procedure>" ;
1917 : printcomp ( primobj -- )
1918 2drop ." <compound procedure>" ;
1920 : printnone ( noneobj -- )
1921 2drop ." Unspecified return value" ;
1923 : printport ( port -- )
1927 fixnum-type istype? if printfixnum exit then
1928 flonum-type istype? if printflonum exit then
1929 ratnum-type istype? if printratnum exit then
1930 boolean-type istype? if printbool exit then
1931 character-type istype? if printchar exit then
1932 string-type istype? if printstring exit then
1933 symbol-type istype? if printsymbol exit then
1934 nil-type istype? if printnil exit then
1935 pair-type istype? if ." (" printpair ." )" exit then
1936 primitive-proc-type istype? if printprim exit then
1937 compound-proc-type istype? if printcomp exit then
1938 none-type istype? if printnone exit then
1939 port-type istype? if printport exit then
1941 except-message: ." tried to print object with unknown type." recoverable-exception throw
1946 \ ---- Garbage Collection ---- {{{
1948 variable gc-stack-depth
1951 depth gc-stack-depth !
1955 false gc-enabled ! ;
1957 : pairlike? ( obj -- obj bool )
1958 pair-type istype? if true exit then
1959 string-type istype? if true exit then
1960 symbol-type istype? if true exit then
1961 compound-proc-type istype? if true exit then
1962 port-type istype? if true exit then
1967 : pairlike-marked? ( obj -- obj bool )
1968 over nextfrees + @ 0=
1971 : mark-pairlike ( obj -- obj )
1972 over nextfrees + 0 swap !
1981 : gc-mark-obj ( obj -- )
1983 pairlike? invert if 2drop exit then
1984 pairlike-marked? if 2drop exit then
1995 scheme-memsize nextfree !
1996 0 scheme-memsize 1- do
1997 nextfrees i + @ 0<> if
1998 nextfree @ nextfrees i + !
2004 \ Following a GC, this gives the amount of free memory
2008 nextfrees i + @ 0= if 1+ then
2012 \ Debugging word - helps spot memory that is retained
2015 nextfrees i + @ 0<> if
2027 symbol-table obj@ gc-mark-obj
2028 macro-table obj@ gc-mark-obj
2029 console-i/o-port obj@ gc-mark-obj
2030 global-env obj@ gc-mark-obj
2032 depth gc-stack-depth @ do
2041 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2042 ; is collect-garbage
2046 \ ---- Loading files ---- {{{
2048 : load ( addr n -- finalResult )
2053 ok-symbol ( port res )
2057 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2059 2over read-port ( port res obj )
2064 2dup EOF character-type objeq? if
2065 2drop 2swap close-port
2069 2swap 2drop ( port obj )
2071 global-env obj@ eval ( port res )
2077 \ ---- Standard Library ---- {{{
2079 include scheme-primitives.4th
2083 s" scheme-library.scm" load 2drop
2091 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2092 : repl-body ( -- bool )
2093 cr bold fg green ." > " reset-term
2097 2dup EOF character-type objeq? if
2099 bold fg blue ." Moriturus te saluto." reset-term cr
2103 global-env obj@ eval
2105 fg cyan ." ; " print reset-term
2115 \ Display welcome message
2116 welcome-symbol nil cons global-env obj@ eval 2drop
2121 recoverable-exception of false endof
2122 unrecoverable-exception of true endof