Scheme (LISP) interpreter

[qbguy]

Code: QB64: [Select]

1. DEFINT A-Z
2. declare function readobj()
3. declare function readtoken()
4. declare function strtoatom(s$)
5. declare function cons(car,cdr)
6. declare function readlist()
7. declare function alloc()
8. declare sub printobj(id)
9. declare function evalobj(id, env)
10. declare function apply(f, args)
11. declare function lookup(anum, env)
12. declare function lvals(id,env)
13. declare sub defvar(var,val,env)
14. declare sub setvar(id,val,env)
15. declare function mkprimop(id)
16.  
17. DIM SHARED depth AS INTEGER,bufpos AS INTEGER, state AS INTEGER
18. DIM SHARED buf AS STRING
19. DIM SHARED anext, hptr
20. DIM SHARED atom$(1024),heap(2048, 2)
21. RANDOMIZE TIMER
22.  
23. CONST TRUE = -1
24. CONST FALSE = 0
25. CONST TNIL = 0
26. CONST TCONS = 2
27. CONST TNUM = 3
28. CONST TSYM = 4
29. CONST TPROC = 5
30. CONST TPPROC = 6
31. CONST TOKNIL = 0
32. CONST TOKERR = 1
33. CONST TOKOPEN = 2
34. CONST TOKCLOSE = 3
35. CONST TOKQUOTE = 4
36. CONST TOKDOT = 5
37.  
38.  
39. CONST PPLUS = 1
40. CONST PTIMES = 3
41. CONST PCONS = 4
42. CONST PCAR = 5
43. CONST PCDR = 6
44. CONST PEQUAL = 7
45. CONST PNOT = 8
46. CONST PEQ = 9
47. CONST PSETCAR = 10
48. CONST PSETCDR = 11
49. CONST PAPPLY = 12
50. CONST PLIST = 13
51. CONST PREAD = 14
52.  
53. hptr = 10: bufpos = 1
54. vars = TNIL
55. vals = TNIL
56. frame = CONS(vars,vals)
57. env = CONS(frame,TNIL)
58.  
59. CALL DEFVAR(STRTOATOM("+"),mkprimop(PPLUS), env)
60. CALL DEFVAR(STRTOATOM("*"),mkprimop(PTIMES), env )
61. CALL DEFVAR(STRTOATOM("CONS"),mkprimop(PCONS), env)
62. CALL DEFVAR(STRTOATOM("CAR"),mkprimop(PCAR), env )
63. CALL DEFVAR(STRTOATOM("CDR"),mkprimop(PCDR), env)
64. CALL DEFVAR(STRTOATOM("="),mkprimop(PEQUAL),env)
65. CALL DEFVAR(STRTOATOM("NOT"),mkprimop(PNOT),env)
66. CALL DEFVAR(STRTOATOM("EQ?"),mkprimop(PEQ),env)
67. CALL DEFVAR(STRTOATOM("EQV?"),mkprimop(PEQ),env)
68. CALL DEFVAR(STRTOATOM("T"),STRTOATOM("T"),env) ' true
69. CALL DEFVAR(STRTOATOM("SET-CAR!"),mkprimop(PSETCAR),env)
70. CALL DEFVAR(STRTOATOM("SET-CDR!"),mkprimop(PSETCDR),env)
71. CALL DEFVAR(STRTOATOM("APPLY"),mkprimop(PAPPLY),env)
72. CALL DEFVAR(STRTOATOM("LIST"),mkprimop(PLIST),env)
73. CALL DEFVAR(STRTOATOM("READ"),mkprimop(PREAD), env)
74.  
75. DO
76.     s = READOBJ()
77.     SELECT CASE s
78.     CASE TOKCLOSE
79.     ' unmatched closed parenthesis
80.     CASE TOKDOT
81.     PRINT  "dot used outside list"
82.     CASE TOKERR
83.     PRINT "[Error]"
84.     CASE ELSE
85.     CALL PRINTOBJ(EVALOBJ(s,env))
86.     END SELECT
87.     PRINT
88. LOOP
89.  
90.  
91. SUB PRINTOBJ(id)
92.  
93.     IF id = TOKERR THEN PRINT "[Error]" : EXIT SUB
94.     SELECT CASE heap(id,0)
95.     CASE TNIL
96.         PRINT "()";
97.     CASE TCONS
98.         PRINT "(";
99. 1       CALL PRINTOBJ(heap(id,1))
100.         PRINT " ";
101.         cdr = heap(id,2)
102.         IF heap(cdr,0) = TCONS THEN
103.             id = cdr: GOTO 1
104.         ELSEIF heap(cdr,0) = TNIL THEN
105.             PRINT ")";
106.         ELSE
107.             PRINT ".";  
108.             CALL PRINTOBJ(cdr)
109.             PRINT ")";
110.         END IF
111.     CASE TNUM
112.         PRINT heap(id,1);
113.     CASE TSYM
114.         PRINT atom$(heap(id,1));
115.     CASE TPROC, TPPROC
116.         PRINT "[Procedure]"
117.     END SELECT
118. END SUB
119.  
120. FUNCTION READTOKEN()
121.    
122. 1    bufend = LEN(buf)
123.     WHILE bufpos < bufend AND INSTR(" "+CHR$(9),MID$(buf,bufpos,1))
124.         bufpos = bufpos + 1
125.     WEND
126.     c$ = MID$(buf,bufpos,1)
127.     IF INSTR(":;",c$) THEN
128.         IF c$ = ":" THEN
129.             bufpos = bufpos + 1
130.             IF bufpos <= bufend THEN
131.                 SELECT CASE MID$(buf,bufpos,1)
132.                 CASE "q" ' quit
133.                     SYSTEM
134.                 CASE ELSE
135.                         READTOKEN = TOKERR
136.                         EXIT FUNCTION
137.                 END SELECT
138.             END IF
139.         END IF
140.         bufpos = bufend + 1
141.     END IF
142.     IF bufpos > bufend THEN
143.         IF depth = 0 THEN PRINT "]=> ";
144.         LINE INPUT buf
145.         bufend = LEN(buf)
146.         bufpos = 1
147.         GOTO 1
148.     END IF
149.     SELECT CASE c$
150.     CASE "("
151.         bufpos = bufpos + 1
152.         READTOKEN = TOKOPEN
153.     CASE ")"
154.         bufpos = bufpos + 1
155.         READTOKEN = TOKCLOSE
156.     CASE "'"
157.         bufpos = bufpos+1
158.         READTOKEN = TOKQUOTE
159.     CASE "."
160.         bufpos = bufpos + 1
161.         READTOKEN = TOKDOT
162.     CASE ELSE
163.         strbeg = bufpos
164.         bufpos = bufpos +1
165.         DO WHILE bufpos <= bufend
166.             c$ = MID$(buf,bufpos,1)
167.             IF c$ = " " OR c$ = "." OR c$ = "(" OR c$ = ")" THEN EXIT DO
168.             bufpos = bufpos + 1
169.         LOOP
170.         READTOKEN = STRTOATOM(MID$(buf,strbeg,bufpos - strbeg))
171.     END SELECT
172. END FUNCTION
173.  
174. FUNCTION STRTOATOM(s$)
175.     l = LEN(s$)
176.     c$ = LEFT$(s$,1)
177.     IF (c$ = "-" AND l >= 2) OR (c$ >= "0" AND c$ <= "9") THEN
178.         v = 0
179.         IF c$ = "-" THEN neg = 1: idx = 2 ELSE neg = 0: idx = 1
180.         FOR idx = idx TO l
181.             c$ = MID$(s$,idx,1)
182.             IF (c$ >= "0" AND c$ <= "9") THEN
183.                 v = v*10 + (ASC(c$)-ASC("0"))
184.             ELSE
185.                 EXIT FOR
186.             END IF
187.         NEXT
188.         IF idx = l + 1 THEN
189.             IF neg THEN v = -v
190.             p = ALLOC()
191.             HEAP(p,0) = TNUM
192.             HEAP(p,1) = v
193.             STRTOATOM = p: EXIT FUNCTION
194.         END IF
195.     END IF
196.     IF UCASE$(s$) = "NIL" THEN STRTOATOM=TOKNIL: EXIT FUNCTION
197.     FOR i = 0 TO anext-1
198.         IF ATOM$(i) = UCASE$(s$) THEN found = TRUE : exit for
199.     NEXT
200.     IF not found then ATOM$(anext) = UCASE$(s$) : anext = anext + 1
201.     p = ALLOC(): HEAP(p,0) = TSYM: HEAP(p,1) = i
202.     STRTOATOM = p
203. END FUNCTION
204.  
205. FUNCTION READOBJ()
206.     tok = READTOKEN()
207.     SELECT CASE tok
208.     CASE TOKOPEN
209.     depth = depth + 1
210.     s = READLIST()
211.     depth = depth - 1
212.     READOBJ = s
213.     CASE TOKQUOTE
214.     depth = depth + 1
215.     tok = READOBJ()
216.     depth = depth - 1
217.     SELECT CASE tok
218.     CASE TOKCLOSE
219.     PRINT "warning: quote before close parenthesis"
220.     READOBJ = TOK
221.     CASE TOKDOT
222.     PRINT "warning: quote before dot"
223.     READOBJ = TOK
224.     CASE ELSE
225.     s = CONS(STRTOATOM("QUOTE"),CONS(tok,0))
226.     READOBJ = s
227.     END SELECT
228.     CASE ELSE
229.     READOBJ = tok
230.     END SELECT
231. END FUNCTION
232.  
233. FUNCTION CONS(car,cdr)
234.     p = ALLOC()
235.     heap(p,0) = TCONS
236.     heap(p,1) = car
237.     heap(p,2) = cdr
238.     cons = p
239. END FUNCTION
240.  
241. FUNCTION ALLOC()
242.     ALLOC = hptr
243.     hptr = hptr + 1
244. END FUNCTION
245.  
246. FUNCTION READLIST()
247.     SH = READOBJ()
248.     SELECT CASE SH
249.     CASE TOKERR
250.         READLIST = TOKERR
251.     CASE TOKCLOSE
252.         READLIST = 0
253.     CASE TOKDOT
254.         SH = READOBJ()
255.         SELECT CASE SH
256.         CASE TOKERR, TOKDOT, TOKCLOSE
257.             READLIST = TOKERR
258.         CASE ELSE
259.             ST = READLIST()
260.             IF ST THEN READLIST = TOKERR ELSE READLIST = SH
261.         END SELECT
262.     CASE ELSE
263.         ST = READLIST()
264.         IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH,ST)
265.     END SELECT
266. END FUNCTION
267.  
268. FUNCTION EVALOBJ(id, env)
269. 1   SELECT CASE heap(id,0)
270.     CASE TNIL, TNUM ' self-evaluating
271.         EVALOBJ = id
272.     CASE TSYM
273.         EVALOBJ = LOOKUP(heap(id,1),env)
274.     CASE TCONS
275.         o = heap(id,1)
276.         t = heap(o,0)
277.         IF t = TSYM THEN
278.         a$ = atom$(heap(o,1)) ' symbol name of car(id)
279.         SELECT CASE a$
280.         CASE "QUOTE"
281.             EVALOBJ = heap(heap(id,2),1)
282.         CASE "SET!"
283.             vid = heap(heap(id,2),1) 'cadr
284.             aval = heap(heap(heap(id,2),2),1) 'caddr
285.             CALL setvar(vid, evalobj(aval, env),env)
286.         CASE "DEFINE"
287.             vid = heap(heap(id,2),1)
288.             aval = heap(heap(heap(id,2),2),1)
289.             CALL setvar(vid, evalobj(aval,env),env)
290.         CASE "IF"
291.             ' (if pred ic ia)
292.             pred = heap(heap(id,2),1) 'predicate = cadr
293.             ic = heap(heap(heap(id,2),2),1) ' caddr
294.             ia = heap(heap(heap(heap(id,2),2),2),1) ' cadddr
295.             IF EVALOBJ(pred,env) THEN
296.                 ' return EVALOBJ(ic,env)
297.                 id = ic: GOTO 1
298.             ELSE
299.                 ' return EVALOBJ(ia,env)
300.                 id = ia : GOTO 1
301.             END IF
302.         CASE "LAMBDA"
303.             p = ALLOC()
304.             heap(p,0) = TPROC
305.             heap(p,1) = heap(heap(id,2),1) ' cadr = args
306.             heap(p,2) = CONS(heap(heap(id,2),2),env) 'caddr = body
307.             EVALOBJ = p
308.         CASE "BEGIN"
309.         seq = heap(id,2)
310.         DO WHILE heap(seq,2)
311.         t = heap(seq,1)
312.         t = evalobj(t,env) 'ignore result
313.         seq = heap(seq,2)
314.         LOOP
315.         id = heap(seq,1): GOTO 1
316.         CASE "AND"
317.         seq = heap(id,2)
318.         DO WHILE heap(seq,2)
319.         t = heap(seq,1)
320.         t = evalobj(t,env)
321.         IF t = 0 THEN evalobj = 0: EXIT FUNCTION
322.         seq = heap(seq,2)
323.         LOOP
324.         id = heap(seq,1): GOTO 1
325.         CASE "OR"
326.         seq = heap(id,2)
327.         DO WHILE heap(seq,2)
328.         t = heap(seq,1)
329.         t = evalobj(t,env)
330.         IF t THEN evalobj = t: EXIT FUNCTION
331.         seq = heap(seq,2)
332.         LOOP
333.         id = heap(seq,1): GOTO 1
334.         CASE "COND"
335.         clauses = heap(id,2)
336.         WHILE clauses
337.         clause = heap(clauses, 1)
338.         pred = heap(clause, 1)
339.         IF EVALOBJ(pred,env) THEN
340.            seq = heap(clause, 2)
341.            DO WHILE heap(seq,2)
342.             t = heap(seq,1)
343.             t = evalobj(t,env) 'ignore result
344.             seq = heap(seq,2)
345.            LOOP
346.            id = heap(seq,1): GOTO 1
347.         END IF
348.         clauses = heap(clauses,2)
349.         WEND
350.         CASE ELSE
351.             args = heap(id,2)
352.             proc = EVALOBJ(o,env)
353.             EVALOBJ = apply(proc,lvals(args,env))
354.         END SELECT
355.         ELSE
356.             args = heap(id,2)
357.             proc = EVALOBJ(o, env)
358.             EVALOBJ = apply(proc,lvals(args,env))
359.         END IF
360.     CASE ELSE
361.         PRINT "Unhandled expression type: "; a$
362.         EVALOBJ = id
363.     END SELECT
364. END FUNCTION
365.  
366. FUNCTION lvals(id,env)
367.    IF heap(id,0) = TCONS THEN
368.      car = heap(id,1)
369.      ecar = EVALOBJ(car,env)
370.      head = CONS(ecar,0)
371.      l = heap(id,2) : prev = head
372.      WHILE l
373.          car = heap(l,1)
374.          ecar = EVALOBJ(car,env)
375.          new = CONS(ecar,0)
376.          heap(prev,2) = new
377.          prev = new
378.          l = heap(l,2)
379.      WEND
380.      lvals = head
381.    ELSE
382.      lvals = 0
383.    END IF
384. END FUNCTION
385.  
386. FUNCTION apply(id,args)
387.     IF heap(id,0) = TPROC THEN
388.     params = heap(id,1)
389.     body = heap(heap(id,2),1)
390.     procenv = heap(heap(id,2),2)
391.     env = CONS(CONS(params,args),procenv)
392.     DO WHILE heap(body,2)
393.     t = heap(body,1)
394.     t = evalobj(t,env) 'ignore result
395.     body = heap(body,2)
396.     LOOP
397.     t = heap(body,1)
398.     apply = evalobj(t,env)
399.     ELSEIF heap(id,0) = TPPROC THEN
400.     SELECT CASE heap(id,1)
401.     CASE PPLUS
402.         sum = 0
403.         a = args
404.         WHILE a
405.             sum = sum + heap(heap(a,1),1)
406.             a = heap(a,2)
407.         WEND
408.         p = ALLOC()
409.         heap(p,0) = TNUM
410.         heap(p,1) = sum
411.         apply = p
412.     CASE PTIMES
413.         prod = 1
414.         a = args
415.         WHILE a
416.             prod = prod * heap(heap(a,1),1)
417.             a = heap(a,2)
418.         WEND
419.         p = ALLOC()
420.         heap(p,0) = TNUM
421.         heap(p,1) = prod
422.         apply = p
423.     CASE PCONS
424.         apply = CONS(heap(args,1), heap(heap(args,2),1))
425.     CASE PCAR
426.         apply = heap(heap(args,1),1)
427.     CASE PCDR
428.         apply = heap(heap(args,1),2)
429.     CASE PEQUAL
430.         IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
431.         f = heap(heap(args,1),1)
432.         a = heap(args,2)
433.         DO WHILE a
434.             IF heap(heap(a,1),1) <> f THEN apply = TNIL : EXIT FUNCTION
435.             a = heap(a,2)
436.         LOOP
437.         apply = STRTOATOM("T"): EXIT FUNCTION
438.     CASE PNOT
439.         IF heap(args,1) THEN apply = TNIL ELSE apply = STRTOATOM("T")
440.     CASE PEQ
441.         arg1 = heap(args,1)
442.         arg2 = heap(heap(args,2),1)
443.         IF heap(arg1,0) <> heap(arg2,0) THEN apply = TNIL: EXIT FUNCTION
444.         SELECT CASE heap(arg1,0)
445.         CASE TNUM, TPROC, TPPROC, TSYM
446.             IF heap(arg1,1) = heap(arg2,1) THEN apply = STRTOATOM("T")
447.         CASE TCONS, TNIL
448.             IF arg1 = arg2 THEN apply = STRTOATOM("T")
449.         END SELECT
450.     CASE PSETCAR
451.         arg1 = heap(args,1)
452.         arg2 = heap(heap(args,2),1)
453.         heap(arg1,1) = arg2
454.     CASE PSETCDR
455.         arg1 = heap(args,1)
456.         arg2 = heap(heap(args,2),1)
457.         heap(arg2,2) = arg2
458.     CASE PAPPLY
459.         arg1 = heap(args,1)
460.         arg2 = heap(heap(args,2),1)
461.         apply = apply(arg1,arg2)
462.     CASE PLIST
463.         apply = args
464.     CASE PREAD
465.         apply = readobj()
466.     END SELECT
467.     ELSE
468.     PRINT "Bad application -- not a function"
469.     apply = TOKERR
470.     END IF
471. END FUNCTION
472.  
473. FUNCTION lookup(anum,env)
474.     ' env is a list of (vars . vals) frames
475.     ' where: vars is a list of symbols
476.     '        vals is a list of their values
477.     e = env
478.     DO
479.     frame = heap(e,1) ' get the first frame
480.  
481.     vars = heap(frame,1) ' vars is car
482.  
483.     vals = heap(frame,2) ' vals is cdr
484.  
485.     WHILE vars ' while vars left to check
486.         IF heap(heap(vars, 1),1) = anum THEN 'atom number of car(vars) = anum
487.             lookup = heap(vals,1) ' car(vals)
488.             EXIT FUNCTION
489.         END IF
490.         vars = heap(vars,2) 'cdr(vars)
491.         vals = heap(vals,2) 'cdr(vals)
492.     WEND
493.     e = heap(e,2) ' cdr(e)
494.     LOOP WHILE e
495.     PRINT "Unbound variable: "; ATOM$(anum): lookup = TOKERR
496. END FUNCTION
497.  
498. SUB setvar(id, value, env)
499.     anum = heap(id,1)
500.     e = env
501.     DO
502.         frame = heap(e,1)
503.         vars = heap(frame,1)
504.         vals = heap(frame,2)
505.         WHILE vars
506.             IF heap(heap(vars,1),1) = anum THEN
507.                 heap(vals,1) = value : EXIT SUB
508.             END IF
509.             vars = heap(vars,2): vals = heap(vals,2)
510.         WEND
511.         e = heap(e,2)
512.     LOOP WHILE e
513.     CALL defvar(id, value, env)
514. END SUB
515.  
516. SUB defvar(id, value, env)
517.     anum = heap(id,1)
518.     frame = heap(env,1)
519.     vars = heap(frame,1)
520.     vals = heap(frame,2)
521.     WHILE vars
522.         IF heap(heap(vars,1),1) = anum THEN
523.             heap(vals,1) = value: EXIT SUB
524.         END IF
525.         vars = heap(vars,2): vals = heap(vals,2)
526.     WEND
527.     vars = heap(frame,1)
528.     vals = heap(frame,2)
529.     heap(frame,1) = CONS(id, vars)
530.     heap(frame,2) = CONS(value, vals)
531. END SUB
532.  
533. FUNCTION mkprimop(id)
534.  p = alloc()
535.  heap(p,0) = TPPROC
536.  heap(p,1) = id
537.  mkprimop = p
538. END FUNCTION
539.  

