############################################################################
#
#	File:     lisp.icn
#
#	Subject:  Program to interpret LISP programs
#
#	Author:   Stephen B. Wampler
#
#	Contributors:  Phillip Lee Thomas, Clinton L. Jeffery
#
#	Date:     April 16, 2012
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#     This program is a simple interpreter for pure Lisp. It takes the
#  name of the Lisp program as a command-line argument.
#
#     The syntax and semantics are based on EV-LISP, as described in
#  Laurent Siklossy's "Let's Talk LISP" (Prentice-Hall, 1976, ISBN
#  0-13-532762-8).  Functions that have been predefined match those
#  described in Chapters 1-4 of the book.
#
#     No attempt at improving efficiency has been made, this is
#  rather an example of how a simple LISP interpreter might be
#  implemented in Icon.
#
#     The language implemented is case-insensitive.
#
#     It only reads enough input lines at one time to produce at least
#  one LISP-expression, but continues to read input until a valid
#  LISP-expression is found.
#
#     It first reads in files listed on command line, switches
#  to reading standard input, and terminates with the first (exit)
#  instruction.
#
#  Errors:
#
#     Fails with error message if current input cannot be made into
#  a valid LISP-expression (i.e. more right than left parens).
#
#  See HELP function at end of file for syntax summary/examples.
#
############################################################################

global words,     # table of variable atoms
       T, NIL,    # universal constants
       infile     # command line library files

global trace_set  # set of currently traced functions

record prop(v,f)  # abbreviated propery list

### main interpretive loop
#
procedure main(f) 
local sexpr, source
   initialize()
   if f[1] == ("-C" | "/C") then pop(f)  # run-command-then-terminate mode
   else if not (!f=="-") then put(f, "-")   # append "-" by default
   while source := pop(f) do {
      if not (infile := (if source == "-" then &input else open(source))) then
	 stop("wtLisp can't open ", image(source))
      if source ~== "-" then write("Reading: ", image(source))
      writes("> ")
      every sexpr := bstol(getbs()) do  {
	 PRINT([EVAL([sexpr])])
	 writes("> ")
	 }
      }
end

## (EVAL e) - the actual LISP interpreter
#
procedure EVAL(l)
local fn, arglist, arg
   l := l[1]
   if T === ATOM([l]) then {                 # it's an atom
      if T === l then return .T
      if EQ([NIL,l]) === T then return .NIL
      return .((\words[l]).v | NIL)
      }
   if glist(l) then {                        # it's a list
      if T === ATOM([l[1]]) then
         case l[1] of {
         "QUOTE" : return .(l[2] | NIL)
         "COND"  : return COND(l[2:0])
         "SETQ"  : return SET([l[2]]|||evlis(l[3:0]))
         "ITRACEON"  : return (&trace := -1,T)
         "ITRACEOFF" : return (&trace := 0,NIL)
         "HELP"      : return (HELP(),NIL)
         "EXIT"      : exit(0)
         default : return apply([l[1]]|||evlis(l[2:0])) | NIL
         }
      return apply([EVAL([l[1]])]|||evlis(l[2:0])) | NIL
      }
   return .NIL
end

## apply(fn,args) - evaluate the function

procedure apply(l)
local fn, arglist, arg, value, fcn
   fn := l[1]
   if member(trace_set, string(fn)) then {
      write("Arguments of ",fn)
      PRINT(l[2:0])
      }
   if value := case string(fn) of {
      "CAR"     : CAR([l[2]]) | NIL
      "CDR"     : CDR([l[2]]) | NIL
      "CONS"    : CONS(l[2:0]) | NIL
      "ATOM"    : ATOM([l[2]]) | NIL
      "NULL"    : NULL([l[2]]) | NIL
      "EQ"      : EQ([l[2],l[3]]) | NIL
      "PRINT"   : PRINT([l[2]]) | NIL
      "EVAL"    : EVAL([l[2]]) | NIL
      "DEFINE"  : DEFINE(l[2]) | NIL
      "TRACE"   : TRACE(l[2]) | NIL
      "UNTRACE" : UNTRACE(l[2]) | NIL
      } then {
         if member(trace_set, string(fn)) then {
            write("value of ",fn)
            PRINT(value)
            }
         return value
         }
   fcn := (\words[fn]).f | return NIL
   if type(fcn) == "list" then
      if fcn[1] == "LAMBDA" then {
         value :=  lambda(l[2:0],fcn[2],fcn[3])
         if member(trace_set, string(fn)) then {
            write("value of ",fn)
            PRINT(value)
            }
         return value
         }
      else
         return EVAL([fn])
   return NIL
