diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 14baa13..9c0f4d2 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -7,6 +7,43 @@ procedure Evaluate is Car: aliased Object_Pointer; Cdr: aliased Object_Pointer; + generic + V: Object_Pointer; + Opcode: Opcode_Type; + procedure Generic_And_Or_Syntax; + + procedure Generic_And_Or_Syntax is + begin + -- (and ...) + -- (and (= 2 2) (> 2 1)) ==> #t + -- (and (= 2 2) (< 2 1)) ==> #f + -- (and (= 2 2) (< 2 1) (= 3 3)) ==> #f + -- (and 1 2 'c '(f g)) ==> (f g) + -- (and) ==> #t + + Operand := Cdr; -- Skip "And" + if Operand = Nil_Pointer then + -- (and) + Pop_Frame (Interp); + Chain_Frame_Result (Interp, Interp.Stack, V); + elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then + -- (and . 10) + -- (and 1 2 . 10) + Ada.Text_IO.Put_LINE ("FUCKING cDR FOR DEFINE"); + raise Syntax_Error; + else + Set_Frame_Opcode (Interp.Stack, Opcode); + Set_Frame_Operand (Interp.Stack, Get_Cdr(Operand)); -- onwards + Clear_Frame_Result (Interp.Stack); + + -- arrange to evaluate + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(Operand)); + end if; + end Generic_And_Or_Syntax; + + procedure Evaluate_And_Syntax is new Generic_And_Or_Syntax(True_Pointer, Opcode_Finish_And_Syntax); + procedure Evaluate_Or_Syntax is new Generic_And_Or_Syntax(False_Pointer, Opcode_Finish_Or_Syntax); + procedure Evaluate_Define_Syntax is pragma Inline (Evaluate_Define_Syntax); begin @@ -92,7 +129,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); end if; -- Switch the current frame to execute action after evaluation. - Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If); + Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If_Syntax); Set_Frame_Operand (Interp.Stack, Operand); -- Arrange to evalaute the conditional @@ -206,7 +243,7 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE"); raise Syntax_Error; end if; - Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let); + Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Let_Syntax); Set_Frame_Operand (Interp.Stack, Operand); declare @@ -303,7 +340,7 @@ 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_Finish_Set); + Set_Frame_Opcode (Interp.Stack, Opcode_Finish_Set_Syntax); Set_Frame_Operand (Interp.Stack, Car); -- Arrange to evalaute the value part @@ -351,6 +388,9 @@ begin -- apply for special syntax objects. case Car.Scode is + when And_Syntax => + Evaluate_And_Syntax; + when Begin_Syntax => Operand := Cdr; -- Skip "begin" @@ -387,6 +427,9 @@ begin when Let_Syntax => Evaluate_Let_Syntax; + when Or_Syntax => + Evaluate_Or_Syntax; + when Quote_Syntax => Evaluate_Quote_Syntax; diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index b482c80..e63066c 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -77,6 +77,42 @@ procedure Execute (Interp: in out Interpreter_Record) is Pop_Tops (Interp, 3); end Evaluate_Group; + -- ---------------------------------------------------------------- + generic + V: Object_Pointer; + procedure Evaluate_Up_To; + + procedure Evaluate_Up_To is + X: aliased Object_Pointer; + Y: aliased Object_Pointer; + begin + X := Get_Frame_Operand(Interp.Stack); + 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 + + if Y /= V and then Is_Cons(X) then + -- The result is not what I look for. + -- Yet there are still more tests to evaluate. + Set_Frame_Operand (Interp.Stack, Get_Cdr(X)); + Clear_Frame_Result (Interp.Stack); + Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X)); + else + -- Return the result of the last expression evaluated. + Pop_Frame (Interp); + Chain_Frame_Result (Interp, Interp.Stack, Y); + end if; + end Evaluate_Up_To; + + procedure Finish_And_Syntax is new Evaluate_Up_To(False_Pointer); + procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer); + -- ---------------------------------------------------------------- + procedure Finish_Define_Symbol is pragma Inline (Finish_Define_Symbol); X: aliased Object_Pointer; @@ -100,8 +136,8 @@ procedure Execute (Interp: in out Interpreter_Record) is Pop_Tops (Interp, 2); end Finish_Define_Symbol; - procedure Finish_If is - pragma Inline (Finish_If); + procedure Finish_If_Syntax is + pragma Inline (Finish_If_Syntax); X: aliased Object_Pointer; Y: aliased Object_Pointer; Z: aliased Object_Pointer; @@ -133,17 +169,17 @@ procedure Execute (Interp: in out Interpreter_Record) is end if; Pop_Tops (Interp, 2); - end Finish_If; + end Finish_If_Syntax; - procedure Finish_Let is - pragma Inline (Finish_Let); + procedure Finish_Let_Syntax is + pragma Inline (Finish_Let_Syntax); begin -ada.text_io.put_line ("Finish_Let"); +ada.text_io.put_line ("Finish_Let_Syntax"); null; - end Finish_Let; + end Finish_Let_Syntax; - procedure Finish_Set is - pragma Inline (Finish_Set); + procedure Finish_Set_Syntax is + pragma Inline (Finish_Set_Syntax); X: aliased Object_Pointer; Y: aliased Object_Pointer; begin @@ -164,7 +200,7 @@ ada.text_io.put_line ("Finish_Let"); Chain_Frame_Result (Interp, Interp.Stack, Y); Pop_Tops (Interp, 2); - end Finish_Set; + end Finish_Set_Syntax; procedure Evaluate is separate; procedure Apply is separate; @@ -795,18 +831,30 @@ begin when Opcode_Finish_Define_Symbol => Finish_Define_Symbol; - when Opcode_Finish_If => - Finish_If; + -- 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; - when Opcode_Finish_Let => - Finish_Let; + -- Assignments + when Opcode_Finish_Set_Syntax => + Finish_Set_Syntax; + + -- Bindings + when Opcode_Finish_Let_Syntax => + Finish_Let_Syntax; + --when Opcode_Finish_Letast_Syntax => + --when Opcode_Finish_Letrec_Syntax => - when Opcode_Finish_Set => - Finish_Set; - when Opcode_Apply => Apply; + -- Reading when Opcode_Read_Object => Read_Object; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 89a5144..a938fe5 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -88,22 +88,24 @@ package body H2.Scheme is subtype Moved_Object_Record is Object_Record (Moved_Object, 0); - subtype Opcode_Type is Object_Integer range 0 .. 14; + subtype Opcode_Type is Object_Integer range 0 .. 16; 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); Opcode_Evaluate_Group: constant Opcode_Type := Opcode_Type'(3); -- (begin ...) and closure apply - Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(4); - Opcode_Finish_If: constant Opcode_Type := Opcode_Type'(5); - Opcode_Finish_Let: constant Opcode_Type := Opcode_Type'(6); - Opcode_Finish_Set: constant Opcode_Type := Opcode_Type'(7); - Opcode_Apply: constant Opcode_Type := Opcode_Type'(8); - Opcode_Read_Object: constant Opcode_Type := Opcode_Type'(9); - Opcode_Read_List: constant Opcode_Type := Opcode_Type'(10); - Opcode_Read_List_Cdr: constant Opcode_Type := Opcode_Type'(11); - Opcode_Read_List_End: constant Opcode_Type := Opcode_Type'(12); - Opcode_Close_List: constant Opcode_Type := Opcode_Type'(13); - Opcode_Close_Quote: constant Opcode_Type := Opcode_Type'(14); + 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); ----------------------------------------------------------------------------- -- COMMON OBJECTS @@ -1222,6 +1224,7 @@ Ada.Text_IO.Put_Line ("Make_String..."); -- environment. If no key is found, add a new pair -- This is mainly for define. pragma Assert (Is_Symbol(Key)); + pragma Assert (Is_Cons(Interp.Environment)); Arr := Find_In_Environment_List(Interp.Self, Get_Car(Interp.Environment), Key); if Arr /= null then