started adding bigint

lib/h2-scheme-bigint.adb

@@ -0,0 +1,68 @@
+with H2.Pool;
+
+separate (H2.Scheme)
+
+package body Bigint is
+
+	use type System.Bit_Order;
+
+	Big_Endian : constant := Standard.Boolean'Pos (
+		System.Default_Bit_Order = System.High_Order_First
+	);
+	Little_Endian : constant := Standard.Boolean'Pos (
+		System.Default_Bit_Order = System.Low_Order_First
+	);
+
+	Half_Word_Bits: constant := Object_Pointer_Bits / 2;
+	Half_Word_Bytes: constant := Half_Word_Bits / System.Storage_Unit;
+
+	type Word_Record is record
+		Low: Object_Half_Word;
+		High: Object_Half_Word;
+	end record;
+	for Word_Record use record
+		--Low at 0 range 0 .. Half_Word_Bits - 1;
+		--High at 0 range Half_Word_Bits .. Word_Bits - 1;
+		Low  at Half_Word_Bytes * (0 * Little_Endian + 1 * Big_Endian)
+		     range 0 .. Half_Word_Bits - 1;
+		High at Half_Word_Bytes * (1 * Little_Endian + 0 * Big_Endian)
+		     range 0 .. Half_Word_Bits - 1;
+	end record;
+	for Word_Record'Size use Object_Word'Size;
+	--for Word_Record'Size use Object_Pointer_Bits;
+	--for Word_Record'Alignment use Object_Word'Alignment;
+	--for Word_Record'Scalar_Storage_Order use System.High_Order_First;
+	--for Word_Record'Bit_Order use System.High_Order_First;
+	--for Word_Record'Bit_Order use System.Low_Order_First;
+
+	function Get_Low (W: in Object_Word) return Object_Half_Word is
+		R: Word_Record;
+		for R'Address use W'Address;		
+	begin
+		return R.Low;	
+	end Get_Low;
+
+	function Get_High (W: in Object_Word) return Object_Half_Word is
+		R: Word_Record;
+		for R'Address use W'Address;		
+	begin
+		return R.High;	
+	end Get_High;
+
+	function Add (Interp: access Interpreter_Record;
+	              X:      in     Object_Pointer;
+	              Y:      in     Object_Pointer) return Object_Pointer is
+		pragma Assert (Is_Integer(X) or else Is_Bigint(X));
+		pragma Assert (Is_Integer(Y) or else Is_Bigint(Y));
+
+		Z: Object_Pointer;
+		
+	begin
+		--if X.Size > Y.Size then
+		--end if;
+
+		--Z := Make_Bigint (Interp,  X.Size
+		return null;
+	end Add;
+
+end Bigint;

lib/h2-scheme-execute.adb

@@ -353,12 +353,6 @@ procedure Execute (Interp: in out Interpreter_Record) is
 			-- apply the evaluated arguments to the evaluated operator.
 			R := Reverse_Cons(R);
 
---ada.text_io.put_line ("xxxxxxxxxxxxxxxxxx");
---print (interp, r);
---print (interp, get_car(r));
---print (interp, get_cdr(r));
---ada.text_io.put_line ("xxxxxxxxxxxxxxxxxx");
-
 			-- This frame can be resumed. Switching the current frame to Opcode_Apply
 			-- affects continuation objects that point to the current frame. However,
 			-- keeping it unchanged causes this frame to repeat actions that has been 
@@ -526,10 +520,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
 
 		X := Get_Frame_Operand(Interp.Stack); -- symbol
 		Y := Get_Frame_Result(Interp.Stack);  -- value
-ada.text_io.put ("%%%%% FINISH SET SYNTAX => [");
+
-print (interp, X);
-print (interp, Y);
-ada.text_io.put_line ("]");
 		pragma Assert (Is_Symbol(X));
 
 		if Set_Environment(Interp.Self, X, Y) = null then

lib/h2-scheme.adb

@@ -13,6 +13,7 @@ with ada.exceptions;
 
 package body H2.Scheme is
 
+	package body Bigint is separate;
 	package body Token is separate;
 	package Ch is new Ascii(Object_Character);
 
@@ -536,6 +537,13 @@ package body H2.Scheme is
 							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;
 
@@ -1028,8 +1036,9 @@ end if;
 			Kind => Pointer_Object,
 			Size => Size,
 			Flags => 0,
-			Scode => Syntax_Code'Val(0),
 			Tag => Unknown_Object,
+			Scode => Syntax_Code'Val(0),
+			Sign => Positive_Sign,
 			Pointer_Slot => (others => Initial)
 		);
 
