-\ Scheme interpreter
-
vocabulary scheme
scheme definitions
include term-colours.4th
+include defer-is.4th
0 constant number-type
1 constant boolean-type
2 constant character-type
+3 constant nil-type
+4 constant pair-type
: istype? ( obj -- obj b )
over = ;
+100 constant N
+create car-cells N allot
+create car-type-cells N allot
+create cdr-cells N allot
+create cdr-type-cells N allot
+
+variable nextfree
+0 nextfree !
+
+: cons ( car-obj cdr-obj -- pair-obj )
+ cdr-type-cells nextfree @ + !
+ cdr-cells nextfree @ + !
+ car-type-cells nextfree @ + !
+ car-cells nextfree @ + !
+
+ nextfree @ pair-type
+
+ 1 nextfree +!
+;
+
\ ---- Read ----
variable parse-idx
create parse-str 161 allot
variable parse-str-span
-
create parse-idx-stack 10 allot
variable parse-idx-sp
parse-idx-stack parse-idx-sp !
;
: str-equiv? ( str -- bool )
+
push-parse-idx
- true
+ true -rot
swap dup rot + swap
+
do
i @ nextchar <> if
drop false
inc-parse-idx
loop
- delim? <> if drop false then
+ delim? false = if drop false then
pop-parse-idx
;
inc-parse-idx
- S" newline" str-equiv? if true exit then
- S" space" str-equiv? if true exit then
- S" tab" str-equiv? if true exit then
+ S" newline" str-equiv? if pop-parse-idx true exit then
+ S" space" str-equiv? if pop-parse-idx true exit then
+ S" tab" str-equiv? if pop-parse-idx true exit then
charavailable? false = if pop-parse-idx false exit then
pop-parse-idx true
;
+: pair? ( -- bool )
+ nextchar [char] ( = ;
+
+
: readnum ( -- num-atom )
minus? dup if
inc-parse-idx
boolean-type
;
+: readchar ( -- char-atom )
+ inc-parse-idx
+ inc-parse-idx
+
+ S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
+ S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
+ S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
+
+ nextchar character-type
+
+ inc-parse-idx
+;
+
+defer read
+
+: readpair ( -- obj )
+ inc-parse-idx
+ eatspaces
+
+ \ Empty lists
+ nextchar [char] ) = if
+ inc-parse-idx
+
+ delim? false = if
+ bold fg red
+ ." No delimiter following right paren. Aborting." cr
+ reset-term abort
+ then
+
+ nil-type exit
+ then
+
+ \ Read first pair element
+ read
+
+ \ Pairs
+ eatspaces
+ nextchar [char] . = if
+ inc-parse-idx
+
+ delim? false = if
+ bold fg red
+ ." No delimiter following '.'. Aborting." cr
+ reset-term abort
+ then
+
+ eatspaces read
+
+ else
+ recurse
+ then
+
+ cons
+;
+
\ Parse a scheme expression
-: read ( -- obj )
+: (read) ( -- obj )
eatspaces
exit
then
+ character? if
+ readchar
+ exit
+ then
+
+ pair? if
+ readpair
+ exit
+ then
+
eof? if
bold fg blue ." Moriturus te saluto." reset-term ." ok" cr
quit
abort
;
+' (read) is read
+
\ ---- Eval ----
: self-evaluating? ( obj -- obj bool )
number-type istype? if true exit then
boolean-type istype? if true exit then
+ character-type istype? if true exit then
+ nil-type istype? if true exit then
false ;
: eval
then
;
+: printchar ( charobj -- )
+ drop
+ case
+ 9 of ." #\tab" endof
+ bl of ." #\space" endof
+ '\n' of ." #\newline" endof
+
+ dup ." #\" emit
+ endcase
+;
+
+: printnil ( nilobj -- )
+ drop ." ()" ;
+
: print ( obj -- )
." ; "
number-type istype? if printnum exit then
boolean-type istype? if printbool exit then
+ character-type istype? if printchar exit then
+ nil-type istype? if printnil exit then
;
\ ---- REPL ----