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