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