Scheme interpreter in QBASIC

Question

I wrote an interpreter for Scheme which includes stop and copy garbage collection.

DefInt A-Z
DECLARE FUNCTION hash (s$)
DECLARE FUNCTION READOBJ (depth)
DECLARE FUNCTION READTOKEN (depth)
DECLARE FUNCTION STRTOATOM (s$)
DECLARE FUNCTION CONS (car, cdr)
DECLARE FUNCTION READLIST (depth)
DECLARE FUNCTION ALLOC ()
DECLARE SUB PRINTOBJ (id)
DECLARE FUNCTION EVALOBJ (id, env)
DECLARE FUNCTION apply (f, args)
DECLARE FUNCTION lookup (anum, env)
DECLARE FUNCTION lvals (id, env)
DECLARE SUB defvar (var, vals, env)
DECLARE SUB setvar (id, vals, env)
DECLARE FUNCTION mkprimop (id)
DECLARE FUNCTION collect(p)
DECLARE SUB gc(root)
' Make these smaller to get it to work in QBASIC / QuickBASIC
' Compiles in QB64 or FreeBASIC
Const msize = 16384 'size of memory -- arbitrary
Const hsize = 16384 'size of hash table -- should be power of 2
Dim Shared bufpos As Integer ' position in input line
Dim Shared buf As String ' line of input from STDIN
Dim Shared hptr ' next location in array below
Dim Shared atom$(0 To hsize - 1) ' hash table for interning strings
Dim Shared heap(2 * msize - 1, 2) ' store LISP objects
Dim Shared mmin, nmin, gcnow ' used by garbage collector
mmin = 1: nmin = msize 
' split memory storage in 2 for garbage collector
' on GC, all objects are compacted into the other half
' and mmin, nmin switch roles
Const TRUE = -1 ' all ones bit pattern (conventional in BASIC)
Const FALSE = 0
' Constants for object type
Const TNIL = 0
Const TCONS = 2
Const TNUM = 3
Const TSYM = 4
Const TPROC = 5
Const TPPROC = 6
' Constants for token type
Const TOKNIL = 0
Const TOKERR = -1
Const TOKOPEN = -2
Const TOKCLOSE = -3
Const TOKQUOTE = -4
Const TOKDOT = -5
' Constants for primitive functions
Const PPLUS = 1
Const PMINUS = 2
Const PTIMES = 3
Const PCONS = 4
Const PCAR = 5
Const PCDR = 6
Const PEQUAL = 7
Const PNOT = 8
Const PEQ = 9
Const PSETCAR = 10
Const PSETCDR = 11
Const PAPPLY = 12
Const PLIST = 13
Const PREAD = 14
Const PLT = 15
Const PGT = 16
Const PGEQ = 17
Const PLEQ = 18
Const PNUMP = 20
Const PPROCP = 21
Const PSYMP = 22
Const PCONSP = 24
hptr = mmin: bufpos = 1
' create an empty environment frame
vars = TNIL
vals = TNIL
frame = CONS(vars, vals)
env = CONS(frame, TNIL)
' add primitive functions to environment
Call defvar(STRTOATOM("+"), mkprimop(PPLUS), env)
Call defvar(STRTOATOM("-"), mkprimop(PMINUS), env)
Call defvar(STRTOATOM("*"), mkprimop(PTIMES), env)
Call defvar(STRTOATOM("CONS"), mkprimop(PCONS), env)
Call defvar(STRTOATOM("CAR"), mkprimop(PCAR), env)
Call defvar(STRTOATOM("CDR"), mkprimop(PCDR), env)
Call defvar(STRTOATOM("="), mkprimop(PEQUAL), env)
Call defvar(STRTOATOM("NOT"), mkprimop(PNOT), env)
Call defvar(STRTOATOM("EQ?"), mkprimop(PEQ), env)
Call defvar(STRTOATOM("EQV?"), mkprimop(PEQ), env)
Call defvar(STRTOATOM("T"), STRTOATOM("T"), env) ' true
Call defvar(STRTOATOM("SET-CAR!"), mkprimop(PSETCAR), env)
Call defvar(STRTOATOM("SET-CDR!"), mkprimop(PSETCDR), env)
Call defvar(STRTOATOM("APPLY"), mkprimop(PAPPLY), env)
Call defvar(STRTOATOM("LIST"), mkprimop(PLIST), env)
Call defvar(STRTOATOM("READ"), mkprimop(PREAD), env)
Call defvar(STRTOATOM("<"), mkprimop(PLT), env)
Call defvar(STRTOATOM(">"), mkprimop(PGT), env)
Call defvar(STRTOATOM(">="), mkprimop(PGEQ), env)
Call defvar(STRTOATOM("<="), mkprimop(LEQ), env)
Call defvar(STRTOATOM("SYMBOL?"), mkprimop(PSYMP), env)
Call defvar(STRTOATOM("NUMBER?"), mkprimop(PNUMP), env)
Call defvar(STRTOATOM("PROCEDURE?"), mkprimop(PPROCP), env)
Call defvar(STRTOATOM("PAIR?"), mkprimop(PCONSP), env)
' Read eval print loop
Do
 s = READOBJ(0) ' read a LISP object
 Select Case s ' check the return value
 Case TOKCLOSE ' ignore extra close parens 
 ' unmatched closed parenthesis
 Case TOKDOT
 Print "dot used outside list"
 Case TOKERR
 Print "[Error]"
 Case Else ' no syntax error, evaluate and print
 Call PRINTOBJ(EVALOBJ(s, env))
 End Select
 Print
 If gcnow Then Call gc(env) ' need to garbage collect
