' Original by qbguy.
' Edits by STxAxTIC (10/16/2014).
' Posted to qb64.org forums on 10-06-2018.
' Make these smaller to get it to work in QBASIC / QuickBASIC
CONST msize
= 16384 'size of memory -- arbitrary CONST hsize
= 4096 'size of hash table -- should be power of 2
DIM SHARED atom$
(0 TO hsize
- 1), heap
(2 * msize
- 1, 2)
mmin = 1: nmin = msize
''''''''''
hptr = mmin: bufpos = 1
vars = TNIL
vals = TNIL
frame = CONS(vars, vals)
env = CONS(frame, TNIL)
CALL defvar
(STRTOATOM
("+"), mkprimop
(PPLUS
), env
) CALL defvar
(STRTOATOM
("-"), mkprimop
(PMINUS
), env
) CALL defvar
(STRTOATOM
("*"), mkprimop
(PTIMES
), env
) 'CALL defvar(STRTOATOM("%"), mkprimop(PMOD), 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
)
r$ = DoLISP$(q$, env)
''''''''''
TheInput$ = TheStringIn
TheOutput$ = ""
s = READOBJ(0)
' Unmatched closed parenthesis.
TheOutput$ = TheOutput$ + "[Unmatched closed parenthesis.]"
'PRINT "Dot used outside list."
TheOutput$ = TheOutput$ + "[Dot used outside list.]"
'PRINT "[Error]"
TheOutput$ = TheOutput$ + "[Error]"
CALL PRINTOBJ
(EVALOBJ
(s
, envin
)) DoLISP$ = TheOutput$
'DO
' s = READOBJ(0)
' SELECT CASE s
' CASE TOKCLOSE
' ' unmatched closed parenthesis
' CASE TOKDOT
' PRINT "dot used outside list"
' CASE TOKERR
' PRINT "[Error]"
' CASE ELSE
' CALL PRINTOBJ(EVALOBJ(s, env))
' END SELECT
' PRINT
' IF gcnow THEN CALL gc(env)
'LOOP
ALLOC = hptr
hptr = hptr + 1
IF hptr
> (mmin
+ 3 * (msize
/ 4)) THEN gcnow
= -1
params = heap(id, 1)
body = heap(heap(id, 2), 1)
procenv = heap(heap(id, 2), 2)
env = CONS(CONS(params, args), procenv)
t = heap(body, 1)
t = EVALOBJ(t, env) 'ignore result
body = heap(body, 2)
t = heap(body, 1)
apply = EVALOBJ(t, env)
sum = 0
a = args
sum = sum + heap(heap(a, 1), 1)
a = heap(a, 2)
p = ALLOC
heap(p, 0) = TNUM
heap(p, 1) = sum
apply = p
prod = 1
a = args
prod = prod * heap(heap(a, 1), 1)
a = heap(a, 2)
p = ALLOC
heap(p, 0) = TNUM
heap(p, 1) = prod
apply = p
'CASE PMOD
' prod = 1
' a = args
' WHILE a
' prod = prod MOD heap(heap(a, 1), 1)
' a = heap(a, 2)
' WEND
' p = ALLOC
' heap(p, 0) = TNUM
' heap(p, 1) = prod
' apply = p
apply = CONS(heap(args, 1), heap(heap(args, 2), 1))
apply = heap(heap(args, 1), 1)
apply = heap(heap(args, 1), 2)
f = heap(heap(args, 1), 1)
a = heap(args, 2)
a = heap(a, 2)
IF heap
(args
, 1) THEN apply
= TNIL
ELSE apply
= STRTOATOM
("T") arg1 = heap(args, 1)
arg2 = heap(heap(args, 2), 1)
CASE TNUM
, TPROC
, TPPROC
, TSYM
IF heap
(arg1
, 1) = heap
(arg2
, 1) THEN apply
= STRTOATOM
("T") IF arg1
= arg2
THEN apply
= STRTOATOM
("T") f = heap(heap(args, 1), 1)
a = heap(args, 2)
IF f
< heap
(heap
(a
, 1), 1) THEN f = heap(heap(a, 1), 1)
a = heap(a, 2)
f = heap(heap(args, 1), 1)
a = heap(args, 2)
IF f
> heap
(heap
(a
, 1), 1) THEN f = heap(heap(a, 1), 1)
a = heap(a, 2)
f = heap(heap(args, 1), 1)
a = heap(args, 2)
IF f
<= heap
(heap
(a
, 1), 1) THEN f = heap(heap(a, 1), 1)
a = heap(a, 2)
f = heap(heap(args, 1), 1)
a = heap(args, 2)
IF f
>= heap
(heap
(a
, 1), 1) THEN f = heap(heap(a, 1), 1)
a = heap(a, 2)
arg1 = heap(args, 1)
arg2 = heap(heap(args, 2), 1)
heap(arg1, 1) = arg2
arg1 = heap(args, 1)
arg2 = heap(heap(args, 2), 1)
heap(arg2, 2) = arg2
arg1 = heap(args, 1)
arg2 = heap(heap(args, 2), 1)
apply = apply(arg1, arg2)
apply = args
apply = READOBJ(0)
arg1 = heap(heap(args, 1), 1)
rargs = heap(args, 2)
res = arg1
res = res - heap(heap(rargs, 1), 1)
rargs = heap(rargs, 2)
p = ALLOC
heap(p, 0) = TNUM: heap(p, 1) = res: apply = p
p = ALLOC: heap(p, 0) = TNUM: heap(p, 1) = -arg1
apply = p
targ1 = heap(heap(args, 1), 0)
IF targ1
= TSYM
THEN apply
= STRTOATOM
("T") targ1 = heap(heap(args, 1), 0)
IF targ1
= TNUM
THEN apply
= STRTOATOM
("T") targ1 = heap(heap(args, 1), 0)
IF targ1
= TPROC
OR targ1
= TPPROC
THEN apply
= STRTOATOM
("T") targ1 = heap(heap(args, 1), 0)
IF targ1
= TCONS
THEN apply
= STRTOATOM
("T") PRINT "Bad application -- not a function" apply = TOKERR
p = ALLOC
heap(p, 0) = TCONS
heap(p, 1) = car
heap(p, 2) = cdr
CONS = p
SUB defvar
(id
, value
, env
) anum = heap(id, 1)
frame = heap(env, 1)
vars = heap(frame, 1)
vals = heap(frame, 2)
IF heap
(heap
(vars
, 1), 1) = anum
THEN vars = heap(vars, 2): vals = heap(vals, 2)
vars = heap(frame, 1)
vals = heap(frame, 2)
heap(frame, 1) = CONS(id, vars)
heap(frame, 2) = CONS(value, vals)
CASE TNIL
, TNUM
' self-evaluating EVALOBJ = id
EVALOBJ = lookup(heap(id, 1), env)
o = heap(id, 1)
t = heap(o, 0)
a$ = atom$(heap(o, 1)) ' symbol name of car(id)
EVALOBJ = heap(heap(id, 2), 1)
vid = heap(heap(id, 2), 1) 'cadr
aval = heap(heap(heap(id, 2), 2), 1) 'caddr
CALL setvar
(vid
, EVALOBJ
(aval
, env
), env
) vid = heap(heap(id, 2), 1)
aval = heap(heap(heap(id, 2), 2), 1)
CALL setvar
(vid
, EVALOBJ
(aval
, env
), env
) ' (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
' return EVALOBJ(ic,env)
' return EVALOBJ(ia,env)
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
seq = heap(id, 2)
t = heap(seq, 1)
t = EVALOBJ(t, env) 'ignore result
seq = heap(seq, 2)
id
= heap
(seq
, 1):
GOTO 1 seq = heap(id, 2)
t = heap(seq, 1)
t = EVALOBJ(t, env)
seq = heap(seq, 2)
id
= heap
(seq
, 1):
GOTO 1 seq = heap(id, 2)
t = heap(seq, 1)
t = EVALOBJ(t, env)
seq = heap(seq, 2)
id
= heap
(seq
, 1):
GOTO 1 clauses = heap(id, 2)
clause = heap(clauses, 1)
pred = heap(clause, 1)
seq = heap(clause, 2)
t = heap(seq, 1)
t = EVALOBJ(t, env) 'ignore result
seq = heap(seq, 2)
id
= heap
(seq
, 1):
GOTO 1 clauses = heap(clauses, 2)
args = heap(id, 2)
proc = EVALOBJ(o, env)
EVALOBJ = apply(proc, lvals(args, env))
args = heap(id, 2)
proc = EVALOBJ(o, env)
EVALOBJ = apply(proc, lvals(args, env))
PRINT "Unhandled expression type: "; a$
EVALOBJ = id
h
= (h
* 33 + c
) MOD hsize
hash = h
' env is a list of (vars . vals) frames
' where: vars is a list of symbols
' vals is a list of their values
e = env
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)
vars = heap(vars, 2) 'cdr(vars)
vals = heap(vals, 2) 'cdr(vals)
e = heap(e, 2) ' cdr(e)
'PRINT "Unbound variable: "; atom$(anum)
TheOutput$ = TheOutput$ + "Unbound variable: " + atom$(anum)
lookup = TOKERR
car = heap(id, 1)
ecar = EVALOBJ(car, env)
head = CONS(ecar, 0)
l = heap(id, 2): prev = head
car = heap(l, 1)
ecar = EVALOBJ(car, env)
new = CONS(ecar, 0)
heap(prev, 2) = new
prev = new
l = heap(l, 2)
lvals = head
lvals = 0
p = ALLOC
heap(p, 0) = TPPROC
heap(p, 1) = id
mkprimop = p
'PRINT "()";
TheOutput$ = TheOutput$ + "()"
'PRINT "(";
TheOutput$ = TheOutput$ + "("
printlist:
CALL PRINTOBJ
(heap
(id
, 1)) 'PRINT " ";
TheOutput$ = TheOutput$ + " "
cdr = heap(id, 2)
IF heap
(cdr
, 0) = TCONS
THEN id
= cdr:
GOTO printlist
'PRINT ")";
TheOutput$ = TheOutput$ + ")"
'PRINT ".";
TheOutput$ = TheOutput$ + "."
'PRINT ")";
TheOutput$ = TheOutput$ + ")"
'PRINT heap(id, 1);
TheOutput$
= TheOutput$
+ STR$(heap
(id
, 1)) 'PRINT atom$(heap(id, 1));
TheOutput$ = TheOutput$ + atom$(heap(id, 1))
'PRINT "[Procedure]"
TheOutput$ = TheOutput$ + "[Procedure]"
SH = READOBJ(depth)
READLIST = TOKERR
READLIST = 0
SH = READOBJ(depth)
CASE TOKERR
, TOKDOT
, TOKCLOSE
READLIST = TOKERR
ST = READLIST(depth)
ST = READLIST(depth)
IF ST
= TOKERR
THEN READLIST
= TOKERR
ELSE READLIST
= CONS
(SH
, ST
)
tok = READTOKEN(depth)
s = READLIST(depth + 1)
READOBJ = s
tok = READOBJ(depth + 1)
PRINT "warning: quote before close parenthesis" READOBJ = tok
PRINT "warning: quote before dot" READOBJ = tok
s = CONS(STRTOATOM("QUOTE"), CONS(tok, 0))
READOBJ = s
READOBJ = tok
start1: bufend
= LEN(buf
) bufpos = bufpos + 1
c$
= MID$(buf
, bufpos
, 1) bufpos = bufpos + 1
CASE "g", "G" ' garbage collect now gcnow = -1
READTOKEN = TOKERR
bufpos = bufend + 1
'IF depth = 0 THEN PRINT "]=> ";
'LINE INPUT buf
buf = TheInput$
bufpos = 1
bufpos = bufpos + 1
READTOKEN = TOKOPEN
bufpos = bufpos + 1
READTOKEN = TOKCLOSE
bufpos = bufpos + 1
READTOKEN = TOKQUOTE
bufpos = bufpos + 1
READTOKEN = TOKDOT
strbeg = bufpos
bufpos = bufpos + 1
c$
= MID$(buf
, bufpos
, 1) bufpos = bufpos + 1
READTOKEN
= STRTOATOM
(MID$(buf
, strbeg
, bufpos
- strbeg
))
SUB setvar
(id
, value
, env
) anum = heap(id, 1)
e = env
frame = heap(e, 1)
vars = heap(frame, 1)
vals = heap(frame, 2)
IF heap
(heap
(vars
, 1), 1) = anum
THEN vars = heap(vars, 2): vals = heap(vals, 2)
e = heap(e, 2)
CALL defvar
(id
, value
, env
)
v = 0
IF c$
= "-" THEN neg
= 1: idx
= 2 ELSE neg
= 0: idx
= 1 v
= v
* 10 + (ASC(c$
) - ASC("0")) p = ALLOC
heap(p, 0) = TNUM
heap(p, 1) = v
found = TRUE
i
= (i
+ count
) MOD hsize
p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
STRTOATOM = p
hptr = nmin
root = collect(root)
gcnow = 0
collect = heap(p, 1)
' address of new copy
x = ALLOC
' car, cdr
a = heap(p, 1)
d = heap(p, 2)
' replace with forwarding address
heap(p, 0) = -1
heap(p, 1) = x
' copy
heap(x, 0) = heap(p, 0)
heap(x, 1) = collect(a)
heap(x, 2) = collect(d)
collect = x
collect = 0
x = ALLOC
' copy the entire structure
heap(x, i) = heap(p, i)
' write forwarding address
heap(p, 0) = -1
heap(p, 1) = x
collect = x