QB64.org Forum

Active Forums => Samples Gallery => Interpreters => Topic started by: The Librarian on March 04, 2020, 06:32:36 PM

Title: LISP Interpreter by qbguy
Post by: The Librarian on March 04, 2020, 06:32:36 PM
LISP Interpreter

Author: @qbguy
Source: qb64.org Forums
URL: https://www.qb64.org/forum/index.php?topic=676.0 (https://www.qb64.org/forum/index.php?topic=676.0)
Version: STxAxTIC mod 2014
Tags: [interpreter]

Description:
Any sufficiently complicated C or Fortran program contains an ad hoc, informally-specified, bug-ridden, slow implementation of half of Common Lisp. - Greenspun's tenth rule of programming

qbguy: 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.


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

Run-time input sample:
Code: [Select]
(+ 2 2)
(apply + '(1 2 3))
(+ 1 -3 2 5)
(define generator (lambda (x) (lambda (y) (IF y (generator y) x))))
(define pocket (generator 8))
(pocket nil)
(define pocktwo (pocket 10))
(pocktwo '())
(define fact (lambda (x) (IF (= x 0) 1 (* x (fact (+ x -1))))))
(fact 5)
(fact 7)
(DEFINE MAP (LAMBDA (F X) (IF X (CONS (F (CAR X)) (MAP F (CDR X))))))
(MAP (LAMBDA (X) (* X 2)) '(1 2 3 4 5 6 7 ))