raw
adalisp_genesis         1 -- Basic lisp machine memory and data representation. The basic memory
adalisp_genesis         2 --  unit of lisp machines is a cell of the form [ tag | data ]. Lisp
adalisp_genesis         3 --  memory is an array of such cells, with cell index 0 being reserved
adalisp_genesis         4 --  for the special value NIL.
adalisp_genesis         5 package LispM is
adalisp_genesis         6    -- 8MCells should be enough for everyone
adalisp_genesis         7    Mem_Size : constant := 2**23;
adalisp_genesis         8    
adalisp_genesis         9    -- Machine words
adalisp_genesis        10    type MWord is mod 2 ** 64;
adalisp_genesis        11    for MWord'Size use 64;
adalisp_genesis        12    
adalisp_genesis        13    -- Cell tags.
adalisp_genesis        14    type Tag is (Free, Builtin, Cons, Bool, Fixnum, Char, Symbol, Closure);
adalisp_genesis        15    type MemPtr is range 0 .. Mem_Size;
adalisp_genesis        16    
adalisp_genesis        17    -- Built-in functions are tied in to a conceptual arithmetic-logic
adalisp_genesis        18    --  unit that provides the building blocks for evaluation.
adalisp_genesis        19    type BuiltinID is (AddB, SubB, MulB, DivB, QuoteB, EvalB, IfB,
adalisp_genesis        20                       ConsB, CarB, CdrB, ListB, ApplyB, DefineB, SetB,
adalisp_genesis        21                       EqnB, EqB, EqvB, PairPB, BooleanPB, NumberPB, SymbolPB,
adalisp_genesis        22                       NullPB, ListPB, AndB, OrB, NotB, LambdaB, LetB,
adalisp_genesis        23                       ReverseB, AppendB);
adalisp_genesis        24 
adalisp_genesis        25    -- Cell data type. The first part of any cell is a tag. The second
adalisp_genesis        26    --  part is a tag-dependent machine word.
adalisp_genesis        27    --
adalisp_genesis        28    -- Machine words are defined by tag, as follows:
adalisp_genesis        29    --
adalisp_genesis        30    -- [ free | 0 ]
adalisp_genesis        31    --
adalisp_genesis        32    -- [ builtin | bid ] where bid is a number corresponding uniquely to
adalisp_genesis        33    --  a BuiltinID.
adalisp_genesis        34    --
adalisp_genesis        35    -- [ cons | car, cdr ] where car and cdr are each half of an MWord.
adalisp_genesis        36    --
adalisp_genesis        37    -- [ bool | b ] where b is a truth value (0 is false, 1 is true). XXX
adalisp_genesis        38    --  bool values should be hardcoded symbols (or something similar).
adalisp_genesis        39    --
adalisp_genesis        40    -- [ fixnum | n ] where n is a signed integer of MWord size / 2, the
adalisp_genesis        41    --  first bit being a sign bit.
adalisp_genesis        42    --
adalisp_genesis        43    -- [ char | c ] where c is the ASCII code of a character.
adalisp_genesis        44    --
adalisp_genesis        45    -- [ symbol | ptr ] where ptr points to a list of characters uniquely
adalisp_genesis        46    --  determining the symbol's name.
adalisp_genesis        47    --
adalisp_genesis        48    -- [ closure | code, env ] where code points to a list of the form
adalisp_genesis        49    --  (args e1 e2 ... en) (where args is a list of symbols) and env
adalisp_genesis        50    --  points to a symbol-value alist.
adalisp_genesis        51    type Cell is record
adalisp_genesis        52       T : Tag;
adalisp_genesis        53       Data : MWord;
adalisp_genesis        54    end record;
adalisp_genesis        55 
adalisp_genesis        56    -- This puts it all together.
adalisp_genesis        57    type Mem is array (MemPtr range 1 .. Mem_Size) of Cell;
adalisp_genesis        58 
adalisp_genesis        59    -- Pointer to heap end. This is incremented on memory
adalisp_genesis        60    --  allocations. Don't worry about deallocations for now, since we
adalisp_genesis        61    --  don't have a GC (yet).
adalisp_genesis        62    Heap_End : MemPtr := 0;
adalisp_genesis        63    
adalisp_genesis        64    -- Pointer to interned symbol list.
adalisp_genesis        65    Sym_Table : MemPtr := 0;
adalisp_genesis        66    -- Pointer to interned symbol representing the "quote" keyword. This
adalisp_genesis        67    --  is used by the parser to transform ' tokens into (quote ...).
adalisp_genesis        68    Quote_Sym : MemPtr := 0;
adalisp_genesis        69    
adalisp_genesis        70    -- Pointer to environment: the environment is a list of symbol-value
adalisp_genesis        71    --  associations; a symbol may have more than one associations at a
adalisp_genesis        72    --  given point in time, in which case the most recent association
adalisp_genesis        73    --  will be considered.
adalisp_genesis        74    Global_Env : MemPtr := 0;
adalisp_genesis        75 
adalisp_genesis        76    -- A statically-allocated memory.
adalisp_genesis        77    AMem : Mem := (others => (T => Free, Data => 0));
adalisp_genesis        78    
adalisp_genesis        79    -- Cell manipulation primitives.
adalisp_genesis        80    function Get_Builtin(C : Cell) return BuiltinID;
adalisp_genesis        81    function Get_Car(C : Cell) return MemPtr;
adalisp_genesis        82    function Get_Cdr(C : Cell) return MemPtr;
adalisp_genesis        83    function Get_Bool(C : Cell) return Boolean;
adalisp_genesis        84    function Get_Fixnum(C : Cell) return Long_Integer;
adalisp_genesis        85    function Get_Char(C : Cell) return Character;
adalisp_genesis        86    function Get_Symbol(C : Cell) return MemPtr;
adalisp_genesis        87    function Get_Closure_Code(C : Cell) return MemPtr;
adalisp_genesis        88    function Get_Closure_Env(C : Cell) return MemPtr;
adalisp_genesis        89    procedure Set_Builtin(C : in out Cell; B : in BuiltinID);
adalisp_genesis        90    procedure Set_Car(C : in out Cell; Car : in MemPtr);
adalisp_genesis        91    procedure Set_Cdr(C : in out Cell; Cdr : in MemPtr);
adalisp_genesis        92    procedure Set_Bool(C : in out Cell; Value : in Boolean);
adalisp_genesis        93    procedure Set_Fixnum(C : in out Cell; Value : in Long_Integer);
adalisp_genesis        94    procedure Set_Char(C : in out Cell; Value : in Character);
adalisp_genesis        95    procedure Set_Symbol(C : in out Cell; Name : in MemPtr);
adalisp_genesis        96    procedure Set_Closure_Code(C : in out Cell; Code : in MemPtr);
adalisp_genesis        97    procedure Set_Closure_Env(C : in out Cell; Env : in MemPtr);
adalisp_genesis        98    
adalisp_genesis        99    -- Memory management primitives.
adalisp_genesis       100 
adalisp_genesis       101    -- Allocate cell in AMem.
adalisp_genesis       102    procedure Alloc_Cell(C : in Cell; P : out MemPtr);
adalisp_genesis       103    -- Higher-level allocation primitives
adalisp_genesis       104    procedure Alloc_Builtin(B : BuiltinID; P : out MemPtr);
adalisp_genesis       105    procedure Alloc_Cons(Car, Cdr : in MemPtr; P : out MemPtr);
adalisp_genesis       106    procedure Alloc_Bool(Value : in Boolean; P : out MemPtr);
adalisp_genesis       107    procedure Alloc_Fixnum(Value : in Long_Integer; P : out MemPtr);
adalisp_genesis       108    procedure Alloc_Char(Value : in Character; P : out MemPtr);
adalisp_genesis       109    procedure Alloc_Symbol(Name : in MemPtr; P : out MemPtr);
adalisp_genesis       110    procedure Alloc_Closure(Code, Env : in MemPtr; P : out MemPtr);
adalisp_genesis       111    
adalisp_genesis       112    -- I/O: output primitives. XXX these should be placed in a separate
adalisp_genesis       113    --  module.
adalisp_genesis       114    
adalisp_genesis       115    -- Dump cell to standard output.
adalisp_genesis       116    procedure Dump_Cell(P : in MemPtr);
adalisp_genesis       117    
adalisp_genesis       118    -- Recursively dump a cons cell, doing sugary processing.
adalisp_genesis       119    procedure Dump_Cons(P : in MemPtr);
adalisp_genesis       120    
adalisp_genesis       121    -- Dump a long integer
adalisp_genesis       122    procedure Dump_Longint(N : in Long_Integer);
adalisp_genesis       123    
adalisp_genesis       124    -- Dump the name of a builtin id
adalisp_genesis       125    procedure Dump_BuiltinID(BID : in BuiltinID);
adalisp_genesis       126    
adalisp_genesis       127    -- Dump a sequence of chars represented as a list.
adalisp_genesis       128    procedure Dump_String(P : in MemPtr);
adalisp_genesis       129    
adalisp_genesis       130    -- Init symbol table to a list of known symbols and add their
adalisp_genesis       131    --  bindings to builtins to the global environment.
adalisp_genesis       132    procedure Init_Builtin_Bindings;
adalisp_genesis       133    
adalisp_genesis       134    -- Check whether two symbol names are equal.
adalisp_genesis       135    function Name_EqualP(Sym1, Sym2 : MemPtr) return Boolean;
adalisp_genesis       136    
adalisp_genesis       137    -- Lookup symbol in symbol table. Return a pointer to a the unique
adalisp_genesis       138    --  symbol object representing it if found, NIL otherwise.
adalisp_genesis       139    procedure Lookup_Symbol(Name : in MemPtr; Sym : out MemPtr);
adalisp_genesis       140    
adalisp_genesis       141    -- Similar to Lookup_Symbol, only if the name does not exist, we
adalisp_genesis       142    --  create and add a new symbol object to the symbol table, and we
adalisp_genesis       143    --  return it.
adalisp_genesis       144    procedure Lookup_Or_Create_Symbol(Name : in MemPtr;
adalisp_genesis       145                                      Sym : out MemPtr);
adalisp_genesis       146    
adalisp_genesis       147    -- Lookup a binding for Sym in Env. Returns a symbol-value pair if it
adalisp_genesis       148    --  exists, NIL otherwise.
adalisp_genesis       149    procedure Lookup_Env(Sym, Env : in MemPtr; Binding : out MemPtr);
adalisp_genesis       150    -- Similar to Lookup_Env, only also try Global_Env
adalisp_genesis       151    procedure Lookup_Env_Or_Global(Sym, Env : in MemPtr;
adalisp_genesis       152                                   Binding : out MemPtr);
adalisp_genesis       153 
adalisp_genesis       154    -- Add a Sym-Value binding in Env. Returns the new binding.
adalisp_genesis       155    procedure Bind_Env(Sym, Value : in MemPtr;
adalisp_genesis       156                       Env : in out MemPtr; Binding : out MemPtr);
adalisp_genesis       157 end LispM;