~ chicken-core (chicken-5) 4d923a24c807c2a28a8f7569dbf4d77e5ec9c8f4

commit 4d923a24c807c2a28a8f7569dbf4d77e5ec9c8f4
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Nov 19 06:04:33 2010 -0500
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Nov 19 06:04:33 2010 -0500

    added equal=?

diff --git a/chicken.h b/chicken.h
index eb271468..0167fd16 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1041,6 +1041,7 @@ extern double trunc(double);
 #define C_specialp(x)             C_mk_bool(C_header_bits(x) & C_SPECIALBLOCK_BIT)
 #define C_byteblockp(x)           C_mk_bool(C_header_bits(x) & C_BYTEBLOCK_BIT)
 #define C_anyp(x)                 C_SCHEME_TRUE
+#define C_sametypep(x, y)         C_mk_bool(C_header_bits(x) == C_header_bits(y))
 #define C_eqp(x, y)               C_mk_bool((x) == (y))
 #define C_vemptyp(x)              C_mk_bool(C_header_size(x) == 0)
 #define C_notvemptyp(x)           C_mk_bool(C_header_size(x) > 0)
diff --git a/library.scm b/library.scm
index 764c6fc0..85aa1a50 100644
--- a/library.scm
+++ b/library.scm
@@ -1071,6 +1071,44 @@ EOF
       (##core#inline "C_set_print_precision" prec) )
     prev ) )
 
+(define (equal=? x y)
+  (define (compare-slots x y start)
+    (let ((l1 (##sys#size x))
+	  (l2 (##sys#size y)))
+      (and (eq? l1 l2)
+	   (or (fx<= l1 start)
+	       (let ((l1n (fx- l1 1)))
+		 (let loop ((i start))
+		   (if (fx= i l1n)
+		       (walk (##sys#slot x i) (##sys#slot y i)) ; tailcall
+		       (and (walk (##sys#slot x i) (##sys#slot y i))
+			    (loop (fx+ i 1))))))))))
+  (define (walk x y)
+    (cond ((eq? x y))
+	  ((fixnum? x) 
+	   (if (flonum? y)
+	       (= x y)
+	       (eq? x y)))
+	  ((flonum? x)
+	   (and (or (fixnum? y) (flonum? y))
+		(= x y)))
+	  ((not (##core#inline "C_blockp" x)) #f)
+	  ((not (##core#inline "C_blockp" y)) #f)
+	  ((not (##core#inline "C_sametypep" x y)) #f)
+	  ((##core#inline "C_specialp" x)
+	   (and (##core#inline "C_specialp" y)
+		(compare-slots x y 1)))
+	  ((##core#inline "C_byteblockp" x)
+	   (and (##core#inline "C_byteblockp" y)
+		(let ((s1 (##sys#size x)))
+		  (and (eq? s1 (##sys#size y))
+		       (##core#inline "C_substring_compare" x y 0 0 s1)))))
+	  (else
+	   (let ((s1 (##sys#size x)))
+	     (and (eq? s1 (##sys#size y))
+		  (compare-slots x y 0))))))
+  (walk x y))
+
 
 ;;; Symbols:
 
diff --git a/manual/Unit library b/manual/Unit library
index dabf11cc..e807986d 100644
--- a/manual/Unit library	
+++ b/manual/Unit library	
@@ -3,9 +3,13 @@
 
 == Unit library
 
-This unit contains basic Scheme definitions. This unit is used by default,
+This unit contains basic library definitions. This unit is used by default,
 unless the program is compiled with the {{-explicit-use}} option.
 
+In addition to standard Scheme functions, this unit provides quite 
+a number of additional operations.
+
+
 === Arithmetic
 
 
@@ -568,6 +572,8 @@ On a UNIX system, that value is the raw return value of waitpid(2), which contai
 #t
 42
 </enscript>
+
+
 === Execution time
 
 
@@ -690,13 +696,6 @@ Displays a warning message (if warnings are enabled with {{enable-warnings}}) an
 continues execution.
 
 
-==== singlestep
-
-<procedure>(singlestep THUNK)</procedure>
-
-Executes the code in the zero-procedure {{THUNK}} in single-stepping mode.
-
-
 
 === Garbage collection
 
@@ -749,7 +748,7 @@ switches statistics off.
 
 
 
-=== Other control structures
+=== Other predicates and comparison operations
 
 
 
@@ -761,6 +760,15 @@ Returns {{#t}} if {{X}} is a promise returned by {{delay}}, or
 {{#f}} otherwise.
 
 
+==== equal=?
+
+<procedure>(equal=? X y)</procedure>
+
+Similar to the standard parocedure {{equal?}}, but compares numbers
+using the {{=}} operator, so {{equal=?}} allows structural comparison
+in combination with comparison of numerical data by value.
+
+
 
 === String utilities
 
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index a41dc61f..01974bac 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -170,3 +170,20 @@
 (assert (= 12 (bar 3)))
 (assert (= 100 (set! (bar) 1)))
 (assert (= 12 (foo 3)))
+
+
+;;; equal=?
+
+(assert (not (equal=? 1 2)))
+(assert (equal=? 1 1))
+(assert (equal=? 1 1.0))
+(assert (not (equal=? 1 1.2)))
+(assert (equal=? 1.0 1))
+(assert (equal=? '#(1) '#(1.0)))
+(assert (not (equal=? 'a "a")))
+(assert (equal=? "abc" "abc"))
+(assert (equal=? '(1 2.0 3) '(1 2 3)))
+(assert (equal=? '#(1 2.0 3) '#(1 2 3)))
+(assert (equal=? '#(1 2 (3)) '#(1 2 (3))))
+(assert (not (equal=? '#(1 2 (4)) '#(1 2 (3)))))
+(assert (not (equal=? 123 '(123))))