implemented 'case'

lib/h2-scheme-execute-apply.adb

@@ -106,6 +106,7 @@ Ada.Text_IO.Put_Line ("EXPECTED CONS-CELL FOR Setcdr");
 		Return_Frame (Interp, A);
 	end Apply_Setcdr_Procedure;
 
+
 	-- -------------------------------------------------------------
 	-- Arithmetic procedures
 	-- -------------------------------------------------------------
@@ -278,11 +279,11 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
 		return Pointer_To_Integer(X) <= Pointer_To_Integer(Y);
 	end Less_Or_Equal;
 
-	procedure Apply_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To);
+	procedure Apply_N_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To);
-	procedure Apply_GT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Than);
+	procedure Apply_N_GT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Than);
-	procedure Apply_LT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Than);
+	procedure Apply_N_LT_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Than);
-	procedure Apply_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal);
+	procedure Apply_N_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);
+	procedure Apply_N_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal);
 
 	-- -------------------------------------------------------------
 	-- Questioning procedures
@@ -338,13 +339,29 @@ Ada.Text_IO.Put_line ("WRONG NUMBER OF ARGUMETNS FOR COMPARISON");
 		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);
-	
 
+	procedure Apply_Q_Null_Procedure is new Apply_Question_Procedure (Is_Null_Class);
+	procedure Apply_Q_Number_Procedure is new Apply_Question_Procedure (Is_Number_Class);
+	procedure Apply_Q_Procedure_Procedure is new Apply_Question_Procedure (Is_Procedure_Class);
+	procedure Apply_Q_String_Procedure is new Apply_Question_Procedure (Is_String_Class);
+	procedure Apply_Q_Symbol_Procedure is new Apply_Question_Procedure (Is_Symbol_Class);
+
+	procedure Apply_Q_Eq_Procedure is
+	begin
+		null;
+	end Apply_Q_Eq_Procedure;
+	
+	procedure Apply_Q_Eqv_Procedure is
+	begin
+		null;
+	end Apply_Q_Eqv_Procedure;
+	
+	
+	procedure Apply_Not_Procedure is
+	begin
+		null;
+	end Apply_Not_Procedure;
+	
 	-- -------------------------------------------------------------
 	-- Closure
 	-- -------------------------------------------------------------
@@ -555,44 +572,50 @@ begin
 				when Setcdr_Procedure =>
 					Apply_Setcdr_Procedure;
 
-				when Add_Procedure =>
+				when N_Add_Procedure =>
 					Apply_Add_Procedure;
-				when Subtract_Procedure =>
+				when N_Subtract_Procedure =>
 					Apply_Subtract_Procedure;
-				when Multiply_Procedure =>
+				when N_Multiply_Procedure =>
 					Apply_Multiply_Procedure;
-				when Quotient_Procedure =>
+				when N_Quotient_Procedure =>
 					Apply_Quotient_Procedure;
-				when Remainder_Procedure =>
+				when N_Remainder_Procedure =>
 					--Apply_Remainder_Procedure;
 					ada.text_io.put_line ("NOT IMPLEMENTED");
 					raise Evaluation_Error;
 
-				when EQ_Procedure =>
+				when N_EQ_Procedure =>
-					Apply_EQ_Procedure;
+					Apply_N_EQ_Procedure;
-				when GT_Procedure =>
+				when N_GT_Procedure =>
-					Apply_GT_Procedure;
+					Apply_N_GT_Procedure;
-				when LT_Procedure =>
+				when N_LT_Procedure =>
-					Apply_LT_Procedure;
+					Apply_N_LT_Procedure;
-				when GE_Procedure =>
+				when N_GE_Procedure =>
-					Apply_GE_Procedure;
+					Apply_N_GE_Procedure;
-				when LE_Procedure =>
+				when N_LE_Procedure =>
-					Apply_LE_Procedure;
+					Apply_N_LE_Procedure;
 
 
-				when NullQ_Procedure =>
+				when Q_Eq_Procedure =>
-					Apply_NullQ_Procedure;	
+					Apply_Q_Eq_Procedure;
-				when NumberQ_Procedure =>
+				when Q_Eqv_Procedure =>
-					Apply_NumberQ_Procedure;	
+					Apply_Q_Eqv_Procedure;
-				when ProcedureQ_Procedure =>
+				when Q_Null_Procedure =>
-					Apply_ProcedureQ_Procedure;	
+					Apply_Q_Null_Procedure;	
-				when StringQ_Procedure =>
+				when Q_Number_Procedure =>
-					Apply_StringQ_Procedure;	
+					Apply_Q_Number_Procedure;	
-				when SymbolQ_Procedure =>
+				when Q_Procedure_Procedure =>
-					Apply_SymbolQ_Procedure;	
+					Apply_Q_Procedure_Procedure;	
+				when Q_String_Procedure =>
+					Apply_Q_String_Procedure;	
+				when Q_Symbol_Procedure =>
+					Apply_Q_Symbol_Procedure;	
+
+
+				when Not_Procedure =>
+					Apply_Not_Procedure;
 
