-
+ 74C1E88D5AF7EEC476C54F9C879514C63EE0BFF3B9354A36AB282DFC6CD010E0F8E9C89FF091732859CC18238F467EFBE35959BF9A4445A422012536E899403F
adalisp/README

(0 . 0)(1 . 33)
README

`adalisp` is an interpreter for a small Lisp-like scripting language
that aims to a. fit in head, while b. being written in a small,
restricted, safe subset of the `Ada` programming language. For more
details, see:

  http://thetarpit.org/posts/y04/074-adalisp-prototype.html

---
To INSTALL `adalisp`:

  * Install an `Ada` distribution; `adalisp` was tested on GNAT GPL
    2016.

  * Use `V` to press:

  mkdir ~/src/adalisp
  cd ~/src/adalisp

  mkdir .wot
  cd .wot && wget http://lucian.mogosanu.ro/spyked.asc && cd ..

  v.pl init http://lucian.mogosanu.ro/src/adalisp
  v.pl press adalisp_genesis adalisp_genesis.vpatch

---
To BUILD and USE `adalisp`:

  cd ~/src/adalisp/adalisp_genesis/adalisp
  gprbuild

  cat test.scm | ./bin/test_repl

-
+ 86525F2C7086039D79E5BF92869D02934A44716812433CA3A90E18A8D03745785C5CA54FE8C39E681B3B13C00C33A5128884A28C8CBACCBC65D0B401D901EC2E
adalisp/bin/README

(0 . 0)(1 . 1)
Placeholder.

-
+ 7C90ED5668838EEBB2F201AB981083B05AF9A9E39946B11914B7CD81E66CE5DD8B2B11246E6FDA73F9DFC96CA9645CEE9F6B7D5AE5791320330C3501DA302E7A
adalisp/manifest

(0 . 0)(1 . 1)
530176 adalisp_genesis spyked Lucian's first adalisp iteration

-
+ 86525F2C7086039D79E5BF92869D02934A44716812433CA3A90E18A8D03745785C5CA54FE8C39E681B3B13C00C33A5128884A28C8CBACCBC65D0B401D901EC2E
adalisp/obj/README

(0 . 0)(1 . 1)
Placeholder.

-
+ 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;

-
+ 546D8D1AC8F29F4CEF32DFDA953790663CE53016C8F63024BE2802CF0C60D0C9D899896ABEA4896DF637AD2FC11610F54CD7B1C89CA32E1195094416F41A5DC8
adalisp/src/evaler.ads

(0 . 0)(1 . 83)
-- Basic LispM evaluator, based on the following rules:
--
-- - LispM constants, i.e. booleans, numbers, characters, builtins and
--  closures are returned as they are.
--
-- - Symbols have their values looked up in the current (lexical) Env
--  or, if not found, in the (dynamic) Global_Env; the first value found
--  is returned; if no bindings are found, an error message is returned.
--
-- - Cons objects are interpreted as function applications, i.e. for any
--  list L, car(L) is evaluated and applied upon cdr(L); if car(L) is
--  not a closure or a builtin, then an error message is returned.
--
-- A large subset of this module is dedicated to the implementation of
--  builtin functions and keywords. An explicit distinction between
--  keywords and functions is not made at this point, i.e. the
--  distinction is implicit in e.g. the way arguments are evaluated.

with LispM; use LispM;

