diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index aee28b5..2f32e84 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -360,23 +360,35 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); procedure Evaluate_Letast_Syntax is pragma Inline (Evaluate_Letast_Syntax); - Envir: Object_Pointer; + Envir: aliased Object_Pointer; begin Check_Let_Syntax; -- Car: , Cdr: - Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call); - Set_Frame_Operand (Interp.Stack, Cdr); - Clear_Frame_Result (Interp.Stack); + Reload_Frame (Interp, Opcode_Grouped_Call, Cdr); + + -- Create a new environment over the current environment. + Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); + Set_Frame_Environment (Interp.Stack, Envir); -- update the environment if Car /= Nil_Pointer then -- is not empty - Push_Frame (Interp, Opcode_Letast_Binding, Car); - else - -- is empty. push the new environment - -- for evaluation. - Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); - Set_Frame_Environment (Interp.Stack, Envir); + + Push_Top (Interp, Envir'Unchecked_Access); + + -- Say, is ((x 2) (y 2)). + -- Get_Car(Car) is (x 2). + -- To get x, Get_Car(Get_Car(Car)) + -- To get 2, Get_Car(Get_Cdr(Get_Car(Car))) + + -- Arrange to evaluate the first expression in the parent environment. + Push_Frame_With_Environment (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Car))), Envir); + + -- Arrange to perform actual binding. Pass the name as an intermediate + -- and the next remaing list as an operand. + Push_Subframe_With_Environment_And_Intermediate (Interp, Opcode_Letast_Binding, Get_Cdr(Car), Envir, Get_Car(Get_Car(Car))); + + Pop_Tops (Interp, 1); end if; end Evaluate_Letast_Syntax; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index c0a064b..50fa9e5 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -240,6 +240,55 @@ procedure Execute (Interp: in out Interpreter_Record) is end if; end Do_Let_Binding; + procedure Do_Letast_Binding is + pragma Inline (Do_Letast_Binding); + O: aliased Object_Pointer; + Envir: Object_Pointer; + begin + -- Perform binding in the parent environment. + Set_Current_Environment (Interp, Get_Frame_Intermediate(Interp.Stack), Get_Frame_Result(Interp.Stack)); + + O := Get_Frame_Operand(Interp.Stack); + + -- Say, is ((x 2) (y 2)). + -- Get_Car(O) is (x 2). + -- To get x, Get_Car(Get_Car(O)) + -- To get 2, Get_Car(Get_Cdr(Get_Car(O))) + if Is_Cons(O) then + Push_Top (Interp, O'Unchecked_Access); + + Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); + Set_Frame_Environment (Interp.Stack, Envir); + + Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O)))); + Push_Subframe_With_Intermediate (Interp, Opcode_Letast_Binding, Get_Cdr(O), Get_Car(Get_Car(O))); + + Pop_Tops (Interp, 1); + else +--envir := get_frame_environment(interp.stack); +--declare +--w: object_word; +--for w'address use envir'address; +--begin +--ada.text_io.put_line ("i$$$$$$$$$$$$$$$$$$$$$$$$44 ENVIR => " & object_word'image(w)); +--print (interp, envir); +--end; + -- Get the final environment + Envir := Get_Frame_Environment(Interp.Stack); + + -- Get stored in the Opcode_Grouped_Call frame + -- pushed in Evalute_Letast_Syntax(). + O := Get_Frame_Operand(Get_Frame_Parent(Interp.Stack)); + + Pop_Frame (Interp); -- Current frame + pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Grouped_Call); + + -- Refresh the Opcode_Grouped_Call frame pushed in Evaluate_Letast_Syntax() + -- with the final environment. + Reload_Frame_With_Environment (Interp, Opcode_Grouped_Call, O, Envir); + end if; + end Do_Letast_Binding; + procedure Do_Letrec_Binding is pragma Inline (Do_Letrec_Binding); O: aliased Object_Pointer; @@ -265,57 +314,6 @@ procedure Execute (Interp: in out Interpreter_Record) is end if; end Do_Letrec_Binding; - procedure Do_Letast_Binding is - pragma Inline (Do_Letast_Binding); - X: Object_Pointer; - begin - X := Get_Frame_Operand(Interp.Stack); -- and onward - - -- Don't call this procedure if is empty. The caller must ensure this - pragma Assert (Is_Cons(X)); - - Set_Frame_Opcode (Interp.Stack, Opcode_Letast_Binding_Finish); - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); - end Do_Letast_Binding; - - procedure Do_Letast_Binding_Finish is - pragma Inline (Do_Letast_Binding_Finish); - X: aliased Object_Pointer; - Envir: aliased Object_Pointer; - begin - Push_Top (Interp, X'Unchecked_Access); - Push_Top (Interp, Envir'Unchecked_Access); - - X := Get_Frame_Operand(Interp.Stack); -- and onward - - -- Update the environment while evaluating - - -- Push a new environment for each binding. - Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); - Set_Frame_Environment (Interp.Stack, Envir); - Set_Current_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack)); - - X := Get_Cdr(X); -- next binding - if Is_Cons(X) then - -- More bingings to evaluate - Set_Frame_Operand (Interp.Stack, X); - Clear_Frame_Result (Interp.Stack); - - -- the next evaluation must be done in the environment where the - -- current binding has been made. - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); - else - -- No more bingings left - Pop_Frame (Interp); -- Done - - -- Update the environment of the Let_Finish frame. - --pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); - Set_Frame_Environment (Interp.Stack, Envir); - end if; - - Pop_Tops (Interp, 2); - end Do_Letast_Binding_Finish; - -- -------------------------------------------------------------------- procedure Do_Set_Finish is @@ -915,9 +913,6 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); when Opcode_Letast_Binding => Do_Letast_Binding; - when Opcode_Letast_Binding_Finish => - Do_Letast_Binding_Finish; - when Opcode_Letrec_Binding => Do_Letrec_Binding; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 1b107c2..8791454 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -105,7 +105,6 @@ package body H2.Scheme is Opcode_If_Finish, Opcode_Let_Binding, Opcode_Letast_Binding, - Opcode_Letast_Binding_Finish, Opcode_Letrec_Binding, Opcode_Procedure_Call, Opcode_Procedure_Call_Finish, @@ -1977,6 +1976,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); when Array_Object => Ada.Text_IO.Put ("#Array"); + when Others => if Atom.Kind = Character_Object then @@ -2036,7 +2036,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); loop Car := Get_Car(Cons); - if Is_Cons (Car) then + if Is_Cons(Car) or else Is_Array(Car) then Print_Object (Car); else Print_Atom (Car); @@ -2057,6 +2057,16 @@ Ada.Text_IO.Put_Line ("Make_String..."); end loop; Ada.Text_IO.Put (")"); + elsif Is_Array(Obj) then + Ada.Text_IO.Put (" #("); + for X in Obj.Pointer_Slot'Range loop + if Is_Cons(Obj.Pointer_Slot(X)) or else Is_Array(Obj.Pointer_Slot(X)) then + Print_Object (Obj.Pointer_Slot(X)); + else + Print_Atom (Obj.Pointer_Slot(X)); + end if; + end loop; + Ada.Text_IO.Put (") "); else Print_Atom (Obj); end if; @@ -2253,11 +2263,22 @@ end if; Envir: Object_Pointer; begin -- Change various frame fields keeping the environment. - Envir := Get_Frame_Environment (Interp.Stack); + Envir := Get_Frame_Environment(Interp.Stack); Pop_Frame (Interp); Push_Frame_With_Environment (Interp, Opcode, Operand, Envir); end Reload_Frame; + procedure Reload_Frame_With_Environment (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Envir: in Object_Pointer) is + pragma Inline (Reload_Frame_With_Environment); + begin + -- Change various frame fields + Pop_Frame (Interp); + Push_Frame_With_Environment (Interp, Opcode, Operand, Envir); + end Reload_Frame_With_Environment; + procedure Reload_Frame_With_Intermediate (Interp: in out Interpreter_Record; Opcode: in Opcode_Type; Operand: in Object_Pointer; @@ -2266,7 +2287,7 @@ end if; Envir: Object_Pointer; begin -- Change various frame fields keeping the environment. - Envir := Get_Frame_Environment (Interp.Stack); + Envir := Get_Frame_Environment(Interp.Stack); Pop_Frame (Interp); Push_Frame_With_Environment_And_Intermediate (Interp, Opcode, Operand, Envir, Interm); end Reload_Frame_With_Intermediate;