implemented and and or

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 <test1> <test2> ...)
+		--   (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)); -- <test2> onwards
+               Clear_Frame_Result (Interp.Stack);
+
+			-- arrange to evaluate <test1>
+               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 <test> 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); -- <expression>
 
 			-- Arrange to finish setting a variable after <expression> 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;
 

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 <test1>. 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
+	procedure Finish_If_Syntax is
-		pragma Inline (Finish_If);
+		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
+	procedure Finish_Let_Syntax is
-		pragma Inline (Finish_Let);
+		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
+	procedure Finish_Set_Syntax is
-		pragma Inline (Finish_Set);
+		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 =>
+			-- Conditionals
-				Finish_If;
+			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 =>
+			-- Assignments
-				Finish_Let;
+			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;
 

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_And_Syntax:    constant Opcode_Type := Opcode_Type'(4); 
-	Opcode_Finish_If:            constant Opcode_Type := Opcode_Type'(5); 
+	Opcode_Finish_Define_Symbol: constant Opcode_Type := Opcode_Type'(5); 
-	Opcode_Finish_Let:           constant Opcode_Type := Opcode_Type'(6); 
+	Opcode_Finish_If_Syntax:     constant Opcode_Type := Opcode_Type'(6); 
-	Opcode_Finish_Set:           constant Opcode_Type := Opcode_Type'(7); 
+	Opcode_Finish_Let_Syntax:    constant Opcode_Type := Opcode_Type'(7); 
-	Opcode_Apply:                constant Opcode_Type := Opcode_Type'(8);
+	Opcode_Finish_Or_Syntax:     constant Opcode_Type := Opcode_Type'(8); 
-	Opcode_Read_Object:          constant Opcode_Type := Opcode_Type'(9);
+	Opcode_Finish_Set_Syntax:    constant Opcode_Type := Opcode_Type'(9); 
-	Opcode_Read_List:            constant Opcode_Type := Opcode_Type'(10);
+	Opcode_Apply:                constant Opcode_Type := Opcode_Type'(10);
-	Opcode_Read_List_Cdr:        constant Opcode_Type := Opcode_Type'(11);
+	Opcode_Read_Object:          constant Opcode_Type := Opcode_Type'(11);
-	Opcode_Read_List_End:        constant Opcode_Type := Opcode_Type'(12);
+	Opcode_Read_List:            constant Opcode_Type := Opcode_Type'(12);
-	Opcode_Close_List:           constant Opcode_Type := Opcode_Type'(13);
+	Opcode_Read_List_Cdr:        constant Opcode_Type := Opcode_Type'(13);
-	Opcode_Close_Quote:          constant Opcode_Type := Opcode_Type'(14);
+	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