implemented if

lib/ascii.txt

@@ -59,7 +59,7 @@ Nine
 Colon
 Semicolon
 Less_Than_Sign
-Equals_Sign
+Equal_Sign
 Greater_Than_Sign
 Question
 Commercial_At

lib/h2-ascii.ads

@@ -67,7 +67,7 @@ package H2.Ascii is
 		Colon               : constant := 58; -- :
 		Semicolon           : constant := 59; -- ;
 		Less_Than_Sign      : constant := 60; -- <
-		Equals_Sign         : constant := 61; -- =
+		Equal_Sign          : constant := 61; -- =
 		Greater_Than_Sign   : constant := 62; -- >
 		Question            : constant := 63; -- ?
 		Commercial_At       : constant := 64; -- @
@@ -197,7 +197,7 @@ package H2.Ascii is
 	Colon               : constant Character_Type := Character_Type'Val(Pos.Colon);
 	Semicolon           : constant Character_Type := Character_Type'Val(Pos.Semicolon);
 	Less_Than_Sign      : constant Character_Type := Character_Type'Val(Pos.Less_Than_Sign);
-	Equals_Sign         : constant Character_Type := Character_Type'Val(Pos.Equals_Sign);
+	Equal_Sign          : constant Character_Type := Character_Type'Val(Pos.Equal_Sign);
 	Greater_Than_Sign   : constant Character_Type := Character_Type'Val(Pos.Greater_Than_Sign);
 	Question            : constant Character_Type := Character_Type'Val(Pos.Question);
 	Commercial_At       : constant Character_Type := Character_Type'Val(Pos.Commercial_At);

lib/h2-scheme-execute-apply.adb

@@ -131,6 +131,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
 			end if;
 			Num := Pointer_To_Integer(Car);
 
+			Ptr := Get_Cdr(Ptr);
 			while Ptr /= Nil_Pointer loop
 				-- TODO: check if car is an integer or bignum or something else.
 				--       if something else, error

lib/h2-scheme-execute-evaluate.adb

@@ -47,6 +47,57 @@ procedure Evaluate is
 
 	end Evaluate_Define_Syntax;
 
+	procedure Evaluate_If_Syntax is
+		pragma Inline (Evaluate_If_Syntax);
+	begin
+		-- (if <test> <consequent>)
+		-- (if <test> <consequent> <alternate>)
+		--   (if (> 3 2) 'yes)
+		--   (if (> 3 2) 'yes 'no)
+		--   (if (> 3 2) (- 3 2) (+ 3 2))      
+		Operand := Cdr;  -- Skip "if"
+		if Not Is_Cons(Operand) then
+			-- e.g) (if)
+			--      (if . 10)
+			Ada.Text_IO.Put_LINE ("NO CONDITIONAL FOR IF");
+			raise Syntax_Error;
+		end if;
+
+		Car := Get_Car(Operand); -- <test>
+
+		Operand := Get_Cdr(Operand); -- cons cell containg <consequent>
+		if not Is_Cons(Operand) then
+			Ada.Text_IO.Put_Line ("NO ACTION FOR IF");
+			raise Syntax_Error;
+		end if;
+
+		Cdr := Get_Cdr(Operand); -- cons cell containing <alternate>
+		if Cdr = Nil_Pointer then
+			-- no <alternate>. it's ok
+Ada.Text_IO.Put_Line ("NO ALTERNATE");
+			null;
+		elsif not Is_Cons(Cdr) then
+			-- no <alternate> but reduncant cdr.	
+			-- (if (> 3 2) 3 . 99)
+			Ada.Text_IO.Put_Line ("FUCKING CDR FOR IF");
+			raise Syntax_Error;
+			
+		elsif Get_Cdr(Cdr) /= Nil_Pointer then
+			-- (if (> 3 2) 3 2 . 99) 
+			-- (if (> 3 2) 3 2 99) 
+			Ada.Text_IO.Put_Line ("TOO MANY ARGUMENTS FOR IF");
+			raise Syntax_Error;
+		end if;
+
+		-- Switch the current frame to execute action after <test> evaluation.
+		Set_Frame_Opcode (Interp.Stack, Opcode_Finish_If);
+		Set_Frame_Operand (Interp.Stack, Operand); 
+
+		-- Arrange to evalaute the conditional
+		Push_Frame (Interp, Opcode_Evaluate_Object, Car); 
+
+	end Evaluate_If_Syntax;
+
 	procedure Evaluate_Lambda_Syntax is
 		pragma Inline (Evaluate_Lambda_Syntax);
 	begin
@@ -142,7 +193,6 @@ begin
 							--      (begin . 10)
 							Ada.Text_IO.Put_LINE ("FUCKNING CDR FOR BEGIN");
 							raise Syntax_Error;
-							--Pop_Frame (Interp);  -- Done
 
 						else
 							Set_Frame_Opcode (Interp.Stack, Opcode_Evaluate_Group);