Loop
' return the index of a new LISP cell
Function ALLOC
 ALLOC = hptr
 hptr = hptr + 1
 If hptr > (mmin + 3 * (msize / 4)) Then gcnow = True
End Function
' apply the function in the lisp cell with index id
' to the arguments in args (also an index of a lisp cell)
Function apply (id, args)
 If heap(id, 0) = TPROC Then ' user-defined procedure
' stored as a LISP list
 params = heap(id, 1) ' car is params
 body = heap(heap(id, 2), 1) ' cadr is body definition
 procenv = heap(heap(id, 2), 2) ' cddr is environment
' add the params to the environment
 env = CONS(CONS(params, args), procenv)
 Do While heap(body, 2) 
' if body contains more than one expression, evaluate in sequence
' and then take the last one
 t = heap(body, 1)
 t = EVALOBJ(t, env) 'ignore result
 body = heap(body, 2)
 Loop
 t = heap(body, 1)
 apply = EVALOBJ(t, env)
 ElseIf heap(id, 0) = TPPROC Then ' primitive (built-in) procedure
 Select Case heap(id, 1) 
' long switch statement for each builtin
 Case PPLUS
 sum = 0
 a = args
 While a
 sum = sum + heap(heap(a, 1), 1)
 a = heap(a, 2)
 Wend
 p = ALLOC
 heap(p, 0) = TNUM
 heap(p, 1) = sum
 apply = p
 Case PTIMES
 prod = 1
 a = args
 While a
 prod = prod * heap(heap(a, 1), 1)
 a = heap(a, 2)
 Wend
 p = ALLOC
 heap(p, 0) = TNUM
 heap(p, 1) = prod
 apply = p
 Case PCONS
 apply = CONS(heap(args, 1), heap(heap(args, 2), 1))
 Case PCAR
 apply = heap(heap(args, 1), 1)
 Case PCDR
 apply = heap(heap(args, 1), 2)
 Case PEQUAL
 If args = TNIL Then apply = STRTOATOM("T"): Exit Function
 f = heap(heap(args, 1), 1)
 a = heap(args, 2)
 Do While a
 If heap(heap(a, 1), 1) <> f Then apply = TNIL: Exit Function
 a = heap(a, 2)
 Loop
 apply = STRTOATOM("T"): Exit Function
 Case PNOT
 If heap(args, 1) Then apply = TNIL Else apply = STRTOATOM("T")
 Case PEQ
 arg1 = heap(args, 1)
 arg2 = heap(heap(args, 2), 1)
 If heap(arg1, 0) <> heap(arg2, 0) Then apply = TNIL: Exit Function
 Select Case heap(arg1, 0)
 Case TNUM, TPROC, TPPROC, TSYM
 If heap(arg1, 1) = heap(arg2, 1) Then apply = STRTOATOM("T")
 Case TCONS, TNIL
 If arg1 = arg2 Then apply = STRTOATOM("T")
 End Select
 Case PLT
 If args = TNIL Then apply = STRTOATOM("T"): Exit Function
 f = heap(heap(args, 1), 1)
 a = heap(args, 2)
 Do While a
 If f < heap(heap(a, 1), 1) Then
 f = heap(heap(a, 1), 1)
 a = heap(a, 2)
 Else
 apply = TNIL: Exit Function
 End If
 Loop
 apply = STRTOATOM("T"): Exit Function
 Case PGT
 If args = TNIL Then apply = STRTOATOM("T"): Exit Function
 f = heap(heap(args, 1), 1)
 a = heap(args, 2)
 Do While a
 If f > heap(heap(a, 1), 1) Then
 f = heap(heap(a, 1), 1)
 a = heap(a, 2)
 Else
 apply = TNIL: Exit Function
 End If
 Loop
 apply = STRTOATOM("T"): Exit Function
 Case PLEQ
 If args = TNIL Then apply = STRTOATOM("T"): Exit Function
 f = heap(heap(args, 1), 1)
 a = heap(args, 2)
 Do While a
 If f <= heap(heap(a, 1), 1) Then
 f = heap(heap(a, 1), 1)
 a = heap(a, 2)
 Else
 apply = TNIL: Exit Function
 End If
 Loop
 apply = STRTOATOM("T"): Exit Function
 Case PGEQ
 If args = TNIL Then apply = STRTOATOM("T"): Exit Function
 f = heap(heap(args, 1), 1)
 a = heap(args, 2)
 Do While a
 If f >= heap(heap(a, 1), 1) Then
 f = heap(heap(a, 1), 1)
 a = heap(a, 2)
 Else
 apply = TNIL: Exit Function
 End If
 Loop
 apply = STRTOATOM("T"): Exit Function
 Case PSETCAR
 arg1 = heap(args, 1)
 arg2 = heap(heap(args, 2), 1)
 heap(arg1, 1) = arg2
 Case PSETCDR
 arg1 = heap(args, 1)
 arg2 = heap(heap(args, 2), 1)
 heap(arg2, 2) = arg2
 Case PAPPLY
 arg1 = heap(args, 1)
 arg2 = heap(heap(args, 2), 1)
 apply = apply(arg1, arg2)
 Case PLIST
 apply = args
 Case PREAD
 apply = READOBJ(0)
 Case PMINUS
 arg1 = heap(heap(args, 1), 1)
 rargs = heap(args, 2)
 If rargs Then
 res = arg1
 While rargs
 res = res - heap(heap(rargs, 1), 1)
 rargs = heap(rargs, 2)
 Wend
 p = ALLOC
 heap(p, 0) = TNUM: heap(p, 1) = res: apply = p
 Else
 p = ALLOC: heap(p, 0) = TNUM: heap(p, 1) = -arg1
 apply = p
 End If
 Case PSYMP
 targ1 = heap(heap(args, 1), 0)
 If targ1 = TSYM Then apply = STRTOATOM("T")
 Case PNUMP
 targ1 = heap(heap(args, 1), 0)
 If targ1 = TNUM Then apply = STRTOATOM("T")
 Case PPROCP
 targ1 = heap(heap(args, 1), 0)
 If targ1 = TPROC Or targ1 = TPPROC Then apply = STRTOATOM("T")
 Case PCONSP
 targ1 = heap(heap(args, 1), 0)
 If targ1 = TCONS Then apply = STRTOATOM("T")
 End Select
 Else
 Print "Bad application -- not a function"
 apply = TOKERR
 End If