[STxAxTIC]

So glad you found us qbguy! I've always liked this project of yours.

EDIT: Long ago I remember this not working as-is when pasted to QB64, and then during my edits I got on the path of making the file into BI/BM fragments so it could be included in other places easily (bots and whatever). More importantly though, I saved the test code because I don't think the audience here delves into LISPy things. Have fun with these two boxes all. They're four years old this month.

Code: QB64: [Select]

1. ' Original by qbguy.
2. ' Edits by STxAxTIC (10/16/2014).
3. ' Posted to qb64.org forums on 10-06-2018.
4.  
5. DECLARE FUNCTION hash (s$)
6. DECLARE FUNCTION READOBJ (depth)
7. DECLARE FUNCTION READTOKEN (depth)
8. DECLARE FUNCTION STRTOATOM (s$)
9. DECLARE FUNCTION CONS (car, cdr)
10. DECLARE FUNCTION READLIST (depth)
11. DECLARE FUNCTION ALLOC ()
12. DECLARE SUB PRINTOBJ (id)
13. DECLARE FUNCTION EVALOBJ (id, env)
14. DECLARE FUNCTION apply (f, args)
15. DECLARE FUNCTION lookup (anum, env)
16. DECLARE FUNCTION lvals (id, env)
17. DECLARE SUB defvar (var, vals, env)
18. DECLARE SUB setvar (id, vals, env)
19. DECLARE FUNCTION mkprimop (id)
20. DECLARE FUNCTION collect(p)
21. DECLARE SUB gc(root)
22. DECLARE FUNCTION DoLISP$(TheStringIn$, envin)
23.  
24. ' Make these smaller to get it to work in QBASIC / QuickBASIC
25. CONST msize = 16384 'size of memory -- arbitrary
26. CONST hsize = 4096 'size of hash table -- should be power of 2
27.  
28. DIM SHARED bufpos AS INTEGER, state AS INTEGER
29. DIM SHARED buf AS STRING
30. DIM SHARED hptr
31. DIM SHARED atom$(0 TO hsize - 1), heap(2 * msize - 1, 2)
32. DIM SHARED mmin, nmin, gcnow
33.  
34. mmin = 1: nmin = msize
35.  
36. DIM SHARED TheInput$
37. DIM SHARED TheOutput$
38.  
39. CONST TRUE = -1
40. CONST FALSE = 0
41. CONST TNIL = 0
42. CONST TCONS = 2
43. CONST TNUM = 3
44. CONST TSYM = 4
45. CONST TPROC = 5
46. CONST TPPROC = 6
47. CONST TOKNIL = 0
48. CONST TOKERR = -1
49. CONST TOKOPEN = -2
50. CONST TOKCLOSE = -3
51. CONST TOKQUOTE = -4
52. CONST TOKDOT = -5
53.  
54. CONST PPLUS = 1
55. CONST PMINUS = 2
56. CONST PTIMES = 3
57. CONST PCONS = 4
58. CONST PCAR = 5
59. CONST PCDR = 6
60. CONST PEQUAL = 7
61. CONST PNOT = 8
62. CONST PEQ = 9
63. CONST PSETCAR = 10
64. CONST PSETCDR = 11
65. CONST PAPPLY = 12
66. CONST PLIST = 13
67. CONST PREAD = 14
68. CONST PLT = 15
69. CONST PGT = 16
70. CONST PGEQ = 17
71. CONST PLEQ = 18
72. CONST PNUMP = 20
73. CONST PPROCP = 21
74. CONST PSYMP = 22
75. CONST PCONSP = 24
76.  
77. ''''''''''
78.  
79. hptr = mmin: bufpos = 1
80. vars = TNIL
81. vals = TNIL
82. frame = CONS(vars, vals)
83. env = CONS(frame, TNIL)
84. CALL defvar(STRTOATOM("+"), mkprimop(PPLUS), env)
85. CALL defvar(STRTOATOM("-"), mkprimop(PMINUS), env)
86. CALL defvar(STRTOATOM("*"), mkprimop(PTIMES), env)
87. 'CALL defvar(STRTOATOM("%"), mkprimop(PMOD), env)
88. CALL defvar(STRTOATOM("CONS"), mkprimop(PCONS), env)
89. CALL defvar(STRTOATOM("CAR"), mkprimop(PCAR), env)
90. CALL defvar(STRTOATOM("CDR"), mkprimop(PCDR), env)
91. CALL defvar(STRTOATOM("="), mkprimop(PEQUAL), env)
92. CALL defvar(STRTOATOM("NOT"), mkprimop(PNOT), env)
93. CALL defvar(STRTOATOM("EQ?"), mkprimop(PEQ), env)
94. CALL defvar(STRTOATOM("EQV?"), mkprimop(PEQ), env)
95. CALL defvar(STRTOATOM("T"), STRTOATOM("T"), env) ' true
96. CALL defvar(STRTOATOM("SET-CAR!"), mkprimop(PSETCAR), env)
97. CALL defvar(STRTOATOM("SET-CDR!"), mkprimop(PSETCDR), env)
98. CALL defvar(STRTOATOM("APPLY"), mkprimop(PAPPLY), env)
99. CALL defvar(STRTOATOM("LIST"), mkprimop(PLIST), env)
100. CALL defvar(STRTOATOM("READ"), mkprimop(PREAD), env)
101. CALL defvar(STRTOATOM("<"), mkprimop(PLT), env)
102. CALL defvar(STRTOATOM(">"), mkprimop(PGT), env)
103. CALL defvar(STRTOATOM(">="), mkprimop(PGEQ), env)
104. CALL defvar(STRTOATOM("<="), mkprimop(LEQ), env)
105. CALL defvar(STRTOATOM("SYMBOL?"), mkprimop(PSYMP), env)
106. CALL defvar(STRTOATOM("NUMBER?"), mkprimop(PNUMP), env)
107. CALL defvar(STRTOATOM("PROCEDURE?"), mkprimop(PPROCP), env)
108. CALL defvar(STRTOATOM("PAIR?"), mkprimop(PCONSP), env)
109.  
110. DO
111.     LINE INPUT ">"; q$
112.     r$ = DoLISP$(q$, env)
113.     PRINT r$: PRINT
114. LOOP
115.  
116. ''''''''''
117.  
118.  
119.  
120. FUNCTION DoLISP$ (TheStringIn AS STRING, envin)
121. TheInput$ = TheStringIn
122. TheOutput$ = ""
123. s = READOBJ(0)
124. SELECT CASE s
125.     CASE TOKCLOSE
126.         ' Unmatched closed parenthesis.
127.         TheOutput$ = TheOutput$ + "[Unmatched closed parenthesis.]"
128.     CASE TOKDOT
129.         'PRINT "Dot used outside list."
130.         TheOutput$ = TheOutput$ + "[Dot used outside list.]"
131.     CASE TOKERR
132.         'PRINT "[Error]"
133.         TheOutput$ = TheOutput$ + "[Error]"
134.     CASE ELSE
135.         CALL PRINTOBJ(EVALOBJ(s, envin))
136. END SELECT
137. DoLISP$ = TheOutput$
138. END FUNCTION
139.  
140. 'DO
141. '    s = READOBJ(0)
142. '    SELECT CASE s
143. '        CASE TOKCLOSE
144. '            ' unmatched closed parenthesis
145. '        CASE TOKDOT
146. '            PRINT "dot used outside list"
147. '        CASE TOKERR
148. '            PRINT "[Error]"
149. '        CASE ELSE
150. '            CALL PRINTOBJ(EVALOBJ(s, env))
151. '    END SELECT
152. '    PRINT
153. '    IF gcnow THEN CALL gc(env)
154. 'LOOP
155.  
156. FUNCTION ALLOC
157. ALLOC = hptr
158. hptr = hptr + 1
159. IF hptr > (mmin + 3 * (msize / 4)) THEN gcnow = -1
160. END FUNCTION
161.  
162. FUNCTION apply (id, args)
163. IF heap(id, 0) = TPROC THEN
164.     params = heap(id, 1)
165.     body = heap(heap(id, 2), 1)
166.     procenv = heap(heap(id, 2), 2)
167.     env = CONS(CONS(params, args), procenv)
168.     DO WHILE heap(body, 2)
169.         t = heap(body, 1)
170.         t = EVALOBJ(t, env) 'ignore result
171.         body = heap(body, 2)
172.     LOOP
173.     t = heap(body, 1)
174.     apply = EVALOBJ(t, env)
175. ELSEIF heap(id, 0) = TPPROC THEN
176.     SELECT CASE heap(id, 1)
177.         CASE PPLUS
178.             sum = 0
179.             a = args
180.             WHILE a
181.                 sum = sum + heap(heap(a, 1), 1)
182.                 a = heap(a, 2)
183.             WEND
184.             p = ALLOC
185.             heap(p, 0) = TNUM
186.             heap(p, 1) = sum
187.             apply = p
188.         CASE PTIMES
189.             prod = 1
190.             a = args
191.             WHILE a
192.                 prod = prod * heap(heap(a, 1), 1)
193.                 a = heap(a, 2)
194.             WEND
195.             p = ALLOC
196.             heap(p, 0) = TNUM
197.             heap(p, 1) = prod
198.             apply = p
199.             'CASE PMOD
200.             '    prod = 1
201.             '    a = args
202.             '    WHILE a
203.             '        prod = prod MOD heap(heap(a, 1), 1)
204.             '        a = heap(a, 2)
205.             '    WEND
206.             '    p = ALLOC
207.             '    heap(p, 0) = TNUM
208.             '    heap(p, 1) = prod
209.             '    apply = p
210.         CASE PCONS
211.             apply = CONS(heap(args, 1), heap(heap(args, 2), 1))
212.         CASE PCAR
213.             apply = heap(heap(args, 1), 1)
214.         CASE PCDR
215.             apply = heap(heap(args, 1), 2)
216.         CASE PEQUAL
217.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
218.             f = heap(heap(args, 1), 1)
219.             a = heap(args, 2)
220.             DO WHILE a
221.                 IF heap(heap(a, 1), 1) <> f THEN apply = TNIL: EXIT FUNCTION
222.                 a = heap(a, 2)
223.             LOOP
224.             apply = STRTOATOM("T"): EXIT FUNCTION
225.         CASE PNOT
226.             IF heap(args, 1) THEN apply = TNIL ELSE apply = STRTOATOM("T")
227.         CASE PEQ
228.             arg1 = heap(args, 1)
229.             arg2 = heap(heap(args, 2), 1)
230.             IF heap(arg1, 0) <> heap(arg2, 0) THEN apply = TNIL: EXIT FUNCTION
231.             SELECT CASE heap(arg1, 0)
232.                 CASE TNUM, TPROC, TPPROC, TSYM
233.                     IF heap(arg1, 1) = heap(arg2, 1) THEN apply = STRTOATOM("T")
234.                 CASE TCONS, TNIL
235.                     IF arg1 = arg2 THEN apply = STRTOATOM("T")
236.             END SELECT
237.         CASE PLT
238.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
239.             f = heap(heap(args, 1), 1)
240.             a = heap(args, 2)
241.             DO WHILE a
242.                 IF f < heap(heap(a, 1), 1) THEN
243.                     f = heap(heap(a, 1), 1)
244.                     a = heap(a, 2)
245.                 ELSE
246.                     apply = TNIL: EXIT FUNCTION
247.                 END IF
248.             LOOP
249.             apply = STRTOATOM("T"): EXIT FUNCTION
250.         CASE PGT
251.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
252.             f = heap(heap(args, 1), 1)
253.             a = heap(args, 2)
254.             DO WHILE a
255.                 IF f > heap(heap(a, 1), 1) THEN
256.                     f = heap(heap(a, 1), 1)
257.                     a = heap(a, 2)
258.                 ELSE
259.                     apply = TNIL: EXIT FUNCTION
260.                 END IF
261.             LOOP
262.             apply = STRTOATOM("T"): EXIT FUNCTION
263.         CASE PLEQ
264.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
265.             f = heap(heap(args, 1), 1)
266.             a = heap(args, 2)
267.             DO WHILE a
268.                 IF f <= heap(heap(a, 1), 1) THEN
269.                     f = heap(heap(a, 1), 1)
270.                     a = heap(a, 2)
271.                 ELSE
272.                     apply = TNIL: EXIT FUNCTION
273.                 END IF
274.             LOOP
275.             apply = STRTOATOM("T"): EXIT FUNCTION
276.         CASE PGEQ
277.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
278.             f = heap(heap(args, 1), 1)
279.             a = heap(args, 2)
280.             DO WHILE a
281.                 IF f >= heap(heap(a, 1), 1) THEN
282.                     f = heap(heap(a, 1), 1)
283.                     a = heap(a, 2)
284.                 ELSE
285.                     apply = TNIL: EXIT FUNCTION
286.                 END IF
287.             LOOP
288.             apply = STRTOATOM("T"): EXIT FUNCTION
289.         CASE PSETCAR
290.             arg1 = heap(args, 1)
291.             arg2 = heap(heap(args, 2), 1)
292.             heap(arg1, 1) = arg2
293.         CASE PSETCDR
294.             arg1 = heap(args, 1)
295.             arg2 = heap(heap(args, 2), 1)
296.             heap(arg2, 2) = arg2
297.         CASE PAPPLY
298.             arg1 = heap(args, 1)
299.             arg2 = heap(heap(args, 2), 1)
300.             apply = apply(arg1, arg2)
301.         CASE PLIST
302.             apply = args
303.         CASE PREAD
304.             apply = READOBJ(0)
305.         CASE PMINUS
306.             arg1 = heap(heap(args, 1), 1)
307.             rargs = heap(args, 2)
308.             IF rargs THEN
309.                 res = arg1
310.                 WHILE rargs
311.                     res = res - heap(heap(rargs, 1), 1)
312.                     rargs = heap(rargs, 2)
313.                 WEND
314.                 p = ALLOC
315.                 heap(p, 0) = TNUM: heap(p, 1) = res: apply = p
316.             ELSE
317.                 p = ALLOC: heap(p, 0) = TNUM: heap(p, 1) = -arg1
318.                 apply = p
319.             END IF
320.         CASE PSYMP
321.             targ1 = heap(heap(args, 1), 0)
322.             IF targ1 = TSYM THEN apply = STRTOATOM("T")
323.         CASE PNUMP
324.             targ1 = heap(heap(args, 1), 0)
325.             IF targ1 = TNUM THEN apply = STRTOATOM("T")
326.         CASE PPROCP
327.             targ1 = heap(heap(args, 1), 0)
328.             IF targ1 = TPROC OR targ1 = TPPROC THEN apply = STRTOATOM("T")
329.         CASE PCONSP
330.             targ1 = heap(heap(args, 1), 0)
331.             IF targ1 = TCONS THEN apply = STRTOATOM("T")
332.     END SELECT
333. ELSE
334.     PRINT "Bad application -- not a function"
335.     apply = TOKERR
336. END IF
337. END FUNCTION
338.  
339. FUNCTION CONS (car, cdr)
340. p = ALLOC
341. heap(p, 0) = TCONS
342. heap(p, 1) = car
343. heap(p, 2) = cdr
344. CONS = p
345. END FUNCTION
346.  
347. SUB defvar (id, value, env)
348. anum = heap(id, 1)
349. frame = heap(env, 1)
350. vars = heap(frame, 1)
351. vals = heap(frame, 2)
352. WHILE vars
353.     IF heap(heap(vars, 1), 1) = anum THEN
354.         heap(vals, 1) = value: EXIT SUB
355.     END IF
356.     vars = heap(vars, 2): vals = heap(vals, 2)
357. WEND
358. vars = heap(frame, 1)
359. vals = heap(frame, 2)
360. heap(frame, 1) = CONS(id, vars)
361. heap(frame, 2) = CONS(value, vals)
362. END SUB
363.  
364. FUNCTION EVALOBJ (id, env)
365. 1 SELECT CASE heap(id, 0)
366.     CASE TNIL, TNUM ' self-evaluating
367.         EVALOBJ = id
368.     CASE TSYM
369.         EVALOBJ = lookup(heap(id, 1), env)
370.     CASE TCONS
371.         o = heap(id, 1)
372.         t = heap(o, 0)
373.         IF t = TSYM THEN
374.             a$ = atom$(heap(o, 1)) ' symbol name of car(id)
375.             SELECT CASE a$
376.                 CASE "QUOTE"
377.                     EVALOBJ = heap(heap(id, 2), 1)
378.                 CASE "SET!"
379.                     vid = heap(heap(id, 2), 1) 'cadr
380.                     aval = heap(heap(heap(id, 2), 2), 1) 'caddr
381.                     CALL setvar(vid, EVALOBJ(aval, env), env)
382.                 CASE "DEFINE"
383.                     vid = heap(heap(id, 2), 1)
384.                     aval = heap(heap(heap(id, 2), 2), 1)
385.                     CALL setvar(vid, EVALOBJ(aval, env), env)
386.                 CASE "IF"
387.                     ' (if pred ic ia)
388.                     pred = heap(heap(id, 2), 1) 'predicate = cadr
389.                     ic = heap(heap(heap(id, 2), 2), 1) ' caddr
390.                     ia = heap(heap(heap(heap(id, 2), 2), 2), 1) ' cadddr
391.                     IF EVALOBJ(pred, env) THEN
392.                         ' return EVALOBJ(ic,env)
393.                         id = ic: GOTO 1
394.                     ELSE
395.                         ' return EVALOBJ(ia,env)
396.                         id = ia: GOTO 1
397.                     END IF
398.                 CASE "LAMBDA"
399.                     p = ALLOC
400.                     heap(p, 0) = TPROC
401.                     heap(p, 1) = heap(heap(id, 2), 1) ' cadr = args
402.                     heap(p, 2) = CONS(heap(heap(id, 2), 2), env) 'caddr = body
403.                     EVALOBJ = p
404.                 CASE "BEGIN"
405.                     seq = heap(id, 2)
406.                     DO WHILE heap(seq, 2)
407.                         t = heap(seq, 1)
408.                         t = EVALOBJ(t, env) 'ignore result
409.                         seq = heap(seq, 2)
410.                     LOOP
411.                     id = heap(seq, 1): GOTO 1
412.                 CASE "AND"
413.                     seq = heap(id, 2)
414.                     DO WHILE heap(seq, 2)
415.                         t = heap(seq, 1)
416.                         t = EVALOBJ(t, env)
417.                         IF t = 0 THEN EVALOBJ = 0: EXIT FUNCTION
418.                         seq = heap(seq, 2)
419.                     LOOP
420.                     id = heap(seq, 1): GOTO 1
421.                 CASE "OR"
422.                     seq = heap(id, 2)
423.                     DO WHILE heap(seq, 2)
424.                         t = heap(seq, 1)
425.                         t = EVALOBJ(t, env)
426.                         IF t THEN EVALOBJ = t: EXIT FUNCTION
427.                         seq = heap(seq, 2)
428.                     LOOP
429.                     id = heap(seq, 1): GOTO 1
430.                 CASE "COND"
431.                     clauses = heap(id, 2)
432.                     WHILE clauses
433.                         clause = heap(clauses, 1)
434.                         pred = heap(clause, 1)
435.                         IF EVALOBJ(pred, env) THEN
436.                             seq = heap(clause, 2)
437.                             DO WHILE heap(seq, 2)
438.                                 t = heap(seq, 1)
439.                                 t = EVALOBJ(t, env) 'ignore result
440.                                 seq = heap(seq, 2)
441.                             LOOP
442.                             id = heap(seq, 1): GOTO 1
443.                         END IF
444.                         clauses = heap(clauses, 2)
445.                     WEND
446.                 CASE ELSE
447.                     args = heap(id, 2)
448.                     proc = EVALOBJ(o, env)
449.                     EVALOBJ = apply(proc, lvals(args, env))
450.             END SELECT
451.         ELSE
452.             args = heap(id, 2)
453.             proc = EVALOBJ(o, env)
454.             EVALOBJ = apply(proc, lvals(args, env))
455.         END IF
456.     CASE ELSE
457.         PRINT "Unhandled expression type: "; a$
458.         EVALOBJ = id
459. END SELECT
460. END FUNCTION
461.  
462. FUNCTION hash (s$)
463. DIM h AS LONG
464. FOR i = 1 TO LEN(s$)
465.     c = ASC(MID$(s$, i, 1))
466.     h = (h * 33 + c) MOD hsize
467. NEXT
468. hash = h
469. END FUNCTION
470.  
471. FUNCTION lookup (anum, env)
472. ' env is a list of (vars . vals) frames
473. ' where: vars is a list of symbols
474. '        vals is a list of their values
475. e = env
476. DO
477.     frame = heap(e, 1) ' get the first frame
478.  
479.     vars = heap(frame, 1) ' vars is car
480.  
481.     vals = heap(frame, 2) ' vals is cdr
482.  
483.     WHILE vars ' while vars left to check
484.         IF heap(heap(vars, 1), 1) = anum THEN 'atom number of car(vars) = anum
485.             lookup = heap(vals, 1) ' car(vals)
486.             EXIT FUNCTION
487.         END IF
488.         vars = heap(vars, 2) 'cdr(vars)
489.         vals = heap(vals, 2) 'cdr(vals)
490.     WEND
491.     e = heap(e, 2) ' cdr(e)
492. LOOP WHILE e
493. 'PRINT "Unbound variable: "; atom$(anum)
494. TheOutput$ = TheOutput$ + "Unbound variable: " + atom$(anum)
495. lookup = TOKERR
496. END FUNCTION
497.  
498. FUNCTION lvals (id, env)
499. IF heap(id, 0) = TCONS THEN
500.     car = heap(id, 1)
501.     ecar = EVALOBJ(car, env)
502.     head = CONS(ecar, 0)
503.     l = heap(id, 2): prev = head
504.     WHILE l
505.         car = heap(l, 1)
506.         ecar = EVALOBJ(car, env)
507.         new = CONS(ecar, 0)
508.         heap(prev, 2) = new
509.         prev = new
510.         l = heap(l, 2)
511.     WEND
512.     lvals = head
513. ELSE
514.     lvals = 0
515. END IF
516. END FUNCTION
517.  
518. FUNCTION mkprimop (id)
519. p = ALLOC
520. heap(p, 0) = TPPROC
521. heap(p, 1) = id
522. mkprimop = p
523. END FUNCTION
524.  
525. SUB PRINTOBJ (id)
526.  
527. IF id = TOKERR THEN PRINT "[Error]": EXIT SUB
528. SELECT CASE heap(id, 0)
529.     CASE TNIL
530.         'PRINT "()";
531.         TheOutput$ = TheOutput$ + "()"
532.     CASE TCONS
533.         'PRINT "(";
534.         TheOutput$ = TheOutput$ + "("
535.         printlist:
536.         CALL PRINTOBJ(heap(id, 1))
537.         'PRINT " ";
538.         TheOutput$ = TheOutput$ + " "
539.         cdr = heap(id, 2)
540.         IF heap(cdr, 0) = TCONS THEN id = cdr: GOTO printlist
541.         IF heap(cdr, 0) = TNIL THEN
542.             'PRINT ")";
543.             TheOutput$ = TheOutput$ + ")"
544.         ELSE
545.             'PRINT ".";
546.             TheOutput$ = TheOutput$ + "."
547.             CALL PRINTOBJ(cdr)
548.             'PRINT ")";
549.             TheOutput$ = TheOutput$ + ")"
550.         END IF
551.     CASE TNUM
552.         'PRINT heap(id, 1);
553.         TheOutput$ = TheOutput$ + STR$(heap(id, 1))
554.     CASE TSYM
555.         'PRINT atom$(heap(id, 1));
556.         TheOutput$ = TheOutput$ + atom$(heap(id, 1))
557.     CASE TPROC, TPPROC
558.         'PRINT "[Procedure]"
559.         TheOutput$ = TheOutput$ + "[Procedure]"
560. END SELECT
561. END SUB
562.  
563. FUNCTION READLIST (depth)
564. SH = READOBJ(depth)
565. SELECT CASE SH
566.     CASE TOKERR
567.         READLIST = TOKERR
568.     CASE TOKCLOSE
569.         READLIST = 0
570.     CASE TOKDOT
571.         SH = READOBJ(depth)
572.         SELECT CASE SH
573.             CASE TOKERR, TOKDOT, TOKCLOSE
574.                 READLIST = TOKERR
575.             CASE ELSE
576.                 ST = READLIST(depth)
577.                 IF ST THEN READLIST = TOKERR ELSE READLIST = SH
578.         END SELECT
579.     CASE ELSE
580.         ST = READLIST(depth)
581.         IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH, ST)
582. END SELECT
583. END FUNCTION
584.  
585. FUNCTION READOBJ (depth)
586. tok = READTOKEN(depth)
587. SELECT CASE tok
588.     CASE TOKOPEN
589.         s = READLIST(depth + 1)
590.         READOBJ = s
591.     CASE TOKQUOTE
592.         tok = READOBJ(depth + 1)
593.         SELECT CASE tok
594.             CASE TOKCLOSE
595.                 PRINT "warning: quote before close parenthesis"
596.                 READOBJ = tok
597.             CASE TOKDOT
598.                 PRINT "warning: quote before dot"
599.                 READOBJ = tok
600.             CASE ELSE
601.                 s = CONS(STRTOATOM("QUOTE"), CONS(tok, 0))
602.                 READOBJ = s
603.         END SELECT
604.     CASE ELSE
605.         READOBJ = tok
606. END SELECT
607. END FUNCTION
608.  
609. FUNCTION READTOKEN (depth)
610.  
611. start1: bufend = LEN(buf)
612. WHILE bufpos < bufend AND INSTR(" " + CHR$(9), MID$(buf, bufpos, 1))
613.     bufpos = bufpos + 1
614. WEND
615. c$ = MID$(buf, bufpos, 1)
616. IF INSTR(":;", c$) THEN
617.     IF c$ = ":" THEN
618.         bufpos = bufpos + 1
619.         IF bufpos <= bufend THEN
620.             SELECT CASE MID$(buf, bufpos, 1)
621.                 CASE "q", "Q" ' quit
622.                     SYSTEM
623.                 CASE "g", "G" ' garbage collect now
624.                     gcnow = -1
625.                 CASE ELSE
626.                     READTOKEN = TOKERR
627.                     EXIT FUNCTION
628.             END SELECT
629.         END IF
630.     END IF
631.     bufpos = bufend + 1
632. END IF
633. IF bufpos > bufend THEN
634.     'IF depth = 0 THEN PRINT "]=> ";
635.     'LINE INPUT buf
636.     buf = TheInput$
637.     bufend = LEN(buf)
638.     bufpos = 1
639.     GOTO start1
640. END IF
641. SELECT CASE c$
642.     CASE "("
643.         bufpos = bufpos + 1
644.         READTOKEN = TOKOPEN
645.     CASE ")"
646.         bufpos = bufpos + 1
647.         READTOKEN = TOKCLOSE
648.     CASE "'"
649.         bufpos = bufpos + 1
650.         READTOKEN = TOKQUOTE
651.     CASE "."
652.         bufpos = bufpos + 1
653.         READTOKEN = TOKDOT
654.     CASE ELSE
655.         strbeg = bufpos
656.         bufpos = bufpos + 1
657.         DO WHILE bufpos <= bufend
658.             c$ = MID$(buf, bufpos, 1)
659.             IF c$ = " " OR c$ = "." OR c$ = "(" OR c$ = ")" THEN EXIT DO
660.             bufpos = bufpos + 1
661.         LOOP
662.         READTOKEN = STRTOATOM(MID$(buf, strbeg, bufpos - strbeg))
663. END SELECT
664. END FUNCTION
665.  
666. SUB setvar (id, value, env)
667. anum = heap(id, 1)
668. e = env
669. DO
670.     frame = heap(e, 1)
671.     vars = heap(frame, 1)
672.     vals = heap(frame, 2)
673.     WHILE vars
674.         IF heap(heap(vars, 1), 1) = anum THEN
675.             heap(vals, 1) = value: EXIT SUB
676.         END IF
677.         vars = heap(vars, 2): vals = heap(vals, 2)
678.     WEND
679.     e = heap(e, 2)
680. LOOP WHILE e
681. CALL defvar(id, value, env)
682. END SUB
683.  
684. FUNCTION STRTOATOM (s$)
685. l = LEN(s$)
686. c$ = LEFT$(s$, 1)
687. IF (c$ = "-" AND l >= 2) OR (c$ >= "0" AND c$ <= "9") THEN
688.     v = 0
689.     IF c$ = "-" THEN neg = 1: idx = 2 ELSE neg = 0: idx = 1
690.     FOR idx = idx TO l
691.         c$ = MID$(s$, idx, 1)
692.         IF (c$ >= "0" AND c$ <= "9") THEN
693.             v = v * 10 + (ASC(c$) - ASC("0"))
694.         ELSE
695.             EXIT FOR
696.         END IF
697.     NEXT
698.     IF idx = l + 1 THEN
699.         IF neg THEN v = -v
700.         p = ALLOC
701.         heap(p, 0) = TNUM
702.         heap(p, 1) = v
703.         STRTOATOM = p: EXIT FUNCTION
704.     END IF
705. END IF
706. IF UCASE$(s$) = "NIL" THEN STRTOATOM = TOKNIL: EXIT FUNCTION
707.  
708. i = hash(UCASE$(s$))
709. FOR count = 1 TO hsize
710.     IF atom$(i) = UCASE$(s$) THEN
711.         found = TRUE: EXIT FOR
712.     ELSEIF atom$(i) = "" THEN
713.         atom$(i) = UCASE$(s$)
714.         found = TRUE
715.         EXIT FOR
716.     ELSE
717.         i = (i + count) MOD hsize
718.     END IF
719. NEXT
720. IF NOT found THEN PRINT "Symbol table full!"
721. p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
722. STRTOATOM = p
723. END FUNCTION
724.  
725. SUB gc (root)
726. hptr = nmin
727. root = collect(root)
728. SWAP mmin, nmin
729. SWAP mmax, nmax
730. gcnow = 0
731. END SUB
732.  
733. FUNCTION collect (p)
734.  
735. SELECT CASE heap(p, 0)
736.  
737.     CASE -1
738.         collect = heap(p, 1)
739.  
740.     CASE TCONS, TPROC
741.  
742.         ' address of new copy
743.         x = ALLOC
744.  
745.         ' car, cdr
746.         a = heap(p, 1)
747.         d = heap(p, 2)
748.  
749.         ' replace with forwarding address
750.         heap(p, 0) = -1
751.         heap(p, 1) = x
752.  
753.         ' copy
754.         heap(x, 0) = heap(p, 0)
755.         heap(x, 1) = collect(a)
756.         heap(x, 2) = collect(d)
757.         collect = x
758.  
759.     CASE TNIL
760.         collect = 0
761.  
762.     CASE ELSE
763.         x = ALLOC
764.  
765.         ' copy the entire structure
766.         FOR i = 0 TO 2
767.             heap(x, i) = heap(p, i)
768.         NEXT
769.  
770.         ' write forwarding address
771.         heap(p, 0) = -1
772.         heap(p, 1) = x
773.         collect = x
774. END SELECT
775.  
776. END FUNCTION
777.  