@@ -1059,8 +1068,9 @@ end if;
 			Kind => Character_Object,
 			Size => Size,
 			Flags => 0,
-			Scode => Syntax_Code'Val(0),
 			Tag => Unknown_Object,
+			Scode => Syntax_Code'Val(0),
+			Sign => Positive_Sign,
 			Character_Slot => (others => Ch.NUL),
 			Character_Terminator => Ch.NUL
 		);
@@ -1100,13 +1110,68 @@ end if;
 			Kind => Byte_Object,
 			Size => Size,
 			Flags => 0,
-			Scode => Syntax_Code'Val(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;
@@ -1301,11 +1366,11 @@ end if;
 
 	function Make_Array (Interp: access Interpreter_Record;
 	                     Size:   in     Pointer_Object_Size) return Object_Pointer is
-		Arr: Object_Pointer;
+		Ptr: Object_Pointer;
 	begin
-		Arr := Allocate_Pointer_Object (Interp, Size, Nil_Pointer);
+		Ptr := Allocate_Pointer_Object(Interp, Size, Nil_Pointer);
-		Arr.Tag := Array_Object;
+		Ptr.Tag := Array_Object;
-		return Arr;
+		return Ptr;
 	end Make_Array;
 
 	function Is_Array (Source: in Object_Pointer) return Standard.Boolean is
@@ -1317,6 +1382,61 @@ end if;
 
 	-----------------------------------------------------------------------------
 
