Author Topic: Scheme (LISP) in QBASIC  (Read 3153 times)

qbguy

  • Sr. Member
  • ****
  • Posts: 273
Scheme (LISP) in QBASIC
« on: July 23, 2014, 01:38:36 pm »
Code: [Select]
' public domain, MMXIV
DEFINT A-Z
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)

mmin = 1

DIM SHARED bufpos AS INTEGER, state AS INTEGER
DIM SHARED buf AS STRING
DIM SHARED anext, hptr
DIM SHARED ATOM$(1024), heap(10100, 2)

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

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

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
LOOP

FUNCTION ALLOC
    ALLOC = hptr
    hptr = hptr + 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 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
    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 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 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" ' quit
    SYSTEM
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
    FOR i = 0 TO anext - 1
IF ATOM$(i) = UCASE$(s$) THEN found = TRUE: EXIT FOR
    NEXT
    IF NOT found THEN ATOM$(anext) = UCASE$(s$): anext = anext + 1
    p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
    STRTOATOM = p
END FUNCTION

« Last Edit: September 17, 2014, 11:35:10 am by qbguy »

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #1 on: July 23, 2014, 03:21:58 pm »
The IDE tells me:

"Expected (...) on line 77"

qbguy

  • Sr. Member
  • ****
  • Posts: 273
Re: Scheme (LISP) in QBASIC
« Reply #2 on: July 23, 2014, 03:36:39 pm »
Oh sorry, I was using a different BASIC compiler and didn't realize that QBASIC doesn't let you put parenthesis after functions with no arguments (e.g. ALLOC()).

I updated the code above and it now runs in QBASIC 1.1. 

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #3 on: July 23, 2014, 03:49:28 pm »
Cool, works now.

I've heard of LISP and I have friends that are frantic about it. Can we get an example of what to type into your prompt?

qbguy

  • Sr. Member
  • ****
  • Posts: 273
Re: Scheme (LISP) in QBASIC
« Reply #4 on: July 23, 2014, 04:00:38 pm »
Some arithmetic:
Code: [Select]
=> (+ 2 2)
4
=> (apply + '(1 2 3))
6
=> (+ 1 -3 2 5)
5

Code: [Select]
(define generator
   (lambda (x) (lambda (y) (if y (generator y) x))))

(define pocket (generator 8))

pocket is now a "pocket" function.  It takes a single argument Y.  If the argument is NIL (the empty list, it returns 8).  Otherwise, it returns another function that has Y in the pocket instead of 8.

Code: [Select]
(pocket nil)
8

(define pocktwo (pocket 10))

(pocktwo '())
10

Factorial:
Code: [Select]
(define fact
  (lambda (x)
     (if (= x 0) 1 (* x (fact (+ x -1)))))))

Code: [Select]
(fact 5)
120
(fact 7)
5040

Right now, numbers are BASIC INTEGERS (a real LISP implementation would have arbitrary-precision integers), so going higher than 7 results in wrong results due to overflow.

Map function takes one argument and applies it to every element of second argument:
Code: [Select]
(DEFINE MAP
   (LAMBDA (F X)
     (IF X
        (CONS (F (CAR X)) (MAP F (CDR X))))))

Example:
Code: [Select]
]=> (MAP (LAMBDA (X) (* X 2)) '(1 2 3 4 5 6 7 ))
( 2   4   6   8   10   12   14  )



STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #5 on: July 23, 2014, 07:01:18 pm »
Thanks very much for this contribution - I still am wondering how I can improve my skills and life with LISP.

Without taking up too much of your time... what can I do with LISP supposing I learn it?

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #6 on: August 08, 2014, 05:06:09 pm »
Hey again qbguy,

I was trying to get this program working, and even basic steps were giving me trouble. When I input (+ 2 2), I don't get a 4 back, but instead I get 0 2 2 on three separate lines. Has this been tested on QB64? Am I doing something wrong?

(I'll try it in FreeBasic and if I learn anything new, I will post again...)

I'd really love to be able to play with Scheme in QBasic.... almost there!!!

EDIT: Works like a charm in FreeBasic. Not sure why, just discovered this seconds ago...

Sill not working in QB64..... trying to troubleshoot....
« Last Edit: August 08, 2014, 08:48:01 pm by STxAxTIC »

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #7 on: August 08, 2014, 10:59:21 pm »
Ok....

I just looked at this problem for a long time now. Here's what I find:

1) This program DOES work properly in QBasic45
2) This program DOES work properly in FreeBASIC
3) This program DOES NOT work properly in QB64
4) This program is too cool to lose. We must get it working here.

I'm going to let this issue cook for a short while, but soon it's probably going to wind up in the Bugs/Incompatibilities section.

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #8 on: August 10, 2014, 09:31:03 am »
In anticipation of using this program in other places, I converted the main input-output loop to a single function. The catch is, you need to enter everything as complete and closed sets of parenthesis - there is no breaking commands onto different lines.

This works in QB45 but not QB64.

Code: [Select]
DEFINT A-Z
DECLARE FUNCTION READOBJ ()
DECLARE FUNCTION READTOKEN ()
DECLARE FUNCTION STRTOATOM (s$)
DECLARE FUNCTION CONS (car, cdr)
DECLARE FUNCTION READLIST ()
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, value, env)
DECLARE SUB setvar (id, value, env)
DECLARE FUNCTION mkprimop (id)
DECLARE FUNCTION DoLISP$(envin)

