From 99c7c03d148a6acd702eba621f7421529db429fa Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Thu, 23 Jan 2014 15:18:47 +0000 Subject: [PATCH] implemented let --- lib/h2-scheme-execute-apply.adb | 2 +- lib/h2-scheme-execute-evaluate.adb | 115 +++++++++++++++++------------ lib/h2-scheme-execute.adb | 110 +++++++++++++++++++++------ lib/h2-scheme.adb | 79 ++++++++++++-------- 4 files changed, 205 insertions(+), 101 deletions(-) diff --git a/lib/h2-scheme-execute-apply.adb b/lib/h2-scheme-execute-apply.adb index f231cb8..9bc6d34 100644 --- a/lib/h2-scheme-execute-apply.adb +++ b/lib/h2-scheme-execute-apply.adb @@ -302,7 +302,7 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON"); -- For a closure created of "(lambda (x y) (+ x y) (* x y))" -- Get_Closure_Code(Func) returns "((x y) (+ x y) (* x y))" - -- Push a new environmen for the closure + -- Push a new environment for the closure Interp.Environment := Make_Environment(Interp.Self, Get_Closure_Environment(Func)); Fbody := Get_Closure_Code(Func); diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 9c0f4d2..9420028 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -170,6 +170,8 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; + -- Check for a duplication formal argument +-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated V := Formals; loop exit when V = Cdr; @@ -182,6 +184,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); V := Get_Cdr(V); end loop; + -- Move on to the next formal argument Cdr := Get_Cdr(Cdr); exit when not Is_Cons(Cdr); end loop; @@ -219,6 +222,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); procedure Evaluate_Let_Syntax is pragma Inline (Evaluate_Let_Syntax); + + Bindings: Object_Pointer; + LetBody: Object_Pointer; begin -- let Operand := Cdr; -- Skip "let". @@ -229,74 +235,86 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; - Car := Get_Car(Operand); -- - if not Is_Cons(Car) then + Bindings := Get_Car(Operand); -- + if not Is_Cons(Bindings) then Ada.Text_IO.Put_Line ("INVALID BINDINGS FOR LET"); raise Syntax_Error; end if; - Cdr := Get_Cdr(Operand); -- cons cell to - if not Is_Cons(Cdr) then + Letbody := Get_Cdr(Operand); -- Cons cell to + if not Is_Cons(Letbody) then -- (let ((x 2)) ) -- (let ((x 2)) . 99) Ada.Text_IO.Put_Line ("INVALID BODY FOR LET"); raise Syntax_Error; end if; - Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let_Syntax); - Set_Frame_Operand (Interp.Stack, Operand); + Cdr := Bindings; + loop + Car := Get_Car(Cdr); -- + if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then + -- no binding name or no binding value or garbage after that + Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET"); + raise Syntax_Error; + end if; - declare - Bindings: aliased Object_Pointer := Car; - Binding_Name: Object_Pointer; - Binding_Value: Object_Pointer; - V: Object_Pointer; - begin - Push_Top (Interp, Bindings'Unchecked_Access); + if not Is_Symbol(Get_Car(Car)) then + Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET"); + raise Syntax_Error; + end if; - Cdr := Bindings; - loop - Car := Get_Car(Cdr); -- - if not Is_Cons(Car) or else not Is_Cons(Get_Cdr(Car)) or else Get_Cdr(Get_Cdr(Car)) /= Nil_Pointer then - Ada.Text_IO.Put_Line ("WRONG BINDING FOR LET"); - raise Syntax_Error; - end if; + -- Check for a duplicate binding name +-- TODO: make duplication check optional or change the implementation more efficient so that this check is not repeated + declare + V: Object_Pointer; + begin + V := Bindings; + loop + exit when V = Cdr; - Binding_Name := Get_Car(Car); - if not Is_Symbol(Binding_Name) then - Ada.Text_IO.Put_Line ("WRONG BINDING NAME FOR LET"); - raise Syntax_Error; - end if; + if Get_Car(Get_Car(V)) = Get_Car(Car) then + Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); + raise Syntax_Error; + end if; - Binding_Value := Get_Car(Get_Cdr(Car)); - Push_Frame (Interp, Opcode_Evaluate_Object, Binding_Value); --- TODO: check duplicate - --V := Formals; - --loop - -- exit when V = Cdr; + V := Get_Cdr(V); + end loop; + end; - -- if Get_Car(V) = Car then - -- Ada.Text_IO.Put_Line ("DUPLICATE BINDING FOR LET"); - -- raise Syntax_Error; - -- end if; --- --- V := Get_Cdr(V); --- end loop; + -- Move on to the next binding + Cdr := Get_Cdr(Cdr); + exit when not Is_Cons(Cdr); + end loop; - Cdr := Get_Cdr(Cdr); - exit when not Is_Cons(Cdr); - end loop; + if Cdr /= Nil_Pointer then + -- The last cdr is not nil. + Ada.Text_IO.Put_Line ("FUCKING CDR FOR LET BINDING"); + raise Syntax_Error; + end if; - Pop_Tops (Interp, 1); - end; + -- To avoid problems of temporary object pointer problems. + Car := Bindings; + Cdr := LetBody; --- if Cdr /= Nil_Pointer and then not Is_Symbol(Cdr) then --- Ada.Text_IO.Put_Line ("FUCKING CDR IN FORMALS FOR LAMBDA"); --- raise Syntax_Error; --- end if; + Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); + Set_Frame_Operand (Interp.Stack, Cdr); + Push_Frame (Interp, Opcode_Let_Binding, Car); + Push_Frame (Interp, Opcode_Let_Evaluation, Car); end Evaluate_Let_Syntax; + procedure Evaluate_Letast_Syntax is + pragma Inline (Evaluate_Letast_Syntax); + begin + + --Set_Frame_Opcode (Interp.Stack, Opcode_Let_Finish); + --Set_Frame_Operand (Interp.Stack, Cdr); + + --Push_Frame (Interp, Opcode_Let_Binding, Car); + --Push_Frame (Interp, Opcode_Let_Evaluation, Car); + null; + end Evaluate_Letast_Syntax; + procedure Evaluate_Quote_Syntax is pragma Inline (Evaluate_Quote_Syntax); begin @@ -427,6 +445,9 @@ begin when Let_Syntax => Evaluate_Let_Syntax; + when Letast_Syntax => + Evaluate_Letast_Syntax; + when Or_Syntax => Evaluate_Or_Syntax; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index e63066c..caf1114 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -83,8 +83,8 @@ procedure Execute (Interp: in out Interpreter_Record) is procedure Evaluate_Up_To; procedure Evaluate_Up_To is - X: aliased Object_Pointer; - Y: aliased Object_Pointer; + X: Object_Pointer; + Y: Object_Pointer; begin X := Get_Frame_Operand(Interp.Stack); Y := Get_Frame_Result(Interp.Stack); @@ -171,12 +171,74 @@ procedure Execute (Interp: in out Interpreter_Record) is Pop_Tops (Interp, 2); end Finish_If_Syntax; - procedure Finish_Let_Syntax is - pragma Inline (Finish_Let_Syntax); + -- -------------------------------------------------------------------- + + procedure Do_Let_Evaluation is + pragma Inline (Do_Let_Evaluation); + X: Object_Pointer; + Y: Object_Pointer; + begin + X := Get_Frame_Operand(Interp.Stack); -- and onward + + if Is_Cons(X) then + Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); + -- Say, is ((x 2) (y 2)). + -- for the first call, Get_Car(X) is (x 2). + -- To get x, Get_Car(Get_Car(X)) + -- To get 2, Get_Car(Get_Cdr(Get_Car(X))) + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Get_Cdr(Get_Car(X)))); + else + -- Pass the result to the Perform_Let_Binding frame. + Y := Get_Frame_Result(Interp.Stack); + Pop_Frame (Interp); + Set_Frame_Result (Interp.Stack, Y); + end if; + end Do_Let_Evaluation; + + procedure Do_Let_Binding is + pragma Inline (Do_Let_Binding); + X: aliased Object_Pointer; + Y: aliased Object_Pointer; begin -ada.text_io.put_line ("Finish_Let_Syntax"); - null; - end Finish_Let_Syntax; + Push_Top (Interp, X'Unchecked_Access); + Push_Top (Interp, Y'Unchecked_Access); + + X := Get_Frame_Operand(Interp.Stack); -- and onward + Y := Get_Frame_Result(Interp.Stack); + + pragma Assert (Interp.Environment = Get_Frame_Environment(Interp.Stack)); + + -- Push a new environment + Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); + + -- Change the frame's environment so that Pop_Frame() doesn't + -- restore the environment to the old one. The new environment + -- has been just pushed above after binding evaluation. + Set_Frame_Environment (Interp.Stack, Interp.Environment); + + while Is_Cons(X) loop + pragma Assert (Is_Cons(Y)); + Put_Environment (Interp, Get_Car(Get_Car(X)), Get_Car(Y)); + + X := Get_Cdr(X); + Y := Get_Cdr(Y); + end loop; + + Pop_Frame (Interp); -- done. + + Pop_Tops (Interp, 2); + end Do_Let_Binding; + + 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); + end Do_Let_Finish; + + -- -------------------------------------------------------------------- procedure Finish_Set_Syntax is pragma Inline (Finish_Set_Syntax); @@ -828,33 +890,37 @@ begin when Opcode_Evaluate_Group => Evaluate_Group; + when Opcode_Finish_And_Syntax => + Finish_And_Syntax; -- Conditional + + --when Opcode_Finish_Case_Syntax => + --when Opcode_Finish_Cond_Syntax => + when Opcode_Finish_Define_Symbol => Finish_Define_Symbol; - -- Conditionals when Opcode_Finish_If_Syntax => - Finish_If_Syntax; - --when Opcode_Finish_Cond_Syntax => -- Derived, Essential - --when Opcode_Finish_Case_Syntax => -- Derived - when Opcode_Finish_And_Syntax => -- Derived - Finish_And_Syntax; - when Opcode_Finish_Or_Syntax => -- Derived - Finish_Or_Syntax; + Finish_If_Syntax; -- Conditional - -- Assignments - when Opcode_Finish_Set_Syntax => - Finish_Set_Syntax; + when Opcode_Let_Binding => + Do_Let_Binding; + when Opcode_Let_Evaluation => + Do_Let_Evaluation; + when Opcode_Let_Finish => + Do_Let_Finish; - -- Bindings - when Opcode_Finish_Let_Syntax => - Finish_Let_Syntax; --when Opcode_Finish_Letast_Syntax => --when Opcode_Finish_Letrec_Syntax => + when Opcode_Finish_Or_Syntax => + Finish_Or_Syntax; -- Conditional + + when Opcode_Finish_Set_Syntax => + Finish_Set_Syntax; -- Assignment + when Opcode_Apply => Apply; - -- Reading when Opcode_Read_Object => Read_Object; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index a938fe5..0ad0361 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -88,7 +88,7 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 16; + subtype Opcode_Type is Object_Integer range 0 .. 18; Opcode_Exit: constant Opcode_Type := Opcode_Type'(0); Opcode_Evaluate_Result: constant Opcode_Type := Opcode_Type'(1); Opcode_Evaluate_Object: constant Opcode_Type := Opcode_Type'(2); @@ -96,16 +96,20 @@ package body H2.Scheme is Opcode_Finish_And_Syntax: constant Opcode_Type := Opcode_Type'(4); Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(5); Opcode_Finish_If_Syntax: constant Opcode_Type := Opcode_Type'(6); - Opcode_Finish_Let_Syntax: constant Opcode_Type := Opcode_Type'(7); - Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(8); - Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(9); - Opcode_Apply: constant Opcode_Type := Opcode_Type'(10); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(11); - Opcode_Read_List: constant Opcode_Type := Opcode_Type'(12); - Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(13); - Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(14); - Opcode_Close_List: constant Opcode_Type := Opcode_Type'(15); - Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(16); + Opcode_Finish_Or_Syntax: constant Opcode_Type := Opcode_Type'(7); + Opcode_Finish_Set_Syntax: constant Opcode_Type := Opcode_Type'(8); + + Opcode_Let_Binding: constant Opcode_Type := Opcode_Type'(9); + Opcode_Let_Evaluation: constant Opcode_Type := Opcode_Type'(10); + Opcode_Let_Finish: constant Opcode_Type := Opcode_Type'(11); + + Opcode_Apply: constant Opcode_Type := Opcode_Type'(12); + Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(13); + Opcode_Read_List: constant Opcode_Type := Opcode_Type'(14); + Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(15); + Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(16); + Opcode_Close_List: constant Opcode_Type := Opcode_Type'(17); + Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(18); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -1253,21 +1257,20 @@ Ada.Text_IO.Put_Line ("Make_String..."); end if; end Put_Environment; - procedure Push_Environment (Interp: in out Interpreter_Record) is - pragma Inline (Push_Environment); - pragma Assert (Is_Cons(Interp.Environment)); - begin - Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); - end Push_Environment; + --procedure Push_Environment (Interp: in out Interpreter_Record) is + -- pragma Inline (Push_Environment); + -- pragma Assert (Is_Cons(Interp.Environment)); + --begin + -- Interp.Environment := Make_Environment(Interp.Self, Interp.Environment); + --end Push_Environment; - procedure Pop_Environment (Interp: in out Interpreter_Record) is - pragma Inline (Pop_Environment); - pragma Assert (Is_Cons(Interp.Environment)); - begin - Interp.Environment := Get_Cdr(Interp.Environment); - end Pop_Environment; + --procedure Pop_Environment (Interp: in out Interpreter_Record) is + -- pragma Inline (Pop_Environment); + -- pragma Assert (Is_Cons(Interp.Environment)); + --begin + -- Interp.Environment := Get_Cdr(Interp.Environment); + --end Pop_Environment; - ----------------------------------------------------------------------------- function Make_Syntax (Interp: access Interpreter_Record; @@ -1379,13 +1382,19 @@ Ada.Text_IO.Put_Line ("Make_String..."); return Frame.Pointer_Slot(Frame_Result_Index); end Get_Frame_Result; - --procedure Set_Frame_Result (Frame: in out Object_Pointer; - -- Value: in Object_Pointer) is - -- pragma Inline (Set_Frame_Result); - -- pragma Assert (Is_Frame(Frame)); - --begin - -- Frame.Pointer_Slot(Frame_Result_Index) := Value; - --end Set_Frame_Result; + procedure Set_Frame_Result (Frame: in out Object_Pointer; + 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 (Is_Cons(Value)); + begin + Frame.Pointer_Slot(Frame_Result_Index) := Value; + end Set_Frame_Result; procedure Chain_Frame_Result (Interp: in out Interpreter_Record; Frame: in Object_Pointer; -- TODO: remove this parameter @@ -1422,6 +1431,14 @@ Ada.Text_IO.Put_Line ("Make_String..."); return Frame.Pointer_Slot(Frame_Environment_Index); end Get_Frame_Environment; + procedure Set_Frame_Environment (Frame: in Object_Pointer; + Value: in Object_Pointer) is + pragma Inline (Set_Frame_Environment); + pragma Assert (Is_Frame(Frame)); + begin + Frame.Pointer_Slot(Frame_Environment_Index) := Value; + end Set_Frame_Environment; + function Get_Frame_Opcode (Frame: in Object_Pointer) return Opcode_Type is pragma Inline (Get_Frame_Opcode); pragma Assert (Is_Frame(Frame));