diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 3fc8b9a..cdc7171 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -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; diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 5b2e059..f08ffbc 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -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: , Cdr: + +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 + -- 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; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index b89a0a5..5beb50e 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -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;