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