home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / progs / lisp.icn < prev    next >
Lisp/Scheme  |  2000-07-29  |  10KB  |  420 lines
  1. ############################################################################
  2. #
  3. #    File:     lisp.icn
  4. #
  5. #    Subject:  Program to interpret LISP programs
  6. #
  7. #    Author:   Stephen B. Wampler, modified by Phillip Lee Thomas
  8. #
  9. #    Date:     February 4, 1991
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #     This program is a simple interpreter for pure Lisp. It takes the
  18. #  name of the Lisp program as a command-line argument.
  19. #
  20. #     The syntax and semantics are based on EV-LISP, as described in
  21. #  Laurent Siklossy's "Let's Talk LISP" (Prentice-Hall, 1976, ISBN
  22. #  0-13-532762-8).  Functions that have been predefined match those
  23. #  described in Chapters 1-4 of the book.
  24. #
  25. #     No attempt at improving efficiency has been made, this is
  26. #  rather an example of how a simple LISP interpreter might be
  27. #  implemented in Icon.
  28. #
  29. #     The language implemented is case-insensitive.
  30. #
  31. #     It only reads enough input lines at one time to produce at least
  32. #   one LISP-expression, but continues to read input until a valid
  33. #   LISP-expression is found.
  34. #
  35. #     Errors:
  36. #
  37. #        Fails on EOF; fails with error message if current
  38. #     input cannot be made into a valid LISP-expression (i.e. more
  39. #     right than left parens).
  40. #
  41. ############################################################################
  42. #
  43. #  Syntax:
  44. #    (quote (a b c))           ==> (A B C)
  45. #    (setq a (quote (A B C)))  ==> (A B C)
  46. #    (car a)                   ==> (A)
  47. #    (cdr a)                   ==> (B C)
  48. #    (cons (quote d) a)        ==> (D A B C)
  49. #    (eq (car a) (car a))      ==> T
  50. #    (atom (quote ()))         ==> T
  51. #    (atom a)                  ==> NIL
  52. #    (null (car (car a)))      ==> T
  53. #    (eval (quote a))          ==> (A B C)
  54. #    (print a)                 ==> (A B C)
  55. #                                  (A B C)
  56. #    (define (quote (
  57. #            (cadr (quote (lambda (l) (car (cdr l)))))
  58. #            (cddr (quote (lambda (l) (cdr (cdr l)))))
  59. #            )))               ==> (CADR CDDR)
  60. #    (trace (quote (cadr)))    ==> NIL
  61. #    (untrace (quote (cadr)))  ==> NIL
  62. #    (itraceon)                ==> T [turns on icon tracing]
  63. #    (itraceoff)               ==> NIL [turns off icon tracing]
  64. #    (exit)                    ==> [exit gracefully from icon]
  65. #
  66. ############################################################################
  67.  
  68. global words,     # table of variable atoms
  69.        T, NIL,    # universal constants
  70.        infile     # command line library files
  71.  
  72. global trace_set  # set of currently traced functions
  73.  
  74. record prop(v,f)  # abbreviated propery list
  75.  
  76. ### main interpretive loop
  77. #
  78. procedure main(f) 
  79. local sexpr, source
  80.    initialize()
  81.    while infile := open(source := (pop(f) | "CON")) do {
  82.       write("Reading: ", source)
  83.       every sexpr := bstol(getbs()) do  {
  84.             PRINT([EVAL([sexpr])])
  85.             writes("> ")
  86.             }
  87.       }
  88.  
  89. end
  90.  
  91. ## (EVAL e) - the actual LISP interpreter
  92. #
  93. procedure EVAL(l)
  94. local fn, arglist, arg
  95.    l := l[1]
  96.    if T === ATOM([l]) then {                 # it's an atom
  97.       if T === l then return .T
  98.       if EQ([NIL,l]) === T then return .NIL
  99.       return .((\words[l]).v | NIL)
  100.       }
  101.    if glist(l) then {                        # it's a list
  102.       if T === ATOM([l[1]]) then
  103.          case l[1] of {
  104.          "QUOTE" : return .(l[2] | NIL)
  105.          "COND"  : return COND(l[2:0])
  106.          "SETQ"  : return SET([l[2]]|||evlis(l[3:0]))
  107.          "ITRACEON"  : return (&trace := -1,T)
  108.          "ITRACEOFF" : return (&trace := 0,NIL)
  109.          "EXIT"      : exit(0)
  110.          default : return apply([l[1]]|||evlis(l[2:0])) | NIL
  111.          }
  112.       return apply([EVAL([l[1]])]|||evlis(l[2:0])) | NIL
  113.       }
  114.    return .NIL
  115. end
  116.  
  117. ## apply(fn,args) - evaluate the function
  118.  
  119. procedure apply(l)
  120. local fn, arglist, arg, value, fcn
  121.    fn := l[1]
  122.    if member(trace_set, string(fn)) then {
  123.       write("Arguments of ",fn)
  124.       PRINT(l[2:0])
  125.       }
  126.    if value := case string(fn) of {
  127.       "CAR"     : CAR([l[2]]) | NIL
  128.       "CDR"     : CDR([l[2]]) | NIL
  129.       "CONS"    : CONS(l[2:0]) | NIL
  130.       "ATOM"    : ATOM([l[2]]) | NIL
  131.       "NULL"    : NULL([l[2]]) | NIL
  132.       "EQ"      : EQ([l[2],l[3]]) | NIL
  133.       "PRINT"   : PRINT([l[2]]) | NIL
  134.       "EVAL"    : EVAL([l[2]]) | NIL
  135.       "DEFINE"  : DEFINE(l[2]) | NIL
  136.       "TRACE"   : TRACE(l[2]) | NIL
  137.       "UNTRACE" : UNTRACE(l[2]) | NIL
  138.       } then {
  139.          if member(trace_set, string(fn)) then {
  140.             write("value of ",fn)
  141.             PRINT(value)
  142.             }
  143.          return value
  144.          }
  145.    fcn := (\words[fn]).f | return NIL
  146.    if type(fcn) == "list" then
  147.       if fcn[1] == "LAMBDA" then {
  148.          value :=  lambda(l[2:0],fcn[2],fcn[3])
  149.          if member(trace_set, string(fn)) then {
  150.             write("value of ",fn)
  151.             PRINT(value)
  152.             }
  153.          return value
  154.          }
  155.       else
  156.          return EVAL([fn])
  157.    return NIL
  158. end
  159.  
  160. ## evlis(l) - evaluate everything in a list
  161. #
  162. procedure evlis(l)
  163. local arglist, arg
  164.    arglist := []
  165.    every arg := !l do
  166.       put(arglist,EVAL([arg])) | fail
  167.    return arglist
  168. end
  169.  
  170.  
  171. ### Initializations
  172.  
  173. ## initialize() - set up global values
  174. #
  175. procedure initialize()
  176.    words := table()
  177.    trace_set := set()
  178.    T     := "T"
  179.    NIL   := []
  180. end
  181.  
  182. ### Primitive Functions
  183.  
  184. ## (CAR l)
  185. #
  186. procedure CAR(l)
  187.    return glist(l[1])[1] | NIL
  188. end
  189.  
  190. ## (CDR l)
  191. #
  192. procedure CDR(l)
  193.    return glist(l[1])[2:0] | NIL
  194. end
  195.  
  196. ## (CONS l)
  197. #
  198. procedure CONS(l)
  199.    return ([l[1]]|||glist(l[2])) | NIL
  200. end
  201.  
  202. ## (SET a l)
  203. #
  204. procedure SET(l)
  205.    (T === ATOM([l[1]])& l[2]) | return NIL
  206.    /words[l[1]] := prop()
  207.    if type(l[2]) == "prop" then
  208.       return .(words[l[1]].v := l[2].v)
  209.    else
  210.       return .(words[l[1]].v := l[2])
  211. end
  212.  
  213. ## (ATOM a)
  214. #
  215. procedure ATOM(l)
  216.    if type(l[1]) == "list" then
  217.       return (*l[1] = 0 & T) | NIL
  218.    return T
  219. end
  220.  
  221. ## (NULL l)
  222. #
  223. procedure NULL(l)
  224.    return EQ([NIL,l[1]])
  225. end
  226.  
  227. ## (EQ a1 a2)
  228. #
  229. procedure EQ(l)
  230.    if type(l[1]) == type(l[2]) == "list" then
  231.       return (0 = *l[1] = *l[2] & T) | NIL
  232.    return (l[1] === l[2] & T) | NIL
  233. end
  234.  
  235. ## (PRINT l)
  236. #
  237. procedure PRINT(l)
  238.    if type(l[1]) == "prop" then
  239.       return PRINT([l[1].v])
  240.    return write(strip(ltos(l)))
  241. end
  242.  
  243. ## COND(l) - support routine to eval
  244. #                 (for COND)
  245. procedure COND(l)
  246. local pair
  247.    every pair := !l do {
  248.       if type(pair) ~== "list" |
  249.               *pair ~= 2 then {
  250.          write(&errout,"COND: ill-formed pair list")
  251.          return NIL
  252.          }
  253.       if T === EVAL([pair[1]]) then
  254.          return EVAL([pair[2]])
  255.       }
  256.    return NIL
  257. end
  258.  
  259. ## (TRACE l)
  260. #
  261. procedure TRACE(l)
  262.    local fn
  263.  
  264.    every fn := !l do {
  265.       insert(trace_set, fn)
  266.       }
  267.    return NIL
  268. end
  269.  
  270. ## (UNTRACE l)
  271. #
  272. procedure UNTRACE(l)
  273.    local fn
  274.  
  275.    every fn := !l do {
  276.       delete(trace_set, fn)
  277.       }
  278.    return NIL
  279. end
  280.  
  281. ## glist(l) - verify that l is a list
  282. #
  283. procedure glist(l)
  284.    if type(l) == "list" then return l
  285. end
  286.  
  287. ## (DEFINE fname definition)
  288. #
  289. # This has been considerable rewritten (and made more difficult to use!)
  290. #  in order to match EV-LISP syntax.
  291. procedure DEFINE(l)
  292.    local fn_def, fn_list
  293.  
  294.    fn_list := []
  295.    every fn_def := !l do {
  296.       put(fn_list, define_fn(fn_def))
  297.       }
  298.  
  299.    return fn_list
  300. end
  301.  
  302. ## Define a single function (called by 'DEFINE')
  303. #
  304. procedure define_fn(fn_def)
  305.    /words[fn_def[1]] := prop(NIL)
  306.    words[fn_def[1]].f := fn_def[2]
  307.    return fn_def[1]
  308. end
  309.  
  310. ## lambda(actuals,formals,def)
  311. #
  312. procedure lambda(actuals, formals, def)
  313. local save, act, form, pair, result, arg, i
  314.    save := table()
  315.    every arg := !formals do
  316.       save[arg] := \words[arg] | prop(NIL)
  317.    i := 0
  318.    every words[!formals] := (prop(actuals[i+:=1]|NIL)\1)
  319.    result := EVAL([def])
  320.    every pair := !sort(save) do
  321.       words[pair[1]] := pair[2]
  322.    return result
  323. end
  324.  
  325. #  Date: June 10, 1988
  326. #
  327. procedure getbs()
  328. static tmp
  329.    initial tmp := ("" ~== |Map(read(infile))) || " "
  330.  
  331.    repeat {
  332.       while not checkbal(tmp) do {
  333.          if more(')','(',tmp) then break
  334.          tmp ||:= (("" ~== |Map(read(infile))) || " ") | break
  335.          }
  336.       suspend balstr(tmp)
  337.       tmp := (("" ~== |Map(read(infile))) || " ") | fail
  338.       }
  339. end
  340.  
  341. ## checkbal(s) - quick check to see if s is
  342. #       balanced w.r.t. parentheses
  343. #
  344. procedure checkbal(s)
  345.    return (s ? 1(tab(bal()),pos(-1)))
  346. end
  347.  
  348. ## more(c1,c2,s) - succeeds if any prefix of
  349. #       s has more characters in c1 than
  350. #       characters in c2, fails otherwise
  351. #
  352. procedure more(c1,c2,s)
  353. local cnt
  354.    cnt := 0
  355.    s ? while (cnt <= 0) & not pos(0) do {
  356.          (any(c1) & cnt +:= 1) |
  357.          (any(c2) & cnt -:= 1)
  358.          move(1)
  359.          }
  360.    return cnt >= 0
  361. end
  362.  
  363. ## balstr(s) - generate the balanced disjoint substrings
  364. #               in s, with blanks or tabs separating words
  365. #
  366. #       errors:
  367. #          fails when next substring cannot be balanced
  368. #
  369. #
  370. procedure balstr(s)
  371. static blanks
  372.    initial blanks := ' \t'
  373.    (s||" ") ? repeat {
  374.           tab(many(blanks))
  375.           if pos(0) then break
  376.           suspend (tab(bal(blanks))\1 |
  377.                   {write(&errout,"ill-formed expression")
  378.                     fail}
  379.                   ) \ 1
  380.           }
  381. end
  382.  
  383. ## bstol(s) - convert a balanced string into equivalent
  384. #       list representation.
  385. #
  386. procedure bstol(s)
  387. static blanks
  388. local l
  389.    initial blanks := ' \t'
  390.    (s||" ") ? {tab(many(blanks))
  391.                l := if not ="(" then s else []
  392.               }
  393.    if not string(l) then
  394.       every put(l,bstol(balstr(strip(s))))
  395.    return l
  396. end
  397.  
  398. ## ltos(l) - convert a list back into a string
  399. #
  400. #
  401. procedure ltos(l)
  402.    local tmp
  403.  
  404.    if type(l) ~== "list" then return l
  405.    if *l = 0 then return "NIL"
  406.    tmp := "("
  407.    every tmp ||:= ltos(!l) || " "
  408.    tmp[-1] := ")"
  409.    return tmp
  410. end
  411.  
  412. procedure strip(s)
  413.    s ?:= 2(="(", tab(bal()), =")", pos(0))
  414.    return s
  415. end
  416.  
  417. procedure Map(s)
  418.    return map(s, &lcase, &ucase)
  419. end
  420.