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
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, 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;
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);
begin
--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);
end Close;

4
cmd/stream.ads
View File

@ -1,11 +1,11 @@
with H2.Scheme;
with H2.UTF8;
with H2.Utf8;
with Ada.Wide_Text_IO;
package Stream is
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;

75
lib/h2-scheme.adb
View File

@ -644,7 +644,14 @@ Print_Object_Pointer ("Root_Table ...", Interp.Root_Table);
Interp.Root_Table := Move_One_Object(Interp.Root_Table);
Interp.Mark := Move_One_Object(Interp.Mark);
-- Scane the heap
-- Migrate temporary object pointers
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.
@ -1460,6 +1467,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
Interp.Base_Input.Stream := null;
Interp.Input := Interp.Base_Input'Unchecked_Access;
Interp.Token := (End_Token, (null, 0, 0));
Interp.Top := (Interp.Top.Data'First - 1, (others => null));
-- TODO: disallow garbage collecion during initialization.
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
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
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
pragma Inline (Evaluate_Object);
Operand: Object_Pointer;
Car: Object_Pointer;
Cdr: Object_Pointer;
Operand: aliased Object_Pointer;
Car: aliased Object_Pointer;
Cdr: aliased Object_Pointer;
begin
Push_Top (Interp, Operand'Unchecked_Access);
Push_Top (Interp, Car'Unchecked_Access);
Push_Top (Interp, Cdr'Unchecked_Access);
<<Start_Over>>
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);
Set_Frame_Opcode (Interp.Stack, Opcode_Apply);
Set_Frame_Operand (Interp.Stack, Operand);
return;
goto Done;
end if;
end loop;
end if;
@ -2066,13 +2109,17 @@ Ada.Text_IO.Put_Line (Object_Size'Image(IO_Character_Record'Max_Size_In_Storage_
-- normal literal object
goto Literal;
end case;
return;
goto Done;
<<Literal>>
Pop_Frame (Interp); -- done
Ada.Text_IO.Put ("Return => ");
Print (Interp, Operand);
Chain_Frame_Result (Interp, Interp.Stack, Operand);
goto Done;
<<Done>>
Pop_Tops (Interp, 3);
end Evaluate_Object;
procedure Evaluate_Procedure is
@ -2084,9 +2131,9 @@ Print (Interp, Operand);
procedure Apply is
pragma Inline (Apply);
Operand: Object_Pointer;
Func: Object_Pointer;
Args: Object_Pointer;
Operand: aliased Object_Pointer;
Func: aliased Object_Pointer;
Args: aliased Object_Pointer;
procedure Apply_Car_Procedure is
begin
@ -2209,6 +2256,10 @@ Print (Interp, Arg);
end Apply_Closure;
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);
pragma Assert (Is_Cons(Operand));
@ -2253,6 +2304,8 @@ Print (Interp, Operand);
raise Internal_Error;
end case;
Pop_Tops (Interp, 3);
end Apply;
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
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
case Get_Frame_Opcode(Interp.Stack) is
when Opcode_Exit =>
@ -2814,6 +2870,7 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
begin
pragma Assert (Interp.Base_Input.Stream /= null);
Clear_Tops (Interp);
Result := Nil_Pointer;
loop

12
lib/h2-scheme.ads
View File

@ -447,7 +447,7 @@ private
type Heap_Pointer is access all Heap_Record;
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,
Identifier_Token,
@ -464,6 +464,14 @@ private
Value: Buffer_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 limited record
--Self: Interpreter_Pointer := null;
@ -487,6 +495,8 @@ private
Token: Token_Record;
LC_Unfetched: Standard.Boolean := Standard.False;
Top: Top_Record;
end record;
package Token is

50
lib/h2-utf8.adb
View File

@ -1,6 +1,6 @@
with ada.text_io;
package body H2.UTF8 is
package body H2.Utf8 is
type Uint8 is mod 2 ** 8;
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)
);
function Get_UTF8_Slot (UV: in Uint32) return System_Size is
pragma Inline (Get_UTF8_Slot);
function Get_Utf8_Slot (UV: in Uint32) return System_Size is
pragma Inline (Get_Utf8_Slot);
begin
for I in Conv_Table'Range loop
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 loop;
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;
I: System_Size;
begin
UV := Unicode_Character'Pos(UC);
I := Get_UTF8_Slot(UV);
I := Get_Utf8_Slot(UV);
if I not in System_Index'Range then
raise Invalid_Unicode_Character;
end if;
declare
subtype Result_String is UTF8_String(1 .. System_Index(Conv_Table(I).Length));
Result: Result_String;
Result: Utf8_String (1 .. System_Index(Conv_Table(I).Length));
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#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;
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;
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
-- TODO: create a procedure to overcome this problem.
Tmp: System_Size;
@ -72,39 +71,38 @@ package body H2.UTF8 is
Tmp := 0;
for I in US'Range loop
declare
UTF8: UTF8_String := Unicode_To_UTF8(US(I));
Utf8: Utf8_String := Unicode_To_Utf8(US(I));
begin
Tmp := Tmp + UTF8'Length;
Tmp := Tmp + Utf8'Length;
end;
end loop;
declare
subtype Result_String is UTF8_String(1 .. Tmp);
Result: Result_String;
Result: Utf8_String (1 .. Tmp);
begin
Tmp := Result'First;
for I in US'Range loop
declare
UTF8: UTF8_String := Unicode_To_UTF8(US(I));
Utf8: Utf8_String := Unicode_To_Utf8(US(I));
begin
Result(Tmp .. Tmp + UTF8'Length - 1) := UTF8;
Tmp := Tmp + UTF8'Length;
Result(Tmp .. Tmp + Utf8'Length - 1) := Utf8;
Tmp := Tmp + Utf8'Length;
end;
end loop;
return Result;
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
begin
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
begin
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
type Utf8_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;
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;
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 (UC: in Unicode_Character) 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);
end H2.UTF8;
end H2.Utf8;