OS/2 Shareware BBS: 10 Tools/10-Tools.zip/sa104os2.zip/SATHR104.ZIP/SATHER/CONTRIB/LISP/LISP.SA

Text File | 1994-10-25 | 26KB | 920 lines

-- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
-- the file "Doc/License" of the Sather distribution.  The license is also   --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
--------> Please email comments to "[e-mail]". <----------

----------------------------------------------------------------------
-- Lisp.sa: Implementation of a primitive Lisp interpreter. The only
-- purpose of this program is to serve as a non-trivial but still com-
-- prehensible Sather 1.0 program. Although the interpreter allows
-- to execute pretty sophisticated programs, it is fairly restricted
-- and especially doesn't allow to define higher order functions
-- (due to the very simple implementation of lambda). The basic
-- Lisp data structures are mapped to corresponding Sather types
-- and classes. To understand the implementation, basic knowledge
-- of Lisp is required. A very brief documentation can be found in
-- Lisp.Docu.ps.
--
-- Author: Robert Griesemer ([e-mail])
-- Created: 17 Aug 1994
----------------------------------------------------------------------

type $LIST is
-- Base type for all Lisp objects. Everything is a $LIST.
--
   eval: $LIST; -- every object can evaluate itself
   str: STR; -- every object can print itself

-- The following methods raise a STR exception if the
-- object is not of the expected type. Otherwise the
-- object (self) is returned. These routines greatly
-- simplify the implementation of predefined functions
-- and unify error handling.
--
   pair: PAIR;
   lpair: PAIR;
   number: NUMBER;
   string: STRING;
   symbol: SYMBOL;
   function: $FUNCTION;
   is_nil: BOOL -- nil predicate
end;


class LIST < $LIST is
-- Basic implementation for Lisp objects.
--
   eval: $LIST is raise 0 end; -- must be overriden in derived classes
   str: STR is raise 1 end; -- must be overriden in derived classes

   pair: PAIR is raise str + " is not a pair" end;
   lpair: PAIR is raise str + " is not a pair" end;
   number: NUMBER is raise str + " is not a number" end;
   string: STRING is raise str + " is not a string" end;
   symbol: SYMBOL is raise str + " is not a symbol" end;
   function: $FUNCTION is raise str + " is not a function" end;
   is_nil: BOOL is return false end
end;


class NIL < $LIST is
-- A unique Lisp object is used to represent the empty list.
-- The advantage of not using void instead is that
-- method access is always possible (e.g. all the methods
-- defined for $LISTs can be called without explicit
-- void tests).
--
   include LIST;
   private shared nil: NIL; -- only instance

   create: NIL is
      if void(nil) then nil := new end;
      return nil
   end;

   eval: $LIST is return nil end;
   str: STR is return "()" end;
   is_nil: BOOL is return true end
end;


type $FUNCTION < $LIST is
-- Base type for all predefined function objects.
-- The argument x of apply is the tail of the function
-- list expression, e.g., if f is a symbol refering to a
-- predefined function [f], and (f a b c) is evaluated,
-- [f].apply is called with argument (a b c).
--
   apply (x: $LIST): $LIST
end;


class FUNCTION < $FUNCTION is
-- Basic implementation for predefined function objects.
--
   include LIST;
   private attr sym: SYMBOL; -- associated symbol

   apply (x: $LIST): $LIST is raise 2 end; -- must be overriden in derived classes
   create (name: STR) is p ::= new; p.sym := #SYMBOL(name); p.sym.bound := p end;
   eval: $LIST is return self end; -- functions evaluate to themselves

   str: STR is
      if void(sym) or ~SYS::ob_eq(sym.bound, self) then sym := SYMBOL::find(self) end;
      if void(sym) then return "[" + SYS::id(self) + ']'
      else return "[" + sym.str + ']'
      end
   end;

   function: $FUNCTION is return self end
end;