End Function
Function CONS (car, cdr)
 p = ALLOC
 heap(p, 0) = TCONS
 heap(p, 1) = car
 heap(p, 2) = cdr
 CONS = p
End Function
Sub defvar (id, value, env)
 anum = heap(id, 1)
 frame = heap(env, 1)
 vars = heap(frame, 1)
 vals = heap(frame, 2)
 While vars
 If heap(heap(vars, 1), 1) = anum Then
 heap(vals, 1) = value: Exit Sub
 End If
 vars = heap(vars, 2): vals = heap(vals, 2)
 Wend
 vars = heap(frame, 1)
 vals = heap(frame, 2)
 heap(frame, 1) = CONS(id, vars)
 heap(frame, 2) = CONS(value, vals)
End Sub
Function EVALOBJ (id, env)
 1 Select Case heap(id, 0)
 Case TNIL, TNUM ' self-evaluating
 EVALOBJ = id
 Case TSYM
 EVALOBJ = lookup(heap(id, 1), env)
 Case TCONS
 o = heap(id, 1)
 t = heap(o, 0)
 If t = TSYM Then
 a$ = atom$(heap(o, 1)) ' symbol name of car(id)
 Select Case a$
 Case "QUOTE"
 EVALOBJ = heap(heap(id, 2), 1)
 Case "SET!"
 vid = heap(heap(id, 2), 1) 'cadr
 aval = heap(heap(heap(id, 2), 2), 1) 'caddr
 Call setvar(vid, EVALOBJ(aval, env), env)
 Case "DEFINE"
 vid = heap(heap(id, 2), 1)
 aval = heap(heap(heap(id, 2), 2), 1)
 Call setvar(vid, EVALOBJ(aval, env), env)
 Case "IF"
 ' (if pred ic ia)
 pred = heap(heap(id, 2), 1) 'predicate = cadr
 ic = heap(heap(heap(id, 2), 2), 1) ' caddr
 ia = heap(heap(heap(heap(id, 2), 2), 2), 1) ' cadddr
 If EVALOBJ(pred, env) Then
 ' return EVALOBJ(ic,env)
 id = ic: GoTo 1
 Else
 ' return EVALOBJ(ia,env)
 id = ia: GoTo 1
 End If
 Case "LAMBDA"
 p = ALLOC
 heap(p, 0) = TPROC
 heap(p, 1) = heap(heap(id, 2), 1) ' cadr = args
 heap(p, 2) = CONS(heap(heap(id, 2), 2), env) 'caddr = body
 EVALOBJ = p
 Case "BEGIN"
 seq = heap(id, 2)
 Do While heap(seq, 2)
 t = heap(seq, 1)
 t = EVALOBJ(t, env) 'ignore result
 seq = heap(seq, 2)
 Loop
 id = heap(seq, 1): GoTo 1
 Case "AND"
 seq = heap(id, 2)
 Do While heap(seq, 2)
 t = heap(seq, 1)
 t = EVALOBJ(t, env)
 If t = 0 Then EVALOBJ = 0: Exit Function
 seq = heap(seq, 2)
 Loop
 id = heap(seq, 1): GoTo 1
 Case "OR"
 seq = heap(id, 2)
 Do While heap(seq, 2)
 t = heap(seq, 1)
 t = EVALOBJ(t, env)
 If t Then EVALOBJ = t: Exit Function
 seq = heap(seq, 2)
 Loop
 id = heap(seq, 1): GoTo 1
 Case "COND"
 clauses = heap(id, 2)
 While clauses
 clause = heap(clauses, 1)
 pred = heap(clause, 1)
 If EVALOBJ(pred, env) Then
 seq = heap(clause, 2)
 Do While heap(seq, 2)
 t = heap(seq, 1)
 t = EVALOBJ(t, env) 'ignore result
 seq = heap(seq, 2)
 Loop
 id = heap(seq, 1): GoTo 1
 End If
 clauses = heap(clauses, 2)
 Wend
 Case Else
 args = heap(id, 2)
 proc = EVALOBJ(o, env)
 EVALOBJ = apply(proc, lvals(args, env))
 End Select
 Else
 args = heap(id, 2)
 proc = EVALOBJ(o, env)
 EVALOBJ = apply(proc, lvals(args, env))
 End If
 Case Else
 Print "Unhandled expression type: "; a$
 EVALOBJ = id
 End Select
