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