Author Topic: Scheme (LISP) interpreter  (Read 6664 times)

0 Members and 1 Guest are viewing this topic.

Offline qbguy

  • Newbie
  • Posts: 11
    • View Profile
Scheme (LISP) interpreter
« on: October 06, 2018, 09:14:42 pm »

Code: QB64: [Select]
  1. DEFINT A-Z
  2. declare function readobj()
  3. declare function readtoken()
  4. declare function strtoatom(s$)
  5. declare function cons(car,cdr)
  6. declare function readlist()
  7. declare sub printobj(id)
  8. declare function evalobj(id, env)
  9. declare function apply(f, args)
  10. declare function lookup(anum, env)
  11. declare function lvals(id,env)
  12. declare sub defvar(var,val,env)
  13. declare sub setvar(id,val,env)
  14. declare function mkprimop(id)
  15.  
  16. DIM SHARED depth AS INTEGER,bufpos AS INTEGER, state AS INTEGER
  17. DIM SHARED anext, hptr
  18. DIM SHARED atom$(1024),heap(2048, 2)
  19.  
  20. CONST TRUE = -1
  21. CONST FALSE = 0
  22. CONST TNIL = 0
  23. CONST TCONS = 2
  24. CONST TNUM = 3
  25. CONST TSYM = 4
  26. CONST TPROC = 5
  27. CONST TPPROC = 6
  28. CONST TOKNIL = 0
  29. CONST TOKERR = 1
  30. CONST TOKOPEN = 2
  31. CONST TOKCLOSE = 3
  32. CONST TOKQUOTE = 4
  33. CONST TOKDOT = 5
  34.  
  35.  
  36. CONST PPLUS = 1
  37. CONST PTIMES = 3
  38. CONST PCONS = 4
  39. CONST PCAR = 5
  40. CONST PCDR = 6
  41. CONST PEQUAL = 7
  42. CONST PNOT = 8
  43. CONST PEQ = 9
  44. CONST PSETCAR = 10
  45. CONST PSETCDR = 11
  46. CONST PAPPLY = 12
  47. CONST PLIST = 13
  48. CONST PREAD = 14
  49.  
  50. hptr = 10: bufpos = 1
  51. vars = TNIL
  52. vals = TNIL
  53. frame = CONS(vars,vals)
  54. env = CONS(frame,TNIL)
  55.  
  56. CALL DEFVAR(STRTOATOM("+"),mkprimop(PPLUS), env)
  57. CALL DEFVAR(STRTOATOM("*"),mkprimop(PTIMES), env )
  58. CALL DEFVAR(STRTOATOM("CONS"),mkprimop(PCONS), env)
  59. CALL DEFVAR(STRTOATOM("CAR"),mkprimop(PCAR), env )
  60. CALL DEFVAR(STRTOATOM("CDR"),mkprimop(PCDR), env)
  61. CALL DEFVAR(STRTOATOM("="),mkprimop(PEQUAL),env)
  62. CALL DEFVAR(STRTOATOM("NOT"),mkprimop(PNOT),env)
  63. CALL DEFVAR(STRTOATOM("EQ?"),mkprimop(PEQ),env)
  64. CALL DEFVAR(STRTOATOM("EQV?"),mkprimop(PEQ),env)
  65. CALL DEFVAR(STRTOATOM("T"),STRTOATOM("T"),env) ' true
  66. CALL DEFVAR(STRTOATOM("SET-CAR!"),mkprimop(PSETCAR),env)
  67. CALL DEFVAR(STRTOATOM("SET-CDR!"),mkprimop(PSETCDR),env)
  68. CALL DEFVAR(STRTOATOM("APPLY"),mkprimop(PAPPLY),env)
  69. CALL DEFVAR(STRTOATOM("LIST"),mkprimop(PLIST),env)
  70. CALL DEFVAR(STRTOATOM("READ"),mkprimop(PREAD), env)
  71.  
  72.     s = READOBJ()
  73.     SELECT CASE s
  74.     CASE TOKCLOSE
  75.     ' unmatched closed parenthesis
  76.     CASE TOKDOT
  77.     PRINT  "dot used outside list"
  78.     CASE TOKERR
  79.     PRINT "[Error]"
  80.     CASE ELSE
  81.     CALL PRINTOBJ(EVALOBJ(s,env))
  82.     END SELECT
  83.     PRINT
  84.  
  85.  
  86. SUB PRINTOBJ(id)
  87.  
  88.     IF id = TOKERR THEN PRINT "[Error]" : EXIT SUB
  89.     SELECT CASE heap(id,0)
  90.     CASE TNIL
  91.         PRINT "()";
  92.     CASE TCONS
  93.         PRINT "(";
  94. 1       CALL PRINTOBJ(heap(id,1))
  95.         PRINT " ";
  96.         cdr = heap(id,2)
  97.         IF heap(cdr,0) = TCONS THEN
  98.             id = cdr: GOTO 1
  99.         ELSEIF heap(cdr,0) = TNIL THEN
  100.             PRINT ")";
  101.         ELSE
  102.             PRINT ".";  
  103.             CALL PRINTOBJ(cdr)
  104.             PRINT ")";
  105.         END IF
  106.     CASE TNUM
  107.         PRINT heap(id,1);
  108.     CASE TSYM
  109.         PRINT atom$(heap(id,1));
  110.     CASE TPROC, TPPROC
  111.         PRINT "[Procedure]"
  112.     END SELECT
  113.  
  114. FUNCTION READTOKEN()
  115.    
  116. 1    bufend = LEN(buf)
  117.     WHILE bufpos < bufend AND INSTR(" "+CHR$(9),MID$(buf,bufpos,1))
  118.         bufpos = bufpos + 1
  119.     WEND
  120.     c$ = MID$(buf,bufpos,1)
  121.     IF INSTR(":;",c$) THEN
  122.         IF c$ = ":" THEN
  123.             bufpos = bufpos + 1
  124.             IF bufpos <= bufend THEN
  125.                 SELECT CASE MID$(buf,bufpos,1)
  126.                 CASE "q" ' quit
  127.                     SYSTEM
  128.                 CASE ELSE
  129.                         READTOKEN = TOKERR
  130.                         EXIT FUNCTION
  131.                 END SELECT
  132.             END IF
  133.         END IF
  134.         bufpos = bufend + 1
  135.     END IF
  136.     IF bufpos > bufend THEN
  137.         IF depth = 0 THEN PRINT "]=> ";
  138.         LINE INPUT buf
  139.         bufend = LEN(buf)
  140.         bufpos = 1
  141.         GOTO 1
  142.     END IF
  143.     SELECT CASE c$
  144.     CASE "("
  145.         bufpos = bufpos + 1
  146.         READTOKEN = TOKOPEN
  147.     CASE ")"
  148.         bufpos = bufpos + 1
  149.         READTOKEN = TOKCLOSE
  150.     CASE "'"
  151.         bufpos = bufpos+1
  152.         READTOKEN = TOKQUOTE
  153.     CASE "."
  154.         bufpos = bufpos + 1
  155.         READTOKEN = TOKDOT
  156.     CASE ELSE
  157.         strbeg = bufpos
  158.         bufpos = bufpos +1
  159.         DO WHILE bufpos <= bufend
  160.             c$ = MID$(buf,bufpos,1)
  161.             IF c$ = " " OR c$ = "." OR c$ = "(" OR c$ = ")" THEN EXIT DO
  162.             bufpos = bufpos + 1
  163.         LOOP
  164.         READTOKEN = STRTOATOM(MID$(buf,strbeg,bufpos - strbeg))
  165.     END SELECT
  166.  
  167. FUNCTION STRTOATOM(s$)
  168.     l = LEN(s$)
  169.     c$ = LEFT$(s$,1)
  170.     IF (c$ = "-" AND l >= 2) OR (c$ >= "0" AND c$ <= "9") THEN
  171.         v = 0
  172.         IF c$ = "-" THEN neg = 1: idx = 2 ELSE neg = 0: idx = 1
  173.         FOR idx = idx TO l
  174.             c$ = MID$(s$,idx,1)
  175.             IF (c$ >= "0" AND c$ <= "9") THEN
  176.                 v = v*10 + (ASC(c$)-ASC("0"))
  177.             ELSE
  178.                 EXIT FOR
  179.             END IF
  180.         NEXT
  181.         IF idx = l + 1 THEN
  182.             IF neg THEN v = -v
  183.             p = ALLOC()
  184.             HEAP(p,0) = TNUM
  185.             HEAP(p,1) = v
  186.             STRTOATOM = p: EXIT FUNCTION
  187.         END IF
  188.     END IF
  189.     IF UCASE$(s$) = "NIL" THEN STRTOATOM=TOKNIL: EXIT FUNCTION
  190.     FOR i = 0 TO anext-1
  191.         IF ATOM$(i) = UCASE$(s$) THEN found = TRUE : exit for
  192.     NEXT
  193.     IF not found then ATOM$(anext) = UCASE$(s$) : anext = anext + 1
  194.     p = ALLOC(): HEAP(p,0) = TSYM: HEAP(p,1) = i
  195.     STRTOATOM = p
  196.  
  197. FUNCTION READOBJ()
  198.     tok = READTOKEN()
  199.     SELECT CASE tok
  200.     CASE TOKOPEN
  201.     depth = depth + 1
  202.     s = READLIST()
  203.     depth = depth - 1
  204.     READOBJ = s
  205.     CASE TOKQUOTE
  206.     depth = depth + 1
  207.     tok = READOBJ()
  208.     depth = depth - 1
  209.     SELECT CASE tok
  210.     CASE TOKCLOSE
  211.     PRINT "warning: quote before close parenthesis"
  212.     READOBJ = TOK
  213.     CASE TOKDOT
  214.     PRINT "warning: quote before dot"
  215.     READOBJ = TOK
  216.     CASE ELSE
  217.     s = CONS(STRTOATOM("QUOTE"),CONS(tok,0))
  218.     READOBJ = s
  219.     END SELECT
  220.     CASE ELSE
  221.     READOBJ = tok
  222.     END SELECT
  223.  
  224. FUNCTION CONS(car,cdr)
  225.     p = ALLOC()
  226.     heap(p,0) = TCONS
  227.     heap(p,1) = car
  228.     heap(p,2) = cdr
  229.     cons = p
  230.  
  231. FUNCTION ALLOC()
  232.     ALLOC = hptr
  233.     hptr = hptr + 1
  234.  
  235. FUNCTION READLIST()
  236.     SH = READOBJ()
  237.     SELECT CASE SH
  238.     CASE TOKERR
  239.         READLIST = TOKERR
  240.     CASE TOKCLOSE
  241.         READLIST = 0
  242.     CASE TOKDOT
  243.         SH = READOBJ()
  244.         SELECT CASE SH
  245.         CASE TOKERR, TOKDOT, TOKCLOSE
  246.             READLIST = TOKERR
  247.         CASE ELSE
  248.             ST = READLIST()
  249.             IF ST THEN READLIST = TOKERR ELSE READLIST = SH
  250.         END SELECT
  251.     CASE ELSE
  252.         ST = READLIST()
  253.         IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH,ST)
  254.     END SELECT
  255.  
  256. FUNCTION EVALOBJ(id, env)
  257. 1   SELECT CASE heap(id,0)
  258.     CASE TNIL, TNUM ' self-evaluating
  259.         EVALOBJ = id
  260.     CASE TSYM
  261.         EVALOBJ = LOOKUP(heap(id,1),env)
  262.     CASE TCONS
  263.         o = heap(id,1)
  264.         t = heap(o,0)
  265.         IF t = TSYM THEN
  266.         a$ = atom$(heap(o,1)) ' symbol name of car(id)
  267.         SELECT CASE a$
  268.         CASE "QUOTE"
  269.             EVALOBJ = heap(heap(id,2),1)
  270.         CASE "SET!"
  271.             vid = heap(heap(id,2),1) 'cadr
  272.             aval = heap(heap(heap(id,2),2),1) 'caddr
  273.             CALL setvar(vid, evalobj(aval, env),env)
  274.         CASE "DEFINE"
  275.             vid = heap(heap(id,2),1)
  276.             aval = heap(heap(heap(id,2),2),1)
  277.             CALL setvar(vid, evalobj(aval,env),env)
  278.         CASE "IF"
  279.             ' (if pred ic ia)
  280.             pred = heap(heap(id,2),1) 'predicate = cadr
  281.             ic = heap(heap(heap(id,2),2),1) ' caddr
  282.             ia = heap(heap(heap(heap(id,2),2),2),1) ' cadddr
  283.             IF EVALOBJ(pred,env) THEN
  284.                 ' return EVALOBJ(ic,env)
  285.                 id = ic: GOTO 1
  286.             ELSE
  287.                 ' return EVALOBJ(ia,env)
  288.                 id = ia : GOTO 1
  289.             END IF
  290.         CASE "LAMBDA"
  291.             p = ALLOC()
  292.             heap(p,0) = TPROC
  293.             heap(p,1) = heap(heap(id,2),1) ' cadr = args
  294.             heap(p,2) = CONS(heap(heap(id,2),2),env) 'caddr = body
  295.             EVALOBJ = p
  296.         CASE "BEGIN"
  297.         seq = heap(id,2)
  298.         DO WHILE heap(seq,2)
  299.         t = heap(seq,1)
  300.         t = evalobj(t,env) 'ignore result
  301.         seq = heap(seq,2)
  302.         LOOP
  303.         id = heap(seq,1): GOTO 1
  304.         CASE "AND"
  305.         seq = heap(id,2)
  306.         DO WHILE heap(seq,2)
  307.         t = heap(seq,1)
  308.         t = evalobj(t,env)
  309.         IF t = 0 THEN evalobj = 0: EXIT FUNCTION
  310.         seq = heap(seq,2)
  311.         LOOP
  312.         id = heap(seq,1): GOTO 1
  313.         CASE "OR"
  314.         seq = heap(id,2)
  315.         DO WHILE heap(seq,2)
  316.         t = heap(seq,1)
  317.         t = evalobj(t,env)
  318.         IF t THEN evalobj = t: EXIT FUNCTION
  319.         seq = heap(seq,2)
  320.         LOOP
  321.         id = heap(seq,1): GOTO 1
  322.         CASE "COND"
  323.         clauses = heap(id,2)
  324.         WHILE clauses
  325.         clause = heap(clauses, 1)
  326.         pred = heap(clause, 1)
  327.         IF EVALOBJ(pred,env) THEN
  328.            seq = heap(clause, 2)
  329.            DO WHILE heap(seq,2)
  330.             t = heap(seq,1)
  331.             t = evalobj(t,env) 'ignore result
  332.             seq = heap(seq,2)
  333.            LOOP
  334.            id = heap(seq,1): GOTO 1
  335.         END IF
  336.         clauses = heap(clauses,2)
  337.         WEND
  338.         CASE ELSE
  339.             args = heap(id,2)
  340.             proc = EVALOBJ(o,env)
  341.             EVALOBJ = apply(proc,lvals(args,env))
  342.         END SELECT
  343.         ELSE
  344.             args = heap(id,2)
  345.             proc = EVALOBJ(o, env)
  346.             EVALOBJ = apply(proc,lvals(args,env))
  347.         END IF
  348.     CASE ELSE
  349.         PRINT "Unhandled expression type: "; a$
  350.         EVALOBJ = id
  351.     END SELECT
  352.  
  353. FUNCTION lvals(id,env)
  354.    IF heap(id,0) = TCONS THEN
  355.      car = heap(id,1)
  356.      ecar = EVALOBJ(car,env)
  357.      head = CONS(ecar,0)
  358.      l = heap(id,2) : prev = head
  359.      WHILE l
  360.          car = heap(l,1)
  361.          ecar = EVALOBJ(car,env)
  362.          new = CONS(ecar,0)
  363.          heap(prev,2) = new
  364.          prev = new
  365.          l = heap(l,2)
  366.      WEND
  367.      lvals = head
  368.    ELSE
  369.      lvals = 0
  370.    END IF
  371.  
  372. FUNCTION apply(id,args)
  373.     IF heap(id,0) = TPROC THEN
  374.     params = heap(id,1)
  375.     body = heap(heap(id,2),1)
  376.     procenv = heap(heap(id,2),2)
  377.     env = CONS(CONS(params,args),procenv)
  378.     DO WHILE heap(body,2)
  379.     t = heap(body,1)
  380.     t = evalobj(t,env) 'ignore result
  381.     body = heap(body,2)
  382.     LOOP
  383.     t = heap(body,1)
  384.     apply = evalobj(t,env)
  385.     ELSEIF heap(id,0) = TPPROC THEN
  386.     SELECT CASE heap(id,1)
  387.     CASE PPLUS
  388.         sum = 0
  389.         a = args
  390.         WHILE a
  391.             sum = sum + heap(heap(a,1),1)
  392.             a = heap(a,2)
  393.         WEND
  394.         p = ALLOC()
  395.         heap(p,0) = TNUM
  396.         heap(p,1) = sum
  397.         apply = p
  398.     CASE PTIMES
  399.         prod = 1
  400.         a = args
  401.         WHILE a
  402.             prod = prod * heap(heap(a,1),1)
  403.             a = heap(a,2)
  404.         WEND
  405.         p = ALLOC()
  406.         heap(p,0) = TNUM
  407.         heap(p,1) = prod
  408.         apply = p
  409.     CASE PCONS
  410.         apply = CONS(heap(args,1), heap(heap(args,2),1))
  411.     CASE PCAR
  412.         apply = heap(heap(args,1),1)
  413.     CASE PCDR
  414.         apply = heap(heap(args,1),2)
  415.     CASE PEQUAL
  416.         IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  417.         f = heap(heap(args,1),1)
  418.         a = heap(args,2)
  419.         DO WHILE a
  420.             IF heap(heap(a,1),1) <> f THEN apply = TNIL : EXIT FUNCTION
  421.             a = heap(a,2)
  422.         LOOP
  423.         apply = STRTOATOM("T"): EXIT FUNCTION
  424.     CASE PNOT
  425.         IF heap(args,1) THEN apply = TNIL ELSE apply = STRTOATOM("T")
  426.     CASE PEQ
  427.         arg1 = heap(args,1)
  428.         arg2 = heap(heap(args,2),1)
  429.         IF heap(arg1,0) <> heap(arg2,0) THEN apply = TNIL: EXIT FUNCTION
  430.         SELECT CASE heap(arg1,0)
  431.         CASE TNUM, TPROC, TPPROC, TSYM
  432.             IF heap(arg1,1) = heap(arg2,1) THEN apply = STRTOATOM("T")
  433.         CASE TCONS, TNIL
  434.             IF arg1 = arg2 THEN apply = STRTOATOM("T")
  435.         END SELECT
  436.     CASE PSETCAR
  437.         arg1 = heap(args,1)
  438.         arg2 = heap(heap(args,2),1)
  439.         heap(arg1,1) = arg2
  440.     CASE PSETCDR
  441.         arg1 = heap(args,1)
  442.         arg2 = heap(heap(args,2),1)
  443.         heap(arg2,2) = arg2
  444.     CASE PAPPLY
  445.         arg1 = heap(args,1)
  446.         arg2 = heap(heap(args,2),1)
  447.         apply = apply(arg1,arg2)
  448.     CASE PLIST
  449.         apply = args
  450.     CASE PREAD
  451.         apply = readobj()
  452.     END SELECT
  453.     ELSE
  454.     PRINT "Bad application -- not a function"
  455.     apply = TOKERR
  456.     END IF
  457.  
  458. FUNCTION lookup(anum,env)
  459.     ' env is a list of (vars . vals) frames
  460.     ' where: vars is a list of symbols
  461.     '        vals is a list of their values
  462.     e = env
  463.     DO
  464.     frame = heap(e,1) ' get the first frame
  465.  
  466.     vars = heap(frame,1) ' vars is car
  467.  
  468.     vals = heap(frame,2) ' vals is cdr
  469.  
  470.     WHILE vars ' while vars left to check
  471.         IF heap(heap(vars, 1),1) = anum THEN 'atom number of car(vars) = anum
  472.             lookup = heap(vals,1) ' car(vals)
  473.             EXIT FUNCTION
  474.         END IF
  475.         vars = heap(vars,2) 'cdr(vars)
  476.         vals = heap(vals,2) 'cdr(vals)
  477.     WEND
  478.     e = heap(e,2) ' cdr(e)
  479.     LOOP WHILE e
  480.     PRINT "Unbound variable: "; ATOM$(anum): lookup = TOKERR
  481.  
  482. SUB setvar(id, value, env)
  483.     anum = heap(id,1)
  484.     e = env
  485.     DO
  486.         frame = heap(e,1)
  487.         vars = heap(frame,1)
  488.         vals = heap(frame,2)
  489.         WHILE vars
  490.             IF heap(heap(vars,1),1) = anum THEN
  491.                 heap(vals,1) = value : EXIT SUB
  492.             END IF
  493.             vars = heap(vars,2): vals = heap(vals,2)
  494.         WEND
  495.         e = heap(e,2)
  496.     LOOP WHILE e
  497.     CALL defvar(id, value, env)
  498.  
  499. SUB defvar(id, value, env)
  500.     anum = heap(id,1)
  501.     frame = heap(env,1)
  502.     vars = heap(frame,1)
  503.     vals = heap(frame,2)
  504.     WHILE vars
  505.         IF heap(heap(vars,1),1) = anum THEN
  506.             heap(vals,1) = value: EXIT SUB
  507.         END IF
  508.         vars = heap(vars,2): vals = heap(vals,2)
  509.     WEND
  510.     vars = heap(frame,1)
  511.     vals = heap(frame,2)
  512.     heap(frame,1) = CONS(id, vars)
  513.     heap(frame,2) = CONS(value, vals)
  514.  
  515. FUNCTION mkprimop(id)
  516.  p = alloc()
  517.  heap(p,0) = TPPROC
  518.  heap(p,1) = id
  519.  mkprimop = p
  520.  

