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

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

Browse Source
This commit is contained in:
hyung-hwan 2014-01-24 13:57:06 +00:00
parent bf612cca65
commit 4b4f8de4fd
3 changed files with 53 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
lib/h2-scheme-execute-apply.adb
View File

@ -305,8 +305,10 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
-- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))"
-- Create a new environment for the closure
--Interp.Environment := Make_Environment(Interp.Self, Get_Closure_Environment(Func));
Envir := Make_Environment(Interp.Self, Get_Closure_Environment(Func));
-- Update the environment of the frame to the one created above
-- so as to put the arguments into the new environment.
Set_Frame_Environment (Interp.Stack, Envir);
Fbody := Get_Closure_Code(Func);
pragma Assert (Is_Cons(Fbody)); -- the lambda evaluator must ensure this.
@ -325,7 +327,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
else
while Is_Cons(Formal) loop
if not Is_Cons(Actual) then
Ada.Text_IO.Put_Line (">>>> Too few arguments for CLOSURE <<<<");
Ada.Text_IO.Put_Line (">>>> TOO FEW ARGUMENTS FOR CLOSURE <<<<");
raise Evaluation_Error;
end if;
@ -353,15 +355,10 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
end if;
end if;
-- TODO: is it correct to keep the environement in the frame?
Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
Set_Frame_Operand (Interp.Stack, Fbody);
Clear_Frame_Result (Interp.Stack);
-- Update the environment of the frame so as to perform
-- body evaluation in the new environment.
Set_Frame_Environment (Interp.Stack, Envir);
Pop_Tops (Interp, 4);
end Apply_Closure;

25
lib/h2-scheme-execute-evaluate.adb
View File

@ -214,7 +214,6 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
declare
Closure: Object_Pointer;
begin
--Closure := Make_Closure(Interp.Self, Operand, Interp.Environment);
Closure := Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack));
Pop_Frame (Interp); -- Done
Chain_Frame_Result (Interp, Interp.Stack, Closure);
@ -350,6 +349,27 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
end if;
end Evaluate_Letast_Syntax;
procedure Evaluate_Letrec_Syntax is
pragma Inline (Evaluate_Letrec_Syntax);
Envir: Object_Pointer;
begin
Check_Let_Syntax;
-- Car: <bindings>, Cdr: <body>
ada.text_io.put_line ("XXXXX <<< LETREC IMPLEMENTATION NEEDED >>XXXXXXXXXXXXXXXXXXXXXXXXXXX");
--Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish);
--Set_Frame_Operand (Interp.Stack, Cdr);
-- Push a new environment to the current frame.
--Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack));
--Set_Frame_Environment (Interp.Stack, Envir);
--if Car /= Nil_Pointer then
-- <bindings> is not empty
-- Push_Frame (Interp, Opcode_Letrec_Binding, Car);
--end if;
end Evaluate_Letrec_Syntax;
procedure Evaluate_Quote_Syntax is
pragma Inline (Evaluate_Quote_Syntax);
begin
@ -483,6 +503,9 @@ begin
when Letast_Syntax =>
Evaluate_Letast_Syntax;
when Letrec_Syntax =>
Evaluate_Letrec_Syntax;
when Or_Syntax =>
Evaluate_Or_Syntax;

76
lib/h2-scheme.adb
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;