X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-char.lisp;h=ad0f9ee0df697108ee81b981d8a53f08368f94d9;hb=d10b036b1d20e6cff820f72b69af2a06dc362327;hp=7f963b870ece52d75750243e30a98d3f8a6be7f7;hpb=cfc1753e593943c7d0eb8d0621158948917f8304;p=sbcl.git

diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp
index 7f963b8..ad0f9ee 100644
--- a/src/code/target-char.lisp
+++ b/src/code/target-char.lisp
@@ -437,16 +437,21 @@
           (ucd-value-1 ,ch)
           (char-code ,ch)))))
 
+(defun two-arg-char-equal (c1 c2)
+  (= (equal-char-code c1) (equal-char-code c2)))
+
 (defun char-equal (character &rest more-characters)
   #!+sb-doc
   "Return T if all of the arguments are the same character.
   Font, bits, and case are ignored."
   (do ((clist more-characters (cdr clist)))
       ((null clist) t)
-    (unless (= (equal-char-code (car clist))
-               (equal-char-code character))
+    (unless (two-arg-char-equal (car clist) character)
       (return nil))))
 
+(defun two-arg-char-not-equal (c1 c2)
+  (/= (equal-char-code c1) (equal-char-code c2)))
+
 (defun char-not-equal (character &rest more-characters)
   #!+sb-doc
   "Return T if no two of the arguments are the same character.
@@ -456,11 +461,13 @@
        ((null list) t)
     (unless (do* ((l list (cdr l)))
                  ((null l) t)
-              (if (= (equal-char-code head)
-                     (equal-char-code (car l)))
+              (if (two-arg-char-equal head (car l))
                   (return nil)))
       (return nil))))
 
+(defun two-arg-char-lessp (c1 c2)
+  (< (equal-char-code c1) (equal-char-code c2)))
+
 (defun char-lessp (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly increasing alphabetic order.
@@ -468,10 +475,12 @@
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
-    (unless (< (equal-char-code c)
-               (equal-char-code (car list)))
+    (unless (two-arg-char-lessp c (car list))
       (return nil))))
 
+(defun two-arg-char-greaterp (c1 c2)
+  (> (equal-char-code c1) (equal-char-code c2)))
+
 (defun char-greaterp (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly decreasing alphabetic order.
@@ -479,10 +488,12 @@
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
-    (unless (> (equal-char-code c)
-               (equal-char-code (car list)))
+    (unless (two-arg-char-greaterp c (car list))
       (return nil))))
 
+(defun two-arg-char-not-greaterp (c1 c2)
+  (<= (equal-char-code c1) (equal-char-code c2)))
+
 (defun char-not-greaterp (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly non-decreasing alphabetic order.
@@ -490,10 +501,12 @@
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
-    (unless (<= (equal-char-code c)
-                (equal-char-code (car list)))
+    (unless (two-arg-char-not-greaterp c (car list))
       (return nil))))
 
+(defun two-arg-char-not-lessp (c1 c2)
+  (>= (equal-char-code c1) (equal-char-code c2)))
+
 (defun char-not-lessp (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly non-increasing alphabetic order.
@@ -501,8 +514,7 @@
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
-    (unless (>= (equal-char-code c)
-                (equal-char-code (car list)))
+    (unless (two-arg-char-not-lessp c (car list))
       (return nil))))
 
 ;;;; miscellaneous functions