implemented cond

lib/h2-scheme-execute-evaluate.adb

@@ -30,7 +30,7 @@ procedure Evaluate is
 		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");
+			Ada.Text_IO.Put_LINE ("FUCKING CDR FOR DEFINE");
 			raise Syntax_Error;	
 		else
 			--Switch_Frame (Interp.Stack, Opcode, Get_Cdr(Operand), Nil_Pointer); -- <test2> onwards
@@ -88,6 +88,76 @@ raise Syntax_Error;
 		end if;
 	end Evaluate_Define_Syntax;
 
+     -- ----------------------------------------------------------------
+
+	procedure Evaluate_Case_Syntax is
+		pragma Inline (Evaluate_Case_Syntax);
+	begin
+		Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
+		raise Evaluation_Error;
+	end Evaluate_Case_Syntax;
+
+     -- ----------------------------------------------------------------
+
+	procedure Evaluate_Cond_Syntax is
+		pragma Inline (Evaluate_Cond_Syntax);
+		Ptr: Object_Pointer;
+	begin
+		-- cond <clause 1> <clause 2> ...
+		-- A clause should be of the form:
+		--    (<test> <expression> ...)
+		-- the last clause may be an else clause of the form:
+		--    (else <expression> ...)
+		-- 
+		-- (cond ((> 3 2) 'greater)
+		--       ((< 3 2) 'less))      =>  greater
+		-- (cond ((> 3 3) 'greater)
+		--       ((< 3 3) 'less)
+		--       (else 'equal))        =>  equal
+
+		Operand := Cdr; -- Skip "cond"
+		if Not Is_Cons(Operand) then
+			-- e.g) (cond)
+			--      (cond . 10)
+			Ada.Text_IO.Put_LINE ("NO CLAUSE FOR COND");
+			raise Syntax_Error;
+		end if;
+	
+		-- Check clauses 
+		-- TODO: Skip this check of clauses that have been checked previously.
+		Ptr := Operand;
+		loop
+			Car := Get_Car(Ptr); -- <clause>
+			if not Is_Cons(Car) then
+				Ada.Text_IO.Put_Line ("FUCKING CLAUSE FOR COND");
+				raise Syntax_Error;
+			end if;
+			If Get_Last_Cdr(Car) /= Nil_Pointer then
+				Ada.Text_IO.Put_Line ("FUCKING CDR FOR COND CLAUSE");
+				raise Syntax_Error;
+			end if;
+			Ptr := Get_Cdr(Ptr);
+			exit when not Is_Cons(Ptr);
+		end loop;
+		if Ptr /= Nil_Pointer then
+			Ada.Text_IO.Put_Line ("FUCKING LAST CLAUSE FOR COND");
+			raise Syntax_Error;
+		end if;
+		
+		Car := Get_Car(Operand); -- first <clause>
+		
+		Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Car), Nil_Pointer); -- first <test>
+		Push_Subframe (Interp, Opcode_Cond_Finish, Operand);
+	end Evaluate_Cond_Syntax;
+
+     -- ----------------------------------------------------------------
+	procedure Evaluate_Do_Syntax is
+		pragma Inline (Evaluate_Do_Syntax);
+	begin
+		Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
+		raise Evaluation_Error;
+	end Evaluate_Do_Syntax;
+
      -- ----------------------------------------------------------------
 
 	procedure Evaluate_If_Syntax is
@@ -426,6 +496,14 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
 		end if;
 	end Evaluate_Letrec_Syntax;
 
+     -- ----------------------------------------------------------------
+	procedure Evaluate_Quasiquote_Syntax is
+		pragma Inline (Evaluate_Quasiquote_Syntax);
+	begin
+		Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
+		raise Evaluation_Error;
+	end Evaluate_Quasiquote_Syntax;
+
      -- ----------------------------------------------------------------
 
 	procedure Evaluate_Quote_Syntax is
@@ -564,9 +642,18 @@ end;
 						--	goto Start_Over; -- for optimization only. not really needed.
 						--end if;
 
+					when Case_Syntax =>
+						Evaluate_Case_Syntax;
+
+					when Cond_Syntax =>
+						Evaluate_Cond_Syntax;
+
 					when Define_Syntax =>
 						Evaluate_Define_Syntax;
 
+					when Do_Syntax =>
+						Evaluate_Do_Syntax;
+
 					when If_Syntax =>
 						Evaluate_If_Syntax;
 
@@ -585,16 +672,15 @@ end;
 					when Or_Syntax =>
 						Evaluate_Or_Syntax;
 
+					when Quasiquote_Syntax =>
+						Evaluate_Quasiquote_Syntax;
+
 					when Quote_Syntax =>
 						Evaluate_Quote_Syntax;
 
 					when Set_Syntax => -- set!
 						Evaluate_Set_Syntax;
 
-					when others =>
-						Ada.Text_IO.Put_Line ("Unknown syntax");	
-						--Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Syntax);  -- Switch to syntax evaluation
-						raise Internal_Error;
 				end case;
 			else
 				-- procedure call

lib/h2-scheme-execute.adb

@@ -51,20 +51,61 @@ procedure Execute (Interp: in out Interpreter_Record) is
 		end if;
 	end Evaluate_While;
 
-	function Is_False (X: in Object_Pointer) return Standard.Boolean is
+	function Is_False_Class (X: in Object_Pointer) return Standard.Boolean is
-		pragma Inline (Is_False);
+		pragma Inline (Is_False_Class);
 	begin
 		return X = False_Pointer;
-	end Is_False;
+	end Is_False_Class;
 
-	function Is_True (X: in Object_Pointer) return Standard.Boolean is
+	function Is_True_Class (X: in Object_Pointer) return Standard.Boolean is
-		pragma Inline (Is_True);
+		pragma Inline (Is_True_Class);
 	begin
 		return X /= False_Pointer;
-	end Is_True;
+	end Is_True_Class;
+
+	procedure Do_And_Finish is new Evaluate_While(Is_True_Class);
+	procedure Do_Or_Finish is new Evaluate_While(Is_False_Class);
+
+	-- ----------------------------------------------------------------
+	procedure Do_Cond_Finish is
+		pragma Inline (Do_Cond_Finish);
+		R: Object_Pointer;
+		O: Object_Pointer;
+	begin
+		R := Get_Frame_Result(Interp.Stack); -- <test> result
+		O := Get_Frame_Operand(Interp.Stack); -- <clause> list
+		
+		if Is_True_Class(R) then
+			O := Get_Cdr(Get_Car(O)); -- <expression> list in <clause>
+			if Is_Cons(O) then
+				Reload_Frame (Interp, Opcode_Grouped_Call, O);
+			else
+				Pop_Frame (Interp);
+			end if;
+		else
+			O := Get_Cdr(O); -- next <clause> list
+
+			if not Is_Cons(O) then
+				-- no more <clause>
+				Pop_Frame (Interp);
+			else
+				R := Get_Car(O); -- next <clause>
+				if Get_Car(R) = Interp.Else_Symbol then
+					-- else <clause>
+					O := Get_Cdr(R); -- <expression> list in else <clause>
+					if Is_Cons(O) then
+						Reload_Frame (Interp, Opcode_Grouped_Call, O);
+					else
+						Pop_Frame (Interp);
+					end if;
+				else
+					Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(R), Nil_Pointer);
+					Push_Subframe (Interp, Opcode_Cond_Finish, O);
+				end if;
+			end if;
+		end if;
+	end Do_Cond_Finish;
 
-	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
@@ -766,7 +807,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected");
 	begin
 		V := Get_Frame_Result(Interp.Stack);
 		V := Make_Cons(Interp.Self, V, Nil_Pointer);
-		V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V);
+		V := Make_Cons(Interp.Self, Interp.Quote_Symbol, V);
 		Pop_Frame (Interp); 
 		Chain_Frame_Intermediate (Interp, Interp.Stack, V);
 	end Close_Quote_In_List;
@@ -777,7 +818,7 @@ Ada.Text_IO.Put_Line ("Right parenthesis expected");
 	begin
 		V := Get_Frame_Result(Interp.Stack);
 		V := Make_Cons(Interp.Self, V, Nil_Pointer);
-		V := Make_Cons(Interp.Self, Interp.Symbol.Quote, V);
+		V := Make_Cons(Interp.Self, Interp.Quote_Symbol, V);
 		Return_Frame (Interp, V);
 	end Close_Quote;
 
@@ -894,9 +935,9 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
 
 			when Opcode_And_Finish => 
 				Do_And_Finish;
-
+ 
-			--when Opcode_Finish_Case_Syntax => 
+			when Opcode_Cond_Finish => 
-			--when Opcode_Finish_Cond_Syntax => 
+				Do_Cond_Finish;
 
 			when Opcode_Define_Finish =>
 				Do_Define_Finish;

lib/h2-scheme.adb

@@ -71,10 +71,12 @@ package body H2.Scheme is
 	Label_SymbolQ:    constant Object_Character_Array := (Ch.LC_S, Ch.LC_Y, Ch.LC_M, Ch.LC_B, Ch.LC_O, Ch.LC_L, Ch.Question); -- "symbol?"
 
 
-	Label_Newline:  constant Object_Character_Array := (Ch.LC_N, Ch.LC_E, Ch.LC_W, Ch.LC_L, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "newline"
+	Label_Newline:    constant Object_Character_Array := (Ch.LC_N, Ch.LC_E, Ch.LC_W, Ch.LC_L, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "newline"
-	Label_Space:    constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space"
+	Label_Space:      constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space"
 
-	Label_Arrow:    constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>"
+	Label_Arrow:      constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>"
+	Label_Else:       constant Object_Character_Array := (Ch.LC_E, Ch.LC_L, Ch.LC_S, Ch.LC_E); -- "else"
+	
 	-----------------------------------------------------------------------------
 	-- EXCEPTIONS
 	-----------------------------------------------------------------------------
@@ -105,6 +107,7 @@ package body H2.Scheme is
 	
 		Opcode_And_Finish,
 		Opcode_Or_Finish,
+		Opcode_Cond_Finish,
 		Opcode_Define_Finish,
 		Opcode_Grouped_Call,  -- (begin ...), closure apply, let body
 		Opcode_If_Finish,
@@ -808,9 +811,10 @@ ada.text_io.put_line ("[GC BEGIN]");
 		end loop;
 
 		-- Migrate some known symbols
-		Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
+		Interp.Arrow_Symbol := Move_One_Object(Interp.Arrow_Symbol);
-		Interp.Symbol.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote);
+		Interp.Else_Symbol := Move_One_Object(Interp.Else_Symbol);
-		Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
+		Interp.Quasiquote_Symbol := Move_One_Object(Interp.Quasiquote_Symbol);
+		Interp.Quote_Symbol := Move_One_Object(Interp.Quote_Symbol);
 
 --Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
 		-- Scan the heap
@@ -908,7 +912,7 @@ end if;
 			Kind => Pointer_Object,
 			Size => Size,
 			Flags => 0,
-			Scode => 0,
+			Scode => Syntax_Code'Val(0),
 			Tag => Unknown_Object,
 			Pointer_Slot => (others => Initial)
 		);
@@ -939,7 +943,7 @@ end if;
 			Kind => Character_Object,
 			Size => Size,
 			Flags => 0,
-			Scode => 0,
+			Scode => Syntax_Code'Val(0),
 			Tag => Unknown_Object,
 			Character_Slot => (others => Ch.NUL),
 			Character_Terminator => Ch.NUL
@@ -980,7 +984,7 @@ end if;
 			Kind => Byte_Object,
 			Size => Size,
 			Flags => 0,
-			Scode => 0,
+			Scode => Syntax_Code'Val(0),
 			Tag => Unknown_Object,
 			Byte_Slot => (others => 0)
 		);
