' Original by qbguy.
' Edits by STxAxTIC (10/16/2014).
' Posted to qb64.org forums on 10-06-2018.

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)
DECLARE FUNCTION DoLISP$(TheStringIn$, envin)

' 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 bufpos AS INTEGER, state AS INTEGER
DIM SHARED buf AS STRING
DIM SHARED hptr
DIM SHARED atom$(0 TO hsize - 1), heap(2 * msize - 1, 2)
DIM SHARED mmin, nmin, gcnow

mmin = 1: nmin = msize

DIM SHARED TheInput$
DIM SHARED TheOutput$

CONST TRUE = -1
CONST FALSE = 0
CONST TNIL = 0
CONST TCONS = 2
CONST TNUM = 3
CONST TSYM = 4
CONST TPROC = 5
CONST TPPROC = 6
CONST TOKNIL = 0
CONST TOKERR = -1
CONST TOKOPEN = -2
CONST TOKCLOSE = -3
CONST TOKQUOTE = -4
CONST TOKDOT = -5

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
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)

DO
    LINE INPUT ">"; q$
    r$ = DoLISP$(q$, env)
    PRINT r$: PRINT
LOOP

''''''''''

FUNCTION DoLISP$ (TheStringIn AS STRING, envin)
    TheInput$ = TheStringIn
    TheOutput$ = ""
    s = READOBJ(0)
    SELECT CASE s
        CASE TOKCLOSE
            ' Unmatched closed parenthesis.
            TheOutput$ = TheOutput$ + "[Unmatched closed parenthesis.]"
        CASE TOKDOT
            'PRINT "Dot used outside list."
            TheOutput$ = TheOutput$ + "[Dot used outside list.]"
        CASE TOKERR
            'PRINT "[Error]"
            TheOutput$ = TheOutput$ + "[Error]"
        CASE ELSE
            CALL PRINTOBJ(EVALOBJ(s, envin))
    END SELECT
    DoLISP$ = TheOutput$
END FUNCTION

'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

FUNCTION ALLOC
    ALLOC = hptr
    hptr = hptr + 1
    IF hptr > (mmin + 3 * (msize / 4)) THEN gcnow = -1
END FUNCTION

FUNCTION apply (id, args)
    IF heap(id, 0) = TPROC THEN
        params = heap(id, 1)
        body = heap(heap(id, 2), 1)
        procenv = heap(heap(id, 2), 2)
        env = CONS(CONS(params, args), procenv)
        DO WHILE heap(body, 2)
            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
        SELECT CASE heap(id, 1)
            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 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
            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)
    TheOutput$ = TheOutput$ + "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 "()";
            TheOutput$ = TheOutput$ + "()"
        CASE TCONS
            '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
            IF heap(cdr, 0) = TNIL THEN
                'PRINT ")";
                TheOutput$ = TheOutput$ + ")"
            ELSE
                'PRINT ".";
                TheOutput$ = TheOutput$ + "."
                CALL PRINTOBJ(cdr)
                'PRINT ")";
                TheOutput$ = TheOutput$ + ")"
            END IF
        CASE TNUM
            'PRINT heap(id, 1);
            TheOutput$ = TheOutput$ + STR$(heap(id, 1))
        CASE TSYM
            'PRINT atom$(heap(id, 1));
            TheOutput$ = TheOutput$ + atom$(heap(id, 1))
        CASE TPROC, TPPROC
            'PRINT "[Procedure]"
            TheOutput$ = TheOutput$ + "[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
        buf = TheInput$
        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

SUB gc (root)
    hptr = nmin
    root = collect(root)
    SWAP mmin, nmin
    SWAP mmax, nmax
    gcnow = 0
END SUB

FUNCTION collect (p)

    SELECT CASE heap(p, 0)

        CASE -1
            collect = heap(p, 1)

        CASE TCONS, TPROC

            ' 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

        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