package Evaler is
   
   -- Arithmetic and logic functions
   type ALUFunc is (ALU_Add, ALU_Sub, ALU_Mul, ALU_Div);
   -- Unary predicates
   type UPred is (UPred_Pair, UPred_Bool, UPred_Num, UPred_Sym,
                  UPred_Nil, UPred_List);
   -- And/or conditional forms
   type AndOr is (AndOr_And, AndOr_Or);
   
   -- Application routines for builtin functions. These should be
   --  self-explanatory.
   procedure Apply_ALU_Func(Func : in ALUFunc;
                            Args : in MemPtr;
                            Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_UPred(Pred : in UPred;
                         Args : in MemPtr;
                         Env : in MemPtr;
                         OutP : out MemPtr);
   procedure Apply_AndOr(Cond : in AndOr;
                         Args : in MemPtr;
                         Env : in MemPtr;
                         OutP : out MemPtr);

   procedure Apply_QuoteB(Args : in MemPtr; OutP : out MemPtr);
   procedure Apply_EvalB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_IfB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_ConsB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_CarB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_CdrB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_ListB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_ApplyB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_DefineB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_SetB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_EqnB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_EqB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_EqvB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_NotB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_LambdaB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_LetB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_ReverseB(Args, Env : in MemPtr; OutP : out MemPtr);
   procedure Apply_AppendB(Args, Env : in MemPtr; OutP : out MemPtr);
   
   -- Application routine for closures
   procedure Apply_Closure(Op, Args, Env : in MemPtr; OutP : out MemPtr);
   
   -- Apply function with name identified by Op, on Args.
   procedure Apply_Func(Op, Args, Env : in MemPtr;
                        Meta : in Boolean;
                        OutP : out MemPtr);
   
   -- Evaluate a list element by element.
   procedure Eval_List(List, Env : in MemPtr; OutP : out MemPtr);
   
   -- Eval S-expression
   procedure Eval(InP, Env : in MemPtr; OutP : out MemPtr);
   
   -- Other usefuls: reverse append, reverse in place, boolean
   --  value. XXX: move these somewhere else.
   procedure Rev_Append(A, B : in MemPtr; OutP : out MemPtr);   
   procedure Rev_In_Place(List, Default : in MemPtr; OutP : out MemPtr);
   function Boolean_Value(P : MemPtr) return Boolean;
end Evaler;

-
+ CB79FB7B406A1D59AB393E1ADE0CCFB11DEEBEF1398F69E3BF73B675616339F018DF6EC769C54F2C922F4EE2DAC0C0FF60F571A9793BD0EBBC8AE1BE348C0FEB
adalisp/src/lispm.adb

(0 . 0)(1 . 696)
-- Lisp machine, procedures for memory manipulation (at least for the
--  time being).
with Ada.Text_IO;

package body LispM is
   
   -- The initial environment requires a set of symbols and their
   --  bindings to builtin functions/keywords. Thus we hold these into a
   --  statically-allocated table and we let the Lisp run-time copy them
   --  in AMem at the beginning of the world.
   
   -- Constant symbol name size: 10 characters should be enough for
   --  everyone.
   subtype BuiltinNameSize is Integer range 1..10;
   -- Symbol name-builtin association
   type BuiltinAssoc is record
      BiName : String(BuiltinNameSize);
      BiValue : BuiltinID;
   end record;
   -- Array of BuiltinAssoc objects
   type BuiltinAssocs is array (Natural range <>) of BuiltinAssoc;
   
   BuiltinTable : constant BuiltinAssocs :=
     (0  => (BiName => "+         ", BiValue => AddB),
      1  => (BiName => "-         ", BiValue => SubB),
      2  => (BiName => "*         ", BiValue => MulB),
      3  => (BiName => "/         ", BiValue => DivB),
      4  => (BiName => "quote     ", BiValue => QuoteB),
      5  => (BiName => "eval      ", BiValue => EvalB),
      6  => (BiName => "if        ", BiValue => IfB),
      7  => (BiName => "cons      ", BiValue => ConsB),
      8  => (BiName => "car       ", BiValue => CarB),
      9  => (BiName => "cdr       ", BiValue => CdrB),
      10 => (BiName => "list      ", BiValue => ListB),
      11 => (BiName => "apply     ", BiValue => ApplyB),
      12 => (BiName => "define    ", BiValue => DefineB),
      13 => (BiName => "set!      ", BiValue => SetB),
      14 => (BiName => "=         ", BiValue => EqnB),
      15 => (BiName => "eq?       ", BiValue => EqB),
      16 => (BiName => "eqv?      ", BiValue => EqvB),
      17 => (BiName => "pair?     ", BiValue => PairPB),
      18 => (BiName => "boolean?  ", BiValue => BooleanPB),
      19 => (BiName => "number?   ", BiValue => NumberPB),
      20 => (BiName => "symbol?   ", BiValue => SymbolPB),
      21 => (BiName => "null?     ", BiValue => NullPB),
      22 => (BiName => "list?     ", BiValue => ListPB),
      23 => (BiName => "and       ", BiValue => AndB),
      24 => (BiName => "or        ", BiValue => OrB),
      25 => (BiName => "not       ", BiValue => NotB),
      26 => (BiName => "lambda    ", BiValue => LambdaB),
      27 => (BiName => "let       ", BiValue => LetB),
      28 => (BiName => "reverse   ", BiValue => ReverseB),
      29 => (BiName => "append    ", BiValue => AppendB));
   
   -- Hack: used for maintaining a special "quote" symbol used by the
   --  parser.
   Quote_Name : constant String := "quote";
   
   -- Shifting functions for MWord, used for low-level arithmetic.
   function Shift_Left
     (Value  : MWord; 
      Amount : Natural)
     return    MWord;
   pragma Import(Intrinsic, Shift_Left);
   
   function Shift_Right
     (Value  : MWord; 
      Amount : Natural)
     return    MWord;
   pragma Import(Intrinsic, Shift_Right);
   
   -- Getters.
   
   -- Get the ID of a builtin cell
   function Get_Builtin(C : Cell) return BuiltinID is
   begin
      pragma Assert (C.T = Builtin, "Not a builtin cell!");
      -- Disclaimer: This list is hand-maintained, programmer must
      --  ensure that 'Get' and 'Set' sides match!
      return BuiltinTable(Integer(C.Data)).BiValue;
   end Get_Builtin;
   
   -- Get the car of a cons cell
   function Get_Car(C : Cell) return MemPtr is
   begin
      pragma Assert (C.T = Cons or C.T = Closure,
                     "Car: Not a cons cell!");
      return MemPtr(Shift_Right(C.Data, 32));
   end Get_Car;
   
   -- Get the cdr of a cons cell
   function Get_Cdr(C : Cell) return MemPtr is
   begin
      pragma Assert (C.T = Cons or C.T = Closure,
                     "Cdr: Not a cons cell!");
      return MemPtr(C.Data and 16#0000_0000_FFFF_FFFF#);
   end Get_Cdr;
   
   -- Get the value of a bool cell
   function Get_Bool(C : Cell) return Boolean is
   begin
      pragma Assert (C.T = Bool, "Not a bool cell!");
      pragma Assert (C.Data = 0 or C.Data = 1,
                     "Bool cell in undefined state!");
      if (C.Data = 0) then
         return False;
      else
         return True;
      end if;
   end Get_Bool;
   
   -- Get the value of a fixnum cell
   function Get_Fixnum(C : Cell) return Long_Integer is
      Temp : Long_Integer;
   begin
      pragma Assert (C.T = Fixnum, "Not a fixnum cell!");
      if (C.Data and 16#8000_0000_0000_0000#) /= 0 then
         Temp := -(Long_Integer(not C.Data) + 1);
      else
         Temp := Long_Integer(C.Data);
      end if;
      return Temp;
   end Get_Fixnum;
   
   -- Get the value of a char cell
   function Get_Char(C : Cell) return Character is
   begin
      pragma Assert (C.T = Char, "Not a char cell!");
      return Character'Val(C.Data);
   end Get_Char;

   -- Get the string (list-of-chars) associated with a symbol cell
   function Get_Symbol(C : Cell) return MemPtr is
   begin
      pragma Assert (C.T = Symbol, "Not a symbol cell!");
      return MemPtr(C.Data);
   end Get_Symbol;
   
   -- Get the code of a closure cell (in practice, the pair car)
   function Get_Closure_Code(C : Cell) return MemPtr is
   begin
      return Get_Car(C);
   end Get_Closure_Code;
   
   -- Get the env of a closure cell (in practice, the pair cdr)
   function Get_Closure_Env(C : Cell) return MemPtr is
   begin
      return Get_Cdr(C);
   end Get_Closure_Env;
   
   -- Setters.
   
   -- Set the value of a builtin cell.
   procedure Set_Builtin(C : in out Cell; B : in BuiltinID) is
      Index : Integer := -1;
   begin
      pragma Assert (C.T = Builtin, "Not a builtin cell!");
      -- Lookup builtin in table
      for I in 0..(BuiltinTable'Length - 1) loop
         if BuiltinTable(I).BiValue = B then
            Index := I;
            exit;
         end if;
      end loop;
      pragma Assert (Index /= -1, "Builtin not found.");
      
      C.Data := MWord(Index);
   end Set_Builtin;
   
   -- Set the car of a cons cell.
   procedure Set_Car(C : in out Cell; Car : in MemPtr) is
   begin
      pragma Assert (C.T = Cons or C.T = Closure,
                     "Not a cons cell!");
      C.Data := (C.Data and 16#0000_0000_FFFF_FFFF#)
        or Shift_Left(MWord(Car), 32);
   end Set_Car;
   
   -- Set the cdr of a cons cell.
   procedure Set_Cdr(C : in out Cell; Cdr : in MemPtr) is
   begin
      pragma Assert (C.T = Cons or C.T = Closure,
                     "Not a cons cell!");
      C.Data := (C.Data and 16#FFFF_FFFF_0000_0000#)
        or MWord(Cdr);
   end Set_Cdr;
   
   -- Set the value of a bool cell.
   procedure Set_Bool(C : in out Cell; Value : in Boolean) is
   begin
      pragma Assert (C.T = Bool, "Not a bool cell!");
      if Value then
         C.Data := 1;
      else
         C.Data := 0;
      end if;
   end Set_Bool;
   
   -- Set the value of a fixnum cell.
   procedure Set_Fixnum(C : in out Cell; Value : in Long_Integer) is
   begin
      pragma Assert (C.T = Fixnum, "Not a fixnum cell!");
      if Value < 0 then
         C.Data := not MWord(-Value) + 1;
      else
         C.Data := MWord(Value);
      end if;
   end Set_Fixnum;
   
   -- Set the value of a char cell.
   procedure Set_Char(C : in out Cell; Value : in Character) is
   begin
      pragma Assert (C.T = Char, "Not a char cell!");
      C.Data := MWord(Character'Pos(Value));
   end Set_Char;
   
   -- Set the name of a symbol cell.
   procedure Set_Symbol(C : in out Cell; Name : in MemPtr) is
      IsStr : Boolean := True;
      PList : MemPtr := Name;
      PCar : MemPtr;
   begin
      pragma Assert (C.T = Symbol, "Not a symbol cell!");
      
      -- Sanity check! At this point, a string is a list-of-chars, so we
      --  need to check that the type of list elements matches.
      pragma Assert (PList /= 0, "Symbol name is empty string!");
      while PList /= 0 loop
         pragma Assert (AMem(PList).T = Cons, "Not a string cons cell!");
         
         -- Get car cell and check its type
         PCar := Get_Car(AMem(PList));
         if (AMem(PCar).T /= Char) then
            IsStr := False;
            exit;
         end if;
         
         -- Get cdr cell
         PList := Get_Cdr(AMem(PList));
      end loop;
      pragma Assert(IsStr, "Symbol not a string!");
      
      C.Data := MWord(Name);
   end Set_Symbol;
   
   -- Set the closure code (car)
   procedure Set_Closure_Code(C : in out Cell; Code : in MemPtr) is
   begin
      Set_Car(C, Code);
   end Set_Closure_Code;
   
   -- Set the closure env (cdr)
   procedure Set_Closure_Env(C : in out Cell; Env : in MemPtr) is
   begin
      Set_Cdr(C, Env);
   end Set_Closure_Env;
   
   -- Allocate new cell in Lisp machine memory.
   procedure Alloc_Cell(C : in Cell; P : out MemPtr) is
   begin
      -- For now we just increase the heap and add the new cell.
      
      -- Increase heap size
      Heap_End := Heap_End + 1;
      -- Check that we're overwriting a free cell.
      pragma Assert (AMem(Heap_End).T = Free,
                     "Alloc_Cell using a non-free cell.");
      -- Assign given cell value
      AMem(Heap_End) := C;
      -- Set P to point to new pointer
      P := Heap_End;
   end Alloc_Cell;
   
   -- Allocate builtin cell.
   procedure Alloc_Builtin(B : BuiltinID; P : out MemPtr) is
   begin
      Alloc_Cell((T => Builtin, Data => 0), P);
      Set_Builtin(AMem(P), B);
   end Alloc_Builtin;
   
   -- Allocate a cons cell.
   procedure Alloc_Cons(Car, Cdr : in MemPtr; P : out MemPtr) is
   begin
      Alloc_Cell((T => Cons, Data => 0), P);
      Set_Car(AMem(P), Car);
      Set_Cdr(AMem(P), Cdr);
   end Alloc_Cons;
   
   -- Allocate a bool cell.
   procedure Alloc_Bool(Value : in Boolean; P : out MemPtr) is
   begin
      Alloc_Cell((T => Bool, Data => 0), P);
      Set_Bool(AMem(P), Value);
   end Alloc_Bool;

   -- Allocate a fixnum cell.
   procedure Alloc_Fixnum(Value : in Long_Integer; P : out MemPtr) is
   begin
      Alloc_Cell((T => Fixnum, Data => 0), P);
      Set_Fixnum(AMem(P), Value);
   end Alloc_Fixnum;
   
   -- Allocate a char cell.
   procedure Alloc_Char(Value : in Character; P : out MemPtr) is
   begin
      Alloc_Cell((T => Char, Data => 0), P);
      Set_Char(AMem(P), Value);
   end Alloc_Char;

   -- Allocate a symbol cell.
   procedure Alloc_Symbol(Name : in MemPtr; P : out MemPtr) is
   begin
      Alloc_Cell((T => Symbol, Data => 0), P);
      Set_Symbol(AMem(P), Name);
   end Alloc_Symbol;
   
   -- Allocate a closure cell.
   procedure Alloc_Closure(Code, Env : in MemPtr; P : out MemPtr) is
   begin
      Alloc_Cell((T => Closure, Data => 0), P);
      Set_Closure_Code(AMem(P), Code);
      Set_Closure_Env(AMem(P), Env);
   end Alloc_Closure;
   
   -- Dump cell from Lisp machine memory.
   procedure Dump_Cell(P : in MemPtr) is
      use Ada.Text_IO;

      C : Cell;
   begin
      -- Check for NIL.
      if (P = 0) then
         -- Scheme notation.
         Put("()");
         return;
      end if;

      -- Otherwise our cell lies in AMem. It's either a free cell or it
      --  has some allocated data in it.
      C := AMem(P);
      case C.T is
         when Free =>
            Put("<free cell>");
         when Builtin =>
            -- XXX check whether the builtin is a function or a keyword.
            Put("<builtin func ");
            Dump_BuiltinID(Get_Builtin(C));
            Put(">");
         when Cons =>
            Dump_Cons(P);
         when Bool =>
            if C.Data = 0 then
               Put("#f");
            else
               Put("#t");
            end if;
         when Fixnum =>
            Dump_Longint(Get_Fixnum(C));
         when Char =>
            Put("#\");
            if Get_Char(C) = ' ' then
               Put("space");
            else
               Put(Get_Char(C));
            end if;
         when Symbol =>
            Dump_String(Get_Symbol(C));
         when Closure =>
            Put("<closure>");
      end case;
   end Dump_Cell;
   
   -- Recursively dump a cons cell, doing sugary processing.
   procedure Dump_Cons(P : in MemPtr) is
      use Ada.Text_IO;
      
      C : Cell;
   begin
      -- Initialization and sanity checks
      pragma Assert (P /= 0, "List must be non-empty.");
      C := AMem(P);
      pragma Assert (C.T = Cons,
                     "Dump_Cons must receive pointer to a Cons cell.");
      
      -- Special processing: if our cons is a list of the form (quote
      --  expr), print 'expr.
      declare
         CarP, CdrP, CadrP : MemPtr;
      begin
         CarP := Get_Car(C);
         CdrP := Get_Cdr(C);
         -- Car(P) = Quote_Sym?
         if CarP = Quote_Sym then
            -- Cdr(P) /= 0?
            if CdrP = 0 then
               Put("()");
               return;
            end if;
            -- Get Cadr(P)
            CadrP := Get_Car(AMem(CdrP));
            -- 'expr
            Put("'");
            Dump_Cell(CadrP);
            return;
         end if;
      end;
      
      -- This cons cell may be a list, so we iterate through it as
      --  long as possible and recursively call ourselves.
      Put("(");
      Dump_Cell(Get_Car(C));
            
      -- XXX This will fail *hard* for circular lists!
      while Get_Cdr(C) /= 0 loop
         -- Exit if cdr(C).tag /= cons.
         exit when (AMem(Get_Cdr(C)).T /= Cons);
         C := AMem(Get_Cdr(C));
         
         Put(" ");
         Dump_Cell(Get_Car(C));
      end loop;

      -- What remains should be either a NIL or some other
      --  value. In the latter case, print it in dotted format.
      if Get_Cdr(C) /= 0 then
         Put(" . ");
         Dump_Cell(Get_Cdr(C));
      end if;
      Put(")");
   end Dump_Cons;
   
   procedure Dump_Longint(N : in Long_Integer) is
      use Ada.Text_IO;
      
      N1, N2 : Long_Integer;
      Num_Digits : Integer;
   begin
      -- 0
      if N = 0 then
         Put("0");
         return;
      end if;
      
      -- Check whether N is negative
      if N < 0 then
         Put('-');
         N1 := -N;
      else
         N1 := N;
      end if;
      
      -- Compute the number of digits
      N2 := 0;
      Num_Digits := 0;
      while N1 /= 0 loop
         N2 := N2 * 10 + N1 rem 10;
         N1 := N1 / 10;
         Num_Digits := Num_Digits + 1;
      end loop;
      -- Same, but algorithm, but print digit by digit
      while Num_Digits > 0 loop
         N1 := N2 rem 10;
         N2 := N2 / 10;
         Put(Character'Val(N1 + Character'Pos('0')));
         Num_Digits := Num_Digits - 1;
      end loop;
   end Dump_Longint;
   
   procedure Dump_BuiltinID(BID : in BuiltinID) is
      use Ada.Text_IO;
   begin
      case BID is
         when AddB => Put("+");
         when SubB => Put("-");
         when MulB => Put("*");
         when DivB => Put("/");
         when QuoteB => Put("quote");
         when EvalB => Put("eval");
         when IfB => Put("if");
         when ConsB => Put("cons");
         when CarB => Put("car");
         when CdrB => Put("cdr");
         when ListB => Put("list");
         when ApplyB => Put("apply");
         when DefineB => Put("define");
         when SetB => Put("set");
         when EqnB => Put("eqn");
         when EqB => Put("eq");
         when EqvB => Put("eqv");
         when PairPB => Put("pairp");
         when BooleanPB => Put("booleanp");
         when NumberPB => Put("numberp");
         when SymbolPB => Put("symbolp");
         when NullPB => Put("nullp");
         when ListPB => Put("listp");
         when AndB => Put("and");
         when OrB => Put("or");
         when NotB => Put("not");
         when LambdaB => Put("lambda");
         when LetB => Put("let");
         when ReverseB => Put("reverse");
         when AppendB => Put("append");
      end case;
   end Dump_BuiltinID;
   
   -- Dump string represented as list of characters.
   procedure Dump_String(P : in MemPtr) is
      use Ada.Text_IO;

      CarP, ListP : MemPtr;
   begin
      ListP := P;
      while ListP /= 0 loop         
         pragma Assert(AMem(ListP).T = Cons, "Not a string-as-list!");
         CarP := Get_Car(AMem(ListP));
         
         -- print elem.
         pragma Assert(AMem(CarP).T = Char, "Not a list of chars!");
         Put(Get_Char(AMem(CarP)));
         
         -- next
         ListP := Get_Cdr(AMem(ListP));
      end loop;
   end Dump_String;
   
   -- Init default bindings to builtin functions
   procedure Init_Builtin_Bindings is
      BuiltinP : MemPtr;
      SymP : MemPtr;
      CharP : MemPtr;
      NameP : MemPtr;
   begin
      -- Allocate symbol-value pair for each builtin, and add it to the
      --  front of Symbol_Table list.      
      for I in 0..(BuiltinTable'Length - 1) loop
         -- allocate builtin
         Alloc_Builtin(BuiltinTable(I).BiValue, BuiltinP);
         -- allocate name
         NameP := 0;
         for K in reverse BuiltinTable(I).BiName'Range loop
            -- skip spaces
            if BuiltinTable(I).BiName(K) /= ' ' then
               Alloc_Char(BuiltinTable(I).BiName(K), CharP);
               Alloc_Cons(CharP, NameP, NameP);
            end if;
         end loop;
         pragma Assert(NameP /= 0, "Name is empty!");
         Alloc_Symbol(NameP, SymP); -- create symbol
         Alloc_Cons(SymP, Sym_Table, Sym_Table); -- intern
         Bind_Env(SymP, BuiltinP, Global_Env, SymP); -- bind in global namespace
      end loop;
      
      -- XXX: Set Quote_Sym to be used by parser routine to convert the
      --  quote token to a proper S-expression. This is quite a
      --  hack, quote symbol could be represented as its own constant by
      --  lispm.
      NameP := 0;
      for K in reverse Quote_Name'Range loop
         Alloc_Char(Quote_Name(K), CharP);
         Alloc_Cons(CharP, NameP, NameP);
      end loop;

      Lookup_Symbol(NameP, Quote_Sym);
      
      -- Use these for debugging.

      --  Dump_Cell(Sym_Table);
      --  Dump_Cell(Global_Env);
   end Init_Builtin_Bindings;
   
   function Name_EqualP(Sym1, Sym2 : MemPtr) return Boolean is
      TempStr1, TempStr2 : MemPtr;
      P1, P2 : MemPtr;
      C1, C2 : Character;
      Same : Boolean := True;
   begin
      TempStr1 := Sym1;
      TempStr2 := Sym2;
      -- Compare strings character by character: iterate while any of
      --  the strings are not NIL.
      while TempStr1 /= 0 or TempStr2 /= 0 loop
         -- If any of them is NIL, then stop and return false.
         if TempStr1 = 0 or TempStr2 = 0 then
            Same := False;
            exit;
         end if;
         -- Otherwise, do the cars match?
         P1 := Get_Car(AMem(TempStr1)); C1 := Get_Char(AMem(P1));
         P2 := Get_Car(AMem(TempStr2)); C2 := Get_Char(AMem(P2));
         if C1 /= C2 then
            Same := False;
            exit;
         end if;
         -- If they do, check the rest.
         TempStr1 := Get_Cdr(AMem(TempStr1));
         TempStr2 := Get_Cdr(AMem(TempStr2));
      end loop;
      
      return Same;
   end Name_EqualP;
   
   -- Lookup Sym_Table for symbol whose name field is equal to Name.
   procedure Lookup_Symbol(Name : in MemPtr; Sym : out MemPtr) is
      ListP : MemPtr := Sym_Table;
   begin
      -- Assume we haven't found a value
      Sym := 0;
      
      -- Iterate through Sym_Table
      while ListP /= 0 loop
        declare
           CurrSym : MemPtr := Get_Car(AMem(ListP));
           CurrName : MemPtr;
        begin
           pragma Assert(CurrSym /= 0, "Sym_Table contains a NIL symbol!");
           pragma Assert(AMem(CurrSym).T = Symbol,
                         "Sym_Table contains a non-symbol!");
           -- Compare the given symbol name with the current alist value.
           CurrName := Get_Symbol(AMem(CurrSym));
           -- Found?
           if Name_EqualP(Name, CurrName) then
              Sym := CurrSym;
              exit;
           end if;
           -- Otherwise keep looking
           ListP := Get_Cdr(AMem(ListP));
        end;
      end loop;
   end Lookup_Symbol;
   
   -- Lookup Name in Sym_Table; if non-existent, add a new (Name . NIL)
   --  pair to the table and set NameVal to it.
   procedure Lookup_Or_Create_Symbol(Name : in MemPtr; Sym: out MemPtr) is
      TempSym : MemPtr;
   begin
      -- Lookup for Name
      Lookup_Symbol(Name, TempSym);
      -- If not found, intern Name
      if TempSym = 0 then
         Alloc_Symbol(Name, TempSym);
         Alloc_Cons(TempSym, Sym_Table, Sym_Table);
      end if;
      -- Return symbol
      Sym := TempSym;
   end Lookup_Or_Create_Symbol;
   
   -- Lookup Sym in Env set Binding to the Sym-Value pair if found.
   procedure Lookup_Env(Sym, Env : in MemPtr; Binding : out MemPtr) is
      EnvP : MemPtr := Env;
   begin
      -- NIL by default
      Binding := 0;
      
      while EnvP /= 0 loop
         declare
            CurrBinding : MemPtr := Get_Car(AMem(EnvP));
            CurrSym : MemPtr;
         begin
            pragma Assert (CurrBinding /= 0, "NIL binding in Env!");
            -- Get symbol of current binding
            CurrSym := Get_Car(AMem(CurrBinding));
            pragma Assert(AMem(CurrSym).T = Symbol, "Not a symbol!");
            -- Compare symbols pointer-wise
            if Sym = CurrSym then
               Binding := CurrBinding;
               exit;
            end if;
            EnvP := Get_Cdr(AMem(EnvP));
         end;
      end loop;   
   end Lookup_Env;
   
   -- Lookup value of Sym in Env or Global_Env
   procedure Lookup_Env_Or_Global(Sym, Env : in MemPtr;
                                  Binding : out MemPtr) is
      TempP : MemPtr;
   begin
      Lookup_Env(Sym, Env, TempP);
      if TempP = 0 then
         Lookup_Env(Sym, Global_Env, Binding);
      else
         Binding := TempP;
      end if;
   end Lookup_Env_Or_Global;
   
   -- Add Sym-Value binding in Env and set Binding to the new pair.
   procedure Bind_Env(Sym, Value : in MemPtr;
                      Env : in out MemPtr; Binding : out MemPtr) is
      TempP : MemPtr;
   begin
      Alloc_Cons(Sym, Value, TempP); -- create pair
      Alloc_Cons(TempP, Env, Env); -- cons pair to env
      
      Binding := TempP; -- return pair.
   end Bind_Env;
end LispM;

-
+ 0FC0C9657956634910EDC6DC4ABE8C5F9743F9C541491D3C1800CD9F9C05B3BF081190DD80C90ABBA91E9358D43CF40F1B7C20F645FFEBAF459683E711ABD782
adalisp/src/lispm.ads

(0 . 0)(1 . 157)
-- Basic lisp machine memory and data representation. The basic memory
--  unit of lisp machines is a cell of the form [ tag | data ]. Lisp
--  memory is an array of such cells, with cell index 0 being reserved
--  for the special value NIL.
package LispM is
   -- 8MCells should be enough for everyone
   Mem_Size : constant := 2**23;
   
   -- Machine words
   type MWord is mod 2 ** 64;
   for MWord'Size use 64;
   
   -- Cell tags.
   type Tag is (Free, Builtin, Cons, Bool, Fixnum, Char, Symbol, Closure);
   type MemPtr is range 0 .. Mem_Size;
   
   -- Built-in functions are tied in to a conceptual arithmetic-logic
   --  unit that provides the building blocks for evaluation.
   type BuiltinID is (AddB, SubB, MulB, DivB, QuoteB, EvalB, IfB,
                      ConsB, CarB, CdrB, ListB, ApplyB, DefineB, SetB,
                      EqnB, EqB, EqvB, PairPB, BooleanPB, NumberPB, SymbolPB,
                      NullPB, ListPB, AndB, OrB, NotB, LambdaB, LetB,
                      ReverseB, AppendB);

   -- Cell data type. The first part of any cell is a tag. The second
   --  part is a tag-dependent machine word.
   --
   -- Machine words are defined by tag, as follows:
   --
   -- [ free | 0 ]
   --
   -- [ builtin | bid ] where bid is a number corresponding uniquely to
   --  a BuiltinID.
   --
   -- [ cons | car, cdr ] where car and cdr are each half of an MWord.
   --
   -- [ bool | b ] where b is a truth value (0 is false, 1 is true). XXX
   --  bool values should be hardcoded symbols (or something similar).
   --
   -- [ fixnum | n ] where n is a signed integer of MWord size / 2, the
   --  first bit being a sign bit.
   --
   -- [ char | c ] where c is the ASCII code of a character.
   --
   -- [ symbol | ptr ] where ptr points to a list of characters uniquely
   --  determining the symbol's name.
   --
   -- [ closure | code, env ] where code points to a list of the form
   --  (args e1 e2 ... en) (where args is a list of symbols) and env
   --  points to a symbol-value alist.
   type Cell is record
      T : Tag;
      Data : MWord;
   end record;

   -- This puts it all together.
   type Mem is array (MemPtr range 1 .. Mem_Size) of Cell;

   -- Pointer to heap end. This is incremented on memory
   --  allocations. Don't worry about deallocations for now, since we
   --  don't have a GC (yet).
   Heap_End : MemPtr := 0;
   
   -- Pointer to interned symbol list.
   Sym_Table : MemPtr := 0;
   -- Pointer to interned symbol representing the "quote" keyword. This
   --  is used by the parser to transform ' tokens into (quote ...).
   Quote_Sym : MemPtr := 0;
   
   -- Pointer to environment: the environment is a list of symbol-value
   --  associations; a symbol may have more than one associations at a
   --  given point in time, in which case the most recent association
   --  will be considered.
   Global_Env : MemPtr := 0;

   -- A statically-allocated memory.
   AMem : Mem := (others => (T => Free, Data => 0));
   
   -- Cell manipulation primitives.
   function Get_Builtin(C : Cell) return BuiltinID;
   function Get_Car(C : Cell) return MemPtr;
   function Get_Cdr(C : Cell) return MemPtr;
   function Get_Bool(C : Cell) return Boolean;
   function Get_Fixnum(C : Cell) return Long_Integer;
   function Get_Char(C : Cell) return Character;
   function Get_Symbol(C : Cell) return MemPtr;
   function Get_Closure_Code(C : Cell) return MemPtr;
   function Get_Closure_Env(C : Cell) return MemPtr;
   procedure Set_Builtin(C : in out Cell; B : in BuiltinID);
   procedure Set_Car(C : in out Cell; Car : in MemPtr);
   procedure Set_Cdr(C : in out Cell; Cdr : in MemPtr);
   procedure Set_Bool(C : in out Cell; Value : in Boolean);
   procedure Set_Fixnum(C : in out Cell; Value : in Long_Integer);
   procedure Set_Char(C : in out Cell; Value : in Character);
   procedure Set_Symbol(C : in out Cell; Name : in MemPtr);
   procedure Set_Closure_Code(C : in out Cell; Code : in MemPtr);
   procedure Set_Closure_Env(C : in out Cell; Env : in MemPtr);
   
   -- Memory management primitives.

   -- Allocate cell in AMem.
   procedure Alloc_Cell(C : in Cell; P : out MemPtr);
   -- Higher-level allocation primitives
   procedure Alloc_Builtin(B : BuiltinID; P : out MemPtr);
   procedure Alloc_Cons(Car, Cdr : in MemPtr; P : out MemPtr);
   procedure Alloc_Bool(Value : in Boolean; P : out MemPtr);
   procedure Alloc_Fixnum(Value : in Long_Integer; P : out MemPtr);
   procedure Alloc_Char(Value : in Character; P : out MemPtr);
   procedure Alloc_Symbol(Name : in MemPtr; P : out MemPtr);
   procedure Alloc_Closure(Code, Env : in MemPtr; P : out MemPtr);
   
   -- I/O: output primitives. XXX these should be placed in a separate
   --  module.
   
   -- Dump cell to standard output.
   procedure Dump_Cell(P : in MemPtr);
   
   -- Recursively dump a cons cell, doing sugary processing.
   procedure Dump_Cons(P : in MemPtr);
   
   -- Dump a long integer
   procedure Dump_Longint(N : in Long_Integer);
   
   -- Dump the name of a builtin id
   procedure Dump_BuiltinID(BID : in BuiltinID);
   
   -- Dump a sequence of chars represented as a list.
   procedure Dump_String(P : in MemPtr);
   
   -- Init symbol table to a list of known symbols and add their
   --  bindings to builtins to the global environment.
   procedure Init_Builtin_Bindings;
   
   -- Check whether two symbol names are equal.
   function Name_EqualP(Sym1, Sym2 : MemPtr) return Boolean;
   
   -- Lookup symbol in symbol table. Return a pointer to a the unique
   --  symbol object representing it if found, NIL otherwise.
   procedure Lookup_Symbol(Name : in MemPtr; Sym : out MemPtr);
   
   -- Similar to Lookup_Symbol, only if the name does not exist, we
   --  create and add a new symbol object to the symbol table, and we
   --  return it.
   procedure Lookup_Or_Create_Symbol(Name : in MemPtr;
                                     Sym : out MemPtr);
   
   -- Lookup a binding for Sym in Env. Returns a symbol-value pair if it
   --  exists, NIL otherwise.
   procedure Lookup_Env(Sym, Env : in MemPtr; Binding : out MemPtr);
   -- Similar to Lookup_Env, only also try Global_Env
   procedure Lookup_Env_Or_Global(Sym, Env : in MemPtr;
                                  Binding : out MemPtr);

   -- Add a Sym-Value binding in Env. Returns the new binding.
   procedure Bind_Env(Sym, Value : in MemPtr;
                      Env : in out MemPtr; Binding : out MemPtr);
end LispM;

-
+ D343C9D00E533B72E6B07F6E9849BFB796DF42AE0E0D376EF7B459C261124311AAB7402EA6E9608BB84DD2037AB837A6C06F9935D371A6D7EFF75A619C054670
adalisp/src/parser.adb

(0 . 0)(1 . 291)
-- S-expression parser implementation.
with Ada.Text_IO; use Ada.Text_IO;

package body Parser is
   -- Predicates on input characters
   WhitespaceP : constant array (Character) of Boolean :=
     (' ' | ASCII.Nul | ASCII.HT | ASCII.CR | ASCII.LF => True, others => False);
   DigitP : constant array (Character) of Boolean :=
     ('0' .. '9' => True, others => False);
   
   -- Reserved characters, although '.' and '#' can technically speaking
   --  be part of symbol names.
   ReservedP : constant array (Character) of Boolean :=
     ('(' | ')' | '#' | '.' | ''' => True, others => False);
   
   C : Character := ' ';
   I : Long_Integer;
   
   -- Given a string, check if all its characters are digits. If so,
   --  accumulate them in I.
   procedure Parse_Integer(Str : in MemPtr;
                           Success : out Boolean;
                           I : out Long_Integer) is
      P : MemPtr := Str;
      PC : MemPtr;
      C : Character;
      Negative : Boolean := False;
      Result : Long_Integer;
   begin
      Result := 0;
      Success := True;
      
      pragma Assert (P /= 0, "Parse_Integer received a NIL string!");
      
      -- Check for leading +/- signs first
      PC := Get_Car(AMem(P));
      C := Get_Char(AMem(PC));
      if C = '-' then
         Negative := True;
      end if;
      if C = '-' or C = '+' then
         P := Get_Cdr(AMem(P));
         -- If we don't have other characters after + or -, then this is
         --  not a number.
         if P = 0 then
            Success := False;
            return;
         end if;
      end if;
      
      while P /= 0 loop
         -- Check list and its car.
         PC := Get_Car(AMem(P));
         C := Get_Char(AMem(PC));
         
         -- Do we have a non-digit?
         if not DigitP(C) then
            Success := False;
            exit;
         end if;
         
         -- If we're still in the all-digits game, gather them, hoping
         --  we get a number.
         Result := Result * 10 + (Character'Pos(C) - Character'Pos('0'));
         
         -- Move on.
         P := Get_Cdr(AMem(P));
      end loop;

      if Negative then
         Result := -Result;
      end if;
      
      -- Set the output value if and only if we succeeded.
      if Success then
         I := Result;
      end if;
   end Parse_Integer;
   
   procedure Eat_Whitespace is
   begin
      while WhitespaceP(C) loop
         Get(C);
      end loop;
   end Eat_Whitespace;
   
   -- Parse a list of characters that may be a symbol or an integer.
   procedure Parse_Atom(P : out MemPtr) is
      CharP, TempP : MemPtr;
      ListP : MemPtr := 0;
      ListTailP : MemPtr := 0;
   begin
      pragma Assert (not ReservedP(C),
                     "Parse_Atom received a reserved character!");
      
      loop
         -- Get a new char cell
         Alloc_Char(C, CharP);
         -- Save old list tail
         TempP := ListTailP;
         -- Cons cell to be appended to the list
         Alloc_Cons(CharP, 0, ListTailP);
         
         -- Does the old list tail point to a cons cell? If so, set the
         --  old cdr to the new list tail, otherwise set the list
         --  pointer to the tail.
         if TempP /= 0 then
            Set_Cdr(AMem(TempP), ListTailP);
         else
            ListP := ListTailP;
         end if;
         
         -- Get a new character and verify the exit condition
         Get(C);
         exit when WhitespaceP(C);
         exit when C = '(' or C = ')';
      end loop;
      -- Assign output parameter to our list.
      P := ListP;
   end Parse_Atom;
   
   -- Parse hash-prepended expression.
   procedure Parse_Hash(P : out MemPtr; TID : out TokenID) is
   begin
      pragma Assert (C = '#',
                     "Parse_Hash does not begin with a hash.");
      
      -- We support the following hash-prepended expressions:
      --
      -- . booleans (#t or #f)
      -- . characters (e.g. #\a, #\b, ...)
      
      Get(C);
      
      if (C = 't') then -- true
         Alloc_Bool(True, P);
         TID := Bool_Token;
      elsif (C = 'f') then -- false
         Alloc_Bool(False, P);
         TID := Bool_Token;
      elsif (C = '\') then -- char
         -- XXX should do more elaborate parsing here, e.g. #\space
         --  etc.
         Get(C);
         Alloc_Char(C, P);
         TID := Char_Token;
      else -- unknown
         pragma Assert (False, "Unknown hash expression.");
      end if;
      
      -- Emulate a space for future calls of Parse
      C := ' ';
   end Parse_Hash;
   
   -- Parse cons objects, i.e. lists and pairs.
   procedure Parse_Cons(P : out MemPtr) is
      ListP : MemPtr := 0;
      ListTailP : MemPtr := 0;
      TID : TokenID;
   begin
      pragma Assert (C = '(', "Parse_Cons should receive an open paren.");
      
      -- Emulate a space for the first call to Parse
      C := ' ';
      
      -- Iterate through the list elements and add them to the list.
      loop
         declare
            ElemP, TempP : MemPtr;
         begin
            -- Parse current element
            Parse(ElemP, TID);
            
            -- Exit conditions
            exit when TID = ListE_Token; -- list end
            exit when TID = ListP_Token; -- pair marker
            
            -- Save old list tail
            TempP := ListTailP;
            -- Add new element to the list: if the TempP is NIL, then we
            --  have a fresh list that we can populate with the new
            --  element.
            Alloc_Cons(ElemP, 0, ListTailP);
            if TempP = 0 then
               ListP := ListTailP;
            else
               Set_Cdr(AMem(TempP), ListTailP);
            end if;
         end;
      end loop;
      
      -- If we received a pair marker, then we have one more element to
      --  parse.
      if TID = ListP_Token then
         declare
            ElemP : MemPtr;
         begin
            pragma Assert (ListTailP /= 0, "Syntax error parsing pair.");
            -- Emulate space
            C := ' ';
            -- Parse element
            Parse(ElemP, TID);
            
            pragma Assert(TID = Bool_Token or TID = Num_Token or
                            TID = List_Token or TID = Char_Token or
                            TID = Symbol_Token,
                          "Syntax error parsing pair.");
            -- Point cdr of list tail to element
            Set_Cdr(AMem(ListTailP), ElemP);
         end;
      elsif TID /= ListE_Token then
         Put_Line("Impossible to get here!");
         P := 0;
         return;
      end if;
      
      -- Set the output and emulate a space for whatever comes next.
      P := ListP;
      C := ' ';
   end Parse_Cons;
   
   -- Parse quoted S-expression.
   procedure Parse_Quoted(P : out MemPtr; TID : out TokenID) is
      ExprP : MemPtr;
   begin
      pragma Assert (C = ''', "Parse_Quoted not given a quote");
      
      -- Emulate a space and parse whatever comes after the quote.
      C := ' ';
      Parse(ExprP, TID);
      
      -- If the result of Parse is an atomic constant, we return it as
      --  it is. Otherwise we wrap whatever expr we get in a quote,
      --  i.e. (quote expr).
      case TID is
         when Bool_Token | Num_Token | Char_Token =>
            P := ExprP;
         when others =>
            -- (expr)
            Alloc_Cons(ExprP, 0, ExprP);
            -- (quote expr)
            Alloc_Cons(Quote_Sym, ExprP, ExprP);
            -- Assign output
            P := ExprP;
            TID := Quoted_Token;
      end case;      
   end Parse_Quoted;
   
   -- Parse any S-expression
   procedure Parse(P : out MemPtr; TID : out TokenID) is
      TempTID : TokenID := Error_Token;
      AtomP : MemPtr;
      TempP1, TempP2, TempP3 : MemPtr := 0;
      Is_Number : Boolean;
   begin
      P := 0;
      TID := Error_Token;
      
      Eat_Whitespace;
      
      -- Not (, ), #, . or '
      if not ReservedP(C) then -- atom
         -- Read atom from stdin
         Parse_Atom(AtomP);
         
         -- Try to parse a number; if we succeed, then return it, else
         --  return the atom as an interned symbol.
         Parse_Integer(AtomP, Is_Number, I);
         if Is_Number then
            Alloc_Fixnum(I, P);
            TID := Num_Token;
         else
            -- Alloc symbol cell
            Lookup_Or_Create_Symbol(AtomP, P);
            TID := Symbol_Token;
         end if;
      elsif C = '#' then -- hash token
         Parse_Hash(P, TID);
      elsif C = '(' then -- list/pair
         Parse_Cons(P);
         -- Instantiate TID
         TID := List_Token;
      elsif C = ')' then -- list/pair end
         TID := ListE_Token;
      elsif C = '.' then -- pair marker
         TID := ListP_Token;
      elsif C = ''' then -- quote marker
         Parse_Quoted(P, TID);
      end if;
   end Parse;
end Parser;

-
+ 30ACFFBB85D590F74E7E9B76F5611663BDA26AF35E38316F633A752A9248AC9B7E61E72BD411252A4BE85B2F89E442F53F5E68A0414CFBBD6376B30F99F3B1BE
adalisp/src/parser.ads

(0 . 0)(1 . 56)
-- S-expression parser. According to the current spec, any of the
--  following objects constitute a S-expr:
--
-- - atom: a sequence containing any characters except spaces or parens,
--  i.e. ( or ); atoms are separated by these characters and may not
--  begin with any of (, ), #, . or '; if an atom is composed only of
--  numeric decimal characters, then it is parsed as a number; otherwise
--  it is parsed as an interned symbol.
--
-- - hash expression: any expression beginning with #; currently,
--  expression beginning with # are the boolean values #t and #f, and
--  escaped characters, e.g. #\a (the character corresponding to the
--  letter a).
--
-- - cons expression: cons expressions begin with a (, contain any
--  number of space-separated sub-expressions and end with ), e.g. (a b
--  c d) denotes the list containing the symbols a, b, c and d, ()
--  denotes the empty list, etc.; a cons expression may optionally
--  contain a period (.) token before the last element, signifying that
--  the last element is set as the cdr of the last cons cell, e.g. (1 2
--  . 3) corresponds to (cons 1 (cons 2 3)).
--
-- - quoted expression: any expression beginning with a single quote (')
--  token; 'expr (where expr is an arbitrary S-expression) gets
--  translated to (quote expr).
with LispM; use LispM;

package Parser is
   type TokenID is (Error_Token, Bool_Token, Num_Token, List_Token,
                    Char_Token, Symbol_Token, ListE_Token, ListP_Token,
                    Quoted_Token);
   
   -- Given a string, check if all its characters are digits.
   procedure Parse_Integer(Str : in MemPtr;
                           Success : out Boolean;
                           I : out Long_Integer);
   -- Eat whitespace.
   procedure Eat_Whitespace;
   
   -- Parse a list of characters not in the reserved set.
   procedure Parse_Atom(P : out MemPtr);
   
   -- Parse a hash-prepended expression.
   procedure Parse_Hash(P : out MemPtr; TID : out TokenID);
   
   -- Parse cons objects, i.e. lists and pairs.
   procedure Parse_Cons(P : out MemPtr);
   
   -- Parse quoted expression.
   procedure Parse_Quoted(P : out MemPtr; TID : out TokenID);
      
   -- Parse an S-expression given as input on the console. Output a
   --  pointer to the parsed expression and its type, as represented by
   --  TokenID.
   procedure Parse(P : out MemPtr; TID : out TokenID);
end Parser;

-
+ 8AAF89145D930D102E76F08E51768E632C183155C4285D89D897CC5835E55DE3C9C1D27F847203D627198B4A919A138F31EAE131FBA600C5CF9507D4CD5C4064
adalisp/src/restrict.adc

(0 . 0)(1 . 65)
pragma Restrictions(Immediate_Reclamation);
pragma Restrictions(Max_Asynchronous_Select_Nesting => 0);
pragma Restrictions(Max_Protected_Entries => 0);
pragma Restrictions(Max_Select_Alternatives => 0);
pragma Restrictions(Max_Task_Entries => 0);
pragma Restrictions(Max_Tasks => 0);
pragma Restrictions(No_Abort_Statements);
pragma Restrictions(No_Access_Parameter_Allocators);
pragma Restrictions(No_Allocators);
pragma Restrictions(No_Asynchronous_Control);
pragma Restrictions(No_Calendar);
pragma Restrictions(No_Coextensions);
pragma Restrictions(No_Default_Stream_Attributes);
pragma Restrictions(No_Delay);
pragma Restrictions(No_Dispatch);
pragma Restrictions(No_Dispatching_Calls);
pragma Restrictions(No_Dynamic_Attachment);
pragma Restrictions(No_Dynamic_Priorities);
pragma Restrictions(No_Entry_Calls_In_Elaboration_Code);
pragma Restrictions(No_Entry_Queue);
pragma Restrictions(No_Enumeration_Maps);
pragma Restrictions(No_Exception_Propagation);
pragma Restrictions(No_Exception_Registration);
pragma Restrictions(No_Finalization);
pragma Restrictions(No_Fixed_Io);
pragma Restrictions(No_Floating_Point);
pragma Restrictions(No_Implementation_Aspect_Specifications);
pragma Restrictions(No_Implementation_Units);
pragma Restrictions(No_Implicit_Aliasing);
pragma Restrictions(No_Implicit_Conditionals);
pragma Restrictions(No_Implicit_Dynamic_Code);
pragma Restrictions(No_Implicit_Heap_Allocations);
pragma Restrictions(No_Implicit_Protected_Object_Allocations);
pragma Restrictions(No_Implicit_Task_Allocations);
pragma Restrictions(No_Initialize_Scalars);
pragma Restrictions(No_Local_Protected_Objects);
pragma Restrictions(No_Local_Timing_Events);
pragma Restrictions(No_Multiple_Elaboration);
pragma Restrictions(No_Nested_Finalization);
pragma Restrictions(No_Protected_Type_Allocators);
pragma Restrictions(No_Protected_Types);
pragma Restrictions(No_Relative_Delay);
pragma Restrictions(No_Requeue_Statements);
pragma Restrictions(No_Secondary_Stack);
pragma Restrictions(No_Select_Statements);
pragma Restrictions(No_Specific_Termination_Handlers);
pragma Restrictions(No_Standard_Allocators_After_Elaboration);
pragma Restrictions(No_Stream_Optimizations);
pragma Restrictions(No_Streams);
pragma Restrictions(No_Task_Allocators);
pragma Restrictions(No_Task_At_Interrupt_Priority);
pragma Restrictions(No_Task_Attributes_Package);
pragma Restrictions(No_Task_Hierarchy);
pragma Restrictions(No_Tasking);
pragma Restrictions(No_Task_Termination);
pragma Restrictions(No_Terminate_Alternatives);
pragma Restrictions(No_Unchecked_Access);
pragma Restrictions(No_Unchecked_Conversion);
pragma Restrictions(No_Unchecked_Deallocation);
pragma Restrictions(No_Wide_Characters);
pragma Restrictions(Pure_Barriers);
pragma Restrictions(Simple_Barriers);
pragma Restrictions(Static_Priorities);
pragma Restrictions(Static_Storage_Size);
pragma Validity_Checks(ALL_CHECKS);

-
+ 040A9F08A31A01C5506C1609493F3E55833F5A0092144FA4A084739CC5EF75FBE8E2124C6C386607E9295A96D1BDD3B1F660D81C91668F481987E29B84EB7B14
adalisp/src/test_repl.adb

(0 . 0)(1 . 36)
-- A test REPL putting all our Ada Lisp components together.
with Ada.Text_IO; use Ada.Text_IO;

with Parser; use Parser;
with Evaler; use Evaler;
with LispM; use LispM;

procedure Test_Repl is
   P : MemPtr;
   TID : TokenID;
begin
   -- Init builtin bindings
   Init_Builtin_Bindings;
   
   loop
      Put("> ");
      
      -- Read
      Parse(P, TID);
      
      -- Eval
      case TID is
         when Error_Token =>
            Put("Parse error.");
            exit;
         when ListE_Token =>
            Put("Unexpected end of list.");
            exit;
         when others =>
            Eval(P, 0, P);
      end case;
      
      -- Print
      Dump_Cell(P); Put_Line("");
   end loop;
end Test_Repl;

-
+ 91D6AFD6207C6ECCA784175CADEFB5512CB50A310BFBE2AFA7DCEC1C221A01F1A12F5167DC8A6BF8C21D96642D04963509356D5FCE62F784584FE6365D327D5D
adalisp/test.scm

(0 . 0)(1 . 41)
(define length (lambda (L)
  (if (eq? L '())
      0
      (+ 1 (length (cdr L))))))

(define map (lambda (f L)
  (if (eq? L '())
      '()
      (cons (f (car L)) (map f (cdr L))))))

(define fibs (lambda (n)
  (if (= n 0)
      0
      (if (= n 1)
          1
          (+ (fibs (- n 1)) (fibs (- n 2)))))))

(define fact (lambda (n)
  (if (= n 0)
      1
      (* n (fact (- n 1))))))

(define equal? (lambda (x y)
  (if (pair? x)
    (and (pair? y)
         (equal? (car x) (car y))
         (equal? (cdr x) (cdr y)))
    (eqv? x y))))

(define 1+ (lambda (x) (+ x 1)))
(define 1- (lambda (x) (- x 1)))

(define succ 1+)
(define pred 1-)

(if (= (length '(a b c d e f g)) 7) 'passed 'failed)
(if (equal? (map (lambda (x) (* x x)) '(1 2 3 4 5))
            '(1 4 9 16 25))
  'passed 'failed)
(if (= (fibs 10) 55) 'passed 'failed)
(if (= (fact 10) 3628800) 'passed 'failed)

-
+ 9EC51C9DFDAC10BAA0E11529637447E9ED8B99D068144B966B6E8C653534CCE7BE30746D6AC834630758A14326353A1F12A560E06A9FF6B88DF151CF1A8A8158
adalisp/test_repl.gpr

(0 . 0)(1 . 48)
project Test_Repl is
  for Object_Dir use "obj";
  
  type Mode_Type is ("debug", "release");
  Mode : Mode_Type := external ("mode", "release");
    
  for Languages use ("Ada");
  for Source_Dirs use ("src");
  for Exec_Dir use "bin";
  for Main use ("test_repl.adb");
  
  package Compiler is
     case Mode is
        when "debug" =>
           for Switches ("Ada")
             use ("-g");
        when "release" =>
           for Switches ("Ada")
             use ("-O2", "-gnata", "-fstack-check",
                  "-fdata-sections", "-ffunction-sections",
                  "-gnatec=" & Test_Repl'Project_Dir & "src/restrict.adc");
     end case;
  end Compiler;
  
  package Binder is
     case Mode is
        when "debug" =>
           for Switches ("Ada")
             use ();
        when "release" =>
           for Switches ("Ada")
             use ("-static");
     end case;
  end Binder;
  
  package Linker is
     case Mode is
        when "debug" =>
           for Switches ("Ada")
             use ();
        when "release" =>
           for Switches ("Ada")
             use ("-Wl,--gc-sections",
                  "-static");
     end case;
  end Linker;
  
end Test_Repl;