From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 19 Feb 2017 01:52:10 +0000 (-0800)
Subject: Implement multiple args for char comparisons.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~69
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=172077e1ecb1670c46ded7f4ac66918968c5ae63;p=mit-scheme.git

Implement multiple args for char comparisons.
---

diff --git a/src/runtime/char.scm b/src/runtime/char.scm
index 004382924..b75fa47f4 100644
--- 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)))
-
+
 (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)))
+
+(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 7ec3a112b..bf8fe441b 100644
--- 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))