X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-char.lisp;h=e4b87c355ccc3eef5ec5f95043883e1ea67fef60;hb=237ec432952f0e7d4a4bcd5f683942a253cac56a;hp=18ea349e0cec8507567c4e469ebfe95111361aac;hpb=8f41e246101ca3906d6c77da51c9de5601777b28;p=sbcl.git

diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp
index 18ea349..e4b87c3 100644
--- a/src/code/target-char.lisp
+++ b/src/code/target-char.lisp
@@ -271,20 +271,21 @@
       (let ((encoding (huffman-encode (string-upcase name)
                                        *unicode-character-name-huffman-tree*)))
         (when encoding
-          (let ((char-code
-                 (car (binary-search encoding
-                                     (cdr *unicode-character-name-database*)
-                                     :key #'cdr)))
-                (name-length (length name)))
+          (let* ((char-code
+                  (car (binary-search encoding
+                                      (cdr *unicode-character-name-database*)
+                                      :key #'cdr)))
+                 (name-string (string name))
+                 (name-length (length name-string)))
             (cond
               (char-code
                (code-char char-code))
               ((and (or (= name-length 9)
                         (= name-length 5))
-                    (char-equal (char name 0) #\U)
+                    (char-equal (char name-string 0) #\U)
                     (loop for i from 1 below name-length
-                          always (digit-char-p (char name i) 16)))
-               (code-char (parse-integer name :start 1 :radix 16)))
+                          always (digit-char-p (char name-string i) 16)))
+               (code-char (parse-integer name-string :start 1 :radix 16)))
               (t
                nil)))))))
 
@@ -371,6 +372,7 @@
 (defun char= (character &rest more-characters)
   #!+sb-doc
   "Return T if all of the arguments are the same character."
+  (declare (truly-dynamic-extent more-characters))
   (dolist (c more-characters t)
     (declare (type character c))
     (unless (eq c character) (return nil))))
@@ -378,6 +380,7 @@
 (defun char/= (character &rest more-characters)
   #!+sb-doc
   "Return T if no two of the arguments are the same character."
+  (declare (truly-dynamic-extent more-characters))
   (do* ((head character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
@@ -389,6 +392,7 @@
 (defun char< (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly increasing alphabetic order."
+  (declare (truly-dynamic-extent more-characters))
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
@@ -399,6 +403,7 @@
 (defun char> (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly decreasing alphabetic order."
+  (declare (truly-dynamic-extent more-characters))
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
@@ -409,6 +414,7 @@
 (defun char<= (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly non-decreasing alphabetic order."
+  (declare (truly-dynamic-extent more-characters))
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
@@ -419,6 +425,7 @@
 (defun char>= (character &rest more-characters)
   #!+sb-doc
   "Return T if the arguments are in strictly non-increasing alphabetic order."
+  (declare (truly-dynamic-extent more-characters))
   (do* ((c character (car list))
         (list more-characters (cdr list)))
        ((null list) t)
@@ -436,72 +443,90 @@
           (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."
+  (declare (truly-dynamic-extent more-characters))
   (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.
    Font, bits, and case are ignored."
+  (declare (truly-dynamic-extent more-characters))
   (do* ((head character (car list))
         (list more-characters (cdr list)))
        ((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.
    Font, bits, and case are ignored."
+  (declare (truly-dynamic-extent more-characters))
   (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.
    Font, bits, and case are ignored."
+  (declare (truly-dynamic-extent more-characters))
   (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.
    Font, bits, and case are ignored."
+  (declare (truly-dynamic-extent more-characters))
   (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.
    Font, bits, and case are ignored."
+  (declare (truly-dynamic-extent more-characters))
   (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