Offline STxAxTIC

  • Library Staff
  • Forum Resident
  • Posts: 1091
  • he lives
    • View Profile
Re: Scheme (LISP) interpreter
« Reply #1 on: October 06, 2018, 09:20:45 pm »
So glad you found us qbguy! I've always liked this project of yours.

EDIT: Long ago I remember this not working as-is when pasted to QB64, and then during my edits I got on the path of making the file into BI/BM fragments so it could be included in other places easily (bots and whatever). More importantly though, I saved the test code because I don't think the audience here delves into LISPy things. Have fun with these two boxes all. They're four years old this month.

Code: QB64: [Select]
  1. ' Original by qbguy.
  2. ' Edits by STxAxTIC (10/16/2014).
  3. ' Posted to qb64.org forums on 10-06-2018.
  4.  
  5. DECLARE FUNCTION hash (s$)
  6. DECLARE FUNCTION READOBJ (depth)
  7. DECLARE FUNCTION READTOKEN (depth)
  8. DECLARE FUNCTION STRTOATOM (s$)
  9. DECLARE FUNCTION CONS (car, cdr)
  10. DECLARE FUNCTION READLIST (depth)
  11. DECLARE FUNCTION ALLOC ()
  12. DECLARE SUB PRINTOBJ (id)
  13. DECLARE FUNCTION EVALOBJ (id, env)
  14. DECLARE FUNCTION apply (f, args)
  15. DECLARE FUNCTION lookup (anum, env)
  16. DECLARE FUNCTION lvals (id, env)
  17. DECLARE SUB defvar (var, vals, env)
  18. DECLARE SUB setvar (id, vals, env)
  19. DECLARE FUNCTION mkprimop (id)
  20. DECLARE FUNCTION collect(p)
  21. DECLARE SUB gc(root)
  22. DECLARE FUNCTION DoLISP$(TheStringIn$, envin)
  23.  
  24. ' Make these smaller to get it to work in QBASIC / QuickBASIC
  25. CONST msize = 16384 'size of memory -- arbitrary
  26. CONST hsize = 4096 'size of hash table -- should be power of 2
  27.  
  28. DIM SHARED bufpos AS INTEGER, state AS INTEGER
  29. DIM SHARED hptr
  30. DIM SHARED atom$(0 TO hsize - 1), heap(2 * msize - 1, 2)
  31. DIM SHARED mmin, nmin, gcnow
  32.  
  33. mmin = 1: nmin = msize
  34.  
  35. DIM SHARED TheInput$
  36. DIM SHARED TheOutput$
  37.  
  38. CONST TRUE = -1
  39. CONST FALSE = 0
  40. CONST TNIL = 0
  41. CONST TCONS = 2
  42. CONST TNUM = 3
  43. CONST TSYM = 4
  44. CONST TPROC = 5
  45. CONST TPPROC = 6
  46. CONST TOKNIL = 0
  47. CONST TOKERR = -1
  48. CONST TOKOPEN = -2
  49. CONST TOKCLOSE = -3
  50. CONST TOKQUOTE = -4
  51. CONST TOKDOT = -5
  52.  
  53. CONST PPLUS = 1
  54. CONST PMINUS = 2
  55. CONST PTIMES = 3
  56. CONST PCONS = 4
  57. CONST PCAR = 5
  58. CONST PCDR = 6
  59. CONST PEQUAL = 7
  60. CONST PNOT = 8
  61. CONST PEQ = 9
  62. CONST PSETCAR = 10
  63. CONST PSETCDR = 11
  64. CONST PAPPLY = 12
  65. CONST PLIST = 13
  66. CONST PREAD = 14
  67. CONST PLT = 15
  68. CONST PGT = 16
  69. CONST PGEQ = 17
  70. CONST PLEQ = 18
  71. CONST PNUMP = 20
  72. CONST PPROCP = 21
  73. CONST PSYMP = 22
  74. CONST PCONSP = 24
  75.  
  76. ''''''''''
  77.  
  78. hptr = mmin: bufpos = 1
  79. vars = TNIL
  80. vals = TNIL
  81. frame = CONS(vars, vals)
  82. env = CONS(frame, TNIL)
  83. CALL defvar(STRTOATOM("+"), mkprimop(PPLUS), env)
  84. CALL defvar(STRTOATOM("-"), mkprimop(PMINUS), env)
  85. CALL defvar(STRTOATOM("*"), mkprimop(PTIMES), env)
  86. 'CALL defvar(STRTOATOM("%"), mkprimop(PMOD), env)
  87. CALL defvar(STRTOATOM("CONS"), mkprimop(PCONS), env)
  88. CALL defvar(STRTOATOM("CAR"), mkprimop(PCAR), env)
  89. CALL defvar(STRTOATOM("CDR"), mkprimop(PCDR), env)
  90. CALL defvar(STRTOATOM("="), mkprimop(PEQUAL), env)
  91. CALL defvar(STRTOATOM("NOT"), mkprimop(PNOT), env)
  92. CALL defvar(STRTOATOM("EQ?"), mkprimop(PEQ), env)
  93. CALL defvar(STRTOATOM("EQV?"), mkprimop(PEQ), env)
  94. CALL defvar(STRTOATOM("T"), STRTOATOM("T"), env) ' true
  95. CALL defvar(STRTOATOM("SET-CAR!"), mkprimop(PSETCAR), env)
  96. CALL defvar(STRTOATOM("SET-CDR!"), mkprimop(PSETCDR), env)
  97. CALL defvar(STRTOATOM("APPLY"), mkprimop(PAPPLY), env)
  98. CALL defvar(STRTOATOM("LIST"), mkprimop(PLIST), env)
  99. CALL defvar(STRTOATOM("READ"), mkprimop(PREAD), env)
  100. CALL defvar(STRTOATOM("<"), mkprimop(PLT), env)
  101. CALL defvar(STRTOATOM(">"), mkprimop(PGT), env)
  102. CALL defvar(STRTOATOM(">="), mkprimop(PGEQ), env)
  103. CALL defvar(STRTOATOM("<="), mkprimop(LEQ), env)
  104. CALL defvar(STRTOATOM("SYMBOL?"), mkprimop(PSYMP), env)
  105. CALL defvar(STRTOATOM("NUMBER?"), mkprimop(PNUMP), env)
  106. CALL defvar(STRTOATOM("PROCEDURE?"), mkprimop(PPROCP), env)
  107. CALL defvar(STRTOATOM("PAIR?"), mkprimop(PCONSP), env)
  108.  
  109.     LINE INPUT ">"; q$
  110.     r$ = DoLISP$(q$, env)
  111.     PRINT r$: PRINT
  112.  
  113. ''''''''''
  114.  
  115.  
  116.  
  117. FUNCTION DoLISP$ (TheStringIn AS STRING, envin)
  118. TheInput$ = TheStringIn
  119. TheOutput$ = ""
  120. s = READOBJ(0)
  121.     CASE TOKCLOSE
  122.         ' Unmatched closed parenthesis.
  123.         TheOutput$ = TheOutput$ + "[Unmatched closed parenthesis.]"
  124.     CASE TOKDOT
  125.         'PRINT "Dot used outside list."
  126.         TheOutput$ = TheOutput$ + "[Dot used outside list.]"
  127.     CASE TOKERR
  128.         'PRINT "[Error]"
  129.         TheOutput$ = TheOutput$ + "[Error]"
  130.     CASE ELSE
  131.         CALL PRINTOBJ(EVALOBJ(s, envin))
  132. DoLISP$ = TheOutput$
  133.  
  134. 'DO
  135. '    s = READOBJ(0)
  136. '    SELECT CASE s
  137. '        CASE TOKCLOSE
  138. '            ' unmatched closed parenthesis
  139. '        CASE TOKDOT
  140. '            PRINT "dot used outside list"
  141. '        CASE TOKERR
  142. '            PRINT "[Error]"
  143. '        CASE ELSE
  144. '            CALL PRINTOBJ(EVALOBJ(s, env))
  145. '    END SELECT
  146. '    PRINT
  147. '    IF gcnow THEN CALL gc(env)
  148. 'LOOP
  149.  
  150. FUNCTION ALLOC
  151. ALLOC = hptr
  152. hptr = hptr + 1
  153. IF hptr > (mmin + 3 * (msize / 4)) THEN gcnow = -1
  154.  
  155. FUNCTION apply (id, args)
  156. IF heap(id, 0) = TPROC THEN
  157.     params = heap(id, 1)
  158.     body = heap(heap(id, 2), 1)
  159.     procenv = heap(heap(id, 2), 2)
  160.     env = CONS(CONS(params, args), procenv)
  161.     DO WHILE heap(body, 2)
  162.         t = heap(body, 1)
  163.         t = EVALOBJ(t, env) 'ignore result
  164.         body = heap(body, 2)
  165.     LOOP
  166.     t = heap(body, 1)
  167.     apply = EVALOBJ(t, env)
  168. ELSEIF heap(id, 0) = TPPROC THEN
  169.     SELECT CASE heap(id, 1)
  170.         CASE PPLUS
  171.             sum = 0
  172.             a = args
  173.             WHILE a
  174.                 sum = sum + heap(heap(a, 1), 1)
  175.                 a = heap(a, 2)
  176.             WEND
  177.             p = ALLOC
  178.             heap(p, 0) = TNUM
  179.             heap(p, 1) = sum
  180.             apply = p
  181.         CASE PTIMES
  182.             prod = 1
  183.             a = args
  184.             WHILE a
  185.                 prod = prod * heap(heap(a, 1), 1)
  186.                 a = heap(a, 2)
  187.             WEND
  188.             p = ALLOC
  189.             heap(p, 0) = TNUM
  190.             heap(p, 1) = prod
  191.             apply = p
  192.             'CASE PMOD
  193.             '    prod = 1
  194.             '    a = args
  195.             '    WHILE a
  196.             '        prod = prod MOD heap(heap(a, 1), 1)
  197.             '        a = heap(a, 2)
  198.             '    WEND
  199.             '    p = ALLOC
  200.             '    heap(p, 0) = TNUM
  201.             '    heap(p, 1) = prod
  202.             '    apply = p
  203.         CASE PCONS
  204.             apply = CONS(heap(args, 1), heap(heap(args, 2), 1))
  205.         CASE PCAR
  206.             apply = heap(heap(args, 1), 1)
  207.         CASE PCDR
  208.             apply = heap(heap(args, 1), 2)
  209.         CASE PEQUAL
  210.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  211.             f = heap(heap(args, 1), 1)
  212.             a = heap(args, 2)
  213.             DO WHILE a
  214.                 IF heap(heap(a, 1), 1) <> f THEN apply = TNIL: EXIT FUNCTION
  215.                 a = heap(a, 2)
  216.             LOOP
  217.             apply = STRTOATOM("T"): EXIT FUNCTION
  218.         CASE PNOT
  219.             IF heap(args, 1) THEN apply = TNIL ELSE apply = STRTOATOM("T")
  220.         CASE PEQ
  221.             arg1 = heap(args, 1)
  222.             arg2 = heap(heap(args, 2), 1)
  223.             IF heap(arg1, 0) <> heap(arg2, 0) THEN apply = TNIL: EXIT FUNCTION
  224.             SELECT CASE heap(arg1, 0)
  225.                 CASE TNUM, TPROC, TPPROC, TSYM
  226.                     IF heap(arg1, 1) = heap(arg2, 1) THEN apply = STRTOATOM("T")
  227.                 CASE TCONS, TNIL
  228.                     IF arg1 = arg2 THEN apply = STRTOATOM("T")
  229.             END SELECT
  230.         CASE PLT
  231.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  232.             f = heap(heap(args, 1), 1)
  233.             a = heap(args, 2)
  234.             DO WHILE a
  235.                 IF f < heap(heap(a, 1), 1) THEN
  236.                     f = heap(heap(a, 1), 1)
  237.                     a = heap(a, 2)
  238.                 ELSE
  239.                     apply = TNIL: EXIT FUNCTION
  240.                 END IF
  241.             LOOP
  242.             apply = STRTOATOM("T"): EXIT FUNCTION
  243.         CASE PGT
  244.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  245.             f = heap(heap(args, 1), 1)
  246.             a = heap(args, 2)
  247.             DO WHILE a
  248.                 IF f > heap(heap(a, 1), 1) THEN
  249.                     f = heap(heap(a, 1), 1)
  250.                     a = heap(a, 2)
  251.                 ELSE
  252.                     apply = TNIL: EXIT FUNCTION
  253.                 END IF
  254.             LOOP
  255.             apply = STRTOATOM("T"): EXIT FUNCTION
  256.         CASE PLEQ
  257.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  258.             f = heap(heap(args, 1), 1)
  259.             a = heap(args, 2)
  260.             DO WHILE a
  261.                 IF f <= heap(heap(a, 1), 1) THEN
  262.                     f = heap(heap(a, 1), 1)
  263.                     a = heap(a, 2)
  264.                 ELSE
  265.                     apply = TNIL: EXIT FUNCTION
  266.                 END IF
  267.             LOOP
  268.             apply = STRTOATOM("T"): EXIT FUNCTION
  269.         CASE PGEQ
  270.             IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
  271.             f = heap(heap(args, 1), 1)
  272.             a = heap(args, 2)
  273.             DO WHILE a
  274.                 IF f >= heap(heap(a, 1), 1) THEN
  275.                     f = heap(heap(a, 1), 1)
  276.                     a = heap(a, 2)
  277.                 ELSE
  278.                     apply = TNIL: EXIT FUNCTION
  279.                 END IF
  280.             LOOP
  281.             apply = STRTOATOM("T"): EXIT FUNCTION
  282.         CASE PSETCAR
  283.             arg1 = heap(args, 1)
  284.             arg2 = heap(heap(args, 2), 1)
  285.             heap(arg1, 1) = arg2
  286.         CASE PSETCDR
  287.             arg1 = heap(args, 1)
  288.             arg2 = heap(heap(args, 2), 1)
  289.             heap(arg2, 2) = arg2
  290.         CASE PAPPLY
  291.             arg1 = heap(args, 1)
  292.             arg2 = heap(heap(args, 2), 1)
  293.             apply = apply(arg1, arg2)
  294.         CASE PLIST
  295.             apply = args
  296.         CASE PREAD
  297.             apply = READOBJ(0)
  298.         CASE PMINUS
  299.             arg1 = heap(heap(args, 1), 1)
  300.             rargs = heap(args, 2)
  301.             IF rargs THEN
  302.                 res = arg1
  303.                 WHILE rargs
  304.                     res = res - heap(heap(rargs, 1), 1)
  305.                     rargs = heap(rargs, 2)
  306.                 WEND
  307.                 p = ALLOC
  308.                 heap(p, 0) = TNUM: heap(p, 1) = res: apply = p
  309.             ELSE
  310.                 p = ALLOC: heap(p, 0) = TNUM: heap(p, 1) = -arg1
  311.                 apply = p
  312.             END IF
  313.         CASE PSYMP
  314.             targ1 = heap(heap(args, 1), 0)
  315.             IF targ1 = TSYM THEN apply = STRTOATOM("T")
  316.         CASE PNUMP
  317.             targ1 = heap(heap(args, 1), 0)
  318.             IF targ1 = TNUM THEN apply = STRTOATOM("T")
  319.         CASE PPROCP
  320.             targ1 = heap(heap(args, 1), 0)
  321.             IF targ1 = TPROC OR targ1 = TPPROC THEN apply = STRTOATOM("T")
  322.         CASE PCONSP
  323.             targ1 = heap(heap(args, 1), 0)
  324.             IF targ1 = TCONS THEN apply = STRTOATOM("T")
  325.     END SELECT
  326.     PRINT "Bad application -- not a function"
  327.     apply = TOKERR
  328.  
  329. FUNCTION CONS (car, cdr)
  330. p = ALLOC
  331. heap(p, 0) = TCONS
  332. heap(p, 1) = car
  333. heap(p, 2) = cdr
  334. CONS = p
  335.  
  336. SUB defvar (id, value, env)
  337. anum = heap(id, 1)
  338. frame = heap(env, 1)
  339. vars = heap(frame, 1)
  340. vals = heap(frame, 2)
  341. WHILE vars
  342.     IF heap(heap(vars, 1), 1) = anum THEN
  343.         heap(vals, 1) = value: EXIT SUB
  344.     END IF
  345.     vars = heap(vars, 2): vals = heap(vals, 2)
  346. vars = heap(frame, 1)
  347. vals = heap(frame, 2)
  348. heap(frame, 1) = CONS(id, vars)
  349. heap(frame, 2) = CONS(value, vals)
  350.  
  351. FUNCTION EVALOBJ (id, env)
  352. 1 SELECT CASE heap(id, 0)
  353.     CASE TNIL, TNUM ' self-evaluating
  354.         EVALOBJ = id
  355.     CASE TSYM
  356.         EVALOBJ = lookup(heap(id, 1), env)
  357.     CASE TCONS
  358.         o = heap(id, 1)
  359.         t = heap(o, 0)
  360.         IF t = TSYM THEN
  361.             a$ = atom$(heap(o, 1)) ' symbol name of car(id)
  362.             SELECT CASE a$
  363.                 CASE "QUOTE"
  364.                     EVALOBJ = heap(heap(id, 2), 1)
  365.                 CASE "SET!"
  366.                     vid = heap(heap(id, 2), 1) 'cadr
  367.                     aval = heap(heap(heap(id, 2), 2), 1) 'caddr
  368.                     CALL setvar(vid, EVALOBJ(aval, env), env)
  369.                 CASE "DEFINE"
  370.                     vid = heap(heap(id, 2), 1)
  371.                     aval = heap(heap(heap(id, 2), 2), 1)
  372.                     CALL setvar(vid, EVALOBJ(aval, env), env)
  373.                 CASE "IF"
  374.                     ' (if pred ic ia)
  375.                     pred = heap(heap(id, 2), 1) 'predicate = cadr
  376.                     ic = heap(heap(heap(id, 2), 2), 1) ' caddr
  377.                     ia = heap(heap(heap(heap(id, 2), 2), 2), 1) ' cadddr
  378.                     IF EVALOBJ(pred, env) THEN
  379.                         ' return EVALOBJ(ic,env)
  380.                         id = ic: GOTO 1
  381.                     ELSE
  382.                         ' return EVALOBJ(ia,env)
  383.                         id = ia: GOTO 1
  384.                     END IF
  385.                 CASE "LAMBDA"
  386.                     p = ALLOC
  387.                     heap(p, 0) = TPROC
  388.                     heap(p, 1) = heap(heap(id, 2), 1) ' cadr = args
  389.                     heap(p, 2) = CONS(heap(heap(id, 2), 2), env) 'caddr = body
  390.                     EVALOBJ = p
  391.                 CASE "BEGIN"
  392.                     seq = heap(id, 2)
  393.                     DO WHILE heap(seq, 2)
  394.                         t = heap(seq, 1)
  395.                         t = EVALOBJ(t, env) 'ignore result
  396.                         seq = heap(seq, 2)
  397.                     LOOP
  398.                     id = heap(seq, 1): GOTO 1
  399.                 CASE "AND"
  400.                     seq = heap(id, 2)
  401.                     DO WHILE heap(seq, 2)
  402.                         t = heap(seq, 1)
  403.                         t = EVALOBJ(t, env)
  404.                         IF t = 0 THEN EVALOBJ = 0: EXIT FUNCTION
  405.                         seq = heap(seq, 2)
  406.                     LOOP
  407.                     id = heap(seq, 1): GOTO 1
  408.                 CASE "OR"
  409.                     seq = heap(id, 2)
  410.                     DO WHILE heap(seq, 2)
  411.                         t = heap(seq, 1)
  412.                         t = EVALOBJ(t, env)
  413.                         IF t THEN EVALOBJ = t: EXIT FUNCTION
  414.                         seq = heap(seq, 2)
  415.                     LOOP
  416.                     id = heap(seq, 1): GOTO 1
  417.                 CASE "COND"
  418.                     clauses = heap(id, 2)
  419.                     WHILE clauses
  420.                         clause = heap(clauses, 1)
  421.                         pred = heap(clause, 1)
  422.                         IF EVALOBJ(pred, env) THEN
  423.                             seq = heap(clause, 2)
  424.                             DO WHILE heap(seq, 2)
  425.                                 t = heap(seq, 1)
  426.                                 t = EVALOBJ(t, env) 'ignore result
  427.                                 seq = heap(seq, 2)
  428.                             LOOP
  429.                             id = heap(seq, 1): GOTO 1
  430.                         END IF
  431.                         clauses = heap(clauses, 2)
  432.                     WEND
  433.                 CASE ELSE
  434.                     args = heap(id, 2)
  435.                     proc = EVALOBJ(o, env)
  436.                     EVALOBJ = apply(proc, lvals(args, env))
  437.             END SELECT
  438.         ELSE
  439.             args = heap(id, 2)
  440.             proc = EVALOBJ(o, env)
  441.             EVALOBJ = apply(proc, lvals(args, env))
  442.         END IF
  443.     CASE ELSE
  444.         PRINT "Unhandled expression type: "; a$
  445.         EVALOBJ = id
  446.  
  447. FUNCTION hash (s$)
  448. FOR i = 1 TO LEN(s$)
  449.     c = ASC(MID$(s$, i, 1))
  450.     h = (h * 33 + c) MOD hsize
  451. hash = h
  452.  
  453. FUNCTION lookup (anum, env)
  454. ' env is a list of (vars . vals) frames
  455. ' where: vars is a list of symbols
  456. '        vals is a list of their values
  457. e = env
  458.     frame = heap(e, 1) ' get the first frame
  459.  
  460.     vars = heap(frame, 1) ' vars is car
  461.  
  462.     vals = heap(frame, 2) ' vals is cdr
  463.  
  464.     WHILE vars ' while vars left to check
  465.         IF heap(heap(vars, 1), 1) = anum THEN 'atom number of car(vars) = anum
  466.             lookup = heap(vals, 1) ' car(vals)
  467.             EXIT FUNCTION
  468.         END IF
  469.         vars = heap(vars, 2) 'cdr(vars)
  470.         vals = heap(vals, 2) 'cdr(vals)
  471.     WEND
  472.     e = heap(e, 2) ' cdr(e)
  473. 'PRINT "Unbound variable: "; atom$(anum)
  474. TheOutput$ = TheOutput$ + "Unbound variable: " + atom$(anum)
  475. lookup = TOKERR
  476.  
  477. FUNCTION lvals (id, env)
  478. IF heap(id, 0) = TCONS THEN
  479.     car = heap(id, 1)
  480.     ecar = EVALOBJ(car, env)
  481.     head = CONS(ecar, 0)
  482.     l = heap(id, 2): prev = head
  483.     WHILE l
  484.         car = heap(l, 1)
  485.         ecar = EVALOBJ(car, env)
  486.         new = CONS(ecar, 0)
  487.         heap(prev, 2) = new
  488.         prev = new
  489.         l = heap(l, 2)
  490.     WEND
  491.     lvals = head
  492.     lvals = 0
  493.  
  494. FUNCTION mkprimop (id)
  495. p = ALLOC
  496. heap(p, 0) = TPPROC
  497. heap(p, 1) = id
  498. mkprimop = p
  499.  
  500. SUB PRINTOBJ (id)
  501.  
  502. IF id = TOKERR THEN PRINT "[Error]": EXIT SUB
  503. SELECT CASE heap(id, 0)
  504.     CASE TNIL
  505.         'PRINT "()";
  506.         TheOutput$ = TheOutput$ + "()"
  507.     CASE TCONS
  508.         'PRINT "(";
  509.         TheOutput$ = TheOutput$ + "("
  510.         printlist:
  511.         CALL PRINTOBJ(heap(id, 1))
  512.         'PRINT " ";
  513.         TheOutput$ = TheOutput$ + " "
  514.         cdr = heap(id, 2)
  515.         IF heap(cdr, 0) = TCONS THEN id = cdr: GOTO printlist
  516.         IF heap(cdr, 0) = TNIL THEN
  517.             'PRINT ")";
  518.             TheOutput$ = TheOutput$ + ")"
  519.         ELSE
  520.             'PRINT ".";
  521.             TheOutput$ = TheOutput$ + "."
  522.             CALL PRINTOBJ(cdr)
  523.             'PRINT ")";
  524.             TheOutput$ = TheOutput$ + ")"
  525.         END IF
  526.     CASE TNUM
  527.         'PRINT heap(id, 1);
  528.         TheOutput$ = TheOutput$ + STR$(heap(id, 1))
  529.     CASE TSYM
  530.         'PRINT atom$(heap(id, 1));
  531.         TheOutput$ = TheOutput$ + atom$(heap(id, 1))
  532.     CASE TPROC, TPPROC
  533.         'PRINT "[Procedure]"
  534.         TheOutput$ = TheOutput$ + "[Procedure]"
  535.  
  536. FUNCTION READLIST (depth)
  537. SH = READOBJ(depth)
  538.     CASE TOKERR
  539.         READLIST = TOKERR
  540.     CASE TOKCLOSE
  541.         READLIST = 0
  542.     CASE TOKDOT
  543.         SH = READOBJ(depth)
  544.         SELECT CASE SH
  545.             CASE TOKERR, TOKDOT, TOKCLOSE
  546.                 READLIST = TOKERR
  547.             CASE ELSE
  548.                 ST = READLIST(depth)
  549.                 IF ST THEN READLIST = TOKERR ELSE READLIST = SH
  550.         END SELECT
  551.     CASE ELSE
  552.         ST = READLIST(depth)
  553.         IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH, ST)
  554.  
  555. FUNCTION READOBJ (depth)
  556. tok = READTOKEN(depth)
  557.     CASE TOKOPEN
  558.         s = READLIST(depth + 1)
  559.         READOBJ = s
  560.     CASE TOKQUOTE
  561.         tok = READOBJ(depth + 1)
  562.         SELECT CASE tok
  563.             CASE TOKCLOSE
  564.                 PRINT "warning: quote before close parenthesis"
  565.                 READOBJ = tok
  566.             CASE TOKDOT
  567.                 PRINT "warning: quote before dot"
  568.                 READOBJ = tok
  569.             CASE ELSE
  570.                 s = CONS(STRTOATOM("QUOTE"), CONS(tok, 0))
  571.                 READOBJ = s
  572.         END SELECT
  573.     CASE ELSE
  574.         READOBJ = tok
  575.  
  576. FUNCTION READTOKEN (depth)
  577.  
  578. start1: bufend = LEN(buf)
  579. WHILE bufpos < bufend AND INSTR(" " + CHR$(9), MID$(buf, bufpos, 1))
  580.     bufpos = bufpos + 1
  581. c$ = MID$(buf, bufpos, 1)
  582. IF INSTR(":;", c$) THEN
  583.     IF c$ = ":" THEN
  584.         bufpos = bufpos + 1
  585.         IF bufpos <= bufend THEN
  586.             SELECT CASE MID$(buf, bufpos, 1)
  587.                 CASE "q", "Q" ' quit
  588.                     SYSTEM
  589.                 CASE "g", "G" ' garbage collect now
  590.                     gcnow = -1
  591.                 CASE ELSE
  592.                     READTOKEN = TOKERR
  593.                     EXIT FUNCTION
  594.             END SELECT
  595.         END IF
  596.     END IF
  597.     bufpos = bufend + 1
  598. IF bufpos > bufend THEN
  599.     'IF depth = 0 THEN PRINT "]=> ";
  600.     'LINE INPUT buf
  601.     buf = TheInput$
  602.     bufend = LEN(buf)
  603.     bufpos = 1
  604.     GOTO start1
  605.     CASE "("
  606.         bufpos = bufpos + 1
  607.         READTOKEN = TOKOPEN
  608.     CASE ")"
  609.         bufpos = bufpos + 1
  610.         READTOKEN = TOKCLOSE
  611.     CASE "'"
  612.         bufpos = bufpos + 1
  613.         READTOKEN = TOKQUOTE
  614.     CASE "."
  615.         bufpos = bufpos + 1
  616.         READTOKEN = TOKDOT
  617.     CASE ELSE
  618.         strbeg = bufpos
  619.         bufpos = bufpos + 1
  620.         DO WHILE bufpos <= bufend
  621.             c$ = MID$(buf, bufpos, 1)
  622.             IF c$ = " " OR c$ = "." OR c$ = "(" OR c$ = ")" THEN EXIT DO
  623.             bufpos = bufpos + 1
  624.         LOOP
  625.         READTOKEN = STRTOATOM(MID$(buf, strbeg, bufpos - strbeg))
  626.  
  627. SUB setvar (id, value, env)
  628. anum = heap(id, 1)
  629. e = env
  630.     frame = heap(e, 1)
  631.     vars = heap(frame, 1)
  632.     vals = heap(frame, 2)
  633.     WHILE vars
  634.         IF heap(heap(vars, 1), 1) = anum THEN
  635.             heap(vals, 1) = value: EXIT SUB
  636.         END IF
  637.         vars = heap(vars, 2): vals = heap(vals, 2)
  638.     WEND
  639.     e = heap(e, 2)
  640. CALL defvar(id, value, env)
  641.  
  642. FUNCTION STRTOATOM (s$)
  643. l = LEN(s$)
  644. c$ = LEFT$(s$, 1)
  645. IF (c$ = "-" AND l >= 2) OR (c$ >= "0" AND c$ <= "9") THEN
  646.     v = 0
  647.     IF c$ = "-" THEN neg = 1: idx = 2 ELSE neg = 0: idx = 1
  648.     FOR idx = idx TO l
  649.         c$ = MID$(s$, idx, 1)
  650.         IF (c$ >= "0" AND c$ <= "9") THEN
  651.             v = v * 10 + (ASC(c$) - ASC("0"))
  652.         ELSE
  653.             EXIT FOR
  654.         END IF
  655.     NEXT
  656.     IF idx = l + 1 THEN
  657.         IF neg THEN v = -v
  658.         p = ALLOC
  659.         heap(p, 0) = TNUM
  660.         heap(p, 1) = v
  661.         STRTOATOM = p: EXIT FUNCTION
  662.     END IF
  663. IF UCASE$(s$) = "NIL" THEN STRTOATOM = TOKNIL: EXIT FUNCTION
  664.  
  665. i = hash(UCASE$(s$))
  666. FOR count = 1 TO hsize
  667.     IF atom$(i) = UCASE$(s$) THEN
  668.         found = TRUE: EXIT FOR
  669.     ELSEIF atom$(i) = "" THEN
  670.         atom$(i) = UCASE$(s$)
  671.         found = TRUE
  672.         EXIT FOR
  673.     ELSE
  674.         i = (i + count) MOD hsize
  675.     END IF
  676. IF NOT found THEN PRINT "Symbol table full!"
  677. p = ALLOC: heap(p, 0) = TSYM: heap(p, 1) = i
  678. STRTOATOM = p
  679.  
  680. SUB gc (root)
  681. hptr = nmin
  682. root = collect(root)
  683. SWAP mmin, nmin
  684. SWAP mmax, nmax
  685. gcnow = 0
  686.  
  687. FUNCTION collect (p)
  688.  
  689. SELECT CASE heap(p, 0)
  690.  
  691.     CASE -1
  692.         collect = heap(p, 1)
  693.  
  694.     CASE TCONS, TPROC
  695.  
  696.         ' address of new copy
  697.         x = ALLOC
  698.  
  699.         ' car, cdr
  700.         a = heap(p, 1)
  701.         d = heap(p, 2)
  702.  
  703.         ' replace with forwarding address
  704.         heap(p, 0) = -1
  705.         heap(p, 1) = x
  706.  
  707.         ' copy
  708.         heap(x, 0) = heap(p, 0)
  709.         heap(x, 1) = collect(a)
  710.         heap(x, 2) = collect(d)
  711.         collect = x
  712.  
  713.     CASE TNIL
  714.         collect = 0
  715.  
  716.     CASE ELSE
  717.         x = ALLOC
  718.  
  719.         ' copy the entire structure
  720.         FOR i = 0 TO 2
  721.             heap(x, i) = heap(p, i)
  722.         NEXT
  723.  
  724.         ' write forwarding address
  725.         heap(p, 0) = -1
  726.         heap(p, 1) = x
  727.         collect = x
  728.  
  729.  

