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