« previous next »
Pages: [1]   Go Down

Author Topic: LISP Interpreter by qbguy  (Read 8006 times)

0 Members and 1 Guest are viewing this topic.

Offline The Librarian

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

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 ))
LISP ss.png
* LISP.bas (Filesize: 24.28 KB, Downloads: 532)
« Last Edit: March 06, 2020, 05:19:39 am by Qwerkey »
Logged
Pages: [1]   Go Up
« previous next »