diff --git a/lib/h2-scheme-execute-evaluate.adb b/lib/h2-scheme-execute-evaluate.adb index 11332f6..4a17bb8 100644 --- a/lib/h2-scheme-execute-evaluate.adb +++ b/lib/h2-scheme-execute-evaluate.adb @@ -8,8 +8,8 @@ procedure Evaluate is Cdr: aliased Object_Pointer; generic - V: Object_Pointer; - Opcode: Opcode_Type; + Result: Object_Pointer; -- Result to return if no expressions exist. + Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next . procedure Generic_And_Or_Syntax; procedure Generic_And_Or_Syntax is @@ -17,14 +17,14 @@ procedure Evaluate is -- (and ...) -- (and (= 2 2) (> 2 1)) ==> #t -- (and (= 2 2) (< 2 1)) ==> #f - -- (and (= 2 2) (< 2 1) (= 3 3)) ==> #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) - Return_Frame (Interp, V); + Return_Frame (Interp, Result); elsif not Is_Cons(Operand) or else Get_Last_Cdr(Operand) /= Nil_Pointer then -- (and . 10) -- (and 1 2 . 10) @@ -38,8 +38,8 @@ procedure Evaluate is 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_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); diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index f3b4aa2..a8410f5 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -21,10 +21,10 @@ procedure Execute (Interp: in out Interpreter_Record) is -- ---------------------------------------------------------------- generic - V: Object_Pointer; - procedure Evaluate_Up_To; + with function Is_Bool (X: in Object_Pointer) return Standard.Boolean; + procedure Evaluate_While; - procedure Evaluate_Up_To is + procedure Evaluate_While is X: Object_Pointer; Y: Object_Pointer; Opcode: Opcode_Type; @@ -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 Y /= V and then Is_Cons(X) then + if Is_Bool(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); @@ -49,10 +49,22 @@ procedure Execute (Interp: in out Interpreter_Record) is -- Return the result of the last expression evaluated. Return_Frame (Interp, Y); end if; - end Evaluate_Up_To; + end Evaluate_While; - procedure Finish_And_Syntax is new Evaluate_Up_To(False_Pointer); - procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer); -----> this is wrong, it shoudl be able to specify "/= False_Pointer". + function Is_False (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_False); + begin + return X = False_Pointer; + end Is_False; + + function Is_True (X: in Object_Pointer) return Standard.Boolean is + pragma Inline (Is_True); + begin + return X /= False_Pointer; + end Is_True; + + procedure Do_And_Finish is new Evaluate_While(Is_True); + procedure Do_Or_Finish is new Evaluate_While(Is_False); -- ---------------------------------------------------------------- procedure Do_Define_Finish is @@ -934,39 +946,48 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack))); when Opcode_Evaluate_Object => Evaluate; - when Opcode_Finish_And_Syntax => - Finish_And_Syntax; -- Conditional + when Opcode_And_Finish => + Do_And_Finish; --when Opcode_Finish_Case_Syntax => --when Opcode_Finish_Cond_Syntax => when Opcode_Define_Finish => Do_Define_Finish; + when Opcode_Grouped_Call => Do_Grouped_Call; + when Opcode_If_Finish => Do_If_Finish; -- Conditional + when Opcode_Let_Binding => Do_Let_Binding; + when Opcode_Letast_Binding => Do_Letast_Binding; + 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_Or_Finish => + Do_Or_Finish; + when Opcode_Procedure_Call => Do_Procedure_Call; + when Opcode_Procedure_Call_Finish => Do_Procedure_Call_Finish; when Opcode_Set_Finish => Do_Set_Finish; -- Assignment - when Opcode_Finish_Or_Syntax => - Finish_Or_Syntax; -- Conditional when Opcode_Apply => Apply; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 9c97e31..bb73eba 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -97,9 +97,9 @@ package body H2.Scheme is Opcode_Exit, Opcode_Evaluate_Result, Opcode_Evaluate_Object, - Opcode_Finish_And_Syntax, - Opcode_Finish_Or_Syntax, + Opcode_And_Finish, + Opcode_Or_Finish, Opcode_Define_Finish, Opcode_Grouped_Call, -- (begin ...), closure apply, let body Opcode_If_Finish,