added code to handle temporary object pointers

This commit is contained in:
2014-01-15 09:21:26 +00:00
parent 967f70fd34
commit 7a80455258
6 changed files with 125 additions and 60 deletions

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
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);
<<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