659 lines
		
	
	
		
			26 KiB
		
	
	
	
		
			Ada
		
	
	
	
	
	
			
		
		
	
	
			659 lines
		
	
	
		
			26 KiB
		
	
	
	
		
			Ada
		
	
	
	
	
	
| ---------------------------------------------------------------------
 | |
| --  #####                                           #     #  #####  
 | |
| -- #     #  ####  #    # ###### #    # ######       #     # #     # 
 | |
| -- #       #    # #    # #      ##  ## #            #     #       # 
 | |
| --  #####  #      ###### #####  # ## # #####  ##### #######  #####  
 | |
| --       # #      #    # #      #    # #            #     # #       
 | |
| -- #     # #    # #    # #      #    # #            #     # #       
 | |
| --  #####   ####  #    # ###### #    # ######       #     # ####### 
 | |
| --
 | |
| -- 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;
 |