@@ -1123,10 +1127,8 @@ end if;
 	                      Source: in      Object_Character_Array) return Object_Pointer is
 		Result: Object_Pointer;
 	begin
-Ada.Text_IO.Put_Line ("Make_String...");
 		Result := Allocate_Character_Object(Interp, Source);
 		Result.Tag := String_Object;
---Print_Object_Pointer ("Make_String Result - " & Source, Result);
 		return Result;
 	end Make_String;
 
@@ -1802,8 +1804,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
 			Dummy := Make_Syntax (Interp.Self, Letast_Syntax, Label_Letast); -- "let*"
 			Dummy := Make_Syntax (Interp.Self, Letrec_Syntax, Label_Letrec); -- "letrec"
 			Dummy := Make_Syntax (Interp.Self, Or_Syntax,     Label_Or); -- "or"
-			Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax,  Label_Quote); -- "quote"
+			Interp.Quote_Symbol := Make_Syntax (Interp.Self, Quote_Syntax,  Label_Quote); -- "quote"
-			Interp.Symbol.Quasiquote := Make_Syntax (Interp.Self, Quasiquote_Syntax,  Label_Quasiquote); -- "quasiquote"
+			Interp.Quasiquote_Symbol := Make_Syntax (Interp.Self, Quasiquote_Syntax,  Label_Quasiquote); -- "quasiquote"
 			Dummy := Make_Syntax (Interp.Self, Set_Syntax,    Label_Set); -- "set!"
 		end Make_Syntax_Objects;
 