DIM SHARED depth AS INTEGER, bufpos AS INTEGER, state AS INTEGER
DIM SHARED buf AS STRING
DIM SHARED anext, hptr
DIM SHARED ATOM$(1024), heap(2048, 2)
RANDOMIZE TIMER

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

hptr = 10: bufpos = 1
vars = TNIL
vals = TNIL
frame = CONS(vars, vals)
env = CONS(frame, TNIL)

CALL defvar(STRTOATOM("+"), mkprimop(PPLUS), 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)

DO
    LINE INPUT a$
    TheInput$ = a$
    'TheOutput$ = ""
    'CALL
    PRINT DoLISP$(env)
    'PRINT TheOutput$
LOOP

END

FUNCTION DoLISP$ (envin)
TheOutput$ = ""
s = READOBJ
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, envin))
END SELECT
DoLISP$ = TheOutput$
END FUNCTION

FUNCTION ALLOC
ALLOC = hptr
hptr = hptr + 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 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 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
    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 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 "()";
        TheOutput$ = "()"
    CASE TCONS
        'PRINT "(";
        TheOutput$ = TheOutput$ + "("
        loop2: CALL PRINTOBJ(heap(id, 1))
        'PRINT " ";
        TheOutput$ = TheOutput$ + " "
        cdr = heap(id, 2)
        IF heap(cdr, 0) = TCONS THEN
            id = cdr: GOTO loop2
        ELSEIF heap(cdr, 0) = TNIL THEN
            'PRINT ")";
            TheOutput$ = TheOutput$ + ")"
        ELSE
            'PRINT ".";
            TheOutput$ = TheOutput$ + "."
            CALL PRINTOBJ(cdr)
            'PRINT ")";
            TheOutput$ = TheOutput$ + ")"
        END IF
    CASE TNUM
        'COLOR 4
        'PRINT heap(id, 1);
        TheOutput$ = TheOutput$ + STR$(heap(id, 1))
        'COLOR 7
    CASE TSYM
        'COLOR 5
        'PRINT ATOM$(heap(id, 1));
        TheOutput$ = ATOM$(heap(id, 1))
        'COLOR 7
    CASE TPROC, TPPROC
        PRINT "[Procedure]"
END SELECT
END SUB

FUNCTION READLIST
SH = READOBJ
SELECT CASE SH
    CASE TOKERR
        READLIST = TOKERR
    CASE TOKCLOSE
        READLIST = 0
    CASE TOKDOT
        SH = READOBJ
        SELECT CASE SH
            CASE TOKERR, TOKDOT, TOKCLOSE
                READLIST = TOKERR
            CASE ELSE
                ST = READLIST
                IF ST THEN READLIST = TOKERR ELSE READLIST = SH
        END SELECT
    CASE ELSE
        ST = READLIST
        IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH, ST)
END SELECT
END FUNCTION

FUNCTION READOBJ
tok = READTOKEN
SELECT CASE tok
    CASE TOKOPEN
        depth = depth + 1
        s = READLIST
        depth = depth - 1
        READOBJ = s
    CASE TOKQUOTE
        depth = depth + 1
        tok = READOBJ
        depth = 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
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" ' quit
                    SYSTEM
                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 "]=> ";
    buf = TheInput$
    '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
FOR i = 0 TO anext - 1
    IF ATOM$(i) = UCASE$(s$) THEN found = TRUE: EXIT FOR
NEXT
IF NOT found THEN ATOM$(anext) = UCASE$(s$): anext = anext + 1
p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
STRTOATOM = p
END FUNCTION

qbguy

  • Sr. Member
  • ****
  • Posts: 273
Re: Scheme (LISP) in QBASIC
« Reply #9 on: August 18, 2014, 07:18:21 pm »
OK, I fixed it in QB64 by making depth a parameter; I also added less than, less or equal, greater than, greater or equal as primitive functions.

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #10 on: August 18, 2014, 09:22:54 pm »
Thanks a whole lot qbguy, I really appreciate your caring enough to make this program work for us.

Let me tell you what I did with the old version, just for your entertainment:

I first modified it into a "function" format so it could be $included into another program easily. With that not working in QB64 though, I modified it again to receive input from a text tile, and give its output to another text file. I then cranked it through FreeBasic to generate an EXE. Next, I modified my chatbot to ping/read/write the above-mentioned text files. Long story short, we had a way of programming in LISP/Scheme right in the IRC chat room as agroup. It would remember the user-defined functions for as long as the EXE was going. It worked great!

It was fun developing that mega-hack, but thanks for updating the code so I may stop using that method. Drop by the chat sometime, and you can show us some stuff live.
« Last Edit: August 18, 2014, 10:02:43 pm by STxAxTIC »

qbguy

  • Sr. Member
  • ****
  • Posts: 273
Re: Scheme (LISP) in QBASIC
« Reply #11 on: August 19, 2014, 08:17:28 pm »
Here's an updated version with garbage collection and some type testing functions:

Code: [Select]
' public domain,  MMXIV
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
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


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("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
    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 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 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

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

« Last Edit: September 17, 2014, 11:35:30 am by qbguy »

STxAxTIC

  • Guest
Re: Scheme (LISP) in QBASIC
« Reply #12 on: August 22, 2014, 08:45:16 pm »
Hey qbguy,

Attached are three files into which your code has been split. The MathBlab program (like LispLib.bas) does a "minimally invasive" call using the DoLISP$ function.