end

## evlis(l) - evaluate everything in a list
#
procedure evlis(l)
local arglist, arg
   arglist := []
   every arg := !l do
      put(arglist,EVAL([arg])) | fail
   return arglist
end


### Initializations

## initialize() - set up global values
#
procedure initialize()
   words := table()
   trace_set := set()
   T     := "T"
   NIL   := []
end

### Primitive Functions

## (CAR l)
#
procedure CAR(l)
   return glist(l[1])[1] | NIL
end

## (CDR l)
#
procedure CDR(l)
   return glist(l[1])[2:0] | NIL
end

## (CONS l)
#
procedure CONS(l)
   return ([l[1]]|||glist(l[2])) | NIL
end

## (SET a l)
#
procedure SET(l)
   (T === ATOM([l[1]])& l[2]) | return NIL
   /words[l[1]] := prop()
   if type(l[2]) == "prop" then
      return .(words[l[1]].v := l[2].v)
   else
      return .(words[l[1]].v := l[2])
end

## (ATOM a)
#
procedure ATOM(l)
   if type(l[1]) == "list" then
      return (*l[1] = 0 & T) | NIL
   return T
end

## (NULL l)
#
procedure NULL(l)
   return EQ([NIL,l[1]])
end

## (EQ a1 a2)
#
procedure EQ(l)
   if type(l[1]) == type(l[2]) == "list" then
      return (0 = *l[1] = *l[2] & T) | NIL
   return (l[1] === l[2] & T) | NIL
end

## (PRINT l)
#
procedure PRINT(l)
   if type(l[1]) == "prop" then
      return PRINT([l[1].v])
   return write(strip(ltos(l)))
end

## COND(l) - support routine to eval
#                 (for COND)
procedure COND(l)
local pair
   every pair := !l do {
      if type(pair) ~== "list" |
              *pair ~= 2 then {
         write(&errout,"COND: ill-formed pair list")
         return NIL
         }
      if T === EVAL([pair[1]]) then
         return EVAL([pair[2]])
      }
   return NIL
end

## (TRACE l)
#
procedure TRACE(l)
   local fn

   every fn := !l do {
      insert(trace_set, fn)
      }
   return NIL
end

## (UNTRACE l)
#
procedure UNTRACE(l)
   local fn

   every fn := !l do {
      delete(trace_set, fn)
      }
   return NIL
end

## glist(l) - verify that l is a list
#
procedure glist(l)
   if type(l) == "list" then return l
end

## (DEFINE fname definition)
#
# This has been considerable rewritten (and made more difficult to use!)
#  in order to match EV-LISP syntax.
procedure DEFINE(l)
   local fn_def, fn_list

   fn_list := []
   every fn_def := !l do {
      put(fn_list, define_fn(fn_def))
      }

   return fn_list
end

## Define a single function (called by 'DEFINE')
#
procedure define_fn(fn_def)
   /words[fn_def[1]] := prop(NIL)
   words[fn_def[1]].f := fn_def[2]
   return fn_def[1]
end

## lambda(actuals,formals,def)
#
procedure lambda(actuals, formals, def)
local save, act, form, pair, result, arg, i
   save := table()
   every arg := !formals do
      save[arg] := \words[arg] | prop(NIL)
   i := 0
   every words[!formals] := (prop(actuals[i+:=1]|NIL)\1)
   result := EVAL([def])
   every pair := !sort(save) do
      words[pair[1]] := pair[2]
   return result
end

#  Date: June 10, 1988
#
procedure getbs()
static tmp
   initial tmp := ("" ~== |Map(read(infile))) || " "

   repeat {
      while not checkbal(tmp) do {
         if more(')','(',tmp) then break
         tmp ||:= (("" ~== |Map(read(infile))) || " ") | break
         }
      suspend balstr(tmp)
      tmp := (("" ~== |Map(read(infile))) || " ") | fail
      }