Code: QB64: [Select]
  1. (+ 2 2)
  2. (apply + '(1 2 3))
  3. (+ 1 -3 2 5)
  4. (define generator (lambda (x) (lambda (y) (if y (generator y) x))))
  5. (define pocket (generator 8))
  6. (pocket nil)
  7. (define pocktwo (pocket 10))
  8. (pocktwo '())
  9. (define fact (lambda (x) (if (= x 0) 1 (* x (fact (+ x -1))))))
  10. (fact 5)
  11. (fact 7)
  12. (DEFINE MAP (LAMBDA (F X) (IF X (CONS (F (CAR X)) (MAP F (CDR X))))))
  13. (MAP (LAMBDA (X) (* X 2)) '(1 2 3 4 5 6 7 ))
« Last Edit: October 06, 2018, 10:24:22 pm by STxAxTIC »
You're not done when it works, you're done when it's right.

FellippeHeitor

  • Guest
Re: Scheme (LISP) interpreter
« Reply #2 on: October 06, 2018, 09:54:16 pm »
Welcome to our new place, qbguy!

Offline qbguy

  • Newbie
  • Posts: 11
    • View Profile
Re: Scheme (LISP) interpreter
« Reply #3 on: October 15, 2018, 10:31:50 pm »
Looks like QB64 still interprets 0-placed recursive functions incorrectly.  The version I posted triggers the recursion bug but it is easy to change the code so as not to use zero-place functions (e.g. make depth a parameter or add a dummy parameter).  STxAxTIC's modified version has this modification already but has the read code modified so it reads from a line of input so you can't split your expressions across lines.

Offline jcolivo

  • Newbie
  • Posts: 5
    • View Profile
Re: Scheme (LISP) interpreter
« Reply #4 on: June 19, 2019, 12:24:59 am »
More importantly though, I saved the test code because I don't think the audience here delves into LISPy things.

Me too. I love Scheme.

--JC

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Scheme (LISP) interpreter
« Reply #5 on: June 19, 2019, 10:17:15 am »
Ah something I have been meaning to check out. Thanks for reminder :)

Offline jack

  • Seasoned Forum Regular
  • Posts: 408
    • View Profile
Re: Scheme (LISP) interpreter
« Reply #6 on: June 20, 2019, 04:32:40 am »
hello bplus
if you want to investigate/explore the Scheme language I suggest you give Racket a try https://www.racket-lang.org
it has a nice IDE and it's designed for students, that is, the IDE gives hints when mistakes are made.

Offline bplus

  • Global Moderator
  • Forum Resident
  • Posts: 8053
  • b = b + ...
    • View Profile
Re: Scheme (LISP) interpreter
« Reply #7 on: June 21, 2019, 02:02:02 am »
Thanks jack,

I did download Dr Rachet, er Racket, and started the intro course because it plays with pictures :)

Very different experience.