End Function
Function hash (s$)
 Dim h As Long
 For i = 1 To Len(s$)
 c = Asc(Mid$(s,ドル i, 1))
 h = (h * 33 + c) Mod hsize
 Next
 hash = h
End Function
Function lookup (anum, env)
 ' env is a list of (vars . vals) frames
 ' where: vars is a list of symbols
 ' vals is a list of their values
 e = env
 Do
 frame = heap(e, 1) ' get the first frame
 vars = heap(frame, 1) ' vars is car
 vals = heap(frame, 2) ' vals is cdr
 While vars ' while vars left to check
 If heap(heap(vars, 1), 1) = anum Then 'atom number of car(vars) = anum
 lookup = heap(vals, 1) ' car(vals)
 Exit Function
 End If
 vars = heap(vars, 2) 'cdr(vars)
 vals = heap(vals, 2) 'cdr(vals)
 Wend
 e = heap(e, 2) ' cdr(e)
 Loop While e
 Print "Unbound variable: "; atom$(anum): lookup = TOKERR
End Function
Function lvals (id, env)
 If heap(id, 0) = TCONS Then
 car = heap(id, 1)
 ecar = EVALOBJ(car, env)
 head = CONS(ecar, 0)
 l = heap(id, 2): prev = head
 While l
 car = heap(l, 1)
 ecar = EVALOBJ(car, env)
 new = CONS(ecar, 0)
 heap(prev, 2) = new
 prev = new
 l = heap(l, 2)
 Wend
 lvals = head
 Else
 lvals = 0
 End If
