fixed a bug of not updating the frame to the new environment when apply a closure

This commit is contained in:
2014-01-24 13:57:06 +00:00
parent 15ff09019a
commit fcdfd4cde7
3 changed files with 53 additions and 59 deletions

View File

@ -2000,78 +2000,53 @@ end if;
Ada.Text_IO.New_Line;
end Print;
function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type is
pragma Inline (Pointer_To_Opcode);
begin
return Pointer_To_Integer(Pointer);
end Pointer_To_Opcode;
function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer is
pragma Inline (Opcode_To_Pointer);
begin
return Integer_To_Pointer(Opcode);
end Opcode_To_Pointer;
function Pointer_To_Opcode (Pointer: in Object_Pointer) return Opcode_Type renames Pointer_To_Integer;
function Opcode_To_Pointer (Opcode: in Opcode_Type) return Object_Pointer renames Integer_To_Pointer;
procedure Push_Frame (Interp: in out Interpreter_Record;
Opcode: in Opcode_Type;
Operand: in Object_Pointer) is
pragma Inline (Push_Frame);
begin
--Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Interp.Environment);
Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), Operand, Get_Frame_Environment(Interp.Stack));
end Push_Frame;
--procedure Pop_Frame (Interp.Stack: out Object_Pointer;
-- Opcode: out Opcode_Type;
-- Operand: out Object_Pointer) is
-- pragma Inline (Pop_Frame);
--begin
-- pragma Assert (Interp.Stack /= Nil_Pointer);
-- Opcode := Pointer_To_Opcode(Interp.Stack.Pointer_Slot(Frame_Opcode_Index));
-- Operand := Interp.Stack.Pointer_Slot(Frame_Operand_Index);
-- Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
--end Pop_Frame;
procedure Pop_Frame (Interp: in out Interpreter_Record) is
pragma Inline (Pop_Frame);
begin
pragma Assert (Interp.Stack /= Interp.Root_Frame);
pragma Assert (Interp.Stack /= Nil_Pointer);
Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Stack_Index); -- pop
end Pop_Frame;
procedure Execute (Interp: in out Interpreter_Record) is separate;
procedure Evaluate (Interp: in out Interpreter_Record;
Source: in Object_Pointer;
Result: out Object_Pointer) is
begin
-- Push a pseudo-frame to terminate the evaluation loop
--pragma Assert (Interp.Stack = Nil_Pointer);
--Interp.Stack := Nil_Pointer;
--Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
pragma Assert (Interp.Stack = Interp.Root_Frame);
pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer);
Result := Nil_Pointer;
-- Push the actual frame for evaluation
-- Perform some clean ups in case the procedure is called
-- again after an exception is raised
Clear_Tops (Interp);
Interp.Stack := Interp.Root_Frame;
Clear_Frame_Result (Interp.Stack);
-- Push an actual frame for evaluation
Push_Frame (Interp, Opcode_Evaluate_Object, Source);
Execute (Interp);
pragma Assert (Interp.Stack = Interp.Root_Frame);
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
Result := Get_Frame_Result (Interp.Stack);
Result := Get_Frame_Result(Interp.Stack);
-- There must be only 1 value chained to the top-level frame
-- once evaluation is over.
pragma Assert (Get_Cdr(Result) = Nil_Pointer);
-- Get the only value chained
Result := Get_Car(Result);
--Pop_Frame (Interp);
--pragma Assert (Interp.Stack = Nil_Pointer);
pragma Assert (Interp.Stack = Interp.Root_Frame);
Clear_Frame_Result (Interp.Stack);
Result := Get_Car(Result); -- Get the only value chained
Clear_Frame_Result (Interp.Stack);
end Evaluate;
procedure Run_Loop (Interp: in out Interpreter_Record;
@ -2081,36 +2056,35 @@ end if;
pragma Assert (Interp.Base_Input.Stream /= null);
--DEBUG_GC := Standard.True;
Clear_Tops (Interp);
Result := Nil_Pointer;
-- Perform some clean ups in case the procedure is called
-- again after an exception is raised
Clear_Tops (Interp);
Interp.Stack := Interp.Root_Frame;
Clear_Frame_Result (Interp.Stack);
loop
--pragma Assert (Interp.Stack = Nil_Pointer);
--Interp.Stack := Nil_Pointer;
--Push_Frame (Interp, Opcode_Exit, Nil_Pointer);
pragma Assert (Interp.Stack = Interp.Root_Frame);
pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer);
--Push_Frame (Interp, Opcode_Print_Result, Nil_Pointer);
Push_Frame (Interp, Opcode_Evaluate_Result, Nil_Pointer);
Push_Frame (Interp, Opcode_Read_Object, Nil_Pointer);
Execute (Interp);
pragma Assert (Interp.Stack = Interp.Root_Frame);
pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit);
-- TODO: this result must be kept at some where that GC dowsn't sweep.
Result := Get_Frame_Result (Interp.Stack);
Result := Get_Frame_Result(Interp.Stack);
pragma Assert (Get_Cdr(Result) = Nil_Pointer);
Result := Get_Car(Result);
Clear_Frame_Result (Interp.Stack);
--Pop_Frame (Interp);
Ada.Text_IO.Put ("RESULT>>>>>");
Print (Interp, Result);
--pragma Assert (Interp.Stack = Nil_Pointer);
pragma Assert (Interp.Stack = Interp.Root_Frame);
Clear_Frame_Result (Interp.Stack);
Ada.Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX CHECKPOINT");
end loop;