hak/h2/lib/h2-scheme.adb

with H2.Pool;

-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx
-- TODO: delete these after debugging
with Ada.Unchecked_Deallocation; -- for h2scm c interface. TOOD: move it to a separate file
with Interfaces.C;
with ada.text_io;
with ada.wide_text_io;
with ada.exceptions;
-- TODO: delete above after debugging
-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXx

package body H2.Scheme is

	package body Bigint is separate;
	package body Token is separate;


	DEBUG_GC: Standard.Boolean := Standard.False;
	-----------------------------------------------------------------------------
	-- PRIMITIVE DEFINITIONS
	-----------------------------------------------------------------------------

	type Procedure_Code is (
		Callcc_Procedure,
		Car_Procedure,
		Cdr_Procedure,
		Cons_Procedure,
		Not_Procedure,

		N_Add_Procedure,
		N_EQ_Procedure,
		N_GT_Procedure,
		N_LT_Procedure,
		N_GE_Procedure,
		N_LE_Procedure,
		N_Multiply_Procedure,
		N_Quotient_Procedure,
		N_Remainder_Procedure,
		N_Subtract_Procedure,

		Q_Boolean_Procedure,
		Q_Eq_Procedure,
		Q_Eqv_Procedure,
		Q_Null_Procedure,
		Q_Number_Procedure,
		Q_Pair_Procedure,
		Q_Procedure_Procedure,
		Q_String_Procedure,
		Q_String_EQ_Procedure,
		Q_Symbol_Procedure,

		Setcar_Procedure,
		Setcdr_Procedure
	);
	for Procedure_Code'Size use Object_Integer'Size;

	-- I define these constants to word around the limitation of not being
	-- able to use a string literal when the string type is a generic parameter.
	-- Why doesn't ada include a formal type support for different character
	-- and string types? This limitation is caused because the generic
	-- type I chosed to use to represent a character type is a discrete type.
	Label_And:        constant Object_Character_Array := (Ch_Val.LC_A, Ch_Val.LC_N, Ch_Val.LC_D); -- "and"
	Label_Begin:      constant Object_Character_Array := (Ch_Val.LC_B, Ch_Val.LC_E, Ch_Val.LC_G, Ch_Val.LC_I, Ch_Val.LC_N); -- "begin"
	Label_Case:       constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_S, Ch_Val.LC_E); -- "case"
	Label_Cond:       constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_D); -- "cond"
	Label_Define:     constant Object_Character_Array := (Ch_Val.LC_D, Ch_Val.LC_E, Ch_Val.LC_F, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_E); -- "define"
	Label_Do:         constant Object_Character_Array := (Ch_Val.LC_D, Ch_Val.LC_O); -- "do"
	Label_If:         constant Object_Character_Array := (Ch_Val.LC_I, Ch_Val.LC_F); -- "if"
	Label_Lambda:     constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_A, Ch_Val.LC_M, Ch_Val.LC_B, Ch_Val.LC_D, Ch_Val.LC_A); -- "lambda"
	Label_Let:        constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T); -- "let"
	Label_Letast:     constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Asterisk); -- "let*"
	Label_Letrec:     constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.LC_C); -- "letrec"
	Label_Or:         constant Object_Character_Array := (Ch_Val.LC_O, Ch_Val.LC_R); -- "or"
	Label_Quasiquote: constant Object_Character_Array := (Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_A, Ch_Val.LC_S, Ch_Val.LC_I,
	                                                      Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_O, Ch_Val.LC_T, Ch_Val.LC_E); -- "quasiquote"
	Label_Quote:      constant Object_Character_Array := (Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_O, Ch_Val.LC_T, Ch_Val.LC_E); -- "quote"
	Label_Set:        constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Exclamation); -- "set!"


	Label_Callcc:     constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_L, Ch_Val.LC_L, Ch_Val.Minus_Sign,
	                                                      Ch_Val.LC_W, Ch_Val.LC_I, Ch_Val.LC_T, Ch_Val.LC_H, Ch_Val.Minus_Sign,
	                                                      Ch_Val.LC_C, Ch_Val.LC_U, Ch_Val.LC_R, Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.LC_N, Ch_Val.LC_T, Ch_Val.Minus_Sign,
	                                                      Ch_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_T, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_U, Ch_Val.LC_A,
	                                                      Ch_Val.LC_T, Ch_Val.LC_I, Ch_Val.LC_O, Ch_Val.LC_N);  -- "call-with-current-continuation"
	Label_Car:        constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_R); -- "car"
	Label_Cdr:        constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_D, Ch_Val.LC_R); -- "cdr"
	Label_Cons:       constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_S); -- "cons"
	Label_Not:        constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_O, Ch_Val.LC_T); -- "not"

	Label_N_Add:       constant Object_Character_Array := (1 => Ch_Val.Plus_Sign); -- "+"
	Label_N_EQ:        constant Object_Character_Array := (1 => Ch_Val.Equal_Sign); -- "="
	Label_N_GE:        constant Object_Character_Array := (Ch_Val.Greater_Than_Sign, Ch_Val.Equal_Sign); -- ">="
	Label_N_GT:        constant Object_Character_Array := (1 => Ch_Val.Greater_Than_Sign); -- ">"
	Label_N_LE:        constant Object_Character_Array := (Ch_Val.Less_Than_Sign, Ch_Val.Equal_Sign); -- "<="
	Label_N_LT:        constant Object_Character_Array := (1 => Ch_Val.Less_Than_Sign); -- "<"
	Label_N_Multiply:  constant Object_Character_Array := (1 => Ch_Val.Asterisk); -- "*"
	Label_N_Quotient:  constant Object_Character_Array := (Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_O, Ch_Val.LC_T, Ch_Val.LC_I, Ch_Val.LC_E, Ch_Val.LC_N, Ch_Val.LC_T); -- "quotient"
	Label_N_Remainder: constant Object_Character_Array := (Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.LC_M, Ch_Val.LC_A, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_D, Ch_Val.LC_E, Ch_Val.LC_R); -- "remainder"
	Label_N_Subtract:  constant Object_Character_Array := (1 => Ch_Val.Minus_Sign); -- "-"

	Label_Q_Boolean:   constant Object_Character_Array := (Ch_Val.LC_B, Ch_Val.LC_O, Ch_Val.LC_O, Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_A, Ch_Val.LC_N, Ch_Val.Question); -- "boolean?"
	Label_Q_Eq:        constant Object_Character_Array := (Ch_Val.LC_E, Ch_Val.LC_Q, Ch_Val.Question); -- "eq?"
	Label_Q_Eqv:       constant Object_Character_Array := (Ch_Val.LC_E, Ch_Val.LC_Q, Ch_Val.LC_V, Ch_Val.Question); -- "eqv?"
	Label_Q_Null:      constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_U, Ch_Val.LC_L, Ch_Val.LC_L, Ch_Val.Question); -- "null?"
	Label_Q_Number:    constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_U, Ch_Val.LC_M, Ch_Val.LC_B, Ch_Val.LC_E, Ch_Val.LC_R, Ch_Val.Question); -- "number?"
	Label_Q_Pair:      constant Object_Character_Array := (Ch_Val.LC_P, Ch_Val.LC_A, Ch_Val.LC_I, Ch_Val.LC_R, Ch_Val.Question); -- "pair?"
	Label_Q_Procedure: constant Object_Character_Array := (Ch_Val.LC_P, Ch_Val.LC_R, Ch_Val.LC_O, Ch_Val.LC_C, Ch_Val.LC_E, Ch_Val.LC_D, Ch_Val.LC_U, Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.Question); -- "procedure?"
	Label_Q_String:    constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_T, Ch_Val.LC_R, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_G, Ch_Val.Question); -- "string?"
	Label_Q_String_EQ: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_T, Ch_Val.LC_R, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_G, Ch_Val.Equal_Sign, Ch_Val.Question); -- "string=?"
	Label_Q_Symbol:    constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_Y, Ch_Val.LC_M, Ch_Val.LC_B, Ch_Val.LC_O, Ch_Val.LC_L, Ch_Val.Question); -- "symbol?"

	Label_Setcar:      constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Minus_Sign, Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_R, Ch_Val.Exclamation); -- "set-car!"
	Label_Setcdr:      constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Minus_Sign, Ch_Val.LC_C, Ch_Val.LC_D, Ch_Val.LC_R, Ch_Val.Exclamation); -- "set-cdr!"

	Label_Newline:    constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_E, Ch_Val.LC_W, Ch_Val.LC_L, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_E); -- "newline"
	Label_Space:      constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_P, Ch_Val.LC_A, Ch_Val.LC_C, Ch_Val.LC_E); -- "space"

	Label_Arrow:      constant Object_Character_Array := (Ch_Val.Equal_Sign, Ch_Val.Greater_Than_Sign); -- "=>"
	Label_Else:       constant Object_Character_Array := (Ch_Val.LC_E, Ch_Val.LC_L, Ch_Val.LC_S, Ch_Val.LC_E); -- "else"

	-----------------------------------------------------------------------------
	-- INTERNAL EXCEPTIONS
	-----------------------------------------------------------------------------
	Stream_End_Error: exception;

	-----------------------------------------------------------------------------
	-- INTERNALLY-USED TYPES
	-----------------------------------------------------------------------------
	type Heap_Element_Pointer is access all Heap_Element;
	for Heap_Element_Pointer'Size use Object_Pointer_Bits; -- ensure that it can be overlaid by an ObjectPointer

	type Thin_Heap_Element_Array is array (1 .. Heap_Size'Last) of Heap_Element;
	type Thin_Heap_Element_Array_Pointer is access all Thin_Heap_Element_Array;
	for Thin_Heap_Element_Array_Pointer'Size use Object_Pointer_Bits;

	subtype Moved_Object_Record is Object_Record (Moved_Object, 0);

	type Opcode_Type is (
		Opcode_Exit,
		Opcode_Evaluate_Result,
		Opcode_Evaluate_Object,

		Opcode_And_Finish,
		Opcode_Or_Finish,
		Opcode_Case_Finish,
		Opcode_Cond_Finish,
		Opcode_Define_Finish,
		Opcode_Do_Binding,
		Opcode_Do_Break,
		Opcode_Do_Step,
		Opcode_Do_Test,
		Opcode_Do_Update,
		Opcode_Grouped_Call,  -- (begin ...), closure apply, let body
		Opcode_If_Finish,
		Opcode_Let_Binding,
		Opcode_Letast_Binding,
		Opcode_Letrec_Binding,
		Opcode_Procedure_Call,
		Opcode_Procedure_Call_Finish,
		Opcode_Set_Finish,

		Opcode_Apply,
		Opcode_Read_Object,
		Opcode_Read_List,
		Opcode_Read_List_Cdr,
		Opcode_Read_List_End,
		Opcode_Close_List,
		Opcode_Close_Quote,
		Opcode_Close_Quote_In_List
	);
	for Opcode_Type'Size use Object_Integer'Size;


	-----------------------------------------------------------------------------
	-- COMMON OBJECTS
	-----------------------------------------------------------------------------
	Cons_Object_Size: constant Pointer_Object_Size := 2;
	Cons_Car_Index: constant Pointer_Object_Size := 1;
	Cons_Cdr_Index: constant Pointer_Object_Size := 2;

	Frame_Object_Size: constant Pointer_Object_Size := 6;
	Frame_Parent_Index: constant Pointer_Object_Size := 1;
	Frame_Opcode_Index: constant Pointer_Object_Size := 2;
	Frame_Operand_Index: constant Pointer_Object_Size := 3;
	Frame_Environment_Index: constant Pointer_Object_Size := 4;
	Frame_Intermediate_Index: constant Pointer_Object_Size := 5;
	Frame_Result_Index: constant Pointer_Object_Size := 6;

	Procedure_Object_Size: constant Pointer_Object_Size := 1;
	Procedure_Opcode_Index: constant Pointer_Object_Size := 1;

	Closure_Object_Size: constant Pointer_Object_Size := 2;
	Closure_Code_Index: constant Pointer_Object_Size := 1;
	Closure_Environment_Index: constant Pointer_Object_Size := 2;
	Continuation_Object_Size: constant Pointer_Object_Size := 1;
	Continuation_Frame_Index: constant Pointer_Object_Size := 1;

	procedure Set_New_Location (Object: in Object_Pointer;
	                            Ptr:    in Heap_Element_Pointer);
	procedure Set_New_Location (Object: in Object_Pointer;
	                            Ptr:    in Object_Pointer);
	pragma Inline (Set_New_Location);

	function Get_New_Location (Object: in Object_Pointer) return Object_Pointer;
	pragma Inline (Get_New_Location);

	-----------------------------------------------------------------------------
	-- FOR DEBUGGING. REMVOE THESE LATER
	-----------------------------------------------------------------------------
	procedure Output_Character_Array (Source: in Object_Character_Array) is
		-- for debugging only.
	begin
		for I in Source'Range loop
			--Ada.Text_IO.Put (Source(I));
-- TODO: note this is a hack for quick printing.
			Ada.Text_IO.Put (Standard.Character'Val(Object_Character'Pos(Source(I))));
		end loop;
	end Output_Character_Array;

	-----------------------------------------------------------------------------
	-- POINTER AND DATA CONVERSION
	-----------------------------------------------------------------------------

	function Get_Pointer_Type (Pointer: in Object_Pointer) return Object_Pointer_Type is
		pragma Inline (Get_Pointer_Type);

		Word: Object_Word;
		for Word'Address use Pointer'Address;
	begin
		return Object_Pointer_Type(Word and Object_Word(Object_Pointer_Type_Mask));
	end Get_Pointer_Type;

	function Is_Pointer (Pointer: in Object_Pointer) return Standard.Boolean is
	begin
		return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Pointer;
	end Is_Pointer;

	function Is_Special_Pointer (Pointer: in Object_Pointer) return Standard.Boolean is
	begin
		-- though sepcial, these 3 pointers gets true for Is_Pointer.
		return Pointer = Nil_Pointer or else
		       Pointer = True_Pointer or else
		       Pointer = False_Pointer;
	end Is_Special_Pointer;

	function Is_Normal_Pointer (Pointer: in Object_Pointer) return Standard.Boolean is
	begin
		return Is_Pointer(Pointer) and then
	            not Is_Special_Pointer(Pointer);
	end Is_Normal_Pointer;

	function Is_Integer (Pointer: in Object_Pointer) return Standard.Boolean is
	begin
		return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Integer;
	end Is_Integer;

	function Is_Character (Pointer: in Object_Pointer) return Standard.Boolean is
	begin
		return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Character;
	end Is_Character;

	function Is_Byte (Pointer: in Object_Pointer) return Standard.Boolean is
	begin
		return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Byte;
	end Is_Byte;

	function Integer_To_Pointer (Value: in Object_Integer) return Object_Pointer is
		Pointer: Object_Pointer;
		Word: Object_Word;
		for Word'Address use Pointer'Address;
	begin
		if Value < 0 then
			-- change the sign of a negative number.
			-- '-Int' may violate the range of Object_Integer
			-- if it is Object_Integer'First. So I add 1 to 'Int'
			-- first to make it fall between Object_Integer'First + 1
			-- .. 0 and typecast it with an extra increment.
			--Word := Object_Word (-(Int + 1)) + 1;

			-- Let me use Object_Signed_Word instead of the trick shown above
			Word := Object_Word(-Object_Signed_Word(Value));

			-- shift the number to the left by 2 and
			-- set the highest bit on by force.
			Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Integer) or (2 ** (Word'Size - 1));
		else
			Word := Object_Word(Value);
			-- Shift 'Word' to the left by 2 and set the integer mark.
			Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Integer);
		end if;

		return Pointer;
	end Integer_To_Pointer;

	function Character_To_Pointer (Value: in Object_Character) return Object_Pointer is
		Pointer: Object_Pointer;
		Word: Object_Word;
		for Word'Address use Pointer'Address;
	begin
		-- Note: Object_Character may get defined to Wide_Wide_Character.
		--   and Wide_Wide_Character'Last is #16#7FFFFFFF#. Such a large value
		--   may get lost when it's shifted left by 2 if Object_Word is 32 bits long
		--   or short. In reality, the last Unicode code point assigned is far
		--   less than #16#7FFFFFFF# as of this writing. So I should not be
		--   worried about it for the time being.
		Word := Object_Character'Pos(Value);
		Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Character);
		return Pointer;
	end Character_To_Pointer;

	function Byte_To_Pointer (Value: in Object_Byte) return Object_Pointer is
		Pointer: Object_Pointer;
		Word: Object_Word;
		for Word'Address use Pointer'Address;
	begin
		Word := Object_Word(Value);
		Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Byte);
		return Pointer;
	end Byte_To_Pointer;

	function Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word);
	--function Pointer_To_Word (Pointer: in Object_Pointer) return Object_Word is
	--	pragma Inline (Pointer_To_Word);
	--	Word: Object_Word;
	--	for Word'Address use Pointer'Address;
	--begin
	--	return Word;
	--end Pointer_To_Word;

	function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer is
		Word: Object_Word := Pointer_To_Word(Pointer);
	begin
		if (Word and (2 ** (Word'Size - 1))) /= 0 then
			-- if the highest bit is set, it's a negative number
			-- originally. strip it off and shift 'Word' to the right by 2.
			return Object_Integer (-Object_Signed_Word (Word and not (2 ** (Word'Size - 1))) / (2 ** Object_Pointer_Type_Bits));
		else
			-- shift Word to the right by Object_Pointer_Type_Bits.
			return Object_Integer (Word / (2 ** Object_Pointer_Type_Bits));
		end if;
	end Pointer_To_Integer;

	function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character is
		Word: Object_Word := Pointer_To_Word (Pointer);
	begin
		return Object_Character'Val(Word / (2 ** Object_Pointer_Type_Bits));
	end Pointer_To_Character;

	function Pointer_To_Byte (Pointer: in Object_Pointer) return Object_Byte is
		Word: Object_Word := Pointer_To_Word (Pointer);
	begin
		return Object_Byte(Word / (2 ** Object_Pointer_Type_Bits));
	end Pointer_To_Byte;

	-- TODO: delete this procedure
	procedure Print_Object_Pointer (Msg: in Standard.String; Source: in Object_Pointer) is
		W: Object_Word;
		for W'Address use Source'Address;

		Ptr_Type: Object_Pointer_Type;
	begin
		Ptr_Type := Get_Pointer_Type(Source);
		if Ptr_Type = Object_Pointer_Type_Character then
			Ada.Text_IO.Put_Line (Msg & Object_Character'Image(Pointer_To_Character(Source)));
		elsif Ptr_Type = Object_Pointer_Type_Integer then
			Ada.Text_IO.Put_Line (Msg & Object_Integer'Image(Pointer_To_Integer(Source)));
		elsif Is_Special_Pointer(Source) then
			Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W));
		elsif Source.Kind = Character_Object then
			Ada.Text_IO.Put (Msg & " at " & Object_Word'Image(W) &
			                   " at " & Object_Kind'Image(Source.Kind) &
			                   " size " & Object_Size'Image(Source.Size) & " - ");
			if Source.Kind = Moved_Object then
				Output_Character_Array (Get_New_Location(Source).Character_Slot);
			else
				Output_Character_Array (Source.Character_Slot);
			end if;
		else
			Ada.Text_IO.Put_Line (Msg & " at " & Object_Word'Image(W) &
			                            " kind: " & Object_Kind'Image(Source.Kind) &
			                            " size: " & Object_Size'Image(Source.Size) &
			                            " tag: " & Object_Tag'Image(Source.Tag));
		end if;
	end Print_Object_Pointer;

	function String_To_Integer_Pointer (Source: in Object_Character_Array) return Object_Pointer is
		V: Object_Integer := 0;
		Negative: Standard.Boolean := False;
		First: Object_Size;
	begin
		-- TODO: BIGNUM, RANGE CHECK, ETC
		pragma Assert (Source'Length > 0);

		First := Source'First;
		if Source(First) = Ch_Val.Minus_Sign then
			First := First + 1;
			Negative := Standard.True;
		elsif Source(First) = Ch_Val.Plus_Sign then
			First := First + 1;
		end if;
		for I in First .. Source'Last loop
			V := V * 10 + Object_Character'Pos(Source(I)) - Object_Character'Pos(Ch_Val.Zero);
		end loop;

		if Negative then
			V := -V;
		end if;

		return Integer_To_Pointer(V);
	end String_To_Integer_Pointer;

	-- TODO: remove this function or improve it to handle conversion properly.
	function String_To_Object_Character_Array (Source: in Standard.String) return Object_Character_Array is
		Result: Object_Character_Array (1 .. Source'Length);
	begin
		for I in Result'Range loop
			Result(I) := Object_Character'Val(Standard.Character'Pos(Source(Source'First + Standard.Natural(I) - 1)));
		end loop;
		return Result;
	end;

	-----------------------------------------------------------------------------
	-- MORE CONVERSIONS
	-----------------------------------------------------------------------------
	--function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type renames Pointer_To_Integer;
	--function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer renames Integer_To_Pointer;

	function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type is
		pragma Inline (Pointer_To_Opcode);
	begin
		return Opcode_Type'Val(Pointer_To_Integer(Pointer));
	end Pointer_To_Opcode;

	function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer is
		pragma Inline (Opcode_To_Pointer);
	begin
		 return Integer_To_Pointer(Opcode_Type'Pos(Opcode));
	end Opcode_To_Pointer;

	function Pointer_To_Procedure_Code (Pointer: in Object_Pointer) return Procedure_Code is
		pragma Inline (Pointer_To_Procedure_Code);
	begin
		return Procedure_Code'Val(Pointer_To_Integer(Pointer));
	end Pointer_To_Procedure_Code;

	function Procedure_Code_To_Pointer (Opcode: in Procedure_Code) return Object_Pointer is
		pragma Inline (Procedure_Code_To_Pointer);
	begin
		 return Integer_To_Pointer(Procedure_Code'Pos(Opcode));
	end Procedure_Code_To_Pointer;


	function Token_To_Pointer (Interp: access Interpreter_Record;
	                           Token:  in     Token_Record) return Object_Pointer is
	begin
		case Token.Kind is
			when Integer_Token =>
				-- TODO: bignum
				--return String_To_Integer_Pointer(Token.Value.Ptr.all(1..Token.Value.Last));
				return Bigint.From_String(Interp, Token.Value.Ptr.all(1..Token.Value.Last),  10);

			when Character_Token =>
				pragma Assert (Token.Value.Last = 1);
				return Character_To_Pointer(Token.Value.Ptr.all(1));

			when String_Token =>
				return Make_String(Interp, Token.Value.Ptr.all(1..Token.Value.Last));

			when Identifier_Token =>
				return Make_Symbol(Interp, Token.Value.Ptr.all(1..Token.Value.Last));

			when True_Token =>
				return True_Pointer;

			when False_Token =>
				return False_Pointer;

			when others =>
				return null;
		end case;
	end Token_To_Pointer;

	-----------------------------------------------------------------------------
	-- COMPARISON
	-----------------------------------------------------------------------------

	function Equal_Values (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
		Ptr_Type: Object_Pointer_Type;
	begin
		if X = Y then
			return Standard.True;
		end if;

		Ptr_Type := Get_Pointer_Type(X);
		case Ptr_Type is
			when Object_Pointer_Type_Integer |
			     Object_Pointer_Type_Character |
			     Object_Pointer_Type_Byte =>

				-- This part of the code won't be reached if two special
				-- pointers are the same. So False can be returned safely
				-- without further check. See the lines commented out.

				--if Get_Pointer_Type(Y) = Ptr_Type then
				--	return X = Y;
				--else
					return Standard.False;
				--end if;

			when others =>
				-- TODO: BIGNUM, OTHER NUMERIC DATA.
				if Is_Special_Pointer(X) then
					return X = Y;
				elsif Get_Pointer_Type(Y) /= Ptr_Type then
					return Standard.False;
				end if;

				case X.Kind is
					when Character_Object =>
						if Y.Kind = X.Kind then
							return X.Character_Slot = Y.Character_Slot;
						else
							return Standard.False;
						end if;

					when Byte_Object =>
						if Y.Kind = X.Kind then
							return X.Byte_Slot = Y.Byte_Slot;
						else
							return Standard.False;
						end if;

					when Word_Object =>
						if Y.Kind = X.Kind then
							return X.Word_Slot = Y.Word_Slot;
						else
							return Standard.False;
						end if;

					when Half_Word_Object =>
						if Y.Kind = X.Kind then
							return X.Half_Word_Slot = Y.Half_Word_Slot;
						else
							return Standard.False;
						end if;

					when Pointer_Object =>
						return X = Y;

					when Moved_Object =>
						raise Internal_Error;
				end case;
		end case;

	end Equal_Values;


	-----------------------------------------------------------------------------
	-- MEMORY MANAGEMENT
	-----------------------------------------------------------------------------
-- (define x ())
-- (define x #())
-- (define x $())
-- (define x #(
--              (#a . 10)  ; a is a symbol
--              (b . 20)   ; b is a variable. resolve b at the eval-time and use it.
--              ("c" . 30) ; "c" is a string
--            )
-- )
-- (clone x y) -- deep copy
-- (define y x) -- reference assignment
-- (set! x.a 20) -- syntaic sugar
-- (set! (get x #a) 20)
-- (define x (make-hash))


	-- I wanted to reuse the Size field to store the pointer to
	-- the new location. GCC-GNAT 3.2.3 suffered from various constraint
	-- check errors. So i gave up on this procedure.
	--------------------------------------------------------------------
	--procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer) is
		--New_Addr: Heap_Element_Pointer;
		--for New_Addr'Address use Object.Size'Address;
		--pragma Import (Ada, New_Addr);
	--begin
		--New_Addr := Ptr;
	--end Set_New_Location;
	--function Get_New_Location (Object: in Object_Pointer) return Object_Pointer is
		--New_Ptr: Object_Pointer;
		--for New_Ptr'Address use Object.Size'Address;
		--pragma Import (Ada, New_Ptr);
	--begin
		--return New_Ptr;
	--end;

	-- Instead, I created a new object kind that indicates a moved object.
	-- The original object is replaced by this special object. this special
	-- object takes up the smallest space that a valid object can take. So
	-- it is safe to overlay it on any normal objects.
	procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Heap_Element_Pointer) is
		Moved_Object: Moved_Object_Record;
		for Moved_Object'Address use Object.all'Address;
		-- pramga Import must not be specified here as I'm counting
		-- on the default initialization of Moved_Object to overwrite
		-- the Kind discriminant in particular.
		--pragma Import (Ada, Moved_Object); -- this must not be used.
		function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
	begin
		Moved_Object.New_Pointer := To_Object_Pointer (Ptr);
	end Set_New_Location;

	procedure Set_New_Location (Object: in Object_Pointer; Ptr: in Object_Pointer) is
		Moved_Object: Moved_Object_Record;
		for Moved_Object'Address use Object.all'Address;
		--pragma Import (Ada, Moved_Object); -- this must not be used.
	begin
		Moved_Object.New_Pointer := Ptr;
	end Set_New_Location;

	function Get_New_Location (Object: in Object_Pointer) return Object_Pointer is
	begin
		return Object.New_Pointer;
	end Get_New_Location;

	function Verify_Pointer (Source: in Object_Pointer) return Object_Pointer is
		pragma Inline (Verify_Pointer);
	begin
		if not Is_Normal_Pointer(Source) or else
		   Source.Kind /= Moved_Object then
			return Source;
		else
			return Get_New_Location(Source);
		end if;
	end Verify_Pointer;

	function Allocate_Bytes_In_Heap (Heap:       access Heap_Record;
	                                 Heap_Bytes: in     Heap_Size) return Heap_Element_Pointer is
		Avail: Heap_Size;
		Result: Heap_Element_Pointer;
		Real_Bytes: Heap_Size := Heap_Bytes;
	begin
		if Real_Bytes < Moved_Object_Record'Max_Size_In_Storage_Elements then
			-- Guarantee the minimum object size to be greater than or
			-- equal to the size of a moved object for GC to work.
			Real_Bytes := Moved_Object_Record'Max_Size_In_Storage_Elements;

			-- Note: Extra attention must be paid when calculating the
			-- actual bytes allocated for an object. Scan_New_Heap() also
			-- makes similar adjustment to skip actual allocated bytes.
		end if;

		Avail := Heap.Size - Heap.Bound;
		if Real_Bytes > Avail then
			return null;
		end if;

		Result := Heap.Space(Heap.Bound + 1)'Unchecked_Access;
		Heap.Bound := Heap.Bound + Real_Bytes;
		return Result;
	end Allocate_Bytes_In_Heap;

	function Get_Heap_Number (Interp: access Interpreter_Record;
	                          Source: in     Object_Pointer) return Heap_Number is
		-- for debugging
		SW: Object_Word;
		for SW'Address use Source'Address;

		H1: Heap_Element_Pointer := Interp.Heap(0).Space(1)'Unchecked_Access;
		H2: Heap_Element_Pointer := Interp.Heap(1).Space(1)'Unchecked_Access;

		HW1: Object_Word;
		for HW1'Address use H1'Address;

		HW2: Object_Word;
		for HW2'Address use H2'Address;
	begin
		if SW >= HW1 and then SW < HW1 + Object_Word(Interp.Heap(0).Size) then
			return 0;
		end if;
		if SW >= HW2 and then SW < HW2 + Object_Word(Interp.Heap(1).Size) then
			return 1;
		end if;

		if Source = Nil_Pointer then
ada.text_io.put_line ("HEAP SOURCE IS NIL");
			return 0;
		end if;

		raise Internal_Error;
	end Get_Heap_Number;


	procedure Copy_Object (Source: in     Object_Pointer;
	                       Target: in out Heap_Element_Pointer) is
		pragma Inline (Copy_Object);
		subtype Target_Object_Record is Object_Record (Source.Kind, Source.Size);
		type Target_Object_Pointer is access all Target_Object_Record;

		Target_Object: Target_Object_Pointer;
		for Target_Object'Address use Target'Address;
		pragma Import (Ada, Target_Object);
	begin
		-- This procedure should work. but gnat 4.3.2 on whiite(ppc32,wii)
		-- produced erroneous code when it was called from Move_One_Object().
		-- Target_Object_Record'Size, Target_Object.all'Size, and
		-- Target_Object_Record'Max_Size_In_Stroage_Elements were not
		-- always correct. For example, for a character object containing
		-- the string "lambda", Target_Object.all'Size returned 72 while
		-- it's supposed to be 96. Use Copy_Object_With_Size() below instead.
		Target_Object.all := Source.all;
		pragma Assert (Source.all'Size = Target_Object.all'Size);
	end Copy_Object;

	procedure Copy_Object_With_Size (Source: in Object_Pointer;
	                                 Target: in Heap_Element_Pointer;
	                                 Bytes:  in Heap_Size) is
		pragma Inline (Copy_Object_With_Size);
		pragma Assert (Bytes > 0);
		-- This procedure uses a more crude type for copying objects.
		-- It's the result of an effort to work around some compiler
		-- issues mentioned above.


		-- The work around, however, still didn't work well with gnat-3.15p.
		-- The overlaying(thus overlaid)  pointer is initialized to null
		-- despite pragma Import.
		--Tgt: Thin_Heap_Element_Array_Pointer;
		--for Tgt'Address use Target'Address;
		--pragma Import (Ada, Tgt);
		--Src: Thin_Heap_Element_Array_Pointer;
		--for Src'Address use Source'Address;
		--pragma Import (Ada, Src);

		-- So let me turn to unchecked conversion instead.
		function Conv1 is new Ada.Unchecked_Conversion(Object_Pointer, Thin_Heap_Element_Array_Pointer);
		function Conv2 is new Ada.Unchecked_Conversion(Heap_Element_Pointer, Thin_Heap_Element_Array_Pointer);
		Src: Thin_Heap_Element_Array_Pointer := Conv1(Source);
		Tgt: Thin_Heap_Element_Array_Pointer := Conv2(Target);
	begin
		Tgt(Tgt'First .. Tgt'First + Bytes - 1) := Src(Src'First .. Src'First + Bytes - 1);
	end Copy_Object_With_Size;

	procedure Collect_Garbage (Interp: in out Interpreter_Record) is

		Last_Pos: Heap_Size;
		New_Heap: Heap_Number;
		Original_Symbol_Table: Object_Pointer;

		--function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
		function Move_One_Object (Source: in Object_Pointer) return Object_Pointer is
		begin
			pragma Assert (Is_Normal_Pointer(Source));

			if Source.Kind = Moved_Object then
				-- the object has moved to the new heap.
				-- the size field has been updated to the new object
				-- in the 'else' block below. i can simply return it
				-- without further migration.
				return Get_New_Location (Source);
			else
				declare
					Bytes: Heap_Size;

					-- This variable holds the allocation result
					Ptr: Heap_Element_Pointer;

					-- Create an overlay for type conversion
					New_Object: Object_Pointer;
					for New_Object'Address use Ptr'Address;
					pragma Import (Ada, New_Object);
				begin
					-- Target_Object_Record'Max_Size_In_Storage_Elements gave
					-- some erroneous values when compiled with GNAT 4.3.2 on
					-- WII(ppc) Debian.
					--Bytes := Target_Object_Record'Max_Size_In_Storage_Elements;
					Bytes := Source.all'Size / System.Storage_Unit;

					-- Allocate space in the new heap
					Ptr := Allocate_Bytes_In_Heap(Interp.Heap(New_Heap), Bytes);

					-- Allocation here must not fail because
					-- I'm allocating the new space in a new heap for
					-- moving an existing object in the current heap.
					-- It must not fail, assuming the new heap is as large
					-- as the old heap, and garbage collection doesn't
					-- allocate more objects than in the old heap.
					pragma Assert (Ptr /= null);

					-- This minimum size adjustment is not needed when copying
					-- an object as it's ok to have garbage in the trailing space.
					-- See Allocate_Bytes_In_Heap() and Scan_New_Heap() for more info.
					--if Bytes < Moved_Object_Record'Max_Size_In_Storage_Elements then
					--	Bytes := Moved_Object_Record'Max_Size_In_Storage_Elements;
					--end  if;

					-- Copy the payload to the new object
					--Copy_Object (Object, Ptr); -- not reliable with some compilers
					Copy_Object_With_Size (Source, Ptr, Bytes); -- use this instead
					pragma Assert (Source.all'Size = New_Object.all'Size);
					pragma Assert (Bytes = New_Object.all'Size / System.Storage_Unit);

					-- Let the size field of the old object point to the
					-- new object allocated in the new heap. It is returned
					-- in the 'if' block at the beginning of this function
					-- if the object is marked with FLAG_MOVED;
					Set_New_Location (Source, Ptr);

					-- Return the new object
					return New_Object;
				end;
			end if;
		end Move_One_Object;

		function Scan_New_Heap (Start_Position: in Heap_Size) return Heap_Size is
			Ptr: Heap_Element_Pointer;
			Position: Heap_Size := Start_Position;
		begin

--Ada.Text_IO.Put_Line ("Start Scanning New Heap from " & Heap_Size'Image(Start_Position) & " Bound: " & Heap_Size'Image (Interp.Heap(New_Heap).Bound));
			while Position <= Interp.Heap(New_Heap).Bound loop

--Ada.Text_IO.Put_Line (">>> Scanning New Heap from " & Heap_Size'Image (Position) & " Bound: " & Heap_Size'Image (Interp.Heap(New_Heap).Bound));
				Ptr := Interp.Heap(New_Heap).Space(Position)'Unchecked_Access;

				declare
					-- There is a overlaid pointer initialization problem despite
					-- "pragma Import()" in gnat-3.15p.
					--Object: Object_Pointer;
					--for Object'Address use Ptr'Address;
					--pragma Import (Ada, Object);

					-- So let me turn to unchecked conversion.
					function Conv1 is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
					Object: Object_Pointer := Conv1(Ptr);

					--subtype Target_Object_Record is Object_Record (Object.Kind, Object.Size);
					Bytes: Heap_Size;
				begin
					--Bytes := Target_Object_Record'Max_Size_In_Storage_Elements;
					Bytes := Object.all'Size / System.Storage_Unit;
					if Bytes < Moved_Object_Record'Max_Size_In_Storage_Elements then
						-- Allocate_Bytes_In_Heap() guarantee the minimum object size.
						-- The size must be guaranteed here when scanning a heap.
						Bytes := Moved_Object_Record'Max_Size_In_Storage_Elements;
					end if;

					if Object.Kind = Pointer_Object then
--Ada.Text_IO.Put_Line (">>> Scanning Obj " & Object_Kind'Image(Object.Kind) & " Size: " & Object_Size'Image(Object.Size) & " At " & Object_Word'Image(Pointer_To_Word(Object)) & " Bytes " & Heap_Size'Image(Bytes));
--Print_Object_Pointer (">>> Scanning :", Object);
						for i in Object.Pointer_Slot'Range loop
							if Is_Normal_Pointer(Object.Pointer_Slot(i)) then
								Object.Pointer_Slot(i) := Move_One_Object(Object.Pointer_Slot(i));
							end if;
						end loop;
					end if;

					Position := Position + Bytes;
				end;

			end loop;

			return Position;
		end Scan_New_Heap;

		procedure Compact_Symbol_Table is
			Pred: Object_Pointer;
			Cons: Object_Pointer;
			Car: Object_Pointer;
			Cdr: Object_Pointer;
		begin
-- TODO: Change code here if the symbol table structure is changed to a hash table.

			Pred := Nil_Pointer;
			Cons := Interp.Symbol_Table;
			while Cons /= Nil_Pointer loop
				pragma Assert (Cons.Tag = Cons_Object);

				Car := Cons.Pointer_Slot(Cons_Car_Index);
				Cdr := Cons.Pointer_Slot(Cons_Cdr_Index);
				pragma Assert (Car.Kind = Moved_Object or else Car.Tag = Symbol_Object);

				if Car.Kind /= Moved_Object and then
				   (Car.Flags and Syntax_Object) = 0 then
					-- A non-syntax symbol has not been moved.
					-- Unlink the cons cell from the symbol table.
					if Pred = Nil_Pointer then
						Interp.Symbol_Table := Cdr;
					else
						Pred.Pointer_Slot(Cons_Cdr_Index) := Cdr;
					end if;
				else
					Pred := Cons;
				end if;

				Cons := Cdr;
			end loop;
		end Compact_Symbol_Table;

	begin

ada.text_io.put_line ("[GC BEGIN]");
--declare
--Avail: Heap_Size;
--begin
--Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
--Ada.Text_IO.Put_Line (">>> [GC BEGIN] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
--end;

		-- As the Heap_Number type is a modular type that can
		-- represent 0 and 1, incrementing it gives the next value.
		New_Heap := Interp.Current_Heap + 1;

		-- Migrate some root objects
--Print_Object_Pointer (">>> [GC] Stack BEFORE ...", Interp.Stack);
		if Is_Normal_Pointer(Interp.Stack) then
			Interp.Stack := Move_One_Object(Interp.Stack);
		end if;

		Interp.Root_Environment := Move_One_Object(Interp.Root_Environment);
		Interp.Root_Frame := Move_One_Object(Interp.Root_Frame);

		-- Migrate temporary object pointers
		for I in Interp.Top.Data'First .. Interp.Top.Last loop
			if Interp.Top.Data(I).all = Interp.Symbol_Table then
				-- The symbol table must stay before compaction.
				-- Skip migrating a temporary object pointer if it
				-- is pointing to the symbol table. Remember that
				-- such skipping has happened.
				Original_Symbol_Table := Interp.Symbol_Table;
			elsif Interp.Top.Data(I).all /= null and then
			      Is_Normal_Pointer(Interp.Top.Data(I).all) then
				Interp.Top.Data(I).all := Move_One_Object(Interp.Top.Data(I).all);
			end if;
		end loop;

		-- Migrate some known symbols
		Interp.Arrow_Symbol := Move_One_Object(Interp.Arrow_Symbol);
		Interp.Else_Symbol := Move_One_Object(Interp.Else_Symbol);
		Interp.Quasiquote_Symbol := Move_One_Object(Interp.Quasiquote_Symbol);
		Interp.Quote_Symbol := Move_One_Object(Interp.Quote_Symbol);

--Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
		-- Scan the heap
		Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First);

		-- Traverse the symbol table for unreferenced symbols.
		-- If the symbol has not moved to the new heap, the symbol
		-- is not referenced by any other objects than the symbol
		-- table itself
--Ada.Text_IO.Put_Line (">>> [GC COMPACTING SYMBOL TABLE]");
		Compact_Symbol_Table;

--Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
		-- Migrate the symbol table itself
		Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);

		-- Update temporary object pointers that were pointing to the symbol table
		if Original_Symbol_Table /= null then
			for I in Interp.Top.Data'First .. Interp.Top.Last loop
				if Interp.Top.Data(I).all = Original_Symbol_Table then
					-- update to the new symbol table
					Interp.Top.Data(I).all := Interp.Symbol_Table;
				end if;
			end loop;
		end if;

--Ada.Text_IO.Put_Line (">>> [GC SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]");
		-- Scan the new heap again from the end position of
		-- the previous scan to move referenced objects by
		-- the symbol table.
		Last_Pos := Scan_New_Heap(Last_Pos);

		-- Swap the current heap and the new heap
		Interp.Heap(Interp.Current_Heap).Bound := 0;
		Interp.Current_Heap := New_Heap;
--declare
--Avail: Heap_Size;
--begin
--Avail := Interp.Heap(Interp.Current_Heap).Size - Interp.Heap(Interp.Current_Heap).Bound;
--Print_Object_Pointer (">>> [GC DONE] Stack ...", Interp.Stack);
--Ada.Text_IO.Put_Line (">>> [GC DONE] BOUND: " & Heap_Size'Image(Interp.Heap(Interp.Current_Heap).Bound) & " AVAIL: " & Heap_Size'Image(Avail));
--Ada.Text_IO.Put_Line (">>> [GC DONE] ----------------------------------------------------------");
--end;
ada.text_io.put_line ("[GC END]");
	end Collect_Garbage;

	function Allocate_Bytes (Interp: access Interpreter_Record;
	                         Bytes:  in     Heap_Size) return Heap_Element_Pointer is

		-- I use this temporary variable not to change Result
		-- if Allocation_Error should be raised.
		Tmp: Heap_Element_Pointer;
	begin
		pragma Assert (Bytes > 0);

-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
if DEBUG_GC then
	Collect_Garbage (Interp.all);
end if;
-- XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

		Tmp := Allocate_Bytes_In_Heap (Interp.Heap(Interp.Current_Heap), Bytes);
		if Tmp = null and then (Interp.Trait.Trait_Bits and No_Garbage_Collection) = 0 then
			Collect_Garbage (Interp.all);
			Tmp := Allocate_Bytes_In_Heap (Interp.Heap(Interp.Current_Heap), Bytes);
			if Tmp = null then
				raise Allocation_Error;
			end if;
		end if;

		return Tmp;
	end Allocate_Bytes;

	function Allocate_Pointer_Object (Interp:  access Interpreter_Record;
	                                  Size:    in     Pointer_Object_Size;
	                                  Initial: in     Object_Pointer) return Object_Pointer is

		subtype Pointer_Object_Record is Object_Record (Pointer_Object, Size);
		type Pointer_Object_Pointer is access all Pointer_Object_Record;

		Ptr: Heap_Element_Pointer;
		Obj_Ptr: Pointer_Object_Pointer;
		for Obj_Ptr'Address use Ptr'Address;
		pragma Import (Ada, Obj_Ptr);
		Result: Object_Pointer;
		for Result'Address use Ptr'Address;
		pragma Import (Ada, Result);
	begin
		Ptr := Allocate_Bytes(
			Interp,
			Heap_Size'(Pointer_Object_Record'Max_Size_In_Storage_Elements)
		);

		Obj_Ptr.all := (
			Kind => Pointer_Object,
			Size => Size,
			Flags => 0,
			Tag => Unknown_Object,
			Scode => Syntax_Code'Val(0),
			Sign => Positive_Sign,
			Pointer_Slot => (others => Initial)
		);

		return Result;
	end Allocate_Pointer_Object;

	function Allocate_Character_Object (Interp: access Interpreter_Record;
	                                    Size:   in     Character_Object_Size) return Object_Pointer is

		subtype Character_Object_Record is Object_Record (Character_Object, Size);
		type Character_Object_Pointer is access all Character_Object_Record;

		Ptr: Heap_Element_Pointer;
		Obj_Ptr: Character_Object_Pointer;
		for Obj_Ptr'Address use Ptr'Address;
		pragma Import (Ada, Obj_Ptr);
		Result: Object_Pointer;
		for Result'Address use Ptr'Address;
		pragma Import (Ada, Result);
	begin
		Ptr := Allocate_Bytes (
			Interp.Self,
			Heap_Size'(Character_Object_Record'Max_Size_In_Storage_Elements)
		);

		Obj_Ptr.all := (
			Kind => Character_Object,
			Size => Size,
			Flags => 0,
			Tag => Unknown_Object,
			Scode => Syntax_Code'Val(0),
			Sign => Positive_Sign,
			Character_Slot => (others => Ch_Val.NUL),
			Character_Terminator => Ch_Val.NUL
		);

		return Result;
	end Allocate_Character_Object;

	function Allocate_Character_Object (Interp: access Interpreter_Record;
	                                    Source: in     Object_Character_Array;
	                                    Invert: in     Standard.Boolean) return Object_Pointer is
		Result: Object_Pointer;
	begin
		if Source'Length > Character_Object_Size'Last then
			raise Size_Error;
		end if;

		Result := Allocate_Character_Object (Interp, Size => Character_Object_Size'(Source'Length));
		if Invert then
			for I in Source'Range loop
				Result.Character_Slot(Result.Character_Slot'Last - (I - Source'First)) := Source(I);
			end loop;
		else
			Result.Character_Slot := Source;
		end if;
		return Result;
	end Allocate_Character_Object;



	function Allocate_Byte_Object (Interp: access Interpreter_Record;
	                               Size:   in     Byte_Object_Size) return Object_Pointer is

		subtype Byte_Object_Record is Object_Record (Byte_Object, Size);
		type Byte_Object_Pointer is access all Byte_Object_Record;

		Ptr: Heap_Element_Pointer;
		Obj_Ptr: Byte_Object_Pointer;
		for Obj_Ptr'Address use Ptr'Address;
		pragma Import (Ada, Obj_Ptr);
		Result: Object_Pointer;
		for Result'Address use Ptr'Address;
		pragma Import (Ada, Result);
	begin
		Ptr := Allocate_Bytes (Interp.Self, Heap_Size'(Byte_Object_Record'Max_Size_In_Storage_Elements));
		Obj_Ptr.all := (
			Kind => Byte_Object,
			Size => Size,
			Flags => 0,
			Tag => Unknown_Object,
			Scode => Syntax_Code'Val(0),
			Sign => Positive_Sign,
			Byte_Slot => (others => 0)
		);
		return Result;
	end Allocate_Byte_Object;

	function Allocate_Word_Object (Interp: access Interpreter_Record;
	                               Size:   in     Word_Object_Size) return Object_Pointer is

		subtype Word_Object_Record is Object_Record (Word_Object, Size);
		type Word_Object_Pointer is access all Word_Object_Record;

		Ptr: Heap_Element_Pointer;
		Obj_Ptr: Word_Object_Pointer;
		for Obj_Ptr'Address use Ptr'Address;
		pragma Import (Ada, Obj_Ptr);
		Result: Object_Pointer;
		for Result'Address use Ptr'Address;
		pragma Import (Ada, Result);
	begin
		Ptr := Allocate_Bytes (Interp.Self, Heap_Size'(Word_Object_Record'Max_Size_In_Storage_Elements));
		Obj_Ptr.all := (
			Kind => Word_Object,
			Size => Size,
			Flags => 0,
			Tag => Unknown_Object,
			Scode => Syntax_Code'Val(0),
			Sign => Positive_Sign,
			Word_Slot => (others => 0)
		);
		return Result;
	end Allocate_Word_Object;

	function Allocate_Half_Word_Object (Interp: access Interpreter_Record;
	                                    Size:   in     Half_Word_Object_Size) return Object_Pointer is

		subtype Half_Word_Object_Record is Object_Record (Half_Word_Object, Size);
		type Half_Word_Object_Pointer is access all Half_Word_Object_Record;

		Ptr: Heap_Element_Pointer;
		Obj_Ptr: Half_Word_Object_Pointer;
		for Obj_Ptr'Address use Ptr'Address;
		pragma Import (Ada, Obj_Ptr);
		Result: Object_Pointer;
		for Result'Address use Ptr'Address;
		pragma Import (Ada, Result);
	begin
		Ptr := Allocate_Bytes (Interp.Self, Heap_Size'(Half_Word_Object_Record'Max_Size_In_Storage_Elements));
		Obj_Ptr.all := (
			Kind => Half_Word_Object,
			Size => Size,
			Flags => 0,
			Tag => Unknown_Object,
			Scode => Syntax_Code'Val(0),
			Sign => Positive_Sign,
			Half_Word_Slot => (others => 0)
		);
		return Result;
	end Allocate_Half_Word_Object;

	-----------------------------------------------------------------------------

	procedure Push_Top (Interp: in out Interpreter_Record;
	                    Source: access Object_Pointer) is
		Top: Top_Record renames Interp.Top;
	begin
		if Top.Last >= Top.Data'Last then
			-- Something is wrong. Too many temporary object pointers
			raise Internal_Error; -- TODO: change the exception to something else.
		end if;

		Top.Last := Top.Last + 1;
		Top.Data(Top.Last) := Top_Datum(Source);
	end Push_Top;

	procedure Pop_Tops (Interp: in out Interpreter_Record;
	                    Count:  in     Object_Size) is
		Top: Top_Record renames Interp.Top;
	begin
		if Top.Last < Count then
			-- Something is wrong. Too few temporary object pointers
			raise Internal_Error; -- TODO: change the exception to something else.
		end if;
		Top.Last := Top.Last - Count;
	end Pop_Tops;

	procedure Clear_Tops (Interp: in out Interpreter_Record) is
		pragma Inline (Clear_Tops);
		Top: Top_Record renames Interp.Top;
	begin
		Top.Last := Top.Data'First - 1;
	end Clear_Tops;

	-----------------------------------------------------------------------------

	function Make_Cons (Interp:  access Interpreter_Record;
	                    Car:     in     Object_Pointer;
	                    Cdr:     in     Object_Pointer) return Object_Pointer is
		Cons: Object_Pointer;
		Aliased_Car: aliased Object_Pointer := Car;
		Aliased_Cdr: aliased Object_Pointer := Cdr;
	begin
		Push_Top (Interp.all, Aliased_Car'Unchecked_Access);
		Push_Top (Interp.all, Aliased_Cdr'Unchecked_Access);

		Cons := Allocate_Pointer_Object(Interp, Cons_Object_Size, Nil_Pointer);
		Cons.Pointer_Slot(Cons_Car_Index) := Aliased_Car;
		Cons.Pointer_Slot(Cons_Cdr_Index) := Aliased_Cdr;
		Cons.Tag := Cons_Object;

		Pop_Tops (Interp.all, 2);
		return Cons;
	end Make_Cons;

	function Is_Cons (Source: in Object_Pointer) return Standard.Boolean is
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Cons_Object;
	end Is_Cons;

	function Get_Car (Source: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Car);
		pragma Assert (Is_Cons(Source));
	begin
		return Source.Pointer_Slot(Cons_Car_Index);
	end Get_Car;

	procedure Set_Car (Source: in Object_Pointer;
	                   Value:  in Object_Pointer) is
		pragma Inline (Set_Car);
		pragma Assert (Is_Cons(Source));
	begin
		Source.Pointer_Slot(Cons_Car_Index) := Value;
	end Set_Car;

	function Get_Cdr (Source: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Cdr);
		pragma Assert (Is_Cons(Source));
	begin
		return Source.Pointer_Slot(Cons_Cdr_Index);
	end Get_Cdr;

	procedure Set_Cdr (Source: in Object_Pointer;
	                   Value:  in Object_Pointer) is
		pragma Inline (Set_Cdr);
		pragma Assert (Is_Cons(Source));
	begin
		Source.Pointer_Slot(Cons_Cdr_Index) := Value;
	end Set_Cdr;

	function Get_Last_Cdr (Source: in Object_Pointer) return Object_Pointer is
		pragma Assert (Is_Cons(Source));
		Ptr: Object_Pointer := Source;
	begin
		loop
			Ptr := Get_Cdr(Ptr);
			exit when not Is_Cons(Ptr);
		end loop;
		return Ptr;
	end Get_Last_Cdr;

	function Reverse_Cons (Source:   in Object_Pointer;
	                       Last_Cdr: in Object_Pointer := Nil_Pointer) return Object_Pointer is
		pragma Assert (Is_Cons(Source));

		-- Note: The non-nil cdr in the last cons cell gets lost.
		--       e.g.) Reversing (1 2 3 . 4) results in (3 2 1)
		Ptr: Object_Pointer;
		Next: Object_Pointer;
		Prev: Object_Pointer;
	begin
		Prev := Last_Cdr;
		Ptr := Source;
		loop
			Next := Get_Cdr(Ptr);
			Set_Cdr (Ptr, Prev);
			Prev := Ptr;
			exit when not Is_Cons(Next);
			Ptr := Next;
		end loop;
		return Ptr;
	end Reverse_Cons;
	-----------------------------------------------------------------------------

	function Is_String (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_String);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = String_Object;
	end Is_String;

	function Make_String (Interp: access  Interpreter_Record;
	                      Source: in      Object_Character_Array;
	                      Invert: in      Standard.Boolean := Standard.False) return Object_Pointer is
		Result: Object_Pointer;
	begin
		Result := Allocate_Character_Object(Interp, Source, Invert);
		Result.Tag := String_Object;
		return Result;
	end Make_String;


	function Is_Symbol (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Symbol);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Symbol_Object;
	end Is_Symbol;

	function Make_Symbol (Interp: access Interpreter_Record;
	                      Source: in     Object_Character_Array;
	                      Invert: in     Standard.Boolean := Standard.False) return Object_Pointer is
		Ptr: aliased Object_Pointer;
	begin
		-- TODO: the current linked list implementation isn't efficient.
		--       change the symbol table to a hashable table.

		-- Find an existing symbol in the symbol table.
		Ptr := Interp.Symbol_Table;
		while Ptr /= Nil_Pointer loop
			pragma Assert (Is_Cons(Ptr));

			declare
				Car: Object_Pointer renames Ptr.Pointer_Slot(Cons_Car_Index);
				Cdr: Object_Pointer renames Ptr.Pointer_Slot(Cons_Cdr_Index);
			begin
				pragma Assert (Car.Tag = Symbol_Object);

				if Car.Character_Slot = Source then
					-- the character string contents are the same.
					return Car;
				end if;

				Ptr := Cdr;
			end;
		end loop;

		-- Create a symbol object
		Ptr := Allocate_Character_Object(Interp, Source, Invert);
		Ptr.Tag := Symbol_Object;

		-- Make Ptr safe from GC
		Push_Top (Interp.all, Ptr'Unchecked_Access);

		-- Link the symbol to the symbol table.
		Interp.Symbol_Table := Make_Cons(Interp.Self, Ptr, Interp.Symbol_Table);

		Pop_Tops (Interp.all, 1);

		return Ptr;
	end Make_Symbol;

	-----------------------------------------------------------------------------

	function Make_Array (Interp: access Interpreter_Record;
	                     Size:   in     Pointer_Object_Size) return Object_Pointer is
		Ptr: Object_Pointer;
	begin
		Ptr := Allocate_Pointer_Object(Interp, Size, Nil_Pointer);
		Ptr.Tag := Array_Object;
		return Ptr;
	end Make_Array;

	function Is_Array (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Array);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Array_Object;
	end Is_Array;

	-----------------------------------------------------------------------------

	function Make_Bigint (Interp: access Interpreter_Record;
	                      Size:   in     Half_Word_Object_Size) return Object_Pointer is
		Ptr: Object_Pointer;
	begin
		Ptr := Allocate_Half_Word_Object(Interp, Size);
		Ptr.Tag := Bigint_Object;
		return Ptr;
	end Make_Bigint;

	function Make_Bigint (Interp: access Interpreter_Record;
	                      Value:  in     Object_Integer) return Object_Pointer is
		Size: Pointer_Object_Size;
		Ptr: Object_Pointer;
		W: Object_Word;
		H: Object_Half_Word;
	begin
		if Value < 0 then
			W := Object_Word(-(Object_Signed_Word(Value)));
		else
			W := Object_Word(Value);
		end if;

		H := Bigint.Get_High(W);
		if H > 0 then
			Size := 2;
		else
			Size := 1;
		end if;

		Ptr := Allocate_Half_Word_Object(Interp, Size);
		Ptr.Tag := Bigint_Object;
		Ptr.Half_Word_Slot(1) := Bigint.Get_Low(W);

		if H > 0 then
			Ptr.Half_Word_Slot(2) := H;
		end if;

		if Value < 0 then
			Ptr.Sign := Negative_Sign;
		end if;

		return Ptr;
	end Make_Bigint;

	function Is_Bigint (Source: in Object_Pointer) return Standard.Boolean is
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Bigint_Object;
	end Is_Bigint;

	-----------------------------------------------------------------------------

	function Make_Frame (Interp:  access Interpreter_Record;
	                     Parent:   in     Object_Pointer; -- current stack pointer
	                     Opcode:  in     Object_Pointer;
	                     Operand: in     Object_Pointer;
	                     Envir:   in     Object_Pointer;
	                     Interm:  in     Object_Pointer) return Object_Pointer is
		Frame: Object_Pointer;
		Aliased_Parent: aliased Object_Pointer := Parent;
		Aliased_Opcode: aliased Object_Pointer := Opcode;
		Aliased_Operand: aliased Object_Pointer := Operand;
		Aliased_Envir: aliased Object_Pointer := Envir;
		Aliased_Interm: aliased Object_Pointer := Interm;

	begin
		Push_Top (Interp.all, Aliased_Parent'Unchecked_Access);
		Push_Top (Interp.all, Aliased_Opcode'Unchecked_Access);
		Push_Top (Interp.all, Aliased_Operand'Unchecked_Access);
		Push_Top (Interp.all, Aliased_Envir'Unchecked_Access);
		Push_Top (Interp.all, Aliased_Interm'Unchecked_Access);

-- TODO: create a Frame in a special memory rather than in Heap Memory.
--       Since it's used for stack, it can be made special.
		Frame := Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer);
		Frame.Tag := Frame_Object;
		Frame.Pointer_Slot(Frame_Parent_Index) := Aliased_Parent;
		Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode;
		Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand;
		Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir;
		Frame.Pointer_Slot(Frame_Intermediate_Index) := Aliased_Interm;

		Pop_Tops (Interp.all, 5);
		return Frame;
	end Make_Frame;

	function Is_Frame (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Frame);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Frame_Object;
	end Is_Frame;

	function Get_Frame_Intermediate (Frame: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Frame_Intermediate);
		pragma Assert (Is_Frame(Frame));
	begin
		return Frame.Pointer_Slot(Frame_Intermediate_Index);
	end Get_Frame_Intermediate;

	procedure Set_Frame_Intermediate (Frame: in Object_Pointer;
	                                  Value: in Object_Pointer) is
		pragma Inline (Set_Frame_Intermediate);
		pragma Assert (Is_Frame(Frame));

		-- This procedure is not to set a single result,
		-- but to set the result chain. so it can be useful
		-- if you want to migrate a result chain from one frame
		-- to another. It's what this assertion is for.
		pragma Assert (Value = Nil_Pointer or else Is_Cons(Value));
	begin
		Frame.Pointer_Slot(Frame_Intermediate_Index) := Value;
	end Set_Frame_Intermediate;

	procedure Chain_Frame_Intermediate (Interp: in out Interpreter_Record;
	                                    Frame:  in     Object_Pointer;
	                                    Value:  in     Object_Pointer) is
		pragma Inline (Chain_Frame_Intermediate);
		pragma Assert (Is_Frame(Frame));
		V: Object_Pointer;
	begin
		-- Add a new cons cell to the front

		--Push_Top (Interp, Frame'Unchecked_Access);
		--Frame.Pointer_Slot(Frame_Intermediate_Index) :=
		--	Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Intermediate_Index));
		--Pop_Tops (Interp, 1);

		-- This seems to cause a problem if Interp.Stack changes in Make_Cons().
		--Interp.Stack.Pointer_Slot(Frame_Intermediate_Index) :=
		--	Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Intermediate_Index));

		-- So, let's separate the evaluation and the assignment.
		V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Intermediate_Index));
		Interp.Stack.Pointer_Slot(Frame_Intermediate_Index) := V;
	end Chain_Frame_Intermediate;

	function Get_Frame_Result (Frame: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Frame_Result);
		pragma Assert (Is_Frame(Frame));
	begin
		return Frame.Pointer_Slot(Frame_Result_Index);
	end Get_Frame_Result;

	procedure Set_Frame_Result (Frame: in Object_Pointer;
	                            Value: in Object_Pointer) is
		pragma Inline (Set_Frame_Result);
		pragma Assert (Is_Frame(Frame));
	begin
		Frame.Pointer_Slot(Frame_Result_Index) := Value;
	end Set_Frame_Result;

	procedure Clear_Frame_Result (Frame: in Object_Pointer) is
	begin
		Frame.Pointer_Slot(Frame_Result_Index) := Nil_Pointer;
	end Clear_Frame_Result;

	function Get_Frame_Environment (Frame: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Frame_Environment);
		pragma Assert (Is_Frame(Frame));
	begin
		return Frame.Pointer_Slot(Frame_Environment_Index);
	end Get_Frame_Environment;

	procedure Set_Frame_Environment (Frame: in Object_Pointer;
	                                 Value: in Object_Pointer) is
		pragma Inline (Set_Frame_Environment);
		pragma Assert (Is_Frame(Frame));
	begin
		Frame.Pointer_Slot(Frame_Environment_Index) := Value;
	end Set_Frame_Environment;

	function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is
		pragma Inline (Get_Frame_Opcode);
		pragma Assert (Is_Frame(Frame));
	begin
		return Pointer_To_Opcode(Frame.Pointer_Slot(Frame_Opcode_Index));
	end Get_Frame_Opcode;

	procedure Set_Frame_Opcode (Frame:  in Object_Pointer;
	                            Opcode: in Opcode_Type) is
		pragma Inline (Set_Frame_Opcode);
		pragma Assert (Is_Frame(Frame));
	begin
		Frame.Pointer_Slot(Frame_Opcode_Index) := Opcode_To_Pointer(Opcode);
	end Set_Frame_Opcode;

	function Get_Frame_Operand (Frame: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Frame_Operand);
		pragma Assert (Is_Frame(Frame));
	begin
		return Frame.Pointer_Slot(Frame_Operand_Index);
	end Get_Frame_Operand;

	procedure Set_Frame_Operand (Frame: in Object_Pointer;
	                             Value: in Object_Pointer) is
		pragma Inline (Set_Frame_Operand);
		pragma Assert (Is_Frame(Frame));
	begin
		Frame.Pointer_Slot(Frame_Operand_Index) := Value;
	end Set_Frame_Operand;

	function Get_Frame_Parent (Frame: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Frame_Parent);
		pragma Assert (Is_Frame(Frame));
	begin
		return Frame.Pointer_Slot(Frame_Parent_Index);
	end Get_Frame_Parent;

	procedure Set_Frame_Parent (Frame: in Object_Pointer;
	                            Value: in Object_Pointer) is
		pragma Inline (Set_Frame_Parent);
		pragma Assert (Is_Frame(Frame));
	begin
		Frame.Pointer_Slot(Frame_Parent_Index) := Value;
	end Set_Frame_Parent;

	procedure Switch_Frame (Frame:   in Object_Pointer;
	                        Opcode:  in Opcode_Type;
	                        Operand: in Object_Pointer;
	                        Interm:  in Object_Pointer) is
	begin
		Set_Frame_Opcode (Frame, Opcode);
		Set_Frame_Operand (Frame, Operand);
		Set_Frame_Intermediate (Frame, Interm);
		Set_Frame_Result (Frame, Nil_Pointer);
	end Switch_Frame;

	-----------------------------------------------------------------------------

	--
	-- Environment is a cons cell whose slots represents:
	--   Car: Point to the first key/value pair.
	--   Cdr: Point to Parent environment
	--
	-- A key/value pair is held in an array object consisting of 3 slots.
	--   #1: Key
	--   #2: Value
	--   #3: Link to the next key/value array.
	--
	-- Frame.Environment     Interp.Root_Environment
     --   |                      |
	--   |                      V
	--   |     +----+----+    +----+----+
	--   +---> | |  |   ----> | |  | Nil|
	--         +-|--+-----    +-|--+-----
	--           |              |
	--           |              +--> another list
	--           V
	--         +----+----+----+   +----+----+----+   +----+----+----+   +----+----+----+
	--   list: | |  | |  |  ----> | |  | |  | -----> | |  | |  | -----> | |  | |  | Nil|
	--         +-|--+-|-------+   +-|--+-|-------+   +-|--+-|-------+   +-|--+-|-------+
	--           |    |             |    |             |    |             |    |
	--           V    V             V    V             V    V             V    V
	--          Key  Value          Key  Value        Key  Value         Key  Value
	--
	-- Upon initialization, Root_Frame.Environment is equal to Interp.Root_Environment.
	-- CDR(Interp.Root_Environment) is Nil_Pointer.
	--
	-- TODO: Change environment implementation to a hash table or something similar

	function Make_Environment (Interp: access Interpreter_Record;
	                           Parent: in     Object_Pointer) return Object_Pointer is
		pragma Inline (Make_Environment);
	begin
		return Make_Cons(Interp, Nil_Pointer, Parent);
	end Make_Environment;

	function Find_In_Environment_List (Interp: access Interpreter_Record;
	                                   List:   in     Object_Pointer;
	                                   Key:    in     Object_Pointer) return Object_Pointer is
		Arr: Object_Pointer;
	begin
		Arr := List;
		while Arr /= Nil_Pointer loop
			pragma Assert (Is_Array(Arr));
			pragma Assert (Arr.Size = 3);

			if Arr.Pointer_Slot(1) = Key then
				return Arr;
			end if;

			Arr := Arr.Pointer_Slot(3);
		end loop;
		return null; -- not found.
	end Find_In_Environment_List;

	function Get_Environment (Interp: access Interpreter_Record;
	                          Key:    in     Object_Pointer) return Object_Pointer is
		Envir: Object_Pointer;
		Arr: Object_Pointer;
	begin
		pragma Assert (Is_Symbol(Key));

		Envir := Get_Frame_Environment(Interp.Stack);

		while Envir /= Nil_Pointer loop
			pragma Assert (Is_Cons(Envir));

			Arr := Find_In_Environment_List(Interp, Get_Car(Envir), Key);
			if Arr /= null then
				return Arr.Pointer_Slot(2);
			end if;

			-- Move on to the parent environment
			Envir := Get_Cdr(Envir);
		end loop;
		return null; -- not found
	end Get_Environment;

	function Set_Environment (Interp: access Interpreter_Record;
	                          Key:    in     Object_Pointer;
	                          Value:  in     Object_Pointer) return Object_Pointer is
		Envir: Object_Pointer;
		Arr: Object_Pointer;
	begin
		-- Search the whole environment chain unlike Set_Current_Environment().
		-- It is mainly for set!.
		pragma Assert (Is_Symbol(Key));

		Envir := Get_Frame_Environment(Interp.Stack);
		while Envir /= Nil_Pointer loop
			pragma Assert (Is_Cons(Envir));

			Arr := Find_In_Environment_List(Interp, Get_Car(Envir), Key);
			if Arr /= null then
				-- Overwrite an existing pair
				Arr.Pointer_Slot(2) := Value;
				return Value;
			end if;

			-- Move on to the parent environment
			Envir := Get_Cdr(Envir);
		end loop;
		return null; -- not found. not set
	end Set_Environment;

	procedure Put_Environment (Interp: in out Interpreter_Record;
	                           Envir:  in     Object_Pointer;
	                           Key:    in     Object_Pointer;
	                           Value:  in     Object_Pointer) is
		Arr: Object_Pointer;
	begin
		-- Search the current environment only. It doesn't search the
		-- environment. If no key is found, add a new pair
		-- This is mainly for define.
		pragma Assert (Is_Symbol(Key));
		pragma Assert (Is_Cons(Envir));

		Arr := Find_In_Environment_List(Interp.Self, Get_Car(Envir), Key);
		if Arr /= null then
			-- Found. Update the existing one
			Arr.Pointer_Slot(2) := Value;
		else
			-- Add a new key/value pair in the current environment
			-- if no existing pair has been found.
			declare
				Aliased_Envir: aliased Object_Pointer := Envir;
				Aliased_Key: aliased Object_Pointer := Key;
				Aliased_Value: aliased Object_Pointer := Value;
			begin
				Push_Top (Interp, Aliased_Envir'Unchecked_Access);
				Push_Top (Interp, Aliased_Key'Unchecked_Access);
				Push_Top (Interp, Aliased_Value'Unchecked_Access);

				Arr := Make_Array(Interp.Self, 3);
				Arr.Pointer_Slot(1) := Aliased_Key;
				Arr.Pointer_Slot(2) := Aliased_Value;

				-- Chain the pair to the head of the list
				Arr.Pointer_Slot(3) := Get_Car(Aliased_Envir);
				Set_Car (Aliased_Envir, Arr);

				Pop_Tops (Interp, 3);
			end;
		end if;
	end Put_Environment;

	procedure Set_Current_Environment (Interp: in out Interpreter_Record;
	                                   Key:    in     Object_Pointer;
	                                   Value:  in     Object_Pointer) is
		pragma Inline (Set_Current_Environment);
	begin
		Put_Environment (Interp, Get_Frame_Environment(Interp.Stack), Key, Value);
	end Set_Current_Environment;

	procedure Set_Parent_Environment (Interp: in out Interpreter_Record;
	                                   Key:    in     Object_Pointer;
	                                   Value:  in     Object_Pointer) is
		pragma Inline (Set_Parent_Environment);
	begin
		Put_Environment (Interp, Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)), Key, Value);
	end Set_Parent_Environment;

	-----------------------------------------------------------------------------

	function Make_Syntax (Interp: access Interpreter_Record;
	                      Opcode: in     Syntax_Code;
	                      Name:   in     Object_Character_Array) return Object_Pointer is
		Result: Object_Pointer;
	begin
		Result := Make_Symbol(Interp, Name);
		Result.Flags := Result.Flags or Syntax_Object;
		Result.Scode := Opcode;
--Ada.Text_IO.Put ("Creating Syntax Symbol ");
--Put_String (To_Thin_Object_String_Pointer (Result));
		return Result;
	end Make_Syntax;

	function Is_Syntax (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Syntax);
	begin
		return Is_Symbol(Source) and then (Source.Flags and Syntax_Object) /= 0;
	end Is_Syntax;

	function Make_Procedure (Interp: access Interpreter_Record;
	                         Code:   in     Procedure_Code;
	                         Name:   in     Object_Character_Array) return Object_Pointer is
		-- this procedure is for internal use only
		Symbol: aliased Object_Pointer;
		Proc:   aliased Object_Pointer;
	begin
		Push_Top (Interp.all, Symbol'Unchecked_Access);
		Push_Top (Interp.all, Proc'Unchecked_Access);

		-- Make a symbol for the procedure
		Symbol := Make_Symbol(Interp, Name);

		-- Make the actual procedure object
		Proc := Allocate_Pointer_Object(Interp, Procedure_Object_Size, Nil_Pointer);
		Proc.Tag := Procedure_Object;
		Proc.Pointer_Slot(Procedure_Opcode_Index) := Procedure_Code_To_Pointer(Code);

		-- Link it to the top environement
		pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment);
		pragma Assert (Get_Environment(Interp.Self, Symbol) = null);
		Set_Current_Environment (Interp.all, Symbol, Proc);

		Pop_Tops (Interp.all, 2);
		return Proc;
	end Make_Procedure;

	function Is_Procedure (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Procedure);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Procedure_Object;
	end Is_Procedure;

	function Get_Procedure_Opcode (Proc: in Object_Pointer) return Procedure_Code is
		pragma Inline (Get_Procedure_Opcode);
		pragma Assert (Is_Procedure(Proc));
		pragma Assert (Proc.Size = Procedure_Object_Size);
	begin
		return Pointer_To_Procedure_Code(Proc.Pointer_Slot(Procedure_Opcode_Index));
	end Get_Procedure_Opcode;

	-----------------------------------------------------------------------------

	function Make_Closure (Interp: access Interpreter_Record;
	                       Code:   in     Object_Pointer;
	                       Envir:  in     Object_Pointer) return Object_Pointer is
		Closure: Object_Pointer;
		Aliased_Code: aliased Object_Pointer := Code;
		Aliased_Envir: aliased Object_Pointer := Envir;
	begin
		Push_Top (Interp.all, Aliased_Code'Unchecked_Access);
		Push_Top (Interp.all, Aliased_Envir'Unchecked_Access);

		Closure := Allocate_Pointer_Object (Interp, Closure_Object_Size, Nil_Pointer);
		Closure.Tag := Closure_Object;
		Closure.Pointer_Slot(Closure_Code_Index) := Aliased_Code;
		Closure.Pointer_Slot(Closure_Environment_Index) := Aliased_Envir;

		Pop_Tops (Interp.all, 2);
		return Closure;
	end Make_Closure;

	function Is_Closure (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Closure);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Closure_Object;
	end Is_Closure;

	function Get_Closure_Code (Closure: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Closure_Code);
		pragma Assert (Is_Closure(Closure));
	begin
		return Closure.Pointer_Slot(Closure_Code_Index);
	end Get_Closure_Code;

	function Get_Closure_Environment (Closure: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Closure_Environment);
		pragma Assert (Is_Closure(Closure));
	begin
		return Closure.Pointer_Slot(Closure_Environment_Index);
	end Get_Closure_Environment;

	-----------------------------------------------------------------------------
	function Make_Continuation (Interp: access Interpreter_Record;
	                            Frame:  in     Object_Pointer) return Object_Pointer is
		Cont: Object_Pointer;
		Aliased_Frame: aliased Object_Pointer := Frame;
	begin
		Push_Top (Interp.all, Aliased_Frame'Unchecked_Access);
		Cont := Allocate_Pointer_Object (Interp, Continuation_Object_Size, Nil_Pointer);
		Cont.Tag := Continuation_Object;
		Cont.Pointer_Slot(Continuation_Frame_Index) := Aliased_Frame;
		Pop_Tops (Interp.all, 1);
		return Cont;
	end Make_Continuation;

	function Is_Continuation (Source: in Object_Pointer) return Standard.Boolean is
		pragma Inline (Is_Continuation);
	begin
		return Is_Normal_Pointer(Source) and then
		       Source.Tag = Continuation_Object;
	end Is_Continuation;

	function Get_Continuation_Frame (Cont: in Object_Pointer) return Object_Pointer is
		pragma Inline (Get_Continuation_Frame);
		pragma Assert (Is_Continuation(Cont));
	begin
		return Cont.Pointer_Slot(Continuation_Frame_Index);
	end Get_Continuation_Frame;

	-----------------------------------------------------------------------------
	procedure Deinitialize_Heap (Interp: in out Interpreter_Record) is
	begin
		for I in Interp.Heap'Range loop
			if Interp.Heap(I) /= null then
				declare
					subtype Target_Heap_Record is Heap_Record (Interp.Heap(I).Size);
					type Target_Heap_Pointer is access all Target_Heap_Record;
					package Pool is new H2.Pool (Target_Heap_Record, Target_Heap_Pointer, Interp.Storage_Pool);

					Heap: Target_Heap_Pointer;
					for Heap'Address use Interp.Heap(I)'Address;
					pragma Import (Ada, Heap);
				begin
					Pool.Deallocate (Heap);
				end;
			end if;
		end loop;
	end Deinitialize_Heap;

	procedure Close_Stream (Stream: in out Stream_Pointer) is
	begin
		Close (Stream.all);
		Stream := null;
	exception
		when others =>
			Stream := null; -- ignore exception
	end Close_Stream;

	procedure Start_Named_Input_Stream (Interp: in out Interpreter_Record;
	                                    Name:   access Object_Character_Array) is
		package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool);

		IO: IO_Pointer := null;
		Stream: Stream_Pointer := null;
	begin
		begin
			IO := IO_Pool.Allocate;
			Interp.Stream.Allocate (Interp, Name, Stream);
		exception
			when others =>
				if IO /= null then
					if Stream /= null then
						Interp.Stream.Deallocate (Interp, Stream);
					end if;
					IO_Pool.Deallocate (IO);
				end if;
				raise;
		end;

		--IO.Stream := Stream;
		--IO.Pos := IO.Data'First - 1;
		--IO.Last := IO.Data'First - 1;
		--IO.Flags := 0;
		--IO.Next := Interp.Input;
		--Interp.Input := IO;

		IO.all := IO_Record'(
			Stream => Stream,
			Data => (others => Object_Character'First),
			Pos | Last => IO.Data'First - 1,
			Flags => 0,
			Next => Interp.Input,
			Iochar => IO_Character_Record'(End_Character, Object_Character'First)
		);
		Interp.Input := IO;
	end Start_Named_Input_Stream;

	procedure Stop_Named_Input_Stream (Interp: in out Interpreter_Record) is
		package IO_Pool is new H2.Pool (IO_Record, IO_Pointer, Interp.Storage_Pool);
		IO: IO_Pointer;
	begin
		pragma Assert (Interp.Input /= Interp.Base_Input'Unchecked_Access);
		IO := Interp.Input;
		Interp.Input := IO.Next;

		pragma Assert (IO.Stream /= null);
		Close_Stream (IO.Stream);
		Interp.Stream.Deallocate (Interp, IO.Stream);
		IO_Pool.Deallocate (IO);
	end Stop_Named_Input_Stream;

	-----------------------------------------------------------------------------

	procedure Open (Interp:            in out Interpreter_Record;
	                Initial_Heap_Size: in     Heap_Size;
	                Storage_Pool:      in     Storage_Pool_Pointer := null) is

		procedure Initialize_Heap (Size: Heap_Size) is
			subtype Target_Heap_Record is Heap_Record(Size);
			type Target_Heap_Pointer is access all Target_Heap_Record;
			package Pool is new H2.Pool(Target_Heap_Record, Target_Heap_Pointer, Interp.Storage_Pool);
		begin
			for I in Interp.Heap'Range loop
				Interp.Heap(I) := null; -- just in case
			end loop;

			for I in Interp.Heap'Range loop
				declare
					Heap: Target_Heap_Pointer;
					for Heap'Address use Interp.Heap(I)'Address;
					pragma Import (Ada, Heap);
				begin
					Heap := Pool.Allocate;
				end;
			end loop;

		exception
			when others =>
				Deinitialize_Heap (Interp);
				raise;
		end Initialize_Heap;

		procedure Make_Syntax_Objects is
			Dummy: Object_Pointer;
		begin
			Dummy := Make_Syntax(Interp.Self, And_Syntax,    Label_And); -- "and"
			Dummy := Make_Syntax(Interp.Self, Begin_Syntax,  Label_Begin); -- "begin"
			Dummy := Make_Syntax(Interp.Self, Case_Syntax,   Label_Case); -- "case"
			Dummy := Make_Syntax(Interp.Self, Cond_Syntax,   Label_Cond); -- "cond"
			Dummy := Make_Syntax(Interp.Self, Define_Syntax, Label_Define); -- "define"
			Dummy := Make_Syntax(Interp.Self, Do_Syntax,     Label_Do); -- "do"
			Dummy := Make_Syntax(Interp.Self, If_Syntax,     Label_If); -- "if"
			Dummy := Make_Syntax(Interp.Self, Lambda_Syntax, Label_Lambda); -- "lamba"
			Dummy := Make_Syntax(Interp.Self, Let_Syntax,    Label_Let); -- "let"
			Dummy := Make_Syntax(Interp.Self, Letast_Syntax, Label_Letast); -- "let*"
			Dummy := Make_Syntax(Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrec"
			Dummy := Make_Syntax(Interp.Self, Or_Syntax,     Label_Or); -- "or"
			Interp.Quote_Symbol := Make_Syntax(Interp.Self, Quote_Syntax,  Label_Quote); -- "quote"
			Interp.Quasiquote_Symbol := Make_Syntax(Interp.Self, Quasiquote_Syntax,  Label_Quasiquote); -- "quasiquote"
			Dummy := Make_Syntax(Interp.Self, Set_Syntax,    Label_Set); -- "set!"
		end Make_Syntax_Objects;

		procedure Make_Procedure_Objects is
			Dummy: Object_Pointer;
		begin

			Dummy := Make_Procedure(Interp.Self, Callcc_Procedure,       Label_Callcc); -- "call-with-current-continuation"
			Dummy := Make_Procedure(Interp.Self, Car_Procedure,          Label_Car); -- "car"
			Dummy := Make_Procedure(Interp.Self, Cdr_Procedure,          Label_Cdr); -- "cdr"
			Dummy := Make_Procedure(Interp.Self, Cons_Procedure,         Label_Cons); -- "cons"
			Dummy := Make_Procedure(Interp.Self, Not_Procedure,          Label_Not); -- "not"


			Dummy := Make_Procedure(Interp.Self, N_Add_Procedure,        Label_N_Add); -- "+"
			Dummy := Make_Procedure(Interp.Self, N_EQ_Procedure,         Label_N_EQ); -- "="
			Dummy := Make_Procedure(Interp.Self, N_GE_Procedure,         Label_N_GE); -- ">="
			Dummy := Make_Procedure(Interp.Self, N_GT_Procedure,         Label_N_GT); -- ">"
			Dummy := Make_Procedure(Interp.Self, N_LE_Procedure,         Label_N_LE); -- "<="
			Dummy := Make_Procedure(Interp.Self, N_LT_Procedure,         Label_N_LT); -- "<"
			Dummy := Make_Procedure(Interp.Self, N_Multiply_Procedure,   Label_N_Multiply); -- "*"
			Dummy := Make_Procedure(Interp.Self, N_Quotient_Procedure,   Label_N_Quotient); -- "quotient"
			Dummy := Make_Procedure(Interp.Self, N_Remainder_Procedure,  Label_N_Remainder); -- "remainder"
			Dummy := Make_Procedure(Interp.Self, N_Subtract_Procedure,   Label_N_Subtract); -- "-"

			Dummy := Make_Procedure(Interp.Self, Q_Boolean_Procedure,    Label_Q_Boolean); -- "boolean?"
			Dummy := Make_Procedure(Interp.Self, Q_Eq_Procedure,         Label_Q_Eq); -- "eq?"
			Dummy := Make_Procedure(Interp.Self, Q_Eqv_Procedure,        Label_Q_Eqv); -- "eqv?"
			Dummy := Make_Procedure(Interp.Self, Q_Null_Procedure,       Label_Q_Null); -- "null?"
			Dummy := Make_Procedure(Interp.Self, Q_Number_Procedure,     Label_Q_Number); -- "number?"
			Dummy := Make_Procedure(Interp.Self, Q_Pair_Procedure,       Label_Q_Pair); -- "pair?"
			Dummy := Make_Procedure(Interp.Self, Q_Procedure_Procedure,  Label_Q_Procedure); -- "procedure?"
			Dummy := Make_Procedure(Interp.Self, Q_String_Procedure,     Label_Q_String); -- "string?"
			Dummy := Make_Procedure(Interp.Self, Q_String_EQ_Procedure,  Label_Q_String_EQ); -- "string=?"
			Dummy := Make_Procedure(Interp.Self, Q_Symbol_Procedure,     Label_Q_Symbol); -- "symbol?"

			Dummy := Make_Procedure(Interp.Self, Setcar_Procedure,       Label_Setcar); -- "set-car!"
			Dummy := Make_Procedure(Interp.Self, Setcdr_Procedure,       Label_Setcdr); -- "set-cdr!"

		end Make_Procedure_Objects;

		procedure Make_Common_Symbol_Objects is
		begin
			Interp.Arrow_Symbol := Make_Symbol(Interp.Self, Label_Arrow);
			Interp.Else_Symbol := Make_Symbol(Interp.Self, Label_Else);
		end Make_Common_Symbol_Objects;
	begin
		-- Initialize child packages in case library-level initialization
		-- has been skipped for various reasons.
		Bigint.Initialize;

		declare
			Aliased_Interp: aliased Interpreter_Record;
			for Aliased_Interp'Address use Interp'Address;
			pragma Import (Ada, Aliased_Interp);
		begin
			-- Store a pointer to the interpreter record itself.
			-- I use this pointer to call functions that accept the "access"
			-- type to work around the ada95 limitation of no "in out" as
			-- a function parameter. Accoring to Ada95 RM (6.2), both a
			-- non-private limited record type and a private type whose
			-- full type is a by-reference type are by-rereference types.
			-- So i assume that it's safe to create this aliased overlay
			-- to deceive the compiler. If Interpreter_Record is a tagged
			-- limited record type, this overlay is not needed since the
			-- type is considered aliased. Having this overlay, however,
			-- should be safe for both "tagged" and "non-tagged".
			-- Note: Making it a tagged limit record caused gnat 3.4.6 to
			--       crash with an internal bug report.
			--Interp.Self := Interp'Unchecked_Access; -- if tagged limited
			Interp.Self := Aliased_Interp'Unchecked_Access;
		end;

		Interp.State := 0;
		Interp.Storage_Pool := Storage_Pool;
		Interp.Symbol_Table := Nil_Pointer;

		Interp.Base_Input.Stream := null;
		Interp.Input := Interp.Base_Input'Unchecked_Access;
		Interp.Token := (End_Token, (null, 0, 0));

		Interp.Top := (Interp.Top.Data'First - 1, (others => null));

-- TODO: disallow garbage collecion during initialization.
		Initialize_Heap (Initial_Heap_Size);

		Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer);
		Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Opcode_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment, Nil_Pointer);
		Interp.Stack := Interp.Root_Frame;

		Make_Syntax_Objects;
		Make_Procedure_Objects;
		Make_Common_Symbol_Objects;

	exception
		when others =>
			Deinitialize_Heap (Interp);
	end Open;

	procedure Close (Interp: in out Interpreter_Record) is
	begin
		-- Destroy all unstacked named input streams
		while Interp.Input /= Interp.Base_Input'Unchecked_Access loop
			Stop_Named_Input_Stream (Interp);
		end loop;

		if Interp.Base_Input.Stream /= null then
			-- Close the main input stream.
			Close_Stream (Interp.Base_Input.Stream);
		end if;

		Deinitialize_Heap (Interp);
		Token.Purge (Interp);
	end Close;

	function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer is
	begin
		return Interp.Storage_Pool;
	end Get_Storage_Pool;

	procedure Set_Option (Interp: in out Interpreter_Record;
	                      Option: in     Option_Record) is
	begin
		case Option.Kind  is
			when Trait_Option =>
				Interp.Trait := Option;
			when Stream_Option =>
				Interp.Stream := Option;
		end case;
	end Set_Option;

	procedure Get_Option (Interp: in out Interpreter_Record;
	                      Option: in out Option_Record) is
	begin
		case Option.Kind  is
			when Trait_Option =>
				Option := Interp.Trait;
			when Stream_Option =>
				Option := Interp.Stream;
		end case;
	end Get_Option;

	procedure Set_Input_Stream  (Interp: in out Interpreter_Record;
	                             Stream: in out Stream_Record'Class) is
	begin
		--Open (Stream, Interp);
		Open (Stream);

		-- if Open raised an exception, it wouldn't reach here.
		-- so the existing stream still remains intact.
		if Interp.Base_Input.Stream /= null then
			Close_Stream (Interp.Base_Input.Stream);
		end if;

		Interp.Base_Input := IO_Record'(
			Stream => Stream'Unchecked_Access,
			Data => (others => Object_Character'First),
			Pos | Last => Interp.Base_Input.Data'First - 1,
			Flags => 0,
			Next => null,
			Iochar => IO_Character_Record'(End_Character, Object_Character'First)
		);
	end Set_Input_Stream;

	--procedure Set_Output_Stream (Interp: in out Interpreter_Record;
	--                             Stream: in out Stream_Record'Class) is
	--begin
	--
	--end Set_Output_Stream;

	procedure Print (Interp: in out Interpreter_Record;
	                 Source: in     Object_Pointer) is

		procedure Print_Atom (Atom: in Object_Pointer) is
			Ptr_Type: Object_Pointer_Type;

			procedure Print_Pointee is
				W: Object_Word;
				for W'Address use Atom'Address;
			begin
				case W is
				when Nil_Word =>
					Ada.Text_IO.Put ("()");

				when True_Word =>
					Ada.Text_IO.Put ("#t");

				when False_Word =>
					Ada.Text_IO.Put ("#f");

				when others =>
					case Atom.Tag is
						when Cons_Object =>
							-- Cons_Object must not reach here.
							raise Internal_Error;

						when Symbol_Object =>
							Output_Character_Array (Atom.Character_Slot);

						when String_Object =>
							Ada.Text_IO.Put ("""");
							Output_Character_Array (Atom.Character_Slot);
							Ada.Text_IO.Put ("""");

						when Closure_Object =>
							Ada.Text_IO.Put ("#Closure");

						when Continuation_Object =>
							declare
								w: object_word;
								for w'address use Atom'address;
							begin
								Ada.Text_IO.Put ("#Continuation[" & object_word'image(w) & "]");
							end;

						when Procedure_Object =>
							Ada.Text_IO.Put ("#Procedure");

						when Array_Object =>
							Ada.Text_IO.Put ("#Array");


						when Bigint_Object =>
							Ada.Text_IO.Put ("#Bigint(");
declare
package Int_IO is new ada.text_io.modular_IO(object_half_word);
begin
if Atom.Sign = Negative_Sign then
ada.text_io.put ("-");
else
ada.text_io.put ("+");
end if;
for I in reverse Atom.Half_Word_Slot'Range loop
ada.text_io.put (" ");
int_io.put (Atom.Half_Word_Slot(I), base=>16);
end loop;
end;

							Ada.Text_IO.Put(")");


						when Others =>
							if Atom.Kind = Character_Object then
								Output_Character_Array (Atom.Character_Slot);
							else
								Ada.Text_IO.Put ("#NOIMPL# => " & Object_Tag'Image(Atom.Tag));
							end if;
						end case;
				end case;
			end Print_Pointee;

			procedure Print_Integer is
				 X: constant Object_Integer := Pointer_To_Integer (Atom);
			begin
				Ada.Text_IO.Put (Object_Integer'Image(X));
			end Print_Integer;

			procedure Print_Character is
				 X: constant Object_Character := Pointer_To_Character (Atom);
			begin
				Ada.Text_IO.Put (Object_Character'Image(X));
			end Print_Character;

			procedure Print_Byte is
				 X: constant Object_Byte := Pointer_To_Byte (Atom);
			begin
				Ada.Text_IO.Put (Object_Byte'Image(X));
			end Print_Byte;

		begin
			Ptr_Type := Get_Pointer_Type(Atom);
			case Ptr_Type is
			when Object_Pointer_Type_Pointer =>
				Print_Pointee;

			when Object_Pointer_Type_Integer =>
				Print_Integer;

			when Object_Pointer_Type_Character =>
				Print_Character;

			when Object_Pointer_Type_Byte =>
				Print_Byte;
			end case;
		end Print_Atom;

		procedure Print_Object (Obj: in Object_Pointer) is
			Cons: Object_Pointer;
			Car: Object_Pointer;
			Cdr: Object_Pointer;

		begin
			if Is_Cons(Obj) then
				Cons := Obj;
				Ada.Text_IO.Put ("(");

				loop
					Car := Get_Car(Cons);

					if Is_Cons(Car)  or else Is_Array(Car) then
						Print_Object (Car);
					else
						Print_Atom (Car);
					end if;

					Cdr := Get_Cdr(Cons);
					if Is_Cons(Cdr) then
						Ada.Text_IO.Put (" ");
						Cons := Cdr;
						exit when Cons = Nil_Pointer;
					else
						if Cdr /= Nil_Pointer then
							Ada.Text_IO.Put (" . ");
							Print_Atom (Cdr);
						end if;
						exit;
					end if;
				end loop;

				Ada.Text_IO.Put (")");
			elsif Is_Array(Obj) then
				Ada.Text_IO.Put (" #(");
				for X in Obj.Pointer_Slot'Range loop
					if Is_Cons(Obj.Pointer_Slot(X)) or else Is_Array(Obj.Pointer_Slot(X)) then
						Print_Object (Obj.Pointer_Slot(X));
					else
						Print_Atom (Obj.Pointer_Slot(X));
					end if;
				end loop;
				Ada.Text_IO.Put (") ");
			else
				Print_Atom (Obj);
			end if;
		end Print_Object;


		Stack: Object_Pointer; -- TODO: make it into the interpreter_Record so that GC can workd
		Opcode: Object_Integer;
		Operand: Object_Pointer;

	begin

if DEBUG_GC then
Print_Object (Source); -- use a recursive version
Ada.Text_IO.New_Line;
return;
end if;

		-- TODO: Let Make_Frame use a dedicated stack space that's apart from the heap.
		--       This way, the stack frame doesn't have to be managed by GC.

-- TODO: use a interp.Stack.
-- TODO: use Push_Frame
		Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Nil_Pointer, Nil_Pointer);  -- just for get_frame_environment...

		Opcode := 1;
		Operand := Source;

		loop
			case Opcode is
				when 1 =>
					if Is_Cons(Operand) then
						-- push cdr
						Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push cdr
						Ada.Text_IO.Put ("(");
						Operand := Get_Car(Operand);
						Opcode := 1;
					else
						Print_Atom (Operand);
						if Stack = Nil_Pointer then
							Opcode := 0; -- stack empty. arrange to exit
							Operand := True_Pointer; -- return value
						else
							Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
							Operand := Stack.Pointer_Slot(Frame_Operand_Index);
							Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
						end if;
					end if;

				when 2 =>

					if Is_Cons(Operand) then
						-- push cdr
						Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push
						Ada.Text_IO.Put (" ");
						Operand := Get_Car(Operand); -- car
						Opcode := 1;
					else
						if Operand /= Nil_Pointer then
							-- cdr of the last cons cell is not null.
							Ada.Text_IO.Put (" . ");
							Print_Atom (Operand);
						end if;
						Ada.Text_IO.Put (")");

						if Stack = Nil_Pointer then
							Opcode := 0; -- stack empty. arrange to exit
						else
							Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index));
							Operand := Stack.Pointer_Slot(Frame_Operand_Index);
							Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop
						end if;
					end if;

				when others =>
					exit;
			end case;
		end loop;

		Ada.Text_IO.New_Line;
	end Print;

	function Insert_Frame (Interp:  access Interpreter_Record;
	                       Parent:  in     Object_Pointer;
	                       Opcode:  in     Opcode_Type;
	                       Operand: in     Object_Pointer;
	                       Envir:   in     Object_Pointer;
	                       Interm:  in     Object_Pointer) return Object_Pointer is
		pragma Inline (Insert_Frame);
		pragma Assert (Parent = Nil_Pointer or else Is_Frame(Parent));
	begin
		return Make_Frame(Interp, Parent, Opcode_To_Pointer(Opcode), Operand, Envir, Interm);
	end Insert_Frame;

	procedure Push_Frame (Interp:  in out Interpreter_Record;
	                      Opcode:  in     Opcode_Type;
	                      Operand: in     Object_Pointer) is
		pragma Inline (Push_Frame);
	begin
		Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer);
	end Push_Frame;

	procedure Push_Frame_With_Environment (Interp:  in out Interpreter_Record;
	                                       Opcode:  in     Opcode_Type;
	                                       Operand: in     Object_Pointer;
	                                       Envir:   in     Object_Pointer) is
		pragma Inline (Push_Frame_With_Environment);
	begin
		Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer);
	end Push_Frame_With_Environment;

	procedure Push_Frame_With_Environment_And_Intermediate (Interp:  in out Interpreter_Record;
	                                                        Opcode:  in     Opcode_Type;
	                                                        Operand: in     Object_Pointer;
	                                                        Envir:   in     Object_Pointer;
	                                                        Interm:  in     Object_Pointer) is
		pragma Inline (Push_Frame_With_Environment_And_Intermediate);
	begin
		Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Interm);
	end Push_Frame_With_Environment_And_Intermediate;

	procedure Push_Frame_With_Intermediate (Interp:  in out Interpreter_Record;
	                                        Opcode:  in     Opcode_Type;
	                                        Operand: in     Object_Pointer;
	                                        Interm:  in     Object_Pointer) is
		pragma Inline (Push_Frame_With_Intermediate);
	begin
		-- Place a new frame below the existing top frame.
		Interp.Stack := Insert_Frame (Interp.Self, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm);
	end Push_Frame_With_Intermediate;

	procedure Push_Subframe (Interp:  in out Interpreter_Record;
	                         Opcode:  in     Opcode_Type;
	                         Operand: in     Object_Pointer) is
		pragma Inline (Push_Subframe);
	begin
		-- Place a new frame below the existing top frame.
		Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer));
	end Push_Subframe;

	procedure Push_Subframe_With_Environment (Interp:  in out Interpreter_Record;
	                                          Opcode:  in     Opcode_Type;
	                                          Operand: in     Object_Pointer;
	                                          Envir:   in     Object_Pointer) is
		pragma Inline (Push_Subframe_With_Environment);
	begin
		-- Place a new frame below the existing top frame.
		Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Envir, Nil_Pointer));
	end Push_Subframe_With_Environment;

	procedure Push_Subframe_With_Intermediate (Interp:  in out Interpreter_Record;
	                                           Opcode:  in     Opcode_Type;
	                                           Operand: in     Object_Pointer;
	                                           Interm:  in     Object_Pointer) is
		pragma Inline (Push_Subframe_With_Intermediate);
	begin
		-- Place a new frame below the existing top frame.
		Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm));
	end Push_Subframe_With_Intermediate;

	procedure Push_Subframe_With_Environment_And_Intermediate (Interp:  in out Interpreter_Record;
	                                                           Opcode:  in     Opcode_Type;
	                                                           Operand: in     Object_Pointer;
	                                                           Envir:   in     Object_Pointer;
	                                                           Interm:  in     Object_Pointer) is
		pragma Inline (Push_Subframe_With_Environment_And_Intermediate);
	begin
		-- Place a new frame below the existing top frame.
		Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Envir, Interm));
	end Push_Subframe_With_Environment_And_Intermediate;

	procedure Pop_Frame (Interp: in out Interpreter_Record) is
		pragma Inline (Pop_Frame);
	begin
		pragma Assert (Interp.Stack /= Interp.Root_Frame);
		pragma Assert (Interp.Stack /= Nil_Pointer);
		Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Parent_Index); -- pop
	end Pop_Frame;

	procedure Return_Frame (Interp: in out Interpreter_Record;
	                        Value:  in     Object_Pointer) is
		pragma Inline (Return_Frame);
	begin
		-- Remove the current frame and return a value
		-- to a new active(top) frame.
		Pop_Frame (Interp);
		Set_Frame_Result (Interp.Stack, Value);
	end Return_Frame;

	procedure Reload_Frame (Interp:  in out Interpreter_Record;
	                        Opcode:  in     Opcode_Type;
	                        Operand: in     Object_Pointer) is
		pragma Inline (Reload_Frame);
		Envir: Object_Pointer;
	begin
		-- Change various frame fields keeping the environment.
		Envir := Get_Frame_Environment(Interp.Stack);
		Pop_Frame (Interp);
		Push_Frame_With_Environment (Interp, Opcode, Operand, Envir);
	end Reload_Frame;

	procedure Reload_Frame_With_Environment (Interp:  in out Interpreter_Record;
	                                         Opcode:  in     Opcode_Type;
	                                         Operand: in     Object_Pointer;
	                                         Envir:   in     Object_Pointer) is
		pragma Inline (Reload_Frame_With_Environment);
	begin
		-- Change various frame fields
		Pop_Frame (Interp);
		Push_Frame_With_Environment (Interp, Opcode, Operand, Envir);
	end Reload_Frame_With_Environment;

	procedure Reload_Frame_With_Intermediate (Interp:  in out Interpreter_Record;
	                                          Opcode:  in     Opcode_Type;
	                                          Operand: in     Object_Pointer;
	                                          Interm:  in     Object_Pointer) is
		pragma Inline (Reload_Frame_With_Intermediate);
		Envir: Object_Pointer;
	begin
		-- Change various frame fields keeping the environment.
		Envir := Get_Frame_Environment(Interp.Stack);
		Pop_Frame (Interp);
		Push_Frame_With_Environment_And_Intermediate (Interp, Opcode, Operand, Envir, Interm);
	end Reload_Frame_With_Intermediate;

	procedure Execute (Interp: in out Interpreter_Record) is separate;

	procedure Evaluate (Interp: in out Interpreter_Record;
	                    Source: in     Object_Pointer;
	                    Result: out    Object_Pointer) is
	begin
		Result := Nil_Pointer;

		-- Perform some clean ups in case the procedure is called
		-- again after an exception is raised
		Clear_Tops (Interp);
		Interp.Stack := Interp.Root_Frame;
		Clear_Frame_Result (Interp.Stack);

		-- Push an actual frame for evaluation
		Push_Frame (Interp, Opcode_Evaluate_Object, Source);

		Execute (Interp);

		pragma Assert (Interp.Stack = Interp.Root_Frame);
		pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);

		Result := Get_Frame_Result(Interp.Stack);
		Clear_Frame_Result (Interp.Stack);
	end Evaluate;

	procedure Run_Loop (Interp: in out Interpreter_Record;
	                    Result: out    Object_Pointer) is
		-- standard read-eval-print loop
		Aliased_Result: aliased Object_Pointer;
	begin
		pragma Assert (Interp.Base_Input.Stream /= null);

DEBUG_GC := Standard.True;

		Result := Nil_Pointer;

		-- Perform some clean ups in case the procedure is called
		-- again after an exception is raised
		Clear_Tops (Interp);
		Interp.Stack := Interp.Root_Frame;
		Clear_Frame_Result (Interp.Stack);

		Push_Top (Interp, Aliased_Result'Unchecked_Access);
		loop
			pragma Assert (Interp.Stack = Interp.Root_Frame);
			pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer);

			--Push_Frame (Interp, Opcode_Print_Result, Nil_Pointer);
			Push_Frame (Interp, Opcode_Evaluate_Result, Nil_Pointer);
			Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
			Execute (Interp);

			pragma Assert (Interp.Stack = Interp.Root_Frame);
			pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);

			Aliased_Result := Get_Frame_Result(Interp.Stack);
			Clear_Frame_Result (Interp.Stack);

Ada.Text_IO.Put ("RESULT: ");
Print (Interp, Aliased_Result);
Ada.Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX CHECKPOINT");
		end loop;


		-- Jump into the exception handler not to repeat the same code here.
		-- In fact, this part must not be reached since the loop above can't
		-- be broken.
		raise Stream_End_Error;

	exception
		when Stream_End_Error =>
			-- this is not a real error. this indicates the end of input stream.
declare
q: object_Pointer;
begin
q := bigint.from_string (interp.self, String_To_Object_Character_Array("20000000000000000000000000000000000000000"), 10);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("20000000000"), 10);
q := bigint.to_string (interp.self, q, 10);
print (interp, q);
end;
			goto SKIP;

declare
A: aliased Object_Pointer;
B: aliased Object_Pointer;
begin
Push_Top (Interp, A'Unchecked_Access);
Push_Top (Interp, B'Unchecked_Access);
--A := Make_Bigint(Interp.Self, Value => 16#0FFFFFFF_FFFFFFFF#);
--B := Make_Bigint(Interp.Self, Value => 16#0FFFFFFF_FFFFFFFF#);
--for I in 1 .. 11 loop
--A := Bigint.Add(Interp.Self, A, B);
--end loop;
A := Make_Bigint(Interp.Self, Value => Object_Integer'Last - 16#FFFF#);
--B := Make_Bigint(Interp.Self, Value => 16#FFFF_0000000F#);
B := Make_Bigint(Interp.Self, Value => Object_Integer'Last);
B.sign := Negative_Sign;

A := Make_Bigint(Interp.Self, Size => 30);
A.Half_Word_Slot(30) := Object_Half_Word'Last;
Bigint.Multiply(Interp, A, integer_to_pointer(2), A);
Bigint.Add(Interp, A, A, A);

B := Make_Bigint(Interp.Self, Size => 4);
B.Half_Word_Slot(4) := Object_Half_Word'Last / 2;
Bigint.Subtract(Interp, integer_to_pointer(1), B, B);
--A := Bigint.Divide(Interp, A, integer_to_pointer(0));

ada.text_io.put ("A => "); print (interp, A);
ada.text_io.put ("B => "); print (interp, B);
declare
q, r: object_Pointer;
begin
	--Bigint.Divide (Interp, integer_to_pointer(-10), integer_to_pointer(6), Q, R);

	Bigint.Divide (Interp, A, B, Q, R);
ada.text_io.put ("Q => "); print (interp, Q);
ada.text_io.put ("R => "); print (interp, R);

r := bigint.to_string (interp.self, Q, 16);
--r := bigint.to_string (interp.self, integer_to_pointer(-2), 10);
print (interp, r);

end;
Pop_tops (Interp, 2);
end;

declare
a: object_pointer;
b: object_pointer;
begin
a := Make_Bigint (Interp.Self, Size => 3);
b := Make_Bigint (Interp.Self, Size => 1);
a.half_word_slot(1) := Object_Half_Word'Last;
a.half_word_slot(2) := Object_Half_Word'Last;
b.half_word_Slot(1) := 16#10#;
bigint.multiply (interp, a, b, a);
print (interp, a);
end;
declare
q: object_Pointer;
begin
q := bigint.from_string (interp.self, String_To_Object_Character_Array("-FFFFFFFFFFFFFFFFAAAAAAAAAAAAAAAA11111111222222223333333344444444"), 16);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("-123456789123456789123456789A"), 15, q);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("123456789012345678901234567890"), 10, q);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("+123456701234567012345670123456701234567"), 8, q);
q := bigint.to_string (interp.self, q, 16);
print (interp, q);
end;
<<SKIP>>
			Ada.Text_IO.Put_LINE ("=== BYE ===");
			Pop_Tops (Interp, 1);
			if Aliased_Result /= null then
				Result := Aliased_Result;
			end if;

		when X: others =>
			Ada.TEXT_IO.PUT_LINE ("ERROR ERROR ERROR -> " & Ada.Exceptions.Exception_Name(X));
			raise;
	end Run_Loop;

	-----------------------------------------------------------------------------

--
--	function h2scm_open return Interpreter_Pointer;
--	pragma Export (C, h2scm_open, "h2scm_open");
--
--	procedure h2scm_close (Interp: in out Interpreter_Pointer);
--	pragma Export (C, h2scm_close, "h2scm_close");
--
--	function h2scm_evaluate (Interp: access Interpreter_Record;
--	                         Source: in     Object_Pointer) return Interfaces.C.int;
--	pragma Export (C, h2scm_evaluate, "h2scm_evaluate");
--
--	procedure h2scm_dealloc is new
--		Ada.Unchecked_Deallocation (Interpreter_Record, Interpreter_Pointer);
--
--	function h2scm_open return Interpreter_Pointer is
--		Interp: Interpreter_Pointer;
--	begin
--		begin
--			Interp := new Interpreter_Record;
--		exception
--			when others =>
--				return null;
--		end;
--
--		begin
--			Open (Interp.all, 1_000_000, null);
--		exception
--			when others =>
--				h2scm_dealloc (Interp);
--				return null;
--		end;
--
--		return Interp;
--	end h2scm_open;
--
--	procedure h2scm_close (Interp: in out Interpreter_Pointer) is
--	begin
--Text_IO.Put_Line ("h2scm_close");
--		Close (Interp.all);
--		h2scm_dealloc (Interp);
--	end h2scm_close;
--
--	function h2scm_evaluate (Interp: access Interpreter_Record;
--	                         Source: in     Object_Pointer) return Interfaces.C.int is
--	begin
--		return Interfaces.C.int(Interp.Heap(Interp.Current_Heap).Size);
--	end h2scm_evaluate;

end H2.Scheme;