@@ -1835,7 +1837,8 @@ Ada.Text_IO.Put_Line ("Make_String...");
 
 		procedure Make_Common_Symbol_Objects is
 		begin
-			Interp.Symbol.Arrow := Make_Symbol (Interp.Self, Label_Arrow);	
+			Interp.Arrow_Symbol := Make_Symbol (Interp.Self, Label_Arrow);	
+			Interp.Else_Symbol := Make_Symbol (Interp.Self, Label_Else);	
 		end Make_Common_Symbol_Objects;
 	begin
 		declare

lib/h2-scheme.ads

@@ -164,24 +164,24 @@ package H2.Scheme is
 	type Object_Flags is mod 2 ** 4;
 	Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#); 
 
-	type Syntax_Code is mod 2 ** 4;
+	type Syntax_Code is (
-	And_Syntax:        constant Syntax_Code := Syntax_Code'(0);
+		And_Syntax,
-	Begin_Syntax:      constant Syntax_Code := Syntax_Code'(1);
+		Begin_Syntax,
-	Case_Syntax:       constant Syntax_Code := Syntax_Code'(2);
+		Case_Syntax,
-	Cond_Syntax:       constant Syntax_Code := Syntax_Code'(3);
+		Cond_Syntax,
-	Define_Syntax:     constant Syntax_Code := Syntax_Code'(4);
+		Define_Syntax,
-	Do_Syntax:         constant Syntax_Code := Syntax_Code'(5);
+		Do_Syntax,
-	If_Syntax:         constant Syntax_Code := Syntax_Code'(6);
+		If_Syntax,
-	Lambda_Syntax:     constant Syntax_Code := Syntax_Code'(7);
+		Lambda_Syntax,
-	Let_Syntax:        constant Syntax_Code := Syntax_Code'(8);
+		Let_Syntax,
-	Letast_Syntax:     constant Syntax_Code := Syntax_Code'(9);
+		Letast_Syntax,
-	Letrec_Syntax:     constant Syntax_Code := Syntax_Code'(10);
+		Letrec_Syntax,
-	Or_Syntax:         constant Syntax_Code := Syntax_Code'(11);
+		Or_Syntax,
-	Quasiquote_Syntax: constant Syntax_Code := Syntax_Code'(12);
+		Quasiquote_Syntax,
-	Quote_Syntax:      constant Syntax_Code := Syntax_Code'(13);
+		Quote_Syntax,
-	Set_Syntax:        constant Syntax_Code := Syntax_Code'(14);
+		Set_Syntax
+	);
 
