4 include term-colours.4th
8 1 constant boolean-type
9 2 constant character-type
12 : istype? ( obj -- obj b )
16 create car-cells N allot
17 create car-type-cells N allot
18 create cdr-cells N allot
19 create cdr-type-cells N allot
24 : cons ( car-obj cdr-obj -- pair-obj )
25 cdr-type-cells nextfree @ + !
26 cdr-cells nextfree @ + !
27 car-type-cells nextfree @ + !
28 car-cells nextfree @ + !
35 : car ( pair-obj -- car-obj )
37 dup car-cells + @ swap
41 : cdr ( pair-obj -- car-obj )
43 dup cdr-cells + @ swap
51 variable stored-parse-idx
52 create parse-str 161 allot
53 variable parse-str-span
55 create parse-idx-stack 10 allot
57 parse-idx-stack parse-idx-sp !
60 parse-idx @ parse-idx-sp @ !
65 parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
69 parse-idx-sp @ @ parse-idx ! ;
73 '\n' parse-str parse-str-span @ + !
81 parse-str 160 expect cr
82 span @ parse-str-span !
92 : charavailable? ( -- bool )
93 parse-str-span @ parse-idx @ > ;
95 : nextchar ( -- char )
96 charavailable? false = if getline then
97 parse-str parse-idx @ + @ ;
99 : whitespace? ( -- bool )
108 nextchar [char] ( = or
109 nextchar [char] ) = or
126 nextchar [char] - = ;
128 : number? ( -- bool )
129 digit? minus? or false = if
150 : boolean? ( -- bool )
151 nextchar [char] # <> if false exit then
158 and if pop-parse-idx false exit then
170 : str-equiv? ( str -- bool )
187 delim? false = if drop false then
192 : character? ( -- bool )
193 nextchar [char] # <> if false exit then
198 nextchar [char] \ <> if pop-parse-idx false exit then
202 S" newline" str-equiv? if pop-parse-idx true exit then
203 S" space" str-equiv? if pop-parse-idx true exit then
204 S" tab" str-equiv? if pop-parse-idx true exit then
206 charavailable? false = if pop-parse-idx false exit then
212 nextchar [char] ( = ;
215 : readnum ( -- num-atom )
223 10 * nextchar [char] 0 - +
232 : readbool ( -- bool-atom )
235 nextchar [char] f = if
246 : readchar ( -- char-atom )
250 S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
251 S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
252 S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
254 nextchar character-type
261 : readpair ( -- obj )
265 nextchar [char] ) = if
270 ." No delimiter following right paren. Aborting." cr
279 \ Read first pair element
284 nextchar [char] . = if
289 ." No delimiter following '.'. Aborting." cr
303 \ Parse a scheme expression
332 nextchar [char] ) <> if
333 bold red ." Missing closing paren." reset-term cr
343 bold fg blue ." Moriturus te saluto." reset-term ." ok" cr
347 bold fg red ." Error parsing string starting at character '"
349 ." '. Aborting." reset-term cr
356 : self-evaluating? ( obj -- obj bool )
357 number-type istype? if true exit then
358 boolean-type istype? if true exit then
359 character-type istype? if true exit then
360 nil-type istype? if true exit then
364 \ self-evaluating? if
369 bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
375 : printnum ( numobj -- ) drop 0 .R ;
377 : printbool ( numobj -- )
385 : printchar ( charobj -- )
389 bl of ." #\space" endof
390 '\n' of ." #\newline" endof
396 : printnil ( nilobj -- )
400 : printpair ( pairobj -- )
404 nil-type istype? if 2drop exit then
405 pair-type istype? if space recurse exit then
410 number-type istype? if printnum exit then
411 boolean-type istype? if printbool exit then
412 character-type istype? if printchar exit then
413 nil-type istype? if printnil exit then
414 pair-type istype? if ." (" printpair ." )" exit then
416 bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
423 cr ." Welcome to scheme.forth.jl!" cr
424 ." Use Ctrl-D to exit." cr
429 cr bold fg green ." > " reset-term
432 fg cyan ." ; " print reset-term