---				when others =>
---					raise Internal_Error;
 			end case;	
 
 		when Closure_Object =>

lib/h2-scheme-execute-evaluate.adb

@@ -109,7 +109,7 @@ procedure Evaluate is
 				raise Syntax_Error;
 			end if;
 
-			--Key := Get_Car(Operand);
+			--Key := Get_Car(Operand); -- <key>
 
 			Ptr1 := Get_Cdr(Operand); -- <clause> list.
 			while Is_Cons(Ptr1) loop
@@ -119,7 +119,7 @@ procedure Evaluate is
 					raise Syntax_Error;
 				end if;
 				
-				Ptr3 := Get_Car(Ptr2); -- <datum>
+				Ptr3 := Get_Car(Ptr2); -- <datum> list or 'else'
 				if Is_Cons(Ptr3) then
 					if Get_Last_Cdr(Ptr3) /= Nil_Pointer then
 						Ada.Text_IO.Put_LINE ("FUCKING CDR FOR CASE DATUM");
@@ -135,6 +135,11 @@ procedure Evaluate is
 					Ada.Text_IO.Put_LINE ("INVALID DATUM FOR CASE");
 					raise Syntax_Error;
 				end if;
+				
+				if Get_Cdr(Ptr2) = Nil_Pointer then
+					Ada.Text_IO.Put_Line ("NO EXPRESSION IN CASE CLAUSE");
+					raise Syntax_Error;
+				end if;
 
 				Ptr1 := Get_Cdr(Ptr1); -- next <clause> list
 			end loop;
@@ -146,9 +151,9 @@ procedure Evaluate is
 
 			Synlist.Flags := Synlist.Flags or Syntax_Checked;
 		end if;
-		
+
-		Ada.Text_IO.Put_LINE ("UNIMPLEMENTED");
+		Switch_Frame (Interp.Stack, Opcode_Evaluate_Object, Get_Car(Operand), Nil_Pointer); -- <key>
-		raise Evaluation_Error;
+		Push_Subframe (Interp, Opcode_Case_Finish, Get_Cdr(Operand)); -- <clause> list
 	end Evaluate_Case_Syntax;
 
      -- ----------------------------------------------------------------

lib/h2-scheme-execute.adb

@@ -66,6 +66,41 @@ procedure Execute (Interp: in out Interpreter_Record) is
 	procedure Do_And_Finish is new Evaluate_While(Is_True_Class);
 	procedure Do_Or_Finish is new Evaluate_While(Is_False_Class);
 
+	-- ----------------------------------------------------------------
+	procedure Do_Case_Finish is
+		pragma Inline (Do_Case_Finish);
+		
+		R: Object_Pointer;
+		O: Object_Pointer;
+		C: Object_Pointer;
+		D: Object_Pointer;
+	begin
+		R := Get_Frame_Result(Interp.Stack); -- <test> result
+		O := Get_Frame_Operand(Interp.Stack); -- <clause> list
+		
+		while Is_Cons(O) loop
+			C := Get_Car(O); -- <clause>
+			D := Get_Car(C); -- <datum> list
+			if D = Interp.Else_Symbol then
+				Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(C));
+				return;
+			end if;
+
+			while Is_Cons(D) loop
+				if Equal_Values(R, Get_Car(D)) then -- <datum>
+					Reload_Frame (Interp, Opcode_Grouped_Call, Get_Cdr(C));
+					return;
+				end if;
+				D := Get_Cdr(D);
+			end loop;
+
+			O := Get_Cdr(O);
+		end loop;
+
+		-- no match found;
+		Pop_Frame (Interp);
+	end Do_Case_Finish;
+	
 	-- ----------------------------------------------------------------
 	procedure Do_Cond_Finish is
 		pragma Inline (Do_Cond_Finish);
