Implement multiple args for char comparisons.

diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index 00438292420aa0e0ac62fc7a6c6e0af655e5d6a2..b75fa47f4edf95b8371eb2f538d59b68ad453083 100644 (file)
--- a/src/runtime/char.scm
+++ b/src/runtime/char.scm
@@ -74,7 +74,7 @@ USA.
   (guarantee-limited-index-fixnum bits char-bits-limit 'CLEAR-CHAR-BITS)
   (%make-char (char-code char)
              (fix:andc (char-bits char) bits)))
-\f
+
 (define (8-bit-char? object)
   (and (char? object)
        (char-8-bit? object)))
@@ -89,45 +89,65 @@ USA.
 (define-integrable (char-ascii? char)
   (fix:< (char->integer char) #x80))
 
-(define-integrable (char=? x y)
+(define (char=-predicate char)
+  (guarantee char? char 'char=-predicate)
+  (lambda (char*)
+    (char=? char* char)))
+
+(define (char-ci=-predicate char)
+  (guarantee char? char 'char-ci=-predicate)
+  (lambda (char*)
+    (char-ci=? char* char)))
+\f
+(define-integrable (%char=? x y)
   (fix:= (char->integer x) (char->integer y)))
 
-(define-integrable (char<? x y)
+(define-integrable (%char<? x y)
   (fix:< (char->integer x) (char->integer y)))
 
-(define-integrable (char<=? x y)
+(define-integrable (%char<=? x y)
   (fix:<= (char->integer x) (char->integer y)))
 
-(define-integrable (char>? x y)
+(define-integrable (%char>? x y)
   (fix:> (char->integer x) (char->integer y)))
 
-(define-integrable (char>=? x y)
+(define-integrable (%char>=? x y)
   (fix:>= (char->integer x) (char->integer y)))
 
-(define (char-ci=? x y)
-  (char=? (char-foldcase x) (char-foldcase y)))
+(define (%char-ci=? x y)
+  (%char=? (char-foldcase x) (char-foldcase y)))
 
-(define (char-ci<? x y)
-  (char<? (char-foldcase x) (char-foldcase y)))
+(define (%char-ci<? x y)
+  (%char<? (char-foldcase x) (char-foldcase y)))
 
-(define (char-ci<=? x y)
-  (char<=? (char-foldcase x) (char-foldcase y)))
+(define (%char-ci<=? x y)
+  (%char<=? (char-foldcase x) (char-foldcase y)))
 
-(define (char-ci>? x y)
-  (char>? (char-foldcase x) (char-foldcase y)))
+(define (%char-ci>? x y)
+  (%char>? (char-foldcase x) (char-foldcase y)))
 
-(define (char-ci>=? x y)
-  (char>=? (char-foldcase x) (char-foldcase y)))
+(define (%char-ci>=? x y)
+  (%char>=? (char-foldcase x) (char-foldcase y)))
 
-(define (char=-predicate char)
-  (guarantee char? char 'char=-predicate)
-  (lambda (char*)
-    (char=? char* char)))
+(define-integrable (char-comparison-maker %compare)
+  (lambda (char1 char2 . chars)
+    (let loop ((char1 char1) (char2 char2) (chars chars))
+      (if (pair? chars)
+         (and (%compare char1 char2)
+              (loop char2 (car chars) (cdr chars)))
+         (%compare char1 char2)))))
 
-(define (char-ci=-predicate char)
-  (guarantee char? char 'char-ci=-predicate)
-  (lambda (char*)
-    (char-ci=? char* char)))
+(define char=? (char-comparison-maker %char=?))
+(define char<? (char-comparison-maker %char<?))
+(define char<=? (char-comparison-maker %char<=?))
+(define char>? (char-comparison-maker %char>?))
+(define char>=? (char-comparison-maker %char>=?))
+
+(define char-ci=? (char-comparison-maker %char-ci=?))
+(define char-ci<? (char-comparison-maker %char-ci<?))
+(define char-ci<=? (char-comparison-maker %char-ci<=?))
+(define char-ci>? (char-comparison-maker %char-ci>?))
+(define char-ci>=? (char-comparison-maker %char-ci>=?))
 
 (define char-downcase)
 (define char-foldcase)

diff --git a/tests/runtime/test-char.scm b/tests/runtime/test-char.scm
index 7ec3a112b4d4727ac87ac2c16f0eb59cfcd9858b..bf8fe441b08255aed05be73945ce76534b5c8e3d 100644 (file)
--- a/tests/runtime/test-char.scm
+++ b/tests/runtime/test-char.scm
@@ -117,30 +117,30 @@ USA.
           (y #\z)
           (z (integer->char (+ 13 (char->integer w)))))
 
-      ;; (assert-false (char-ci=? x y z))
-      ;; (assert-true  (char-ci=? x x z))
-      ;; (assert-false (char-ci=? w x y))
-      ;; (assert-false (char-ci=? y x w))
-
-      ;; (assert-false (char-ci<? x y z))
-      ;; (assert-false (char-ci<? x x z))
-      ;; (assert-true  (char-ci<? w x y))
-      ;; (assert-false (char-ci<? y x w))
-
-      ;; (assert-false (char-ci>? x y z))
-      ;; (assert-false (char-ci>? x x z))
-      ;; (assert-false (char-ci>? w x y))
-      ;; (assert-true  (char-ci>? y x w))
-
-      ;; (assert-false (char-ci<=? x y z))
-      ;; (assert-true  (char-ci<=? x x z))
-      ;; (assert-true  (char-ci<=? w x y))
-      ;; (assert-false (char-ci<=? y x w))
-
-      ;; (assert-false (char-ci>=? x y z))
-      ;; (assert-true  (char-ci>=? x x z))
-      ;; (assert-false (char-ci>=? w x y))
-      ;; (assert-true  (char-ci>=? y x w))
+      (assert-false (char-ci=? x y z))
+      (assert-true  (char-ci=? x x z))
+      (assert-false (char-ci=? w x y))
+      (assert-false (char-ci=? y x w))
+
+      (assert-false (char-ci<? x y z))
+      (assert-false (char-ci<? x x z))
+      (assert-true  (char-ci<? w x y))
+      (assert-false (char-ci<? y x w))
+
+      (assert-false (char-ci>? x y z))
+      (assert-false (char-ci>? x x z))
+      (assert-false (char-ci>? w x y))
+      (assert-true  (char-ci>? y x w))
+
+      (assert-false (char-ci<=? x y z))
+      (assert-true  (char-ci<=? x x z))
+      (assert-true  (char-ci<=? w x y))
+      (assert-false (char-ci<=? y x w))
+
+      (assert-false (char-ci>=? x y z))
+      (assert-true  (char-ci>=? x x z))
+      (assert-false (char-ci>=? w x y))
+      (assert-true  (char-ci>=? y x w))
 
       (assert-true  (char-ci=? x x))
       (assert-false (char-ci=? w x))