tools-for-build/ucd.lisp

   1 (in-package "SB-COLD")
   2
   3 ;;; Common
   4
   5 (defparameter *output-directory*
   6   (merge-pathnames
   7    (make-pathname :directory '(:relative :up "output"))
   8    (make-pathname :directory (pathname-directory *load-truename*))))
   9
  10 (defparameter *page-size-exponent* 8)
  11
  12 (defun cp-high (cp)
  13   (ash cp (- *page-size-exponent*)))
  14
  15 (defun cp-low (cp)
  16   (ldb (byte *page-size-exponent* 0) cp))
  17
  18 ;;; Generator
  19
  20 (defstruct ucd misc transform)
  21
  22 (defparameter *unicode-character-database*
  23   (make-pathname :directory (pathname-directory *load-truename*)))
  24
  25 (defparameter *ucd-base* nil)
  26 (defparameter *unicode-names* (make-hash-table))
  27
  28 (defparameter *last-uppercase* nil)
  29 (defparameter *uppercase-transition-count* 0)
  30 (defparameter *different-titlecases* nil)
  31 (defparameter *different-numerics* nil)
  32 (defparameter *name-size* 0)
  33 (defparameter *misc-hash* (make-hash-table :test #'equal))
  34 (defparameter *misc-index* -1)
  35 (defparameter *misc-table* nil)
  36 (defparameter *misc-mapping* nil)
  37 (defparameter *both-cases* nil)
  38 (defparameter *long-decompositions* nil)
  39 (defparameter *decomposition-types* nil)
  40 (defparameter *decomposition-base* nil)
  41
  42 (defun hash-misc (gc-index bidi-index ccc-index decimal-digit digit
  43                   bidi-mirrored cl-both-case-p decomposition-info)
  44   (let* ((list (list gc-index bidi-index ccc-index decimal-digit digit
  45                      bidi-mirrored cl-both-case-p decomposition-info))
  46          (index (gethash list *misc-hash*)))
  47     (or index
  48         (progn
  49           (vector-push list *misc-table*)
  50           (setf (gethash list *misc-hash*)
  51                 (incf *misc-index*))))))
  52
  53 (defun compare-misc-entry (left right)
  54   (destructuring-bind (left-gc-index left-bidi-index left-ccc-index
  55                        left-decimal-digit left-digit left-bidi-mirrored
  56                        left-cl-both-case-p left-decomposition-info)
  57       left
  58     (destructuring-bind (right-gc-index right-bidi-index right-ccc-index
  59                          right-decimal-digit right-digit right-bidi-mirrored
  60                          right-cl-both-case-p right-decomposition-info)
  61         right
  62       (or (and left-cl-both-case-p (not right-cl-both-case-p))
  63           (and (or left-cl-both-case-p (not right-cl-both-case-p))
  64                (or (< left-gc-index right-gc-index)
  65                    (and (= left-gc-index right-gc-index)
  66                         (or (< left-decomposition-info right-decomposition-info)
  67                             (and (= left-decomposition-info right-decomposition-info)
  68                                  (or (< left-bidi-index right-bidi-index)
  69                                      (and (= left-bidi-index right-bidi-index)
  70                                           (or (< left-ccc-index right-ccc-index)
  71                                               (and (= left-ccc-index right-ccc-index)
  72                                                    (or (string< left-decimal-digit
  73                                                                 right-decimal-digit)
  74                                                        (and (string= left-decimal-digit
  75                                                                      right-decimal-digit)
  76                                                             (or (string< left-digit right-digit)
  77                                                                 (and (string= left-digit
  78                                                                               right-digit)
  79                                                                      (string< left-bidi-mirrored
  80                                                                               right-bidi-mirrored))))))))))))))))))
  81
  82 (defun build-misc-table ()
  83   (sort *misc-table* #'compare-misc-entry)
  84   (setq *misc-mapping* (make-array (1+ *misc-index*)))
  85   (loop for i from 0 to *misc-index*
  86      do (setf (aref *misc-mapping*
  87                     (gethash (aref *misc-table* i) *misc-hash*))
  88               i)))
  89
  90 (defun slurp-ucd ()
  91   (setq *last-uppercase* nil)
  92   (setq *uppercase-transition-count* 0)
  93   (setq *different-titlecases* nil)
  94   (setq *different-numerics* nil)
  95   (setq *name-size* 0)
  96   (setq *misc-hash* (make-hash-table :test #'equal))
  97   (setq *misc-index* -1)
  98   (setq *misc-table* (make-array 2048 :fill-pointer 0))
  99   (setq *both-cases* nil)
 100   (setq *long-decompositions*
 101         (make-array 2048 :fill-pointer 0 :adjustable t))
 102   (setq *decomposition-types*
 103         (let ((array (make-array 256 :initial-element nil :fill-pointer 1)))
 104           (vector-push "" array)
 105           (vector-push "<compat>" array)
 106           array))
 107   (setq *decomposition-base* (make-array (ash #x110000
 108                                               (- *page-size-exponent*))
 109                                          :initial-element nil))
 110   (setq *ucd-base* (make-array (ash #x110000 (- *page-size-exponent*))
 111                                :initial-element nil))
 112   (with-open-file (*standard-input*
 113                    (make-pathname :name "UnicodeData"
 114                                   :type "txt"
 115                                   :defaults *unicode-character-database*)
 116                    :direction :input)
 117     (loop for line = (read-line nil nil)
 118           while line
 119           do (slurp-ucd-line line)))
 120   (second-pass)
 121   (build-misc-table)
 122   (fixup-hangul-syllables)
 123   (length *long-decompositions*))
 124
 125 (defun fixup-hangul-syllables ()
 126   ;; "Hangul Syllable Composition, Unicode 5.1 section 3-12"
 127   (let* ((sbase #xac00)
 128          (lbase #x1100)
 129          (vbase #x1161)
 130          (tbase #x11a7)
 131          (scount 11172)
 132          (lcount 19)
 133          (vcount 21)
 134          (tcount 28)
 135          (ncount (* vcount tcount))
 136          (table (make-hash-table)))
 137     (with-open-file (*standard-input*
 138                      (make-pathname :name "Jamo" :type "txt"
 139                                     :defaults *unicode-character-database*))
 140       (loop for line = (read-line nil nil)
 141             while line
 142             if (position #\; line)
 143             do (add-jamo-information line table)))
 144     (dotimes (sindex scount)
 145       (let* ((l (+ lbase (floor sindex ncount)))
 146              (v (+ vbase (floor (mod sindex ncount) tcount)))
 147              (tee (+ tbase (mod sindex tcount)))
 148              (name (format nil "HANGUL_SYLLABLE_~A~A~:[~A~;~]"
 149                            (gethash l table) (gethash v table)
 150                            (= tee tbase) (gethash tee table))))
 151         (setf (gethash (+ sbase sindex) *unicode-names*) name)))))
 152
 153 (defun add-jamo-information (line table)
 154   (let* ((split (split-string line #\;))
 155          (code (parse-integer (first split) :radix 16))
 156          (syllable (string-trim '(#\Space)
 157                                 (subseq (second split) 0 (position #\# (second split))))))
 158     (setf (gethash code table) syllable)))
 159
 160 (defun split-string (line character)
 161   (loop for prev-position = 0 then (1+ position)
 162         for position = (position character line :start prev-position)
 163         collect (subseq line prev-position position)
 164         do (unless position
 165              (loop-finish))))
 166
 167 (defun init-indices (strings)
 168   (let ((hash (make-hash-table :test #'equal)))
 169     (loop for string in strings
 170           for index from 0
 171           do (setf (gethash string hash) index))
 172     hash))
 173
 174 (defparameter *general-categories*
 175   (init-indices '("Lu" "Ll" "Lt" "Lm" "Lo" "Cc" "Cf" "Co" "Cs" "Mc"
 176                   "Me" "Mn" "Nd" "Nl" "No" "Pc" "Pd" "Pe" "Pf" "Pi"
 177                   "Po" "Ps" "Sc" "Sk" "Sm" "So" "Zl" "Zp" "Zs")))
 178 (defparameter *bidi-classes*
 179   (init-indices '("AL" "AN" "B" "BN" "CS" "EN" "ES" "ET" "L" "LRE" "LRO"
 180                   "NSM" "ON" "PDF" "R" "RLE" "RLO" "S" "WS")))
 181
 182
 183 (defparameter *block-first* nil)
 184
 185 (defun normalize-character-name (name)
 186   (when (find #\_ name)
 187     (error "Bad name for a character: ~A" name))
 188   (unless (or (zerop (length name)) (find #\< name) (find #\> name))
 189     (substitute #\_ #\Space name)))
 190
 191 ;;;   3400  --  4DB5  : cjk ideograph extension a ;Lo;0;L;;;;;N;;;;;
 192 ;;;   AC00  --  D7A3  : hangul syllables ;Lo;0;L;;;;;N;;;;;
 193 ;;;   D800  --  F8FF  : surrogates and private use
 194 ;;;  20000  --  2A6D6 : cjk ideograph extension b ;Lo;0;L;;;;;N;;;;;
 195 ;;;  F0000  --  FFFFD : private use
 196 ;;; 100000  --  10FFFD: private use
 197 (defun encode-ucd-line (line code-point)
 198   (destructuring-bind (name general-category canonical-combining-class
 199                             bidi-class decomposition-type-and-mapping
 200                             decimal-digit digit numeric bidi-mirrored
 201                             unicode-1-name iso-10646-comment simple-uppercase
 202                             simple-lowercase simple-titlecase)
 203       line
 204     (declare (ignore unicode-1-name iso-10646-comment))
 205     (if (and (> (length name) 8)
 206              (string= ", First>" name :start2 (- (length name) 8)))
 207         (progn
 208           (setq *block-first* code-point)
 209           nil)
 210         (let* ((gc-index (or (gethash general-category *general-categories*)
 211                              (error "unknown general category ~A"
 212                                     general-category)))
 213                (bidi-index (or (gethash bidi-class *bidi-classes*)
 214                                (error "unknown bidirectional class ~A"
 215                                       bidi-class)))
 216                (ccc-index (parse-integer canonical-combining-class))
 217                (digit-index (unless (string= "" decimal-digit)
 218                               (parse-integer decimal-digit)))
 219                (upper-index (unless (string= "" simple-uppercase)
 220                               (parse-integer simple-uppercase :radix 16)))
 221                (lower-index (unless (string= "" simple-lowercase)
 222                               (parse-integer simple-lowercase :radix 16)))
 223                (title-index (unless (string= "" simple-titlecase)
 224                               (parse-integer simple-titlecase :radix 16)))
 225                (cl-both-case-p
 226                 (not (null (or (and (= gc-index 0) lower-index)
 227                                (and (= gc-index 1) upper-index)))))
 228                (decomposition-info 0))
 229           (declare (ignore digit-index))
 230           (when (and (not cl-both-case-p)
 231                      (< gc-index 2))
 232             (format t "~A~%" name))
 233           (incf *name-size* (length name))
 234           (when (string/= "" decomposition-type-and-mapping)
 235             (let ((split (split-string decomposition-type-and-mapping #\Space)))
 236               (cond
 237                 ((char= #\< (aref (first split) 0))
 238                  (unless (position (first split) *decomposition-types*
 239                                    :test #'equal)
 240                    (vector-push (first split) *decomposition-types*))
 241                  (setf decomposition-info (position (pop split) *decomposition-types* :test #'equal)))
 242                 (t (setf decomposition-info 1)))
 243               (unless (aref *decomposition-base* (cp-high code-point))
 244                 (setf (aref *decomposition-base* (cp-high code-point))
 245                       (make-array (ash 1 *page-size-exponent*)
 246                                   :initial-element nil)))
 247               (setf (aref (aref *decomposition-base* (cp-high code-point))
 248                           (cp-low code-point))
 249                     (let ((decomposition
 250                            (mapcar #'(lambda (string)
 251                                        (parse-integer string :radix 16))
 252                                    split)))
 253                       (if (= (length decomposition) 1)
 254                           (cons 1 (car decomposition))
 255                           (cons (length decomposition)
 256                                 (prog1 (fill-pointer *long-decompositions*)
 257                                   (dolist (code decomposition)
 258                                     (vector-push-extend code *long-decompositions*)))))))))
 259           (when (and (string/= "" simple-uppercase)
 260                      (string/= "" simple-lowercase))
 261             (push (list code-point upper-index lower-index) *both-cases*))
 262           (when (string/= simple-uppercase simple-titlecase)
 263             (push (cons code-point title-index) *different-titlecases*))
 264           (when (string/= digit numeric)
 265             (push (cons code-point numeric) *different-numerics*))
 266           (cond
 267             ((= gc-index 8)
 268              (unless *last-uppercase*
 269                (incf *uppercase-transition-count*))
 270              (setq *last-uppercase* t))
 271             (t
 272              (when *last-uppercase*
 273                (incf *uppercase-transition-count*))
 274              (setq *last-uppercase* nil)))
 275           (when (> ccc-index 255)
 276             (error "canonical combining class too large ~A" ccc-index))
 277           (let* ((misc-index (hash-misc gc-index bidi-index ccc-index
 278                                         decimal-digit digit bidi-mirrored
 279                                         cl-both-case-p decomposition-info))
 280                  (result (make-ucd :misc misc-index
 281                                    :transform (or upper-index lower-index 0))))
 282             (when (and (> (length name) 7)
 283                        (string= ", Last>" name :start2 (- (length name) 7)))
 284               (let ((page-start (ash (+ *block-first*
 285                                         (ash 1 *page-size-exponent*)
 286                                         -1)
 287                                      (- *page-size-exponent*)))
 288                     (page-end (ash code-point (- *page-size-exponent*))))
 289                 (loop for point from *block-first*
 290                       below (ash page-start *page-size-exponent*)
 291                       do (setf (aref (aref *ucd-base* (cp-high point))
 292                                      (cp-low point))
 293                                result))
 294                 (loop for page from page-start below page-end
 295                       do (setf (aref *ucd-base* page)
 296                                (make-array (ash 1 *page-size-exponent*)
 297                                            :initial-element result)))
 298                 (loop for point from (ash page-end *page-size-exponent*)
 299                       below code-point
 300                       do (setf (aref (aref *ucd-base* (cp-high point))
 301                                      (cp-low point))
 302                                result))))
 303             (values result (normalize-character-name name)))))))
 304
 305 (defun slurp-ucd-line (line)
 306   (let* ((split-line (split-string line #\;))
 307          (code-point (parse-integer (first split-line) :radix 16))
 308          (code-high (ash code-point (- *page-size-exponent*)))
 309          (code-low (ldb (byte *page-size-exponent* 0) code-point)))
 310     (unless (aref *ucd-base* code-high)
 311       (setf (aref *ucd-base* code-high)
 312             (make-array (ash 1 *page-size-exponent*)
 313                         :initial-element nil)))
 314     (multiple-value-bind (encoding name)
 315         (encode-ucd-line (cdr split-line) code-point)
 316       (setf (aref (aref *ucd-base* code-high) code-low) encoding
 317             (gethash code-point *unicode-names*) name))))
 318
 319 ;;; this fixes up the case conversion discrepancy between CL and
 320 ;;; Unicode: CL operators depend on char-downcase / char-upcase being
 321 ;;; inverses, which is not true in general in Unicode even for
 322 ;;; characters which change case to single characters.
 323 (defun second-pass ()
 324   (loop for i from 0 below (length *ucd-base*)
 325         when (aref *ucd-base* i)
 326         do (loop for j from 0 below (length (aref *ucd-base* i))
 327                  for result = (aref (aref *ucd-base* i) j)
 328                  when result
 329                  when (let* ((transform-point (ucd-transform result))
 330                              (transform-high (ash transform-point
 331                                                   (- *page-size-exponent*)))
 332                              (transform-low (ldb (byte *page-size-exponent* 0)
 333                                                  transform-point)))
 334                         (and (plusp transform-point)
 335                              (/= (ucd-transform
 336                                   (aref (aref *ucd-base* transform-high)
 337                                         transform-low))
 338                                  (+ (ash i *page-size-exponent*) j))))
 339                  do (destructuring-bind (gc-index bidi-index ccc-index
 340                                          decimal-digit digit bidi-mirrored
 341                                          cl-both-case-p decomposition-info)
 342                         (aref *misc-table* (ucd-misc result))
 343                       (declare (ignore cl-both-case-p))
 344                       (format t "~A~%" (+ (ash i *page-size-exponent*) j))
 345                       (setf (ucd-misc result)
 346                             (hash-misc gc-index bidi-index ccc-index
 347                                        decimal-digit digit bidi-mirrored
 348                                        nil decomposition-info))))))
 349
 350 (defun write-4-byte (quadruplet stream)
 351   (write-byte (ldb (byte 8 24) quadruplet) stream)
 352   (write-byte (ldb (byte 8 16) quadruplet) stream)
 353   (write-byte (ldb (byte 8 8) quadruplet) stream)
 354   (write-byte (ldb (byte 8 0) quadruplet) stream))
 355
 356 (defun digit-to-byte (digit)
 357   (if (string= "" digit)
 358       255
 359       (parse-integer digit)))
 360
 361 (defun output ()
 362   (let ((hash (make-hash-table :test #'equalp))
 363         (index 0))
 364     (loop for page across *ucd-base*
 365           do (when page
 366                (unless (gethash page hash)
 367                  (setf (gethash page hash)
 368                        (incf index)))))
 369     (let ((array (make-array (1+ index))))
 370       (maphash #'(lambda (key value)
 371                    (setf (aref array value) key))
 372                hash)
 373       (setf (aref array 0)
 374             (make-array (ash 1 *page-size-exponent*) :initial-element nil))
 375       (with-open-file (stream (make-pathname :name "ucd"
 376                                              :type "dat"
 377                                              :defaults *output-directory*)
 378                               :direction :output
 379                               :element-type '(unsigned-byte 8)
 380                               :if-exists :supersede
 381                               :if-does-not-exist :create)
 382         (loop for (gc-index bidi-index ccc-index decimal-digit digit
 383                             bidi-mirrored nil decomposition-info)
 384               across *misc-table*
 385               do (write-byte gc-index stream)
 386               do (write-byte bidi-index stream)
 387               do (write-byte ccc-index stream)
 388               do (write-byte (digit-to-byte decimal-digit) stream)
 389               do (write-byte (digit-to-byte digit) stream)
 390               do (write-byte (if (string= "N" bidi-mirrored) 0 1) stream)
 391               do (write-byte decomposition-info stream)
 392               do (write-byte 0 stream))
 393         (loop for page across *ucd-base*
 394            do (write-byte (if page (gethash page hash) 0) stream))
 395         (loop for page across array
 396            do (loop for entry across page
 397                  do (write-4-byte
 398                      (dpb (if entry (aref *misc-mapping* (ucd-misc entry)) #x7ff)
 399                           (byte 11 21)
 400                           (if entry (ucd-transform entry) 0))
 401                      stream))))))
 402   ;; KLUDGE: this code, to write out decomposition information, is a
 403   ;; little bit very similar to the ucd entries above.  Try factoring
 404   ;; out the common stuff?
 405   (let ((hash (make-hash-table :test #'equalp))
 406         (index 0))
 407     (loop for page across *decomposition-base*
 408           do (when page
 409                (unless (gethash page hash)
 410                  (setf (gethash page hash)
 411                        (prog1 index (incf index))))))
 412     (let ((array (make-array index)))
 413       (maphash #'(lambda (key value)
 414                    (setf (aref array value) key))
 415                hash)
 416       (with-open-file (stream (make-pathname :name "decomp" :type "dat"
 417                                              :defaults *output-directory*)
 418                               :direction :output
 419                               :element-type '(unsigned-byte 8)
 420                               :if-exists :supersede
 421                               :if-does-not-exist :create)
 422         (loop for page across *decomposition-base*
 423            do (write-byte (if page (gethash page hash) 0) stream))
 424         (loop for page across array
 425            do (loop for entry across page
 426                  do (write-4-byte
 427                      (dpb (if entry (car entry) 0)
 428                           (byte 11 21)
 429                           (if entry (cdr entry) 0))
 430                      stream))))
 431       (with-open-file (stream (make-pathname :name "ldecomp" :type "dat"
 432                                              :defaults *output-directory*)
 433                               :direction :output
 434                               :element-type '(unsigned-byte 8)
 435                               :if-exists :supersede
 436                               :if-does-not-exist :create)
 437         (loop for code across (copy-seq *long-decompositions*)
 438            do (write-4-byte code stream)))))
 439   (with-open-file (f (make-pathname :name "ucd-names" :type "lisp-expr"
 440                                     :defaults *output-directory*)
 441                      :direction :output
 442                      :if-exists :supersede
 443                      :if-does-not-exist :create)
 444     (with-standard-io-syntax
 445       (write-string ";;; Do not edit by hand: generated by ucd.lisp" f)
 446       (maphash (lambda (code name)
 447                  (when name
 448                   (print code f)
 449                   (prin1 name f)))
 450                *unicode-names*))
 451     (setf *unicode-names* nil))
 452   (with-open-file (*standard-output*
 453                    (make-pathname :name "numerics"
 454                                   :type "lisp-expr"
 455                                   :defaults *output-directory*)
 456                    :direction :output
 457                    :if-exists :supersede
 458                    :if-does-not-exist :create)
 459     (with-standard-io-syntax
 460       (let ((*print-pretty* t))
 461         (prin1 (mapcar #'(lambda (x) (cons (car x) (read-from-string (cdr x))))
 462                        *different-numerics*)))))
 463   (with-open-file (*standard-output*
 464                    (make-pathname :name "titlecases"
 465                                   :type "lisp-expr"
 466                                   :defaults *output-directory*)
 467                    :direction :output
 468                    :if-exists :supersede
 469                    :if-does-not-exist :create)
 470     (with-standard-io-syntax
 471       (let ((*print-pretty* t))
 472         (prin1 *different-titlecases*))))
 473   (with-open-file (*standard-output*
 474                    (make-pathname :name "misc"
 475                                   :type "lisp-expr"
 476                                   :defaults *output-directory*)
 477                    :direction :output
 478                    :if-exists :supersede
 479                    :if-does-not-exist :create)
 480     (with-standard-io-syntax
 481       (let ((*print-pretty* t))
 482         (prin1 `(:length ,(length *misc-table*)
 483                  :uppercase ,(loop for (gc-index) across *misc-table*
 484                                 for i from 0
 485                                 when (= gc-index 0)
 486                                 collect i)
 487                  :lowercase ,(loop for (gc-index) across *misc-table*
 488                                 for i from 0
 489                                 when (= gc-index 1)
 490                                 collect i)
 491                  :titlecase ,(loop for (gc-index) across *misc-table*
 492                                 for i from 0
 493                                 when (= gc-index 2)
 494                                 collect i))))))
 495   (values))
 496
 497 ;;; Use of the generated files
 498
 499 (defparameter *compiled-ucd* nil)
 500
 501 (defun read-compiled-ucd ()
 502   (with-open-file (stream (make-pathname :name "ucd"
 503                                          :type "dat"
 504                                          :defaults *output-directory*)
 505                           :direction :input
 506                           :element-type '(unsigned-byte 8))
 507     (let ((length (file-length stream)))
 508       (setq *compiled-ucd*
 509             (make-array length :element-type '(unsigned-byte 8)))
 510       (read-sequence *compiled-ucd* stream)))
 511   (values))
 512
 513 ;;; The stuff below is dependent on misc.lisp-expr being
 514 ;;;
 515 ;;; (:LENGTH 395 :UPPERCASE (0 1 2 3 8 9 10 11) :LOWERCASE (4 5 6 7 12 13 14 15) :TITLECASE (16 17))
 516 ;;;
 517 ;;; There are two groups of entries for UPPERCASE and LOWERCASE
 518 ;;; because some characters have case (by Unicode standards) but are
 519 ;;; not transformable character-by-character in a locale-independent
 520 ;;; way (as CL requires for its standard operators).
 521 ;;;
 522 ;;; for more details on these debugging functions, see the description
 523 ;;; of the character database format in src/code/target-char.lisp
 524
 525 (defparameter *length* 395)
 526
 527 (defun cp-index (cp)
 528   (let* ((cp-high (cp-high cp))
 529          (page (aref *compiled-ucd* (+ (* 8 *length*) cp-high))))
 530     (+ (* 8 *length*)
 531        (ash #x110000 (- *page-size-exponent*))
 532        (* (ash 4 *page-size-exponent*) page)
 533        (* 4 (cp-low cp)))))
 534
 535 (defun cp-value-0 (cp)
 536   (let ((index (cp-index cp)))
 537     (dpb (aref *compiled-ucd* index)
 538          (byte 8 3)
 539          (ldb (byte 3 5) (aref *compiled-ucd* (1+ index))))))
 540
 541 (defun cp-value-1 (cp)
 542   (let ((index (cp-index cp)))
 543     (dpb (aref *compiled-ucd* (1+ index)) (byte 5 16)
 544          (dpb (aref *compiled-ucd* (+ index 2)) (byte 8 8)
 545               (aref *compiled-ucd* (+ index 3))))))
 546
 547 (defun cp-general-category (cp)
 548   (aref *compiled-ucd* (* 8 (cp-value-0 cp))))
 549
 550 (defun cp-decimal-digit (cp)
 551   (let ((decimal-digit (aref *compiled-ucd* (+ 3 (* 8 (cp-value-0 cp))))))
 552     (and (< decimal-digit 10)
 553          decimal-digit)))
 554
 555 (defun cp-alpha-char-p (cp)
 556   (< (cp-general-category cp) 5))
 557
 558 (defun cp-alphanumericp (cp)
 559   (let ((gc (cp-general-category cp)))
 560     (or (< gc 5)
 561         (= gc 12))))
 562
 563 (defun cp-digit-char-p (cp &optional (radix 10))
 564   (let ((number (or (cp-decimal-digit cp)
 565                     (and (<= 65 cp 90)
 566                          (- cp 55))
 567                     (and (<= 97 cp 122)
 568                          (- cp 87)))))
 569     (when (and number (< number radix))
 570       number)))
 571
 572 (defun cp-graphic-char-p (cp)
 573   (or (<= 32 cp 127)
 574       (<= 160 cp)))
 575
 576 (defun cp-char-upcase (cp)
 577   (if (< 3 (cp-value-0 cp) 8)
 578       (cp-value-1 cp)
 579       cp))
 580
 581 (defun cp-char-downcase (cp)
 582   (if (< (cp-value-0 cp) 4)
 583       (cp-value-1 cp)
 584       cp))
 585
 586 (defun cp-upper-case-p (cp)
 587   (< (cp-value-0 cp) 4))
 588
 589 (defun cp-lower-case-p (cp)
 590   (< 3 (cp-value-0 cp) 8))
 591
 592 (defun cp-both-case-p (cp)
 593   (< (cp-value-0 cp) 8))