Fixed pair read/print.
[scheme.forth.jl.git] / scheme.4th
1 vocabulary scheme
2 scheme definitions
3
4 include term-colours.4th
5 include defer-is.4th
6
7 0 constant number-type
8 1 constant boolean-type
9 2 constant character-type
10 3 constant nil-type
11 4 constant pair-type
12 : istype? ( obj -- obj b )
13     over = ;
14
15 100 constant N
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
20
21 variable nextfree
22 0 nextfree !
23
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 @ + !
29
30     nextfree @ pair-type
31
32     1 nextfree +!
33 ;
34
35 : car ( pair-obj -- car-obj )
36     drop
37     dup car-cells + @ swap
38     car-type-cells + @
39 ;
40
41 : cdr ( pair-obj -- car-obj )
42     drop
43     dup cdr-cells + @ swap
44     cdr-type-cells + @
45 ;
46
47
48 \ ---- Read ----
49
50 variable parse-idx
51 variable stored-parse-idx
52 create parse-str 161 allot
53 variable parse-str-span
54
55 create parse-idx-stack 10 allot 
56 variable parse-idx-sp
57 parse-idx-stack parse-idx-sp !
58
59 : push-parse-idx
60     parse-idx @ parse-idx-sp @ !
61     1 parse-idx-sp +!
62 ;
63
64 : pop-parse-idx
65     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
66
67     1 parse-idx-sp -!
68
69     parse-idx-sp @ @ parse-idx ! ;
70
71
72 : append-newline
73     '\n' parse-str parse-str-span @ + !
74     1 parse-str-span +! ;
75
76 : empty-parse-str
77     0 parse-str-span !
78     0 parse-idx ! ;
79
80 : getline
81     parse-str 160 expect cr
82     span @ parse-str-span !
83     append-newline
84     0 parse-idx ! ;
85
86 : inc-parse-idx
87     1 parse-idx +! ;
88
89 : dec-parse-idx
90     1 parse-idx -! ;
91
92 : charavailable? ( -- bool )
93     parse-str-span @ parse-idx @ > ;
94
95 : nextchar ( -- char )
96     charavailable? false = if getline then
97     parse-str parse-idx @ + @ ;
98
99 : whitespace? ( -- bool )
100     nextchar BL = 
101     nextchar '\n' = or ;
102
103 : eof? ( -- bool )
104     nextchar 4 = ;
105
106 : delim? ( -- bool )
107     whitespace?
108     nextchar [char] ( = or
109     nextchar [char] ) = or
110 ;
111
112 : eatspaces
113     begin
114         whitespace?
115     while
116         inc-parse-idx
117     repeat
118 ;
119
120 : digit? ( -- bool )
121     nextchar [char] 0 >=
122     nextchar [char] 9 <=
123     and ;
124
125 : minus? ( -- bool )
126     nextchar [char] - = ;
127
128 : number? ( -- bool )
129     digit? minus? or false = if
130         false
131         exit
132     then
133
134     push-parse-idx
135     inc-parse-idx
136
137     begin digit? while
138         inc-parse-idx
139     repeat
140
141     delim? if
142         pop-parse-idx
143         true
144     else
145         pop-parse-idx
146         false
147     then
148 ;
149
150 : boolean? ( -- bool )
151     nextchar [char] # <> if false exit then
152
153     push-parse-idx
154     inc-parse-idx
155
156     nextchar [char] t <>
157     nextchar [char] f <>
158     and if pop-parse-idx false exit then
159
160     inc-parse-idx
161     delim? if
162         pop-parse-idx
163         true
164     else
165         pop-parse-idx
166         false
167     then
168 ;
169
170 : str-equiv? ( str -- bool )
171
172     push-parse-idx
173
174     true -rot
175
176     swap dup rot + swap
177
178     do
179         i @ nextchar <> if
180             drop false
181             leave
182         then
183
184         inc-parse-idx
185     loop
186
187     delim? false = if drop false then
188
189     pop-parse-idx
190 ;
191
192 : character? ( -- bool )
193     nextchar [char] # <> if false exit then
194
195     push-parse-idx
196     inc-parse-idx
197
198     nextchar [char] \ <> if pop-parse-idx false exit then
199
200     inc-parse-idx
201
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
205
206     charavailable? false = if pop-parse-idx false exit then
207
208     pop-parse-idx true
209 ;
210
211 : pair? ( -- bool )
212     nextchar [char] ( = ;
213
214
215 : readnum ( -- num-atom )
216     minus? dup if
217         inc-parse-idx
218     then
219
220     0
221
222     begin digit? while
223         10 * nextchar [char] 0 - +
224         inc-parse-idx
225     repeat
226
227     swap if negate then
228
229     number-type
230 ;
231
232 : readbool ( -- bool-atom )
233     inc-parse-idx
234     
235     nextchar [char] f = if
236         false
237     else
238         true
239     then
240
241     inc-parse-idx
242
243     boolean-type
244 ;
245
246 : readchar ( -- char-atom )
247     inc-parse-idx
248     inc-parse-idx
249
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
253
254     nextchar character-type
255
256     inc-parse-idx
257 ;
258
259 defer read
260
261 : readpair ( -- obj )
262     eatspaces
263
264     \ Empty lists
265     nextchar [char] ) = if
266         inc-parse-idx
267
268         delim? false = if
269             bold fg red
270             ." No delimiter following right paren. Aborting." cr
271             reset-term abort
272         then
273
274         dec-parse-idx
275
276         0 nil-type exit
277     then
278
279     \ Read first pair element
280     read
281
282     \ Pairs
283     eatspaces
284     nextchar [char] . = if
285         inc-parse-idx
286
287         delim? false = if
288             bold fg red
289             ." No delimiter following '.'. Aborting." cr
290             reset-term abort
291         then
292
293         eatspaces read
294     else
295         recurse
296     then
297
298     eatspaces
299
300     cons
301 ;
302
303 \ Parse a scheme expression
304 :noname ( -- obj )
305
306     eatspaces
307
308     number? if
309         readnum
310         exit
311     then
312
313     boolean? if
314         readbool
315         exit
316     then
317
318     character? if
319         readchar
320         exit
321     then
322
323     pair? if
324         inc-parse-idx
325
326         eatspaces
327
328         readpair
329
330         eatspaces
331
332         nextchar [char] ) <> if
333             bold red ." Missing closing paren." reset-term cr
334             abort
335         then
336
337         inc-parse-idx
338
339         exit
340     then
341
342     eof? if
343         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
344         quit
345     then
346
347     bold fg red ." Error parsing string starting at character '"
348     nextchar emit
349     ." '. Aborting." reset-term cr
350     abort
351
352 ; is read
353
354 \ ---- Eval ----
355
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
361     false ;
362
363 : eval
364     \ self-evaluating? if
365     \     exit
366     \ then
367     exit
368
369     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
370     abort
371 ;
372
373 \ ---- Print ----
374
375 : printnum ( numobj -- ) drop 0 .R ;
376
377 : printbool ( numobj -- )
378     drop if
379         ." #t"
380     else
381         ." #f"
382     then
383 ;
384
385 : printchar ( charobj -- )
386     drop
387     case
388         9 of ." #\tab" endof
389         bl of ." #\space" endof
390         '\n' of ." #\newline" endof
391         
392         dup ." #\" emit
393     endcase
394 ;
395
396 : printnil ( nilobj -- )
397     2drop ." ()" ;
398
399 defer print
400 : printpair ( pairobj -- )
401     2dup
402     car print
403     cdr
404     nil-type istype? if 2drop exit then
405     pair-type istype? if space recurse exit then
406     ."  . " print
407 ;
408
409 :noname ( obj -- )
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
415
416     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
417     abort
418 ; is print
419
420 \ ---- REPL ----
421
422 : repl
423     cr ." Welcome to scheme.forth.jl!" cr
424        ." Use Ctrl-D to exit." cr
425
426     empty-parse-str
427
428     begin
429         cr bold fg green ." > " reset-term
430         read
431         eval
432         fg cyan ." ; " print reset-term
433     again
434 ;
435
436 forth definitions