added some query procedures

lib/h2-scheme-execute-apply.adb

@@ -197,6 +197,10 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
 		Return_Frame (Interp, Integer_To_Pointer(Num));
 	end Apply_Quotient_Procedure;
 
+	-- -------------------------------------------------------------
+	-- Comparions procedures
+	-- -------------------------------------------------------------
+
 	generic 
 		with function Validate (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean;
 		with function Compare (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean;
@@ -280,6 +284,67 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
 	procedure Apply_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal);
 	procedure Apply_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal);
 
+	-- -------------------------------------------------------------
+	-- Questioning procedures
+	-- -------------------------------------------------------------
+	generic 
+		with function Question (X: in Object_Pointer) return Standard.Boolean;
+	procedure Apply_Question_Procedure;
+
+	procedure Apply_Question_Procedure is
+		Bool: Object_Pointer;
+	begin
+		if Is_Cons(Args) and then not Is_Cons(Get_Cdr(Args)) then
+			-- 1 actual argument
+			if Question(Get_Car(Args)) then
+				Bool := True_Pointer;
+			else
+				Bool := False_Pointer;
+			end if;
+			Return_Frame (Interp, Bool);
+		else
+Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON");
+			raise Syntax_Error;
+		end if;
+	end Apply_Question_Procedure;
+	
+	function Is_Null_Class (X: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Null_Class);
+	begin
+		return X = Nil_Pointer;
+	end Is_Null_Class;
+
+	function Is_Number_Class (X: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Number_Class);
+	begin
+		return Is_Integer(X); -- TODO bignum
+	end Is_Number_Class;
+
+	function Is_Procedure_Class (X: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Procedure_Class);
+	begin
+		return Is_Closure(X) or else Is_Procedure(X) or else Is_Continuation(X);
+	end Is_Procedure_Class;
+
+	function Is_String_Class (X: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_String_Class);
+	begin
+		return Is_String(X);
+	end Is_String_Class;
+
+	function Is_Symbol_Class (X: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_Symbol_Class);
+	begin
+		return Is_Symbol(X);
+	end Is_Symbol_Class;
+
+	procedure Apply_NullQ_Procedure is new Apply_Question_Procedure (Is_Null_Class);
+	procedure Apply_NumberQ_Procedure is new Apply_Question_Procedure (Is_Number_Class);
+	procedure Apply_ProcedureQ_Procedure is new Apply_Question_Procedure (Is_Procedure_Class);
+	procedure Apply_StringQ_Procedure is new Apply_Question_Procedure (Is_String_Class);
+	procedure Apply_SymbolQ_Procedure is new Apply_Question_Procedure (Is_Symbol_Class);
+	
+
 	-- -------------------------------------------------------------
 	-- Closure
 	-- -------------------------------------------------------------
@@ -498,8 +563,10 @@ begin
 					Apply_Multiply_Procedure;
 				when Quotient_Procedure =>
 					Apply_Quotient_Procedure;
-				--when Remainder_Procedure =>
+				when Remainder_Procedure =>
-				--	Apply_Remainder_Procedure;
+					--Apply_Remainder_Procedure;
+					ada.text_io.put_line ("NOT IMPLEMENTED");
+					raise Evaluation_Error;
 
 				when EQ_Procedure =>
 					Apply_EQ_Procedure;
@@ -511,8 +578,21 @@ begin
 					Apply_GE_Procedure;
 				when LE_Procedure =>
 					Apply_LE_Procedure;
-				when others =>
+
-					raise Internal_Error;
+
+				when NullQ_Procedure =>
+					Apply_NullQ_Procedure;	
+				when NumberQ_Procedure =>
+					Apply_NumberQ_Procedure;	
+				when ProcedureQ_Procedure =>
+					Apply_ProcedureQ_Procedure;	
+				when StringQ_Procedure =>
+					Apply_StringQ_Procedure;	
+				when SymbolQ_Procedure =>
+					Apply_SymbolQ_Procedure;	
+
+--				when others =>
+--					raise Internal_Error;
 			end case;	
 
 		when Closure_Object =>

lib/h2-scheme.adb

@@ -49,21 +49,26 @@ package body H2.Scheme is
 	                                                     Ch.LC_C, Ch.LC_U, Ch.LC_R, Ch.LC_R, Ch.LC_E, Ch.LC_N, Ch.LC_T, Ch.Minus_Sign,
 	                                                     Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_T, Ch.LC_I, Ch.LC_N, Ch.LC_U, Ch.LC_A, 
 	                                                     Ch.LC_T, Ch.LC_I, Ch.LC_O, Ch.LC_N);  -- "call-with-current-continuation"
