From 81d910a0e1fffdfa086cd5aa1741cfac0c128c2b Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 9 Feb 2014 15:28:46 +0000 Subject: [PATCH] made let and letrec continuation-friendly --- lib/h2-scheme-execute-apply.adb | 6 +- lib/h2-scheme-execute-evaluate.adb | 94 +++++++++------ lib/h2-scheme-execute.adb | 183 ++++++++++------------------- lib/h2-scheme.adb | 80 +++++++++++-- lib/h2-scheme.ads | 8 +- 5 files changed, 203 insertions(+), 168 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index 80ef56e..a01b042 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -316,7 +316,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); -- Closure made of a lambda expression with a single formal argument -- e.g) (lambda x (car x)) -- Apply the whole actual argument list to the closure. - Put_Environment (Interp, Formal, Actual); + Set_Current_Environment (Interp, Formal, Actual); else while Is_Cons(Formal) loop if not Is_Cons(Actual) then @@ -325,7 +325,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); end if; -- Insert the key/value pair into the environment - Put_Environment (Interp, Get_Car(Formal), Get_Car(Actual)); + Set_Current_Environment (Interp, Get_Car(Formal), Get_Car(Actual)); Formal := Get_Cdr(Formal); Actual := Get_Cdr(Actual); @@ -336,7 +336,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); -- The last formal argument to the closure is in a CDR. -- Assign the remaining actual arguments to the last formal argument -- e.g) ((lambda (x y . z) z) 1 2 3 4 5) - Put_Environment (Interp, Formal, Actual); + Set_Current_Environment (Interp, Formal, Actual); else -- The lambda evaluator must ensure all formal arguments are symbols. pragma Assert (Formal = Nil_Pointer); diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 4a17bb8..aee28b5 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -7,6 +7,8 @@ procedure Evaluate is Car: aliased Object_Pointer; Cdr: aliased Object_Pointer; + -- ---------------------------------------------------------------- + generic Result: Object_Pointer; -- Result to return if no expressions exist. Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next . @@ -41,6 +43,8 @@ procedure Evaluate is procedure Evaluate_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_And_Finish); procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Or_Finish); + -- ---------------------------------------------------------------- + procedure Evaluate_Define_Syntax is pragma Inline (Evaluate_Define_Syntax); begin @@ -84,6 +88,8 @@ raise Syntax_Error; end if; end Evaluate_Define_Syntax; + -- ---------------------------------------------------------------- + procedure Evaluate_If_Syntax is pragma Inline (Evaluate_If_Syntax); begin @@ -135,6 +141,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Push_Subframe (Interp, Opcode_If_Finish, Operand); end Evaluate_If_Syntax; + -- ---------------------------------------------------------------- + procedure Evaluate_Lambda_Syntax is pragma Inline (Evaluate_Lambda_Syntax); begin @@ -213,6 +221,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Return_Frame (Interp, Make_Closure(Interp.Self, Operand, Get_Frame_Environment(Interp.Stack))); end Evaluate_Lambda_Syntax; + -- ---------------------------------------------------------------- + procedure Check_Let_Syntax is pragma Inline (Check_Let_Syntax); @@ -297,20 +307,6 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); pragma Inline (Evaluate_Let_Syntax); Envir: aliased Object_Pointer; begin - Check_Let_Syntax; - -- Car: , Cdr: - - Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); - Set_Frame_Operand (Interp.Stack, Cdr); - Clear_Frame_Result (Interp.Stack); - - -- Push a new environment onto the current frame. - -- It's pushed even if is empty because - -- the new environment is still needed in such a case - -- as shown in the first sample below. - Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); - Set_Frame_Environment (Interp.Stack, Envir); - -- Some let samples: -- #1. -- (define x 99) ; define x in the root environment @@ -327,22 +323,37 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); -- (define x (let ((x x)) x)) -- + Check_Let_Syntax; + -- Car: , Cdr: + + -- Switch the frame to Opcode_Grouped_Call and let its environment + -- be the new environment created. Use Reload_Frame() instead + -- of Switch_Frame() for continuation. This frame is executed once + -- the Opcode_Let_Binding frame pushed in the 'if' block is finished. + 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_Top (Interp, Envir'Unchecked_Access); Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)); - -- Create an array to hold the binding list and the evaluation result - Cdr := Make_Array (Interp.Self, 3); - Cdr.Pointer_Slot(1) := Car; + -- 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))) - -- The actual binding after evaluation must be performed in the - -- new environment. - Push_Frame (Interp, Opcode_Let_Binding, Cdr); + -- 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_Let_Binding, Get_Cdr(Car), Envir, Get_Car(Get_Car(Car))); - -- But evaluation must be done in the current environment which is - -- the environment before the environment update above. - Push_Frame_With_Environment (Interp, Opcode_Let_Evaluation, Cdr, Envir); Pop_Tops (Interp, 1); end if; end Evaluate_Let_Syntax; @@ -354,7 +365,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Check_Let_Syntax; -- Car: , Cdr: - Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); + Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call); Set_Frame_Operand (Interp.Stack, Cdr); Clear_Frame_Result (Interp.Stack); @@ -376,26 +387,35 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Check_Let_Syntax; -- Car: , Cdr: - Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); - Set_Frame_Operand (Interp.Stack, Cdr); - Clear_Frame_Result (Interp.Stack); + -- Switch the frame to Opcode_Grouped_Call and let its environment + -- be the new environment created. Use Reload_Frame() instead + -- of Switch_Frame() for continuation. This frame is executed once + -- the Opcode_Letrec_Binding frame pushed in the 'if' block is finished. + Reload_Frame (Interp, Opcode_Grouped_Call, Cdr); - -- Push a new environment. + -- Create a new environment over the current environment. Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); - Set_Frame_Environment (Interp.Stack, Envir); + Set_Frame_Environment (Interp.Stack, Envir); -- update the environment if Car /= Nil_Pointer then -- is not empty - -- Arrange to perform evaluataion and binding in the - -- new environment created. - Cdr := Make_Array (Interp.Self, 3); - Cdr.Pointer_Slot(1) := Car; - Push_Frame (Interp, Opcode_Let_Binding, Cdr); - Push_Frame (Interp, Opcode_Let_Evaluation, Cdr); + -- 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 (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(Car)))); + + -- Arrange to perform actual binding. Pass the name as an intermediate + -- and the next remaing list as an operand. + Push_Subframe_With_Intermediate (Interp, Opcode_Letrec_Binding, Get_Cdr(Car), Get_Car(Get_Car(Car))); end if; end Evaluate_Letrec_Syntax; + -- ---------------------------------------------------------------- + procedure Evaluate_Quote_Syntax is pragma Inline (Evaluate_Quote_Syntax); begin @@ -412,6 +432,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Return_Frame (Interp, Get_Car(Operand)); end Evaluate_Quote_Syntax; + -- ---------------------------------------------------------------- + procedure Evaluate_Set_Syntax is pragma Inline (Evaluate_Set_Syntax); begin @@ -451,6 +473,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; end Evaluate_Set_Syntax; + -- ---------------------------------------------------------------- + begin Push_Top (Interp, Operand'Unchecked_Access); Push_Top (Interp, Car'Unchecked_Access); diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index a8410f5..c0a064b 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -21,7 +21,7 @@ procedure Execute (Interp: in out Interpreter_Record) is -- ---------------------------------------------------------------- generic - with function Is_Bool (X: in Object_Pointer) return Standard.Boolean; + with function Is_Good_Result (X: in Object_Pointer) return Standard.Boolean; procedure Evaluate_While; procedure Evaluate_While is @@ -36,7 +36,7 @@ procedure Execute (Interp: in out Interpreter_Record) is -- evaluate . Y must be valid even at the first time -- this procedure is called. - if Is_Bool(Y) and then Is_Cons(X) then + if Is_Good_Result(Y) and then Is_Cons(X) then -- The result is not what I look for. -- Yet there are still more tests to evaluate. --Switch_Frame (Interp.Stack, Get_Frame_Opcode(Interp.Stack), Get_Cdr(X), Nil_Pointer); @@ -72,14 +72,14 @@ procedure Execute (Interp: in out Interpreter_Record) is X: Object_Pointer; Y: aliased Object_Pointer; begin - -- Keep Y managed as Y is referenced beyond the gc point. + -- Manage Y as it's referenced after the gc point. Push_Top (Interp, Y'Unchecked_Access); X := Get_Frame_Operand(Interp.Stack); -- symbol pragma Assert (Is_Symbol(X)); Y := Get_Frame_Result(Interp.Stack); -- value list - Put_Environment (Interp, X, Y); -- gc point + Set_Current_Environment (Interp, X, Y); -- gc point Return_Frame (Interp, Y); -- Y is referenced here. Pop_Tops (Interp, 1); -- Unmanage Y end Do_Define_Finish; @@ -101,10 +101,10 @@ procedure Execute (Interp: in out Interpreter_Record) is X := Get_Cdr(X); -- cons cell containing if Is_Cons(X) then -- Switch the current current to evaluate - -- keeping the environment untouched. Use Pop_Frame and - -- Push_Frame instead of Switch_Frame for continuation. - -- If continuation has been created in , continuation - -- can be made to this frame. + -- keeping the environment untouched. Use Reload_Frame + -- instead of Switch_Frame for continuation. If continuation + -- has been created in , continuation can be made to + -- this frame. -- -- For example, -- (if (define xx (call/cc call/cc)) @@ -115,8 +115,7 @@ procedure Execute (Interp: in out Interpreter_Record) is -- , its opcode must remain as Opcode_If_Finish. --Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); - Pop_Frame (Interp); - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); else -- Return nil if no is specified Return_Frame (Interp, Nil_Pointer); @@ -124,11 +123,10 @@ procedure Execute (Interp: in out Interpreter_Record) is else -- All values except #f are true values. evaluate . -- Switch the current current to evaluate keeping - -- the environment untouched. Use Pop_Frame and Push_Frame - -- instead of Switch_Frame for continuation to work. + -- the environment untouched. Use Reload_Frame instead of + -- Switch_Frame for continuation to work. --Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X), Nil_Pointer); - Pop_Frame (Interp); - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); end if; end Do_If_Finish; @@ -189,8 +187,7 @@ procedure Execute (Interp: in out Interpreter_Record) is R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Nil_Pointer); X := Get_Frame_Operand(Interp.Stack); - Pop_Frame (Interp); - Push_Frame_With_Intermediate (Interp, Opcode_Apply, X, R); + Reload_Frame_With_Intermediate (Interp, Opcode_Apply, X, R); --Pop_Tops (Interp, 2); end Do_Procedure_Call_Finish; @@ -218,96 +215,56 @@ procedure Execute (Interp: in out Interpreter_Record) is end Do_Grouped_Call; -- ---------------------------------------------------------------- - - procedure Do_Let_Evaluation is - pragma Inline (Do_Let_Evaluation); - X: aliased Object_Pointer; - S: aliased Object_Pointer; - R: aliased Object_Pointer; - begin - Push_Top (Interp, X'Unchecked_Access); - Push_Top (Interp, S'Unchecked_Access); - Push_Top (Interp, R'Unchecked_Access); - - X := Get_Frame_Operand(Interp.Stack); - pragma Assert (Is_Array(X)); - - R := X.Pointer_Slot(3); - if R = Nil_Pointer then - -- First call; - X.Pointer_Slot(2) := X.Pointer_Slot(1); - else - -- Subsequent calls. Store the result in the room created - -- in the previous call. - pragma Assert (Is_Cons(R)); - Set_Car (R, Get_Frame_Result(Interp.Stack)); - end if; - S := X.Pointer_Slot(2); - - if Is_Cons(S) then - -- Handle each binding. - - -- Make an empty room to hold the result on the next call - R := Make_Cons (Interp.Self, Nil_Pointer, R); - X.Pointer_Slot(3) := R; - - -- Remember the next to evaluate - X.Pointer_Slot(2) := Get_Cdr(S); - - -- Say, is ((x 2) (y 2)). - -- for the first call, Get_Car(S) is (x 2). - -- To get x, Get_Car(Get_Car(S)) - -- To get 2, Get_Car(Get_Cdr(Get_Car(S))) - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(S)))); - - else - -- No more binding to handle. - Pop_Frame (Interp); - - -- The operands at the Let_Evaluation and the Let_Binding frame - -- must be the identical objects. this way, i don't need to carry - -- over the binding result to the Let_Binding frame. - pragma Assert (X = Get_Frame_Operand(Interp.Stack)); - pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Binding); - --X := Get_Frame_Operand(Interp.Stack); - --pragma Assert (Is_Array(X)); - --pragma Assert (X.Pointer_Slot(3) = Nil_Pointer); - --X.Pointer_Slot(3) := R; - end if; - - Pop_Tops (Interp, 3); - end Do_Let_Evaluation; - procedure Do_Let_Binding is pragma Inline (Do_Let_Binding); - X: aliased Object_Pointer; - S: aliased Object_Pointer; - R: aliased Object_Pointer; + O: aliased Object_Pointer; begin - Push_Top (Interp, X'Unchecked_Access); - Push_Top (Interp, S'Unchecked_Access); - Push_Top (Interp, R'Unchecked_Access); + -- Perform binding in the parent environment. + Set_Parent_Environment (Interp, Get_Frame_Intermediate(Interp.Stack), Get_Frame_Result(Interp.Stack)); - X := Get_Frame_Operand(Interp.Stack); -- and onward - pragma Assert (Is_Array(X)); + O := Get_Frame_Operand(Interp.Stack); - S := X.Pointer_Slot(1); - R := X.Pointer_Slot(3); - R := Reverse_Cons(R); + -- 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); - while Is_Cons(S) loop - pragma Assert (Is_Cons(R)); - Put_Environment (Interp, Get_Car(Get_Car(S)), Get_Car(R)); - S := Get_Cdr(S); - R := Get_Cdr(R); - end loop; + Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O)))); + Push_Subframe_With_Intermediate (Interp, Opcode_Let_Binding, Get_Cdr(O), Get_Car(Get_Car(O))); - Pop_Frame (Interp); -- done. - pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); - - Pop_Tops (Interp, 3); + Pop_Tops (Interp, 1); + else + Pop_Frame (Interp); -- done. + end if; end Do_Let_Binding; + procedure Do_Letrec_Binding is + pragma Inline (Do_Letrec_Binding); + O: aliased 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); + + Reload_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(O)))); + Push_Subframe_With_Intermediate (Interp, Opcode_Letrec_Binding, Get_Cdr(O), Get_Car(Get_Car(O))); + + Pop_Tops (Interp, 1); + else + Pop_Frame (Interp); + end if; + end Do_Letrec_Binding; + procedure Do_Letast_Binding is pragma Inline (Do_Letast_Binding); X: Object_Pointer; @@ -336,7 +293,7 @@ procedure Execute (Interp: in out Interpreter_Record) is -- Push a new environment for each binding. Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); Set_Frame_Environment (Interp.Stack, Envir); - Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack)); + 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 @@ -352,37 +309,28 @@ procedure Execute (Interp: in out Interpreter_Record) is Pop_Frame (Interp); -- Done -- Update the environment of the Let_Finish frame. - pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); + --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_Let_Finish is - pragma Inline (Do_Let_Finish); - begin - pragma Assert (Get_Frame_Result(Interp.Stack) = Nil_Pointer); - -- Evaluate_Let_Syntax has places in the operand of this frame. - -- can be evaluated as if it's in 'begin'. - --Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group); - Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call); - end Do_Let_Finish; - -- -------------------------------------------------------------------- procedure Do_Set_Finish is pragma Inline (Do_Set_Finish); - X: aliased Object_Pointer; + X: Object_Pointer; Y: aliased Object_Pointer; begin - Push_Top (Interp, X'Unchecked_Access); Push_Top (Interp, Y'Unchecked_Access); X := Get_Frame_Operand(Interp.Stack); -- symbol Y := Get_Frame_Result(Interp.Stack); -- value -ada.text_io.put ("%%%%% FINISH SET SYNTAX => "); -print (interp, Get_Frame_Result(Interp.Stack)); +ada.text_io.put ("%%%%% FINISH SET SYNTAX => ["); +print (interp, X); +print (interp, Y); +ada.text_io.put_line ("]"); pragma Assert (Is_Symbol(X)); if Set_Environment(Interp.Self, X, Y) = null then @@ -392,7 +340,7 @@ print (interp, Get_Frame_Result(Interp.Stack)); Return_Frame (Interp, Y); - Pop_Tops (Interp, 2); + Pop_Tops (Interp, 1); end Do_Set_Finish; procedure Evaluate is separate; @@ -970,11 +918,8 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); when Opcode_Letast_Binding_Finish => Do_Letast_Binding_Finish; - when Opcode_Let_Evaluation => - Do_Let_Evaluation; - - when Opcode_Let_Finish => - Do_Let_Finish; + when Opcode_Letrec_Binding => + Do_Letrec_Binding; when Opcode_Or_Finish => Do_Or_Finish; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index bb73eba..1b107c2 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -106,8 +106,7 @@ package body H2.Scheme is Opcode_Let_Binding, Opcode_Letast_Binding, Opcode_Letast_Binding_Finish, - Opcode_Let_Evaluation, - Opcode_Let_Finish, + Opcode_Letrec_Binding, Opcode_Procedure_Call, Opcode_Procedure_Call_Finish, Opcode_Set_Finish, @@ -1440,7 +1439,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Envir: Object_Pointer; Arr: Object_Pointer; begin - -- Search the whole environment chain unlike Put_Environment(). + -- Search the whole environment chain unlike Set_Current_Environment(). -- It is mainly for set!. pragma Assert (Is_Symbol(Key)); @@ -1462,13 +1461,11 @@ Ada.Text_IO.Put_Line ("Make_String..."); end Set_Environment; procedure Put_Environment (Interp: in out Interpreter_Record; + Envir: in Object_Pointer; Key: in Object_Pointer; Value: in Object_Pointer) is Arr: Object_Pointer; - Envir: aliased Object_Pointer; begin - Envir := Get_Frame_Environment(Interp.Stack); - -- Search the current environment only. It doesn't search the -- environment. If no key is found, add a new pair -- This is mainly for define. @@ -1483,10 +1480,11 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- Add a new key/value pair in the current environment -- if no existing pair has been found. declare + Aliased_Envir: aliased Object_Pointer := Envir; Aliased_Key: aliased Object_Pointer := Key; Aliased_Value: aliased Object_Pointer := Value; begin - Push_Top (Interp, Envir'Unchecked_Access); + Push_Top (Interp, Aliased_Envir'Unchecked_Access); Push_Top (Interp, Aliased_Key'Unchecked_Access); Push_Top (Interp, Aliased_Value'Unchecked_Access); @@ -1495,14 +1493,30 @@ Ada.Text_IO.Put_Line ("Make_String..."); Arr.Pointer_Slot(2) := Aliased_Value; -- Chain the pair to the head of the list - Arr.Pointer_Slot(3) := Get_Car(Envir); - Set_Car (Envir, Arr); + Arr.Pointer_Slot(3) := Get_Car(Aliased_Envir); + Set_Car (Aliased_Envir, Arr); Pop_Tops (Interp, 3); end; end if; end Put_Environment; + procedure Set_Current_Environment (Interp: in out Interpreter_Record; + Key: in Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Current_Environment); + begin + Put_Environment (Interp, Get_Frame_Environment(Interp.Stack), Key, Value); + end Set_Current_Environment; + + procedure Set_Parent_Environment (Interp: in out Interpreter_Record; + Key: in Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Parent_Environment); + begin + Put_Environment (Interp, Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)), Key, Value); + end Set_Parent_Environment; + ----------------------------------------------------------------------------- function Make_Syntax (Interp: access Interpreter_Record; @@ -1545,7 +1559,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- Link it to the top environement pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment); pragma Assert (Get_Environment(Interp.Self, Symbol) = null); - Put_Environment (Interp.all, Symbol, Proc); + Set_Current_Environment (Interp.all, Symbol, Proc); Pop_Tops (Interp.all, 2); return Proc; @@ -2154,6 +2168,16 @@ end if; Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer); end Push_Frame_With_Environment; + procedure Push_Frame_With_Environment_And_Intermediate (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Envir: in Object_Pointer; + Interm: in Object_Pointer) is + pragma Inline (Push_Frame_With_Environment_And_Intermediate); + begin + Interp.Stack := Insert_Frame(Interp.Self, Interp.Stack, Opcode, Operand, Envir, Interm); + end Push_Frame_With_Environment_And_Intermediate; + procedure Push_Frame_With_Intermediate (Interp: in out Interpreter_Record; Opcode: in Opcode_Type; Operand: in Object_Pointer; @@ -2193,6 +2217,17 @@ end if; Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm)); end Push_Subframe_With_Intermediate; + procedure Push_Subframe_With_Environment_And_Intermediate (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Envir: in Object_Pointer; + Interm: in Object_Pointer) is + pragma Inline (Push_Subframe_With_Environment_And_Intermediate); + begin + -- Place a new frame below the existing top frame. + Set_Frame_Parent (Interp.Stack, Insert_Frame(Interp.Self, Get_Frame_Parent(Interp.Stack), Opcode, Operand, Envir, Interm)); + end Push_Subframe_With_Environment_And_Intermediate; + procedure Pop_Frame (Interp: in out Interpreter_Record) is pragma Inline (Pop_Frame); begin @@ -2211,6 +2246,31 @@ end if; Set_Frame_Result (Interp.Stack, Value); end Return_Frame; + procedure Reload_Frame (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer) is + pragma Inline (Reload_Frame); + Envir: Object_Pointer; + begin + -- Change various frame fields keeping the environment. + Envir := Get_Frame_Environment (Interp.Stack); + Pop_Frame (Interp); + Push_Frame_With_Environment (Interp, Opcode, Operand, Envir); + end Reload_Frame; + + procedure Reload_Frame_With_Intermediate (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Interm: in Object_Pointer) is + pragma Inline (Reload_Frame_With_Intermediate); + Envir: Object_Pointer; + begin + -- Change various frame fields keeping the environment. + 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; + procedure Execute (Interp: in out Interpreter_Record) is separate; procedure Evaluate (Interp: in out Interpreter_Record; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 11dea3e..fbcc182 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -230,7 +230,13 @@ package H2.Scheme is Pointer_Slot: Object_Pointer_Array(1 .. Size) := (others => null); when Character_Object => Character_Slot: Object_Character_Array(1 .. Size) := (others => Object_Character'First); - Character_Terminator: Object_Character := Object_Character'First; -- TODO: can this guarantee terminating NULL? require some attribute for it to work? + -- The character terminator is to ease integration with + -- other languages using a terminating null. + -- TODO: can this guarantee terminating NULL? is this + -- terminator guaranteed to be placed after the + -- character_slot without any gaps in between + -- under the current alignement condition? + Character_Terminator: Object_Character := Object_Character'First; when Byte_Object => Byte_Slot: Object_Byte_Array(1 .. Size) := (others => 0); when Word_Object =>