diff --git a/cmd/stream.adb b/cmd/stream.adb index dfc4634..9851ef2 100644 --- a/cmd/stream.adb +++ b/cmd/stream.adb @@ -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; diff --git a/cmd/stream.ads b/cmd/stream.ads index a4e80fa..0134a57 100644 --- a/cmd/stream.ads +++ b/cmd/stream.ads @@ -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; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 9a5e654..8cb30f1 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -641,11 +641,18 @@ Ada.Text_IO.Put_Line (" Flags....after " & Object_Kind'Image(Object.Kind) & " N -- Migrate objects in the root table Print_Object_Pointer ("Root_Table ...", Interp.Root_Table); - Interp.Root_Table := Move_One_Object (Interp.Root_Table); - Interp.Mark := Move_One_Object (Interp.Mark); + Interp.Root_Table := Move_One_Object(Interp.Root_Table); + Interp.Mark := Move_One_Object(Interp.Mark); - -- Scane the heap - Last_Pos := Scan_New_Heap (Interp.Heap(New_Heap).Space'First); + -- 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. -- 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); -- 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]"); -- Scan the new heap again from the end position of -- the previous scan to move referenced objects by -- 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 Interp.Heap(Interp.Current_Heap).Bound := 0; @@ -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); + <> 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; <> Pop_Frame (Interp); -- done Ada.Text_IO.Put ("Return => "); Print (Interp, Operand); Chain_Frame_Result (Interp, Interp.Stack, Operand); + goto 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 diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 18a6460..5905f6b 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -130,7 +130,7 @@ package H2.Scheme is subtype Object_String_Size is Object_Size; 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; 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; 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; - 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_Pointer_Array is array(Object_Index range <>) of Object_Pointer; + type Object_Word_Array is array(Object_Index range <>) of Object_Word; type Object_Kind is ( Moved_Object, -- internal use only @@ -437,9 +437,9 @@ package H2.Scheme is end record; 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); Bound: Heap_Size := 0; end record; @@ -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, @@ -463,6 +463,14 @@ private Kind: Token_Kind; 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 @@ -487,6 +495,8 @@ private Token: Token_Record; LC_Unfetched: Standard.Boolean := Standard.False; + + Top: Top_Record; end record; package Token is diff --git a/lib/h2-utf8.adb b/lib/h2-utf8.adb index ee560a0..b07d4a0 100644 --- a/lib/h2-utf8.adb +++ b/lib/h2-utf8.adb @@ -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; diff --git a/lib/h2-utf8.ads b/lib/h2-utf8.ads index 273f473..afc1ac3 100644 --- a/lib/h2-utf8.ads +++ b/lib/h2-utf8.ads @@ -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;