--------------------------------------------------------------------- -- ##### # # ##### -- # # #### # # ###### # # ###### # # # # -- # # # # # # ## ## # # # # -- ##### # ###### ##### # ## # ##### ##### ####### ##### -- # # # # # # # # # # # -- # # # # # # # # # # # # # -- ##### #### # # ###### # # ###### # # ####### -- -- Literal -- Number: 1, 10 -- String: "hello" -- -- Environment -- The environment holds the key/value pairs. -- -- Procedure -- Some builtin-procedure objects are registered to the top-level environment -- upon start-up. You can break the mapping between a name and a procedure -- as it's in the normal environment. -- -- Syntax Object -- Some syntax objects are registered upon start-up. They are handled -- very specially when the list containing one of them as the first argument -- is evaluated. -- -- Evaluation Rule -- A literal object evaluates to itself. A Symbol object evaluates to -- a value found in the environment. List evaluation is slightly more -- complex. Each element of a list is evluated using the standard evaluation -- rule. The first argument acts as a function and the rest of the arguments -- are applied to the function. An element must evaluate to a closure to be -- a function. The syntax object bypasses the normal evaluation rule and is -- evaluated according to the object-specific rule. -- --------------------------------------------------------------------- with Ada.Unchecked_Conversion; with H2.Ascii; generic type Character_Type is (<>); package H2.Scheme is ----------------------------------------------------------------------------- -- EXCEPTIONS ----------------------------------------------------------------------------- Allocation_Error: exception; Size_Error: exception; Syntax_Error: exception; Evaluation_Error: exception; Internal_Error: exception; IO_Error: exception; Divide_By_Zero_Error: exception; Numeric_String_Error: exception; type Interpreter_Record is limited private; type Interpreter_Pointer is access all Interpreter_Record; -- ----------------------------------------------------------------------------- -- While I could define Heap_Element and Heap_Size to be -- the subtype of Object_Byte and Object_Size each, they are not -- logically the same thing. -- subtype Heap_Element is Object_Byte; -- subtype Heap_Size is Object_Size; --type Heap_Element is mod 2 ** System_Byte_Bits; --type Heap_Size is range 0 .. (2 ** (System_Word_Bits - 1)) - 1; subtype Heap_Element is System_Byte; subtype Heap_Size is System_Size; -- ----------------------------------------------------------------------- -- An object pointer takes up as many bytes as a system word. Object_Pointer_Bits: constant := System_Word_Bits; Object_Pointer_Bytes: constant := Object_Pointer_Bits / System_Byte_Bits; -- I use the lower 2 bits to indicate the type of an object pointer. -- A real object pointer is typically allocated on a word boundary. -- As a result, the lower 2 bits should always be 0. Using this -- property, I keep some other values at the lower 2 bits to indicate -- some other direct values like an integer or a character. Object_Pointer_Type_Bits: constant := 2; type Object_Pointer_Type is mod 2 ** Object_Pointer_Type_Bits; Object_Pointer_Type_Pointer: constant Object_Pointer_Type := 2#00#; Object_Pointer_Type_Integer: constant Object_Pointer_Type := 2#01#; Object_Pointer_Type_Character: constant Object_Pointer_Type := 2#10#; Object_Pointer_Type_Byte: constant Object_Pointer_Type := 2#11#; Object_Pointer_Type_Mask: constant Object_Pointer_Type := 2#11#; type Object_Record; type Object_Pointer is access all Object_Record; for Object_Pointer'Size use Object_Pointer_Bits; type Object_Bit is mod 2 ** 1; --for Object_Bit'Size use 1; -- Object_Word is a numeric type as large as Object_Poinetr; type Object_Word is mod 2 ** Object_Pointer_Bits; for Object_Word'Size use Object_Pointer_Bits; type Object_Half_Word is mod 2 ** (Object_Pointer_Bits / 2); for Object_Half_Word'Size use (Object_Pointer_Bits / 2); -- Object_Signed_Word is the signed version of Object_Word. -- Note Object_Word is a modular type while this is a signed range. type Object_Signed_Word is range -(2 ** (Object_Pointer_Bits - 1)) .. +(2 ** (Object_Pointer_Bits - 1)) - 1; for Object_Signed_Word'Size use Object_Pointer_Bits; -- The actual number of bits for an integer the number of bits excluding -- the pointer type bits. Object_Integer_Bits: constant := Object_Pointer_Bits - Object_Pointer_Type_Bits; -- Object_Integer represents the range of SmallInteger. -- It defines an integer that can be held in the upper Object_Integer_Bits -- bits. Conversion functions betwen Object_Integer and Object_Pointer -- use the highest 1 bit to represent the sign after shifting. So, the -- range is shrunk further by 1 bit, resulting in -2 in the foluma below. -- ----------------------------------------------------------------------- -- type Object_Integer is range -(2 ** (Object_Integer_Bits - 2)) .. -- +(2 ** (Object_Integer_Bits - 2)) - 1; -- ----------------------------------------------------------------------- -- If i don't include -(2 ** (Object_Integer_Bits - 1)) into the range, -- it can be extended to a larger range. That's because the excluded number -- conflicts with the highest sign bit during the conversion process. -- ----------------------------------------------------------------------- type Object_Integer is range -(2 ** (Object_Integer_Bits - 1)) + 1 .. +(2 ** (Object_Integer_Bits - 1)) - 1; -- ----------------------------------------------------------------------- -- What is a better choice? TODO: decide what to use -- ----------------------------------------------------------------------- -- Let Object_Integer take up as large a space as Object_Pointer -- despite the actual range of Object_Integer. for Object_Integer'Size use Object_Pointer_Bits; -- The Object_Size type defines the size of object payload. -- It is the number of payload items for each object kind. type Object_Size is new System_Size; for Object_Size'Size use Object_Pointer_Bits; -- for GC subtype Object_Index is Object_Size range Object_Size(System_Index'First) .. Object_Size(System_Index'Last); --type Object_Byte is mod 2 ** System_Byte_Bits; --for Object_Byte'Size use System_Byte_Bits; subtype Object_Byte is System_Byte; subtype Object_Character is Character_Type; type Object_Pointer_Array is array(Object_Index range <>) of Object_Pointer; type Object_Character_Array is array(Object_Index range <>) of Object_Character; type Object_Byte_Array is array(Object_Index range <>) of Object_Byte; type Object_Word_Array is array(Object_Index range <>) of Object_Word; type Object_Half_Word_Array is array(Object_Index range <>) of Object_Half_Word; type Object_Character_Array_Pointer is access all Object_Character_Array; for Object_Character_Array_Pointer'Size use Object_Pointer_Bits; type Constant_Object_Character_Array_Pointer is access constant Object_Character_Array; for Constant_Object_Character_Array_Pointer'Size use Object_Pointer_Bits; subtype Thin_Object_Character_Array is Object_Character_Array(Object_Index'Range); type Thin_Object_Character_Array_Pointer is access all Thin_Object_Character_Array; for Thin_Object_Character_Array_Pointer'Size use Object_Pointer_Bits; type Object_Kind is ( Moved_Object, -- internal use only Pointer_Object, Character_Object, Byte_Object, Word_Object, Half_Word_Object ); for Object_Kind use ( Moved_Object => 0, Pointer_Object => 1, Character_Object => 2, Byte_Object => 3, Word_Object => 4, Half_Word_Object => 5 ); -- ----------------------------------------------------------------------- -- Object_Record contains the Flags field that can be used -- freely for management purpose. The Object_Flags type -- represents the value that can be stored in this field. type Object_Flags is mod 2 ** 4; Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); Syntax_Checked: constant Object_Flags := Object_Flags'(2#0010#); Argument_Checked: constant Object_Flags := Object_Flags'(2#0100#); type Object_Tag is ( Unknown_Object, Cons_Object, String_Object, Symbol_Object, Array_Object, Bigint_Object, Procedure_Object, Closure_Object, Continuation_Object, Frame_Object ); type Syntax_Code is ( And_Syntax, Begin_Syntax, Case_Syntax, Cond_Syntax, Define_Syntax, Do_Syntax, If_Syntax, Lambda_Syntax, Let_Syntax, Letast_Syntax, Letrec_Syntax, Or_Syntax, Quasiquote_Syntax, Quote_Syntax, Set_Syntax ); type Object_Sign is ( Positive_Sign, Negative_Sign ); type Object_Record(Kind: Object_Kind; Size: Object_Size) is record Flags: Object_Flags := 0; Tag: Object_Tag := Unknown_Object; Scode: Syntax_Code := Syntax_Code'Val(0); -- Used if Flags contain Syntax_Object Sign: Object_Sign := Positive_Sign; -- Used for Bigint_Object -- Object payload: -- I assume that the smallest payload is able to hold an -- object pointer by specifying the alignement attribute -- to Object_Pointer_Bytes and checking the minimum allocation -- size in Allocate_Bytes_In_Heap(). case Kind is when Moved_Object => New_Pointer: Object_Pointer := null; when Pointer_Object => Pointer_Slot: Object_Pointer_Array(1 .. Size) := (others => null); when Character_Object => Character_Slot: Object_Character_Array(1 .. Size) := (others => Object_Character'First); -- The character terminator is to ease integration with -- other languages using a terminating null. -- TODO: can this guarantee terminating NULL? is this -- terminator guaranteed to be placed after the -- character_slot without any gaps in between -- under the current alignement condition? Character_Terminator: Object_Character := Object_Character'First; when Byte_Object => Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0); when Word_Object => Word_Slot: Object_Word_Array(1 .. Size) := (others => 0); when Half_Word_Object => Half_Word_Slot: Object_Half_Word_Array(1 .. Size) := (others => 0); end case; end record; for Object_Record use record Kind at 0 range 0 .. 2; -- 3 bits (0 .. 7) Flags at 0 range 3 .. 6; -- 4 bits Tag at 0 range 7 .. 10; -- 4 bits (0 .. 15) Scode at 0 range 11 .. 14; -- 4 bits (0 .. 15) Sign at 0 range 15 .. 15; -- 1 bit (0 or 1) -- there are still some space unused in the first word. What can i do? end record; for Object_Record'Alignment use Object_Pointer_Bytes; -- the following 3 size types are defined for limiting the object size range. subtype Empty_Object_Record is Object_Record(Byte_Object, 0); Object_Header_Bits: constant Object_Size := Empty_Object_Record'Size; -- the number of bytes in an object header. this is fixed in size -- Object_Header_Bytes: constant Object_Size := Empty_Object_Record'Max_Size_In_Storage_Elements; Object_Header_Bytes: constant Object_Size := Object_Header_Bits / System_Byte_Bits; -- the largest number of bytes that an object can hold after the header Object_Payload_Max_Bytes: constant Object_Size := Object_Size'Last - Object_Header_Bytes; -- the following types are defined to set the byte range of the object data. -- the upper bound is set to the maximum that don't cause overflow in calcuating the size in bits. -- the compiler doesn't seem to be able to return 'Size or 'Max_Size_In_Storage_Elements properly -- when the number of bits calculated overflows. Byte_Object_Size_Last: constant Object_Size := Object_Payload_Max_Bytes / (Object_Byte'Size / System_Byte_Bits); Character_Object_Size_Last: constant Object_Size := Object_Payload_Max_Bytes / (Object_Character'Size / System_Byte_Bits); Pointer_Object_Size_Last: constant Object_Size := Object_Payload_Max_Bytes / (Object_Pointer'Size / System_Byte_Bits); Word_Object_Size_Last: constant Object_Size := Object_Payload_Max_Bytes / (Object_Word'Size / System_Byte_Bits); Half_Word_Object_Size_Last: constant Object_Size := Object_Payload_Max_Bytes / (Object_Half_Word'Size / System_Byte_Bits); subtype Byte_Object_Size is Object_Size range Object_Size'First .. Byte_Object_Size_Last; subtype Character_Object_Size is Object_Size range Object_Size'First .. Character_Object_Size_Last; subtype Pointer_Object_Size is Object_Size range Object_Size'First .. Pointer_Object_Size_Last; subtype Word_Object_Size is Object_Size range Object_Size'First .. Word_Object_Size_Last; subtype Half_Word_Object_Size is Object_Size range Object_Size'First .. Half_Word_Object_Size_Last; -- ----------------------------------------------------------------------------- -- Various pointer classification and conversion procedures -- ----------------------------------------------------------------------------- function Is_Pointer (Pointer: in Object_Pointer) return Standard.Boolean; function Is_Special_Pointer (Pointer: in Object_Pointer) return Standard.Boolean; function Is_Normal_Pointer (Pointer: in Object_Pointer) return Standard.Boolean; function Is_Integer (Pointer: in Object_Pointer) return Standard.Boolean; function Is_Character (Pointer: in Object_Pointer) return Standard.Boolean; function Is_Byte (Pointer: in Object_Pointer) return Standard.Boolean; function Integer_To_Pointer (Value: in Object_Integer) return Object_Pointer; function Character_To_Pointer (Value: in Object_Character) return Object_Pointer; function Byte_To_Pointer (Value: in Object_Byte) return Object_Pointer; function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer; function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character; function Pointer_To_Byte (Pointer: in Object_Pointer) return Object_Byte; pragma Inline (Is_Special_Pointer); pragma Inline (Is_Pointer); pragma Inline (Is_Integer); pragma Inline (Is_Character); pragma Inline (Integer_To_Pointer); pragma Inline (Character_To_Pointer); pragma Inline (Byte_To_Pointer); -- this caused GNAT 4.6.3 to end up with an internal bug when used in the generirc Plain_Integer_Op function. -- let me comment it out temporarily. --pragma Inline (Pointer_To_Integer); pragma Inline (Pointer_To_Character); pragma Inline (Pointer_To_Byte); -- ----------------------------------------------------------------------------- function Is_Cons (Source: in Object_Pointer) return Standard.Boolean; function Is_Bigint (Source: in Object_Pointer) return Standard.Boolean; pragma Inline (Is_Cons); pragma Inline (Is_Bigint); -- ----------------------------------------------------------------------------- type Stream_Record is abstract tagged limited null record; procedure Open (Stream: in out Stream_Record) is abstract; procedure Close (Stream: in out Stream_Record) is abstract; procedure Read (Stream: in out Stream_Record; Data: out Object_Character_Array; Last: out Object_Size) is abstract; procedure Write (Stream: in out Stream_Record; Data: out Object_Character_Array; Last: out Object_Size) is abstract; type Stream_Pointer is access all Stream_Record'Class; type Stream_Allocator is access procedure (Interp: in out Interpreter_Record; Name: access Object_Character_Array; Result: out Stream_Pointer); type Stream_Deallocator is access procedure (Interp: in out Interpreter_Record; Source: in out Stream_Pointer); type IO_Flags is mod 2 ** 4; IO_End_Reached: constant IO_Flags := IO_Flags'(2#0001#); IO_Error_Occurred: constant IO_Flags := IO_Flags'(2#0001#); type IO_Record; type IO_Pointer is access all IO_Record; type Character_Kind is (End_Character, Normal_Character, Error_Character); type IO_Character_Record is record Kind: Character_Kind := End_Character; Value: Object_Character := Object_Character'First; end record; --pragma Pack (IO_Character_Record); type IO_Record is record --type IO_Record is limited record Stream: Stream_Pointer := null; --Data: Object_Character_Array(1..2048) := (others => Object_Character'First); Data: Object_Character_Array(1..5) := (others => Object_Character'First); Last: Object_Size := 0; Pos: Object_Size := 0; Flags: IO_Flags := 0; -- EOF, ERROR Next: IO_Pointer := null; Iochar: IO_Character_Record; -- the last character read. end record; -- ----------------------------------------------------------------------------- type Trait_Mask is mod 2 ** System_Word_Bits; No_Garbage_Collection: constant Trait_Mask := 2#0000_0000_0000_0001#; No_Optimization: constant Trait_Mask := 2#0000_0000_0000_0010#; type Option_Kind is (Trait_Option, Stream_Option); type Option_Record (Kind: Option_Kind) is record case Kind is when Trait_Option => Trait_Bits: Trait_Mask := 0; when Stream_Option => Allocate: Stream_Allocator := null; Deallocate: Stream_Deallocator := null; end case; end record; -- ----------------------------------------------------------------------------- -- The nil/true/false object are represented by special pointer values. -- The special values are defined under the assumption that actual objects -- are never allocated on one of these addresses. Addresses of 4, 8, 12 are -- very low, making the assumption pretty safe. I don't use 0 for Nil_Word -- as it may conflict with ada's null. Nil_Word: constant Object_Word := 2#0100#; -- 4 --Nil_Pointer: constant Object_Pointer; --for Nil_Pointer'Address use Nil_Word'Address; --pragma Import (Ada, Nil_Pointer); True_Word: constant Object_Word := 2#1000#; -- 8 --True_Pointer: constant Object_Pointer; --for True_Pointer'Address use True_Word'Address; --pragma Import (Ada, True_Pointer); False_Word: constant Object_Word := 2#1100#; -- 12 --False_Pointer: constant Object_Pointer; --for False_Pointer'Address use False_Word'Address; --pragma Import (Ada, False_Pointer); function Object_Word_To_Pointer is new Ada.Unchecked_Conversion (Object_Word, Object_Pointer); function Object_Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word); Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer(Nil_Word); True_Pointer: constant Object_Pointer := Object_Word_To_Pointer(True_Word); False_Pointer: constant Object_Pointer := Object_Word_To_Pointer(False_Word); -- ----------------------------------------------------------------------------- procedure Open (Interp: in out Interpreter_Record; Initial_Heap_Size:in Heap_Size; Storage_Pool: in Storage_Pool_Pointer := null); procedure Close (Interp: in out Interpreter_Record); function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer; procedure Set_Option (Interp: in out Interpreter_Record; Option: in Option_Record); procedure Get_Option (Interp: in out Interpreter_Record; Option: in out Option_Record); procedure Set_Input_Stream (Interp: in out Interpreter_Record; Stream: in out Stream_Record'Class); -- Source must be open for Read() to work. --procedure Read (Interp: in out Interpreter_Record; -- Result: out Object_Pointer); procedure Evaluate (Interp: in out Interpreter_Record; Source: in Object_Pointer; Result: out Object_Pointer); procedure Print (Interp: in out Interpreter_Record; Source: in Object_Pointer); procedure Run_Loop (Interp: in out Interpreter_Record; Result: out Object_Pointer); procedure Collect_Garbage (Interp: in out Interpreter_Record); procedure Push_Top (Interp: in out Interpreter_Record; Source: access Object_Pointer); procedure Pop_Tops (Interp: in out Interpreter_Record; Count: in Object_Size); function Make_String (Interp: access Interpreter_Record; Source: in Object_Character_Array; Invert: in Standard.Boolean := Standard.False) return Object_Pointer; function Make_Symbol (Interp: access Interpreter_Record; Source: in Object_Character_Array; Invert: in Standard.Boolean := Standard.False) return Object_Pointer; function Make_Bigint (Interp: access Interpreter_Record; Size: in Half_Word_Object_Size) return Object_Pointer; function Make_Bigint (Interp: access Interpreter_Record; Value: in Object_Integer) return Object_Pointer; -- ----------------------------------------------------------------------------- private package Ch is new H2.Ascii(Object_Character, Object_Character); package Ch_Code renames Ch.Code; package Ch_Val renames Ch.Slim; -- Ch.Slim and Ch.Wide are the same as both are Object_Charater above. type Heap_Element_Array is array(Heap_Size range <>) of aliased Heap_Element; type Heap_Record(Size: Heap_Size) is record Space: Heap_Element_Array(1..Size) := (others => 0); Bound: Heap_Size := 0; end record; for Heap_Record'Alignment use Object_Pointer_Bytes; type Heap_Pointer is access all Heap_Record; type Heap_Number is mod 2 ** 1; type Heap_Pointer_Array is array(Heap_Number'First .. Heap_Number'Last) of Heap_Pointer; type Buffer_Record is record Ptr: Thin_Object_Character_Array_Pointer := null; Len: Object_Size := 0; Last: Object_Size := 0; end record; type Token_Kind is (End_Token, Identifier_Token, Left_Parenthesis_Token, Right_Parenthesis_Token, Period_Token, Single_Quote_Token, True_Token, False_Token, Character_Token, String_Token, Integer_Token ); type Token_Record is record Kind: Token_Kind; Value: Buffer_Record; end record; -- Temporary Object Pointer to preserve during GC type Top_Datum is access all Object_Pointer; type Top_Array is array(Object_Index range<>) of Top_Datum; type Top_Record is record Last: Object_Size := 0; Data: Top_Array(1 .. 100) := (others => null); end record; type Interpreter_State is mod 2 ** 4; Force_Syntax_Check: constant Interpreter_State := Interpreter_State'(2#0001#); --type Interpreter_Record is tagged limited record type Interpreter_Record is limited record Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer State: Interpreter_State := 0; -- Internal housekeeping state Storage_Pool: Storage_Pool_Pointer := null; Trait: Option_Record(Trait_Option); Stream: Option_Record(Stream_Option); Heap: Heap_Pointer_Array := (others => null); Current_Heap: Heap_Number := Heap_Number'First; Symbol_Table: Object_Pointer := Nil_Pointer; Root_Environment: Object_Pointer := Nil_Pointer; Root_Frame: Object_Pointer := Nil_Pointer; Stack: Object_Pointer := Nil_Pointer; Arrow_Symbol: Object_Pointer := Nil_Pointer; Else_Symbol: Object_Pointer := Nil_Pointer; Quasiquote_Symbol: Object_Pointer := Nil_Pointer; Quote_Symbol: Object_Pointer := Nil_Pointer; Top: Top_Record; -- temporary object pointers Base_Input: aliased IO_Record; Input: IO_Pointer := null; Token: Token_Record; LC_Unfetched: Standard.Boolean := Standard.False; end record; package Token is procedure Purge (Interp: in out Interpreter_Record); pragma Inline (Purge); procedure Set (Interp: in out Interpreter_Record; Kind: in Token_Kind); procedure Set (Interp: in out Interpreter_Record; Kind: in Token_Kind; Value: in Object_Character); procedure Set (Interp: in out Interpreter_Record; Kind: in Token_Kind; Value: in Object_Character_Array); procedure Append_String (Interp: in out Interpreter_Record; Value: in Object_Character_Array); pragma Inline (Append_String); procedure Append_Character (Interp: in out Interpreter_Record; Value: in Object_Character); pragma Inline (Append_Character); end Token; package Bigint is subtype Object_Radix is Object_Word range 2 .. 36; function Get_Low (W: Object_Word) return Object_Half_Word; function Get_High (W: Object_Word) return Object_Half_Word; function Make_Word (L: Object_Half_Word; H: Object_Half_Word) return Object_Word; pragma Inline (Get_High); pragma Inline (Get_Low); pragma Inline (Make_Word); procedure Add (Interp: in out Interpreter_Record; X: in Object_Pointer; Y: in Object_Pointer; Z: out Object_Pointer); procedure Subtract (Interp: in out Interpreter_Record; X: in Object_Pointer; Y: in Object_Pointer; Z: out Object_Pointer); procedure Multiply (Interp: in out Interpreter_Record; X: in Object_Pointer; Y: in Object_Pointer; Z: out Object_Pointer); procedure Divide (Interp: in out Interpreter_Record; X: in Object_Pointer; Y: in Object_Pointer; Q: out Object_Pointer; R: out Object_Pointer); function Compare (Interp: access Interpreter_Record; X: in Object_Pointer; Y: in Object_Pointer) return Standard.Integer; function To_String (Interp: access Interpreter_Record; X: in Object_Pointer; Radix: in Object_Radix) return Object_Pointer; function From_String (Interp: access Interpreter_Record; X: in Object_Character_Array; Radix: in Object_Radix) return Object_Pointer; procedure Initialize; end Bigint; end H2.Scheme;