~ chicken-r7rs (master) cdd031c5aa08edb8c453b7f6f5efd4e9e73c32ff

commit cdd031c5aa08edb8c453b7f6f5efd4e9e73c32ff
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Thu Oct 24 22:08:28 2013 +0000
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Thu Oct 24 22:08:28 2013 +0000

    Extended-arity char*? and string*? comparators

diff --git a/scheme.base-interface.scm b/scheme.base-interface.scm
index bed6bbf..823f129 100644
--- a/scheme.base-interface.scm
+++ b/scheme.base-interface.scm
@@ -32,7 +32,9 @@
   ceiling
   char-ready?
   char->integer integer->char
-  char<? char>? char<=? char>=?
+  |#
+  char=? char<? char>? char<=? char>=?
+  #|
   char?
   close-input-port close-output-port
   |#
@@ -181,7 +183,9 @@
   string-length
   string-map
   string-ref string-set!
+  |#
   string=? string<? string>? string<=? string>=?
+  #|
   string?
   substring
   symbol=?
diff --git a/scheme.base.scm b/scheme.base.scm
index eecb4ab..6f78058 100644
--- a/scheme.base.scm
+++ b/scheme.base.scm
@@ -1,6 +1,12 @@
 (module scheme.base ()
 
-(import (except scheme syntax-rules cond-expand member))
+(import (except scheme syntax-rules cond-expand
+                       assoc list-set! list-tail member
+                       char=? char<? char>? char<=? char>=?
+                       string=? string<? string>? string<=? string>=?))
+(import (prefix (only scheme char=? char<? char>? char<=? char>=?
+                             string=? string<? string>? string<=? string>=?)
+                %))
 (import (except chicken with-exception-handler raise quotient remainder modulo))
 (import numbers)
 
@@ -221,6 +227,51 @@
         (##sys#fast-reverse res)
         (lp (cons (car lst) res) (cdr lst)))))
 
+;;;
+;;; 6.6 Characters
+;;;
+
+(define-syntax define-extended-arity-comparator
+  (syntax-rules ()
+    ((_ name comparator check-type)
+     (define name
+       (let ((cmp comparator))
+         (lambda (o1 o2 . os)
+           (check-type o1 'name)
+           (let lp ((o1 o1) (o2 o2) (os os) (eq #t))
+             (check-type o2 'name)
+             (if (null? os)
+                 (and eq (cmp o1 o2))
+                 (lp o2 (car os) (cdr os) (and eq (cmp o1 o2)))))))))))
+
+(: char=? (char char #!rest char -> boolean))
+(: char<? (char char #!rest char -> boolean))
+(: char>? (char char #!rest char -> boolean))
+(: char<=? (char char #!rest char -> boolean))
+(: char>=? (char char #!rest char -> boolean))
+
+(define-extended-arity-comparator char=? %char=? ##sys#check-char)
+(define-extended-arity-comparator char>? %char>? ##sys#check-char)
+(define-extended-arity-comparator char<? %char<? ##sys#check-char)
+(define-extended-arity-comparator char<=? %char<=? ##sys#check-char)
+(define-extended-arity-comparator char>=? %char>=? ##sys#check-char)
+
+;;;
+;;; 6.7 Strings
+;;;
+
+(: string=? (string string #!rest string -> boolean))
+(: string<? (string string #!rest string -> boolean))
+(: string>? (string string #!rest string -> boolean))
+(: string<=? (string string #!rest string -> boolean))
+(: string>=? (string string #!rest string -> boolean))
+
+(define-extended-arity-comparator string=? %string=? ##sys#check-string)
+(define-extended-arity-comparator string<? %string<? ##sys#check-string)
+(define-extended-arity-comparator string>? %string>? ##sys#check-string)
+(define-extended-arity-comparator string<=? %string<=? ##sys#check-string)
+(define-extended-arity-comparator string>=? %string>=? ##sys#check-string)
+
 ;;;
 ;;; 6.11. Exceptions
 ;;;
diff --git a/tests/run.scm b/tests/run.scm
index a111879..412d933 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -299,6 +299,50 @@
    (test '((3 8 2 8)) (list b))
    (test '((1 8 2 8)) (list a))))
 
+(test-group "6.6: characters"
+  (test-group "char*?"
+    (test-error "arity" (char=? #\a))
+    (test-error "type check" (char=? #\a #\a 1))
+    (test-error "no shortcutting" (char=? #\a #\b 1))
+    (test #t (char=? #\a #\a))
+    (test #f (char=? #\a #\b))
+    (test #t (char=? #\a #\a #\a))
+    (test #f (char=? #\a #\b #\a))
+    (test #f (char=? #\a #\a #\b))
+    (test #t (char=? #\a #\a #\a #\a))
+    (test #f (char=? #\a #\b #\a #\a))
+    (test #f (char=? #\a #\a #\a #\b))
+    (test #t (char<? #\a #\b #\c))
+    (test #f (char<? #\a #\b #\b))
+    (test #t (char<=? #\a #\b #\b))
+    (test #f (char<=? #\a #\b #\a))
+    (test #t (char>? #\c #\b #\a))
+    (test #f (char>? #\a #\a #\a))
+    (test #t (char>=? #\b #\b #\a))
+    (test #f (char>=? #\b #\a #\b))))
+
+(test-group "6.7: strings"
+  (test-group "string*?"
+    (test-error "arity" (string=? "a"))
+    (test-error "type check" (string=? "a" "a" 1))
+    (test-error "no shortcutting" (string=? "a" "b" 1))
+    (test #t (string=? "a" "a"))
+    (test #f (string=? "a" "b"))
+    (test #t (string=? "a" "a" "a"))
+    (test #f (string=? "a" "b" "a"))
+    (test #f (string=? "a" "a" "b"))
+    (test #t (string=? "a" "a" "a" "a"))
+    (test #f (string=? "a" "b" "a" "a"))
+    (test #f (string=? "a" "a" "a" "b"))
+    (test #t (string<? "a" "b" "c"))
+    (test #f (string<? "a" "b" "b"))
+    (test #t (string<=? "a" "b" "b"))
+    (test #f (string<=? "a" "b" "a"))
+    (test #t (string>? "c" "b" "a"))
+    (test #f (string>? "c" "b" "b"))
+    (test #t (string>=? "b" "b" "a"))
+    (test #f (string>=? "b" "a" "b"))))
+
 (define-syntax catch
   (syntax-rules ()
     ((_ . body) (handle-exceptions e e . body))))