raw
adalisp_genesis         1 -- Lisp machine, procedures for memory manipulation (at least for the
adalisp_genesis         2 --  time being).
adalisp_genesis         3 with Ada.Text_IO;
adalisp_genesis         4 
adalisp_genesis         5 package body LispM is
adalisp_genesis         6    
adalisp_genesis         7    -- The initial environment requires a set of symbols and their
adalisp_genesis         8    --  bindings to builtin functions/keywords. Thus we hold these into a
adalisp_genesis         9    --  statically-allocated table and we let the Lisp run-time copy them
adalisp_genesis        10    --  in AMem at the beginning of the world.
adalisp_genesis        11    
adalisp_genesis        12    -- Constant symbol name size: 10 characters should be enough for
adalisp_genesis        13    --  everyone.
adalisp_genesis        14    subtype BuiltinNameSize is Integer range 1..10;
adalisp_genesis        15    -- Symbol name-builtin association
adalisp_genesis        16    type BuiltinAssoc is record
adalisp_genesis        17       BiName : String(BuiltinNameSize);
adalisp_genesis        18       BiValue : BuiltinID;
adalisp_genesis        19    end record;
adalisp_genesis        20    -- Array of BuiltinAssoc objects
adalisp_genesis        21    type BuiltinAssocs is array (Natural range <>) of BuiltinAssoc;
adalisp_genesis        22    
adalisp_genesis        23    BuiltinTable : constant BuiltinAssocs :=
adalisp_genesis        24      (0  => (BiName => "+         ", BiValue => AddB),
adalisp_genesis        25       1  => (BiName => "-         ", BiValue => SubB),
adalisp_genesis        26       2  => (BiName => "*         ", BiValue => MulB),
adalisp_genesis        27       3  => (BiName => "/         ", BiValue => DivB),
adalisp_genesis        28       4  => (BiName => "quote     ", BiValue => QuoteB),
adalisp_genesis        29       5  => (BiName => "eval      ", BiValue => EvalB),
adalisp_genesis        30       6  => (BiName => "if        ", BiValue => IfB),
adalisp_genesis        31       7  => (BiName => "cons      ", BiValue => ConsB),
adalisp_genesis        32       8  => (BiName => "car       ", BiValue => CarB),
adalisp_genesis        33       9  => (BiName => "cdr       ", BiValue => CdrB),
adalisp_genesis        34       10 => (BiName => "list      ", BiValue => ListB),
adalisp_genesis        35       11 => (BiName => "apply     ", BiValue => ApplyB),
adalisp_genesis        36       12 => (BiName => "define    ", BiValue => DefineB),
adalisp_genesis        37       13 => (BiName => "set!      ", BiValue => SetB),
adalisp_genesis        38       14 => (BiName => "=         ", BiValue => EqnB),
adalisp_genesis        39       15 => (BiName => "eq?       ", BiValue => EqB),
adalisp_genesis        40       16 => (BiName => "eqv?      ", BiValue => EqvB),
adalisp_genesis        41       17 => (BiName => "pair?     ", BiValue => PairPB),
adalisp_genesis        42       18 => (BiName => "boolean?  ", BiValue => BooleanPB),
adalisp_genesis        43       19 => (BiName => "number?   ", BiValue => NumberPB),
adalisp_genesis        44       20 => (BiName => "symbol?   ", BiValue => SymbolPB),
adalisp_genesis        45       21 => (BiName => "null?     ", BiValue => NullPB),
adalisp_genesis        46       22 => (BiName => "list?     ", BiValue => ListPB),
adalisp_genesis        47       23 => (BiName => "and       ", BiValue => AndB),
adalisp_genesis        48       24 => (BiName => "or        ", BiValue => OrB),
adalisp_genesis        49       25 => (BiName => "not       ", BiValue => NotB),
adalisp_genesis        50       26 => (BiName => "lambda    ", BiValue => LambdaB),
adalisp_genesis        51       27 => (BiName => "let       ", BiValue => LetB),
adalisp_genesis        52       28 => (BiName => "reverse   ", BiValue => ReverseB),
adalisp_genesis        53       29 => (BiName => "append    ", BiValue => AppendB));
adalisp_genesis        54    
adalisp_genesis        55    -- Hack: used for maintaining a special "quote" symbol used by the
adalisp_genesis        56    --  parser.
adalisp_genesis        57    Quote_Name : constant String := "quote";
adalisp_genesis        58    
adalisp_genesis        59    -- Shifting functions for MWord, used for low-level arithmetic.
adalisp_genesis        60    function Shift_Left
adalisp_genesis        61      (Value  : MWord; 
adalisp_genesis        62       Amount : Natural)
adalisp_genesis        63      return    MWord;
adalisp_genesis        64    pragma Import(Intrinsic, Shift_Left);
adalisp_genesis        65    
adalisp_genesis        66    function Shift_Right
adalisp_genesis        67      (Value  : MWord; 
adalisp_genesis        68       Amount : Natural)
adalisp_genesis        69      return    MWord;
adalisp_genesis        70    pragma Import(Intrinsic, Shift_Right);
adalisp_genesis        71    
adalisp_genesis        72    -- Getters.
adalisp_genesis        73    
adalisp_genesis        74    -- Get the ID of a builtin cell
adalisp_genesis        75    function Get_Builtin(C : Cell) return BuiltinID is
adalisp_genesis        76    begin
adalisp_genesis        77       pragma Assert (C.T = Builtin, "Not a builtin cell!");
adalisp_genesis        78       -- Disclaimer: This list is hand-maintained, programmer must
adalisp_genesis        79       --  ensure that 'Get' and 'Set' sides match!
adalisp_genesis        80       return BuiltinTable(Integer(C.Data)).BiValue;
adalisp_genesis        81    end Get_Builtin;
adalisp_genesis        82    
adalisp_genesis        83    -- Get the car of a cons cell
adalisp_genesis        84    function Get_Car(C : Cell) return MemPtr is
adalisp_genesis        85    begin
adalisp_genesis        86       pragma Assert (C.T = Cons or C.T = Closure,
adalisp_genesis        87                      "Car: Not a cons cell!");
adalisp_genesis        88       return MemPtr(Shift_Right(C.Data, 32));
adalisp_genesis        89    end Get_Car;
adalisp_genesis        90    
adalisp_genesis        91    -- Get the cdr of a cons cell
adalisp_genesis        92    function Get_Cdr(C : Cell) return MemPtr is
adalisp_genesis        93    begin
adalisp_genesis        94       pragma Assert (C.T = Cons or C.T = Closure,
adalisp_genesis        95                      "Cdr: Not a cons cell!");
adalisp_genesis        96       return MemPtr(C.Data and 16#0000_0000_FFFF_FFFF#);
adalisp_genesis        97    end Get_Cdr;
adalisp_genesis        98    
adalisp_genesis        99    -- Get the value of a bool cell
adalisp_genesis       100    function Get_Bool(C : Cell) return Boolean is
adalisp_genesis       101    begin
adalisp_genesis       102       pragma Assert (C.T = Bool, "Not a bool cell!");
adalisp_genesis       103       pragma Assert (C.Data = 0 or C.Data = 1,
adalisp_genesis       104                      "Bool cell in undefined state!");
adalisp_genesis       105       if (C.Data = 0) then
adalisp_genesis       106          return False;
adalisp_genesis       107       else
adalisp_genesis       108          return True;
adalisp_genesis       109       end if;
adalisp_genesis       110    end Get_Bool;
adalisp_genesis       111    
adalisp_genesis       112    -- Get the value of a fixnum cell
adalisp_genesis       113    function Get_Fixnum(C : Cell) return Long_Integer is
adalisp_genesis       114       Temp : Long_Integer;
adalisp_genesis       115    begin
adalisp_genesis       116       pragma Assert (C.T = Fixnum, "Not a fixnum cell!");
adalisp_genesis       117       if (C.Data and 16#8000_0000_0000_0000#) /= 0 then
adalisp_genesis       118          Temp := -(Long_Integer(not C.Data) + 1);
adalisp_genesis       119       else
adalisp_genesis       120          Temp := Long_Integer(C.Data);
adalisp_genesis       121       end if;
adalisp_genesis       122       return Temp;
adalisp_genesis       123    end Get_Fixnum;
adalisp_genesis       124    
adalisp_genesis       125    -- Get the value of a char cell
adalisp_genesis       126    function Get_Char(C : Cell) return Character is
adalisp_genesis       127    begin
adalisp_genesis       128       pragma Assert (C.T = Char, "Not a char cell!");
adalisp_genesis       129       return Character'Val(C.Data);
adalisp_genesis       130    end Get_Char;
adalisp_genesis       131 
adalisp_genesis       132    -- Get the string (list-of-chars) associated with a symbol cell
adalisp_genesis       133    function Get_Symbol(C : Cell) return MemPtr is
adalisp_genesis       134    begin
adalisp_genesis       135       pragma Assert (C.T = Symbol, "Not a symbol cell!");
adalisp_genesis       136       return MemPtr(C.Data);
adalisp_genesis       137    end Get_Symbol;
adalisp_genesis       138    
adalisp_genesis       139    -- Get the code of a closure cell (in practice, the pair car)
adalisp_genesis       140    function Get_Closure_Code(C : Cell) return MemPtr is
adalisp_genesis       141    begin
adalisp_genesis       142       return Get_Car(C);
adalisp_genesis       143    end Get_Closure_Code;
adalisp_genesis       144    
adalisp_genesis       145    -- Get the env of a closure cell (in practice, the pair cdr)
adalisp_genesis       146    function Get_Closure_Env(C : Cell) return MemPtr is
adalisp_genesis       147    begin
adalisp_genesis       148       return Get_Cdr(C);
adalisp_genesis       149    end Get_Closure_Env;
adalisp_genesis       150    
adalisp_genesis       151    -- Setters.
adalisp_genesis       152    
adalisp_genesis       153    -- Set the value of a builtin cell.
adalisp_genesis       154    procedure Set_Builtin(C : in out Cell; B : in BuiltinID) is
adalisp_genesis       155       Index : Integer := -1;
adalisp_genesis       156    begin
adalisp_genesis       157       pragma Assert (C.T = Builtin, "Not a builtin cell!");
adalisp_genesis       158       -- Lookup builtin in table
adalisp_genesis       159       for I in 0..(BuiltinTable'Length - 1) loop
adalisp_genesis       160          if BuiltinTable(I).BiValue = B then
adalisp_genesis       161             Index := I;
adalisp_genesis       162             exit;
adalisp_genesis       163          end if;
adalisp_genesis       164       end loop;
adalisp_genesis       165       pragma Assert (Index /= -1, "Builtin not found.");
adalisp_genesis       166       
adalisp_genesis       167       C.Data := MWord(Index);
adalisp_genesis       168    end Set_Builtin;
adalisp_genesis       169    
adalisp_genesis       170    -- Set the car of a cons cell.
adalisp_genesis       171    procedure Set_Car(C : in out Cell; Car : in MemPtr) is
adalisp_genesis       172    begin
adalisp_genesis       173       pragma Assert (C.T = Cons or C.T = Closure,
adalisp_genesis       174                      "Not a cons cell!");
adalisp_genesis       175       C.Data := (C.Data and 16#0000_0000_FFFF_FFFF#)
adalisp_genesis       176         or Shift_Left(MWord(Car), 32);
adalisp_genesis       177    end Set_Car;
adalisp_genesis       178    
adalisp_genesis       179    -- Set the cdr of a cons cell.
adalisp_genesis       180    procedure Set_Cdr(C : in out Cell; Cdr : in MemPtr) is
adalisp_genesis       181    begin
adalisp_genesis       182       pragma Assert (C.T = Cons or C.T = Closure,
adalisp_genesis       183                      "Not a cons cell!");
adalisp_genesis       184       C.Data := (C.Data and 16#FFFF_FFFF_0000_0000#)
adalisp_genesis       185         or MWord(Cdr);
adalisp_genesis       186    end Set_Cdr;
adalisp_genesis       187    
adalisp_genesis       188    -- Set the value of a bool cell.
adalisp_genesis       189    procedure Set_Bool(C : in out Cell; Value : in Boolean) is
adalisp_genesis       190    begin
adalisp_genesis       191       pragma Assert (C.T = Bool, "Not a bool cell!");
adalisp_genesis       192       if Value then
adalisp_genesis       193          C.Data := 1;
adalisp_genesis       194       else
adalisp_genesis       195          C.Data := 0;
adalisp_genesis       196       end if;
adalisp_genesis       197    end Set_Bool;
adalisp_genesis       198    
adalisp_genesis       199    -- Set the value of a fixnum cell.
adalisp_genesis       200    procedure Set_Fixnum(C : in out Cell; Value : in Long_Integer) is
adalisp_genesis       201    begin
adalisp_genesis       202       pragma Assert (C.T = Fixnum, "Not a fixnum cell!");
adalisp_genesis       203       if Value < 0 then
adalisp_genesis       204          C.Data := not MWord(-Value) + 1;
adalisp_genesis       205       else
adalisp_genesis       206          C.Data := MWord(Value);
adalisp_genesis       207       end if;
adalisp_genesis       208    end Set_Fixnum;
adalisp_genesis       209    
adalisp_genesis       210    -- Set the value of a char cell.
adalisp_genesis       211    procedure Set_Char(C : in out Cell; Value : in Character) is
adalisp_genesis       212    begin
adalisp_genesis       213       pragma Assert (C.T = Char, "Not a char cell!");
adalisp_genesis       214       C.Data := MWord(Character'Pos(Value));
adalisp_genesis       215    end Set_Char;
adalisp_genesis       216    
adalisp_genesis       217    -- Set the name of a symbol cell.
adalisp_genesis       218    procedure Set_Symbol(C : in out Cell; Name : in MemPtr) is
adalisp_genesis       219       IsStr : Boolean := True;
adalisp_genesis       220       PList : MemPtr := Name;
adalisp_genesis       221       PCar : MemPtr;
adalisp_genesis       222    begin
adalisp_genesis       223       pragma Assert (C.T = Symbol, "Not a symbol cell!");
adalisp_genesis       224       
adalisp_genesis       225       -- Sanity check! At this point, a string is a list-of-chars, so we
adalisp_genesis       226       --  need to check that the type of list elements matches.
adalisp_genesis       227       pragma Assert (PList /= 0, "Symbol name is empty string!");
adalisp_genesis       228       while PList /= 0 loop
adalisp_genesis       229          pragma Assert (AMem(PList).T = Cons, "Not a string cons cell!");
adalisp_genesis       230          
adalisp_genesis       231          -- Get car cell and check its type
adalisp_genesis       232          PCar := Get_Car(AMem(PList));
adalisp_genesis       233          if (AMem(PCar).T /= Char) then
adalisp_genesis       234             IsStr := False;
adalisp_genesis       235             exit;
adalisp_genesis       236          end if;
adalisp_genesis       237          
adalisp_genesis       238          -- Get cdr cell
adalisp_genesis       239          PList := Get_Cdr(AMem(PList));
adalisp_genesis       240       end loop;
adalisp_genesis       241       pragma Assert(IsStr, "Symbol not a string!");
adalisp_genesis       242       
adalisp_genesis       243       C.Data := MWord(Name);
adalisp_genesis       244    end Set_Symbol;
adalisp_genesis       245    
adalisp_genesis       246    -- Set the closure code (car)
adalisp_genesis       247    procedure Set_Closure_Code(C : in out Cell; Code : in MemPtr) is
adalisp_genesis       248    begin
adalisp_genesis       249       Set_Car(C, Code);
adalisp_genesis       250    end Set_Closure_Code;
adalisp_genesis       251    
adalisp_genesis       252    -- Set the closure env (cdr)
adalisp_genesis       253    procedure Set_Closure_Env(C : in out Cell; Env : in MemPtr) is
adalisp_genesis       254    begin
adalisp_genesis       255       Set_Cdr(C, Env);
adalisp_genesis       256    end Set_Closure_Env;
adalisp_genesis       257    
adalisp_genesis       258    -- Allocate new cell in Lisp machine memory.
adalisp_genesis       259    procedure Alloc_Cell(C : in Cell; P : out MemPtr) is
adalisp_genesis       260    begin
adalisp_genesis       261       -- For now we just increase the heap and add the new cell.
adalisp_genesis       262       
adalisp_genesis       263       -- Increase heap size
adalisp_genesis       264       Heap_End := Heap_End + 1;
adalisp_genesis       265       -- Check that we're overwriting a free cell.
adalisp_genesis       266       pragma Assert (AMem(Heap_End).T = Free,
adalisp_genesis       267                      "Alloc_Cell using a non-free cell.");
adalisp_genesis       268       -- Assign given cell value
adalisp_genesis       269       AMem(Heap_End) := C;
adalisp_genesis       270       -- Set P to point to new pointer
adalisp_genesis       271       P := Heap_End;
adalisp_genesis       272    end Alloc_Cell;
adalisp_genesis       273    
adalisp_genesis       274    -- Allocate builtin cell.
adalisp_genesis       275    procedure Alloc_Builtin(B : BuiltinID; P : out MemPtr) is
adalisp_genesis       276    begin
adalisp_genesis       277       Alloc_Cell((T => Builtin, Data => 0), P);
adalisp_genesis       278       Set_Builtin(AMem(P), B);
adalisp_genesis       279    end Alloc_Builtin;
adalisp_genesis       280    
adalisp_genesis       281    -- Allocate a cons cell.
adalisp_genesis       282    procedure Alloc_Cons(Car, Cdr : in MemPtr; P : out MemPtr) is
adalisp_genesis       283    begin
adalisp_genesis       284       Alloc_Cell((T => Cons, Data => 0), P);
adalisp_genesis       285       Set_Car(AMem(P), Car);
adalisp_genesis       286       Set_Cdr(AMem(P), Cdr);
adalisp_genesis       287    end Alloc_Cons;
adalisp_genesis       288    
adalisp_genesis       289    -- Allocate a bool cell.
adalisp_genesis       290    procedure Alloc_Bool(Value : in Boolean; P : out MemPtr) is
adalisp_genesis       291    begin
adalisp_genesis       292       Alloc_Cell((T => Bool, Data => 0), P);
adalisp_genesis       293       Set_Bool(AMem(P), Value);
adalisp_genesis       294    end Alloc_Bool;
adalisp_genesis       295 
adalisp_genesis       296    -- Allocate a fixnum cell.
adalisp_genesis       297    procedure Alloc_Fixnum(Value : in Long_Integer; P : out MemPtr) is
adalisp_genesis       298    begin
adalisp_genesis       299       Alloc_Cell((T => Fixnum, Data => 0), P);
adalisp_genesis       300       Set_Fixnum(AMem(P), Value);
adalisp_genesis       301    end Alloc_Fixnum;
adalisp_genesis       302    
adalisp_genesis       303    -- Allocate a char cell.
adalisp_genesis       304    procedure Alloc_Char(Value : in Character; P : out MemPtr) is
adalisp_genesis       305    begin
adalisp_genesis       306       Alloc_Cell((T => Char, Data => 0), P);
adalisp_genesis       307       Set_Char(AMem(P), Value);
adalisp_genesis       308    end Alloc_Char;
adalisp_genesis       309 
adalisp_genesis       310    -- Allocate a symbol cell.
adalisp_genesis       311    procedure Alloc_Symbol(Name : in MemPtr; P : out MemPtr) is
adalisp_genesis       312    begin
adalisp_genesis       313       Alloc_Cell((T => Symbol, Data => 0), P);
adalisp_genesis       314       Set_Symbol(AMem(P), Name);
adalisp_genesis       315    end Alloc_Symbol;
adalisp_genesis       316    
adalisp_genesis       317    -- Allocate a closure cell.
adalisp_genesis       318    procedure Alloc_Closure(Code, Env : in MemPtr; P : out MemPtr) is
adalisp_genesis       319    begin
adalisp_genesis       320       Alloc_Cell((T => Closure, Data => 0), P);
adalisp_genesis       321       Set_Closure_Code(AMem(P), Code);
adalisp_genesis       322       Set_Closure_Env(AMem(P), Env);
adalisp_genesis       323    end Alloc_Closure;
adalisp_genesis       324    
adalisp_genesis       325    -- Dump cell from Lisp machine memory.
adalisp_genesis       326    procedure Dump_Cell(P : in MemPtr) is
adalisp_genesis       327       use Ada.Text_IO;
adalisp_genesis       328 
adalisp_genesis       329       C : Cell;
adalisp_genesis       330    begin
adalisp_genesis       331       -- Check for NIL.
adalisp_genesis       332       if (P = 0) then
adalisp_genesis       333          -- Scheme notation.
adalisp_genesis       334          Put("()");
adalisp_genesis       335          return;
adalisp_genesis       336       end if;
adalisp_genesis       337 
adalisp_genesis       338       -- Otherwise our cell lies in AMem. It's either a free cell or it
adalisp_genesis       339       --  has some allocated data in it.
adalisp_genesis       340       C := AMem(P);
adalisp_genesis       341       case C.T is
adalisp_genesis       342          when Free =>
adalisp_genesis       343             Put("<free cell>");
adalisp_genesis       344          when Builtin =>
adalisp_genesis       345             -- XXX check whether the builtin is a function or a keyword.
adalisp_genesis       346             Put("<builtin func ");
adalisp_genesis       347             Dump_BuiltinID(Get_Builtin(C));
adalisp_genesis       348             Put(">");
adalisp_genesis       349          when Cons =>
adalisp_genesis       350             Dump_Cons(P);
adalisp_genesis       351          when Bool =>
adalisp_genesis       352             if C.Data = 0 then
adalisp_genesis       353                Put("#f");
adalisp_genesis       354             else
adalisp_genesis       355                Put("#t");
adalisp_genesis       356             end if;
adalisp_genesis       357          when Fixnum =>
adalisp_genesis       358             Dump_Longint(Get_Fixnum(C));
adalisp_genesis       359          when Char =>
adalisp_genesis       360             Put("#\");
adalisp_genesis       361             if Get_Char(C) = ' ' then
adalisp_genesis       362                Put("space");
adalisp_genesis       363             else
adalisp_genesis       364                Put(Get_Char(C));
adalisp_genesis       365             end if;
adalisp_genesis       366          when Symbol =>
adalisp_genesis       367             Dump_String(Get_Symbol(C));
adalisp_genesis       368          when Closure =>
adalisp_genesis       369             Put("<closure>");
adalisp_genesis       370       end case;
adalisp_genesis       371    end Dump_Cell;
adalisp_genesis       372    
adalisp_genesis       373    -- Recursively dump a cons cell, doing sugary processing.
adalisp_genesis       374    procedure Dump_Cons(P : in MemPtr) is
adalisp_genesis       375       use Ada.Text_IO;
adalisp_genesis       376       
adalisp_genesis       377       C : Cell;
adalisp_genesis       378    begin
adalisp_genesis       379       -- Initialization and sanity checks
adalisp_genesis       380       pragma Assert (P /= 0, "List must be non-empty.");
adalisp_genesis       381       C := AMem(P);
adalisp_genesis       382       pragma Assert (C.T = Cons,
adalisp_genesis       383                      "Dump_Cons must receive pointer to a Cons cell.");
adalisp_genesis       384       
adalisp_genesis       385       -- Special processing: if our cons is a list of the form (quote
adalisp_genesis       386       --  expr), print 'expr.
adalisp_genesis       387       declare
adalisp_genesis       388          CarP, CdrP, CadrP : MemPtr;
adalisp_genesis       389       begin
adalisp_genesis       390          CarP := Get_Car(C);
adalisp_genesis       391          CdrP := Get_Cdr(C);
adalisp_genesis       392          -- Car(P) = Quote_Sym?
adalisp_genesis       393          if CarP = Quote_Sym then
adalisp_genesis       394             -- Cdr(P) /= 0?
adalisp_genesis       395             if CdrP = 0 then
adalisp_genesis       396                Put("()");
adalisp_genesis       397                return;
adalisp_genesis       398             end if;
adalisp_genesis       399             -- Get Cadr(P)
adalisp_genesis       400             CadrP := Get_Car(AMem(CdrP));
adalisp_genesis       401             -- 'expr
adalisp_genesis       402             Put("'");
adalisp_genesis       403             Dump_Cell(CadrP);
adalisp_genesis       404             return;
adalisp_genesis       405          end if;
adalisp_genesis       406       end;
adalisp_genesis       407       
adalisp_genesis       408       -- This cons cell may be a list, so we iterate through it as
adalisp_genesis       409       --  long as possible and recursively call ourselves.
adalisp_genesis       410       Put("(");
adalisp_genesis       411       Dump_Cell(Get_Car(C));
adalisp_genesis       412             
adalisp_genesis       413       -- XXX This will fail *hard* for circular lists!
adalisp_genesis       414       while Get_Cdr(C) /= 0 loop
adalisp_genesis       415          -- Exit if cdr(C).tag /= cons.
adalisp_genesis       416          exit when (AMem(Get_Cdr(C)).T /= Cons);
adalisp_genesis       417          C := AMem(Get_Cdr(C));
adalisp_genesis       418          
adalisp_genesis       419          Put(" ");
adalisp_genesis       420          Dump_Cell(Get_Car(C));
adalisp_genesis       421       end loop;
adalisp_genesis       422 
adalisp_genesis       423       -- What remains should be either a NIL or some other
adalisp_genesis       424       --  value. In the latter case, print it in dotted format.
adalisp_genesis       425       if Get_Cdr(C) /= 0 then
adalisp_genesis       426          Put(" . ");
adalisp_genesis       427          Dump_Cell(Get_Cdr(C));
adalisp_genesis       428       end if;
adalisp_genesis       429       Put(")");
adalisp_genesis       430    end Dump_Cons;
adalisp_genesis       431    
adalisp_genesis       432    procedure Dump_Longint(N : in Long_Integer) is
adalisp_genesis       433       use Ada.Text_IO;
adalisp_genesis       434       
adalisp_genesis       435       N1, N2 : Long_Integer;
adalisp_genesis       436       Num_Digits : Integer;
adalisp_genesis       437    begin
adalisp_genesis       438       -- 0
adalisp_genesis       439       if N = 0 then
adalisp_genesis       440          Put("0");
adalisp_genesis       441          return;
adalisp_genesis       442       end if;
adalisp_genesis       443       
adalisp_genesis       444       -- Check whether N is negative
adalisp_genesis       445       if N < 0 then
adalisp_genesis       446          Put('-');
adalisp_genesis       447          N1 := -N;
adalisp_genesis       448       else
adalisp_genesis       449          N1 := N;
adalisp_genesis       450       end if;
adalisp_genesis       451       
adalisp_genesis       452       -- Compute the number of digits
adalisp_genesis       453       N2 := 0;
adalisp_genesis       454       Num_Digits := 0;
adalisp_genesis       455       while N1 /= 0 loop
adalisp_genesis       456          N2 := N2 * 10 + N1 rem 10;
adalisp_genesis       457          N1 := N1 / 10;
adalisp_genesis       458          Num_Digits := Num_Digits + 1;
adalisp_genesis       459       end loop;
adalisp_genesis       460       -- Same, but algorithm, but print digit by digit
adalisp_genesis       461       while Num_Digits > 0 loop
adalisp_genesis       462          N1 := N2 rem 10;
adalisp_genesis       463          N2 := N2 / 10;
adalisp_genesis       464          Put(Character'Val(N1 + Character'Pos('0')));
adalisp_genesis       465          Num_Digits := Num_Digits - 1;
adalisp_genesis       466       end loop;
adalisp_genesis       467    end Dump_Longint;
adalisp_genesis       468    
adalisp_genesis       469    procedure Dump_BuiltinID(BID : in BuiltinID) is
adalisp_genesis       470       use Ada.Text_IO;
adalisp_genesis       471    begin
adalisp_genesis       472       case BID is
adalisp_genesis       473          when AddB => Put("+");
adalisp_genesis       474          when SubB => Put("-");
adalisp_genesis       475          when MulB => Put("*");
adalisp_genesis       476          when DivB => Put("/");
adalisp_genesis       477          when QuoteB => Put("quote");
adalisp_genesis       478          when EvalB => Put("eval");
adalisp_genesis       479          when IfB => Put("if");
adalisp_genesis       480          when ConsB => Put("cons");
adalisp_genesis       481          when CarB => Put("car");
adalisp_genesis       482          when CdrB => Put("cdr");
adalisp_genesis       483          when ListB => Put("list");
adalisp_genesis       484          when ApplyB => Put("apply");
adalisp_genesis       485          when DefineB => Put("define");
adalisp_genesis       486          when SetB => Put("set");
adalisp_genesis       487          when EqnB => Put("eqn");
adalisp_genesis       488          when EqB => Put("eq");
adalisp_genesis       489          when EqvB => Put("eqv");
adalisp_genesis       490          when PairPB => Put("pairp");
adalisp_genesis       491          when BooleanPB => Put("booleanp");
adalisp_genesis       492          when NumberPB => Put("numberp");
adalisp_genesis       493          when SymbolPB => Put("symbolp");
adalisp_genesis       494          when NullPB => Put("nullp");
adalisp_genesis       495          when ListPB => Put("listp");
adalisp_genesis       496          when AndB => Put("and");
adalisp_genesis       497          when OrB => Put("or");
adalisp_genesis       498          when NotB => Put("not");
adalisp_genesis       499          when LambdaB => Put("lambda");
adalisp_genesis       500          when LetB => Put("let");
adalisp_genesis       501          when ReverseB => Put("reverse");
adalisp_genesis       502          when AppendB => Put("append");
adalisp_genesis       503       end case;
adalisp_genesis       504    end Dump_BuiltinID;
adalisp_genesis       505    
adalisp_genesis       506    -- Dump string represented as list of characters.
adalisp_genesis       507    procedure Dump_String(P : in MemPtr) is
adalisp_genesis       508       use Ada.Text_IO;
adalisp_genesis       509 
adalisp_genesis       510       CarP, ListP : MemPtr;
adalisp_genesis       511    begin
adalisp_genesis       512       ListP := P;
adalisp_genesis       513       while ListP /= 0 loop         
adalisp_genesis       514          pragma Assert(AMem(ListP).T = Cons, "Not a string-as-list!");
adalisp_genesis       515          CarP := Get_Car(AMem(ListP));
adalisp_genesis       516          
adalisp_genesis       517          -- print elem.
adalisp_genesis       518          pragma Assert(AMem(CarP).T = Char, "Not a list of chars!");
adalisp_genesis       519          Put(Get_Char(AMem(CarP)));
adalisp_genesis       520          
adalisp_genesis       521          -- next
adalisp_genesis       522          ListP := Get_Cdr(AMem(ListP));
adalisp_genesis       523       end loop;
adalisp_genesis       524    end Dump_String;
adalisp_genesis       525    
adalisp_genesis       526    -- Init default bindings to builtin functions
adalisp_genesis       527    procedure Init_Builtin_Bindings is
adalisp_genesis       528       BuiltinP : MemPtr;
adalisp_genesis       529       SymP : MemPtr;
adalisp_genesis       530       CharP : MemPtr;
adalisp_genesis       531       NameP : MemPtr;
adalisp_genesis       532    begin
adalisp_genesis       533       -- Allocate symbol-value pair for each builtin, and add it to the
adalisp_genesis       534       --  front of Symbol_Table list.      
adalisp_genesis       535       for I in 0..(BuiltinTable'Length - 1) loop
adalisp_genesis       536          -- allocate builtin
adalisp_genesis       537          Alloc_Builtin(BuiltinTable(I).BiValue, BuiltinP);
adalisp_genesis       538          -- allocate name
adalisp_genesis       539          NameP := 0;
adalisp_genesis       540          for K in reverse BuiltinTable(I).BiName'Range loop
adalisp_genesis       541             -- skip spaces
adalisp_genesis       542             if BuiltinTable(I).BiName(K) /= ' ' then
adalisp_genesis       543                Alloc_Char(BuiltinTable(I).BiName(K), CharP);
adalisp_genesis       544                Alloc_Cons(CharP, NameP, NameP);
adalisp_genesis       545             end if;
adalisp_genesis       546          end loop;
adalisp_genesis       547          pragma Assert(NameP /= 0, "Name is empty!");
adalisp_genesis       548          Alloc_Symbol(NameP, SymP); -- create symbol
adalisp_genesis       549          Alloc_Cons(SymP, Sym_Table, Sym_Table); -- intern
adalisp_genesis       550          Bind_Env(SymP, BuiltinP, Global_Env, SymP); -- bind in global namespace
adalisp_genesis       551       end loop;
adalisp_genesis       552       
adalisp_genesis       553       -- XXX: Set Quote_Sym to be used by parser routine to convert the
adalisp_genesis       554       --  quote token to a proper S-expression. This is quite a
adalisp_genesis       555       --  hack, quote symbol could be represented as its own constant by
adalisp_genesis       556       --  lispm.
adalisp_genesis       557       NameP := 0;
adalisp_genesis       558       for K in reverse Quote_Name'Range loop
adalisp_genesis       559          Alloc_Char(Quote_Name(K), CharP);
adalisp_genesis       560          Alloc_Cons(CharP, NameP, NameP);
adalisp_genesis       561       end loop;
adalisp_genesis       562 
adalisp_genesis       563       Lookup_Symbol(NameP, Quote_Sym);
adalisp_genesis       564       
adalisp_genesis       565       -- Use these for debugging.
adalisp_genesis       566 
adalisp_genesis       567       --  Dump_Cell(Sym_Table);
adalisp_genesis       568       --  Dump_Cell(Global_Env);
adalisp_genesis       569    end Init_Builtin_Bindings;
adalisp_genesis       570    
adalisp_genesis       571    function Name_EqualP(Sym1, Sym2 : MemPtr) return Boolean is
adalisp_genesis       572       TempStr1, TempStr2 : MemPtr;
adalisp_genesis       573       P1, P2 : MemPtr;
adalisp_genesis       574       C1, C2 : Character;
adalisp_genesis       575       Same : Boolean := True;
adalisp_genesis       576    begin
adalisp_genesis       577       TempStr1 := Sym1;
adalisp_genesis       578       TempStr2 := Sym2;
adalisp_genesis       579       -- Compare strings character by character: iterate while any of
adalisp_genesis       580       --  the strings are not NIL.
adalisp_genesis       581       while TempStr1 /= 0 or TempStr2 /= 0 loop
adalisp_genesis       582          -- If any of them is NIL, then stop and return false.
adalisp_genesis       583          if TempStr1 = 0 or TempStr2 = 0 then
adalisp_genesis       584             Same := False;
adalisp_genesis       585             exit;
adalisp_genesis       586          end if;
adalisp_genesis       587          -- Otherwise, do the cars match?
adalisp_genesis       588          P1 := Get_Car(AMem(TempStr1)); C1 := Get_Char(AMem(P1));
adalisp_genesis       589          P2 := Get_Car(AMem(TempStr2)); C2 := Get_Char(AMem(P2));
adalisp_genesis       590          if C1 /= C2 then
adalisp_genesis       591             Same := False;
adalisp_genesis       592             exit;
adalisp_genesis       593          end if;
adalisp_genesis       594          -- If they do, check the rest.
adalisp_genesis       595          TempStr1 := Get_Cdr(AMem(TempStr1));
adalisp_genesis       596          TempStr2 := Get_Cdr(AMem(TempStr2));
adalisp_genesis       597       end loop;
adalisp_genesis       598       
adalisp_genesis       599       return Same;
adalisp_genesis       600    end Name_EqualP;
adalisp_genesis       601    
adalisp_genesis       602    -- Lookup Sym_Table for symbol whose name field is equal to Name.
adalisp_genesis       603    procedure Lookup_Symbol(Name : in MemPtr; Sym : out MemPtr) is
adalisp_genesis       604       ListP : MemPtr := Sym_Table;
adalisp_genesis       605    begin
adalisp_genesis       606       -- Assume we haven't found a value
adalisp_genesis       607       Sym := 0;
adalisp_genesis       608       
adalisp_genesis       609       -- Iterate through Sym_Table
adalisp_genesis       610       while ListP /= 0 loop
adalisp_genesis       611         declare
adalisp_genesis       612            CurrSym : MemPtr := Get_Car(AMem(ListP));
adalisp_genesis       613            CurrName : MemPtr;
adalisp_genesis       614         begin
adalisp_genesis       615            pragma Assert(CurrSym /= 0, "Sym_Table contains a NIL symbol!");
adalisp_genesis       616            pragma Assert(AMem(CurrSym).T = Symbol,
adalisp_genesis       617                          "Sym_Table contains a non-symbol!");
adalisp_genesis       618            -- Compare the given symbol name with the current alist value.
adalisp_genesis       619            CurrName := Get_Symbol(AMem(CurrSym));
adalisp_genesis       620            -- Found?
adalisp_genesis       621            if Name_EqualP(Name, CurrName) then
adalisp_genesis       622               Sym := CurrSym;
adalisp_genesis       623               exit;
adalisp_genesis       624            end if;
adalisp_genesis       625            -- Otherwise keep looking
adalisp_genesis       626            ListP := Get_Cdr(AMem(ListP));
adalisp_genesis       627         end;
adalisp_genesis       628       end loop;
adalisp_genesis       629    end Lookup_Symbol;
adalisp_genesis       630    
adalisp_genesis       631    -- Lookup Name in Sym_Table; if non-existent, add a new (Name . NIL)
adalisp_genesis       632    --  pair to the table and set NameVal to it.
adalisp_genesis       633    procedure Lookup_Or_Create_Symbol(Name : in MemPtr; Sym: out MemPtr) is
adalisp_genesis       634       TempSym : MemPtr;
adalisp_genesis       635    begin
adalisp_genesis       636       -- Lookup for Name
adalisp_genesis       637       Lookup_Symbol(Name, TempSym);
adalisp_genesis       638       -- If not found, intern Name
adalisp_genesis       639       if TempSym = 0 then
adalisp_genesis       640          Alloc_Symbol(Name, TempSym);
adalisp_genesis       641          Alloc_Cons(TempSym, Sym_Table, Sym_Table);
adalisp_genesis       642       end if;
adalisp_genesis       643       -- Return symbol
adalisp_genesis       644       Sym := TempSym;
adalisp_genesis       645    end Lookup_Or_Create_Symbol;
adalisp_genesis       646    
adalisp_genesis       647    -- Lookup Sym in Env set Binding to the Sym-Value pair if found.
adalisp_genesis       648    procedure Lookup_Env(Sym, Env : in MemPtr; Binding : out MemPtr) is
adalisp_genesis       649       EnvP : MemPtr := Env;
adalisp_genesis       650    begin
adalisp_genesis       651       -- NIL by default
adalisp_genesis       652       Binding := 0;
adalisp_genesis       653       
adalisp_genesis       654       while EnvP /= 0 loop
adalisp_genesis       655          declare
adalisp_genesis       656             CurrBinding : MemPtr := Get_Car(AMem(EnvP));
adalisp_genesis       657             CurrSym : MemPtr;
adalisp_genesis       658          begin
adalisp_genesis       659             pragma Assert (CurrBinding /= 0, "NIL binding in Env!");
adalisp_genesis       660             -- Get symbol of current binding
adalisp_genesis       661             CurrSym := Get_Car(AMem(CurrBinding));
adalisp_genesis       662             pragma Assert(AMem(CurrSym).T = Symbol, "Not a symbol!");
adalisp_genesis       663             -- Compare symbols pointer-wise
adalisp_genesis       664             if Sym = CurrSym then
adalisp_genesis       665                Binding := CurrBinding;
adalisp_genesis       666                exit;
adalisp_genesis       667             end if;
adalisp_genesis       668             EnvP := Get_Cdr(AMem(EnvP));
adalisp_genesis       669          end;
adalisp_genesis       670       end loop;   
adalisp_genesis       671    end Lookup_Env;
adalisp_genesis       672    
adalisp_genesis       673    -- Lookup value of Sym in Env or Global_Env
adalisp_genesis       674    procedure Lookup_Env_Or_Global(Sym, Env : in MemPtr;
adalisp_genesis       675                                   Binding : out MemPtr) is
adalisp_genesis       676       TempP : MemPtr;
adalisp_genesis       677    begin
adalisp_genesis       678       Lookup_Env(Sym, Env, TempP);
adalisp_genesis       679       if TempP = 0 then
adalisp_genesis       680          Lookup_Env(Sym, Global_Env, Binding);
adalisp_genesis       681       else
adalisp_genesis       682          Binding := TempP;
adalisp_genesis       683       end if;
adalisp_genesis       684    end Lookup_Env_Or_Global;
adalisp_genesis       685    
adalisp_genesis       686    -- Add Sym-Value binding in Env and set Binding to the new pair.
adalisp_genesis       687    procedure Bind_Env(Sym, Value : in MemPtr;
adalisp_genesis       688                       Env : in out MemPtr; Binding : out MemPtr) is
adalisp_genesis       689       TempP : MemPtr;
adalisp_genesis       690    begin
adalisp_genesis       691       Alloc_Cons(Sym, Value, TempP); -- create pair
adalisp_genesis       692       Alloc_Cons(TempP, Env, Env); -- cons pair to env
adalisp_genesis       693       
adalisp_genesis       694       Binding := TempP; -- return pair.
adalisp_genesis       695    end Bind_Env;
adalisp_genesis       696 end LispM;