hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added Self to Interpreter_Record

Browse Source
This commit is contained in:
hyung-hwan 2013-12-11 15:40:57 +00:00
parent 73b2ff2af1
commit abfc6372f6
2 changed files with 57 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
lib/h2-scheme.adb
View File

@ -206,9 +206,10 @@ package body H2.Scheme is
--end; --end;
-- Method 2. -- Method 2.
-- ObjectAda complains that the member of Object_String is not aliased -- ObjectAda complains that the member of Object_String is not
-- because Object_Character_Array is an array of aliased Object_Character. -- aliased because Object_Character_Array is an array of aliased
-- It points to LRM 4.6(12); The component subtypes shall statically match. -- Object_Character.It points to LRM 4.6(12); The component subtypes
-- shall statically match.
-- --------------------------------------------------------------------- -- ---------------------------------------------------------------------
--Target(Target'First .. Target'Last - 1) := Object_Character_Array (Source(Source'First .. Source'Last)); --Target(Target'First .. Target'Last - 1) := Object_Character_Array (Source(Source'First .. Source'Last));
--Target(Target'Last) := Object_Character'First; -- Object_Character'Val(0); --Target(Target'Last) := Object_Character'First; -- Object_Character'Val(0);
@ -239,10 +240,10 @@ package body H2.Scheme is
function To_String (Source: in Object_Character_Array) return Object_String is function To_String (Source: in Object_Character_Array) return Object_String is
begin begin
-- ObjectAda complains that the member of Object_String is not aliased -- ObjectAda complains that the member of Object_String is not
-- because Object_Character_Array is an array of aliased Object_Character. -- aliased because Object_Character_Array is an array of aliased
-- It points to LRM 4.6(12); The component subtypes shall statically match. -- Object_Character. It points to LRM 4.6(12); The component subtypes
-- So let me turn to unchecked conversion. -- shall statically match. So let me turn to unchecked conversion.
declare declare
subtype Character_Array is Object_Character_Array (Source'First .. Source'Last - 1); subtype Character_Array is Object_Character_Array (Source'First .. Source'Last - 1);
subtype String_Array is Object_String (1 .. Source'Length - 1); subtype String_Array is Object_String (1 .. Source'Length - 1);
@ -937,6 +938,28 @@ Put_String (To_Thin_String_Pointer (Result));
Make_Syntax (Interp, SET_SYNTAX, "set!", Dummy); Make_Syntax (Interp, SET_SYNTAX, "set!", Dummy);
end Make_Syntax_Objects; end Make_Syntax_Objects;
begin begin
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.Storage_Pool := Storage_Pool; Interp.Storage_Pool := Storage_Pool;
Interp.Root_Table := Nil_Pointer; Interp.Root_Table := Nil_Pointer;
Interp.Symbol_Table := Nil_Pointer; Interp.Symbol_Table := Nil_Pointer;
@ -976,12 +999,6 @@ Put_String (To_Thin_String_Pointer (Result));
procedure Print (Interp: in out Interpreter_Record; procedure Print (Interp: in out Interpreter_Record;
Source: in Object_Pointer) is Source: in Object_Pointer) is
Accessible_Interp: aliased Interpreter_Record;
for Accessible_Interp'Address use Interp'Address;
pragma Import (Ada, Accessible_Interp);
type Interpreter_Pointer is access all Interpreter_Record;
Interp_Pointer: Interpreter_Pointer := Accessible_Interp'Access;
procedure Print_Atom (Atom: in Object_Pointer) is procedure Print_Atom (Atom: in Object_Pointer) is
Ptr_Type: Object_Pointer_Type; Ptr_Type: Object_Pointer_Type;
@ -1119,7 +1136,7 @@ Put_String (To_Thin_String_Pointer (Result));
when 1 => when 1 =>
if Is_Cons(Operand) then if Is_Cons(Operand) then
-- push cdr -- push cdr
Stack := Make_Frame (Interp_Pointer, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push cdr Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push cdr
Text_IO.Put ("("); Text_IO.Put ("(");
Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car
Opcode := 1; Opcode := 1;
@ -1138,7 +1155,7 @@ Put_String (To_Thin_String_Pointer (Result));
if Is_Cons(Operand) then if Is_Cons(Operand) then
-- push cdr -- push cdr
Stack := Make_Frame (Interp_Pointer, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Operand.Pointer_Slot(Cons_Cdr_Index)); -- push
Text_IO.Put (" "); Text_IO.Put (" ");
Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car Operand := Operand.Pointer_Slot(Cons_Car_Index); -- car
Opcode := 1; Opcode := 1;
@ -1180,37 +1197,27 @@ Make_Symbol (Interp, "lambda", Interp.Root_Table);
Collect_Garbage (Interp); Collect_Garbage (Interp);
declare
Y: aliased Interpreter_Record;
for Y'Address use Interp'Address;
pragma Import (Ada, Y);
type Interpreter_Pointer is access all Interpreter_Record;
Z: Interpreter_Pointer := Y'Access;
begin
-- (define x 10) -- (define x 10)
X := Make_Cons ( X := Make_Cons (
Z, Interp.Self,
Make_Symbol (Z, "define"), Make_Symbol (Interp.Self, "define"),
Make_Cons ( Make_Cons (
Z, Interp.Self,
Make_Symbol (Z, "x"), Make_Symbol (Interp.Self, "x"),
Make_Cons ( Make_Cons (
Z, Interp.Self,
Integer_To_Pointer (10), Integer_To_Pointer (10),
--Nil_Pointer --Nil_Pointer
Integer_To_Pointer (10) Integer_To_Pointer (10)
) )
) )
); );
X := Make_Cons (Z, X, Make_Cons (Z, X, Integer_To_Pointer(10))); X := Make_Cons (Interp.Self, X, Make_Cons (Interp.Self, X, Integer_To_Pointer(10)));
--X := Make_Cons (Z, Nil_Pointer, Make_Cons (Z, Nil_Pointer, Integer_To_Pointer(TEN))); --X := Make_Cons (Interp.Self, Nil_Pointer, Make_Cons (Interp.Self, Nil_Pointer, Integer_To_Pointer(TEN)));
--X := Make_Cons (Z, Nil_Pointer, Nil_Pointer); --X := Make_Cons (Interp.Self, Nil_Pointer, Nil_Pointer);
Print (Interp, X); Print (Interp, X);
end;
end Evaluate; end Evaluate;

9
lib/h2-scheme.ads
View File

@ -245,8 +245,6 @@ package H2.Scheme is
type Memory_Element is mod 2 ** System.Storage_Unit; type Memory_Element is mod 2 ** System.Storage_Unit;
type Memory_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1; type Memory_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1;
type Interpreter_Record is limited private;
type Trait_Mask is mod 2 ** System.Word_Size; type Trait_Mask is mod 2 ** System.Word_Size;
No_Garbage_Collection: constant Trait_Mask := 2 ** 0; No_Garbage_Collection: constant Trait_Mask := 2 ** 0;
@ -287,6 +285,10 @@ package H2.Scheme is
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
type Interpreter_Record is limited private;
-- -----------------------------------------------------------------------------
procedure Open (Interp: in out Interpreter_Record; procedure Open (Interp: in out Interpreter_Record;
Initial_Heap_Size:in Memory_Size; Initial_Heap_Size:in Memory_Size;
Storage_Pool: in Storage_Pool_Pointer := null); Storage_Pool: in Storage_Pool_Pointer := null);
@ -301,6 +303,7 @@ package H2.Scheme is
procedure Get_Option (Interp: in out Interpreter_Record; procedure Get_Option (Interp: in out Interpreter_Record;
Option: in out Option_Record); Option: in out Option_Record);
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
private private
@ -323,7 +326,9 @@ private
Next: Object_Pointer := Nil_Pointer; Next: Object_Pointer := Nil_Pointer;
end record; end record;
type Interpreter_Pointer is access all Interpreter_Record;
type Interpreter_Record is limited record type Interpreter_Record is limited record
Self: Interpreter_Pointer := null;
Storage_Pool: Storage_Pool_Pointer := null; Storage_Pool: Storage_Pool_Pointer := null;
Trait: Option_Record (Trait_Option); Trait: Option_Record (Trait_Option);