started adding bigint
This commit is contained in:
parent
cffbaef42f
commit
f43fef30c2
68
lib/h2-scheme-bigint.adb
Normal file
68
lib/h2-scheme-bigint.adb
Normal file
@ -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;
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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",
|
||||
|
||||
Loading…
Reference in New Issue
Block a user