fixed bugs in and/or handlers

lib/h2-scheme-execute-evaluate.adb

@@ -8,8 +8,8 @@ procedure Evaluate is
 	Cdr: aliased Object_Pointer;
 
 	generic
-		V: Object_Pointer;
+		Result: Object_Pointer; -- Result to return if no <test> expressions exist.
-		Opcode: Opcode_Type;
+		Opcode: Opcode_Type; -- Switch to this opcode to evaluate the next <test>.
 	procedure Generic_And_Or_Syntax;
 
 	procedure Generic_And_Or_Syntax is
@@ -17,14 +17,14 @@ procedure Evaluate is
 		-- (and <test1> <test2> ...)
 		--   (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_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_Finish_Or_Syntax);
+	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);

lib/h2-scheme-execute.adb

@@ -21,10 +21,10 @@ procedure Execute (Interp: in out Interpreter_Record) is
 
 	-- ----------------------------------------------------------------
 	generic
-		V: Object_Pointer;
+		with function Is_Bool (X: in Object_Pointer) return Standard.Boolean;
-	procedure Evaluate_Up_To;
+	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 <test1>. 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);
+	function Is_False (X: in Object_Pointer) return Standard.Boolean is
-	procedure Finish_Or_Syntax is new Evaluate_Up_To(True_Pointer); -----> this is wrong, it shoudl be able to specify "/= False_Pointer".
+		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 => 
+			when Opcode_And_Finish => 
-				Finish_And_Syntax; -- Conditional
+				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;

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,