(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)))))))
\f
(defun char= (character &rest more-characters)
#!+sb-doc
"Return T if all of the arguments are the same character."
+ (declare (dynamic-extent more-characters))
(dolist (c more-characters t)
(declare (type character c))
(unless (eq c character) (return nil))))
(defun char/= (character &rest more-characters)
#!+sb-doc
"Return T if no two of the arguments are the same character."
+ (declare (dynamic-extent more-characters))
(do* ((head character (car list))
(list more-characters (cdr list)))
((null list) t)
(defun char< (character &rest more-characters)
#!+sb-doc
"Return T if the arguments are in strictly increasing alphabetic order."
+ (declare (dynamic-extent more-characters))
(do* ((c character (car list))
(list more-characters (cdr list)))
((null list) t)
(defun char> (character &rest more-characters)
#!+sb-doc
"Return T if the arguments are in strictly decreasing alphabetic order."
+ (declare (dynamic-extent more-characters))
(do* ((c character (car list))
(list more-characters (cdr list)))
((null list) t)
(defun char<= (character &rest more-characters)
#!+sb-doc
"Return T if the arguments are in strictly non-decreasing alphabetic order."
+ (declare (dynamic-extent more-characters))
(do* ((c character (car list))
(list more-characters (cdr list)))
((null list) t)
(defun char>= (character &rest more-characters)
#!+sb-doc
"Return T if the arguments are in strictly non-increasing alphabetic order."
+ (declare (dynamic-extent more-characters))
(do* ((c character (car list))
(list more-characters (cdr list)))
((null list) t)
(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 (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 (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 (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 (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 (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 (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))))
\f
;;;; miscellaneous functions