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 2swap 2over 2over ( val var frame var frame )
502 get-vals-frame nil? if
507 ( val var frame vals )
508 2swap 2drop 2swap 2drop
513 : make-procedure ( params body env -- proc )
516 drop compound-proc-type
520 nil nil nil extend-env
525 \ ---- Primitives ---- {{{
527 : make-primitive ( cfa -- )
534 rot primitive-proc-type ( var prim )
535 global-env obj@ define-var
538 : ensure-arg-count ( args n -- )
540 drop nil objeq? false = if
541 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
545 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
552 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
554 drop nil objeq? false = if
555 except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
559 except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
562 2dup cdr 2swap car ( ... t1 n args' arg1 )
563 2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
565 except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
573 : push-args-to-stack ( args -- arg1 arg2 ... argn )
583 : add-fa-checks ( cfa n -- cfa' )
584 here current @ 1+ dup @ , !
588 ['] 2dup , ['] lit , , ['] ensure-arg-count ,
589 ['] push-args-to-stack ,
590 ['] lit , , ['] execute ,
594 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
595 here current @ 1+ dup @ , !
602 dup ( cfa t1 t2 ... tn n m )
607 rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
613 ['] lit , , ['] ensure-arg-type-and-count ,
615 ['] push-args-to-stack ,
616 ['] lit , , ['] execute ,
622 : make-fa-primitive ( cfa n -- )
623 add-fa-checks make-primitive ;
625 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
626 add-fa-type-checks make-primitive ;
629 bold fg red ." Incorrect argument type." reset-term cr
633 : ensure-arg-type ( arg type -- arg )
635 except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
642 \ ---- Macros ---- {{{
646 ( Look up macro in macro table. Returns nil if
648 : lookup-macro ( name_symbol -- proc )
650 symbol-type istype? invert if
651 \ Early exit if argument is not a symbol
673 : make-macro ( name_symbol params body env -- )
676 2swap ( proc name_symbol )
683 2over 2over ( proc name table name table )
685 2swap 2drop ( proc table )
697 macro-table obj@ cons
706 variable stored-parse-idx
707 create parse-str 161 allot
708 variable parse-str-span
710 create parse-idx-stack 10 allot
711 variable parse-idx-sp
712 parse-idx-stack parse-idx-sp !
715 parse-idx @ parse-idx-sp @ !
720 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
724 parse-idx-sp @ @ parse-idx ! ;
728 '\n' parse-str parse-str-span @ + !
729 1 parse-str-span +! ;
732 4 parse-str parse-str-span @ + !
733 1 parse-str-span +! ;
740 current-input-port obj@ console-i/o-port obj@ objeq? if
741 parse-str 160 expect cr
742 span @ parse-str-span !
744 parse-str 160 current-input-port obj@ fileport>fid orig-read-line
745 drop swap parse-str-span !
747 parse-str-span @ 0= and if append-eof then
758 : charavailable? ( -- bool )
759 parse-str-span @ parse-idx @ > ;
761 : nextchar ( -- char )
762 charavailable? false = if getline then
763 parse-str parse-idx @ + @ ;
766 : whitespace? ( -- bool )
778 nextchar [char] ( = or
779 nextchar [char] ) = or
782 : commentstart? ( -- bool )
783 nextchar [char] ; = ;
787 false \ Indicates whether or not we're eating a comment
790 dup whitespace? or commentstart? or
792 dup nextchar '\n' = and if
793 invert \ Stop eating comment
795 dup false = commentstart? and if
796 invert \ Begin eating comment
811 nextchar [char] - = ;
814 nextchar [char] + = ;
816 : fixnum? ( -- bool )
842 : flonum? ( -- bool )
849 \ Record starting parse idx:
850 \ Want to detect whether any characters (following +/-) were eaten.
857 [char] . nextchar = if
864 [char] e nextchar = [char] E nextchar = or if
872 drop pop-parse-idx false exit
880 \ This is a real number if characters were
881 \ eaten and the next characer is a delimiter.
882 parse-idx @ < delim? and
887 : ratnum? ( -- bool )
895 pop-parse-idx false exit
904 [char] / nextchar <> if
905 pop-parse-idx false exit
911 pop-parse-idx false exit
923 : boolean? ( -- bool )
924 nextchar [char] # <> if false exit then
931 and if pop-parse-idx false exit then
943 : str-equiv? ( str -- bool )
960 delim? false = if drop false then
965 : character? ( -- bool )
966 nextchar [char] # <> if false exit then
971 nextchar [char] \ <> if pop-parse-idx false exit then
975 S" newline" str-equiv? if pop-parse-idx true exit then
976 S" space" str-equiv? if pop-parse-idx true exit then
977 S" tab" str-equiv? if pop-parse-idx true exit then
979 charavailable? false = if pop-parse-idx false exit then
985 nextchar [char] ( = ;
987 : string? ( -- bool )
988 nextchar [char] " = ;
990 : readfixnum ( -- fixnum )
1001 10 * nextchar [char] 0 - +
1010 : readflonum ( -- flonum )
1012 dup 0< swap abs i->f
1014 [char] . nextchar = if
1020 nextchar [char] 0 - i->f ( f exp d )
1021 over f/ rot f+ ( exp f' )
1022 swap 10.0 f* ( f' exp' )
1029 [char] e nextchar = [char] E nextchar = or if
1032 readfixnum drop i->f
1043 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1050 fixnum-type swap fixnum-type
1051 cons drop ratnum-type
1055 : readratnum ( -- ratnum )
1056 readfixnum inc-parse-idx readfixnum
1060 : readbool ( -- bool-obj )
1063 nextchar [char] f = if
1074 : readchar ( -- char-obj )
1078 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1079 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1080 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1082 nextchar character-type
1087 : readstring ( -- charlist )
1092 nextchar [char] " <>
1094 nextchar [char] \ = if
1097 [char] n of '\n' endof
1098 [char] " of [char] " endof
1104 inc-parse-idx character-type
1107 ( firstchar prevchar thischar )
1110 2drop 2swap 2drop 2dup ( thischar thischar )
1112 ( firstchar thischar prevchar )
1113 2over 2swap set-cdr! ( firstchar thischar )
1117 \ Discard previous character
1123 ." No delimiter following right double quote. Aborting." cr
1135 : readsymbol ( -- charlist )
1136 delim? if nil exit then
1138 nextchar inc-parse-idx character-type
1145 : readpair ( -- pairobj )
1149 nextchar [char] ) = if
1154 ." No delimiter following right paren. Aborting." cr
1163 \ Read first pair element
1168 nextchar [char] . = if
1173 ." No delimiter following '.'. Aborting." cr
1187 \ Parse a scheme expression
1222 nextchar [char] " <> if
1223 bold red ." Missing closing double-quote." reset-term cr
1241 nextchar [char] ) <> if
1242 bold red ." Missing closing paren." reset-term cr
1251 nextchar [char] ' = if
1253 quote-symbol recurse nil cons cons exit
1256 nextchar [char] ` = if
1258 quasiquote-symbol recurse nil cons cons exit
1261 nextchar [char] , = if
1263 nextchar [char] @ = if
1265 unquote-splicing-symbol recurse nil cons cons exit
1267 unquote-symbol recurse nil cons cons exit
1277 nextchar [char] ) = if
1279 except-message: ." unmatched closing parenthesis." recoverable-exception throw
1282 \ Anything else is parsed as a symbol
1283 readsymbol charlist>symbol
1285 \ Replace λ with lambda
1286 2dup λ-symbol objeq? if
1295 \ ---- Syntax ---- {{{
1297 : self-evaluating? ( obj -- obj bool )
1298 boolean-type istype? if true exit then
1299 fixnum-type istype? if true exit then
1300 flonum-type istype? if true exit then
1301 ratnum-type istype? if true exit then
1302 character-type istype? if true exit then
1303 string-type istype? if true exit then
1304 nil-type istype? if true exit then
1305 none-type istype? if true exit then
1310 : tagged-list? ( obj tag-obj -- obj bool )
1312 pair-type istype? false = if
1318 : quote? ( obj -- obj bool )
1319 quote-symbol tagged-list? ;
1321 : quote-body ( quote-obj -- quote-body-obj )
1324 : variable? ( obj -- obj bool )
1325 symbol-type istype? ;
1327 : definition? ( obj -- obj bool )
1328 define-symbol tagged-list? ;
1330 : definition-var ( obj -- var )
1333 : definition-val ( obj -- val )
1336 : assignment? ( obj -- obj bool )
1337 set!-symbol tagged-list? ;
1339 : assignment-var ( obj -- var )
1342 : assignment-val ( obj -- val )
1345 : macro-definition? ( obj -- obj bool )
1346 define-macro-symbol tagged-list? ;
1348 : macro-definition-name ( exp -- mname )
1351 : macro-definition-params ( exp -- params )
1354 : macro-definition-body ( exp -- body )
1357 : if? ( obj -- obj bool )
1358 if-symbol tagged-list? ;
1360 : if-predicate ( ifobj -- pred )
1363 : if-consequent ( ifobj -- conseq )
1366 : if-alternative ( ifobj -- alt|none )
1374 : false? ( boolobj -- boolean )
1375 boolean-type istype? if
1376 false boolean-type objeq?
1382 : true? ( boolobj -- bool )
1385 : lambda? ( obj -- obj bool )
1386 lambda-symbol tagged-list? ;
1388 : lambda-parameters ( obj -- params )
1391 : lambda-body ( obj -- body )
1394 : application? ( obj -- obj bool )
1397 : operator ( obj -- operator )
1400 : operands ( obj -- operands )
1403 : nooperands? ( operands -- bool )
1406 : first-operand ( operands -- operand )
1409 : rest-operands ( operands -- other-operands )
1412 : procedure-params ( proc -- params )
1413 drop pair-type car ;
1415 : procedure-body ( proc -- body )
1416 drop pair-type cdr car ;
1418 : procedure-env ( proc -- body )
1419 drop pair-type cdr cdr car ;
1421 ( Ensure terminating symbol arg name is handled
1422 specially to allow for variadic procedures. )
1423 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1425 2over nil? false = if
1426 except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1433 symbol-type istype? if
1443 except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1450 recurse ( argvals argnames argvals'' argnames'' )
1451 2rot car 2swap cons ( argvals argvals'' argnames' )
1452 2rot car 2rot cons ( argnames' argvals' )
1458 \ ---- Analyze ---- {{{
1460 : evaluate-eproc ( eproc env --- res )
1471 2drop \ get rid of null
1475 \ Final element of eproc list is primitive procedure
1476 drop \ dump type signifier
1478 goto \ jump straight to primitive procedure (executor)
1481 : self-evaluating-executor ( exp env -- exp )
1484 : analyze-self-evaluating ( exp --- eproc )
1485 ['] self-evaluating-executor primitive-proc-type
1489 : quote-executor ( exp env -- exp )
1492 : analyze-quoted ( exp -- eproc )
1495 ['] quote-executor primitive-proc-type
1499 : variable-executor ( var env -- val )
1502 : analyze-variable ( exp -- eproc )
1503 ['] variable-executor primitive-proc-type
1507 : definition-executor ( var val-eproc env -- ok )
1508 2swap 2over ( var env val-eproc env )
1509 evaluate-eproc 2swap ( var val env )
1514 : analyze-definition ( exp -- eproc )
1516 2swap definition-val analyze
1518 ['] definition-executor primitive-proc-type
1522 : assignment-executor ( var val-eproc env -- ok )
1523 2swap 2over ( var env val-eproc env )
1524 evaluate-eproc 2swap ( var val env )
1529 : analyze-assignment ( exp -- eproc )
1531 2swap assignment-val analyze ( var val-eproc )
1533 ['] assignment-executor primitive-proc-type
1537 : sequence-executor ( eproc-list env -- res )
1541 2dup cdr ( env elist elist-rest)
1544 -2rot car 2over ( elist-rest env elist-head env )
1545 evaluate-eproc ( elist-rest env head-res )
1546 2drop 2swap ( env elist-rest )
1550 ['] evaluate-eproc goto
1554 : (analyze-sequence) ( explist -- eproc-list )
1563 : analyze-sequence ( explist -- eproc )
1565 ['] sequence-executor primitive-proc-type
1570 : macro-definition-executor ( name params bproc env -- ok )
1571 make-macro ok-symbol
1574 : analyze-macro-definition ( exp -- eproc )
1575 2dup macro-definition-name
1576 2swap 2dup macro-definition-params
1577 2swap macro-definition-body analyze-sequence
1579 ['] macro-definition-executor primitive-proc-type
1580 nil cons cons cons cons
1583 : if-executor ( cproc aproc pproc env -- res )
1584 2swap 2over ( cproc aproc env pproc env -- res )
1593 ['] evaluate-eproc goto
1596 : analyze-if ( exp -- eproc )
1597 2dup if-consequent analyze
1598 2swap 2dup if-alternative analyze
1599 2swap if-predicate analyze
1601 ['] if-executor primitive-proc-type
1602 nil cons cons cons cons
1605 : lambda-executor ( params bproc env -- res )
1607 ( Although this is packaged up as a regular compound procedure,
1608 the "body" element contains an _eproc_ to be evaluated in an
1609 environment resulting from extending env with the parameter
1613 : analyze-lambda ( exp -- eproc )
1614 2dup lambda-parameters
1618 except-message: ." encountered lambda with an empty body." recoverable-exception throw
1623 ['] lambda-executor primitive-proc-type
1627 : operand-eproc-list ( operands -- eprocs )
1635 : evaluate-operand-eprocs ( env aprocs -- vals )
1639 2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1640 -2rot cdr recurse ( thisval restvals )
1645 : apply ( vals proc )
1647 primitive-proc-type of
1651 compound-proc-type of
1652 2dup procedure-body ( argvals proc bproc )
1653 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1654 -2rot procedure-env ( bproc argnames argvals procenv )
1660 extend-env ( bproc env )
1662 ['] evaluate-eproc goto
1665 except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1669 : application-executor ( operator-proc arg-procs env -- res )
1670 2rot 2over ( aprocs env fproc env )
1671 evaluate-eproc ( aprocs env proc )
1673 -2rot 2swap ( proc env aprocs )
1674 evaluate-operand-eprocs ( proc vals )
1681 : analyze-application ( exp -- eproc )
1682 2dup operator analyze
1683 2swap operands operand-eproc-list
1685 ['] application-executor primitive-proc-type
1689 :noname ( exp --- eproc )
1691 self-evaluating? if analyze-self-evaluating exit then
1693 quote? if analyze-quoted exit then
1695 variable? if analyze-variable exit then
1697 definition? if analyze-definition exit then
1699 assignment? if analyze-assignment exit then
1701 macro-definition? if analyze-macro-definition exit then
1703 if? if analyze-if exit then
1705 lambda? if analyze-lambda exit then
1707 application? if analyze-application exit then
1709 except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1715 \ ---- Macro Expansion ---- {{{
1717 ( Simply evaluates the given procedure with expbody as its argument. )
1718 : macro-eval ( proc expbody -- result )
1720 2dup procedure-body ( expbody proc bproc )
1721 -2rot 2dup procedure-params ( bproc expbody proc argnames )
1722 -2rot procedure-env ( bproc argnames expbody procenv )
1728 extend-env ( bproc env )
1730 ['] evaluate-eproc goto
1733 : expand-macro ( exp -- result )
1734 pair-type istype? invert if exit then
1736 2dup car symbol-type istype? invert if 2drop exit then
1738 lookup-macro nil? if 2drop exit then
1740 2over cdr macro-eval
1742 2dup no-match-symbol objeq? if
1748 R> drop ['] expand goto-deferred
1751 : expand-definition ( exp -- result )
1755 2swap definition-val expand
1756 nil ( define var val' nil )
1760 : expand-assignment ( exp -- result )
1764 2swap assignment-val expand
1765 nil ( define var val' nil )
1769 : expand-list ( exp -- res )
1777 : macro-definition-nameparams
1780 : expand-define-macro ( exp -- res )
1781 define-macro-symbol 2swap
1782 2dup macro-definition-nameparams
1783 2swap macro-definition-body expand-list
1787 : expand-lambda ( exp -- res )
1789 2dup lambda-parameters
1790 2swap lambda-body expand-list
1794 : expand-if ( exp -- res )
1797 2dup if-predicate expand
1798 2swap 2dup if-consequent expand
1799 2swap if-alternative none? if
1807 : expand-application ( exp -- res )
1808 2dup operator expand
1809 2swap operands expand-list
1813 :noname ( exp -- result )
1816 self-evaluating? if exit then
1820 definition? if expand-definition exit then
1822 assignment? if expand-assignment exit then
1824 macro-definition? if expand-define-macro exit then
1826 lambda? if expand-lambda exit then
1828 if? if expand-if exit then
1830 application? if expand-application exit then
1836 :noname ( exp env -- res )
1837 2swap expand analyze 2swap evaluate-eproc
1840 \ ---- Print ---- {{{
1842 : printfixnum ( fixnum -- ) drop 0 .R ;
1844 : printflonum ( flonum -- ) drop f. ;
1846 : printratnum ( ratnum -- )
1848 car print ." /" cdr print
1851 : printbool ( bool -- )
1859 : printchar ( charobj -- )
1862 9 of ." #\tab" endof
1863 bl of ." #\space" endof
1864 '\n' of ." #\newline" endof
1870 : (printstring) ( stringobj -- )
1871 nil? if 2drop exit then
1875 '\n' of ." \n" drop endof
1876 [char] \ of ." \\" drop endof
1877 [char] " of [char] \ emit [char] " emit drop endof
1883 : printstring ( stringobj -- )
1888 : printsymbol ( symbolobj -- )
1889 nil-type istype? if 2drop exit then
1895 : printnil ( nilobj -- )
1898 : printpair ( pairobj -- )
1902 nil-type istype? if 2drop exit then
1903 pair-type istype? if space recurse exit then
1907 : printprim ( primobj -- )
1908 2drop ." <primitive procedure>" ;
1910 : printcomp ( primobj -- )
1911 2drop ." <compound procedure>" ;
1913 : printnone ( noneobj -- )
1914 2drop ." Unspecified return value" ;
1916 : printport ( port -- )
1920 fixnum-type istype? if printfixnum exit then
1921 flonum-type istype? if printflonum exit then
1922 ratnum-type istype? if printratnum exit then
1923 boolean-type istype? if printbool exit then
1924 character-type istype? if printchar exit then
1925 string-type istype? if printstring exit then
1926 symbol-type istype? if printsymbol exit then
1927 nil-type istype? if printnil exit then
1928 pair-type istype? if ." (" printpair ." )" exit then
1929 primitive-proc-type istype? if printprim exit then
1930 compound-proc-type istype? if printcomp exit then
1931 none-type istype? if printnone exit then
1932 port-type istype? if printport exit then
1934 except-message: ." tried to print object with unknown type." recoverable-exception throw
1940 \ ---- Garbage Collection ---- {{{
1942 ( Notes on garbage collection:
1943 This is a mark-sweep garbage collector, invoked by cons.
1944 The roots of the object tree used by the marking routine
1945 include all objects in the parameter stack, and several
1946 other fixed roots such as global-env, symbol-table, macro-table,
1947 and the console-i/o-port.
1949 NO OTHER OBJECTS WILL BE MARKED!
1951 This places implicit restrictions on when cons can be invoked.
1952 Invoking cons when live objects are stored on the return stack
1953 or in other variables than the above will result in possible
1954 memory corruption if the cons triggers the GC. )
1956 variable gc-stack-depth
1959 depth gc-stack-depth !
1963 false gc-enabled ! ;
1965 : pairlike? ( obj -- obj bool )
1966 pair-type istype? if true exit then
1967 string-type istype? if true exit then
1968 symbol-type istype? if true exit then
1969 compound-proc-type istype? if true exit then
1970 port-type istype? if true exit then
1975 : pairlike-marked? ( obj -- obj bool )
1976 over nextfrees + @ 0=
1979 : mark-pairlike ( obj -- obj )
1980 over nextfrees + 0 swap !
1989 : gc-mark-obj ( obj -- )
1991 pairlike? invert if 2drop exit then
1992 pairlike-marked? if 2drop exit then
2003 scheme-memsize nextfree !
2004 0 scheme-memsize 1- do
2005 nextfrees i + @ 0<> if
2006 nextfree @ nextfrees i + !
2012 \ Following a GC, this gives the amount of free memory
2016 nextfrees i + @ 0= if 1+ then
2020 \ Debugging word - helps spot memory that is retained
2023 nextfrees i + @ 0<> if
2035 symbol-table obj@ gc-mark-obj
2036 macro-table obj@ gc-mark-obj
2037 console-i/o-port obj@ gc-mark-obj
2038 global-env obj@ gc-mark-obj
2040 depth gc-stack-depth @ do
2049 \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2050 ; is collect-garbage
2054 \ ---- Loading files ---- {{{
2056 : load ( addr n -- finalResult )
2061 ok-symbol ( port res )
2065 \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2067 2over read-port ( port res obj )
2072 2dup EOF character-type objeq? if
2073 2drop 2swap close-port
2077 2swap 2drop ( port obj )
2079 global-env obj@ eval ( port res )
2085 \ ---- Standard Library ---- {{{
2087 include scheme-primitives.4th
2091 s" scheme-library.scm" load 2drop
2099 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2100 : repl-body ( -- bool )
2101 cr bold fg green ." > " reset-term
2105 2dup EOF character-type objeq? if
2107 bold fg blue ." Moriturus te saluto." reset-term cr
2111 global-env obj@ eval
2113 fg cyan ." ; " print reset-term
2123 \ Display welcome message
2124 welcome-symbol nil cons global-env obj@ eval 2drop
2129 recoverable-exception of false endof
2130 unrecoverable-exception of true endof