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

added code to handle temporary object pointers

Browse Source
This commit is contained in:
hyung-hwan 2014-01-15 09:21:26 +00:00
parent bcf50fe381
commit 2e03937883
6 changed files with 125 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
cmd/stream.adb
View File

@ -52,9 +52,9 @@ Ada.Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
procedure Open (Stream: in out File_Stream_Record) is procedure Open (Stream: in out File_Stream_Record) is
begin begin
Ada.Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & Standard.String(UTF8.Unicode_To_Utf8(UTF8.Unicode_String(Stream.Name.all)))); Ada.Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
--Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Standard.Wide_String(Stream.Name.all))); --Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Standard.Wide_String(Stream.Name.all)));
Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Standard.String(UTF8.Unicode_To_Utf8(UTF8.Unicode_String(Stream.Name.all)))); Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
end Open; end Open;
procedure Close (Stream: in out File_Stream_Record) is procedure Close (Stream: in out File_Stream_Record) is
@ -62,7 +62,7 @@ Ada.Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & Standard.String(UTF8.Uni
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_String, Wide_String); function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_String, Wide_String);
begin begin
--Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all)); --Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all));
Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(UTF8.Unicode_To_Utf8(UTF8.Unicode_String(Stream.Name.all)))); Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
Ada.Wide_Text_IO.Close (Stream.Handle); Ada.Wide_Text_IO.Close (Stream.Handle);
end Close; end Close;

4
cmd/stream.ads
View File

@ -1,11 +1,11 @@
with H2.Scheme; with H2.Scheme;
with H2.UTF8; with H2.Utf8;
with Ada.Wide_Text_IO; with Ada.Wide_Text_IO;
package Stream is package Stream is
package S is new H2.Scheme (Standard.Wide_Character); package S is new H2.Scheme (Standard.Wide_Character);
package UTF8 is new H2.UTF8 (Standard.Wide_Character, Standard.Character); package Utf8 is new H2.Utf8 (Standard.Character, Standard.Wide_Character);
------------------------------------------------------------ ------------------------------------------------------------
--type Object_String_Pointer is access all S.Object_String; --type Object_String_Pointer is access all S.Object_String;

85
lib/h2-scheme.adb
View File

