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