Code: QB64: [Select]

1. (+ 2 2)
2. (apply + '(1 2 3))
3. (+ 1 -3 2 5)
4. (define generator (lambda (x) (lambda (y) (if y (generator y) x))))
5. (define pocket (generator 8))
6. (pocket nil)
7. (define pocktwo (pocket 10))
8. (pocktwo '())
9. (define fact (lambda (x) (if (= x 0) 1 (* x (fact (+ x -1))))))
10. (fact 5)
11. (fact 7)
12. (DEFINE MAP (LAMBDA (F X) (IF X (CONS (F (CAR X)) (MAP F (CDR X))))))
13. (MAP (LAMBDA (X) (* X 2)) '(1 2 3 4 5 6 7 ))

[FellippeHeitor]

Welcome to our new place, qbguy!

[qbguy]

Looks like QB64 still interprets 0-placed recursive functions incorrectly.  The version I posted triggers the recursion bug but it is easy to change the code so as not to use zero-place functions (e.g. make depth a parameter or add a dummy parameter).  STxAxTIC's modified version has this modification already but has the read code modified so it reads from a line of input so you can't split your expressions across lines.

[jcolivo]

More importantly though, I saved the test code because I don't think the audience here delves into LISPy things.

Me too. I love Scheme.

--JC

[bplus]

Ah something I have been meaning to check out. Thanks for reminder :)

[jack]

hello bplus
if you want to investigate/explore the Scheme language I suggest you give Racket a try https://www.racket-lang.org
it has a nice IDE and it's designed for students, that is, the IDE gives hints when mistakes are made.

[bplus]

Thanks jack,

I did download Dr Rachet, er Racket, and started the intro course because it plays with pictures :)

Very different experience.