ec97f09761c26f8603c14001277cd08b6f5e7dd8
[scheme.forth.jl.git] / src / scheme.4th
1 vocabulary scheme
2 scheme definitions
3
4 include term-colours.4th
5 include defer-is.4th
6 include catch-throw.4th
7 include integer.4th
8 include float.4th
9
10 include debugging.4th
11
12 defer read
13 defer expand
14 defer eval
15 defer print
16
17 defer collect-garbage
18
19 \ ---- Types ---- {{{
20
21 variable nexttype
22 0 nexttype !
23 : make-type
24     create nexttype @ ,
25     1 nexttype +!
26     does> @ ;
27
28 make-type fixnum-type
29 make-type flonum-type
30 make-type ratnum-type
31 make-type boolean-type
32 make-type character-type
33 make-type string-type
34 make-type nil-type
35 make-type none-type
36 make-type pair-type
37 make-type symbol-type
38 make-type primitive-proc-type
39 make-type compound-proc-type
40 make-type port-type
41 : istype? ( obj type -- obj bool )
42     over = ;
43
44 \ }}}
45
46 \ ---- Exceptions ---- {{{
47
48 variable nextexception
49 1 nextexception !
50 : make-exception 
51     create nextexception @ ,
52     1 nextexception +!
53     does> @ ;
54
55 : except-message:
56     bold fg red
57     ." Exception: "
58 ;
59
60 make-exception recoverable-exception
61 make-exception unrecoverable-exception
62
63 : throw reset-term throw ;
64
65 \ }}}
66
67 \ ---- List-structured memory ---- {{{
68
69 20000 constant scheme-memsize
70
71 create car-cells scheme-memsize allot
72 create car-type-cells scheme-memsize allot
73 create cdr-cells scheme-memsize allot
74 create cdr-type-cells scheme-memsize allot
75
76 create nextfrees scheme-memsize allot
77 :noname
78     scheme-memsize 0 do
79         i 1+ nextfrees i + !
80     loop
81 ; execute
82         
83 variable nextfree
84 0 nextfree !
85
86 : inc-nextfree
87     nextfrees nextfree @ + @
88     nextfree !
89
90     nextfree @ scheme-memsize >= if
91         collect-garbage
92     then
93
94     nextfree @ scheme-memsize >= if
95         except-message: ." Out of memory!" unrecoverable-exception throw
96     then
97 ;
98
99 : cons ( car-obj cdr-obj -- pair-obj )
100     cdr-type-cells nextfree @ + !
101     cdr-cells nextfree @ + !
102     car-type-cells nextfree @ + !
103     car-cells nextfree @ + !
104
105     nextfree @ pair-type
106     inc-nextfree
107 ;
108
109 : car ( pair-obj -- car-obj )
110     drop
111     dup car-cells + @ swap
112     car-type-cells + @
113 ;
114
115 : cdr ( pair-obj -- car-obj )
116     drop
117     dup cdr-cells + @ swap
118     cdr-type-cells + @
119 ;
120
121 : set-car! ( obj pair-obj -- )
122     drop dup
123     rot swap  car-type-cells + !
124     car-cells + !
125 ;
126
127 : set-cdr! ( obj pair-obj -- )
128     drop dup
129     rot swap  cdr-type-cells + !
130     cdr-cells + !
131 ;
132
133 : nil 0 nil-type ;
134 : nil? nil-type istype? ;
135
136 : none 0 none-type ;
137 : none? none-type istype? ;
138
139 : objvar create nil swap , , ;
140
141 : value@ ( objvar -- val ) @ ;
142 : type@ ( objvar -- type ) 1+ @ ;
143 : value! ( newval objvar -- ) ! ;
144 : type! ( newtype objvar -- ) 1+ ! ;
145 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ; 
146 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ; 
147
148 : objeq? ( obj obj -- bool )
149     rot = -rot = and ;
150
151 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
152     >R >R ( a1 a2 b1 b2 )
153     2swap ( b1 b2 a1 a2 )
154     R> R> ( b1 b2 a1 a2 c1 c2 )
155     2swap
156 ;
157
158 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
159     2swap ( a1 a2 c1 c2 b1 b2 )
160     >R >R ( a1 a2 c1 c2 )
161     2swap ( c1 c2 a1 a2 )
162     R> R>
163 ;
164
165 \ }}}
166
167 \ ---- Pre-defined symbols ---- {{{
168
169 objvar symbol-table
170
171 : duplicate-charlist ( charlist -- copy )
172     nil? false = if
173         2dup car 2swap cdr recurse cons
174     then ;
175
176 : charlist-equiv ( charlist charlist -- bool )
177
178     2over 2over
179
180     \ One or both nil
181     nil? -rot 2drop
182     if
183         nil? -rot 2drop
184         if
185             2drop 2drop true exit
186         else
187             2drop 2drop false exit
188         then
189     else
190         nil? -rot 2drop
191         if
192             2drop 2drop false exit
193         then
194     then
195
196     2over 2over
197
198     \ Neither nil
199     car drop -rot car drop = if
200             cdr 2swap cdr recurse
201         else
202             2drop 2drop false
203     then
204 ;
205
206 : charlist>symbol ( charlist -- symbol-obj )
207
208     symbol-table obj@
209
210     begin
211         nil? false =
212     while
213         2over 2over
214         car drop pair-type
215         charlist-equiv if
216             2swap 2drop
217             car
218             exit
219         else
220             cdr
221         then
222     repeat
223
224     2drop
225     drop symbol-type 2dup
226     symbol-table obj@ cons
227     symbol-table obj!
228 ;
229
230
231 : cstr>charlist ( addr n -- charlist )
232     dup 0= if
233         2drop nil
234     else
235         2dup drop @ character-type 2swap
236         swap 1+ swap 1-
237         recurse
238
239         cons
240     then
241 ;
242
243 : create-symbol ( -- )
244     bl word
245     count
246
247     cstr>charlist
248     charlist>symbol
249
250     create swap , ,
251     does> dup @ swap 1+ @
252 ;
253
254 create-symbol quote             quote-symbol
255 create-symbol quasiquote        quasiquote-symbol
256 create-symbol unquote           unquote-symbol
257 create-symbol unquote-splicing  unquote-splicing-symbol
258 create-symbol define            define-symbol
259 create-symbol define-macro      define-macro-symbol
260 create-symbol set!              set!-symbol
261 create-symbol ok                ok-symbol
262 create-symbol if                if-symbol
263 create-symbol lambda            lambda-symbol
264 create-symbol λ                 λ-symbol
265 create-symbol eof               eof-symbol
266 create-symbol no-match          no-match-symbol
267
268 \ Symbol to be bound to welcome message procedure by library
269 create-symbol welcome           welcome-symbol
270
271 \ }}}
272
273 \ ---- Port I/O ----  {{{
274
275 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
276
277 : fileport>fid ( fileport -- fid )
278     drop pair-type car drop ;
279
280 : get-last-peek ( fileport -- char/nil )
281     drop pair-type cdr ;
282
283 : set-last-peek ( char/nil fileport -- )
284     drop pair-type set-cdr!
285 ;
286
287 : fid>fileport ( fid -- fileport )
288     fixnum-type nil cons drop port-type ;
289
290 : open-input-file ( addr n -- fileport )
291     r/o open-file drop fid>fileport
292 ;
293
294 : close-port ( fileport -- )
295     fileport>fid close-file drop
296 ;
297
298 objvar console-i/o-port
299 0 fixnum-type nil cons drop port-type console-i/o-port obj!
300
301 objvar current-input-port
302 console-i/o-port obj@ current-input-port obj!
303
304 : read-char ( port -- char ) 
305     2dup get-last-peek nil? if
306         2drop
307         2dup console-i/o-port obj@ objeq? if
308             2drop
309             key character-type
310         else
311             fileport>fid pad 1 rot read-file 0= if
312                 eof-symbol
313             else
314                 pad @ character-type
315             then
316         then
317     else
318         nil 2rot set-cdr!
319     then
320 ;
321
322 : peek-char ( port -- char )
323     2dup get-last-peek nil? if
324         2drop 2dup read-char
325         2dup 2rot set-last-peek
326     else
327         2swap 2drop
328     then
329 ;
330
331 variable read-line-buffer-span
332 variable read-line-buffer-offset
333
334 ( Hack to save original read-line while we transition to new one. )
335 : orig-read-line immediate
336     ['] read-line , ;
337
338 : read-line ( port -- string )
339
340     2dup get-last-peek
341     nil? if
342         2drop
343         0 read-line-buffer-offset !
344     else
345         2over nil 2swap set-last-peek
346         2dup drop '\n' = if
347             2drop nil nil cons exit
348         else
349             drop pad !
350             1 read-line-buffer-offset !
351         then
352     then
353
354     2dup console-i/o-port obj@ objeq? if
355         2drop
356         pad read-line-buffer-offset @ + 200 expect cr
357         span @ read-line-buffer-offset @ + read-line-buffer-span !
358     else
359         pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
360         drop swap read-line-buffer-offset @ + read-line-buffer-span !
361     then
362
363     nil
364     
365     begin
366         read-line-buffer-span @ 0>
367     while
368         pad read-line-buffer-span @ 1- + @ character-type 2swap cons
369         -1 read-line-buffer-span +!
370     repeat
371
372     nil? if
373         nil cons drop string-type
374     else
375         drop string-type
376     then
377 ;
378
379 : read-port ( fileport -- obj )
380     current-input-port obj!
381     read ;
382
383 : read-console ( -- obj )
384     console-i/o-port obj@ read-port ;
385
386 \ }}}
387
388 \ ---- Environments ---- {{{
389
390 : enclosing-env ( env -- env )
391     cdr ;
392
393 : first-frame ( env -- frame )
394     car ;
395
396 : make-frame ( vars vals -- frame )
397     cons ;
398
399 : frame-vars ( frame -- vars )
400     car ;
401
402 : frame-vals ( frame -- vals )
403     cdr ;
404
405 : add-binding ( var val frame -- )
406     2swap 2over frame-vals cons
407     2over set-cdr!
408     2swap 2over frame-vars cons
409     2swap set-car!
410 ;
411
412 : extend-env ( vars vals env -- env )
413     >R >R
414     make-frame
415     R> R>
416     cons
417 ;
418
419 objvar vars
420 objvar vals
421
422 : get-vars-vals-frame ( var frame -- bool )
423     2dup frame-vars vars obj!
424     frame-vals vals obj!
425
426     begin
427         vars obj@ nil objeq? false =
428     while
429         2dup vars obj@ car objeq? if
430             2drop true
431             exit
432         then
433
434         vars obj@ cdr vars obj!
435         vals obj@ cdr vals obj!
436     repeat
437
438     2drop false
439 ;
440
441 : get-vars-vals ( var env -- vars? vals? bool )
442
443     begin
444         nil? false =
445     while
446         2over 2over first-frame
447         get-vars-vals-frame if
448             2drop 2drop
449             vars obj@ vals obj@ true
450             exit
451         then
452
453         enclosing-env
454     repeat
455
456     2drop 2drop
457     false
458 ;
459
460 hide vars
461 hide vals
462
463 objvar var
464
465 : lookup-var ( var env -- val )
466     2over var obj!
467     get-vars-vals if
468         2swap 2drop car
469     else
470         except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception  throw
471     then
472 ;
473
474 : set-var ( var val env -- )
475     >R >R 2swap R> R> ( val var env )
476     2over var obj!
477     get-vars-vals if
478         2swap 2drop ( val vals )
479         set-car!
480     else
481         except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw
482     then
483 ;
484
485 hide var
486
487 objvar env
488
489 : define-var ( var val env -- )
490     env obj! 
491
492     2over env obj@ ( var val var env )
493     get-vars-vals if
494         2swap 2drop ( var val vals )
495         set-car!
496         2drop
497     else
498         env obj@
499         first-frame ( var val frame )
500         add-binding
501     then
502 ;
503
504 hide env
505
506 : make-procedure ( params body env -- proc )
507     nil
508     cons cons cons
509     drop compound-proc-type
510 ;
511
512 objvar global-env
513 nil nil nil extend-env
514 global-env obj!
515
516 \ }}}
517
518 \ ---- Primitives ---- {{{
519
520 : make-primitive ( cfa -- )
521     bl word
522     count
523
524     cstr>charlist
525     charlist>symbol
526   
527     rot primitive-proc-type ( var prim )
528     global-env obj@ define-var
529 ;
530
531 : ensure-arg-count ( args n -- )
532     dup 0= if
533         drop nil objeq? false = if
534             except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
535         then
536     else
537         -rot nil? if
538             except-message: ." Too few arguments for primitive procedure." recoverable-exception  throw
539         then
540         
541         cdr rot 1- recurse
542     then
543 ;
544
545 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
546     dup 0= if
547         drop nil objeq? false = if
548             except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
549         then
550     else
551         -rot nil? if
552             except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
553         then
554
555         2dup cdr 2swap car ( ... t1 n args' arg1 )
556         2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
557         istype? false = if
558             except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
559         then
560
561         2drop recurse
562     then
563
564 ;
565
566 : push-args-to-stack ( args -- arg1 arg2 ... argn )
567     begin
568         nil? false =
569     while
570         2dup car 2swap cdr
571     repeat
572
573     2drop
574 ;
575
576 : add-fa-checks ( cfa n -- cfa' )
577     here current @ 1+ dup @ , !
578     0 ,
579     here -rot
580     docol ,
581     ['] 2dup , ['] lit , , ['] ensure-arg-count ,
582     ['] push-args-to-stack ,
583     ['] lit , , ['] execute ,
584     ['] exit ,
585 ;
586
587 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
588     here current @ 1+ dup @ , !
589     0 ,
590     here >R
591     docol ,
592     ['] 2dup ,
593     ['] >R , ['] >R ,
594
595     dup ( cfa t1 t2 ... tn n m )
596     
597     begin
598         ?dup 0>
599     while
600         rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
601         1-
602     repeat
603
604     ['] R> , ['] R> ,
605
606     ['] lit , , ['] ensure-arg-type-and-count ,
607
608     ['] push-args-to-stack ,
609     ['] lit , , ['] execute ,
610     ['] exit ,
611
612     R>
613 ;
614
615 : make-fa-primitive ( cfa n -- )
616     add-fa-checks make-primitive ;
617
618 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
619     add-fa-type-checks make-primitive ;
620
621 : arg-type-error
622             bold fg red ." Incorrect argument type." reset-term cr
623             abort
624 ;
625
626 : ensure-arg-type ( arg type -- arg )
627     istype? false = if
628         except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
629     then
630 ;
631
632
633 \ }}}
634
635 \ ---- Macros ---- {{{
636
637 objvar macro-table
638
639 ( Look up macro in macro table. Returns nil if
640   no macro is found. )
641 : lookup-macro ( name_symbol -- proc )
642
643     symbol-type istype? invert if
644         \ Early exit if argument is not a symbol
645         2drop nil exit
646     then
647     
648     macro-table obj@
649
650     begin
651         nil? false =
652     while
653         2over 2over
654         car car objeq? if
655             2swap 2drop
656             car cdr
657             exit
658         then
659
660         cdr
661     repeat
662
663     2swap 2drop
664 ;
665
666 : make-macro ( name_symbol params body env -- )
667     make-procedure
668
669     2swap ( proc name_symbol )
670
671     macro-table obj@
672
673     begin
674         nil? false =
675     while
676         2over 2over ( proc name table name table )
677         car car objeq? if
678             2swap 2drop ( proc table )
679             car ( proc entry )
680             set-cdr!
681             exit
682         then
683
684         cdr
685     repeat
686
687     2drop
688
689     2swap cons
690     macro-table obj@ cons
691     macro-table obj!
692 ;
693
694 \ }}}
695
696 \ ---- Read ---- {{{
697
698 variable parse-idx
699 variable stored-parse-idx
700 create parse-str 161 allot
701 variable parse-str-span
702
703 create parse-idx-stack 10 allot 
704 variable parse-idx-sp
705 parse-idx-stack parse-idx-sp !
706
707 : push-parse-idx
708     parse-idx @ parse-idx-sp @ !
709     1 parse-idx-sp +!
710 ;
711
712 : pop-parse-idx
713     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
714
715     1 parse-idx-sp -!
716
717     parse-idx-sp @ @ parse-idx ! ;
718
719
720 : append-newline
721     '\n' parse-str parse-str-span @ + !
722     1 parse-str-span +! ;
723
724 : append-eof
725     4 parse-str parse-str-span @ + !
726     1 parse-str-span +!  ;
727
728 : empty-parse-str
729     0 parse-str-span !
730     0 parse-idx ! ;
731
732 : getline
733     current-input-port obj@ console-i/o-port obj@ objeq? if
734         parse-str 160 expect cr
735         span @ parse-str-span !
736     else
737         parse-str 160 current-input-port obj@ fileport>fid orig-read-line
738         drop swap parse-str-span !
739
740         parse-str-span @ 0= and if append-eof then
741     then
742     append-newline
743     0 parse-idx ! ;
744
745 : inc-parse-idx
746     1 parse-idx +! ;
747
748 : dec-parse-idx
749     1 parse-idx -! ;
750
751 : charavailable? ( -- bool )
752     parse-str-span @ parse-idx @ > ;
753
754 : nextchar ( -- char )
755     charavailable? false = if getline then
756     parse-str parse-idx @ + @ ;
757
758 : '\t' 9 ;
759 : whitespace? ( -- bool )
760     nextchar BL = 
761     nextchar '\n' =
762     nextchar '\t' =
763     or or ;
764
765 : EOF 4 ; 
766 : eof? ( -- bool )
767     nextchar EOF = ;
768
769 : delim? ( -- bool )
770     whitespace?
771     nextchar [char] ( = or
772     nextchar [char] ) = or
773 ;
774
775 : commentstart? ( -- bool )
776     nextchar [char] ; = ;
777
778 : eatspaces
779
780     false \ Indicates whether or not we're eating a comment
781
782     begin
783         dup whitespace? or commentstart? or
784     while
785         dup nextchar '\n' = and if
786             invert \ Stop eating comment
787         else
788             dup false = commentstart? and if   
789                 invert \ Begin eating comment
790             then
791         then
792
793         inc-parse-idx
794     repeat
795     drop
796 ;
797
798 : digit? ( -- bool )
799     nextchar [char] 0 >=
800     nextchar [char] 9 <=
801     and ;
802
803 : minus? ( -- bool )
804     nextchar [char] - = ;
805
806 : plus? ( -- bool )
807     nextchar [char] + = ;
808
809 : fixnum? ( -- bool )
810     minus? plus? or if
811         inc-parse-idx
812
813         delim? if
814             dec-parse-idx
815             false exit
816         else
817             dec-parse-idx
818         then
819     else
820         digit? false = if
821             false exit
822         then
823     then
824
825     push-parse-idx
826     inc-parse-idx
827
828     begin digit? while
829         inc-parse-idx
830     repeat
831
832     delim? pop-parse-idx
833 ;
834
835 : flonum? ( -- bool )
836     push-parse-idx
837
838     minus? plus? or if
839         inc-parse-idx
840     then
841
842     \ Record starting parse idx:
843     \ Want to detect whether any characters (following +/-) were eaten.
844     parse-idx @
845
846     begin digit? while
847             inc-parse-idx
848     repeat
849
850     [char] . nextchar = if
851         inc-parse-idx
852         begin digit? while
853                 inc-parse-idx
854         repeat
855     then
856
857     [char] e nextchar = [char] E nextchar = or if
858         inc-parse-idx
859
860         minus? plus? or if
861             inc-parse-idx
862         then
863
864         digit? invert if
865             drop pop-parse-idx false exit
866         then
867
868         begin digit? while
869                 inc-parse-idx
870         repeat
871     then
872
873     \ This is a real number if characters were
874     \ eaten and the next characer is a delimiter.
875     parse-idx @ < delim? and
876
877     pop-parse-idx
878 ;
879
880 : ratnum? ( -- bool )
881     push-parse-idx
882
883     minus? plus? or if
884         inc-parse-idx
885     then
886
887     digit? invert if
888         pop-parse-idx false exit
889     else
890         inc-parse-idx
891     then
892
893     begin digit? while
894         inc-parse-idx
895     repeat
896
897     [char] / nextchar <> if
898         pop-parse-idx false exit
899     else
900         inc-parse-idx
901     then
902
903     digit? invert if
904         pop-parse-idx false exit
905     else
906         inc-parse-idx
907     then
908
909     begin digit? while
910         inc-parse-idx
911     repeat
912
913     delim? pop-parse-idx
914 ;
915
916 : boolean? ( -- bool )
917     nextchar [char] # <> if false exit then
918
919     push-parse-idx
920     inc-parse-idx
921
922     nextchar [char] t <>
923     nextchar [char] f <>
924     and if pop-parse-idx false exit then
925
926     inc-parse-idx
927     delim? if
928         pop-parse-idx
929         true
930     else
931         pop-parse-idx
932         false
933     then
934 ;
935
936 : str-equiv? ( str -- bool )
937
938     push-parse-idx
939
940     true -rot
941
942     swap dup rot + swap
943
944     do
945         i @ nextchar <> if
946             drop false
947             leave
948         then
949
950         inc-parse-idx
951     loop
952
953     delim? false = if drop false then
954
955     pop-parse-idx
956 ;
957
958 : character? ( -- bool )
959     nextchar [char] # <> if false exit then
960
961     push-parse-idx
962     inc-parse-idx
963
964     nextchar [char] \ <> if pop-parse-idx false exit then
965
966     inc-parse-idx
967
968     S" newline" str-equiv? if pop-parse-idx true exit then
969     S" space" str-equiv? if pop-parse-idx true exit then
970     S" tab" str-equiv? if pop-parse-idx true exit then
971
972     charavailable? false = if pop-parse-idx false exit then
973
974     pop-parse-idx true
975 ;
976
977 : pair? ( -- bool )
978     nextchar [char] ( = ;
979
980 : string? ( -- bool )
981     nextchar [char] " = ;
982
983 : readfixnum ( -- fixnum )
984     plus? minus? or if
985         minus?
986         inc-parse-idx
987     else
988         false
989     then
990
991     0
992
993     begin digit? while
994         10 * nextchar [char] 0 - +
995         inc-parse-idx
996     repeat
997
998     swap if negate then
999
1000     fixnum-type
1001 ;
1002
1003 : readflonum ( -- flonum )
1004     readfixnum drop
1005     dup 0< swap abs i->f
1006
1007     [char] . nextchar = if
1008         inc-parse-idx
1009
1010         10.0 ( f exp )
1011
1012         begin digit? while
1013             nextchar [char] 0 - i->f ( f exp d )
1014             over f/ rot f+ ( exp f' )
1015             swap 10.0 f* ( f' exp' )
1016             inc-parse-idx
1017         repeat
1018
1019         drop
1020     then
1021
1022     [char] e nextchar = [char] E nextchar = or if
1023         inc-parse-idx
1024         10.0
1025         readfixnum drop i->f
1026         f^ f*
1027     then
1028
1029     swap if
1030         -1.0 f*
1031     then
1032
1033     flonum-type
1034 ;
1035
1036 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1037     drop swap drop
1038     simplify
1039
1040     dup 1 = if
1041         drop fixnum-type
1042     else
1043         fixnum-type swap fixnum-type
1044         cons drop ratnum-type
1045     then
1046 ;
1047
1048 : readratnum ( -- ratnum )
1049     readfixnum inc-parse-idx readfixnum
1050     make-rational
1051 ;
1052
1053 : readbool ( -- bool-obj )
1054     inc-parse-idx
1055     
1056     nextchar [char] f = if
1057         false
1058     else
1059         true
1060     then
1061
1062     inc-parse-idx
1063
1064     boolean-type
1065 ;
1066
1067 : readchar ( -- char-obj )
1068     inc-parse-idx
1069     inc-parse-idx
1070
1071     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1072     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1073     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1074
1075     nextchar character-type
1076
1077     inc-parse-idx
1078 ;
1079
1080 : readstring ( -- charlist )
1081
1082     nil nil
1083
1084     begin
1085         nextchar [char] " <>
1086     while
1087         nextchar [char] \ = if
1088             inc-parse-idx
1089             nextchar case
1090                 [char] n of '\n' endof
1091                 [char] " of [char] " endof
1092                 [char] \
1093             endcase
1094         else
1095             nextchar
1096         then
1097         inc-parse-idx character-type
1098         nil cons
1099
1100         ( firstchar prevchar thischar )
1101
1102         2swap nil? if
1103             2drop 2swap 2drop 2dup  ( thischar thischar )
1104         else
1105             ( firstchar thischar prevchar )
1106             2over 2swap  set-cdr! ( firstchar thischar )
1107         then
1108     repeat
1109
1110     \ Discard previous character
1111     2drop
1112
1113     inc-parse-idx
1114     delim? false = if
1115         bold fg red
1116         ." No delimiter following right double quote. Aborting." cr
1117         reset-term abort
1118     then
1119
1120     dec-parse-idx
1121
1122     nil? if
1123         nil cons
1124     then
1125     drop string-type
1126 ;
1127
1128 : readsymbol ( -- charlist )
1129     delim? if nil exit then
1130
1131     nextchar inc-parse-idx character-type
1132
1133     recurse
1134
1135     cons
1136 ;
1137
1138 : readpair ( -- pairobj )
1139     eatspaces
1140
1141     \ Empty lists
1142     nextchar [char] ) = if
1143         inc-parse-idx
1144
1145         delim? false = if
1146             bold fg red
1147             ." No delimiter following right paren. Aborting." cr
1148             reset-term abort
1149         then
1150
1151         dec-parse-idx
1152
1153         0 nil-type exit
1154     then
1155
1156     \ Read first pair element
1157     read
1158
1159     \ Pairs
1160     eatspaces
1161     nextchar [char] . = if
1162         inc-parse-idx
1163
1164         delim? false = if
1165             bold fg red
1166             ." No delimiter following '.'. Aborting." cr
1167             reset-term abort
1168         then
1169
1170         eatspaces read
1171     else
1172         recurse
1173     then
1174
1175     eatspaces
1176
1177     cons
1178 ;
1179
1180 \ Parse a scheme expression
1181 :noname ( -- obj )
1182
1183     eatspaces
1184
1185     fixnum? if
1186         readfixnum
1187         exit
1188     then
1189
1190     flonum? if
1191         readflonum
1192         exit
1193     then
1194
1195     ratnum? if
1196         readratnum
1197         exit
1198     then
1199
1200     boolean? if
1201         readbool
1202         exit
1203     then
1204
1205     character? if
1206         readchar
1207         exit
1208     then
1209
1210     string? if
1211         inc-parse-idx
1212
1213         readstring
1214
1215         nextchar [char] " <> if
1216             bold red ." Missing closing double-quote." reset-term cr
1217             abort
1218         then
1219
1220         inc-parse-idx
1221
1222         exit
1223     then
1224
1225     pair? if
1226         inc-parse-idx
1227
1228         eatspaces
1229
1230         readpair
1231
1232         eatspaces
1233
1234         nextchar [char] ) <> if
1235             bold red ." Missing closing paren." reset-term cr
1236             abort
1237         then
1238
1239         inc-parse-idx
1240
1241         exit
1242     then
1243
1244     nextchar [char] ' = if
1245         inc-parse-idx
1246         quote-symbol recurse nil cons cons exit
1247     then
1248
1249     nextchar [char] ` = if
1250         inc-parse-idx
1251         quasiquote-symbol recurse nil cons cons exit
1252     then
1253
1254     nextchar [char] , = if
1255         inc-parse-idx
1256         nextchar [char] @ = if
1257             inc-parse-idx
1258             unquote-splicing-symbol recurse nil cons cons exit
1259         else
1260             unquote-symbol recurse nil cons cons exit
1261         then
1262     then
1263
1264     eof? if
1265         EOF character-type
1266         inc-parse-idx
1267         exit
1268     then
1269
1270     \ Anything else is parsed as a symbol
1271     readsymbol charlist>symbol
1272
1273     \ Replace λ with lambda
1274     2dup λ-symbol objeq? if
1275         2drop lambda-symbol
1276     then
1277     
1278
1279 ; is read
1280
1281 \ }}}
1282
1283 \ ---- Eval ---- {{{
1284
1285 : self-evaluating? ( obj -- obj bool )
1286     boolean-type istype? if true exit then
1287     fixnum-type istype? if true exit then
1288     flonum-type istype? if true exit then
1289     ratnum-type istype? if true exit then
1290     character-type istype? if true exit then
1291     string-type istype? if true exit then
1292     nil-type istype? if true exit then
1293     none-type istype? if true exit then
1294
1295     false
1296 ;
1297
1298 : tagged-list? ( obj tag-obj -- obj bool )
1299     2over 
1300     pair-type istype? false = if
1301         2drop 2drop false
1302     else
1303         car objeq?
1304     then ;
1305
1306 : quote? ( obj -- obj bool )
1307     quote-symbol tagged-list?  ;
1308
1309 : quote-body ( quote-obj -- quote-body-obj )
1310     cdr car ;
1311
1312 : quasiquote? ( obj -- obj bool )
1313     quasiquote-symbol tagged-list? ;
1314
1315 : unquote? ( obj -- obj bool )
1316     unquote-symbol tagged-list? ;
1317
1318 : unquote-splicing? ( obj -- obj bool )
1319     unquote-splicing-symbol tagged-list? ;
1320
1321 : eval-unquote ( env obj -- res )
1322     cdr ( env args )
1323
1324     nil? if
1325         except-message: ." no arguments to unquote." recoverable-exception throw
1326     then
1327
1328     2dup cdr
1329     nil? false = if
1330         except-message: ." too many arguments to unquote." recoverable-exception throw
1331     then
1332
1333     2drop car 2swap eval
1334 ;
1335
1336 ( Create a new list from elements of l1 consed on to l2 )
1337 : join-lists ( l2 l1 -- l3 )
1338     nil? if 2drop exit then
1339
1340     2dup car
1341     -2rot cdr
1342     recurse cons
1343 ;
1344
1345 defer eval-quasiquote-item
1346 : eval-quasiquote-pair ( env obj -- res )
1347     2over 2over ( env obj env obj )
1348
1349     cdr eval-quasiquote-item
1350
1351     -2rot car ( cdritem env objcar )
1352
1353     unquote-splicing? if
1354         eval-unquote ( cdritems caritem )
1355
1356         2swap nil? if
1357             2drop
1358         else
1359             2swap join-lists
1360         then
1361     else
1362         eval-quasiquote-item ( cdritems caritem )
1363         2swap cons
1364     then
1365
1366 ;
1367
1368 :noname ( env obj )
1369     nil? if
1370         2swap 2drop exit
1371     then
1372
1373     unquote? if
1374         eval-unquote exit
1375     then
1376
1377     pair-type istype? if
1378         eval-quasiquote-pair exit
1379     then
1380
1381     2swap 2drop
1382 ; is eval-quasiquote-item
1383
1384 : eval-quasiquote ( obj env -- res )
1385     2swap cdr ( env args )
1386
1387     nil? if
1388         except-message: ." no arguments to quasiquote." recoverable-exception throw
1389     then
1390
1391     2dup cdr ( env args args-cdr )
1392     nil? false = if
1393         except-message: ." too many arguments to quasiquote." recoverable-exception throw
1394     then
1395
1396     2drop car ( env arg )
1397
1398     eval-quasiquote-item
1399 ;
1400
1401 : variable? ( obj -- obj bool )
1402     symbol-type istype? ;
1403
1404 : definition? ( obj -- obj bool )
1405     define-symbol tagged-list? ;
1406
1407 : definition-var ( obj -- var )
1408     cdr car ;
1409
1410 : definition-val ( obj -- val )
1411     cdr cdr car ;
1412
1413 : eval-definition ( obj env -- res )
1414     2swap
1415     2over 2over
1416     definition-val 2swap
1417     eval
1418
1419     2swap definition-var 2swap
1420
1421     2rot
1422     define-var
1423
1424     ok-symbol
1425 ;
1426
1427 : assignment? ( obj -- obj bool )
1428     set!-symbol tagged-list? ;
1429
1430 : assignment-var ( obj -- var )
1431     cdr car ;
1432     
1433 : assignment-val ( obj -- val )
1434     cdr cdr car ;
1435
1436 : eval-assignment ( obj env -- res )
1437     2swap 
1438     2over 2over ( env obj env obj )
1439     assignment-val 2swap ( env obj valexp env )
1440     eval  ( env obj val )
1441     
1442     2swap assignment-var 2swap ( env var val )
1443
1444     2rot ( var val env )
1445     set-var
1446
1447     ok-symbol
1448 ;
1449
1450 : macro-definition? ( obj -- obj bool )
1451     define-macro-symbol tagged-list? ;
1452
1453 : macro-definition-name ( exp -- mname )
1454     cdr car car ;
1455
1456 : macro-definition-params ( exp -- params )
1457     cdr car cdr ;
1458
1459 : macro-definition-body ( exp -- body )
1460     cdr cdr ;
1461
1462 objvar env
1463 : eval-define-macro ( obj env -- res )
1464     env obj!
1465
1466     2dup macro-definition-name 2swap ( name obj )
1467     2dup macro-definition-params 2swap ( name params obj )
1468     macro-definition-body ( name params body )
1469
1470     env obj@ ( name params body env )
1471
1472     make-macro
1473
1474     ok-symbol
1475 ;
1476 hide env
1477
1478 : if? ( obj -- obj bool )
1479     if-symbol tagged-list? ;
1480
1481 : if-predicate ( ifobj -- pred )
1482     cdr car ;
1483
1484 : if-consequent ( ifobj -- conseq )
1485     cdr cdr car ;
1486
1487 : if-alternative ( ifobj -- alt|none )
1488     cdr cdr cdr
1489     nil? if
1490         2drop none
1491     else
1492         car
1493     then ;
1494
1495 : false? ( boolobj -- boolean )
1496     boolean-type istype? if
1497         false boolean-type objeq?
1498     else
1499         2drop false
1500     then
1501 ;
1502
1503 : true? ( boolobj -- bool )
1504     false? invert ;
1505
1506 : lambda? ( obj -- obj bool )
1507     lambda-symbol tagged-list? ;
1508
1509 : lambda-parameters ( obj -- params )
1510     cdr car ;
1511
1512 : lambda-body ( obj -- body )
1513     cdr cdr ;
1514
1515 : eval-sequence ( explist env -- finalexp env )
1516     ( Evaluates all bar the final expressions in
1517       an an expression list. The final expression
1518       is returned to allow for tail optimization. )
1519
1520     2swap ( env explist )
1521
1522     \ Abort on empty list
1523     nil? if
1524         2drop none
1525         2swap exit
1526     then
1527
1528     begin
1529         2dup cdr ( env explist nextexplist )
1530         nil? false =
1531     while
1532         -2rot car 2over ( nextexplist env exp env )
1533         eval
1534         2drop \ discard result
1535         2swap ( env nextexplist )
1536     repeat
1537
1538     2drop car 2swap ( finalexp env )
1539 ;
1540
1541 : application? ( obj -- obj bool )
1542     pair-type istype? ;
1543
1544 : operator ( obj -- operator )
1545     car ;
1546
1547 : operands ( obj -- operands )
1548     cdr ;
1549
1550 : nooperands? ( operands -- bool )
1551     nil objeq? ;
1552
1553 : first-operand ( operands -- operand )
1554     car ;
1555
1556 : rest-operands ( operands -- other-operands )
1557     cdr ;
1558
1559 : list-of-vals ( args env -- vals )
1560     2swap
1561
1562     2dup nooperands? if
1563         2swap 2drop
1564     else
1565         2over 2over first-operand 2swap eval
1566         -2rot rest-operands 2swap recurse
1567         cons
1568     then
1569 ;
1570
1571 : procedure-params ( proc -- params )
1572     drop pair-type car ;
1573
1574 : procedure-body ( proc -- body )
1575     drop pair-type cdr car ;
1576
1577 : procedure-env ( proc -- body )
1578     drop pair-type cdr cdr car ;
1579
1580 ( Ensure terminating symbol arg name is handled
1581   specially to allow for variadic procedures. )
1582 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1583     nil? if
1584         2over nil? false = if
1585             except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1586         else
1587             2drop
1588         then
1589         exit
1590     then
1591
1592     symbol-type istype? if
1593         nil cons
1594         2swap
1595         nil cons
1596         2swap
1597         exit
1598     then
1599
1600     2over
1601     nil? if
1602         except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1603     else
1604         cdr
1605     then
1606
1607     2over cdr
1608
1609     recurse ( argvals argnames argvals'' argnames'' )
1610     2rot car 2swap cons  ( argvals argvals'' argnames' )
1611     2rot car 2rot cons ( argnames' argvals' )
1612     2swap
1613 ;
1614
1615 : apply ( proc argvals -- result )
1616         2swap dup case
1617             primitive-proc-type of
1618                 drop execute     
1619             endof
1620
1621             compound-proc-type of
1622                 2dup procedure-body ( argvals proc body )
1623                 -2rot 2dup procedure-params ( body argvals proc argnames )
1624                 -2rot procedure-env ( body argnames argvals procenv )
1625
1626                 -2rot 2swap
1627                 flatten-proc-args
1628                 2swap 2rot
1629
1630                 extend-env ( body env )
1631
1632                 eval-sequence
1633
1634                 R> drop ['] eval goto-deferred  \ Tail call optimization
1635             endof
1636
1637             except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1638         endcase
1639 ;
1640
1641 :noname ( obj env -- result )
1642     2swap
1643
1644     \ --- DEBUG ---
1645     ( 
1646       fg yellow ." Evaluating: " bold 2dup print reset-term
1647       space fg green ." PS: " bold depth . reset-term
1648       space fg blue  ." RS: " bold RSP@ RSP0 - . reset-term cr
1649     )
1650
1651     self-evaluating? if
1652         2swap 2drop
1653         exit
1654     then
1655
1656     quote? if
1657         quote-body
1658         2swap 2drop
1659         exit
1660     then
1661
1662     quasiquote? if
1663         2swap eval-quasiquote
1664         exit
1665     then
1666
1667     variable? if
1668         2swap lookup-var
1669         exit
1670     then
1671
1672     definition? if
1673         2swap eval-definition
1674         exit
1675     then
1676
1677     assignment? if
1678         2swap eval-assignment
1679         exit
1680     then
1681
1682     macro-definition? if
1683         2swap eval-define-macro
1684         exit
1685     then
1686
1687     if? if
1688         2over 2over
1689         if-predicate
1690         2swap eval 
1691
1692         true? if
1693             if-consequent
1694         else
1695             if-alternative
1696         then
1697
1698         2swap
1699         ['] eval goto-deferred
1700     then
1701
1702     lambda? if
1703         2dup lambda-parameters
1704         2swap lambda-body
1705         2rot make-procedure
1706         exit
1707     then
1708
1709     application? if
1710
1711         2over 2over ( env exp env exp )
1712         operator ( env exp env opname )
1713
1714         2swap eval ( env exp proc )
1715
1716         -2rot ( proc env exp )
1717         operands 2swap ( proc operands env )
1718         list-of-vals ( proc argvals )
1719
1720         apply
1721         exit
1722     then
1723
1724     except-message: ." tried to evaluate object with unknown type." recoverable-exception throw
1725 ; is eval
1726
1727 \ }}}
1728
1729 \ ---- Macro Expansion ---- {{{
1730
1731 ( Simply evaluates the given procedure with expbody as its argument. )
1732 : macro-eval ( proc expbody -- result )
1733     2swap
1734     2dup procedure-body ( expbody proc procbody )
1735     -2rot 2dup procedure-params ( procbody expbody proc argnames )
1736     -2rot procedure-env ( procbody argnames expbody procenv )
1737     
1738     -2rot 2swap
1739     flatten-proc-args
1740     2swap 2rot
1741
1742     extend-env eval-sequence eval
1743 ;
1744
1745 : expand-macro ( exp -- result )
1746     pair-type istype? invert if exit then
1747     2dup car symbol-type istype? invert if 2drop exit then
1748     
1749     lookup-macro nil? if
1750         2drop exit then
1751
1752     2over cdr macro-eval
1753
1754     2dup no-match-symbol objeq? if
1755         2drop exit
1756     else
1757         2swap 2drop
1758     then
1759
1760     R> drop ['] expand goto-deferred
1761 ;
1762
1763 : expand-quasiquote-item ( exp -- result )
1764     nil? if exit then
1765
1766     unquote? if
1767         unquote-symbol 2swap cdr car expand nil cons cons
1768         exit
1769     then
1770
1771     unquote-splicing? if
1772         unquote-splicing-symbol 2swap cdr car expand nil cons cons
1773         exit
1774     then
1775     
1776     pair-type istype? if
1777         2dup car recurse
1778         2swap cdr recurse
1779         cons
1780     then
1781 ;
1782
1783 : expand-quasiquote ( exp -- result )
1784     quasiquote-symbol 2swap cdr
1785
1786     expand-quasiquote-item
1787
1788     cons ;
1789
1790 : expand-definition ( exp -- result )
1791     define-symbol 2swap
1792
1793     2dup definition-var
1794     2swap definition-val expand
1795     nil ( define var val' nil )
1796
1797     cons cons cons ;
1798
1799 : expand-assignment ( exp -- result )
1800     set!-symbol 2swap
1801
1802     2dup assignment-var
1803     2swap assignment-val expand
1804     nil ( define var val' nil )
1805
1806     cons cons cons ;
1807
1808 : expand-list ( exp -- res )
1809     nil? if exit then
1810
1811     2dup car expand
1812     2swap cdr recurse
1813
1814     cons ;
1815
1816 : macro-definition-nameparams
1817     cdr car ;
1818
1819 : expand-define-macro ( exp -- res )
1820     define-macro-symbol 2swap
1821     2dup macro-definition-nameparams
1822     2swap macro-definition-body expand-list
1823
1824     cons cons ;
1825
1826 : expand-lambda ( exp -- res )
1827     lambda-symbol 2swap
1828     2dup lambda-parameters
1829     2swap lambda-body expand-list
1830
1831     cons cons ;
1832
1833 : expand-if ( exp -- res )
1834     if-symbol 2swap
1835     
1836     2dup if-predicate expand
1837     2swap 2dup if-consequent expand
1838     2swap if-alternative none? if
1839         2drop nil
1840     else
1841         expand nil cons
1842     then
1843
1844     cons cons cons ;
1845
1846 : expand-application ( exp -- res )
1847     2dup operator expand
1848     2swap operands expand-list
1849
1850     cons ;
1851
1852 :noname ( exp -- result )
1853     expand-macro
1854
1855     self-evaluating? if exit then
1856
1857     quote? if exit then
1858
1859     quasiquote? if expand-quasiquote exit then
1860
1861     definition? if expand-definition exit then
1862
1863     assignment? if expand-assignment exit then
1864
1865     macro-definition? if expand-define-macro exit then
1866
1867     lambda? if expand-lambda exit then
1868
1869     if? if expand-if exit then
1870
1871     application? if expand-application exit then
1872
1873 ; is expand
1874
1875 \ }}}
1876
1877 \ ---- Print ---- {{{
1878
1879 : printfixnum ( fixnum -- ) drop 0 .R ;
1880
1881 : printflonum ( flonum -- ) drop f. ;
1882
1883 : printratnum ( ratnum -- )
1884     drop pair-type 2dup
1885     car print ." /" cdr print
1886 ;
1887
1888 : printbool ( bool -- )
1889     drop if
1890         ." #t"
1891     else
1892         ." #f"
1893     then
1894 ;
1895
1896 : printchar ( charobj -- )
1897     drop
1898     case
1899         9 of ." #\tab" endof
1900         bl of ." #\space" endof
1901         '\n' of ." #\newline" endof
1902         
1903         dup ." #\" emit
1904     endcase
1905 ;
1906
1907 : (printstring) ( stringobj -- )
1908     nil? if 2drop exit then
1909
1910     2dup car drop dup
1911     case
1912         '\n' of ." \n" drop endof
1913         [char] \ of ." \\" drop endof
1914         [char] " of [char] \ emit [char] " emit drop endof
1915         emit
1916     endcase
1917
1918     cdr recurse
1919 ;
1920 : printstring ( stringobj -- )
1921     [char] " emit
1922     (printstring)
1923     [char] " emit ;
1924
1925 : printsymbol ( symbolobj -- )
1926     nil-type istype? if 2drop exit then
1927
1928     2dup car drop emit
1929     cdr recurse
1930 ;
1931
1932 : printnil ( nilobj -- )
1933     2drop ." ()" ;
1934
1935 : printpair ( pairobj -- )
1936     2dup
1937     car print
1938     cdr
1939     nil-type istype? if 2drop exit then
1940     pair-type istype? if space recurse exit then
1941     ."  . " print
1942 ;
1943
1944 : printprim ( primobj -- )
1945     2drop ." <primitive procedure>" ;
1946
1947 : printcomp ( primobj -- )
1948     2drop ." <compound procedure>" ;
1949
1950 : printnone ( noneobj -- )
1951     2drop ." Unspecified return value" ;
1952
1953 : printport ( port -- )
1954     2drop ." <port>" ;
1955
1956 :noname ( obj -- )
1957     fixnum-type istype? if printfixnum exit then
1958     flonum-type istype? if printflonum exit then
1959     ratnum-type istype? if printratnum exit then
1960     boolean-type istype? if printbool exit then
1961     character-type istype? if printchar exit then
1962     string-type istype? if printstring exit then
1963     symbol-type istype? if printsymbol exit then
1964     nil-type istype? if printnil exit then
1965     pair-type istype? if ." (" printpair ." )" exit then
1966     primitive-proc-type istype? if printprim exit then
1967     compound-proc-type istype? if printcomp exit then
1968     none-type istype? if printnone exit then
1969     port-type istype? if printport exit then
1970
1971     except-message: ." tried to print object with unknown type." recoverable-exception throw
1972 ; is print
1973
1974 \ }}}
1975
1976 \ ---- Garbage Collection ---- {{{
1977
1978 variable gc-enabled
1979 false gc-enabled !
1980
1981 variable gc-stack-depth
1982
1983 : enable-gc
1984     depth gc-stack-depth !
1985     true gc-enabled ! ;
1986
1987 : disable-gc
1988     false gc-enabled ! ;
1989
1990 : gc-enabled?
1991     gc-enabled @ ;
1992
1993 : pairlike? ( obj -- obj bool )
1994     pair-type istype? if true exit then
1995     string-type istype? if true exit then
1996     symbol-type istype? if true exit then
1997     compound-proc-type istype? if true exit then
1998     port-type istype? if true exit then
1999
2000     false
2001 ;
2002
2003 : pairlike-marked? ( obj -- obj bool )
2004     over nextfrees + @ 0=
2005 ;
2006
2007 : mark-pairlike ( obj -- obj )
2008         over nextfrees + 0 swap !
2009 ;
2010
2011 : gc-unmark ( -- )
2012     scheme-memsize 0 do
2013         1 nextfrees i + !
2014     loop
2015 ;
2016
2017 : gc-mark-obj ( obj -- )
2018
2019     pairlike? invert if 2drop exit then
2020     pairlike-marked? if 2drop exit then
2021
2022     mark-pairlike
2023
2024     drop pair-type 2dup
2025
2026     car recurse
2027     cdr recurse
2028 ;
2029
2030 : gc-sweep
2031     scheme-memsize nextfree !
2032     0 scheme-memsize 1- do
2033         nextfrees i + @ 0<> if
2034             nextfree @ nextfrees i + !
2035             i nextfree !
2036         then
2037     -1 +loop
2038 ;
2039
2040 \ Following a GC, this gives the amount of free memory
2041 : gc-count-marked
2042     0
2043     scheme-memsize 0 do
2044         nextfrees i + @ 0= if 1+ then
2045     loop
2046 ;
2047
2048 \ Debugging word - helps spot memory that is retained
2049 : gc-zero-unmarked
2050     scheme-memsize 0 do
2051         nextfrees i + @ 0<> if
2052             0 car-cells i + !
2053             0 cdr-cells i + !
2054         then
2055     loop
2056 ;
2057
2058 :noname
2059     \ ." GC! "
2060
2061     gc-unmark
2062
2063     symbol-table obj@ gc-mark-obj
2064     macro-table obj@ gc-mark-obj
2065     console-i/o-port obj@ gc-mark-obj
2066     global-env obj@ gc-mark-obj
2067
2068     depth gc-stack-depth @ do
2069         PSP0 i + 1 + @
2070         PSP0 i + 2 + @
2071
2072         gc-mark-obj
2073     2 +loop
2074
2075     gc-sweep
2076
2077     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2078 ; is collect-garbage
2079
2080 \ }}}
2081
2082 \ ---- Loading files ---- {{{
2083
2084 : load ( addr n -- finalResult )
2085     open-input-file
2086
2087     empty-parse-str
2088
2089     ok-symbol ( port res )
2090
2091     begin
2092         2over read-port ( port res obj )
2093
2094         2dup EOF character-type objeq? if
2095             2drop 2swap close-port
2096             exit
2097         then
2098
2099         2swap 2drop ( port obj )
2100
2101         expand
2102
2103         global-env obj@ eval ( port res )
2104     again
2105 ;
2106
2107 \ }}}
2108
2109 \ ---- Standard Library ---- {{{
2110
2111     include scheme-primitives.4th
2112
2113     s" scheme-library.scm" load 2drop
2114     
2115 \ }}}
2116
2117 \ ---- REPL ----
2118
2119 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2120 : repl-body ( -- bool )
2121     cr bold fg green ." > " reset-term
2122
2123     read-console
2124
2125     2dup EOF character-type objeq? if
2126         2drop
2127         bold fg blue ." Moriturus te saluto." reset-term cr
2128         true exit
2129     then
2130
2131     expand
2132
2133     global-env obj@ eval
2134
2135     fg cyan ." ; " print reset-term
2136
2137     false
2138 ;
2139
2140 : repl
2141     empty-parse-str
2142
2143     enable-gc
2144
2145     \ Display welcome message
2146     welcome-symbol nil cons global-env obj@ eval 2drop
2147
2148     begin
2149         ['] repl-body catch
2150         case
2151             recoverable-exception of false endof
2152             unrecoverable-exception of true endof
2153
2154             throw false
2155         endcase
2156     until
2157 ;
2158
2159 forth definitions
2160
2161 \ vim:fdm=marker