@@ -936,6 +971,9 @@ ada.text_io.put_line (Opcode_Type'Image(Get_Frame_Opcode(Interp.Stack)));
 			when Opcode_And_Finish => 
 				Do_And_Finish;
  
+			when Opcode_Case_Finish =>
+				Do_Case_Finish;
+				
 			when Opcode_Cond_Finish => 
 				Do_Cond_Finish;
 

lib/h2-scheme.adb

@@ -21,6 +21,38 @@ package body H2.Scheme is
 	-- PRIMITIVE DEFINITIONS
 	-----------------------------------------------------------------------------
 
+	type Procedure_Code is (
+		Callcc_Procedure,
+		Car_Procedure,
+		Cdr_Procedure,
+		Cons_Procedure,
+		
+		Not_Procedure,
+		
+		N_EQ_Procedure,
+		N_GT_Procedure,
+		N_LT_Procedure,
+		N_GE_Procedure,
+		N_LE_Procedure,
+		N_Add_Procedure,
+		N_Multiply_Procedure,
+		N_Quotient_Procedure,
+		N_Remainder_Procedure,
+		N_Subtract_Procedure,
+		
+		Q_Eq_Procedure,
+		Q_Eqv_Procedure,
+		Q_Null_Procedure,
+		Q_Number_Procedure,
+		Q_Procedure_Procedure,
+		Q_String_Procedure,
+		Q_Symbol_Procedure,
+		
+		Setcar_Procedure,
+		Setcdr_Procedure
+	);
+	for Procedure_Code'Size use Object_Integer'Size;
+
 	-- I define these constants to word around the limitation of not being
 	-- able to use a string literal when the string type is a generic parameter.
 	-- Why doesn't ada include a formal type support for different character
@@ -52,23 +84,31 @@ package body H2.Scheme is
 	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_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_GE:         constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_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_N_EQ:        constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "="
-	Label_LT:         constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
+	Label_N_GE:        constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">="
-	Label_Minus:      constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
+	Label_N_GT:        constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">"
-	Label_Multiply:   constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
+	Label_N_LE:        constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<="
-	Label_NullQ:      constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?"
+	Label_N_LT:        constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
-	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_N_Minus:     constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
-	Label_Plus:       constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
+	Label_N_Multiply:  constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
-	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_N_Plus:      constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
-	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_N_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_N_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_Q_Eq:        constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.Question); -- "eq?"
-	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_Q_Eqv:       constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.LC_V, Ch.Question); -- "eqv?"
-	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_Q_Null:      constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?"
+	Label_Q_Number:    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_Q_Procedure: 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_Q_String:    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_Q_Symbol:    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_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_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"
@@ -107,6 +147,7 @@ package body H2.Scheme is
 	
 		Opcode_And_Finish,
 		Opcode_Or_Finish,
+		Opcode_Case_Finish,
 		Opcode_Cond_Finish,
 		Opcode_Define_Finish,
 		Opcode_Grouped_Call,  -- (begin ...), closure apply, let body
@@ -431,6 +472,64 @@ package body H2.Scheme is
 		end case;
 	end Token_To_Pointer;
 