End Function
Function mkprimop (id)
 p = ALLOC
 heap(p, 0) = TPPROC
 heap(p, 1) = id
 mkprimop = p
End Function
Sub PRINTOBJ (id)
 If id = TOKERR Then Print "[Error]": Exit Sub
 Select Case heap(id, 0)
 Case TNIL
 Print "()";
 Case TCONS
 Print "(";
 printlist:
 Call PRINTOBJ(heap(id, 1))
 Print " ";
 cdr = heap(id, 2)
 If heap(cdr, 0) = TCONS Then id = cdr: GoTo printlist
 If heap(cdr, 0) = TNIL Then
 Print ")";
 Else
 Print ".";
 Call PRINTOBJ(cdr)
 Print ")";
 End If
 Case TNUM
 Print Str$(heap(id, 1));
 Case TSYM
 Print atom$(heap(id, 1));
 Case TPROC, TPPROC
 Print "[Procedure]"
 End Select
End Sub
Function READLIST (depth)
 SH = READOBJ(depth)
 Select Case SH
 Case TOKERR
 READLIST = TOKERR
 Case TOKCLOSE
 READLIST = 0
 Case TOKDOT
 SH = READOBJ(depth)
 Select Case SH
 Case TOKERR, TOKDOT, TOKCLOSE
 READLIST = TOKERR
 Case Else
 ST = READLIST(depth)
 If ST Then READLIST = TOKERR Else READLIST = SH
 End Select
 Case Else
 ST = READLIST(depth)
 If ST = TOKERR Then READLIST = TOKERR Else READLIST = CONS(SH, ST)
 End Select
End Function
Function READOBJ (depth)
 tok = READTOKEN(depth)
 Select Case tok
 Case TOKOPEN
 s = READLIST(depth + 1)
 READOBJ = s
 Case TOKQUOTE
 tok = READOBJ(depth + 1)
 Select Case tok
 Case TOKCLOSE
 Print "warning: quote before close parenthesis"
 READOBJ = tok
 Case TOKDOT
 Print "warning: quote before dot"
 READOBJ = tok
 Case Else
 s = CONS(STRTOATOM("QUOTE"), CONS(tok, 0))
 READOBJ = s
 End Select
 Case Else
 READOBJ = tok
 End Select
