Character comparisons, case sensitive.

diff --git a/src/char.lisp b/src/char.lisp
index f13b516..ede7352 100644 (file)
--- a/src/char.lisp
+++ b/src/char.lisp
@@ -1,3 +1,48 @@
+;; These comparison functions heavily borrowed from SBCL/CMUCL (public domain).
+
+(defun char= (character &rest more-characters)
+  (dolist (c more-characters t)
+    (unless (eql c character) (return nil))))
+
+(defun char/= (character &rest more-characters)
+  (do* ((head character (car list))
+        (list more-characters (cdr list)))
+       ((null list) t)
+       (dolist (c list)
+        (when (eql head c) (return-from char/= nil)))))
+
+(defun char< (character &rest more-characters)
+  (do* ((c character (car list))
+        (list more-characters (cdr list)))
+       ((null list) t)
+       (unless (< (char-int c)
+                 (char-int (car list)))
+        (return nil))))
+
+(defun char> (character &rest more-characters)
+  (do* ((c character (car list))
+        (list more-characters (cdr list)))
+       ((null list) t)
+       (unless (> (char-int c)
+                 (char-int (car list)))
+        (return nil))))
+
+(defun char<= (character &rest more-characters)
+  (do* ((c character (car list))
+        (list more-characters (cdr list)))
+       ((null list) t)
+       (unless (<= (char-int c)
+                  (char-int (car list)))
+        (return nil))))
+
+(defun char>= (character &rest more-characters)
+  (do* ((c character (car list))
+        (list more-characters (cdr list)))
+       ((null list) t)
+       (unless (>= (char-int c)
+                  (char-int (car list)))
+        (return nil))))
+
 (defun character (character)
   (cond ((characterp character)
         character)

diff --git a/tests/characters.lisp b/tests/characters.lisp
index 1528006..9ec833d 100644 (file)
--- a/tests/characters.lisp
+++ b/tests/characters.lisp
@@ -1,5 +1,41 @@
-;; CHAR=
+;; CHAR=, CHAR/=, etc.
 (test (char= (code-char 127744) (code-char 127744)))
+(test (char= #\d #\d))
+(test (not (char= #\A #\a)))
+(test (not (char= #\d #\x)))
+(test (not (char= #\d #\D)))
+(test (not (char/= #\d #\d)))
+(test (char/= #\d #\x))
+(test (char/= #\d #\D))
+(test (char= #\d #\d #\d #\d))
+(test (not (char/= #\d #\d #\d #\d)))
+(test (not (char= #\d #\d #\x #\d)))
+(test (not (char/= #\d #\d #\x #\d)))
+(test (not (char= #\d #\y #\x #\c)))
+(test (char/= #\d #\y #\x #\c))
+(test (not (char= #\d #\c #\d)))
+(test (not (char/= #\d #\c #\d)))
+(test (char< #\d #\x))
+(test (char<= #\d #\x))
+(test (not (char< #\d #\d)))
+(test (char<= #\d #\d))
+(test (char< #\a #\e #\y #\z))
+(test (char<= #\a #\e #\y #\z))
+(test (not (char< #\a #\e #\e #\y)))
+(test (char<= #\a #\e #\e #\y))
+(test (char> #\e #\d))
+(test (char>= #\e #\d))
+(test (char> #\d #\c #\b #\a))
+(test (char>= #\d #\c #\b #\a))
+(test (not (char> #\d #\d #\c #\a)))
+(test (char>= #\d #\d #\c #\a))
+(test (not (char> #\e #\d #\b #\c #\a)))
+(test (not (char>= #\e #\d #\b #\c #\a)))
+;; (char> #\z #\A) =>  implementation-dependent
+;; (char> #\Z #\a) =>  implementation-dependent
+;; (test (char-equal #\A #\a))
+;; (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp) =>  (#\A #\a #\b #\B #\c #\C)
+;; (stable-sort (list #\b #\A #\B #\a #\c #\C) #'char<) => implementation-dependent
 
 ;; TODO: char/=, char<, etc.