@@ -161,6 +211,9 @@ begin
 					when Define_Syntax =>
 						Evaluate_Define_Syntax;
 
+					when If_Syntax =>
+						Evaluate_If_Syntax;
+
 					when Lambda_Syntax =>
 						Evaluate_Lambda_Syntax;
 

lib/h2-scheme-execute.adb

@@ -45,7 +45,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
 					if Cdr /= Nil_Pointer then
 						-- The last CDR is not Nil.
 						Ada.Text_IO.Put_Line ("$$$$..................FUCKING CDR. FOR GROUP....................$$$$");
-						-- raise Syntax_Error;
+						raise Syntax_Error;
 					end if;
 
 					-- Change the operand to a mark object so that the call to this 
@@ -86,8 +86,8 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
 		Push_Top (Interp, X'Unchecked_Access);
 		Push_Top (Interp, Y'Unchecked_Access);
 
-		X := Get_Frame_Operand(Interp.Stack);
+		X := Get_Frame_Operand(Interp.Stack); -- symbol
-		Y := Get_Car(Get_Frame_Result(Interp.Stack)); 
+		Y := Get_Car(Get_Frame_Result(Interp.Stack));  -- value
 		pragma Assert (Is_Symbol(X));
 		pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
 
@@ -99,6 +99,41 @@ Ada.Text_IO.PUt_Line ("FINISH DEFINE SYMBOL");
 		Pop_Tops (Interp, 2);
 	end Finish_Define_Symbol;
 
+	procedure Finish_If is
+		pragma Inline (Finish_If);
+		X: aliased Object_Pointer;
+		Y: aliased Object_Pointer;
+		Z: aliased Object_Pointer;
+	begin
+Ada.Text_IO.PUt_Line ("FINISH IF");
+
+		Push_Top (Interp, X'Unchecked_Access);
+		Push_Top (Interp, Y'Unchecked_Access);
+
+		X := Get_Frame_Operand(Interp.Stack); -- cons cell containing <consequent>
+		Y := Get_Car(Get_Frame_Result(Interp.Stack)); -- result of conditional
+		pragma Assert (Is_Cons(X)); 
+		pragma Assert (Get_Cdr(Get_Frame_Result(Interp.Stack)) = Nil_Pointer);
+
+		Pop_Frame (Interp);
+		if Y = False_Pointer then
+			-- <test> evaluated to #f.
+			X := Get_Cdr(X); -- cons cell containing <alternate>
+			if Is_Cons(X) then
+				-- evaluate <alternate>
+				Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
+			else
+				-- return nil if no <alternate> is specified
+				Chain_Frame_Result (Interp, Interp.Stack, Nil_Pointer);
+			end if;
+		else
+			-- all values except #f are true values. evaluate <consequent>
+			Push_Frame (Interp, Opcode_Evaluate_Object, Get_Car(X));
+		end if;
+
+		Pop_Tops (Interp, 2);
+	end Finish_If;
+
 	procedure Evaluate is separate;
 	procedure Apply is separate;
 
@@ -449,6 +484,12 @@ Ada.Text_IO.Put_Line ("ERROR: PREMATURE LIST END");
 				V := Make_Symbol(Interp.Self, Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last));
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
+			when True_Token =>
+				Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
+
+			when False_Token =>
+				Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
+
 			when others =>
 				-- TODO: set various error info
 				raise Syntax_Error;
@@ -507,6 +548,14 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 				Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
+			when True_Token =>
+				Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
+				Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
+
+			when False_Token =>
+				Set_Frame_Opcode (Interp.Stack, Opcode_Read_List_End);
+				Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
+
 			when others =>
 				-- TODO: set various error info
 				raise Syntax_Error;
@@ -558,8 +607,7 @@ Ada.Text_IO.Put_Line ("ERROR: CDR QUOT LIST END");
 	begin
 		--Push_Top (Interp, V'Unchecked_Access);
 
--- TODO: use Interp.Quote_Syntax instead of Make_Symbol("quote")
+		Chain_Frame_Result (Interp, Interp.Stack, Interp.Symbol.Quote);
-		Chain_Frame_Result (Interp, Interp.Stack, Make_Symbol(Interp.Self, Label_Quote));
 		V := Get_Frame_Result(Interp.Stack);
 		Pop_Frame (Interp); -- Done with the current frame
 		Chain_Frame_Result (Interp, Interp.Stack, V);
@@ -610,6 +658,15 @@ Ada.Text_IO.Put_Line ("INFO: NO MORE TOKEN ");
 				Pop_Frame (Interp); -- Done with the current frame
 				Chain_Frame_Result (Interp, Interp.Stack, V);
 
+			when True_Token =>	
+				Pop_Frame (Interp); -- Done with the current frame
+				Chain_Frame_Result (Interp, Interp.Stack, True_Pointer);
+
+			when False_Token =>	
+				Pop_Frame (Interp); -- Done with the current frame
+				Chain_Frame_Result (Interp, Interp.Stack, False_Pointer);
+
+
 			when others =>
 				-- TODO: set various error info
 				raise Syntax_Error;
@@ -702,6 +759,9 @@ begin
 			when Opcode_Finish_Define_Symbol =>
 				Finish_Define_Symbol;
 
+			when Opcode_Finish_If =>
+				Finish_If;
+				
 			when Opcode_Apply =>
 				Apply;
 

lib/h2-scheme.adb

@@ -54,6 +54,8 @@ package body H2.Scheme is
 
 	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_Arrow:    constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>"
 	-----------------------------------------------------------------------------
 	-- EXCEPTIONS
 	-----------------------------------------------------------------------------
@@ -78,19 +80,20 @@ package body H2.Scheme is
 
 	subtype Moved_Object_Record is Object_Record (Moved_Object, 0);
 
-	subtype Opcode_Type is Object_Integer range 0 .. 11;
+	subtype Opcode_Type is Object_Integer range 0 .. 12;
 	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_Apply:                constant Opcode_Type := Opcode_Type'(5);
+	Opcode_Finish_If:            constant Opcode_Type := Opcode_Type'(5); 
-	Opcode_Read_Object:          constant Opcode_Type := Opcode_Type'(6);
+	Opcode_Apply:                constant Opcode_Type := Opcode_Type'(6);
-	Opcode_Read_List:            constant Opcode_Type := Opcode_Type'(7);
+	Opcode_Read_Object:          constant Opcode_Type := Opcode_Type'(7);
-	Opcode_Read_List_Cdr:        constant Opcode_Type := Opcode_Type'(8);
+	Opcode_Read_List:            constant Opcode_Type := Opcode_Type'(8);
-	Opcode_Read_List_End:        constant Opcode_Type := Opcode_Type'(9);
+	Opcode_Read_List_Cdr:        constant Opcode_Type := Opcode_Type'(9);
-	Opcode_Close_List:           constant Opcode_Type := Opcode_Type'(10);
+	Opcode_Read_List_End:        constant Opcode_Type := Opcode_Type'(10);
-	Opcode_Close_Quote:          constant Opcode_Type := Opcode_Type'(11);
+	Opcode_Close_List:           constant Opcode_Type := Opcode_Type'(11);
+	Opcode_Close_Quote:          constant Opcode_Type := Opcode_Type'(12);
 
 	-----------------------------------------------------------------------------
 	-- COMMON OBJECTS
@@ -734,6 +737,8 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
 --Print_Object_Pointer (">>> [GC MOVING SYMBOL TABLE]", Interp.Symbol_Table);
 		-- Migrate the symbol table itself
 		Interp.Symbol_Table := Move_One_Object(Interp.Symbol_Table);
+		Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
+		Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
 
 		-- Update temporary object pointers that were pointing to the symbol table
 		if Original_Symbol_Table /= null then
@@ -1580,7 +1585,7 @@ 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); -- "letrc"
 			Dummy := Make_Syntax (Interp.Self, Or_Syntax,     Label_Or); -- "or"
-			Dummy := Make_Syntax (Interp.Self, Quote_Syntax,  Label_Quote); -- "quote"
+			Interp.Symbol.Quote := Make_Syntax (Interp.Self, Quote_Syntax,  Label_Quote); -- "quote"
 			Dummy := Make_Syntax (Interp.Self, Set_Syntax,    Label_Set); -- "set!"
 		end Make_Syntax_Objects;
 
@@ -1598,6 +1603,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
 			Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure,    Label_Setcdr); -- "set-cdr!"
 			Dummy := Make_Procedure (Interp.Self, Subtract_Procedure,  Label_Minus); -- "-"
 		end Make_Procedure_Objects;
+
+		procedure Make_Common_Symbol_Objects is
+		begin
+			Interp.Symbol.Arrow := Make_Symbol (Interp.Self, Label_Arrow);	
+		end Make_Common_Symbol_Objects;
 	begin
 		declare
 			Aliased_Interp: aliased Interpreter_Record;
@@ -1636,6 +1646,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
 		Interp.Environment := Interp.Root_Environment;
 		Make_Syntax_Objects;
 		Make_Procedure_Objects;
+		Make_Common_Symbol_Objects;
 
 	exception
 		when others =>

lib/h2-scheme.ads

@@ -471,6 +471,11 @@ private
 		Data: Top_Array(1 .. 100) := (others => null);
 	end record;
 
+	type Common_Symbol_Record is record
+		Quote: Object_Pointer := Nil_Pointer;
+		Arrow: 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
@@ -488,6 +493,7 @@ private
 		Stack: aliased Object_Pointer := Nil_Pointer;
 		Mark: Object_Pointer := Nil_Pointer;
 
+		Symbol: Common_Symbol_Record;
 		Top: Top_Record; -- temporary object pointers
 
 		Base_Input: aliased IO_Record;