+	-----------------------------------------------------------------------------
+	-- COMPARISON
+	-----------------------------------------------------------------------------
+
+	function Equal_Values (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		Ptr_Type: Object_Pointer_Type;
+	begin
+	
+		Ptr_Type := Get_Pointer_Type(X);
+		case Ptr_Type is
+			when Object_Pointer_Type_Integer |
+			     Object_Pointer_Type_Character |
+			     Object_Pointer_Type_Byte =>
+			     
+				if Get_Pointer_Type(Y) = Ptr_Type then
+					return X = Y;
+				else
+					return Standard.False;
+				end if;
+
+			when others =>
+				-- TODO: BIGNUM, OTHER NUMERIC DATA.
+
+				case X.Kind is
+					when Character_Object =>
+						if Y.Kind = X.Kind then
+							return X.Character_Slot = Y.Character_Slot;
+						else
+							return Standard.False;
+						end if;
+
+					when Byte_Object =>
+						if Y.Kind = X.Kind then
+							return X.Byte_Slot = Y.Byte_Slot;
+						else
+							return Standard.False;
+						end if;
+
+					when Word_Object =>
+						if Y.Kind = X.Kind then
+							return X.Word_Slot = Y.Word_Slot;
+						else
+							return Standard.False;
+						end if;
+
+					when Pointer_Object =>
+						return X = Y;
+
+					when Moved_Object =>
+						raise Internal_Error;
+				end case;
+
+				return X = Y;
+		end case;
+
+	end Equal_Values;
+
+
 	-----------------------------------------------------------------------------
 	-- MEMORY MANAGEMENT
 	-----------------------------------------------------------------------------
@@ -438,7 +537,7 @@ package body H2.Scheme is
 -- (define x #())
 -- (define x $())
 -- (define x #( 
---              (#a . 10)  ; a is a synbol
+--              (#a . 10)  ; a is a symbol
 --              (b . 20)   ; b is a variable. resolve b at the eval-time and use it.
 --              ("c" . 30) ; "c" is a string
 --            )
@@ -1812,27 +1911,36 @@ end if;
 		procedure Make_Procedure_Objects is
 			Dummy: Object_Pointer;
 		begin
-			Dummy := Make_Procedure (Interp.Self, Add_Procedure,          Label_Plus); -- "+"
+			
 			Dummy := Make_Procedure (Interp.Self, Callcc_Procedure,       Label_Callcc); -- "call-with-current-continuation"
 			Dummy := Make_Procedure (Interp.Self, Car_Procedure,          Label_Car); -- "car"
 			Dummy := Make_Procedure (Interp.Self, Cdr_Procedure,          Label_Cdr); -- "cdr"
 			Dummy := Make_Procedure (Interp.Self, Cons_Procedure,         Label_Cons); -- "cons"
-			Dummy := Make_Procedure (Interp.Self, EQ_Procedure,           Label_EQ); -- "="
+			
-			Dummy := Make_Procedure (Interp.Self, GE_Procedure,           Label_GE); -- ">="
+
-			Dummy := Make_Procedure (Interp.Self, GT_Procedure,           Label_GT); -- ">"
+			Dummy := Make_Procedure (Interp.Self, N_EQ_Procedure,         Label_N_EQ); -- "="
-			Dummy := Make_Procedure (Interp.Self, LE_Procedure,           Label_LE); -- "<="
+			Dummy := Make_Procedure (Interp.Self, N_GE_Procedure,         Label_N_GE); -- ">="
-			Dummy := Make_Procedure (Interp.Self, LT_Procedure,           Label_LT); -- "<"
+			Dummy := Make_Procedure (Interp.Self, N_GT_Procedure,         Label_N_GT); -- ">"
-			Dummy := Make_Procedure (Interp.Self, Multiply_Procedure,     Label_Multiply); -- "*"
+			Dummy := Make_Procedure (Interp.Self, N_LE_Procedure,         Label_N_LE); -- "<="
-			Dummy := Make_Procedure (Interp.Self, NumberQ_Procedure,      Label_NumberQ); -- "number?"
+			Dummy := Make_Procedure (Interp.Self, N_LT_Procedure,         Label_N_LT); -- "<"
-			Dummy := Make_Procedure (Interp.Self, NullQ_Procedure,        Label_NullQ); -- "null?"
+			Dummy := Make_Procedure (Interp.Self, N_Add_Procedure,        Label_N_Plus); -- "+"
-			Dummy := Make_Procedure (Interp.Self, Quotient_Procedure,     Label_Quotient); -- "quotient"
+			Dummy := Make_Procedure (Interp.Self, N_Multiply_Procedure,   Label_N_Multiply); -- "*"
-			Dummy := Make_Procedure (Interp.Self, Remainder_Procedure,    Label_Remainder); -- "remainder"
+			Dummy := Make_Procedure (Interp.Self, N_Quotient_Procedure,   Label_N_Quotient); -- "quotient"
+			Dummy := Make_Procedure (Interp.Self, N_Remainder_Procedure,  Label_N_Remainder); -- "remainder"
+			Dummy := Make_Procedure (Interp.Self, N_Subtract_Procedure,   Label_N_Minus); -- "-"
+			
+			
+			Dummy := Make_Procedure (Interp.Self, Q_Eq_Procedure,         Label_Q_Eq); -- "eq?"
+			Dummy := Make_Procedure (Interp.Self, Q_Eqv_Procedure,        Label_Q_Eqv); -- "eqv?"
+			Dummy := Make_Procedure (Interp.Self, Q_Null_Procedure,       Label_Q_Null); -- "null?"
+			Dummy := Make_Procedure (Interp.Self, Q_Number_Procedure,     Label_Q_Number); -- "number?"
+			Dummy := Make_Procedure (Interp.Self, Q_Procedure_Procedure,  Label_Q_Procedure); -- "procedure?"
+			Dummy := Make_Procedure (Interp.Self, Q_String_Procedure,     Label_Q_String); -- "string?"
+			Dummy := Make_Procedure (Interp.Self, Q_Symbol_Procedure,     Label_Q_Symbol); -- "symbol?"
+			
 			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;
 
 		procedure Make_Common_Symbol_Objects is

lib/h2-scheme.ads

@@ -183,32 +183,6 @@ package H2.Scheme is
 		Set_Syntax
 	);
 
-	type Procedure_Code is (
-		Add_Procedure,
-		Callcc_Procedure,
-		Car_Procedure,
-		Cdr_Procedure,
-		Cons_Procedure,
-		EQ_Procedure,
-		GT_Procedure,
-		LT_Procedure,
-		GE_Procedure,
-		LE_Procedure,
-		Multiply_Procedure,
-		NullQ_Procedure,
-		NumberQ_Procedure,
-		ProcedureQ_Procedure,
-		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, 
 		Cons_Object,