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 : add-frame-to-env ( frame env -- env )
416 : frame-vars ( frame -- vars )
419 : frame-vals ( frame -- vals )
422 : add-binding ( var val frame -- )
423 2swap 2over frame-vals cons
425 2swap 2over frame-vars cons
429 : extend-env ( vars vals env -- env )
431 2swap add-frame-to-env
434 : get-vals-frame ( var frame -- vals | nil )
436 2swap frame-vals ( var vars vals )
442 -2rot ( vals var vars )
443 2over 2over car objeq? if
455 : get-vals ( var env -- vals | nil )
460 2over 2over first-frame
461 get-vals-frame nil? false = if
462 2swap 2drop 2swap 2drop
474 objvar var \ Used only for error messages
475 : lookup-var ( var env -- val )
479 except-message: ." tried to read unbound variable '" var obj@ print ." '."
480 recoverable-exception throw
486 : set-var ( var val env -- )
487 2rot 2dup var obj! ( val env var )
489 except-message: ." tried to set unbound variable '" var obj@ print ." '."
490 recoverable-exception throw
498 : define-var ( var val env -- )
499 first-frame ( var val frame )
500 2rot 2over 2over ( val frame var frame var )
502 get-vals-frame nil? if
503 2drop ( val frame var )
506 ( val frame var vals )
507 2swap 2drop 2swap 2drop
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 nextchar [char] ) = if
1278 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1281 \ Anything else is parsed as a symbol
1282 readsymbol charlist>symbol
1284 \ Replace λ with lambda
1285 2dup λ-symbol objeq? if
1294 \ ---- Syntax ---- {{{
1296 : self-evaluating? ( obj -- obj bool )
1297 boolean-type istype? if true exit then
1298 fixnum-type istype? if true exit then
1299 flonum-type istype? if true exit then
1300 ratnum-type istype? if true exit then
1301 character-type istype? if true exit then
1302 string-type istype? if true exit then
1303 nil-type istype? if true exit then
1304 none-type istype? if true exit then
1309 : tagged-list? ( obj tag-obj -- obj bool )
1311 pair-type istype? false = if
1317 : quote? ( obj -- obj bool )
1318 quote-symbol tagged-list? ;
1320 : quote-body ( quote-obj -- quote-body-obj )
1323 : variable? ( obj -- obj bool )
1324 symbol-type istype? ;
1326 : definition? ( obj -- obj bool )
1327 define-symbol tagged-list? ;
1329 : definition-var ( obj -- var )
1332 : definition-val ( obj -- val )
1335 : assignment? ( obj -- obj bool )
1336 set!-symbol tagged-list? ;
1338 : assignment-var ( obj -- var )
1341 : assignment-val ( obj -- val )
1344 : macro-definition? ( obj -- obj bool )
1345 define-macro-symbol tagged-list? ;
1347 : macro-definition-name ( exp -- mname )
1350 : macro-definition-params ( exp -- params )
1353 : macro-definition-body ( exp -- body )
1356 : if? ( obj -- obj bool )
1357 if-symbol tagged-list? ;
1359 : if-predicate ( ifobj -- pred )
1362 : if-consequent ( ifobj -- conseq )
1365 : if-alternative ( ifobj -- alt|none )
1373 : false? ( boolobj -- boolean )
1374 boolean-type istype? if
1375 false boolean-type objeq?
1381 : true? ( boolobj -- bool )
1384 : lambda? ( obj -- obj bool )
1385 lambda-symbol tagged-list? ;
1387 : lambda-parameters ( obj -- params )
1390 : lambda-body ( obj -- body )
1393 : application? ( obj -- obj bool )
1396 : operator ( obj -- operator )
1399 : operands ( obj -- operands )
1402 : nooperands? ( operands -- bool )
1405 : first-operand ( operands -- operand )
1408 : rest-operands ( operands -- other-operands )
1411 : procedure-params ( proc -- params )
1412 drop pair-type car ;
1414 : procedure-body ( proc -- body )
1415 drop pair-type cdr car ;
1417 : procedure-env ( proc -- body )
1418 drop pair-type cdr cdr car ;
1420 ( Ensure terminating symbol arg name is handled
1421 specially to allow for variadic procedures. )
1422 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1424 2over nil? false = if
1425 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1432 symbol-type istype? if
1442 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1449 recurse ( argvals argnames argvals'' argnames'' )
1450 2rot car 2swap cons ( argvals argvals'' argnames' )
1451 2rot car 2rot cons ( argnames' argvals' )
1457 \ ---- Analyze ---- {{{
1459 : evaluate-eproc ( eproc env --- res )
1470 2drop \ get rid of null
1474 \ Final element of eproc list is primitive procedure
1475 drop \ dump type signifier
1477 goto \ jump straight to primitive procedure (executor)
1480 : self-evaluating-executor ( exp env -- exp )
1483 : analyze-self-evaluating ( exp --- eproc )
1484 ['] self-evaluating-executor primitive-proc-type
1488 : quote-executor ( exp env -- exp )
1491 : analyze-quoted ( exp -- eproc )
1494 ['] quote-executor primitive-proc-type
1498 : variable-executor ( var env -- val )
1501 : analyze-variable ( exp -- eproc )
1502 ['] variable-executor primitive-proc-type
1506 : definition-executor ( var val-eproc env -- ok )
1507 2swap 2over ( var env val-eproc env )
1508 evaluate-eproc 2swap ( var val env )
1513 : analyze-definition ( exp -- eproc )
1515 2swap definition-val analyze
1517 ['] definition-executor primitive-proc-type
1521 : assignment-executor ( var val-eproc env -- ok )
1522 2swap 2over ( var env val-eproc env )
1523 evaluate-eproc 2swap ( var val env )
1528 : analyze-assignment ( exp -- eproc )
1530 2swap assignment-val analyze ( var val-eproc )
1532 ['] assignment-executor primitive-proc-type
1536 : sequence-executor ( eproc-list env -- res )
1540 2dup cdr ( env elist elist-rest)
1543 -2rot car 2over ( elist-rest env elist-head env )
1544 evaluate-eproc ( elist-rest env head-res )
1545 2drop 2swap ( env elist-rest )
1549 ['] evaluate-eproc goto
1553 : (analyze-sequence) ( explist -- eproc-list )
1562 : analyze-sequence ( explist -- eproc )
1564 ['] sequence-executor primitive-proc-type
1569 : macro-definition-executor ( name params bproc env -- ok )
1570 make-macro ok-symbol
1573 : analyze-macro-definition ( exp -- eproc )
1574 2dup macro-definition-name
1575 2swap 2dup macro-definition-params
1576 2swap macro-definition-body analyze-sequence
1578 ['] macro-definition-executor primitive-proc-type
1579 nil cons cons cons cons
1582 : if-executor ( cproc aproc pproc env -- res )
1583 2swap 2over ( cproc aproc env pproc env -- res )
1592 ['] evaluate-eproc goto
1595 : analyze-if ( exp -- eproc )
1596 2dup if-consequent analyze
1597 2swap 2dup if-alternative analyze
1598 2swap if-predicate analyze
1600 ['] if-executor primitive-proc-type
1601 nil cons cons cons cons
1604 : lambda-executor ( params bproc env -- res )
1606 ( Although this is packaged up as a regular compound procedure,
1607 the "body" element contains an _eproc_ to be evaluated in an
1608 environment resulting from extending env with the parameter
1612 : analyze-lambda ( exp -- eproc )
1613 2dup lambda-parameters
1617 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1622 ['] lambda-executor primitive-proc-type
1626 : operand-eproc-list ( operands -- eprocs )
1634 : evaluate-operand-eprocs ( env aprocs -- vals )
1638 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1639 -2rot cdr recurse ( thisval restvals )
1644 : apply ( vals proc )
1646 primitive-proc-type of
1650 compound-proc-type of
1651 2dup procedure-body ( argvals proc bproc )
1652 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1653 -2rot procedure-env ( bproc argnames argvals procenv )
1659 extend-env ( bproc env )
1661 ['] evaluate-eproc goto
1664 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1668 : application-executor ( operator-proc arg-procs env -- res )
1669 2rot 2over ( aprocs env fproc env )
1670 evaluate-eproc ( aprocs env proc )
1672 -2rot 2swap ( proc env aprocs )
1673 evaluate-operand-eprocs ( proc vals )
1680 : analyze-application ( exp -- eproc )
1681 2dup operator analyze
1682 2swap operands operand-eproc-list
1684 ['] application-executor primitive-proc-type
1688 :noname ( exp --- eproc )
1690 self-evaluating? if analyze-self-evaluating exit then
1692 quote? if analyze-quoted exit then
1694 variable? if analyze-variable exit then
1696 definition? if analyze-definition exit then
1698 assignment? if analyze-assignment exit then
1700 macro-definition? if analyze-macro-definition exit then
1702 if? if analyze-if exit then
1704 lambda? if analyze-lambda exit then
1706 application? if analyze-application exit then
1708 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1714 \ ---- Macro Expansion ---- {{{
1716 ( Simply evaluates the given procedure with expbody as its argument. )
1717 : macro-eval ( proc expbody -- result )
1719 2dup procedure-body ( expbody proc bproc )
1720 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1721 -2rot procedure-env ( bproc argnames expbody procenv )
1727 extend-env ( bproc env )
1729 ['] evaluate-eproc goto
1732 : expand-macro ( exp -- result )
1733 pair-type istype? invert if exit then
1735 2dup car symbol-type istype? invert if 2drop exit then
1737 lookup-macro nil? if 2drop exit then
1739 2over cdr macro-eval
1741 2dup no-match-symbol objeq? if
1747 R> drop ['] expand goto-deferred
1750 : expand-definition ( exp -- result )
1754 2swap definition-val expand
1755 nil ( define var val' nil )
1759 : expand-assignment ( exp -- result )
1763 2swap assignment-val expand
1764 nil ( define var val' nil )
1768 : expand-list ( exp -- res )
1776 : macro-definition-nameparams
1779 : expand-define-macro ( exp -- res )
1780 define-macro-symbol 2swap
1781 2dup macro-definition-nameparams
1782 2swap macro-definition-body expand-list
1786 : expand-lambda ( exp -- res )
1788 2dup lambda-parameters
1789 2swap lambda-body expand-list
1793 : expand-if ( exp -- res )
1796 2dup if-predicate expand
1797 2swap 2dup if-consequent expand
1798 2swap if-alternative none? if
1806 : expand-application ( exp -- res )
1807 2dup operator expand
1808 2swap operands expand-list
1812 :noname ( exp -- result )
1815 self-evaluating? if exit then
1819 definition? if expand-definition exit then
1821 assignment? if expand-assignment exit then
1823 macro-definition? if expand-define-macro exit then
1825 lambda? if expand-lambda exit then
1827 if? if expand-if exit then
1829 application? if expand-application exit then
1835 :noname ( exp env -- res )
1836 2swap expand analyze 2swap evaluate-eproc
1839 \ ---- Print ---- {{{
1841 : printfixnum ( fixnum -- ) drop 0 .R ;
1843 : printflonum ( flonum -- ) drop f. ;
1845 : printratnum ( ratnum -- )
1847 car print ." /" cdr print
1850 : printbool ( bool -- )
1858 : printchar ( charobj -- )
1861 9 of ." #\tab" endof
1862 bl of ." #\space" endof
1863 '\n' of ." #\newline" endof
1869 : (printstring) ( stringobj -- )
1870 nil? if 2drop exit then
1874 '\n' of ." \n" drop endof
1875 [char] \ of ." \\" drop endof
1876 [char] " of [char] \ emit [char] " emit drop endof
1882 : printstring ( stringobj -- )
1887 : printsymbol ( symbolobj -- )
1888 nil-type istype? if 2drop exit then
1894 : printnil ( nilobj -- )
1897 : printpair ( pairobj -- )
1901 nil-type istype? if 2drop exit then
1902 pair-type istype? if space recurse exit then
1906 : printprim ( primobj -- )
1907 2drop ." <primitive procedure>" ;
1909 : printcomp ( primobj -- )
1910 2drop ." <compound procedure>" ;
1912 : printnone ( noneobj -- )
1913 2drop ." Unspecified return value" ;
1915 : printport ( port -- )
1919 fixnum-type istype? if printfixnum exit then
1920 flonum-type istype? if printflonum exit then
1921 ratnum-type istype? if printratnum exit then
1922 boolean-type istype? if printbool exit then
1923 character-type istype? if printchar exit then
1924 string-type istype? if printstring exit then
1925 symbol-type istype? if printsymbol exit then
1926 nil-type istype? if printnil exit then
1927 pair-type istype? if ." (" printpair ." )" exit then
1928 primitive-proc-type istype? if printprim exit then
1929 compound-proc-type istype? if printcomp exit then
1930 none-type istype? if printnone exit then
1931 port-type istype? if printport exit then
1933 except-message: ." tried to print object with unknown type." recoverable-exception throw
1939 \ ---- Garbage Collection ---- {{{
1941 ( Notes on garbage collection:
1942 This is a mark-sweep garbage collector, invoked by cons.
1943 The roots of the object tree used by the marking routine
1944 include all objects in the parameter stack, and several
1945 other fixed roots such as global-env, symbol-table, macro-table,
1946 and the console-i/o-port.
1948 NO OTHER OBJECTS WILL BE MARKED!
1950 This places implicit restrictions on when cons can be invoked.
1951 Invoking cons when live objects are stored on the return stack
1952 or in other variables than the above will result in possible
1953 memory corruption if the cons triggers the GC. )
1955 variable gc-stack-depth
1958 depth gc-stack-depth !
1962 false gc-enabled ! ;
1964 : pairlike? ( obj -- obj bool )
1965 pair-type istype? if true exit then
1966 string-type istype? if true exit then
1967 symbol-type istype? if true exit then
1968 compound-proc-type istype? if true exit then
1969 port-type istype? if true exit then
1974 : pairlike-marked? ( obj -- obj bool )
1975 over nextfrees + @ 0=
1978 : mark-pairlike ( obj -- obj )
1979 over nextfrees + 0 swap !
1988 : gc-mark-obj ( obj -- )
1990 pairlike? invert if 2drop exit then
1991 pairlike-marked? if 2drop exit then
2002 scheme-memsize nextfree !
2003 0 scheme-memsize 1- do
2004 nextfrees i + @ 0<> if
2005 nextfree @ nextfrees i + !
2011 \ Following a GC, this gives the amount of free memory
2015 nextfrees i + @ 0= if 1+ then
2019 \ Debugging word - helps spot memory that is retained
2022 nextfrees i + @ 0<> if
2034 symbol-table obj@ gc-mark-obj
2035 macro-table obj@ gc-mark-obj
2036 console-i/o-port obj@ gc-mark-obj
2037 global-env obj@ gc-mark-obj
2039 depth gc-stack-depth @ do
2048 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2049 ; is collect-garbage
2053 \ ---- Loading files ---- {{{
2055 : load ( addr n -- finalResult )
2060 ok-symbol ( port res )
2064 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2066 2over read-port ( port res obj )
2071 2dup EOF character-type objeq? if
2072 2drop 2swap close-port
2076 2swap 2drop ( port obj )
2078 global-env obj@ eval ( port res )
2084 \ ---- Standard Library ---- {{{
2086 include scheme-primitives.4th
2090 s" scheme-library.scm" load 2drop
2098 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2099 : repl-body ( -- bool )
2100 cr bold fg green ." > " reset-term
2104 2dup EOF character-type objeq? if
2106 bold fg blue ." Moriturus te saluto." reset-term cr
2110 global-env obj@ eval
2112 fg cyan ." ; " print reset-term
2122 \ Display welcome message
2123 welcome-symbol nil cons global-env obj@ eval 2drop
2128 recoverable-exception of false endof
2129 unrecoverable-exception of true endof