End Function
Function READTOKEN (depth)
 
 start1: bufend = Len(buf)
 While bufpos < bufend And InStr(" " + Chr$(9), Mid$(buf, bufpos, 1))
 bufpos = bufpos + 1
 Wend
 c$ = Mid$(buf, bufpos, 1)
 If InStr(":;", c$) Then
 If c$ = ":" Then
 bufpos = bufpos + 1
 If bufpos <= bufend Then
 Select Case Mid$(buf, bufpos, 1)
 Case "q", "Q" ' quit
 System
 Case "g", "G" ' garbage collect now
 gcnow = -1
 Case Else
 READTOKEN = TOKERR
 Exit Function
 End Select
 End If
 End If
 bufpos = bufend + 1
 End If
 If bufpos > bufend Then
 If depth = 0 Then Print "]=> ";
 Line Input buf
 bufend = Len(buf)
 bufpos = 1
 GoTo start1
 End If
 Select Case c$
 Case "("
 bufpos = bufpos + 1
 READTOKEN = TOKOPEN
 Case ")"
 bufpos = bufpos + 1
 READTOKEN = TOKCLOSE
 Case "'"
 bufpos = bufpos + 1
 READTOKEN = TOKQUOTE
 Case "."
 bufpos = bufpos + 1
 READTOKEN = TOKDOT
 Case Else
 strbeg = bufpos
 bufpos = bufpos + 1
 Do While bufpos <= bufend
 c$ = Mid$(buf, bufpos, 1)
 If c$ = " " Or c$ = "." Or c$ = "(" Or c$ = ")" Then Exit Do
 bufpos = bufpos + 1
 Loop
 READTOKEN = STRTOATOM(Mid$(buf, strbeg, bufpos - strbeg))
 End Select
End Function
Sub setvar (id, value, env)
 anum = heap(id, 1)
 e = env
 Do
 frame = heap(e, 1)
 vars = heap(frame, 1)
 vals = heap(frame, 2)
 While vars
 If heap(heap(vars, 1), 1) = anum Then
 heap(vals, 1) = value: Exit Sub
 End If
 vars = heap(vars, 2): vals = heap(vals, 2)
 Wend
 e = heap(e, 2)
 Loop While e
 Call defvar(id, value, env)
End Sub
Function STRTOATOM (s$)
 l = Len(s$)
 c$ = Left$(s,ドル 1)
 If (c$ = "-" And l >= 2) Or (c$ >= "0" And c$ <= "9") Then
 v = 0
 If c$ = "-" Then neg = 1: idx = 2 Else neg = 0: idx = 1
 For idx = idx To l
 c$ = Mid$(s,ドル idx, 1)
 If (c$ >= "0" And c$ <= "9") Then
 v = v * 10 + (Asc(c$) - Asc("0"))
 Else
 Exit For
 End If
 Next
 If idx = l + 1 Then
 If neg Then v = -v
 p = ALLOC
 heap(p, 0) = TNUM
 heap(p, 1) = v
 STRTOATOM = p: Exit Function
 End If
 End If
 If UCase$(s$) = "NIL" Then STRTOATOM = TOKNIL: Exit Function
 i = hash(UCase$(s$))
 For count = 1 To hsize
 If atom$(i) = UCase$(s$) Then
 found = true: Exit For
 ElseIf atom$(i) = "" Then
 atom$(i) = UCase$(s$)
 found = true
 Exit For
 Else
 i = (i + count) Mod hsize
 End If
 Next
 If Not found Then Print "Symbol table full!"
 p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
 STRTOATOM = p
End Function
' stop and copy garbage collection
Sub gc (root)
 hptr = nmin
' copy root pointer
 scan = hptr
 x = ALLOC
 For i = 0 To 2
 heap(x, 1) = heap(root, i)
 Next
 heap(root, 0) = -1
 heap(root, 1) = x
 root = x
' while new things have been copied
 While scan <> hptr
 If heap(scan, 0) = TCONS Or heap(scan, 0) = TPROC Then
 heap(scan, 1) = collect(heap(scan, 1))
 heap(scan, 2) = collect(heap(scan, 2))
 End If
 scan = scan + 1
 Wend
' swap pointers to two halves of memory
 Swap mmin, nmin
 Swap mmax, nmax
 gcnow = False
End Sub
' return new location of lisp cell pointed to at p 
Function collect (p)
 Select Case heap(p, 0)
 Case -1
 collect = heap(p, 1)
 Case TNIL
 collect = 0
 Case Else
 x = ALLOC
 ' copy the entire structure
 For i = 0 To 2
 heap(x, i) = heap(p, i)
 Next
 ' write forwarding address
 heap(p, 0) = -1
 heap(p, 1) = x
 collect = x
 End Select
End Function

https://gist.github.com/menezesd/2a2cedb7fea564c4de99889f2fd78e92