+	function Make_Bigint (Interp: access Interpreter_Record;
+	                      Size:   in     Pointer_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;
+
+ada.text_io.put_line (Object_Half_Word'image(bigint.get_high(w)));
+ada.text_io.put_line (Object_Half_Word'image(bigint.get_low(w)));
+		return Ptr;
+	end Make_Bigint;
+
+	function Is_Bigint (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Bigint);
+	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;
@@ -2518,6 +2638,7 @@ 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.

lib/h2-scheme.ads

@@ -82,6 +82,9 @@ package H2.Scheme is
 	type Object_Word is mod 2 ** Object_Pointer_Bits;
 	for Object_Word'Size use Object_Pointer_Bits;
 
+	type Object_Half_Word is mod 2 ** (Object_Pointer_Bits / 2);
+	for Object_Half_Word'Size use (Object_Pointer_Bits / 2);
+
 	-- Object_Signed_Word is the signed version of Object_Word.
 	-- Note Object_Word is a modular type while this is a signed range.
 	type Object_Signed_Word is range -(2 ** (Object_Pointer_Bits - 1)) ..
@@ -132,6 +135,7 @@ package H2.Scheme is
 	type Object_Character_Array is array(Object_Index range <>) of Object_Character;
 	type Object_Byte_Array is array(Object_Index range <>) of Object_Byte;
 	type Object_Word_Array is array(Object_Index range <>) of Object_Word;
+	type Object_Half_Word_Array is array(Object_Index range <>) of Object_Half_Word;
 
 	type Object_Character_Array_Pointer is access all Object_Character_Array;
 	for Object_Character_Array_Pointer'Size use Object_Pointer_Bits;
@@ -146,14 +150,16 @@ package H2.Scheme is
 		Pointer_Object,
 		Character_Object,
 		Byte_Object,
-		Word_Object
+		Word_Object,
+		Half_Word_Object
 	);
 	for Object_Kind use (
 		Moved_Object => 0,
 		Pointer_Object => 1,
 		Character_Object => 2,
 		Byte_Object => 3,
-		Word_Object => 4
+		Word_Object => 4,
+		Half_Word_Object => 5
 	);
 
 	-- -----------------------------------------------------------------------
@@ -166,6 +172,19 @@ package H2.Scheme is
 	Syntax_Checked: constant Object_Flags := Object_Flags'(2#0010#);
 	Argument_Checked: constant Object_Flags := Object_Flags'(2#0100#);
 
+	type Object_Tag is (
+		Unknown_Object, 
+		Cons_Object,
+		String_Object,
+		Symbol_Object,
+		Array_Object,
+		Bigint_Object,
+		Procedure_Object,
+		Closure_Object,
+		Continuation_Object,
+		Frame_Object
+	);
+
 	type Syntax_Code is (
 		And_Syntax,
 		Begin_Syntax,
@@ -184,24 +203,16 @@ package H2.Scheme is
 		Set_Syntax
 	);
 
-	type Object_Tag is (
+	type Object_Sign is (
-		Unknown_Object, 
+		Positive_Sign,
-		Cons_Object,
+		Negative_Sign
-		String_Object,
-		Symbol_Object,
-		Number_Object,
-		Array_Object,
-		Table_Object,
-		Procedure_Object,
-		Closure_Object,
-		Continuation_Object,
-		Frame_Object
 	);
 
 	type Object_Record(Kind: Object_Kind; Size: Object_Size) is record
 		Flags: Object_Flags := 0;
-		Scode: Syntax_Code := Syntax_Code'Val(0);
 		Tag: Object_Tag := Unknown_Object;
+		Scode: Syntax_Code := Syntax_Code'Val(0); -- Used if Flags contain Syntax_Object
+		Sign: Object_Sign := Positive_Sign; -- Used for Bigint_Object
 
 		-- Object payload:
 		--  I assume that the smallest payload is able to hold an 
@@ -211,8 +222,10 @@ package H2.Scheme is
 		case Kind is
 			when Moved_Object =>
 				New_Pointer: Object_Pointer := null;
+
 			when Pointer_Object =>
 				Pointer_Slot: Object_Pointer_Array(1 .. Size) := (others => null);
+
 			when Character_Object =>
 				Character_Slot: Object_Character_Array(1 .. Size) := (others => Object_Character'First);
 				-- The character terminator is to ease integration with 
@@ -222,17 +235,23 @@ package H2.Scheme is
 				--       character_slot without any gaps in between 
 				--       under the current alignement condition?
 				Character_Terminator: Object_Character := Object_Character'First; 
+
 			when Byte_Object =>
 				Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0);
+
 			when Word_Object =>
 				Word_Slot: Object_Word_Array(1 .. Size) := (others => 0);
+
+			when Half_Word_Object =>
+				Half_Word_Slot: Object_Half_Word_Array(1 .. Size) := (others => 0);
 		end case;
 	end record;
 	for Object_Record use record
-		Kind  at 0 range 0 .. 3; -- 4 bits (0 .. 15)
+		Kind  at 0 range 0 .. 2; -- 3 bits (0 .. 7)
-		Flags at 0 range 4 .. 7; -- 4 bits 
+		Flags at 0 range 3 .. 6; -- 4 bits 
-		Scode at 0 range 8 .. 11; -- 4 bits (0 .. 15)
+		Tag   at 0 range 7 .. 10; -- 4 bits (0 .. 15)
-		Tag   at 0 range 12 .. 15; -- 4 bits (0 .. 15)
+		Scode at 0 range 11 .. 14; -- 4 bits (0 .. 15)
+		Sign  at 0 range 15 .. 15; -- 1 bit (0 or 1)
 		-- there are still some space unused in the first word. What can i do?
 	end record;
 	for Object_Record'Alignment use Object_Pointer_Bytes;
@@ -257,6 +276,8 @@ package H2.Scheme is
 		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Pointer'Max_Size_In_Storage_Elements * System.Storage_Unit));
 	subtype Word_Object_Size is Object_Size range
 		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Word'Max_Size_In_Storage_Elements * System.Storage_Unit));
+	subtype Half_Word_Object_Size is Object_Size range
+		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Half_Word'Max_Size_In_Storage_Elements * System.Storage_Unit));
 
 	-- -----------------------------------------------------------------------------
 	-- Various pointer classification and conversion procedures
@@ -289,6 +310,11 @@ package H2.Scheme is
 
 	-- -----------------------------------------------------------------------------
 
+	function Is_Cons (Source: in Object_Pointer) return Standard.Boolean;
+	function Is_Bigint (Source: in Object_Pointer) return Standard.Boolean;
+
+	-- -----------------------------------------------------------------------------
+
 
 	type Stream_Record is abstract tagged limited null record;
 
@@ -539,5 +565,18 @@ private
 
 	end Token;
 
+	package Bigint is
+
+		function Get_Low (W: Object_Word) return Object_Half_Word;
+		function Get_High (W: Object_Word) return Object_Half_Word;
+
+		pragma Inline (Get_High);
+		pragma Inline (Get_Low);
+
+		function Add (Interp: access Interpreter_Record;
+		              X:      in     Object_Pointer;
+		              Y:      in     Object_Pointer) return Object_Pointer;
+
+	end Bigint;
 
 end H2.Scheme;

lib/lib.gpr.in

@@ -14,6 +14,7 @@ project Lib is
 		"h2-pool.ads",
 		"h2-scheme.adb",
 		"h2-scheme.ads",
+		"h2-scheme-bigint.adb",
 		"h2-scheme-execute.adb",
 		"h2-scheme-execute-apply.adb",
 		"h2-scheme-execute-evaluate.adb",