@ -641,11 +641,18 @@ Ada.Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " N
-- Migrate objects in the root table -- Migrate objects in the root table
Print_Object_Pointer ("Root_Table ...", Interp.Root_Table); Print_Object_Pointer ("Root_Table ...", Interp.Root_Table);
Interp.Root_Table := Move_One_Object (Interp.Root_Table); Interp.Root_Table := Move_One_Object(Interp.Root_Table);
Interp.Mark := Move_One_Object (Interp.Mark); Interp.Mark := Move_One_Object(Interp.Mark);
-- Scane the heap -- Migrate temporary object pointers
Last_Pos := Scan_New_Heap (Interp.Heap(New_Heap).Space'First); for I in Interp.Top.Data'First .. Interp.Top.Last loop
if Interp.Top.Data(I).all /= null then
Interp.Top.Data(I).all := Move_One_Object(Interp.Top.Data(I).all);
end if;
end loop;
-- Scan the heap
Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First);
-- Traverse the symbol table for unreferenced symbols. -- Traverse the symbol table for unreferenced symbols.
-- If the symbol has not moved to the new heap, the symbol -- If the symbol has not moved to the new heap, the symbol
@ -656,13 +663,13 @@ Ada.Text_IO.Put_Line (">>> [COMPACTING SYMBOL TABLE]");
Print_Object_Pointer (">>> [MOVING SYMBOL TABLE]", Interp.Symbol_Table); Print_Object_Pointer (">>> [MOVING SYMBOL TABLE]", Interp.Symbol_Table);
-- Migrate the symbol table itself -- Migrate the symbol table itself
Interp.Symbol_Table := Move_One_Object (Interp.Symbol_Table); Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
Ada.Text_IO.Put_Line (">>> [SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]"); Ada.Text_IO.Put_Line (">>> [SCANNING HEAP AGAIN AFTER SYMBOL TABLE MIGRATION]");
-- Scan the new heap again from the end position of -- Scan the new heap again from the end position of
-- the previous scan to move referenced objects by -- the previous scan to move referenced objects by
-- the symbol table. -- the symbol table.
Last_Pos := Scan_New_Heap (Last_Pos); Last_Pos := Scan_New_Heap(Last_Pos);
-- Swap the current heap and the new heap -- Swap the current heap and the new heap
Interp.Heap(Interp.Current_Heap).Bound := 0; Interp.Heap(Interp.Current_Heap).Bound := 0;
@ -1460,6 +1467,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Interp.Base_Input.Stream := null; Interp.Base_Input.Stream := null;
Interp.Input := Interp.Base_Input'Unchecked_Access; Interp.Input := Interp.Base_Input'Unchecked_Access;
Interp.Token := (End_Token, (null, 0, 0)); Interp.Token := (End_Token, (null, 0, 0));
Interp.Top := (Interp.Top.Data'First - 1, (others => null));
-- TODO: disallow garbage collecion during initialization. -- TODO: disallow garbage collecion during initialization.
Ada.Text_IO.Put_Line ("1111111111"); Ada.Text_IO.Put_Line ("1111111111");
@ -1791,6 +1799,37 @@ Ada.Text_IO.Put_Line (Object_Size'Image(IO_Character_Record'Max_Size_In_Storage_
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
end Pop_Frame; end Pop_Frame;
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;
procedure Execute (Interp: in out Interpreter_Record) is procedure Execute (Interp: in out Interpreter_Record) is
LC: IO_Character_Record renames Interp.Input.Iochar; LC: IO_Character_Record renames Interp.Input.Iochar;
@ -1864,10 +1903,14 @@ Ada.Text_IO.Put_Line (Object_Size'Image(IO_Character_Record'Max_Size_In_Storage_
procedure Evaluate_Object is procedure Evaluate_Object is
pragma Inline (Evaluate_Object); pragma Inline (Evaluate_Object);
Operand: Object_Pointer; Operand: aliased Object_Pointer;
Car: Object_Pointer; Car: aliased Object_Pointer;
Cdr: Object_Pointer; Cdr: aliased Object_Pointer;
begin begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
<<Start_Over>> <<Start_Over>>
Operand := Get_Frame_Operand(Interp.Stack); Operand := Get_Frame_Operand(Interp.Stack);
@ -2015,7 +2058,7 @@ Ada.Text_IO.Put_Line (Object_Size'Image(IO_Character_Record'Max_Size_In_Storage_
Clear_Frame_Result (Interp.Stack); Clear_Frame_Result (Interp.Stack);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply); Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand); Set_Frame_Operand (Interp.Stack, Operand);
return; goto Done;
end if; end if;
end loop; end loop;
end if; end if;
@ -2066,13 +2109,17 @@ Ada.Text_IO.Put_Line (Object_Size'Image(IO_Character_Record'Max_Size_In_Storage_
-- normal literal object -- normal literal object
goto Literal; goto Literal;
end case; end case;
return; goto Done;
<<Literal>> <<Literal>>
Pop_Frame (Interp); -- done Pop_Frame (Interp); -- done
Ada.Text_IO.Put ("Return => "); Ada.Text_IO.Put ("Return => ");
Print (Interp, Operand); Print (Interp, Operand);
Chain_Frame_Result (Interp, Interp.Stack, Operand); Chain_Frame_Result (Interp, Interp.Stack, Operand);
goto Done;
<<Done>>
Pop_Tops (Interp, 3);
end Evaluate_Object; end Evaluate_Object;
procedure Evaluate_Procedure is procedure Evaluate_Procedure is
@ -2084,9 +2131,9 @@ Print (Interp, Operand);
procedure Apply is procedure Apply is
pragma Inline (Apply); pragma Inline (Apply);
Operand: Object_Pointer; Operand: aliased Object_Pointer;
Func: Object_Pointer; Func: aliased Object_Pointer;
Args: Object_Pointer; Args: aliased Object_Pointer;
procedure Apply_Car_Procedure is procedure Apply_Car_Procedure is
begin begin
@ -2209,6 +2256,10 @@ Print (Interp, Arg);
end Apply_Closure; end Apply_Closure;
begin begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Func'Unchecked_Access);
Push_Top (Interp, Args'Unchecked_Access);
Operand := Get_Frame_Operand(Interp.Stack); Operand := Get_Frame_Operand(Interp.Stack);
pragma Assert (Is_Cons(Operand)); pragma Assert (Is_Cons(Operand));
@ -2253,6 +2304,8 @@ Print (Interp, Operand);
raise Internal_Error; raise Internal_Error;
end case; end case;
Pop_Tops (Interp, 3);
end Apply; end Apply;
procedure Fetch_Character is procedure Fetch_Character is
@ -2723,6 +2776,9 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
-- The caller must push some frames before calling this procedure -- The caller must push some frames before calling this procedure
pragma Assert (Interp.Stack /= Nil_Pointer); pragma Assert (Interp.Stack /= Nil_Pointer);
-- The caller must ensure there are no temporary object pointers.
pragma Assert (Interp.Top.Last < Interp.Top.Data'First);
loop loop
case Get_Frame_Opcode(Interp.Stack) is case Get_Frame_Opcode(Interp.Stack) is
when Opcode_Exit => when Opcode_Exit =>
@ -2814,6 +2870,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
begin begin
pragma Assert (Interp.Base_Input.Stream /= null); pragma Assert (Interp.Base_Input.Stream /= null);
Clear_Tops (Interp);
Result := Nil_Pointer; Result := Nil_Pointer;
loop loop

24
lib/h2-scheme.ads
View File

@ -130,7 +130,7 @@ package H2.Scheme is
subtype Object_String_Size is Object_Size; subtype Object_String_Size is Object_Size;
subtype Object_String_Index is Object_Index; subtype Object_String_Index is Object_Index;
type Object_String is array (Object_String_Index range <>) of Object_Character; type Object_String is array(Object_String_Index range <>) of Object_Character;
type Object_String_Pointer is access all Object_String; type Object_String_Pointer is access all Object_String;
for Object_String_Pointer'Size use Object_Pointer_Bits; for Object_String_Pointer'Size use Object_Pointer_Bits;
@ -142,10 +142,10 @@ package H2.Scheme is
type Thin_Object_String_Pointer is access all Thin_Object_String; type Thin_Object_String_Pointer is access all Thin_Object_String;
for Thin_Object_String_Pointer'Size use Object_Pointer_Bits; for Thin_Object_String_Pointer'Size use Object_Pointer_Bits;
type Object_Byte_Array is array (Object_Index range <>) of Object_Byte; type Object_Byte_Array is array(Object_Index range <>) of Object_Byte;
subtype Object_Character_Array is Object_String; subtype Object_Character_Array is Object_String;
type Object_Pointer_Array is array (Object_Index range <>) of Object_Pointer; type Object_Pointer_Array is array(Object_Index range <>) of Object_Pointer;
type Object_Word_Array is array (Object_Index range <>) of Object_Word; type Object_Word_Array is array(Object_Index range <>) of Object_Word;
type Object_Kind is ( type Object_Kind is (
Moved_Object, -- internal use only Moved_Object, -- internal use only
@ -437,9 +437,9 @@ package H2.Scheme is
end record; end record;
private private
type Heap_Element_Array is array (Heap_Size range <>) of aliased Heap_Element; type Heap_Element_Array is array(Heap_Size range <>) of aliased Heap_Element;
type Heap_Record (Size: Heap_Size) is record type Heap_Record(Size: Heap_Size) is record
Space: Heap_Element_Array(1..Size) := (others => 0); Space: Heap_Element_Array(1..Size) := (others => 0);
Bound: Heap_Size := 0; Bound: Heap_Size := 0;
end record; end record;
@ -447,7 +447,7 @@ private
type Heap_Pointer is access all Heap_Record; type Heap_Pointer is access all Heap_Record;
type Heap_Number is mod 2 ** 1; type Heap_Number is mod 2 ** 1;
type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer; type Heap_Pointer_Array is array(Heap_Number'First .. Heap_Number'Last) of Heap_Pointer;
type Token_Kind is (End_Token, type Token_Kind is (End_Token,
Identifier_Token, Identifier_Token,
@ -464,6 +464,14 @@ private
Value: Buffer_Record; Value: Buffer_Record;
end record; end record;
-- Temporary Object Pointer to preserve during GC
type Top_Datum is access all Object_Pointer;
type Top_Array is array(Object_Index range<>) of Top_Datum;
type Top_Record is record
Last: Object_Size := 0;
Data: Top_Array(1 .. 100) := (others => null);
end record;
--type Interpreter_Record is tagged limited record --type Interpreter_Record is tagged limited record
type Interpreter_Record is limited record type Interpreter_Record is limited record
--Self: Interpreter_Pointer := null; --Self: Interpreter_Pointer := null;
@ -487,6 +495,8 @@ private
Token: Token_Record; Token: Token_Record;
LC_Unfetched: Standard.Boolean := Standard.False; LC_Unfetched: Standard.Boolean := Standard.False;
Top: Top_Record;
end record; end record;
package Token is package Token is

50
lib/h2-utf8.adb
View File

@ -1,6 +1,6 @@
with ada.text_io; with ada.text_io;
package body H2.UTF8 is package body H2.Utf8 is
type Uint8 is mod 2 ** 8; type Uint8 is mod 2 ** 8;
type Uint32 is mod 2 ** 32; type Uint32 is mod 2 ** 32;
@ -25,8 +25,8 @@ package body H2.UTF8 is
(16#0400_0000#, 16#7FFF_FFFF#, 16#FC#, 16#FE#, 16#01#, 6) (16#0400_0000#, 16#7FFF_FFFF#, 16#FC#, 16#FE#, 16#01#, 6)
); );
function Get_UTF8_Slot (UV: in Uint32) return System_Size is function Get_Utf8_Slot (UV: in Uint32) return System_Size is
pragma Inline (Get_UTF8_Slot); pragma Inline (Get_Utf8_Slot);
begin begin
for I in Conv_Table'Range loop for I in Conv_Table'Range loop
if UV >= Conv_Table(I).Lower and then UV <= Conv_Table(I).Upper then if UV >= Conv_Table(I).Lower and then UV <= Conv_Table(I).Upper then
@ -34,37 +34,36 @@ package body H2.UTF8 is
end if; end if;
end loop; end loop;
return System_Size'First; return System_Size'First;
end Get_UTF8_Slot; end Get_Utf8_Slot;
function Unicode_To_UTF8 (UC: in Unicode_Character) return UTF8_String is function Unicode_To_Utf8 (UC: in Unicode_Character) return Utf8_String is
UV: Uint32; UV: Uint32;
I: System_Size; I: System_Size;
begin begin
UV := Unicode_Character'Pos(UC); UV := Unicode_Character'Pos(UC);
I := Get_UTF8_Slot(UV); I := Get_Utf8_Slot(UV);
if I not in System_Index'Range then if I not in System_Index'Range then
raise Invalid_Unicode_Character; raise Invalid_Unicode_Character;
end if; end if;
declare declare
subtype Result_String is UTF8_String(1 .. System_Index(Conv_Table(I).Length)); Result: Utf8_String (1 .. System_Index(Conv_Table(I).Length));
Result: Result_String;
begin begin
for J in reverse Result_String'First + 1 .. Result_String'Last loop for J in reverse Result'First + 1 .. Result'Last loop
-- 2#0011_1111#: 16#3F# -- 2#0011_1111#: 16#3F#
-- 2#1000_0000#: 16#80# -- 2#1000_0000#: 16#80#
Result(J) := UTF8_Character'Val((UV and 2#0011_1111#) or 2#1000_0000#); Result(J) := Utf8_Character'Val((UV and 2#0011_1111#) or 2#1000_0000#);
UV := UV / (2 ** 6); --UV := UV >> 6; UV := UV / (2 ** 6); --UV := UV >> 6;
end loop; end loop;
Result(Result_String'First) := UTF8_Character'Val(UV or Uint32(Conv_Table(I).Fbyte)); Result(Result'First) := Utf8_Character'Val(UV or Uint32(Conv_Table(I).Fbyte));
return Result; return Result;
end; end;
end Unicode_To_UTF8; end Unicode_To_Utf8;
function Unicode_To_UTF8 (US: in Unicode_String) return UTF8_String is function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String is
-- this function has high stack pressur if the input string is too long -- this function has high stack pressur if the input string is too long
-- TODO: create a procedure to overcome this problem. -- TODO: create a procedure to overcome this problem.
Tmp: System_Size; Tmp: System_Size;
@ -72,39 +71,38 @@ package body H2.UTF8 is
Tmp := 0; Tmp := 0;
for I in US'Range loop for I in US'Range loop
declare declare
UTF8: UTF8_String := Unicode_To_UTF8(US(I)); Utf8: Utf8_String := Unicode_To_Utf8(US(I));
begin begin
Tmp := Tmp + UTF8'Length; Tmp := Tmp + Utf8'Length;
end; end;
end loop; end loop;
declare declare
subtype Result_String is UTF8_String(1 .. Tmp); Result: Utf8_String (1 .. Tmp);
Result: Result_String;
begin begin
Tmp := Result'First; Tmp := Result'First;
for I in US'Range loop for I in US'Range loop
declare declare
UTF8: UTF8_String := Unicode_To_UTF8(US(I)); Utf8: Utf8_String := Unicode_To_Utf8(US(I));
begin begin
Result(Tmp .. Tmp + UTF8'Length - 1) := UTF8; Result(Tmp .. Tmp + Utf8'Length - 1) := Utf8;
Tmp := Tmp + UTF8'Length; Tmp := Tmp + Utf8'Length;
end; end;
end loop; end loop;
return Result; return Result;
end; end;
end Unicode_To_UTF8; end Unicode_To_Utf8;
procedure UTF8_To_Unicode (UTF8: in UTF8_String; procedure Utf8_To_Unicode (Utf8: in Utf8_String;
UC: out Unicode_Character) is UC: out Unicode_Character) is
begin begin
null; null;
end UTF8_To_Unicode; end Utf8_To_Unicode;
procedure UTF8_To_Unicode (UTF8: in UTF8_String; procedure Utf8_To_Unicode (Utf8: in Utf8_String;
US: in out Unicode_String) is US: in out Unicode_String) is
begin begin
null; null;
end UTF8_To_Unicode; end Utf8_To_Unicode;
end H2.UTF8; end H2.Utf8;

16
lib/h2-utf8.ads
View File

@ -1,20 +1,20 @@
generic generic
type Utf8_Character_Type is (<>);
type Unicode_Character_Type is (<>); type Unicode_Character_Type is (<>);
type UTF8_Character_Type is (<>); package H2.Utf8 is
package H2.UTF8 is
Invalid_Unicode_Character: exception; Invalid_Unicode_Character: exception;
subtype Unicode_Character is Unicode_Character_Type; subtype Unicode_Character is Unicode_Character_Type;
subtype UTF8_Character is UTF8_Character_Type; subtype Utf8_Character is Utf8_Character_Type;
type UTF8_String is array(System_Index range<>) of UTF8_Character; type Utf8_String is array(System_Index range<>) of Utf8_Character;
type Unicode_String is array(System_Index range<>) of Unicode_Character; type Unicode_String is array(System_Index range<>) of Unicode_Character;
function Unicode_To_UTF8 (UC: in Unicode_Character) return UTF8_String; function Unicode_To_Utf8 (UC: in Unicode_Character) return Utf8_String;
function Unicode_To_UTF8 (US: in Unicode_String) return UTF8_String; function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String;
--procedure UTF8_To_Unicode (UTF8: in UTF8_String; --procedure Utf8_To_Unicode (Utf8: in Utf8_String;
-- UC: out Unicode_Character_Type); -- UC: out Unicode_Character_Type);
end H2.UTF8; end H2.Utf8;