-	Label_Car:       constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car"
+	Label_Car:        constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car"
-	Label_Cdr:       constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr"
+	Label_Cdr:        constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr"
-	Label_Cons:      constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons"
+	Label_Cons:       constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons"
-	Label_EQ:        constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "="
+	Label_EQ:         constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "="
-	Label_GE:        constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">="
+	Label_GE:         constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">="
-	Label_GT:        constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">"
+	Label_GT:         constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">"
-	Label_LE:        constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<="
+	Label_LE:         constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<="
-	Label_LT:        constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
+	Label_LT:         constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
-	Label_Minus:     constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
+	Label_Minus:      constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
-	Label_Multiply:  constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
+	Label_Multiply:   constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
-	Label_Plus:      constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
+	Label_NullQ:      constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?"
-	Label_Quotient:  constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_I, Ch.LC_E, Ch.LC_N, Ch.LC_T); -- "quotient"
+	Label_NumberQ:    constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_M, Ch.LC_B, Ch.LC_E, Ch.LC_R, Ch.Question); -- "number?"
-	Label_Remainder: constant Object_Character_Array := (Ch.LC_R, Ch.LC_E, Ch.LC_M, Ch.LC_A, Ch.LC_I, Ch.LC_N, Ch.LC_D, Ch.LC_E, Ch.LC_R); -- "remainder"
+	Label_Plus:       constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
-	Label_Setcar:    constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_A, Ch.LC_R, Ch.Exclamation); -- "set-car!"
+	Label_ProcedureQ: constant Object_Character_Array := (Ch.LC_P, Ch.LC_R, Ch.LC_O, Ch.LC_C, Ch.LC_E, Ch.LC_D, Ch.LC_U, Ch.LC_R, Ch.LC_E, Ch.Question); -- "procedure?"
-	Label_Setcdr:    constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_D, Ch.LC_R, Ch.Exclamation); -- "set-cdr!"
+	Label_Quotient:   constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_I, Ch.LC_E, Ch.LC_N, Ch.LC_T); -- "quotient"
+	Label_Remainder:  constant Object_Character_Array := (Ch.LC_R, Ch.LC_E, Ch.LC_M, Ch.LC_A, Ch.LC_I, Ch.LC_N, Ch.LC_D, Ch.LC_E, Ch.LC_R); -- "remainder"
+	Label_Setcar:     constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_A, Ch.LC_R, Ch.Exclamation); -- "set-car!"
+	Label_Setcdr:     constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_D, Ch.LC_R, Ch.Exclamation); -- "set-cdr!"
+	Label_StringQ:    constant Object_Character_Array := (Ch.LC_S, Ch.LC_T, Ch.LC_R, Ch.LC_I, Ch.LC_N, Ch.LC_G, Ch.Question); -- "string?"
+	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"
@@ -381,6 +386,19 @@ package body H2.Scheme is
 		 return Integer_To_Pointer(Opcode_Type'Pos(Opcode));
 	end Opcode_To_Pointer;
 
+	function Pointer_To_Procedure_Code (Pointer: in Object_Pointer) return Procedure_Code is
+		pragma Inline (Pointer_To_Procedure_Code);
+	begin
+		return Procedure_Code'Val(Pointer_To_Integer(Pointer));
+	end Pointer_To_Procedure_Code;
+
+	function Procedure_Code_To_Pointer (Opcode: in Procedure_Code) return Object_Pointer is
+		pragma Inline (Procedure_Code_To_Pointer);
+	begin
+		 return Integer_To_Pointer(Procedure_Code'Pos(Opcode));
+	end Procedure_Code_To_Pointer;
+
+
 	function Token_To_Pointer (Interp: access Interpreter_Record; 
 	                           Token:  in     Token_Record) return Object_Pointer is
 	begin
@@ -1094,12 +1112,19 @@ end if;
 	end Reverse_Cons;
 	-----------------------------------------------------------------------------
 
+	function Is_String (Source: in Object_Pointer) return Standard.Boolean is
+		pragma Inline (Is_String);
+	begin
+		return Is_Normal_Pointer(Source) and then 
+		       Source.Tag = String_Object;
+	end Is_String;
+
 	function Make_String (Interp: access  Interpreter_Record;
 	                      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 := Allocate_Character_Object(Interp, Source);
 		Result.Tag := String_Object;
 --Print_Object_Pointer ("Make_String Result - " & Source, Result);
 		return Result;
@@ -1108,7 +1133,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
 	function Is_Symbol (Source: in Object_Pointer) return Standard.Boolean is
 		pragma Inline (Is_Symbol);
 	begin
-		return Is_Normal_Pointer (Source) and then 
+		return Is_Normal_Pointer(Source) and then 
 		       Source.Tag = Symbol_Object;
 	end Is_Symbol;
 
@@ -1538,7 +1563,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
 	end Is_Syntax;
 
 	function Make_Procedure (Interp: access Interpreter_Record;
-	                         Opcode: in     Procedure_Code;
+	                         Code:   in     Procedure_Code;
 	                         Name:   in     Object_Character_Array) return Object_Pointer is
 		-- this procedure is for internal use only
 		Symbol: aliased Object_Pointer;
@@ -1553,7 +1578,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
 		-- Make the actual procedure object
 		Proc := Allocate_Pointer_Object(Interp, Procedure_Object_Size, Nil_Pointer);
 		Proc.Tag := Procedure_Object;
-		Proc.Pointer_Slot(Procedure_Opcode_Index) := Integer_To_Pointer(Opcode);
+		Proc.Pointer_Slot(Procedure_Opcode_Index) := Procedure_Code_To_Pointer(Code);
 
 		-- Link it to the top environement
 		pragma Assert (Get_Frame_Environment(Interp.Stack) = Interp.Root_Environment); 
@@ -1576,7 +1601,7 @@ Ada.Text_IO.Put_Line ("Make_String...");
 		pragma Assert (Is_Procedure(Proc));
 		pragma Assert (Proc.Size = Procedure_Object_Size);
 	begin
-		return Pointer_To_Integer(Proc.Pointer_Slot(Procedure_Opcode_Index));
+		return Pointer_To_Procedure_Code(Proc.Pointer_Slot(Procedure_Opcode_Index));
 	end Get_Procedure_Opcode;
 	
 	-----------------------------------------------------------------------------
@@ -1796,10 +1821,15 @@ Ada.Text_IO.Put_Line ("Make_String...");
 			Dummy := Make_Procedure (Interp.Self, LE_Procedure,           Label_LE); -- "<="
 			Dummy := Make_Procedure (Interp.Self, LT_Procedure,           Label_LT); -- "<"
 			Dummy := Make_Procedure (Interp.Self, Multiply_Procedure,     Label_Multiply); -- "*"
+			Dummy := Make_Procedure (Interp.Self, NumberQ_Procedure,      Label_NumberQ); -- "number?"
+			Dummy := Make_Procedure (Interp.Self, NullQ_Procedure,        Label_NullQ); -- "null?"
 			Dummy := Make_Procedure (Interp.Self, Quotient_Procedure,     Label_Quotient); -- "quotient"
 			Dummy := Make_Procedure (Interp.Self, Remainder_Procedure,    Label_Remainder); -- "remainder"
 			Dummy := Make_Procedure (Interp.Self, Setcar_Procedure,       Label_Setcar); -- "set-car!"
 			Dummy := Make_Procedure (Interp.Self, Setcdr_Procedure,       Label_Setcdr); -- "set-cdr!"
+			Dummy := Make_Procedure (Interp.Self, ProcedureQ_Procedure,   Label_ProcedureQ); -- "procedure?"
+			Dummy := Make_Procedure (Interp.Self, StringQ_Procedure,      Label_StringQ); -- "string?"
+			Dummy := Make_Procedure (Interp.Self, SymbolQ_Procedure,      Label_SymbolQ); -- "symbol?"
 			Dummy := Make_Procedure (Interp.Self, Subtract_Procedure,     Label_Minus); -- "-"
 		end Make_Procedure_Objects;
 

lib/h2-scheme.ads

@@ -181,23 +181,32 @@ package H2.Scheme is
 	Quote_Syntax:      constant Syntax_Code := Syntax_Code'(13);
 	Set_Syntax:        constant Syntax_Code := Syntax_Code'(14);
 
-	subtype Procedure_Code is Object_Integer;
+	--subtype Procedure_Code is Object_Integer;
-	Add_Procedure:          constant Procedure_Code := Procedure_Code'(0);
+	type Procedure_Code is (
-	Callcc_Procedure:       constant Procedure_Code := Procedure_Code'(1);
+		Add_Procedure,
-	Car_Procedure:          constant Procedure_Code := Procedure_Code'(2);
+		Callcc_Procedure,
-	Cdr_Procedure:          constant Procedure_Code := Procedure_Code'(3);
+		Car_Procedure,
-	Cons_Procedure:         constant Procedure_Code := Procedure_Code'(4);
+		Cdr_Procedure,
-	EQ_Procedure:           constant Procedure_Code := Procedure_Code'(5);
+		Cons_Procedure,
-	GT_Procedure:           constant Procedure_Code := Procedure_Code'(6);
+		EQ_Procedure,
-	LT_Procedure:           constant Procedure_Code := Procedure_Code'(7);
+		GT_Procedure,
-	GE_Procedure:           constant Procedure_Code := Procedure_Code'(8);
+		LT_Procedure,
-	LE_Procedure:           constant Procedure_Code := Procedure_Code'(9);
+		GE_Procedure,
-	Multiply_Procedure:     constant Procedure_Code := Procedure_Code'(10);
+		LE_Procedure,
-	Quotient_Procedure:     constant Procedure_Code := Procedure_Code'(11);
+		Multiply_Procedure,
-	Remainder_Procedure:    constant Procedure_Code := Procedure_Code'(12);
+		NullQ_Procedure,
-	Setcar_Procedure:       constant Procedure_Code := Procedure_Code'(13);
+		NumberQ_Procedure,
-	Setcdr_Procedure:       constant Procedure_Code := Procedure_Code'(14);
+		ProcedureQ_Procedure,
-	Subtract_Procedure:     constant Procedure_Code := Procedure_Code'(15);
+		Quotient_Procedure,
+		Remainder_Procedure,
+		Setcar_Procedure,
+		Setcdr_Procedure,
+		StringQ_Procedure,
+		Subtract_Procedure,
+		SymbolQ_Procedure
+	);
+	for Procedure_Code'Size use Object_Integer'Size;
+	
 
 	type Object_Tag is (
 		Unknown_Object,