diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb new file mode 100644 index 0000000..c9901af --- /dev/null +++ b/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; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 83b9053..b4e286d 100644 --- a/lib/h2-scheme-execute.adb +++ b/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 diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 2c479d8..02e757a 100644 --- a/lib/h2-scheme.adb +++ b/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); - Arr.Tag := Array_Object; - return Arr; + 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 @@ -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. diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 2c6822a..b9adfb0 100644 --- a/lib/h2-scheme.ads +++ b/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 ( - Unknown_Object, - Cons_Object, - String_Object, - Symbol_Object, - Number_Object, - Array_Object, - Table_Object, - Procedure_Object, - Closure_Object, - Continuation_Object, - Frame_Object + type Object_Sign is ( + Positive_Sign, + Negative_Sign ); 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) - Flags at 0 range 4 .. 7; -- 4 bits - Scode at 0 range 8 .. 11; -- 4 bits (0 .. 15) - Tag at 0 range 12 .. 15; -- 4 bits (0 .. 15) + Kind at 0 range 0 .. 2; -- 3 bits (0 .. 7) + Flags at 0 range 3 .. 6; -- 4 bits + Tag at 0 range 7 .. 10; -- 4 bits (0 .. 15) + Scode at 0 range 11 .. 14; -- 4 bits (0 .. 15) + Sign at 0 range 15 .. 15; -- 1 bit (0 or 1) -- there are still some space unused in the first word. What can i do? end record; for Object_Record'Alignment use Object_Pointer_Bytes; @@ -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; diff --git a/lib/lib.gpr.in b/lib/lib.gpr.in index 4cf0fbc..5d2368c 100644 --- a/lib/lib.gpr.in +++ b/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",