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