-	--subtype Procedure_Code is Object_Integer;
 	type Procedure_Code is (
 		Add_Procedure,
 		Callcc_Procedure,
@@ -224,7 +224,7 @@ package H2.Scheme is
 
 	type Object_Record(Kind: Object_Kind; Size: Object_Size) is record
 		Flags: Object_Flags := 0;
-		Scode: Syntax_Code := 0;
+		Scode: Syntax_Code := Syntax_Code'Val(0);
 		Tag: Object_Tag := Unknown_Object;
 
 		-- Object payload:
@@ -503,12 +503,6 @@ private
 		Data: Top_Array(1 .. 100) := (others => null);
 	end record;
 
-	type Common_Symbol_Record is record
-		Arrow:      Object_Pointer := Nil_Pointer;
-		Quasiquote: Object_Pointer := Nil_Pointer;
-		Quote:      Object_Pointer := Nil_Pointer;
-	end record;
-
 	--type Interpreter_Record is tagged limited record
 	type Interpreter_Record is limited record
 		Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
@@ -525,7 +519,11 @@ private
 		Root_Frame: Object_Pointer := Nil_Pointer;
 		Stack: Object_Pointer := Nil_Pointer;
 
-		Symbol: Common_Symbol_Record;
+		Arrow_Symbol:      Object_Pointer := Nil_Pointer;
+		Else_Symbol:       Object_Pointer := Nil_Pointer;
+		Quasiquote_Symbol: Object_Pointer := Nil_Pointer;
+		Quote_Symbol:      Object_Pointer := Nil_Pointer;
+		
 		Top: Top_Record; -- temporary object pointers
 
 		Base_Input: aliased IO_Record;