added numeric comparison procedures

lib/h2-scheme-execute-apply.adb

@@ -206,6 +206,90 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
 		Chain_Frame_Result (Interp, Interp.Stack, Integer_To_Pointer(Num));
 	end Apply_Quotient_Procedure;
 
+	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;
+	procedure Apply_Compare_Procedure;
+
+	procedure Apply_Compare_Procedure is
+		-- TODO: support other values
+		Ptr: Object_Pointer := Args;
+		X: Object_Pointer;
+		Y: Object_Pointer;
+		Bool: Object_Pointer := True_Pointer;
+	begin
+		if Is_Cons(Ptr) and then Is_Cons(Get_Cdr(Ptr)) then
+			-- at least 2 actual arguments
+			X := Get_Car(Ptr);
+			
+			Ptr := Get_Cdr(Ptr);
+			while Is_Cons(Ptr) loop
+				Y := Get_Car(Ptr);
+
+				if not Validate(X, Y) then
+					ADA.TEXT_IO.PUT_LINE ("NON INTEGER FOR COMPARISION");
+					raise Evaluation_Error;
+				end if;
+
+				if not Compare(X, Y) then
+					Bool := False_Pointer;
+					exit;
+				end if;
+
+				X := Y;
+				Ptr := Get_Cdr(Ptr);
+			end loop;
+
+			Pop_Frame (Interp); --  Done with the current frame
+			Chain_Frame_Result (Interp, Interp.Stack, Bool);
+		else
+Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
+			raise Syntax_Error;
+		end if;
+	end Apply_Compare_Procedure;
+
+	function Validate_Numeric (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		-- TODO: support BIGNUM, OTHER DATA TYPES
+	begin
+		return Is_Integer(X) and then Is_Integer(Y);
+	end Validate_Numeric;
+
+	function Equal_To (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		-- TODO: support BIGNUM, OTHER DATA TYPES
+	begin
+		return Pointer_To_Integer(X) = Pointer_To_Integer(Y);
+	end Equal_To;
+
+	function Greater_Than (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		-- TODO: support BIGNUM, OTHER DATA TYPES
+	begin
+		return Pointer_To_Integer(X) > Pointer_To_Integer(Y);
+	end Greater_Than;
+
+	function Less_Than (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		-- TODO: support BIGNUM, OTHER DATA TYPES
+	begin
+		return Pointer_To_Integer(X) < Pointer_To_Integer(Y);
+	end Less_Than;
+
+	function Greater_Or_Equal (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		-- TODO: support BIGNUM, OTHER DATA TYPES
+	begin
+		return Pointer_To_Integer(X) >= Pointer_To_Integer(Y);
+	end Greater_Or_Equal;
+
+	function Less_Or_Equal (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
+		-- TODO: support BIGNUM, OTHER DATA TYPES
+	begin
+		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_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_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_Closure is
 		Fbody: aliased Object_Pointer;
 		Formal: aliased Object_Pointer;
@@ -307,7 +391,6 @@ Print (Interp, Operand);
 				when Setcdr_Procedure =>
 					Apply_Setcdr_Procedure;
 
-
 				when Add_Procedure =>
 					Apply_Add_Procedure;
 				when Subtract_Procedure =>
@@ -319,6 +402,16 @@ Print (Interp, Operand);
 				--when Remainder_Procedure =>
 				--	Apply_Remainder_Procedure;
 
+				when EQ_Procedure =>
+					Apply_EQ_Procedure;
+				when GT_Procedure =>
+					Apply_GT_Procedure;
+				when LT_Procedure =>
+					Apply_LT_Procedure;
+				when GE_Procedure =>
+					Apply_GE_Procedure;
+				when LE_Procedure =>
+					Apply_LE_Procedure;
 				when others =>
 					raise Internal_Error;
 			end case;	

lib/h2-scheme-execute-evaluate.adb

@@ -10,6 +10,8 @@ procedure Evaluate is
 	procedure Evaluate_Define_Syntax is
 		pragma Inline (Evaluate_Define_Syntax);
 	begin
+-- TODO: limit the context where define can be used.
+
 		-- (define x 10) 
 		-- (define (add x y) (+ x y)) -> (define add (lambda (x y) (+ x y)))
 		Operand := Cdr; -- Skip "define"
@@ -114,9 +116,9 @@ Ada.Text_IO.Put_Line ("NO ALTERNATE");
 		end if;
 
 		Car := Get_Car(Operand);  -- <formals>
-		if Is_Symbol(Car) then
+		if Car = Nil_Pointer or else Is_Symbol(Car) then
-			-- (lambda x ...)
+			-- (lambda () ...) or (lambda x ...)
-			-- nothing to do.
+			-- nothing to do	
 			null;
 		elsif Is_Cons(Car) then 
 			declare

lib/h2-scheme.adb

@@ -46,13 +46,18 @@ 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_LT:        constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<"
+	Label_Minus:     constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
+	Label_Multiply:  constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
+	Label_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_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_Plus:      constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+"
-	Label_Minus:     constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-"
-	Label_Multiply:  constant Object_Character_Array := (1 => Ch.Asterisk); -- "*"
 
 
 	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"
@@ -548,25 +553,17 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
 		Original_Symbol_Table: Object_Pointer;
 
 		--function To_Object_Pointer is new Ada.Unchecked_Conversion (Heap_Element_Pointer, Object_Pointer);
-
 		function Move_One_Object (Source: in Object_Pointer) return Object_Pointer is
 		begin
 			pragma Assert (Is_Normal_Pointer(Source));
 
-			--if Is_Special_Pointer(Source)  then
---Print_Object_Pointer ("Moving special ...", Source);
-			--	return Source;
-			--end if;
-
 			if Source.Kind = Moved_Object then
---Print_Object_Pointer ("Moving NOT ...", Source);
 				-- the object has moved to the new heap.
 				-- the size field has been updated to the new object
 				-- in the 'else' block below. i can simply return it
 				-- without further migration.
 				return Get_New_Location (Source);
 			else
---Print_Object_Pointer ("Moving REALLY ...", Source);
 				declare
 					Bytes: Heap_Size;
 
@@ -608,8 +605,6 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
 					-- if the object is marked with FLAG_MOVED;
 					Set_New_Location (Source, Ptr);
 
---Ada.Text_IO.Put_Line (Object_Word'Image(Pointer_To_Word(Source)) & Object_Word'Image(Pointer_To_Word(New_Object)));
---Ada.Text_IO.Put_Line ("  Flags....after " & Object_Kind'Image(Source.Kind) & " New Size " & Object_Size'Image(Source.Size) & " New Loc: " & Object_Word'Image(Pointer_To_Word(Source.New_Pointer)));
 					-- Return the new object
 					return New_Object;
 				end;
@@ -728,6 +723,11 @@ ada.text_io.put_line ("HEAP SOURCE IS NIL");
 			end if;
 		end loop;
 
+		-- Migrate some known symbols
+		Interp.Symbol.Arrow := Move_One_Object(Interp.Symbol.Arrow);
+		Interp.Symbol.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote);
+		Interp.Symbol.Quote := Move_One_Object(Interp.Symbol.Quote);
+
 --Ada.Text_IO.Put_Line (">>> [GC SCANNING NEW HEAP]");
 		-- Scan the heap
 		Last_Pos := Scan_New_Heap(Interp.Heap(New_Heap).Space'First);
@@ -742,9 +742,6 @@ 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.Quasiquote := Move_One_Object(Interp.Symbol.Quasiquote);
-		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
@@ -1630,6 +1627,11 @@ Ada.Text_IO.Put_Line ("Make_String...");
 			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, 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, Quotient_Procedure,     Label_Quotient); -- "quotient"
 			Dummy := Make_Procedure (Interp.Self, Remainder_Procedure,    Label_Remainder); -- "remainder"

lib/h2-scheme.ads

@@ -186,12 +186,17 @@ package H2.Scheme is
 	Car_Procedure:          constant Procedure_Code := Procedure_Code'(1);
 	Cdr_Procedure:          constant Procedure_Code := Procedure_Code'(2);
 	Cons_Procedure:         constant Procedure_Code := Procedure_Code'(3);
-	Multiply_Procedure:  constant Procedure_Code := Procedure_Code'(4);
+	EQ_Procedure:           constant Procedure_Code := Procedure_Code'(4);
-	Quotient_Procedure:  constant Procedure_Code := Procedure_Code'(5);
+	GT_Procedure:           constant Procedure_Code := Procedure_Code'(5);
-	Remainder_Procedure: constant Procedure_Code := Procedure_Code'(6);
+	LT_Procedure:           constant Procedure_Code := Procedure_Code'(6);
-	Setcar_Procedure:    constant Procedure_Code := Procedure_Code'(7);
+	GE_Procedure:           constant Procedure_Code := Procedure_Code'(7);
-	Setcdr_Procedure:    constant Procedure_Code := Procedure_Code'(8);
+	LE_Procedure:           constant Procedure_Code := Procedure_Code'(8);
-	Subtract_Procedure:  constant Procedure_Code := Procedure_Code'(9);
+	Multiply_Procedure:     constant Procedure_Code := Procedure_Code'(9);
+	Quotient_Procedure:     constant Procedure_Code := Procedure_Code'(10);
+	Remainder_Procedure:    constant Procedure_Code := Procedure_Code'(11);
+	Setcar_Procedure:       constant Procedure_Code := Procedure_Code'(12);
+	Setcdr_Procedure:       constant Procedure_Code := Procedure_Code'(13);
+	Subtract_Procedure:     constant Procedure_Code := Procedure_Code'(14);
 
 	type Object_Tag is (
 		Unknown_Object,