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