1 ;;;; character functions
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 ;;; We compile some trivial character operations via inline expansion.
16 (declaim (inline standard-char-p graphic-char-p alpha-char-p
17 upper-case-p lower-case-p both-case-p
19 (declaim (maybe-inline digit-char-p
))
22 `(integer 0 (,sb
!xc
:char-code-limit
)))
24 (defglobal **unicode-character-name-huffman-tree
** ())
26 (declaim (inline pack-3-codepoints
))
27 (defun pack-3-codepoints (first &optional
(second 0) (third 0))
28 (declare (type (unsigned-byte 21) first second third
))
29 (sb!c
::mask-signed-field
63 (logior first
(ash second
21) (ash third
42))))
32 (flet ((coerce-it (array)
33 (!coerce-to-specialized array
'(unsigned-byte 8)))
35 (merge-pathnames (make-pathname
37 '(:relative
:up
:up
"output")
38 :name name
:type type
)
39 sb
!xc
:*compile-file-truename
*))
40 (read-ub8-vector (pathname)
41 (with-open-file (stream pathname
42 :element-type
'(unsigned-byte 8))
43 (let* ((length (file-length stream
))
45 length
:element-type
'(unsigned-byte 8))))
46 (read-sequence array stream
)
48 (init-global (name type
)
51 ,(if (eql type
'hash-table
)
53 `(make-array 0 :element-type
',type
)))
54 (declaim (type ,(if (eql type
'hash-table
)
56 `(simple-array ,type
(*))) ,name
)))))
57 (let ((misc-database (coerce-it (read-ub8-vector (file "ucdmisc" "dat"))))
58 (ucd-high-pages (coerce-it (read-ub8-vector (file "ucdhigh" "dat"))))
59 (ucd-low-pages (coerce-it (read-ub8-vector (file "ucdlow" "dat"))))
60 (decompositions (coerce-it (read-ub8-vector (file "decomp" "dat"))))
61 (primary-compositions (coerce-it (read-ub8-vector (file "comp" "dat"))))
62 (case-data (coerce-it (read-ub8-vector (file "case" "dat"))))
63 (case-pages (coerce-it (read-ub8-vector (file "casepages" "dat"))))
64 (collations (coerce-it (read-ub8-vector (file "collation" "dat")))))
66 ;; KLUDGE: All temporary values, fixed up in cold-load
67 ,(init-global '**character-misc-database
** '(unsigned-byte 8))
68 ,(init-global '**character-high-pages
** '(unsigned-byte 16))
69 ,(init-global '**character-low-pages
** '(unsigned-byte 16))
70 ,(init-global '**character-decompositions
** '(unsigned-byte 21))
71 ,(init-global '**character-case-pages
** '(unsigned-byte 8))
72 ,(init-global '**character-primary-compositions
** 'hash-table
)
73 ,(init-global '**character-cases
** '(unsigned-byte 32))
74 ,(init-global '**character-unicode-cases
** t
)
75 ,(init-global '**character-collations
** 'hash-table
)
76 ,(init-global '**unicode-char-name-database
** t
)
77 ,(init-global '**unicode-name-char-database
** t
)
78 ,(init-global '**unicode-1-char-name-database
** t
)
79 ,(init-global '**unicode-1-name-char-database
** t
)
81 (defun !character-database-cold-init
()
82 (flet ((make-ubn-vector (raw-bytes n
)
85 (/ (length raw-bytes
) n
)
86 :element-type
(list 'unsigned-byte
(* 8 n
)))))
87 (loop for i from
0 below
(length raw-bytes
) by n
89 (loop for offset from
0 below n do
91 (ash (aref raw-bytes
(+ i offset
))
92 (* 8 (- n offset
1)))))
93 (setf (aref new-array
(/ i n
)) element
))
95 (setf **character-misc-database
**
97 **character-high-pages
**
98 (make-ubn-vector ,ucd-high-pages
2)
99 **character-low-pages
**
100 (make-ubn-vector ,ucd-low-pages
2)
101 **character-case-pages
**
102 ,(coerce-it case-pages
)
103 **character-decompositions
**
104 (make-ubn-vector ,decompositions
3))
106 (setf **character-primary-compositions
**
107 (let ((table (make-hash-table))
108 (info (make-ubn-vector ,primary-compositions
3)))
109 (dotimes (i (/ (length info
) 3))
110 (setf (gethash (dpb (aref info
(* 3 i
)) (byte 21 21)
111 (aref info
(1+ (* 3 i
))))
113 (aref info
(+ (* 3 i
) 2))))
116 (let* ((unicode-table
118 (* 64 (1+ (aref **character-case-pages
**
119 (1- (length **character-case-pages
**)))))))
121 (* 2 (length unicode-table
))
122 :element-type
'(unsigned-byte 32)))
125 (length (length info
)))
126 (labels ((read-codepoint ()
127 (let* ((b1 (aref info index
))
128 (b2 (aref info
(incf index
)))
129 (b3 (aref info
(incf index
))))
132 (dpb b2
(byte 8 8) b3
))))
133 (read-length-tagged ()
134 (let ((len (aref info index
)) ret
)
140 (push (read-codepoint) ret
))
142 (loop until
(>= index length
)
143 for key
= (read-codepoint)
144 for upper
= (read-length-tagged)
145 for lower
= (read-length-tagged)
146 for page
= (aref **character-case-pages
** (ash key -
6))
147 for i
= (+ (ash page
6) (ldb (byte 6 0) key
))
149 (setf (aref unicode-table i
) (cons upper lower
))
150 when
(and (atom upper
)
152 ;; Some characters are only equal under unicode rules,
153 ;; e.g. #\MICRO_SIGN and #\GREEK_CAPITAL_LETTER_MU
155 (both-case-index-p (misc-index (code-char lower
)))
157 (both-case-index-p (misc-index (code-char upper
))))
159 (setf (aref table
(* i
2)) lower
160 (aref table
(1+ (* i
2))) upper
)))
161 (setf **character-unicode-cases
** unicode-table
)
162 (setf **character-cases
** table
))
164 (setf **character-collations
**
165 (let* ((table (make-hash-table))
167 (info (make-ubn-vector ,collations
4))
169 (loop while
(< index len
) do
170 (let* ((entry-head (aref info index
))
171 (cp-length (ldb (byte 4 28) entry-head
))
172 (key-length (ldb (byte 5 23) entry-head
))
175 :element-type
'(unsigned-byte 32)))
177 (assert (and (/= cp-length
0) (/= key-length
0)))
178 (loop repeat cp-length do
179 (push (dpb 0 (byte 10 22) (aref info index
))
182 (setf codepoints
(nreverse codepoints
))
183 (dotimes (i key-length
)
184 (setf (aref key i
) (aref info index
))
187 (apply #'pack-3-codepoints codepoints
)
192 (stream (file "ucd-names" "lisp-expr"))
193 (with-open-file (u1-stream (file "ucd1-names" "lisp-expr"))
194 (flet ((convert-to-double-vector (vector &optional reversed
)
195 (let ((result (make-array (* (length vector
) 2))))
196 (loop for
(code . name
) across vector
201 (setf (aref result i
) code
202 (aref result
(1+ i
)) name
))
204 (let ((names (make-hash-table))
205 (u1-names (make-hash-table)))
207 for code-point
= (read stream nil nil
)
208 for char-name
= (string-upcase (read stream nil nil
))
210 do
(setf (gethash code-point names
) char-name
))
212 for code-point
= (read u1-stream nil nil
)
213 for char-name
= (string-upcase (read u1-stream nil nil
))
215 do
(setf (gethash code-point u1-names
) char-name
))
219 (maphash (lambda (code name
)
220 (declare (ignore code
))
223 (maphash (lambda (code u1-name
)
224 (declare (ignore code
))
229 (make-array (hash-table-count names
)
233 (make-array (hash-table-count u1-names
)
236 (maphash (lambda (code name
)
238 (cons code
(huffman-encode name tree
))
241 (maphash (lambda (code name
)
243 (cons code
(huffman-encode name tree
))
247 (sort (copy-seq code-
>name
) #'< :key
#'cdr
))
249 (sort (copy-seq name-
>code
) #'< :key
#'car
))
251 (sort (copy-seq code-
>u1-name
) #'< :key
#'cdr
))
253 (sort (copy-seq u1-name-
>code
) #'< :key
#'car
))
254 (setf names nil u1-names nil
)
255 `(defun !character-name-database-cold-init
()
256 (setf **unicode-character-name-huffman-tree
** ',tree
257 **unicode-char-name-database
**
258 ',(convert-to-double-vector code-
>name
)
259 **unicode-name-char-database
**
260 ',(convert-to-double-vector name-
>code t
)
261 **unicode-1-char-name-database
**
262 ',(convert-to-double-vector code-
>u1-name
)
263 **unicode-1-name-char-database
**
264 ',(convert-to-double-vector u1-name-
>code t
)))))))))))))
267 #+sb-xc-host
(!character-name-database-cold-init
)
269 (defparameter *base-char-name-alist
*
270 ;; Note: The *** markers here indicate character names which are
271 ;; required by the ANSI specification of #'CHAR-NAME. For the others,
272 ;; we prefer the ASCII standard name.
273 '((#x00
"Nul" "Null" "^@")
280 ;; Don't alias to Bell, another Unicode character has that name.
282 (#x08
"Backspace" "^h" "Bs") ; *** See Note above
283 (#x09
"Tab" "^i" "Ht") ; *** See Note above
284 (#x0A
"Newline" "Linefeed" "^j" "Lf" "Nl") ; *** See Note above
286 (#x0C
"Page" "^l" "Form" "Formfeed" "Ff" "Np") ; *** See Note above
287 (#x0D
"Return" "^m" "Cr") ; *** See Note above
301 (#x1B
"Esc" "Escape" "^[" "Altmode" "Alt")
306 (#x20
"Space" "Sp") ; *** See Note above
307 (#x7f
"Rubout" "Delete" "Del")
310 (#x82
"Break-Permitted")
311 (#x83
"No-Break-Permitted")
314 (#x86
"Start-Selected-Area")
315 (#x87
"End-Selected-Area")
316 (#x88
"Character-Tabulation-Set")
317 (#x89
"Character-Tabulation-With-Justification")
318 (#x8A
"Line-Tabulation-Set")
319 (#x8B
"Partial-Line-Forward")
320 (#x8C
"Partial-Line-Backward")
321 (#x8D
"Reverse-Linefeed")
322 (#x8E
"Single-Shift-Two")
323 (#x8F
"Single-Shift-Three")
324 (#x90
"Device-Control-String")
325 (#x91
"Private-Use-One")
326 (#x92
"Private-Use-Two")
327 (#x93
"Set-Transmit-State")
328 (#x94
"Cancel-Character")
329 (#x95
"Message-Waiting")
330 (#x96
"Start-Guarded-Area")
331 (#x97
"End-Guarded-Area")
332 (#x98
"Start-String")
334 (#x9A
"Single-Character-Introducer")
335 (#x9B
"Control-Sequence-Introducer")
336 (#x9C
"String-Terminator")
337 (#x9D
"Operating-System-Command")
338 (#x9E
"Privacy-Message")
339 (#x9F
"Application-Program-Command"))) ; *** See Note above
341 ;;;; UCD accessor functions
343 ;;; The character database is made of several arrays.
344 ;;; **CHARACTER-MISC-DATABASE** is an array of bytes that encode character
345 ;;; attributes. Each entry in the misc database is +misc-width+ (currently 8)
346 ;;; bytes wide. Within each entry, the bytes represent: general category, BIDI
347 ;;; class, canonical combining class, digit value, decomposition info, other
348 ;;; flags, script, line break class, and age, respectively. Several of the
349 ;;; entries have additional information encoded in them at the bit level. The
350 ;;; digit value field is equal to 128 (has only its high bit set) if characters
351 ;;; with that set of attribute are not digits. Bit 6 is set if that entry
352 ;;; encodes decimal digits, that is, characters that are DIGIT-CHAR-P. The rest
353 ;;; of the value is the digit value of characters with that entry. Decomposition
354 ;;; info contains the length of the decomposition of characters with that entry,
355 ;;; and also sets its high bit if the decompositions are compatibility
356 ;;; decompositions. The other flags byte encodes boolean properties. Bit 7 is
357 ;;; set if the entry's characters are BOTH-CASE-P in the Common Lisp sense. Bit
358 ;;; 6 is set if the entry's characters hav a defined case transformation in
359 ;;; Unicode. Bit 5 is set if the characters have the property BIDI_Mirrored=Y.
360 ;;; Bits 3-0 encode the entry's East Asian Width. Bit 4 is unused. Age stores
361 ;;; the minor version in bits 0-2, and the major version in the remaining 5
364 ;;; To find which entry in **CHARACTER-MISC-DATABASE** encodes a character's
365 ;;; attributes, first index **CHARACTER-HIGH-PAGES** (an array of 16-bit
366 ;;; values) with the high 13 bits of the character's codepoint. If the result
367 ;;; value has its high bit set, the character is in a "compressed page". To
368 ;;; find the misc entry number, simply clear the high bit. If the high bit is
369 ;;; not set, the misc entry number must be looked up in
370 ;;; **CHARACTER-LOW-PAGES**, which is an array of 16-bit values. Each entry in
371 ;;; the array consists of two such values, the misc entry number and the
372 ;;; decomposition index. To find the misc entry number, index into
373 ;;; **CHARACTER-LOW-PAGES** using the value retreived from
374 ;;; **CHARACTER-HIGH-PAGES** (shifted left 8 bits) plus the low 8 bits of the
375 ;;; codepoint, all times two to account for the widtth of the entries. The
376 ;;; value in **CHARACTER-LOW-PAGES** at this point is the misc entry number. To
377 ;;; transform a misc entry number into an index into
378 ;;; **CHARACTER-MISC-DATABASE**, multiply it by +misc-width*. This gives the
379 ;;; index of the start of the charater's misc entry in
380 ;;; **CHARACTER-MISC-DATABASE**.
382 ;;; To look up a character's decomposition, first retreive its
383 ;;; decomposition-info from the misc database as described above. If the
384 ;;; decomposition info is not 0, the character has a decomposition with a
385 ;;; length given by the decomposition info with the high bit (which indicates
386 ;;; compatibility/canonical status) cleared. To find the decomposition, move
387 ;;; one value past the character's misc entry number in
388 ;;; **CHARACTER-LOW-DATABASE**, which gives an index into
389 ;;; **CHARACTER-DECOMPOSITIONS**. The next LENGTH values in
390 ;;; **CHARACTER-DECOMPOSITIONS** (an array of codepoints), starting at this
391 ;;; index, are the decomposition of the character. This proceduce does not
392 ;;; apply to Hangul syllables, which have their own decomposition algorithm.
394 ;;; Case information is stored in **CHARACTER-UNICODE-CASES**, an array that
395 ;;; indirectly maps a character's codepoint to (cons uppercase
396 ;;; lowercase). Uppercase and lowercase are either a single codepoint,
397 ;;; which is the upper- or lower-case of the given character, or a
398 ;;; list of codepoints which taken as a whole are the upper- or
399 ;;; lower-case. These case lists are only used in Unicode case
400 ;;; transformations, not in Common Lisp ones.
402 ;;; **CHARACTER-CASES** is similar to the above but it stores codes in
403 ;;; a flat array twice as large, and it includes only the standard casing rules,
404 ;;; so there's always just two characters.
406 ;;; Similarly, composition information is stored in **CHARACTER-COMPOSITIONS**,
407 ;;; which is a hash table of codepoints indexed by (+ (ash codepoint1 21)
410 (declaim (inline clear-flag
))
411 (defun clear-flag (bit integer
)
412 (logandc2 integer
(ash 1 bit
)))
414 (defconstant +misc-width
+ 9)
416 (declaim (ftype (sfunction (t) (unsigned-byte 16)) misc-index
))
417 (defun misc-index (char)
418 (let* ((cp (char-code char
))
419 (cp-high (ash cp -
8))
420 (high-index (aref **character-high-pages
** cp-high
)))
421 (if (logbitp 15 high-index
)
422 (* +misc-width
+ (clear-flag 15 high-index
))
424 (aref **character-low-pages
**
425 (* 2 (+ (ldb (byte 8 0) cp
) (ash high-index
8))))))))
427 (declaim (ftype (sfunction (t) (unsigned-byte 8)) ucd-general-category
)
428 (inline ucd-general-category
))
429 (defun ucd-general-category (char)
430 (aref **character-misc-database
** (misc-index char
)))
432 (defun ucd-decimal-digit (char)
433 (let ((digit (aref **character-misc-database
**
434 (+ 3 (misc-index char
)))))
435 (when (logbitp 6 digit
) ; decimalp flag
436 (ldb (byte 4 0) digit
))))
438 (defun char-code (char)
440 "Return the integer code of CHAR."
443 (defun char-int (char)
445 "Return the integer code of CHAR. (In SBCL this is the same as CHAR-CODE, as
446 there are no character bits or fonts.)"
449 (defun code-char (code)
451 "Return the character with the code CODE."
454 (defun character (object)
456 "Coerce OBJECT into a CHARACTER if possible. Legal inputs are characters,
457 strings and symbols of length 1."
458 (flet ((do-error (control args
)
459 (error 'simple-type-error
461 ;;?? how to express "symbol with name of length 1"?
462 :expected-type
'(or character
(string 1))
463 :format-control control
464 :format-arguments args
)))
467 (string (if (= 1 (length (the string object
)))
470 "String is not of length one: ~S" (list object
))))
471 (symbol (if (= 1 (length (symbol-name object
)))
472 (schar (symbol-name object
) 0)
474 "Symbol name is not of length one: ~S" (list object
))))
475 (t (do-error "~S cannot be coerced to a character." (list object
))))))
477 (defun char-name (char)
479 "Return the name (a STRING) for a CHARACTER object."
480 (let ((char-code (char-code char
)))
481 (or (second (assoc char-code
*base-char-name-alist
*))
482 (let ((h-code (double-vector-binary-search char-code
483 **unicode-char-name-database
**)))
486 (huffman-decode h-code
**unicode-character-name-huffman-tree
**))
488 (format nil
"U~X" char-code
)))))))
490 (defun name-char (name)
492 "Given an argument acceptable to STRING, NAME-CHAR returns a character whose
493 name is that string, if one exists. Otherwise, NIL is returned."
494 (let ((char-code (car (rassoc-if (lambda (names)
495 (member name names
:test
#'string-equal
))
496 *base-char-name-alist
*))))
498 (code-char char-code
))
499 ((let ((start (cond ((eql (string-not-equal "U+" name
) 2)
501 ((eql (string-not-equal "U" name
) 1)
504 (loop for i from start
506 always
(digit-char-p (char name i
) 16))
507 (code-char (parse-integer name
:start start
:radix
16)))))
509 (let ((encoding (huffman-encode (string-upcase name
)
510 **unicode-character-name-huffman-tree
**)))
514 (double-vector-binary-search encoding
515 **unicode-name-char-database
**)
516 (double-vector-binary-search encoding
517 **unicode-1-name-char-database
**))))
519 (code-char char-code
)))))))))
523 (defun standard-char-p (char)
525 "The argument must be a character object. STANDARD-CHAR-P returns T if the
526 argument is a standard character -- one of the 95 ASCII printing characters or
528 (and (typep char
'base-char
)
529 (let ((n (char-code (the base-char char
))))
533 (defun %standard-char-p
(thing)
535 "Return T if and only if THING is a standard-char. Differs from
536 STANDARD-CHAR-P in that THING doesn't have to be a character."
537 (and (characterp thing
) (standard-char-p thing
)))
539 (defun graphic-char-p (char)
541 "The argument must be a character object. GRAPHIC-CHAR-P returns T if the
542 argument is a printing character (space through ~ in ASCII), otherwise returns
544 (let ((n (char-code char
)))
548 (defun alpha-char-p (char)
550 "The argument must be a character object. ALPHA-CHAR-P returns T if the
551 argument is an alphabetic character, A-Z or a-z; otherwise NIL."
552 (< (ucd-general-category char
) 5))
554 (declaim (inline both-case-index-p
))
555 (defun both-case-index-p (misc-index)
556 (declare (type (unsigned-byte 16) misc-index
))
557 (logbitp 7 (aref **character-misc-database
** (+ 5 misc-index
))))
559 (defun both-case-p (char)
561 "The argument must be a character object. BOTH-CASE-P returns T if the
562 argument is an alphabetic character and if the character exists in both upper
563 and lower case. For ASCII, this is the same as ALPHA-CHAR-P."
564 (both-case-index-p (misc-index char
)))
566 (defun upper-case-p (char)
568 "The argument must be a character object; UPPER-CASE-P returns T if the
569 argument is an upper-case character, NIL otherwise."
570 (let ((index (misc-index char
)))
572 (both-case-index-p index
)
573 (= (aref **character-misc-database
** index
) 0))))
575 (defun lower-case-p (char)
577 "The argument must be a character object; LOWER-CASE-P returns T if the
578 argument is a lower-case character, NIL otherwise."
579 (let ((index (misc-index char
)))
581 (both-case-index-p index
)
582 (= (aref **character-misc-database
** index
) 1))))
584 (defun digit-char-p (char &optional
(radix 10.
))
586 "If char is a digit in the specified radix, returns the fixnum for which
587 that digit stands, else returns NIL."
588 (if (<= (char-code char
) 127)
589 (let ((weight (- (char-code char
) 48)))
590 (cond ((minusp weight
) nil
)
592 ;; Special-case ASCII digits in decimal and smaller radices.
593 (if (< weight radix
) weight nil
))
594 ;; Digits 0 - 9 are used as is, since radix is larger.
595 ((< weight
10) weight
)
596 ;; Check for upper case A - Z.
597 ((and (>= (decf weight
7) 10) (< weight radix
)) weight
)
598 ;; Also check lower case a - z.
599 ((and (>= (decf weight
32) 10) (< weight radix
)) weight
)))
600 (let ((number (ucd-decimal-digit char
)))
601 (when (and number
(< (truly-the fixnum number
) radix
))
604 ;;; EQUAL-CHAR-CODE is used by the following functions as a version of CHAR-INT
605 ;;; which loses font, bits, and case info.
607 ;;; Return a cons with (upper-case . lower-case), where it either can
608 ;;; be a character code or a list of character codes if the character
609 ;;; donwcases or upcases into multiple characters.
610 (declaim (inline char-case-info
))
611 (defun char-case-info (character)
612 (let* ((code (char-code character
))
613 (page (aref **character-case-pages
** (ash code -
6))))
614 ;; Pages with 255 means the character is not both-case.
615 ;; **character-cases** has 0 for those characters.
616 (aref **character-unicode-cases
**
618 (ldb (byte 6 0) code
)))))
620 ;;; Returns the downcased code or the character code
621 (declaim (inline equal-char-code
))
622 (defun equal-char-code (char)
623 (let* ((code (char-code char
))
624 (shifted (ash code -
6))
625 (page (if (>= shifted
(length **character-case-pages
**))
626 (return-from equal-char-code code
)
627 (aref **character-case-pages
** shifted
))))
631 (aref **character-cases
**
633 (ldb (byte 6 0) code
))
635 (if (zerop down-code
)
639 (defun two-arg-char-equal (c1 c2
)
640 (flet ((base-char-equal-p ()
641 (let* ((code1 (char-code c1
))
642 (code2 (char-code c2
))
643 (sum (logxor code1 code2
)))
645 (let ((sum (+ code1 code2
)))
646 (or (and (< 161 sum
213))
647 (and (< 415 sum
461))
648 (and (< 463 sum
477))))))))
649 (declare (inline base-char-equal-p
))
656 (and (base-char-p c2
)
657 (base-char-equal-p)))
659 (= (equal-char-code c1
) (equal-char-code c2
)))))))
661 (defun char-equal-constant (x char reverse-case-char
)
662 (declare (type character x
) (explicit-check))
664 (eq reverse-case-char x
)))
666 (defun two-arg-char-not-equal (c1 c2
)
667 (/= (equal-char-code c1
) (equal-char-code c2
)))
669 (macrolet ((def (name test doc
)
670 (declare (ignorable doc
))
671 `(defun ,name
(character &rest more-characters
)
674 (do ((c character
(nth i more-characters
))
676 ((>= i
(length more-characters
)) t
)
677 (do-rest-arg ((c2) more-characters i
)
679 (return-from ,name nil
))))
680 ;; CHAR-NOT-EQUAL has explicit check attribute
681 (progn (the character character
) t
)))))
682 (def char
/= (eq c
(the character c2
))
683 "Return T if no two of the arguments are the same character.")
684 (def char-not-equal
(two-arg-char-equal c c2
)
685 "Return T if no two of the arguments are the same character.
688 (defun two-arg-char-lessp (c1 c2
)
689 (< (equal-char-code c1
) (equal-char-code c2
)))
691 (defun two-arg-char-greaterp (c1 c2
)
692 (> (equal-char-code c1
) (equal-char-code c2
)))
694 (defun two-arg-char-not-greaterp (c1 c2
)
695 (<= (equal-char-code c1
) (equal-char-code c2
)))
697 (defun two-arg-char-not-lessp (c1 c2
)
698 (>= (equal-char-code c1
) (equal-char-code c2
)))
700 (macrolet ((def (op test doc
&optional explicit-check
)
701 (declare (ignorable doc
))
702 `(defun ,op
(character &rest more-characters
)
704 ,@(when explicit-check
`((declare (explicit-check))))
705 (let ((c1 character
))
706 (declare (character c1
))
707 (do-rest-arg ((c2 i
) more-characters
0 t
)
710 (return (do-rest-arg ((c) more-characters
(1+ i
))
711 (the character c
))))))))) ; for effect
713 (def char
= (eq c1
(the character c2
))
714 "Return T if all of the arguments are the same character.")
715 (def char
< (< (char-int c1
) (char-int c2
))
716 "Return T if the arguments are in strictly increasing alphabetic order.")
717 (def char
> (> (char-int c1
) (char-int c2
))
718 "Return T if the arguments are in strictly decreasing alphabetic order.")
719 (def char
<= (<= (char-int c1
) (char-int c2
))
720 "Return T if the arguments are in strictly non-decreasing alphabetic order.")
721 (def char
>= (>= (char-int c1
) (char-int c2
))
722 "Return T if the arguments are in strictly non-increasing alphabetic order.")
725 (def char-equal
(two-arg-char-equal c1 c2
)
726 "Return T if all of the arguments are the same character.
728 (def char-lessp
(two-arg-char-lessp c1 c2
)
729 "Return T if the arguments are in strictly increasing alphabetic order.
731 (def char-greaterp
(two-arg-char-greaterp c1 c2
)
732 "Return T if the arguments are in strictly decreasing alphabetic order.
734 (def char-not-greaterp
(two-arg-char-not-greaterp c1 c2
)
735 "Return T if the arguments are in strictly non-decreasing alphabetic order.
737 (def char-not-lessp
(two-arg-char-not-lessp c1 c2
)
738 "Return T if the arguments are in strictly non-increasing alphabetic order.
739 Case is ignored." t
))
742 ;;;; miscellaneous functions
744 (defun char-upcase (char)
746 "Return CHAR converted to upper-case if that is possible. Don't convert
747 lowercase eszet (U+DF)."
748 (let* ((code (char-code char
))
749 (shifted (ash code -
6))
750 (page (if (>= shifted
(length **character-case-pages
**))
751 (return-from char-upcase char
)
752 (aref **character-case-pages
** shifted
))))
756 (aref **character-cases
**
757 (1+ (* (+ (ash page
6)
758 (ldb (byte 6 0) code
))
762 (code-char code
))))))
764 (defun char-downcase (char)
766 "Return CHAR converted to lower-case if that is possible."
767 (let* ((code (char-code char
))
768 (shifted (ash code -
6))
769 (page (if (< shifted
(length **character-case-pages
**))
770 (aref **character-case-pages
** shifted
)
771 (return-from char-downcase char
))))
775 (aref **character-cases
**
777 (ldb (byte 6 0) code
))))))
780 (code-char code
))))))
782 (defun digit-char (weight &optional
(radix 10))
784 "All arguments must be integers. Returns a character object that represents
785 a digit of the given weight in the specified radix. Returns NIL if no such
787 (and (typep weight
'fixnum
)
788 (>= weight
0) (< weight radix
) (< weight
36)
789 (code-char (if (< weight
10) (+ 48 weight
) (+ 55 weight
)))))