-
+ 97B22557F90FE3BB7B5889A5976AFEE0788CC7063F955194BB78287D7C4A6924F99A400271A0DB241DA7D19C4F210AF1AFDA511E533C4B9C20A956BE87C9F6DD
adalisp/src/evaler.adb

(0 . 0)(1 . 1014)
-- LispM evaluator implementation.

with Ada.Text_IO; use Ada.Text_IO; -- for error reporting

package body Evaler is
   
   -- An accumulator register for arithmetic/logic ops.
   ALU_Acc : Long_Integer := 0;
   
   -- Apply arithmetic and logic function, i.e. +, -, * or /
   procedure Apply_ALU_Func(Func : in ALUFunc;
                            Args : in MemPtr;
                            Env : in MemPtr; OutP : out MemPtr) is
      P, CarP : MemPtr;
   begin
      -- General form: (f e1 e2 ...) where f is one of +, -, * or
      --  /. Special cases:
      --
      -- - (+) --> 0
      -- - (- x) --> -x
      -- - (*) --> 1
      -- - (/ x) --> 1/x (always 0 for Fixnums)
      
      -- Initialize loop variables and perform argument count checks
      --  where needed.
      P := Args;
      case Func is
         when ALU_Add =>
            -- Identity element for +
            ALU_Acc := 0;
         when ALU_Sub =>
            -- - needs at least one argument
            pragma Assert(P /= 0, "- needs at least 1 argument");
            CarP := Get_Car(AMem(P));
            P := Get_Cdr(AMem(P));
            
            -- (- x) is arithmetic negation; (- x y ...) is equivalent
            --  to x - y - ...
            if (P = 0) then
               ALU_Acc := -Get_Fixnum(AMem(CarP));
            else
               ALU_Acc := Get_Fixnum(AMem(CarP));
            end if;
         when ALU_Mul =>
            -- Identity element for *
            ALU_Acc := 1;
         when ALU_Div =>
            -- / needs at least 1 argument
            pragma Assert(P /= 0, "/ needs at least 1 argument");
            CarP := Get_Car(AMem(P));
            P := Get_Cdr(AMem(P));
            
            -- (/ x) is 1 / x; (/ x y ...) is equivalent to x / y /
            --  ... ; we don't support floats, so 1 / x should always
            --  yield 0.
            if (P = 0) then
               ALU_Acc := 1 / Get_Fixnum(AMem(CarP));
            else
               ALU_Acc := Get_Fixnum(AMem(CarP));
            end if;
      end case;
      
      -- Loop through the arg list and accumulate.
      while P /= 0 loop
         -- Get car and accumulate it
         CarP := Get_Car(AMem(P));
         pragma Assert(AMem(CarP).T = Fixnum,
                       "Expected a number.");
         case Func is
            when ALU_Add =>
               ALU_Acc := ALU_Acc + Get_Fixnum(AMem(CarP));
            when ALU_Sub =>
               ALU_Acc := ALU_Acc - Get_Fixnum(AMem(CarP));
            when ALU_Mul =>
               ALU_Acc := ALU_Acc * Get_Fixnum(AMem(CarP));
            when ALU_Div =>
               pragma Assert(Get_Fixnum(AMem(CarP)) /= 0,
                             "Division by zero!");
               ALU_Acc := ALU_Acc / Get_Fixnum(AMem(CarP));
         end case;
         
         -- Continue
         P := Get_Cdr(AMem(P));
      end loop;
      -- Store value in a new cell and return it.
      Alloc_Fixnum(ALU_Acc, OutP);
   end Apply_ALU_Func;
   
   -- Apply unary predicate.
   procedure Apply_UPred(Pred : in UPred;
                         Args : in MemPtr;
                         Env : in MemPtr;
                         OutP : out MemPtr) is
      P : MemPtr := Args;
      ArgP : MemPtr;
   begin
      -- General form: (pred val) where pred is one of pair?, boolean?,
      --  number?, symbol?, null? or list?. Read below for
      --  particularities.
      
      -- Argument sanity checking
      pragma Assert(P /= 0, "Function requires 1 argument.");
      ArgP := Get_Car(AMem(P));
      P := Get_Cdr(AMem(P));
      pragma Assert(P = 0, "Function requires 1 argument.");
      
      -- What predicate op are we applying?
      case Pred is
         when UPred_Pair =>
            -- (pair? '()) --> #f
            -- (pair? anything-else) --> anything-else is a cons
            if ArgP = 0 then
               Alloc_Bool(False, OutP);
            else
               Alloc_Bool(AMem(ArgP).T = Cons, OutP);
            end if;
         when UPred_Bool =>
            -- (boolean? '()) --> #f
            -- (boolean? anything-else) --> anything-else is #t or #f
            if ArgP = 0 then
               Alloc_Bool(False, OutP);
            else
               Alloc_Bool(AMem(ArgP).T = Bool, OutP);
            end if;
         when UPred_Num =>
            -- (number? '()) --> #f
            -- (number? anything-else) --> anything-else is a fixnum
            if ArgP = 0 then
               Alloc_Bool(False, OutP);
            else
               Alloc_Bool(AMem(ArgP).T = Fixnum, OutP);
            end if;
         when UPred_Sym =>
            -- (symbol? '()) --> #f
            -- (symbol? 'anything-else) --> anything else is a symbol
            if ArgP = 0 then
               Alloc_Bool(False, OutP);
            else
               Alloc_Bool(AMem(ArgP).T = Symbol, OutP);
            end if;
         when UPred_Nil =>
            -- (null? '()) --> #t
            -- (null? anything-else) --> #f
            Alloc_Bool(ArgP = 0, OutP);
         when UPred_List =>
            -- (list? x) --> x is a proper-list, i.e. NIL or a form
            --  (cons e1 .. (cons en NIL))
            
            -- try walking through a list until NIL
            loop
               exit when ArgP = 0;
               exit when AMem(ArgP).T /= Cons;
               ArgP := Get_Cdr(AMem(ArgP));
            end loop;
            -- if a non-NIL is encountered anywhere in a cdr (or in the
            --  main object), then not a list.
            Alloc_Bool(ArgP = 0, OutP);
      end case;
   end Apply_UPred;
   
   -- Apply and/or special form.
   procedure Apply_AndOr(Cond : in AndOr;
                         Args : in MemPtr;
                         Env : in MemPtr;
                         OutP : out MemPtr) is
      P, ArgP : MemPtr;
      ReachedEnd : Boolean := False;      
   begin
      -- General form: (cond e1 e2 ...) where cond is one of and or
      --  or. Particularities:
      --
      -- - and evaluates until the end or the first #f encountered
      -- - or evaluates until the end or the first non-#f encountered
      --
      -- More details below.
      
      P := Args;
      if P = 0 then
         -- vacuous truth/falsity:
         -- (and) --> #t
         -- (or) --> #f
         ReachedEnd := True;
         Alloc_Bool(Cond = AndOr_And, ArgP);
      end if;
      loop
         -- have we reached the end?
         if P = 0 then
            ReachedEnd := True;
            exit;
         end if;         
         -- eval lazily:
         -- - and stops at the first argument evaluated to #f
         -- - or stops at the first argument evaluated to #t
         ArgP := Get_Car(AMem(P));
         Eval(ArgP, Env, ArgP);
         
         exit when Cond = AndOr_And and Boolean_Value(ArgP) = False;
         exit when Cond = AndOr_Or and Boolean_Value(ArgP) = True;
         
         -- continue
         P := Get_Cdr(AMem(P));
      end loop;
      
      -- Returned value:
      -- (and e1 e2 ...) returns #f or the last element
      -- (or e1 e2 ...) returns #f or the first non-#f element
      case Cond is
         when AndOr_And =>
            if ReachedEnd then
               OutP := ArgP;
            else
               Alloc_Bool(False, OutP);
            end if;
         when AndOr_Or =>
            if ReachedEnd then
               Alloc_Bool(False, OutP);
            else
               OutP := ArgP;
            end if;
      end case;
   end Apply_AndOr;
   
   -- Apply quote.
   procedure Apply_QuoteB(Args : in MemPtr; OutP : out MemPtr) is
   begin
      -- General form:
      --
      -- (quote '()) --> ()
      -- (quote expr) --> expr
      
      OutP := (if Args = 0 then 0 else Get_Car(AMem(Args)));
   end Apply_QuoteB;
   
   -- Apply eval.
   procedure Apply_EvalB(Args, Env : in MemPtr; OutP : out MemPtr) is
      Arg : MemPtr;
   begin
      -- General form: (eval expr env), where expr is any S-expression
      --  and env is an optional environment (currently unimplemented).
      
      -- XXX: Need to do eval environments.
      pragma Assert(Args /= 0, "Eval needs at least 1 argument.");
      Arg := Get_Car(AMem(Args));
      -- Just call eval on arg
      Eval(Arg, Env, OutP);
   end Apply_EvalB;
   
   -- Apply if.
   procedure Apply_IfB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      PredP : MemPtr;
      PredVal : Boolean;
   begin
      -- General form: (if pred a b) where pred, a and b are optional
      --  S-expressions. The evaluation rules are:
      --
      -- - (if) --> ()
      -- - (if pred) --> pred is evaluated and () is returned
      -- - (if pred a) --> pred is evaluated
      --   . if pred evals to #t, then a is evaluated and returned
      --   . otherwise, () is returned
      -- - (if pred a b) --> pred is evaluated
      --   . if pred evals to #t, then a is evaluated and returned
      --   . otherwise, b is evaluated and returned
      
      -- no args: (if) --> ()
      if P = 0 then
         OutP := 0;
         return;
      end if;
      
      -- get predicate, evaluate it and determine its boolean value
      --  (implicitly true for non-booleans)
      PredP := Get_Car(AMem(P));
      Eval(PredP, Env, PredP);
      PredVal := Boolean_Value(PredP);
      
      -- look for branches: P points to () or (a) or (a b)
      P := Get_Cdr(AMem(P));
      
      -- select branch: if pred evaluated to #f and the user specified
      --  (at least) the #t branch, then we cdr to the #f branch;
      --  otherwise, if no branches are specified, we return.
      if not PredVal and P /= 0 then
         P := Get_Cdr(AMem(P));
      elsif P = 0 then
         OutP := 0;
         return;
      end if;
      -- evaluate taken branch
      P := Get_Car(AMem(P));
      Eval(P, Env, OutP);
   end Apply_IfB;
   
   -- Apply cons.
   procedure Apply_ConsB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      CarP, CdrP : MemPtr;
   begin
      -- General form: (cons a b) where a and b are S-expressions.
      
      pragma Assert(P /= 0, "Cons needs exactly 2 arguments.");
      -- get car
      CarP := Get_Car(AMem(P));
      -- get cdr
      P := Get_Cdr(AMem(P));
      pragma Assert(P /= 0, "Cons needs exactly 2 arguments.");
      CdrP := Get_Car(AMem(P));
      
      -- Rest of P needs to be nil now.
      P := Get_Cdr(AMem(P));
      pragma Assert(P = 0, "Cons needs exactly 2 arguments.");
      
      -- Cons the two
      Alloc_Cons(CarP, CdrP, OutP);
   end Apply_ConsB;
   
   -- Apply car.
   procedure Apply_CarB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      ConsP : MemPtr;
   begin
      -- General form: (car x) where x is a cons.
      
      pragma Assert(P /= 0, "car needs exactly 1 argument.");
      -- Get x
      ConsP := Get_Car(AMem(P));
      pragma Assert (AMem(ConsP).T = Cons, "Expected pair.");
      OutP := Get_Car(AMem(ConsP));
      
      -- Rest of P needs to be nil
      P := Get_Cdr(AMem(P));
      pragma Assert (P = 0, "car needs exactly 1 argument.");
   end Apply_CarB;
   
   -- Apply cdr.
   procedure Apply_CdrB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      ConsP : MemPtr;
   begin
      -- General form: (cdr x) where x is a cons.
      
      pragma Assert(P /= 0, "cdr needs exactly 1 argument.");
      -- Get x
      ConsP := Get_Car(AMem(P));
      pragma Assert (AMem(ConsP).T = Cons, "Expected pair.");
      OutP := Get_Cdr(AMem(ConsP));
      
      -- Rest of P needs to be nil
      P := Get_Cdr(AMem(P));
      pragma Assert (P = 0, "cdr needs exactly 1 argument.");
   end Apply_CdrB;
   
   -- Apply list.
   procedure Apply_ListB(Args, Env : in MemPtr; OutP : out MemPtr) is
   begin
      -- General form: (list e1 e2 ...) where e1 e2 ... are optional
      --  S-expressions.
      
      -- Applicative order evaluation is done by Apply_Func, so we just
      --  propagate the arguments.
      OutP := Args;
   end Apply_ListB;
   
   -- Apply apply.
   procedure Apply_ApplyB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      OpP, ArgsP, LastArgP : MemPtr;
   begin
      -- General form: (apply f a1 a2 ... args) where f is a function,
      --  a1 a2 ... are S-expressions and args is a list.
      --
      --  The result is the same as applying f with (append (list a1 a2
      --  ...) args) as arguments.
      
      pragma Assert(P /= 0, "apply needs at least 1 argument.");
      
      -- get op
      OpP := Get_Car(AMem(P));
      
      -- get args: this section is roughly equivalent to list* (or
      --  cons*), i.e. (list* a1 a2 a3 ... args) --> (a1 a2 a3
      --  ... . args), i.e. we stick args in the butt of (a1 a2 a3 ...).
      P := Get_Cdr(AMem(P));
      -- first, we check if we have any args at all
      if P = 0 then goto DoApply; end if;
      -- if so, we do a shallow (reversed) copy of the list, accumulated
      --  in ArgsP; we put the car (the "args" above) in LastArgP and we
      --  keep the cdr in ArgsP.
      ArgsP := 0;
      while P /= 0 loop
         exit when AMem(P).T /= Cons;
         Alloc_Cons(Get_Car(AMem(P)), ArgsP, ArgsP);
         P := Get_Cdr(AMem(P));
      end loop;
      -- ArgsP has at least one element now!
      LastArgP := Get_Car(AMem(ArgsP));
      ArgsP := Get_Cdr(AMem(ArgsP));
      -- now put this in the proper form
      Rev_In_Place(ArgsP, LastArgP, P);
            
  <<DoApply>>
      -- Do the actual application
      Apply_Func(OpP, P, Env, True, OutP);
   end Apply_ApplyB;
   
   -- Apply define.
   procedure Apply_DefineB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      SymP, ValP : MemPtr;
   begin
      -- General form: (define sym val) where sym is a symbol and val is
      --  an optional S-expression.
      --
      -- XXX we need to split this into two types of defines:
      --  symbol-defines (such as the one described here) and
      --  lambda-defines, e.g. (define (func arg1 ...) val).
      
      -- get sym
      SymP := Get_Car(AMem(P));
      pragma Assert (SymP /= 0, "Define: expected symbol for arg 1!");
      pragma Assert (AMem(SymP).T = Symbol,
                     "Define: expected symbol for arg 1!");
      
      -- get val: (define sym) binds sym to NIL.
      P := Get_Cdr(AMem(P));
      ValP := (if P = 0 then 0 else Get_Car(AMem(P)));
      
      -- evaluate val
      Eval(ValP, Env, ValP);
      -- make (top-level!) binding
      Bind_Env(SymP, ValP, Global_Env, P);
      -- return symbol name
      OutP := Get_Car(AMem(P));
   end Apply_DefineB;

   -- Apply set.
   procedure Apply_SetB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      SymP, ValP : MemPtr;
      BindingP : MemPtr;
   begin
      -- General form: (set! sym val) where sym is a bound symbol and
      --  val is an optional S-expression. set! returns the evaluated
      --  val.
      
      pragma Assert(P /= 0, "set! requires at least 1 argument.");
      -- get sym
      SymP := Get_Car(AMem(P));
      -- and look it up in the scoped Envs
      Lookup_Env_Or_Global(SymP, Env, BindingP);
      -- binding must exist
      pragma Assert(BindingP /= 0, "set! got an unbound variable.");
      
      -- get value
      P := Get_Cdr(AMem(P));
      ValP := (if P = 0 then 0 else Get_Car(AMem(P)));
      -- eval it
      Eval(ValP, Env, ValP);
      -- and modify the binding
      Set_Cdr(AMem(BindingP), ValP);
      -- return the value
      OutP := ValP;
   end Apply_SetB;
   
   -- Apply numeric equality.
   procedure Apply_EqnB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      Fst, Other : MemPtr;
      Result : MemPtr;
   begin
      -- General form: (= n1 n2 ...) where n1, n2, ... are numbers. =
      --  expects at least two numbers as parameters.
      
      pragma Assert(P /= 0, "= requires at least 2 arguments");
      -- get first number
      Fst := Get_Car(AMem(P));
      pragma Assert(AMem(Fst).T = Fixnum, "Expected numeric arguments.");
      -- move on to rest
      P := Get_Cdr(AMem(P));
      pragma Assert(P /= 0, "= requires at least 2 arguments");
      
      -- allocate result: assume all numbers are equal until found
      --  otherwise.
      Alloc_Bool(True, Result);
      -- loop through the other numbers
      while P /= 0 loop
         -- get other
         Other := Get_Car(AMem(P));
         pragma Assert(AMem(Other).T = Fixnum, "Expected numeric arguments.");
         -- check equality: we assume two's complement representation
         if AMem(Fst).Data /= AMem(Other).Data then
            Set_Bool(AMem(Result), False);
         end if;
         -- move on to next element of the arg list
         P := Get_Cdr(AMem(P));
      end loop;
      -- store result
      OutP := Result;
   end Apply_EqnB;
   
   -- Apply pointer equality.
   procedure Apply_EqB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      P1, P2 : MemPtr;
   begin
      -- General form: (eq? x y) where x and y are S-expressions.
      
      -- get x
      pragma Assert(P /= 0, "eq? requires 2 arguments.");
      P1 := Get_Car(AMem(P));      
      P := Get_Cdr(AMem(P));
      
      -- get y
      pragma Assert(P /= 0, "eq? requires 2 arguments.");
      P2 := Get_Car(AMem(P));
      P := Get_Cdr(AMem(P));
      pragma Assert(P = 0, "eq? requires 2 arguments.");
      
      -- compare x and y. XXX this is a hack, but eq? guarantees that
      --  matching boolean values match, e.g. (eq? #f #f) --> #t. As an
      --  alternative, we could reserve two special cells for #f and #t,
      --  or give up the schemism altogether and use nil and everything
      --  else as booleans.
      --
      -- (eq? '() '()) --> #t
      -- (eq? 1 1) --> may be #f if the two instances of 1 have
      --  different memory locations.
      if P1 /= 0 and P2 /= 0 then
         if AMem(P1).T = Bool and AMem(P2).T = Bool then
            Alloc_Bool(AMem(P1).Data = AMem(P2).Data, OutP);
         else
            Alloc_Bool(P1 = P2, OutP);
         end if;
      else
         Alloc_Bool(P1 = P2, OutP);
      end if;
   end Apply_EqB;
   
   -- Apply value-wise equality.
   procedure Apply_EqvB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      Val1, Val2 : MemPtr;
      Result : Boolean;
   begin
      -- General form: (eqv? x y) where x and y are
      --  S-expressions. Unlike eq?, eqv? compares the data found in the
      --  cells pointed to by x and y, with the exception of NIL
      --  pointers, which are compared pointer-wise.
      
      -- get x
      pragma Assert(P /= 0, "eqv? requires 2 arguments.");
      Val1 := Get_Car(AMem(P));
      P := Get_Cdr(AMem(P));
      
      -- get y
      pragma Assert(P /= 0, "eqv? requires 2 arguments.");
      Val2 := Get_Car(AMem(P));
      P := Get_Cdr(AMem(P));
      pragma Assert(P = 0, "eqv? requires 2 arguments.");
      
      -- (eqv? '() y) --> (null? y)
      -- (eqv? x y) (where x is non-NIL) --> values are equal, e.g.
      -- - (eqv? 1 1) --> #t
      -- - (eqv? '(1) '(1)) --> #f (comparison between values of cons cells)
      if Val1 = 0 then
         Result := Val2 = 0;
      else
         Result := AMem(Val1).Data = AMem(Val2).Data;
      end if;
      -- set result
      Alloc_Bool(Result, OutP);
   end Apply_EqvB;
   
   -- Apply not.
   procedure Apply_NotB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      Val : MemPtr;
   begin
      -- General form: (not x) where x is a S-expression. not is
      --  evaluated using the following rules:
      -- - (not #f) --> #t
      -- - (not x) (x /= #f) --> #f
      
      -- get argument
      pragma Assert (P /= 0, "not requires 1 argument.");
      Val := Get_Car(AMem(P));
      P := Get_Cdr(AMem(P));
      pragma Assert (P = 0, "not requires 1 argument.");
      
      -- perform logic negation on boolean value.
      Alloc_Bool(not Boolean_Value(Val), OutP);
   end Apply_NotB;
   
   -- Apply lambda.
   procedure Apply_LambdaB(Args, Env : in MemPtr; OutP : out MemPtr) is
   begin
      -- General form: (lambda args e1 e2 ...) where args is a list of
      --  formal arguments (symbols) and e1 e2 ... are optional
      --  S-expressions that may contain references to the formal
      --  arguments; i.e., e1 e2 ... forms a lexical scope where the
      --  formal arguments are bound.
      --
      -- See Alloc_Closure for more details.
      Alloc_Closure(Args, Env, OutP);
   end Apply_LambdaB;
   
   -- Apply let.
   procedure Apply_LetB(Args, Env : in MemPtr; OutP : out MemPtr) is
      BndsP, CodeP : MemPtr;
      ArgsP, ValuesP, ClosureP : MemPtr;
   begin
      -- General form: (let bnds . code) where bnds is a list (bnd1 bnd2
      --  ...) and code is a list (e1 e2 ...). More precisely:
      --
      -- - bndi is a list of the form (si vi) where si is a symbol and
      --  vi is a mandatory S-expression.
      -- - ek is an optional S-expression that may contain references to
      --  si.
      --
      -- Lets do the following: 1. every vi is evaluated; 2. every
      --  evaluated vi is used as a lexical binding for the
      --  corresponding si; and 3. in the newly-created lexical scope,
      --  ek are evaluated in the order they appear in code.
      --
      -- More generally, any expression of the form:
      --
      -- (let ((s1 v1) (s2 v2) ... (sn vn)) e1 e2 ... em)
      --
      -- is equivalent to:
      --
      -- ((lambda (s1 s2 ... sn) e1 e2 ... em) v1 v2 ... vn).
      --
      -- Thus this implementation: 1. collects the formal arguments
      --  (names) in ArgsP and the effective arguments (values) in
      --  ValuesP; 2. collects the code in CodeP; 3. creates a closure
      --  ClosureP from the list (ArgsP . CodeP); 4. applies ClosureP on
      --  ValuesP.
      
      -- (let) --> ()
      if Args = 0 then
         -- nothing to do here
         OutP := 0;
         return;
      end if;
   
      -- get bindings and code; initialize arglist and valuelist
      BndsP := Get_Car(AMem(Args));
      CodeP := Get_Cdr(AMem(Args));
      ArgsP := 0; ValuesP := 0;
      
      -- collect formal args and effective values
      while BndsP /= 0 loop
         declare
            BndP : MemPtr := Get_Car(AMem(BndsP));
            SymP, ValP : MemPtr;
         begin
            pragma Assert(BndP /= 0, "Bad syntax of let spec.");
            pragma Assert(AMem(BndP).T = Cons, "Bad syntax of let spec.");
            
            -- get symbol and advance in BndP
            SymP := Get_Car(AMem(BndP));
            ValP := Get_Cdr(AMem(BndP));
            -- XXX: this is the stricter version
            pragma Assert (ValP /= 0, "Bad syntax of binding in let.");
            -- get val and evaluate it
            ValP := Get_Car(AMem(ValP));
            Eval(ValP, Env, ValP);
            -- add symbol to ArgsP, value to ValuesP
            Alloc_Cons(SymP, ArgsP, ArgsP);
            Alloc_Cons(ValP, ValuesP, ValuesP);
            -- continue
            BndsP := Get_Cdr(AMem(BndsP));
         end;
      end loop;
      
      -- cons args to code
      Alloc_Cons(ArgsP, CodeP, CodeP);
      -- make closure
      Apply_LambdaB(CodeP, Env, ClosureP);
      -- apply closure
      Apply_Closure(ClosureP, ValuesP, Env, OutP);
   end Apply_LetB;
   
   -- Apply reverse.
   procedure Apply_ReverseB(Args, Env : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := Args;
      List : MemPtr;
   begin
      -- General form: (reverse x) where x is a list.
      
      -- get x
      pragma Assert (P /= 0, "reverse requires 1 argument.");
      List := Get_Car(AMem(P));
      P := Get_Cdr(AMem(P));
      pragma Assert (P = 0, "reverse requires 1 argument.");
      
      -- reverse x
      Rev_Append(0, List, OutP);
   end Apply_ReverseB;
   
   -- Apply append.
   procedure Apply_AppendB(Args, Env : in MemPtr; OutP : out MemPtr) is
      Lists : MemPtr := Args;
      Acc : MemPtr := 0;
   begin
      -- General form: (append x1 x2 ...) where x1 x2 ... are lists. In
      --  particular, the last xi may be any object, in which case the
      --  result of append is not a proper list, e.g.
      --
      -- - (append '(x) '(y)) --> (x y)
      -- - (append '(x y) 'z) --> (x y . z)
      
      -- (append) --> ()
      if Lists = 0 then
         OutP := 0;
         return;
      end if;
      
      -- accumulate in acc; stop when Lists has one element, so that we
      --  don't lose the reference to the last element.
      while Get_Cdr(AMem(Lists)) /= 0 loop
         -- prepend in reverse to Acc
         Rev_Append(Acc, Get_Car(AMem(Lists)), Acc);
         -- continue
         Lists := Get_Cdr(AMem(Lists));
      end loop;
      
      -- reverse Acc in place, adding the last element in Lists to the
      --  tail.
      Rev_In_Place(Acc, Get_Car(AMem(Lists)), Acc);
      OutP := Acc;
   end Apply_AppendB;
   
   -- Apply closure.
   procedure Apply_Closure(Op, Args, Env : in MemPtr; OutP : out MemPtr) is
      EArgs : MemPtr := Args;
      CArgs, CCode, CEnv : MemPtr;
   begin
      -- General form: (f a1 a2 ... an) where:
      --
      -- - f is a closure object, comprising an environment env (a list
      --  of bindings) and a code; the code is itself made of a list of
      --  formal parameters and a code body;
      -- - a1, a2 ... an, are arguments, i.e. effective parameters, to
      --  f, such that n is equal to the length of the list of formal
      --  parameters.
      --
      -- The application of f on the arguments is performed by binding
      --  each formal parameter to each corresponding argument, adding
      --  them to env and evaluating each expression in the code body in
      --  the (lexical) context of env.
      
      -- Initialize CArgs, CCode, CEnv.
      CEnv := Get_Closure_Env(AMem(Op));
      CCode := Get_Closure_Code(AMem(Op));
      -- Do we have an arglist and code?
      if CCode = 0 then
         CArgs := 0;
      else
         CArgs := Get_Car(AMem(CCode));
         CCode := Get_Cdr(AMem(CCode));
      end if;
      
      -- ((lambda () ...) ...)
      if CArgs = 0 then goto DoEval; end if;
      
      -- CArgs can be a:
      -- - symbol, e.g. ((lambda x (cdr x)) 1 2) --> (2)
      -- - list, e.g. ((lambda (x y) (+ x y)) 1 2) --> 3
      if AMem(CArgs).T = Symbol then
         -- extend env with a binding to effective arglist
         Alloc_Cons(CArgs, EArgs, CArgs);
         Alloc_Cons(CArgs, CEnv, CEnv);
      elsif AMem(CArgs).T = Cons then
         -- for each argument in CArgs corresponding to an actual value
         --  in EArgs, add a binding in CEnv.
         while CArgs /= 0 loop
            declare
               ArgP, ValP, BindingP : MemPtr;
            begin
               -- assert: (= (length CArgs) (length EArgs))
               pragma Assert(EArgs /= 0,
                             "Not enough arguments.");
               -- (cons (car CArgs) (car EArgs))
               ArgP := Get_Car(AMem(CArgs));
               ValP := Get_Car(AMem(EArgs));
               -- add binding to env, ignore non-symbols
               if ArgP /= 0 then
                  if AMem(ArgP).T = Symbol then
                     Alloc_Cons(ArgP, ValP, BindingP);
                     Alloc_Cons(BindingP, CEnv, CEnv);
                  end if;
               end if;
               -- continue with next argument
               CArgs := Get_Cdr(AMem(CArgs));
               EArgs := Get_Cdr(AMem(EArgs));
            end;
         end loop;
      else
         pragma Assert(False, "Expected symbol or cons.");
      end if;
      
  <<DoEval>>
      -- eval all coads
      while CCode /= 0 loop
         declare
            E : MemPtr;
         begin
            -- get current coad
            E := Get_Car(AMem(CCode));
            -- eval it, put result in OutP
            Eval(E, CEnv, OutP);
            -- continue
            CCode := Get_Cdr(AMem(CCode));
         end;
      end loop;
   end Apply_Closure;

   -- Apply a function on argument list.
   procedure Apply_Func(Op, Args, Env : in MemPtr;
                        Meta : in Boolean;
                        OutP : out MemPtr) is
      
      -- XXX: This should actually delimit between built-in functions
      --  and keywords; other functions (e.g. apply) may need to use
      --  this to provide relevant errors.
      Applicative_OrderP : constant array(BuiltinID) of Boolean :=
        (QuoteB | IfB | DefineB | SetB | AndB | OrB | LambdaB |
           LetB => False,
         others => True);
      
      BID : BuiltinID;
      EvaledArgs : MemPtr;
   begin
      pragma Assert(Op /= 0, "NIL op!");
      
      -- Is Op a builtin?
      if AMem(Op).T = Builtin then
         BID := Get_Builtin(AMem(Op));
         
         -- We want to evaluate the arguments before applying the
         --  function if:
         --  . the function permits it, or
         --  . Apply_Func was not called by apply (who already evals)
         if Applicative_OrderP(BID) and (not Meta) then
            Eval_List(Args, Env, EvaledArgs);
         else
            EvaledArgs := Args;
         end if;
         -- What builtin Op do we evaluate?
         case BID is
            when AddB => Apply_ALU_Func(ALU_Add, EvaledArgs, Env, OutP);
            when SubB => Apply_ALU_Func(ALU_Sub, EvaledArgs, Env, OutP);
            when MulB => Apply_ALU_Func(ALU_Mul, EvaledArgs, Env, OutP);
            when DivB => Apply_ALU_Func(ALU_Div, EvaledArgs, Env, OutP);
            when QuoteB => Apply_QuoteB(EvaledArgs, OutP);
            when EvalB => Apply_EvalB(EvaledArgs, Env, OutP);
            when IfB => Apply_IfB(EvaledArgs, Env, OutP);
            when ConsB => Apply_ConsB(EvaledArgs, Env, OutP);
            when CarB => Apply_CarB(EvaledArgs, Env, OutP);
            when CdrB => Apply_CdrB(EvaledArgs, Env, OutP);
            when ListB => Apply_ListB(EvaledArgs, Env, OutP);
            when ApplyB => Apply_ApplyB(EvaledArgs, Env, OutP);
            when DefineB => Apply_DefineB(EvaledArgs, Env, OutP);
            when SetB => Apply_SetB(EvaledArgs, Env, OutP);
            when EqnB => Apply_EqnB(EvaledArgs, Env, OutP);
            when EqB => Apply_EqB(EvaledArgs, Env, OutP);
            when EqvB => Apply_EqvB(EvaledArgs, Env, OutP);
            when PairPB => Apply_UPred(UPred_Pair, EvaledArgs, Env, OutP);
            when BooleanPB => Apply_UPred(UPred_Bool, EvaledArgs, Env, OutP);
            when NumberPB => Apply_UPred(UPred_Num, EvaledArgs, Env, OutP);
            when SymbolPB => Apply_UPred(UPred_Sym, EvaledArgs, Env, OutP);
            when NullPB => Apply_UPred(UPred_Nil, EvaledArgs, Env, OutP);
            when ListPB => Apply_UPred(UPred_List, EvaledArgs, Env, OutP);
            when AndB => Apply_AndOr(AndOr_And, EvaledArgs, Env, OutP);
            when OrB => Apply_AndOr(AndOr_Or, EvaledArgs, Env, OutP);
            when NotB => Apply_NotB(EvaledArgs, Env, OutP);
            when LambdaB => Apply_LambdaB(Args, Env, OutP);
            when LetB => Apply_LetB(Args, Env, OutP);
            when ReverseB => Apply_ReverseB(EvaledArgs, Env, OutP);
            when AppendB => Apply_AppendB(EvaledArgs, Env, OutP);
         end case;
      elsif AMem(Op).T = Closure then
         -- We evaluate the argument list only if this is not a
         --  meta-application (e.g. called by apply).
         if not Meta then
            Eval_List(Args, Env, EvaledArgs);
         else
            EvaledArgs := Args;
         end if;
         -- Apply closure.
         Apply_Closure(Op, EvaledArgs, Env, OutP);
      else
         OutP := 0;
         pragma Assert(False, "Trying to apply a non-function.");
      end if;
   end Apply_Func;
   
   -- Evaluate a list element by element.
   procedure Eval_List(List, Env : in MemPtr; OutP : out MemPtr) is
      LP : MemPtr := List;
      Result : MemPtr := 0;
      Default : MemPtr := 0;
   begin
      -- eval elements one by one
      while LP /= 0 loop
         declare
            TempP : MemPtr;
         begin
            -- degenerate case: cdr is neither list nor nil
            exit when AMem(LP).T /= Cons;
            -- eval current element in LP
            Eval(Get_Car(AMem(LP)), Env, TempP);
            -- cons result to Result
            Alloc_Cons(TempP, Result, Result);
            -- advance in LP
            LP := Get_Cdr(AMem(LP));
         end;
      end loop;
      
      -- also eval in the degenerate case
      if LP /= 0 then
         if AMem(LP).T /= Cons then
            Eval(LP, Env, Default);
         end if;
      end if;

      -- result is the reverse-in-place of our computation
      Rev_In_Place(Result, Default, OutP);
   end Eval_List;

   -- Evaluate a given S-expression
   procedure Eval(InP, Env : in MemPtr; OutP : out MemPtr) is
      TempP, OpP, ArgsP : MemPtr;
   begin
      -- NIL.
      if (InP = 0) then
         OutP := 0;
         return;
      end if;
      
      -- Non-NIL data.
      case AMem(InP).T is
         when Free => -- this is illegal
            pragma Assert(False, "Trying to eval free cell!");
         when Cons =>
            -- Eval car to get Op
            TempP := Get_Car(AMem(InP));
            Eval(TempP, Env, OpP);
            -- Get arglist
            ArgsP := Get_Cdr(AMem(InP));
            -- Apply op on arglist
            Apply_Func(OpP, ArgsP, Env, False, OutP);
         when Bool | Fixnum | Char | Builtin | Closure  =>
            -- Constants are returned as they are.
            OutP := InP;
         when Symbol =>
            -- Lookup symbol value in Env.
            Lookup_Env_Or_Global(InP, Env, TempP);
            -- If found return it, otherwise report error.
            if TempP = 0 then
               Put("Not found: "); Dump_Cell(InP);
               pragma Assert(False, "No binding for symbol.");
            end if;
            OutP := Get_Cdr(AMem(TempP));
      end case;
   end Eval;
   
   -- Prepend the elements of B to A, in reverse.
   procedure Rev_Append(A, B : in MemPtr; OutP : out MemPtr) is
      Acc : MemPtr := A;
      P : MemPtr := B;
   begin
      while P /= 0 loop
         exit when AMem(P).T /= Cons;
         Alloc_Cons(Get_Car(AMem(P)), Acc, Acc);
         P := Get_Cdr(AMem(P));
      end loop;
      
      pragma Assert (P = 0, "Non-list argument to append");
      
      OutP := Acc;
   end Rev_Append;
   
   procedure Rev_In_Place(List, Default : in MemPtr; OutP : out MemPtr) is
      P : MemPtr := List;
      Result : MemPtr := Default;
      Temp : MemPtr;
   begin
      while P /= 0 loop
         Temp := Get_Cdr(AMem(P)); -- save cdr
         Set_Cdr(AMem(P), Result); -- put partial result in tail
         Result := P; -- update result
         P := Temp; -- get cdr
      end loop;
      
      OutP := Result;
   end Rev_In_Place;
   
   -- Return the actual boolean associated with a Lisp value.
   function Boolean_Value(P : MemPtr) return Boolean is
   begin
      -- Non-boolean values (including NIL) default to True. Boolean
      --  values get the value of Get_Bool;         
      if P = 0 then
         return True;
      elsif AMem(P).T = Bool then
         return Get_Bool(AMem(P));
      else
         return True;
      end if;
   end Boolean_Value;
end Evaler;