From 4208d8f2dfcd4db6a0f8172cb8e6e2cda2f1e2ab Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 26 Jan 2014 14:58:02 +0000 Subject: [PATCH] implemented letrec and corrected let and let* --- lib/h2-scheme-execute-apply.adb | 2 +- lib/h2-scheme-execute-evaluate.adb | 55 ++++++++++++++++++++---------- lib/h2-scheme-execute.adb | 21 ++++++++++-- lib/h2-scheme.adb | 29 ++++++++++++---- 4 files changed, 79 insertions(+), 28 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index cdc7171..d2732f9 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -2,7 +2,7 @@ separate (H2.Scheme.Execute) procedure Apply is - pragma Inline (Apply); + --pragma Inline (Apply); Operand: aliased Object_Pointer; Func: aliased Object_Pointer; diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index f08ffbc..522f440 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -1,7 +1,7 @@ separate (H2.Scheme.Execute) procedure Evaluate is - pragma Inline (Evaluate); + --pragma Inline (Evaluate); Operand: aliased Object_Pointer; Car: aliased Object_Pointer; @@ -301,7 +301,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); procedure Evaluate_Let_Syntax is pragma Inline (Evaluate_Let_Syntax); - Envir: Object_Pointer; + Envir: aliased Object_Pointer; begin Check_Let_Syntax; -- Car: , Cdr: @@ -309,7 +309,10 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); Set_Frame_Operand (Interp.Stack, Cdr); - -- Push a new environment to the current frame. + -- 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); @@ -320,12 +323,25 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); -- x ; this must be 99. -- -- #2. - -- ... + -- (define x 10) ; x-outer + -- (define y (let ((x (+ x 1))) x)) ; x-inner := x-outer + 1, y := x-inner + -- y ; 11 + -- x ; 10 + -- if Car /= Nil_Pointer then -- is not empty + Push_Top (Interp, Envir'Unchecked_Access); + Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)); + + -- The actual binding after evaluation must be performed in the + -- new environment. Push_Frame (Interp, Opcode_Let_Binding, Car); - Push_Frame (Interp, Opcode_Let_Evaluation, 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, Car, Envir); + Pop_Tops (Interp, 1); end if; end Evaluate_Let_Syntax; @@ -339,13 +355,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); 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_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); end if; end Evaluate_Letast_Syntax; @@ -356,18 +373,20 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); 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); + 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); + -- Push a new environment. + Envir := Make_Environment(Interp.Self, Get_Frame_Environment(Interp.Stack)); + Set_Frame_Environment (Interp.Stack, Envir); - --if Car /= Nil_Pointer then + if Car /= Nil_Pointer then -- is not empty - -- Push_Frame (Interp, Opcode_Letrec_Binding, Car); - --end if; + -- Arrange to perform evaluataion and binding in the + -- new environment created. + Push_Frame (Interp, Opcode_Let_Binding, Car); + Push_Frame (Interp, Opcode_Let_Evaluation, Car); + end if; end Evaluate_Letrec_Syntax; procedure Evaluate_Quote_Syntax is diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 9f0fa40..56c1161 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -224,6 +224,8 @@ procedure Execute (Interp: in out Interpreter_Record) is end loop; Pop_Frame (Interp); -- done. + pragma Assert (Get_Frame_Opcode(Interp.Stack) = Opcode_Let_Finish); + Pop_Tops (Interp, 2); end Do_Let_Binding; @@ -231,9 +233,11 @@ procedure Execute (Interp: in out Interpreter_Record) is pragma Inline (Do_Letast_Binding); 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); @@ -241,25 +245,36 @@ procedure Execute (Interp: in out Interpreter_Record) is if Y = Nil_Pointer then -- First call pragma Assert (Is_Cons(X)); -- Don't provoke this procedure if is empty. + Envir := Get_Frame_Environment(Get_Frame_Parent(Interp.Stack)); Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); else - -- Subsequence calls - -- Update the environment while evaluating + -- Subsequence calls. 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)); + 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; end if; - Pop_Tops (Interp, 2); + Pop_Tops (Interp, 3); end Do_Letast_Binding; procedure Do_Let_Finish is diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 5beb50e..e903e54 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -119,7 +119,7 @@ package body H2.Scheme is Cons_Cdr_Index: constant Pointer_Object_Size := 2; Frame_Object_Size: constant Pointer_Object_Size := 5; - Frame_Stack_Index: constant Pointer_Object_Size := 1; + 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; @@ -1135,7 +1135,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- Since it's used for stack, it can be made special. Frame := Allocate_Pointer_Object (Interp, Frame_Object_Size, Nil_Pointer); Frame.Tag := Frame_Object; - Frame.Pointer_Slot(Frame_Stack_Index) := Aliased_Stack; + Frame.Pointer_Slot(Frame_Parent_Index) := Aliased_Stack; Frame.Pointer_Slot(Frame_Opcode_Index) := Aliased_Opcode; Frame.Pointer_Slot(Frame_Operand_Index) := Aliased_Operand; Frame.Pointer_Slot(Frame_Environment_Index) := Aliased_Envir; @@ -1247,6 +1247,13 @@ Ada.Text_IO.Put_Line ("Make_String..."); 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)); + begin + return Frame.Pointer_Slot(Frame_Parent_Index); + end Get_Frame_Parent; + ----------------------------------------------------------------------------- -- @@ -1962,7 +1969,7 @@ end if; else Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); Operand := Stack.Pointer_Slot(Frame_Operand_Index); - Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop + Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop end if; end if; @@ -1987,7 +1994,7 @@ end if; else Opcode := Pointer_To_Integer(Stack.Pointer_Slot(Frame_Opcode_Index)); Operand := Stack.Pointer_Slot(Frame_Operand_Index); - Stack := Stack.Pointer_Slot(Frame_Stack_Index); -- pop + Stack := Stack.Pointer_Slot(Frame_Parent_Index); -- pop end if; end if; @@ -2008,15 +2015,25 @@ end if; 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)); end Push_Frame; + procedure Push_Frame_With_Environment (Interp: in out Interpreter_Record; + Opcode: in Opcode_Type; + Operand: in Object_Pointer; + 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); + end Push_Frame_With_Environment; + 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 + Interp.Stack := Interp.Stack.Pointer_Slot(Frame_Parent_Index); -- pop end Pop_Frame; procedure Execute (Interp: in out Interpreter_Record) is separate;