end

## checkbal(s) - quick check to see if s is
#       balanced w.r.t. parentheses
#
procedure checkbal(s)
   return (s ? 1(tab(bal()),pos(-1)))
end

## more(c1,c2,s) - succeeds if any prefix of
#       s has more characters in c1 than
#       characters in c2, fails otherwise
#
procedure more(c1,c2,s)
local cnt
   cnt := 0
   s ? while (cnt <= 0) & not pos(0) do {
         (any(c1) & cnt +:= 1) |
         (any(c2) & cnt -:= 1)
         move(1)
         }
   return cnt >= 0
end

## balstr(s) - generate the balanced disjoint substrings
#               in s, with blanks or tabs separating words
#
#       errors:
#          fails when next substring cannot be balanced
#
#
procedure balstr(s)
static blanks
   initial blanks := ' \t'
   (s||" ") ? repeat {
          tab(many(blanks))
          if pos(0) then break
          suspend (tab(bal(blanks))\1 |
                  {write(&errout,"ill-formed expression")
                    fail}
                  ) \ 1
          }
end

## bstol(s) - convert a balanced string into equivalent
#       list representation.
#
procedure bstol(s)
static blanks
local l
   initial blanks := ' \t'
   (s||" ") ? {tab(many(blanks))
               l := if not ="(" then s else []
              }
   if not string(l) then
      every put(l,bstol(balstr(strip(s))))
   return l
end

## ltos(l) - convert a list back into a string
#
#
procedure ltos(l)
   local tmp

   if type(l) ~== "list" then return l
   if *l = 0 then return "NIL"
   tmp := "("
   every tmp ||:= ltos(!l) || " "
   tmp[-1] := ")"
   return tmp
end

procedure strip(s)
   s ?:= 2(="(", tab(bal()), =")", pos(0))
   return s
end

procedure Map(s)
   return map(s, &lcase, &ucase)
end

procedure HELP()
   write("\n",
	 "Syntax:\n",
	 "  (quote (a b c))           ==> (A B C)\n",
	 "  (setq a (quote (a b c)))  ==> (A B C)\n",
	 "  (setq b (quote (x y z)))  ==> (X Y Z)\n",
	 "  (car a)                   ==> A\n",
	 "  (cdr a)                   ==> (B C)\n",
	 "  (cons (quote d) a)        ==> (D A B C)\n",
	 "  (eq (car a) (car a))      ==> T\n",
	 "  (atom (quote ()))         ==> T\n",
	 "  (atom a)                  ==> NIL\n",
	 "  (null (car (car a)))      ==> T\n",
	 "  (eval (quote a))          ==> (A B C)\n",
	 "  (print a)                 ==> (A B C)\n",
	 "                                (A B C)\n",
	 "Define functions cadr and cddr:\n",
	 "  (define (quote (\n",
	 "          (cadr (lambda (l) (car (cdr l))))\n",
	 "          (cddr (lambda (l) (cdr (cdr l))))\n",
	 "          )))               ==> (CADR CDDR)\n",
	 "  (cadr a)                  ==> B\n",
	 "  (cddr a)                  ==> (C)\n",
	 "  (trace (quote (cadr)))    ==> NIL\n",
	 "  (cadr a)                  ==> B\n",
	 "  (untrace (quote (cadr)))  ==> NIL\n",
	 "\n",
	 "Is an atom in a list? Uses cond and recursion:\n",
	 "  (define (quote (\n",
	 "    (has (lambda (atm lis)\n",
	 "      (cond ((null lis) nil)\n",
	 "        ((eq atm (car lis)) t)\n",
	 "        (t (has atm (cdr lis))))\n",
	 "  )) )))                    ==> (HAS)\n",
	 "  (has (quote y) b)         ==> T\n",
	 "\n",
	 "  (itraceon)                ==> T [turn on icon tracing]\n",
	 "  (itraceoff)               ==> NIL [turn off icon tracing]\n",
	 "  (help)                    ==> NIL [print help message]\n",
	 "  (exit)                    ==> [exit gracefully from icon]"
	 )
   return
end