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