class TRACER < $FUNCTION is
   include FUNCTION;
   readonly shared on: BOOL;
   private shared level: INT;

   reset is level := 0 end;

   apply (x: $LIST): $LIST is
      if ~x.is_nil then on := SYS::ob_eq(x.lpair.car.symbol, #SYMBOL("on")) end;
      if on then return #SYMBOL("on")
      else return #SYMBOL("off")
      end
   end;

   private indent is
      i: INT := level;
      loop while!(i > 0); i := i-1; #OUT + "   " end
   end;

   trace (f: $FUNCTION, x: $LIST): $LIST is
      indent; #OUT + f.str + " called with " + x.str + '\n';
      level := level+1; x := f.apply(x); level := level-1;
      indent; #OUT + f.str + " returns " + x.str + '\n';
      return x
   end
end;


class FRAME is
-- Stack frame for evaluation of user-defined functions.
-- Every frame contains an array with arguments.
--
   include ARRAY {$LIST}; -- arguments
   readonly shared top: FRAME; -- top of stack
   private attr prev: FRAME; -- previous stack frame
   readonly attr this: USERDEF; -- corresponding function

   create (nofArgs: INT, this: USERDEF): FRAME is
      f ::= new(nofArgs); f.prev := void; f.this := this; return f
   end;

   reset is top := void end;
   enter is prev := top; top := self end;
   exit is top := prev end
end;


class LOCAL < $LIST is
-- Objects referring to local variable (no) on topmost stack frame.
--
   include LIST;
   readonly attr no: INT;

   create (n: INT): LOCAL is r ::= new; r.no := n; return r end;
   eval: $LIST is return FRAME::top[no] end;
   str: STR is return "#" + no end
end;


class USERDEF < $FUNCTION is
-- User defined functions contain a list of expressions (fun), to be
-- evaluated when the function is called. Within these expressions,
-- local variables are accessed via LOCAL objects.
--
   include FUNCTION;
   private attr nofArgs: INT; -- no. of arguments
   private attr argExt: INT; -- either 0 or 1
   private attr fun: $LIST; -- list of expressions

   create (nofArgs, argExt: INT, fun: $LIST): USERDEF is
      r ::= new; r.sym := void; r.nofArgs := nofArgs; r.argExt := argExt; r.fun := fun;
      return r
   end;

   apply (x: $LIST): $LIST is
   -- create new stack frame
      f ::= #FRAME(nofArgs + argExt, self); i ::= 0;
   -- evaluate and pass arguments
      loop while!(i < nofArgs); p ::= x.pair; f[i] := p.car.eval; x := p.cdr; i := i+1 end;
   -- pass extension, if any (no evaluation)
      if argExt > 0 then f[i] := x; x := LISP::nil end;
   -- call function and evaluate function expressions
      h: $LIST := LISP::nil;
      if x.is_nil then
         f.enter; x := fun;
         loop until!(x.is_nil); p ::= x.pair; x := p.cdr; h := p.car.eval end;
         f.exit
      else raise "number of args and params does not match"
      end;
      return h
   end;

   str: STR is
      if void(sym) or ~SYS::ob_eq(sym.bound, self) then sym := SYMBOL::find(self) end;
      if void(sym) then return "[" + fun.str + ']'
      else return "[" + sym.str + ']'
      end
   end
end;


class LAMBDA < $FUNCTION is
-- "Compiler" for user defined functions: Lambda expressions
-- are translated into USERDEF objects. Symbols representing
-- local variables are substituted by LOCAL objects (subst).
--
   include FUNCTION;

   subst (x: $LIST, pars: FLIST {SYMBOL}): $LIST is
      r ::= x;
      typecase x
      when PAIR then
         r := #PAIR(subst(x.car, pars), subst(x.cdr, pars))
      when SYMBOL then i ::= 0;
         loop while!((i < pars.size) and ~SYS::ob_eq(x, pars[i])); i := i+1 end;
         if i < pars.size then r := #LOCAL(i) end
      else end;
      return r
   end;

   apply (x: $LIST): $LIST is
      pars: FLIST {SYMBOL} := void; argExt ::= 0;
      p ::= x.pair; q ::= p.car; x := p.cdr;
      loop
         typecase q
         when PAIR then pars := pars.push(q.car.symbol); p := q
         when NIL then break!
         else pars := pars.push(q.symbol); argExt := 1; break!
         end;
         q := p.cdr
      end;
      return #USERDEF(pars.size - argExt, argExt, subst(x, pars))
   end
end;


class CAR < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return x.lpair.car.eval.pair.car end
end;


class CDR < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return x.lpair.car.eval.pair.cdr end
end;


class CONS < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is p ::= x.pair; return #PAIR(p.car.eval, p.cdr.lpair.car.eval) end
end;


class QUOTE < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return x.lpair.car end
end;


class ADD < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; t ::= p.car.eval.number.val;
      loop p := x.pair; x := p.cdr; t := t + p.car.eval.number.val; until!(x.is_nil) end;
      return #NUMBER(t)
   end
end;


class SUB < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; t ::= p.car.eval.number.val;
      loop p := x.pair; x := p.cdr; t := t - p.car.eval.number.val; until!(x.is_nil) end;
      return #NUMBER(t)
   end
end;


class MUL < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; t ::= p.car.eval.number.val;
      loop p := x.pair; x := p.cdr; t := t * p.car.eval.number.val; until!(x.is_nil) end;
      return #NUMBER(t)
   end
end;


class DIV < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; t ::= p.car.eval.number.val;
      loop p := x.pair; x := p.cdr; t := t / p.car.eval.number.val; until!(x.is_nil) end;
      return #NUMBER(t)
   end
end;


class MOD < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; t ::= p.car.eval.number.val;
      loop p := x.pair; x := p.cdr; t := t % p.car.eval.number.val; until!(x.is_nil) end;
      return #NUMBER(t)
   end
end;


class POW < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; t ::= p.car.eval.number.val;
      loop p := x.pair; x := p.cdr; t := t ^ p.car.eval.number.val.floor.int; until!(x.is_nil) end;
      return #NUMBER(t)
   end
end;


class EQL < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; h ::= p.car.eval;
      typecase h
      when NUMBER then n ::= h.val;
         loop p := x.pair; x := p.cdr; m ::= p.car.eval.number.val;
            if n /= m then return LISP::nil end;
            n := m; until!(x.is_nil)
         end
      when STRING then s ::= h.s;
         loop p := x.pair; x := p.cdr; t ::= p.car.eval.string.s;
            if s /= t then return LISP::nil end;
            s := t; until!(x.is_nil)
         end
      else raise h.str + " is not a number or string"
      end;
      return LISP::t
   end
end;


class NEQ < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; h ::= p.car.eval;
      typecase h
      when NUMBER then n ::= h.val;
         loop p := x.pair; x := p.cdr; m ::= p.car.eval.number.val;
            if n = m then return LISP::nil end;
            n := m; until!(x.is_nil)
         end
      when STRING then s ::= h.s;
         loop p := x.pair; x := p.cdr; t ::= p.car.eval.string.s;
            if s = t then return LISP::nil end;
            s := t; until!(x.is_nil)
         end
      else raise h.str + " is not a number or string"
      end;
      return LISP::t
   end
end;


class LSS < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; h ::= p.car.eval;
      typecase h
      when NUMBER then n ::= h.val;
         loop p := x.pair; x := p.cdr; m ::= p.car.eval.number.val;
            if n >= m then return LISP::nil end;
            n := m; until!(x.is_nil)
         end
      when STRING then s ::= h.s;
         loop p := x.pair; x := p.cdr; t ::= p.car.eval.string.s;
            if s >= t then return LISP::nil end;
            s := t; until!(x.is_nil)
         end
      else raise h.str + " is not a number or string"
      end;
      return LISP::t
   end
end;


class LEQ < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; h ::= p.car.eval;
      typecase h
      when NUMBER then n ::= h.val;
         loop p := x.pair; x := p.cdr; m ::= p.car.eval.number.val;
            if n > m then return LISP::nil end;
            n := m; until!(x.is_nil)
         end
      when STRING then s ::= h.s;
         loop p := x.pair; x := p.cdr; t ::= p.car.eval.string.s;
            if s > t then return LISP::nil end;
            s := t; until!(x.is_nil)
         end
      else raise h.str + " is not a number or string"
      end;
      return LISP::t
   end
end;


class GTR < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; h ::= p.car.eval;
      typecase h
      when NUMBER then n ::= h.val;
         loop p := x.pair; x := p.cdr; m ::= p.car.eval.number.val;
            if n <= m then return LISP::nil end;
            n := m; until!(x.is_nil)
         end
      when STRING then s ::= h.s;
         loop p := x.pair; x := p.cdr; t ::= p.car.eval.string.s;
            if s <= t then return LISP::nil end;
            s := t; until!(x.is_nil)
         end
      else raise h.str + " is not a number or string"
      end;
      return LISP::t
   end
end;


class GEQ < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; x := p.cdr; h ::= p.car.eval;
      typecase h
      when NUMBER then n ::= h.val;
         loop p := x.pair; x := p.cdr; m ::= p.car.eval.number.val;
            if n < m then return LISP::nil end;
            n := m; until!(x.is_nil)
         end
      when STRING then s ::= h.s;
         loop p := x.pair; x := p.cdr; t ::= p.car.eval.string.s;
            if s < t then return LISP::nil end;
            s := t; until!(x.is_nil)
         end
      else raise h.str + " is not a number or string"
      end;
      return LISP::t
   end
end;


class FLOOR < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return #NUMBER(x.lpair.car.eval.number.val.floor) end
end;


class CEILING < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return #NUMBER(x.lpair.car.eval.number.val.ceiling) end
end;


class FACT < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return #NUMBER(x.lpair.car.eval.number.val.floor.factorial) end
end;


class EQ < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair;
      a ::= p.car.eval; b ::= p.cdr.lpair.car.eval;
      if SYS::ob_eq(a, b) then return LISP::t
      else return LISP::nil
      end
   end
end;


class COND < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      t: $LIST := LISP::nil;
      loop p ::= x.pair; x := p.cdr; y ::= p.car;
         if ~y.is_nil then p := y.pair; y := p.cdr; t := p.car.eval;
            if ~t.is_nil then x := LISP::nil;
               loop while!(~y.is_nil); p := y.pair; y := p.cdr; t := p.car.eval end
            end
         end;
         until!(x.is_nil)
      end;
      return t
   end
end;


class EVAL < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is return x.lpair.car.eval.eval end
end;


class ATOM < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is x := x.lpair.car.eval;
      typecase x when PAIR then return LISP::nil
      else return LISP::t
      end
   end
end;


class SET < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; d ::= p.car.eval; s ::= p.cdr.lpair.car.eval;
      typecase d
      when LOCAL then FRAME::top[d.no] := s
      when SYMBOL then d.bound := s
      else raise d.str + " is not a variable"
      end;
      return s
   end
end;


class SETQ < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      p ::= x.pair; d ::= p.car; s ::= p.cdr.lpair.car.eval;
      typecase d
      when LOCAL then FRAME::top[d.no] := s
      when SYMBOL then d.bound := s
      else raise d.str + " is not a variable"
      end;
      return s
   end
end;


class SYMBOLS < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is assert x.is_nil; return SYMBOL::list end
end;


class EXIT < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is assert x.is_nil; LISP::exit := true; return x end
end;


class WRITE < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is x := x.lpair.car.eval; #OUT + x.str; return x end
end;


class WRITELN < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is assert x.is_nil; #OUT + '\n'; return x end
end;


class READFILE < $FUNCTION is
   include FUNCTION;
   apply (x: $LIST): $LIST is
      name ::= x.lpair.car.eval.string.s;
      file ::= FILE::open_for_read(name);
      if ~void(file) and ~file.error then
         reader ::= #READER(file);
         protect
            loop
               h ::= reader.line; until!(void(h));
               x := h.eval
            end
         else file.close;
            #OUT + "in file: " + name + '\n';
            raise exception
         end
      end;
      return x
   end
end;


class PAIR < $LIST is
-- Base class used to form lists. Head and tail are called 'car' and
-- 'cdr' respectively for historical reasons (the first Lisp implementation
-- on a IBM 704 used two special registers called CAR = Contents of Address
-- Register and CDR = Contents of Displacement Register for this purpose).
-- Evaluating a pair means evaluating its head and applying the resulting
-- function to its tail.
--
   include LIST;
   attr car, cdr: $LIST;

   create (car, cdr: $LIST): PAIR is p ::= new; p.car := car; p.cdr := cdr; return p end;

   eval: $LIST is
      if TRACER::on then return TRACER::trace(car.eval.function, cdr)
      else return car.eval.function.apply(cdr)
      end
   end;

   str: STR is
      s ::= "(" + car.str; x ::= cdr;
      loop p: PAIR;
         typecase x when PAIR then p := x else break! end;
         s := s + ' ' + p.car.str; x := p.cdr
      end;
      if ~x.is_nil then s := s + " . " + x.str end;
      return s + ')'
   end;

   pair: PAIR is return self end;

   lpair: PAIR is
      if self.cdr.is_nil then return self
      else raise str + " contains more than one element"
      end
   end
end;


class NUMBER < $LIST is
-- Implementation of numbers.
--
   include LIST;
   readonly attr val: RAT;

   create (val: INTI): NUMBER is r ::= new; r.val := #RAT(val); return r end;
   create (val: RAT): NUMBER is r ::= new; r.val := val; return r end;
   eval: $LIST is return self end;
   str: STR is return val.str end;
   number: NUMBER is return self end
end;


class STRING < $LIST is
-- Implementation of strings.
--
   include LIST;
   readonly attr s: STR;

   create (s: STR): STRING is r ::= new; r.s := s; return r end;
   eval: $LIST is return self end;
   str: STR is return "\"" + s + '"' end;
   string: STRING is return self end
end;


class SYMBOL < $LIST is
-- Implementation of symbols. All known symbols are inserted
-- into a binary tree (root).
--
   include LIST;
   attr bound: $LIST; -- assigned value
   private attr name: STR; -- symbol name
   private shared root: SYMBOL;
   private attr left, right: SYMBOL;

   private traverse (x: $LIST, s: SYMBOL): $LIST is
      if ~void(s) then x := traverse(#PAIR(s, traverse(x, s.right)), s.left) end;
      return x
   end;

   list: $LIST is return traverse(LISP::nil, root) end;

   private search (q: SYMBOL, x: $LIST): SYMBOL is
      r ::= q;
      if ~void(q) then
         if ~SYS::ob_eq(q.bound, x) then
            r := search(q.left, x);
            if void(r) then r := search(q.right, x) end
         end
      end;
      return r
   end;

   find (x: $LIST): SYMBOL is return search(root, x) end;

   create (name: STR): SYMBOL is
      p: SYMBOL := void; q ::= root;
      loop while!(~void(q)); p := q;
         if name < q.name then q := q.left
         elsif q.name < name then q := q.right
         else return q
         end
      end;
      q := new; q.name := name; q.bound := LISP::nil;
      if void(p) then root := q
      elsif name < p.name then p.left := q
      else p.right := q
      end;
      return q
   end;

   eval: $LIST is return bound end;
   str: STR is return name end;
   symbol: SYMBOL is return self end
end;


class READER is
-- Scanner and parser for Lisp expressions. Strategy:
-- Conventional recursive descent parser (expr), one
-- character lookahead (ch).
--
   private attr file: FILE; -- read file
   private attr buf: FSTR; -- reader workspace
   private attr ch: CHAR; -- one character look ahead
   private attr lev: INT; -- list nesting level
   private const eof: CHAR := '\0';
   private const eol: CHAR := '\12';

   create (file: FILE): READER is
   -- file must be ready to read from
      r ::= new; r.file := file; r.buf := #FSTR(32); r.ch := ' '; r.lev := 0;
      return r
   end;

   private next is
      ch := file.get_char;
      if file.eof then ch := eof
      elsif ch = eof then ch := ' '
      end
   end;

   private comment is
      assert ch = '{'; next; n ::= 1;
      loop
         while!((ch /= eof) and (n > 0));
         if ch = '{' then n := n+1
         elsif ch = '}' then n := n-1
         end;
         next
      end
   end;

   private skip is
      loop
         if ch = '{' then comment
         elsif (ch > ' ') or (ch = eof) or ((ch = eol) and (lev = 0)) then break!
         else next
         end
      end
   end;

   private is_special (ch: CHAR): BOOL is
      case ch when '!', '#', '$', '%', '&', '*', '+', '-', '/', ':', '<', '=', '>', '?', '@', '\\', '^', '|', '~' then return true
      else return false
      end
   end;

   private enter is lev := lev+1 end;
   private exit is lev := lev-1 end;

   private error (loc: STR) is
      ch0 ::= ch;
      loop while!((ch /= eol) and (ch /= eof)); next end;
      raise "illegal character '" + ch0 + "' found in " + loc
   end;

   private int: INTI is
      assert ch.is_digit; buf.clear;
      loop buf := buf + ch; next; while!(ch.is_digit) end;
      return #INTI(buf)
   end;

   private number (neg: BOOL): $LIST is
      assert ch.is_digit;
      u ::= int; v ::= #INTI(1);
      if ch = '/' then next;
         if ch.is_digit then v := int
         else error("rational number")
         end
      end;
      skip;
      if neg then u := -u end;
      return #NUMBER(#RAT(u, v))
   end;

   private operator (sign: BOOL): $LIST is
      buf.clear;
      if sign then buf := buf + '-' end;
      loop while!(is_special(ch)); buf := buf + ch; next end;
      skip; return #SYMBOL(buf.str)
   end;

   private expr: $LIST is
      x: $LIST; p, q: PAIR;
      if ch = '\'' then next; skip; x := #PAIR(#SYMBOL("quote"), #PAIR(expr, LISP::nil))
      elsif ch = '(' then enter; next; skip;
         if ch = ')' then exit; next; skip; x := LISP::nil
         else p := #PAIR(expr, LISP::nil); x := p;
            loop while!((ch /= '.') and (ch /= ')'));
               q := #PAIR(expr, LISP::nil); p.cdr := q; p := q
            end;
            if ch = '.' then next; skip; p.cdr := expr end;
            if ch = ')' then exit; next; skip
            else error("list")
            end
         end
      elsif ch.is_alpha then -- symbol
         buf.clear;
         loop buf := buf + ch; next; while!(ch.is_alpha or ch.is_digit) end;
         skip; x := #SYMBOL(buf.str)
      elsif ch = '-' then -- operator or number
         next;
         if ch.is_digit then x := number(true)
         else x := operator(true)
         end
      elsif is_special(ch) then x := operator(false)
      elsif ch.is_digit then x := number(false)
      elsif ch = '"' then -- string
         next; buf.clear;
         loop while!((ch >= ' ') and (ch /= '"')); buf := buf + ch; next end;
         if ch = '"' then next; skip; x := #STRING(buf.str)
         else error("string")
         end
      else error("expression")
      end;
      return x
   end;

   line: $LIST is
      lev := 1; skip; -- ignore eol's
      if ch = eof then return void
      else lev := 0; return expr
      end
   end
end;


class LISP is
-- Main class. Contains initialization of symbol table (init),
-- the read-eval-write loop, and exception handling.
--
   readonly shared nil: $LIST; -- unique value for nil
   readonly shared t: SYMBOL; -- unique truth value
   shared exit: BOOL;

   init is
      nil := #NIL;
      t := #SYMBOL("t"); t.bound := t;
   -- predefined functions
      TRACER::create("tracer");
      CAR::create("car");
      CDR::create("cdr");
      CONS::create("cons");
      QUOTE::create("quote");
      ADD::create("+");
      SUB::create("-");
      MUL::create("*");
      DIV::create("/");
      MOD::create("%");
      POW::create("^");
      EQL::create("=");
      NEQ::create("#");
      LSS::create("<");
      LEQ::create("<=");
      GTR::create(">");
      GEQ::create(">=");
      FLOOR::create("floor");
      CEILING::create("ceiling");
      FACT::create("!");
      EQ::create("eq");
      COND::create("cond");
      EVAL::create("eval");
      ATOM::create("atom");
      SET::create("set");
      SETQ::create("setq");
      SYMBOLS::create("symbols");
      EXIT::create("exit");
      LAMBDA::create("lambda");
      WRITE::create("write");
      WRITELN::create("writeLn");
      READFILE::create("readFile")
   end;

   main is
      #OUT + "Sather Lisp - gri 17 Aug 94\n";
      #OUT + "(symbols) returns a list of all defined symbols\n";
      LISP::init;
      reader ::= #READER(FILE::stdin); exit := false;
      loop
         protect
            TRACER::reset; FRAME::reset;
            #OUT + "> "; OUT::flush; x ::= reader.line;
            if ~void(x) then #OUT + x.eval.str + '\n'
            else exit := true
            end
         when STR then #OUT + "error";
            if ~void(FRAME::top) then #OUT + " in " + FRAME::top.this.str end;
            #OUT + ": " + exception + '\n'
         end;
         until!(exit)
      end
   end

end