From 032dda22632a48c06f3f4a35830e20f5bb44640e Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Wed, 5 Feb 2014 15:08:59 +0000 Subject: [PATCH] addded a new slot to hold an intermediate value to a frame object. made partial changes relevant --- lib/h2-scheme-execute-evaluate.adb | 29 ++--- lib/h2-scheme-execute.adb | 203 +++++++++-------------------- lib/h2-scheme.adb | 169 ++++++++++++++++-------- lib/h2-scheme.ads | 1 - 4 files changed, 188 insertions(+), 214 deletions(-) diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index c7d485c..ad3df25 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -448,12 +448,13 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Cdr := Get_Car(Cdr); -- -- Arrange to finish setting a variable after evaluation. - Set_Frame_Opcode (Interp.Stack, Opcode_Set_Finish); - Set_Frame_Operand (Interp.Stack, Car); - Clear_Frame_Result (Interp.Stack); - + --Switch_Frame (Interp.Stack, Opcode_Set_Finish, Car); -- Arrange to evalaute the value part - Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); + --Push_Frame (Interp, Opcode_Evaluate_Object, Cdr); + + -- These 2 lines derives the same result as the 2 lines commented out above. + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Cdr); + Push_Subframe (Interp, Opcode_Set_Finish, Car); else Ada.Text_IO.Put_LINE ("INVALID SYMBOL AFTER SET!"); raise Syntax_Error; @@ -526,9 +527,7 @@ end; raise Syntax_Error; end if; - Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call); - Set_Frame_Operand (Interp.Stack, Operand); - Clear_Frame_Result (Interp.Stack); + Switch_Frame (Interp.Stack, Opcode_Grouped_Call, Operand); end if; --if (Interp.Trait.Trait_Bits and No_Optimization) = 0 then @@ -580,17 +579,11 @@ end; raise Syntax_Error; end if; - -- Create a cons cell whose 'car' holds arguments and - -- 'cdr' holds evaluation results before applying them. - Cdr := Make_Cons (Interp.Self, Cdr, Nil_Pointer); + -- Switch the current frame to evaluate + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Car); - -- Set it as a frame operand - Set_Frame_Opcode (Interp.Stack, Opcode_Procedure_Call); - Set_Frame_Operand (Interp.Stack, Cdr); - Clear_Frame_Result (Interp.Stack); - - -- Arrange to evaluate first. - Push_Frame (Interp, Opcode_Evaluate_Object, Car); + -- Push a new frame to evaluate arguments. + Push_Subframe (Interp, Opcode_Procedure_Call, Cdr); end if; when others => diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 05f5029..5464f63 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -14,7 +14,7 @@ procedure Execute (Interp: in out Interpreter_Record) is -- It takes only the head(car) element of the result chain. -- Calling this function to evaluate the result of any arbitrary frame -- other than 'Read_Object' is not recommended. - Set_Frame_Operand (Interp.Stack, Get_Car(Get_Frame_Result(Interp.Stack))); + Set_Frame_Operand (Interp.Stack, Get_Frame_Result(Interp.Stack)); Clear_Frame_Result (Interp.Stack); Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Object); end Evaluate_Result; @@ -32,11 +32,8 @@ procedure Execute (Interp: in out Interpreter_Record) is Y := Get_Frame_Result(Interp.Stack); -- Evaluate_And_Syntax/Evaluate_Or_Syntax has arranged to - -- evaluate . Y must not be Nil_Pointer even at the - -- first time this procedure is called, - pragma Assert (Is_Cons(Y)); - pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure 1 resul - Y := Get_Car(Y); -- actual result + -- evaluate . Y must be valid even at the first time + -- this procedure is called. if Y /= V and then Is_Cons(X) then -- The result is not what I look for. @@ -67,8 +64,6 @@ procedure Execute (Interp: in out Interpreter_Record) is pragma Assert (Is_Symbol(X)); Y := Get_Frame_Result(Interp.Stack); -- value list - pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value - Y := Get_Car(Y); -- the first value Put_Environment (Interp, X, Y); @@ -91,8 +86,6 @@ procedure Execute (Interp: in out Interpreter_Record) is pragma Assert (Is_Cons(X)); Y := Get_Frame_Result(Interp.Stack); -- result list of - pragma Assert (Get_Cdr(Y) = Nil_Pointer); -- ensure only 1 return value - Y := Get_Car(Y); -- the first value if Y = False_Pointer then -- evaluated to #f. @@ -125,95 +118,47 @@ procedure Execute (Interp: in out Interpreter_Record) is procedure Do_Procedure_Call is pragma Inline (Do_Procedure_Call); 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_Cons(X)); + R := Make_Cons(Interp.Self, Get_Frame_Result(Interp.Stack), Get_Frame_Intermediate(Interp.Stack)); - -- When this procedure is called for the first time, - -- the first argument must be at the head of the list that - -- 'S' points to. it's because evaluation frame - -- is pushed by Evaluate(). - S := Get_Car(X); - R := Get_Cdr(X); - -- Threfore, the frame result is for for the first call. - R := Make_Cons(Interp.Self, Get_Car(Get_Frame_Result(Interp.Stack)), R); - - Clear_Frame_Result (Interp.Stack); - if Is_Cons(S) then - Set_Cdr (X, R); -- chain the result - Set_Car (X, Get_Cdr(S)); -- remember the next to evaluate - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(S)); + if Is_Cons(X) then + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X)); + Push_Subframe_With_Intermediate (Interp, Opcode_Procedure_Call, Get_Cdr(X), R); else -- no more argument to evaluate. -- apply the evaluated arguments to the evaluated operator. - Set_Frame_Opcode (Interp.Stack, Opcode_Apply); - Set_Frame_Operand (Interp.Stack, Reverse_Cons(R)); + Switch_Frame (Interp.Stack, Opcode_Apply, Reverse_Cons(R)); end if; - Pop_Tops (Interp, 3); + Pop_Tops (Interp, 2); end Do_Procedure_Call; -- ---------------------------------------------------------------- procedure Do_Grouped_Call is + pragma Inline (Do_Grouped_Call); X: Object_Pointer; begin X := Get_Frame_Operand(Interp.Stack); pragma Assert (Is_Cons(X)); -- The caller must ensure this. - --if Is_Cons(X) then - Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call_Finish); - Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); - Clear_Frame_Result (Interp.Stack); - - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); - --else - -- -- Nothing to evaluate. - -- Pop_Frame (Interp); - -- Put_Frame_Result (Interp, Interp.Stack, Nil_Pointer); - --end if; - end Do_Grouped_Call; - - procedure Do_Grouped_Call_Finish is - X: Object_Pointer; - R: Object_Pointer; - begin - X := Get_Frame_Operand(Interp.Stack); + -- Switch the current frame to evaluate the first + -- expression in the group. + Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(X)); + X := Get_Cdr(X); if Is_Cons(X) then - Set_Frame_Opcode (Interp.Stack, Opcode_Grouped_Call_Finish); - Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); - Clear_Frame_Result (Interp.Stack); - - Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); - else - -- Nothing more to evaluate. - R := Get_Frame_Result(Interp.Stack); - -declare -w: object_word; -for w'address use interp.stack'address; -begin -ada.text_io.put_line ("Frame" & object_word'image(w) & " " & Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); -ada.text_io.put (" EVAL-GROUP RESULT "); -print (Interp, R); -end; - --- There must be only 1 return value chained in the Group frame. -pragma Assert (Get_Cdr(R) = Nil_Pointer); - - Pop_Frame (Interp); - - -- Return the last result to the upper frame - Put_Frame_Result (Interp, Interp.Stack, Get_Car(R)); + -- Add a new frame for handling the remaining expressions in + -- the group. Place it below the current frame so that it's + -- executed after the current frame switched is executed first. + Push_Subframe (Interp, Opcode_Grouped_Call, X); end if; - end Do_Grouped_Call_Finish; + end Do_Grouped_Call; -- ---------------------------------------------------------------- @@ -238,7 +183,7 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer); -- Subsequent calls. Store the result in the room created -- in the previous call. pragma Assert (Is_Cons(R)); - Set_Car (R, Get_Car(Get_Frame_Result(Interp.Stack))); + Set_Car (R, Get_Frame_Result(Interp.Stack)); end if; S := X.Pointer_Slot(2); @@ -322,22 +267,19 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer); procedure Do_Letast_Binding_Finish is pragma Inline (Do_Letast_Binding_Finish); X: aliased Object_Pointer; - Y: aliased Object_Pointer; Envir: aliased Object_Pointer; begin Push_Top (Interp, X'Unchecked_Access); - Push_Top (Interp, Y'Unchecked_Access); Push_Top (Interp, Envir'Unchecked_Access); X := Get_Frame_Operand(Interp.Stack); -- and onward - Y := Get_Frame_Result(Interp.Stack); -- 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); - Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y)); + Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Frame_Result(Interp.Stack)); X := Get_Cdr(X); -- next binding if Is_Cons(X) then @@ -357,7 +299,7 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer); Set_Frame_Environment (Interp.Stack, Envir); end if; - Pop_Tops (Interp, 3); + Pop_Tops (Interp, 2); end Do_Letast_Binding_Finish; procedure Do_Let_Finish is @@ -381,14 +323,13 @@ pragma Assert (Get_Cdr(R) = Nil_Pointer); Push_Top (Interp, Y'Unchecked_Access); X := Get_Frame_Operand(Interp.Stack); -- symbol - Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- value + Y := Get_Frame_Result(Interp.Stack); -- value ada.text_io.put ("%%%%% FINISH SET SYNTAX => "); print (interp, Get_Frame_Result(Interp.Stack)); pragma Assert (Is_Symbol(X)); - pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer); if Set_Environment(Interp.Self, X, Y) = null then - Ada.Text_IO.PUt_LINE ("ERROR: UNBOUND SYMBOL"); + Ada.Text_IO.Put_LINE ("ERROR: UNBOUND SYMBOL"); raise Evaluation_Error; end if; @@ -693,7 +634,7 @@ print (interp, Get_Frame_Result(Interp.Stack)); procedure Read_List is pragma Inline (Read_List); - V: aliased Object_Pointer; + V: Object_Pointer; begin -- This procedure reads each token in a list. -- If the list contains no period, this procedure reads up to the @@ -702,8 +643,6 @@ print (interp, Get_Frame_Result(Interp.Stack)); Fetch_Token; - --Push_Top (Interp, V'Unchecked_Access); - case Interp.Token.Kind is when End_Token => Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); @@ -713,15 +652,15 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); Push_Frame (Interp, Opcode_Read_List, Nil_Pointer); when Right_Parenthesis_Token => - V := Get_Frame_Result(Interp.Stack); - if V /= Nil_Pointer then + V := Get_Frame_Intermediate(Interp.Stack); + if Is_Cons(V) then V := Reverse_Cons(V); end if; Pop_Frame (Interp); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when Period_Token => - V := Get_Frame_Result(Interp.Stack); + V := Get_Frame_Intermediate(Interp.Stack); if V = Nil_Pointer then -- . immediately after ( raise Syntax_Error; @@ -736,38 +675,37 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); when Integer_Token => -- TODO: bignum V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when Character_Token => pragma Assert (Interp.Token.Value.Last = 1); V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1)); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when String_Token => V := Make_String(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when Identifier_Token => V := Make_Symbol(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when True_Token => - Chain_Frame_Result (Interp, Interp.Stack, True_Pointer); + Chain_Frame_Intermediate (Interp, Interp.Stack, True_Pointer); when False_Token => - Chain_Frame_Result (Interp, Interp.Stack, False_Pointer); + Chain_Frame_Intermediate (Interp, Interp.Stack, False_Pointer); when others => -- TODO: set various error info raise Syntax_Error; end case; - --Pop_Tops (Interp, 1); end Read_List; procedure Read_List_Cdr is pragma Inline (Read_List_Cdr); - V: aliased Object_Pointer; + V: Object_Pointer; begin -- This procedure reads the first token after a period has been read. -- It transfers the control over to Read_List_End once it has read @@ -776,8 +714,6 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); -- to handle the head item specially. Fetch_Token; - --Push_Top (Interp, V'Unchecked_Access); - case Interp.Token.Kind is when End_Token => Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END"); @@ -797,100 +733,86 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END"); -- TODO: bignum V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when Character_Token => pragma Assert (Interp.Token.Value.Last = 1); V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1)); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when String_Token => V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when Identifier_Token => V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); - Chain_Frame_Result (Interp, Interp.Stack, V); + Chain_Frame_Intermediate (Interp, Interp.Stack, V); when True_Token => Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); - Chain_Frame_Result (Interp, Interp.Stack, True_Pointer); + Chain_Frame_Intermediate (Interp, Interp.Stack, True_Pointer); when False_Token => Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End); - Chain_Frame_Result (Interp, Interp.Stack, False_Pointer); + Chain_Frame_Intermediate (Interp, Interp.Stack, False_Pointer); when others => -- TODO: set various error info raise Syntax_Error; end case; - --Pop_Tops (Interp, 1); end Read_List_Cdr; procedure Read_List_End is pragma Inline (Read_List_End); - V: aliased Object_Pointer; + V: Object_Pointer; begin Fetch_Token; - --Push_Top (Interp, V'Unchecked_Access); - case Interp.Token.Kind is when Right_Parenthesis_Token => - V := Get_Frame_Result(Interp.Stack); + V := Get_Frame_Intermediate(Interp.Stack); pragma Assert (V /= Nil_Pointer); -- The first item in the chain is actually Cdr of the last cell. V := Reverse_Cons(Get_Cdr(V), Get_Car(V)); Pop_Frame (Interp); - Chain_Frame_Result (Interp, Interp.Stack, V); + Set_Frame_Result (Interp.Stack, V); when others => Ada.Text_IO.Put_Line ("Right parenthesis expected"); raise Syntax_Error; end case; - --Pop_Tops (Interp, 1); end Read_List_End; procedure Close_List is pragma Inline (Close_List); - V: aliased Object_Pointer; + V: Object_Pointer; begin - --Push_Top (Interp, V'Unchecked_Access); - - V := Get_Frame_Result(Interp.Stack); - pragma Assert (Get_Cdr(V) = Nil_Pointer); - Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, Get_Car(V)); - - --Pop_Tops (Interp, 1); + V := Get_Frame_Intermediate(Interp.Stack); + Pop_Frame (Interp); + Set_Frame_Result (Interp.Stack, Get_Car(V)); end Close_List; procedure Close_Quote is pragma Inline (Close_Quote); - V: aliased Object_Pointer; + V: Object_Pointer; begin - --Push_Top (Interp, V'Unchecked_Access); - - Chain_Frame_Result (Interp, Interp.Stack, Interp.Symbol.Quote); V := Get_Frame_Result(Interp.Stack); + V := Make_Cons(Interp.Self, V, Nil_Pointer); + V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V); Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, V); - - --Pop_Tops (Interp, 1); + Set_Frame_Result (Interp.Stack, V); end Close_Quote; procedure Read_Object is pragma Inline (Read_Object); - V: aliased Object_Pointer; + V: Object_Pointer; begin Fetch_Token; - --Push_Top (Interp, V'Unchecked_Access); - case Interp.Token.Kind is when End_Token => Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN "); @@ -908,32 +830,31 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN "); -- TODO: bignum V := String_To_Integer_Pointer(Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, V); + Set_Frame_Result (Interp.Stack, V); when Character_Token => pragma Assert (Interp.Token.Value.Last = 1); V := Character_To_Pointer(Interp.Token.Value.Ptr.all(1)); Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, V); + Set_Frame_Result (Interp.Stack, V); when String_Token => V := Make_String (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, V); + Set_Frame_Result (Interp.Stack, V); when Identifier_Token => V := Make_Symbol (Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last)); Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, V); + Set_Frame_Result (Interp.Stack, V); when True_Token => Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, True_Pointer); + Set_Frame_Result (Interp.Stack, True_Pointer); when False_Token => Pop_Frame (Interp); -- Done with the current frame - Chain_Frame_Result (Interp, Interp.Stack, False_Pointer); - + Set_Frame_Result (Interp.Stack, False_Pointer); when others => -- TODO: set various error info @@ -941,7 +862,6 @@ Ada.Text_IO.Put_Line ("INFO: UNKNOWN TOKEN " & Token_Kind'Image(Interp.Token.Kin raise Syntax_Error; end case; - --Pop_Tops (Interp, 1); end Read_Object; begin @@ -1012,6 +932,7 @@ begin pragma Assert (Interp.Top.Last < Interp.Top.Data'First); loop +ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); case Get_Frame_Opcode(Interp.Stack) is when Opcode_Exit => exit; @@ -1036,8 +957,6 @@ begin when Opcode_Grouped_Call => Do_Grouped_Call; - when Opcode_Grouped_Call_Finish => - Do_Grouped_Call_Finish; when Opcode_Let_Binding => Do_Let_Binding; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 6c64a5e..3d43d94 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -103,7 +103,6 @@ package body H2.Scheme is Opcode_Finish_Or_Syntax, Opcode_Grouped_Call, -- (begin ...), closure apply, let body - Opcode_Grouped_Call_Finish, Opcode_Let_Binding, Opcode_Letast_Binding, Opcode_Letast_Binding_Finish, @@ -130,12 +129,13 @@ package body H2.Scheme is Cons_Car_Index: constant Pointer_Object_Size := 1; Cons_Cdr_Index: constant Pointer_Object_Size := 2; - Frame_Object_Size: constant Pointer_Object_Size := 5; + Frame_Object_Size: constant Pointer_Object_Size := 6; Frame_Parent_Index: constant Pointer_Object_Size := 1; Frame_Opcode_Index: constant Pointer_Object_Size := 2; Frame_Operand_Index: constant Pointer_Object_Size := 3; Frame_Environment_Index: constant Pointer_Object_Size := 4; - Frame_Result_Index: constant Pointer_Object_Size := 5; + Frame_Intermediate_Index: constant Pointer_Object_Size := 5; + Frame_Result_Index: constant Pointer_Object_Size := 6; Procedure_Object_Size: constant Pointer_Object_Size := 1; Procedure_Opcode_Index: constant Pointer_Object_Size := 1; @@ -1145,12 +1145,14 @@ Ada.Text_IO.Put_Line ("Make_String..."); Stack: in Object_Pointer; -- current stack pointer Opcode: in Object_Pointer; Operand: in Object_Pointer; - Envir: in Object_Pointer) return Object_Pointer is + Envir: in Object_Pointer; + Interm: in Object_Pointer) return Object_Pointer is Frame: Object_Pointer; Aliased_Stack: aliased Object_Pointer := Stack; Aliased_Opcode: aliased Object_Pointer := Opcode; Aliased_Operand: aliased Object_Pointer := Operand; Aliased_Envir: aliased Object_Pointer := Envir; + Aliased_Interm: aliased Object_Pointer := Interm; begin @@ -1158,6 +1160,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Push_Top (Interp.all, Aliased_Opcode'Unchecked_Access); Push_Top (Interp.all, Aliased_Operand'Unchecked_Access); Push_Top (Interp.all, Aliased_Envir'Unchecked_Access); + Push_Top (Interp.all, Aliased_Interm'Unchecked_Access); -- TODO: create a Frame in a special memory rather than in Heap Memory. -- Since it's used for stack, it can be made special. @@ -1167,9 +1170,10 @@ Ada.Text_IO.Put_Line ("Make_String..."); Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode; Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand; Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir; + Frame.Pointer_Slot(Frame_Intermediate_Index) := Aliased_Interm; --Print_Object_Pointer ("Make_Frame Result - ", Result); - Pop_Tops (Interp.all, 4); + Pop_Tops (Interp.all, 5); return Frame; end Make_Frame; @@ -1180,6 +1184,50 @@ Ada.Text_IO.Put_Line ("Make_String..."); Source.Tag = Frame_Object; end Is_Frame; + function Get_Frame_Intermediate (Frame: in Object_Pointer) return Object_Pointer is + pragma Inline (Get_Frame_Intermediate); + pragma Assert (Is_Frame(Frame)); + begin + return Frame.Pointer_Slot(Frame_Intermediate_Index); + end Get_Frame_Intermediate; + + procedure Set_Frame_Intermediate (Frame: in Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Frame_Intermediate); + pragma Assert (Is_Frame(Frame)); + + -- This procedure is not to set a single result, + -- but to set the result chain. so it can be useful + -- if you want to migrate a result chain from one frame + -- to another. It's what this assertion is for. + pragma Assert (Value = Nil_Pointer or else Is_Cons(Value)); + begin + Frame.Pointer_Slot(Frame_Intermediate_Index) := Value; + end Set_Frame_Intermediate; + + procedure Chain_Frame_Intermediate (Interp: in out Interpreter_Record; + Frame: in Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Chain_Frame_Intermediate); + pragma Assert (Is_Frame(Frame)); + V: Object_Pointer; + begin + -- Add a new cons cell to the front + + --Push_Top (Interp, Frame'Unchecked_Access); + --Frame.Pointer_Slot(Frame_Intermediate_Index) := + -- Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Intermediate_Index)); + --Pop_Tops (Interp, 1); + + -- This seems to cause a problem if Interp.Stack changes in Make_Cons(). + --Interp.Stack.Pointer_Slot(Frame_Intermediate_Index) := + -- Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Intermediate_Index)); + + -- So, let's separate the evaluation and the assignment. + V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Intermediate_Index)); + Interp.Stack.Pointer_Slot(Frame_Intermediate_Index) := V; + end Chain_Frame_Intermediate; + function Get_Frame_Result (Frame: in Object_Pointer) return Object_Pointer is pragma Inline (Get_Frame_Result); pragma Assert (Is_Frame(Frame)); @@ -1191,12 +1239,6 @@ Ada.Text_IO.Put_Line ("Make_String..."); Value: in Object_Pointer) is pragma Inline (Set_Frame_Result); pragma Assert (Is_Frame(Frame)); - - -- This procedure is not to set a single result, - -- but to set the result chain. so it can be useful - -- if you want to migrate a result chain from one frame - -- to another. It's what this assertion is for. - pragma Assert (Value = Nil_Pointer or else Is_Cons(Value)); begin Frame.Pointer_Slot(Frame_Result_Index) := Value; end Set_Frame_Result; @@ -1206,36 +1248,10 @@ Ada.Text_IO.Put_Line ("Make_String..."); Value: in Object_Pointer) is pragma Inline (Put_Frame_Result); pragma Assert (Is_Frame(Frame)); - V: Object_Pointer; begin - V := Make_Cons(Interp.Self, Value, Nil_Pointer); - Interp.Stack.Pointer_Slot(Frame_Result_Index) := V; + Interp.Stack.Pointer_Slot(Frame_Result_Index) := Value; end Put_Frame_Result; - procedure Chain_Frame_Result (Interp: in out Interpreter_Record; - Frame: in Object_Pointer; -- TODO: remove this parameter - Value: in Object_Pointer) is - pragma Inline (Chain_Frame_Result); - pragma Assert (Is_Frame(Frame)); - V: Object_Pointer; - begin - -- Add a new cons cell to the front - - --Push_Top (Interp, Frame'Unchecked_Access); - --Frame.Pointer_Slot(Frame_Result_Index) := - -- Make_Cons(Interp.Self, Value, Frame.Pointer_Slot(Frame_Result_Index)); - --Pop_Tops (Interp, 1); - - -- This seems to cause a problem if Interp.Stack changes in Make_Cons(). - --Interp.Stack.Pointer_Slot(Frame_Result_Index) := - -- Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index)); - - -- So, let's separate the evaluation and the assignment. - V := Make_Cons(Interp.Self, Value, Interp.Stack.Pointer_Slot(Frame_Result_Index)); - Interp.Stack.Pointer_Slot(Frame_Result_Index) := V; - end Chain_Frame_Result; - - procedure Clear_Frame_Result (Frame: in Object_Pointer) is begin Frame.Pointer_Slot(Frame_Result_Index) := Nil_Pointer; @@ -1286,7 +1302,6 @@ Ada.Text_IO.Put_Line ("Make_String..."); Frame.Pointer_Slot(Frame_Operand_Index) := Value; end Set_Frame_Operand; - function Get_Frame_Parent (Frame: in Object_Pointer) return Object_Pointer is pragma Inline (Get_Frame_Parent); pragma Assert (Is_Frame(Frame)); @@ -1294,6 +1309,15 @@ Ada.Text_IO.Put_Line ("Make_String..."); return Frame.Pointer_Slot(Frame_Parent_Index); end Get_Frame_Parent; + procedure Switch_Frame (Frame: in Object_Pointer; + Opcode: in Opcode_Type; + Operand: in Object_Pointer) is + begin + Set_Frame_Opcode (Frame, Opcode); + Set_Frame_Operand (Frame, Operand); + Set_Frame_Result (Frame, Nil_Pointer); + --Set_Frame_Intermediate (Frame, Nil_Pointer); + end Switch_Frame; ----------------------------------------------------------------------------- @@ -1772,7 +1796,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); Initialize_Heap (Initial_Heap_Size); Interp.Root_Environment := Make_Environment(Interp.Self, Nil_Pointer); - Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Opcode_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment); + Interp.Root_Frame := Make_Frame(Interp.Self, Nil_Pointer, Opcode_To_Pointer(Opcode_Exit), Nil_Pointer, Interp.Root_Environment, Nil_Pointer); Interp.Stack := Interp.Root_Frame; Make_Syntax_Objects; @@ -2006,7 +2030,7 @@ end if; -- TODO: use a interp.Stack. -- TODO: use Push_Frame - Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Nil_Pointer); -- just for get_frame_environment... + Stack := Make_Frame (Interp.Self, Nil_Pointer, Integer_To_Pointer(0), Nil_Pointer, Nil_Pointer, Nil_Pointer); -- just for get_frame_environment... Opcode := 1; Operand := Source; @@ -2016,7 +2040,7 @@ end if; when 1 => if Is_Cons(Operand) then -- push cdr - Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer); -- push cdr + Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push cdr Ada.Text_IO.Put ("("); Operand := Get_Car(Operand); Opcode := 1; @@ -2036,7 +2060,7 @@ end if; if Is_Cons(Operand) then -- push cdr - Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer); -- push + Stack := Make_Frame (Interp.Self, Stack, Integer_To_Pointer(2), Get_Cdr(Operand), Nil_Pointer, Nil_Pointer); -- push Ada.Text_IO.Put (" "); Operand := Get_Car(Operand); -- car Opcode := 1; @@ -2066,14 +2090,26 @@ end if; Ada.Text_IO.New_Line; end Print; + procedure Insert_Frame (Interp: in out Interpreter_Record; + Parent: in out Object_Pointer; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Envir: in Object_Pointer; + Interm: in Object_Pointer) is + pragma Inline (Insert_Frame); + pragma Assert (Parent = Nil_Pointer or else Is_Frame(Parent)); + begin + Parent := Make_Frame(Interp.Self, Parent, Opcode_To_Pointer(Opcode), Operand, Envir, Interm); + end Insert_Frame; 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, Get_Frame_Environment(Interp.Stack)); + --Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), + -- Operand, Get_Frame_Environment(Interp.Stack)); + Insert_Frame (Interp, Interp.Stack, Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer); end Push_Frame; procedure Push_Frame_With_Environment (Interp: in out Interpreter_Record; @@ -2082,10 +2118,43 @@ end if; Envir: in Object_Pointer) is pragma Inline (Push_Frame_With_Environment); begin - Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), - Operand, Envir); + --Interp.Stack := Make_Frame(Interp.Self, Interp.Stack, Opcode_To_Pointer(Opcode), + -- Operand, Envir); + Insert_Frame (Interp, Interp.Stack, Opcode, Operand, Envir, Nil_Pointer); end Push_Frame_With_Environment; + procedure Push_Subframe (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer) is + pragma Inline (Push_Subframe); + begin + -- Place a new frame below the existing top frame. + Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index), + Opcode, Operand, Get_Frame_Environment(Interp.Stack), Nil_Pointer); + end Push_Subframe; + + procedure Push_Subframe_With_Environment (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Envir: in Object_Pointer) is + pragma Inline (Push_Subframe_With_Environment); + begin + -- Place a new frame below the existing top frame. + Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index), + Opcode, Operand, Envir, Nil_Pointer); + end Push_Subframe_With_Environment; + + procedure Push_Subframe_With_Intermediate (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + Interm: in Object_Pointer) is + pragma Inline (Push_Subframe_With_Intermediate); + begin + -- Place a new frame below the existing top frame. + Insert_Frame (Interp, Interp.Stack.Pointer_Slot(Frame_Parent_Index), + Opcode, Operand, Get_Frame_Environment(Interp.Stack), Interm); + end Push_Subframe_With_Intermediate; + procedure Pop_Frame (Interp: in out Interpreter_Record) is pragma Inline (Pop_Frame); begin @@ -2117,10 +2186,6 @@ end if; pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Exit); 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); - Result := Get_Car(Result); -- Get the only value chained Clear_Frame_Result (Interp.Stack); end Evaluate; @@ -2154,8 +2219,6 @@ end if; -- TODO: this result must be kept at some where that GC dowsn't sweep. Result := Get_Frame_Result(Interp.Stack); - pragma Assert (Get_Cdr(Result) = Nil_Pointer); - Result := Get_Car(Result); Clear_Frame_Result (Interp.Stack); Ada.Text_IO.Put ("RESULT>>>>>"); diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index db2edc1..7ffb4d9 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -500,7 +500,6 @@ private Root_Environment: Object_Pointer := Nil_Pointer; Root_Frame: Object_Pointer := Nil_Pointer; Stack: Object_Pointer := Nil_Pointer; - Active_Frame: Object_Pointer := NIl_Pointer; Symbol: Common_Symbol_Record; Top: Top_Record; -- temporary object pointers