5 (defparameter *output-directory
*
7 (make-pathname :directory
'(:relative
:up
"output"))
8 (make-pathname :directory
(pathname-directory *load-truename
*))))
10 (defun split-string (line character
)
11 (loop for prev-position
= 0 then
(1+ position
)
12 for position
= (position character line
:start prev-position
)
13 collect
(subseq line prev-position position
)
17 (defun parse-codepoints (string &key
(singleton-list t
))
18 "Gets a list of codepoints out of 'aaaa bbbb cccc', stripping surrounding space"
20 (lambda (s) (parse-integer s
:radix
16))
21 (remove "" (split-string string
#\Space
) :test
#'string
=))))
22 (if (not (or (cdr list
) singleton-list
)) (car list
) list
)))
25 (defun parse-codepoint-range (string)
26 "Parse the Unicode syntax DDDD|DDDD..DDDD into an inclusive range (start end)"
27 (destructuring-bind (start &optional empty end
) (split-string string
#\.
)
28 (declare (ignore empty
))
29 (let* ((head (parse-integer start
:radix
16))
31 (parse-integer end
:radix
16 :end
(position #\Space end
))
35 (defun init-indices (strings)
36 (let ((hash (make-hash-table :test
#'equal
)))
37 (loop for string in strings
39 do
(setf (gethash string hash
) index
))
42 (defun clear-flag (bit integer
)
43 (logandc2 integer
(ash 1 bit
)))
46 ;;; Output storage globals
47 (defstruct ucd misc decomp
)
49 (defparameter *unicode-character-database
*
50 (make-pathname :directory
(pathname-directory *load-truename
*)))
52 (defparameter *unicode-names
* (make-hash-table))
53 (defparameter *unicode-1-names
* (make-hash-table))
55 (defparameter *decompositions
*
56 (make-array 10000 :element-type
'(unsigned-byte 24) :fill-pointer
0
57 :adjustable t
)) ; 10000 is not a significant number
59 (defparameter *decomposition-corrections
*
60 (with-open-file (s (make-pathname :name
"NormalizationCorrections" :type
"txt"
61 :defaults
*unicode-character-database
*))
62 (loop with result
= nil
63 for line
= (read-line s nil nil
) while line
64 do
(when (position #\
; line)
65 (destructuring-bind (cp old-decomp correction version
)
66 (split-string line
#\
;)
67 (declare (ignore old-decomp version
))
68 (push (cons (parse-integer cp
:radix
16)
69 (parse-integer correction
:radix
16))
71 finally
(return result
)))
72 "List of decompsotions that were amended in Unicode corrigenda")
74 (defparameter *compositions
* (make-hash-table :test
#'equal
))
75 (defparameter *composition-exclusions
*
76 (with-open-file (s (make-pathname :name
"CompositionExclusions" :type
"txt"
77 :defaults
*unicode-character-database
*))
78 (loop with result
= nil
79 for line
= (read-line s nil nil
) while line
80 when
(and (> (length line
) 0) (char/= (char line
0) #\
#))
81 do
(push (parse-integer line
:end
(position #\Space line
) :radix
16)
82 result
) finally
(return result
)))
83 "Characters that are excluded from composition according to UAX#15")
85 (defparameter *different-titlecases
* nil
)
86 (defparameter *different-casefolds
* nil
)
88 (defparameter *case-mapping
*
89 (with-open-file (s (make-pathname :name
"SpecialCasing" :type
"txt"
90 :defaults
*unicode-character-database
*))
91 (loop with hash
= (make-hash-table)
92 for line
= (read-line s nil nil
) while line
93 unless
(or (not (position #\
# line
)) (= 0 (position #\
# line
)))
94 do
(destructuring-bind (%cp %lower %title %upper
&optional context comment
)
95 (split-string line
#\
;)
96 (unless (and context comment
)
97 (let ((cp (parse-integer %cp
:radix
16))
98 (lower (parse-codepoints %lower
:singleton-list nil
))
99 (title (parse-codepoints %title
:singleton-list nil
))
100 (upper (parse-codepoints %upper
:singleton-list nil
)))
101 (setf (gethash cp hash
) (cons upper lower
))
102 (unless (equal title upper
) (push (cons cp title
) *different-titlecases
*)))))
103 finally
(return hash
)))
104 "Maps cp -> (cons uppercase|(uppercase ...) lowercase|(lowercase ...))")
106 (defparameter *misc-table
* (make-array 3000 :fill-pointer
0)
107 "Holds the entries in the Unicode database's miscellanious array, stored as lists.
108 These lists have the form (gc-index bidi-index ccc digit decomposition-info
109 flags script line-break age). Flags is a bit-bashed integer containing
110 cl-both-case-p, has-case-p, and bidi-mirrored-p, and an east asian width.
111 Length should be adjusted when the standard changes.")
112 (defparameter *misc-hash
* (make-hash-table :test
#'equal
)
113 "Maps a misc list to its position in the misc table.")
115 (defparameter *different-numerics
* nil
)
117 (defparameter *ucd-entries
* (make-hash-table))
119 ;; Mappings of the general categories and bidi classes to integers
120 ;; Letter classes go first to optimize certain cl character type checks
121 ;; BN is the first BIDI class so that unallocated characters are BN
122 ;; Uppercase in the CL sense must have GC = 0, lowercase must GC = 1
123 (defparameter *general-categories
*
124 (init-indices '("Lu" "Ll" "Lt" "Lm" "Lo" "Cc" "Cf" "Co" "Cs" "Cn"
125 "Mc" "Me" "Mn" "Nd" "Nl" "No" "Pc" "Pd" "Pe" "Pf"
126 "Pi" "Po" "Ps" "Sc" "Sk" "Sm" "So" "Zl" "Zp" "Zs")))
127 (defparameter *bidi-classes
*
128 (init-indices '("BN" "AL" "AN" "B" "CS" "EN" "ES" "ET" "L" "LRE" "LRO"
129 "NSM" "ON" "PDF" "R" "RLE" "RLO" "S" "WS" "LRI" "RLI"
131 (defparameter *east-asian-widths
* (init-indices '("N" "A" "H" "W" "F" "Na")))
132 (defparameter *scripts
*
134 '("Unknown" "Common" "Latin" "Greek" "Cyrillic" "Armenian" "Hebrew" "Arabic"
135 "Syriac" "Thaana" "Devanagari" "Bengali" "Gurmukhi" "Gujarati" "Oriya"
136 "Tamil" "Telugu" "Kannada" "Malayalam" "Sinhala" "Thai" "Lao" "Tibetan"
137 "Myanmar" "Georgian" "Hangul" "Ethiopic" "Cherokee" "Canadian_Aboriginal"
138 "Ogham" "Runic" "Khmer" "Mongolian" "Hiragana" "Katakana" "Bopomofo" "Han"
139 "Yi" "Old_Italic" "Gothic" "Deseret" "Inherited" "Tagalog" "Hanunoo" "Buhid"
140 "Tagbanwa" "Limbu" "Tai_Le" "Linear_B" "Ugaritic" "Shavian" "Osmanya"
141 "Cypriot" "Braille" "Buginese" "Coptic" "New_Tai_Lue" "Glagolitic"
142 "Tifinagh" "Syloti_Nagri" "Old_Persian" "Kharoshthi" "Balinese" "Cuneiform"
143 "Phoenician" "Phags_Pa" "Nko" "Sundanese" "Lepcha" "Ol_Chiki" "Vai"
144 "Saurashtra" "Kayah_Li" "Rejang" "Lycian" "Carian" "Lydian" "Cham"
145 "Tai_Tham" "Tai_Viet" "Avestan" "Egyptian_Hieroglyphs" "Samaritan" "Lisu"
146 "Bamum" "Javanese" "Meetei_Mayek" "Imperial_Aramaic" "Old_South_Arabian"
147 "Inscriptional_Parthian" "Inscriptional_Pahlavi" "Old_Turkic" "Kaithi"
148 "Batak" "Brahmi" "Mandaic" "Chakma" "Meroitic_Cursive"
149 "Meroitic_Hieroglyphs" "Miao" "Sharada" "Sora_Sompeng" "Takri"
150 "Bassa_Vah" "Mahajani" "Pahawh_Hmong" "Caucasian_Albanian" "Manichaean"
151 "Palmyrene" "Duployan" "Mende_Kikakui" "Pau_Cin_Hau" "Elbasan" "Modi"
152 "Psalter_Pahlavi" "Grantha" "Mro" "Siddham" "Khojki" "Nabataean" "Tirhuta"
153 "Khudawadi" "Old_North_Arabian" "Warang_Citi" "Linear_A" "Old_Permic")))
154 (defparameter *line-break-classes
*
156 '("XX" "AI" "AL" "B2" "BA" "BB" "BK" "CB" "CJ" "CL" "CM" "CP" "CR" "EX" "GL"
157 "HL" "HY" "ID" "IN" "IS" "LF" "NL" "NS" "NU" "OP" "PO" "PR" "QU" "RI" "SA"
158 "SG" "SP" "SY" "WJ" "ZW")))
160 (defparameter *east-asian-width-table
*
161 (with-open-file (s (make-pathname :name
"EastAsianWidth" :type
"txt"
162 :defaults
*unicode-character-database
*))
163 (loop with hash
= (make-hash-table)
164 for line
= (read-line s nil nil
) while line
165 unless
(or (not (position #\
# line
)) (= 0 (position #\
# line
)))
166 do
(destructuring-bind (codepoints value
)
168 (string-right-trim " " (subseq line
0 (position #\
# line
))) #\
;)
169 (let ((range (parse-codepoint-range codepoints
))
170 (index (gethash value
*east-asian-widths
*)))
171 (loop for i from
(car range
) to
(cadr range
)
172 do
(setf (gethash i hash
) index
))))
173 finally
(return hash
)))
174 "Table of East Asian Widths. Used in the creation of misc entries.")
176 (defparameter *script-table
*
177 (with-open-file (s (make-pathname :name
"Scripts" :type
"txt"
178 :defaults
*unicode-character-database
*))
179 (loop with hash
= (make-hash-table)
180 for line
= (read-line s nil nil
) while line
181 unless
(or (not (position #\
# line
)) (= 0 (position #\
# line
)))
182 do
(destructuring-bind (codepoints value
)
184 (string-right-trim " " (subseq line
0 (position #\
# line
))) #\
;)
185 (let ((range (parse-codepoint-range codepoints
))
186 (index (gethash (subseq value
1) *scripts
*)))
187 (loop for i from
(car range
) to
(cadr range
)
188 do
(setf (gethash i hash
) index
))))
189 finally
(return hash
)))
190 "Table of scripts. Used in the creation of misc entries.")
192 (defparameter *line-break-class-table
*
193 (with-open-file (s (make-pathname :name
"LineBreakProperty" :type
"txt"
194 :defaults
*unicode-character-database
*))
195 (loop with hash
= (make-hash-table)
196 for line
= (read-line s nil nil
) while line
197 unless
(or (not (position #\
# line
)) (= 0 (position #\
# line
)))
198 do
(destructuring-bind (codepoints value
)
200 (string-right-trim " " (subseq line
0 (position #\
# line
))) #\
;)
201 (let ((range (parse-codepoint-range codepoints
))
202 ;; Hangul syllables temporarily go to "Unkwown"
203 (index (gethash value
*line-break-classes
* 0)))
204 (loop for i from
(car range
) to
(cadr range
)
205 do
(setf (gethash i hash
) index
))))
206 finally
(return hash
)))
207 "Table of line break classes. Used in the creation of misc entries.")
209 (defparameter *age-table
*
210 (with-open-file (s (make-pathname :name
"DerivedAge" :type
"txt"
211 :defaults
*unicode-character-database
*))
212 (loop with hash
= (make-hash-table)
213 for line
= (read-line s nil nil
) while line
214 unless
(or (not (position #\
# line
)) (= 0 (position #\
# line
)))
215 do
(destructuring-bind (codepoints value
)
217 (string-right-trim " " (subseq line
0 (position #\
# line
))) #\
;)
218 (let* ((range (parse-codepoint-range codepoints
))
219 (age-parts (mapcar #'parse-integer
(split-string value
#\.
)))
220 (age (logior (ash (car age-parts
) 3) (cadr age-parts
))))
221 (loop for i from
(car range
) to
(cadr range
)
222 do
(setf (gethash i hash
) age
))))
223 finally
(return hash
)))
224 "Table of character ages. Used in the creation of misc entries.")
226 (defvar *block-first
* nil
)
229 ;;; Unicode data file parsing
230 (defun hash-misc (gc-index bidi-index ccc digit decomposition-info flags
231 script line-break age
)
232 (let* ((list (list gc-index bidi-index ccc digit decomposition-info flags
233 script line-break age
))
234 (index (gethash list
*misc-hash
*)))
237 (setf (gethash list
*misc-hash
*)
238 (fill-pointer *misc-table
*))
239 (when (eql nil
(vector-push list
*misc-table
*))
240 (error "Misc table too small."))
241 (gethash list
*misc-hash
*)))))
243 (defun ordered-ranges-member (item vector
)
244 (labels ((recurse (start end
)
246 (let* ((i (+ start
(truncate (- end start
) 2)))
248 (elt1 (svref vector index
))
249 (elt2 (svref vector
(1+ index
))))
253 (recurse (+ 1 i
) end
))
256 (recurse 0 (/ (length vector
) 2))))
258 (defun unallocated-bidi-class (code-point)
259 ;; See tests/data/DerivedBidiClass.txt for more information
260 (flet ((in (vector class
)
261 (when (ordered-ranges-member code-point vector
)
262 (gethash class
*bidi-classes
*))))
265 #(#x0600
#x07BF
#x08A0
#x08FF
#xFB50
#xFDCF
#xFDF0
#xFDFF
#xFE70
#xFEFF
266 #x1EE00
#x1EEFF
) "AL"))
268 #(#x0590
#x05FF
#x07C0
#x089F
#xFB1D
#xFB4F
#x10800
#x10FFF
#x1E800
#x1EDFF
269 #x1EF00
#x1EFFF
) "R"))
270 ((in #(#x20A0
#x20CF
) "ET"))
271 ;; BN is non-characters and default-ignorable.
272 ;; Default-ignorable will be dealt with elsewhere
273 ((in #(#xFDD0
#xFDEF
#xFFFE
#xFFFF
#x1FFFE
#x1FFFF
#x2FFFE
#x2FFFF
274 #x3FFFE
#x3FFFF
#x4FFFE
#x4FFFF
#x5FFFE
#x5FFFF
#x6FFFE
#x6FFFF
275 #x7FFFE
#x7FFFF
#x8FFFE
#x8FFFF
#x9FFFE
#x9FFFF
#xAFFFE
#xAFFFF
276 #xBFFFE
#xBFFFF
#xCFFFE
#xCFFFF
#xDFFFE
#xDFFFF
#xEFFFE
#xEFFFF
277 #xFFFFE
#xFFFFF
#x10FFFE
#x10FFFF
)
279 ((in #(#x0
#x10FFFF
) "L"))
280 (t (error "Somehow we've gone too far in unallocated bidi determination")))))
282 (defun complete-misc-table ()
283 (loop for code-point from
0 to
#x10FFFF do
; Flood-fil unallocated codepoints
284 (unless (second (multiple-value-list (gethash code-point
*ucd-entries
*)))
285 (let* ((unallocated-misc
286 ;; unallocated characters have a GC of "Cn", aren't digits
287 ;; (digit = 128), have a bidi that depends on their block, and
288 ;; don't decompose, combine, or have case. They have an East
289 ;; Asian Width (eaw) of "N" (0), and a script, line breaking
290 ;; class, and age of 0 ("Unknown"), unless some of those
291 ;; properties are otherwise assigned.
292 `(,(gethash "Cn" *general-categories
*)
293 ,(unallocated-bidi-class code-point
) 0 128 0
294 ,(gethash code-point
*east-asian-width-table
* 0)
295 0 ,(gethash code-point
*line-break-class-table
* 0)
296 ,(gethash code-point
*age-table
* 0)))
297 (unallocated-index (apply #'hash-misc unallocated-misc
))
298 (unallocated-ucd (make-ucd :misc unallocated-index
)))
299 (setf (gethash code-point
*ucd-entries
*) unallocated-ucd
)))))
301 (defun expand-decomposition (decomposition)
302 (loop for cp in decomposition
303 for ucd
= (gethash cp
*ucd-entries
*)
304 for length
= (elt (aref *misc-table
* (ucd-misc ucd
)) 4)
305 if
(and (not (logbitp 7 length
))
307 append
(expand-decomposition (ucd-decomp ucd
))
311 ;;; Recursively expand canonical decompositions
312 (defun fixup-decompositions ()
313 (loop for did-something
= nil
315 (loop for code being the hash-key of
*ucd-entries
*
316 using
(hash-value ucd
)
317 when
(and (ucd-decomp ucd
)
318 (not (logbitp 7 (elt (aref *misc-table
* (ucd-misc ucd
)) 4))))
320 (let ((expanded (expand-decomposition (ucd-decomp ucd
))))
321 (unless (equal expanded
(ucd-decomp ucd
))
322 (setf (ucd-decomp ucd
) expanded
325 (loop for i below
(hash-table-count *ucd-entries
*)
326 for ucd
= (gethash i
*ucd-entries
*)
327 for decomp
= (ucd-decomp ucd
)
329 (setf (ucd-decomp ucd
)
330 (cond ((not (consp decomp
)) 0)
331 ((logbitp 7 (elt (aref *misc-table
* (ucd-misc ucd
)) 4))
332 (prog1 (length *decompositions
*)
333 (loop for cp in decomp
334 do
(vector-push-extend cp
*decompositions
*))))
336 (let ((misc-entry (copy-list (aref *misc-table
* (ucd-misc ucd
)))))
337 (setf (elt misc-entry
4) (length decomp
)
338 (ucd-misc ucd
) (apply #'hash-misc misc-entry
))
339 (prog1 (length *decompositions
*)
340 (loop for cp in decomp
341 do
(vector-push-extend cp
*decompositions
*)))))))))
343 (defun fixup-compositions ()
347 (ucd (gethash cp
*ucd-entries
*))
348 (misc (aref *misc-table
* (ucd-misc ucd
)))
350 ;; we can do everything in the first pass except for
351 ;; accounting for decompositions where the first
352 ;; character of the decomposition is not a starter.
354 (remhash k
*compositions
*)))))
355 (maphash #'fixup
*compositions
*)))
357 (defun add-jamo-information (line table
)
358 (let* ((split (split-string line
#\
;))
359 (code (parse-integer (first split
) :radix
16))
360 (syllable (string-trim
362 (subseq (second split
) 0 (position #\
# (second split
))))))
363 (setf (gethash code table
) syllable
)))
365 (defun fixup-hangul-syllables ()
366 ;; "Hangul Syllable Composition, Unicode 5.1 section 3-12"
367 (let* ((sbase #xac00
)
375 (ncount (* vcount tcount
))
376 (table (make-hash-table)))
377 (declare (ignore lcount
))
378 (with-open-file (*standard-input
*
379 (make-pathname :name
"Jamo" :type
"txt"
380 :defaults
*unicode-character-database
*))
381 (loop for line
= (read-line nil nil
)
383 if
(position #\
; line)
384 do
(add-jamo-information line table
)))
385 (dotimes (sindex scount
)
386 (let* ((l (+ lbase
(floor sindex ncount
)))
387 (v (+ vbase
(floor (mod sindex ncount
) tcount
)))
388 (tee (+ tbase
(mod sindex tcount
)))
389 (code-point (+ sbase sindex
))
390 (name (format nil
"HANGUL_SYLLABLE_~A~A~:[~A~;~]"
391 (gethash l table
) (gethash v table
)
392 (= tee tbase
) (gethash tee table
))))
393 (setf (gethash code-point
*unicode-names
*) name
)))))
395 (defun normalize-character-name (name)
396 (when (find #\_ name
)
397 (error "Bad name for a character: ~A" name
))
398 ;; U+1F5CF (PAGE)'s name conflicts with the ANSI CL-assigned
399 ;; name for form feed (^L, U+000C). To avoid a case where
400 ;; more than one character has a particular name while remaining
401 ;; standards-compliant, we remove U+1F5CF's name here.
402 (when (string= name
"PAGE")
403 (return-from normalize-character-name
"UNICODE_PAGE"))
404 (unless (or (zerop (length name
)) (find #\
< name
) (find #\
> name
))
405 (substitute #\_
#\Space name
)))
407 ;;; 3400 -- 4DB5 : cjk ideograph extension a ;Lo;0;L;;;;;N;;;;;
408 ;;; AC00 -- D7A3 : hangul syllables ;Lo;0;L;;;;;N;;;;;
409 ;;; D800 -- F8FF : surrogates and private use
410 ;;; 20000 -- 2A6D6 : cjk ideograph extension b ;Lo;0;L;;;;;N;;;;;
411 ;;; F0000 -- FFFFD : private use
412 ;;; 100000 -- 10FFFD: private use
413 (defun encode-ucd-line (line code-point
)
414 (destructuring-bind (name general-category canonical-combining-class
415 bidi-class decomposition-type-and-mapping
416 decimal-digit digit numeric bidi-mirrored
417 unicode-1-name iso-10646-comment simple-uppercase
418 simple-lowercase simple-titlecase
)
420 (declare (ignore iso-10646-comment
))
421 (if (and (> (length name
) 8)
422 (string= ", First>" name
:start2
(- (length name
) 8)))
424 (setf *block-first
* code-point
)
426 (let* ((gc-index (or (gethash general-category
*general-categories
*)
427 (error "unknown general category ~A"
429 (bidi-index (or (gethash bidi-class
*bidi-classes
*)
430 (error "unknown bidirectional class ~A"
432 (ccc (parse-integer canonical-combining-class
))
433 (digit-index (if (string= "" digit
) 128 ; non-digits have high bit
434 (let ((%digit
(parse-integer digit
)))
435 (if (string= digit decimal-digit
)
436 ;; decimal-digit-p is in bit 6
437 (logior (ash 1 6) %digit
) %digit
))))
438 (upper-index (unless (string= "" simple-uppercase
)
439 (parse-integer simple-uppercase
:radix
16)))
440 (lower-index (unless (string= "" simple-lowercase
)
441 (parse-integer simple-lowercase
:radix
16)))
442 (title-index (unless (string= "" simple-titlecase
)
443 (parse-integer simple-titlecase
:radix
16)))
444 (cl-both-case-p (or (and (= gc-index
0) lower-index
)
445 (and (= gc-index
1) upper-index
)))
446 (bidi-mirrored-p (string= bidi-mirrored
"Y"))
447 (decomposition-info 0)
448 (eaw-index (gethash code-point
*east-asian-width-table
*))
449 (script-index (gethash code-point
*script-table
* 0))
450 (line-break-index (gethash code-point
*line-break-class-table
* 0))
451 (age-index (gethash code-point
*age-table
* 0))
453 (when (and (not cl-both-case-p
)
455 (format t
"~A~%" name
))
457 (when (string/= "" decomposition-type-and-mapping
)
458 (let* ((compatibility-p (position #\
> decomposition-type-and-mapping
)))
461 (subseq decomposition-type-and-mapping
462 (if compatibility-p
(1+ compatibility-p
) 0))))
463 (when (assoc code-point
*decomposition-corrections
*)
465 (list (cdr (assoc code-point
*decomposition-corrections
*)))))
466 (setf decomposition-info
467 (logior (length decomposition
) (if compatibility-p
128 0)))
468 (unless compatibility-p
469 ;; Primary composition excludes:
470 ;; * singleton decompositions;
471 ;; * decompositions of non-starters;
472 ;; * script-specific decompositions;
473 ;; * later-version decompositions;
474 ;; * decompositions whose first character is a
476 ;; All but the last case can be handled here;
477 ;; for the fixup, see FIXUP-COMPOSITIONS
478 (when (and (> decomposition-info
1)
480 (not (member code-point
*composition-exclusions
*)))
481 (unless (= decomposition-info
2)
482 (error "canonical decomposition unexpectedly long"))
483 (setf (gethash (cons (first decomposition
)
484 (second decomposition
))
487 ;; Hangul decomposition; see Unicode 6.2 section 3-12
488 (when (= code-point
#xd7a3
)
489 ;; KLUDGE: The decomposition-length for Hangul syllables in the
490 ;; misc database will be a bit of a lie. It doesn't really matter
491 ;; since the only purpose of the length is to index into the
492 ;; decompositions array (which Hangul decomposition doesn't use).
493 ;; The decomposition index is 0 because we won't be going into the
495 (setf decomposition-info
3))
497 (unless (gethash code-point
*case-mapping
*) ; Exclude codepoints from SpecialCasing
498 (when (string/= simple-uppercase simple-titlecase
)
499 (push (cons code-point title-index
) *different-titlecases
*))
500 (and (or upper-index lower-index
)
501 (setf (gethash code-point
*case-mapping
*)
503 (or upper-index code-point
)
504 (or lower-index code-point
)))))
506 (when (string/= digit numeric
)
507 (push (cons code-point numeric
) *different-numerics
*))
510 (error "canonical combining class too large ~A" ccc
))
511 (let* ((flags (logior
512 (if cl-both-case-p
(ash 1 7) 0)
513 (if (gethash code-point
*case-mapping
*) (ash 1 6) 0)
514 (if bidi-mirrored-p
(ash 1 5) 0)
516 (misc-index (hash-misc gc-index bidi-index ccc digit-index
517 decomposition-info flags script-index
518 line-break-index age-index
))
519 (result (make-ucd :misc misc-index
520 :decomp decomposition
)))
521 (when (and (> (length name
) 7)
522 (string= ", Last>" name
:start2
(- (length name
) 7)))
523 ;; We can still do this despite East Asian Width being in the
524 ;; databasce since each of the UCD <First><Last> blocks
525 ;; has a consistent East Asian Width
526 (loop for point from
*block-first
* to code-point do
527 (setf (gethash point
*ucd-entries
*) result
)))
528 (values result
(normalize-character-name name
)
529 (normalize-character-name unicode-1-name
)))))))
531 (defun slurp-ucd-line (line)
532 (let* ((split-line (split-string line
#\
;))
533 (code-point (parse-integer (first split-line
) :radix
16)))
534 (multiple-value-bind (encoding name unicode-1-name
)
535 (encode-ucd-line (cdr split-line
) code-point
)
536 (setf (gethash code-point
*ucd-entries
*) encoding
537 (gethash code-point
*unicode-names
*) name
)
539 (setf (gethash code-point
*unicode-1-names
*) unicode-1-name
)))))
541 ;;; this fixes up the case conversion discrepancy between CL and
542 ;;; Unicode: CL operators depend on char-downcase / char-upcase being
543 ;;; inverses, which is not true in general in Unicode even for
544 ;;; characters which change case to single characters.
545 ;;; Also, fix misassigned age values, which are not constant across blocks
546 (defun second-pass ()
548 (sort (loop for code-point being the hash-keys in
*case-mapping
*
549 using
(hash-value value
)
550 collect
(cons code-point value
))
552 (loop for
(code-point upper . lower
) in case-mapping
553 for misc-index
= (ucd-misc (gethash code-point
*ucd-entries
*))
554 for
(gc bidi ccc digit decomp flags script lb age
) = (aref *misc-table
* misc-index
)
555 when
(logbitp 7 flags
) do
556 (when (or (not (atom upper
)) (not (atom lower
))
558 (not (equal (car (gethash lower
*case-mapping
*)) code-point
)))
560 (not (equal (cdr (gethash upper
*case-mapping
*)) code-point
))))
561 (let* ((new-flags (clear-flag 7 flags
))
562 (new-misc (hash-misc gc bidi ccc digit decomp new-flags script lb age
)))
563 (setf (ucd-misc (gethash code-point
*ucd-entries
*)) new-misc
))))))
565 (defun fixup-casefolding ()
566 (with-open-file (s (make-pathname :name
"CaseFolding" :type
"txt"
567 :defaults
*unicode-character-database
*))
568 (loop for line
= (read-line s nil nil
)
570 unless
(or (not (position #\
; line)) (equal (position #\# line) 0))
571 do
(destructuring-bind (original type mapping comment
)
572 (split-string line
#\
;)
573 (declare (ignore comment
))
574 (let ((cp (parse-integer original
:radix
16))
575 (fold (parse-codepoints mapping
:singleton-list nil
)))
576 (unless (or (string= type
" S") (string= type
" T"))
577 (when (not (equal (cdr (gethash cp
*case-mapping
*)) fold
))
578 (push (cons cp fold
) *different-casefolds
*))))))))
582 (loop for code-point being the hash-keys in
*age-table
*
583 using
(hash-value true-age
)
584 collect
(cons code-point true-age
))
586 (loop for
(code-point . true-age
) in age
587 for misc-index
= (ucd-misc (gethash code-point
*ucd-entries
*))
588 for
(gc bidi ccc digit decomp flags script lb age
) = (aref *misc-table
* misc-index
)
589 unless
(= age true-age
) do
590 (let* ((new-misc (hash-misc gc bidi ccc digit decomp flags script lb true-age
))
593 :decomp
(ucd-decomp (gethash code-point
*ucd-entries
*)))))
594 (setf (gethash code-point
*ucd-entries
*) new-ucd
)))))
597 (with-open-file (*standard-input
*
598 (make-pathname :name
"UnicodeData"
600 :defaults
*unicode-character-database
*)
602 (loop for line
= (read-line nil nil
)
604 do
(slurp-ucd-line line
)))
607 (fixup-hangul-syllables)
608 (complete-misc-table)
611 (fixup-decompositions)
616 (defparameter **proplist-properties
** nil
617 "A list of properties extracted from PropList.txt")
619 (defun parse-property (stream &optional name
)
620 (let ((result (make-array 1 :fill-pointer
0 :adjustable t
)))
621 (loop for line
= (read-line stream nil nil
)
622 ;; Deal with Blah=Blah in DerivedNormalizationPRops.txt
623 while
(and line
(not (position #\
= (substitute #\Space
#\
= line
:count
1))))
624 for entry
= (subseq line
0 (position #\
# line
))
625 when
(and entry
(string/= entry
""))
627 (destructuring-bind (start end
)
628 (parse-codepoint-range (car (split-string entry
#\
;)))
629 (vector-push-extend start result
)
630 (vector-push-extend end result
)))
632 (push name
**proplist-properties
**)
633 (push result
**proplist-properties
**))))
635 (defun slurp-proplist ()
636 (with-open-file (s (make-pathname :name
"PropList"
638 :defaults
*unicode-character-database
*)
640 (parse-property s
) ;; Initial comments
641 (parse-property s
:white-space
)
642 (parse-property s
:bidi-control
)
643 (parse-property s
:join-control
)
644 (parse-property s
:dash
)
645 (parse-property s
:hyphen
)
646 (parse-property s
:quotation-mark
)
647 (parse-property s
:terminal-punctuation
)
648 (parse-property s
:other-math
)
649 (parse-property s
:hex-digit
)
650 (parse-property s
:ascii-hex-digit
)
651 (parse-property s
:other-alphabetic
)
652 (parse-property s
:ideographic
)
653 (parse-property s
:diacritic
)
654 (parse-property s
:extender
)
655 (parse-property s
:other-lowercase
)
656 (parse-property s
:other-uppercase
)
657 (parse-property s
:noncharacter-code-point
)
658 (parse-property s
:other-grapheme-extend
)
659 (parse-property s
:ids-binary-operator
)
660 (parse-property s
:ids-trinary-operator
)
661 (parse-property s
:radical
)
662 (parse-property s
:unified-ideograph
)
663 (parse-property s
:other-default-ignorable-code-point
)
664 (parse-property s
:deprecated
)
665 (parse-property s
:soft-dotted
)
666 (parse-property s
:logical-order-exception
)
667 (parse-property s
:other-id-start
)
668 (parse-property s
:other-id-continue
)
669 (parse-property s
:sterm
)
670 (parse-property s
:variation-selector
)
671 (parse-property s
:pattern-white-space
)
672 (parse-property s
:pattern-syntax
))
674 (with-open-file (s (make-pathname :name
"DerivedNormalizationProps"
676 :defaults
*unicode-character-database
*)
678 (parse-property s
) ;; Initial comments
679 (parse-property s
) ;; FC_NFKC_Closure
680 (parse-property s
) ;; FC_NFKC_Closure
681 (parse-property s
) ;; Full_Composition_Exclusion
682 (parse-property s
) ;; NFD_QC Comments
683 (parse-property s
:nfd-qc
)
684 (parse-property s
) ;; NFC_QC Comments
685 (parse-property s
:nfc-qc
)
686 (parse-property s
:nfc-qc-maybe
)
687 (parse-property s
) ;; NFKD_QC Comments
688 (parse-property s
:nfkd-qc
)
689 (parse-property s
) ;; NFKC_QC Comments
690 (parse-property s
:nfkc-qc
)
691 (parse-property s
:nfkc-qc-maybe
))
692 (setf **proplist-properties
** (nreverse **proplist-properties
**))
697 (defvar *maximum-variable-key
* 1)
699 (defun bitpack-collation-key (primary secondary tertiary
)
700 ;; 0 <= primary <= #xFFFD (default table)
701 ;; 0 <= secondary <= #x10C [9 bits]
702 ;; 0 <= tertiary <= #x1E (#x1F allowed) [5 bits]
703 ;; Because of this, the bit packs don't overlap
704 (logior (ash primary
16) (ash secondary
5) tertiary
))
706 (defun parse-collation-line (line)
707 (destructuring-bind (%code-points %keys
) (split-string line
#\
;)
708 (let* ((code-points (parse-codepoints %code-points
))
712 (split-string (remove #\
[ (remove #\Space %keys
)) #\
]) :test
#'string
=))
714 (loop for key in keys
715 for variable-p
= (position #\
* key
)
717 ;; Don't need first value, it's always just ""
718 (cdr (mapcar (lambda (x) (parse-integer x
:radix
16 :junk-allowed t
))
719 (split-string (substitute #\.
#\
* key
) #\.
)))
721 (destructuring-bind (primary secondary tertiary
) parsed
722 (when variable-p
(setf *maximum-variable-key
*
723 (max primary
*maximum-variable-key
*)))
724 (bitpack-collation-key primary secondary tertiary
)))))
725 (values code-points ret
))))
727 (defparameter *collation-table
*
728 (with-open-file (stream (make-pathname :name
"Allkeys70" :type
"txt"
729 :defaults
*unicode-character-database
*))
730 (loop with hash
= (make-hash-table :test
#'equal
)
731 for line
= (read-line stream nil nil
) while line
732 unless
(eql 0 (position #\
# line
))
733 do
(multiple-value-bind (codepoints keys
) (parse-collation-line line
)
734 (setf (gethash codepoints hash
) keys
))
735 finally
(return hash
))))
739 (defparameter *confusables
*
740 (with-open-file (s (make-pathname :name
"ConfusablesEdited" :type
"txt"
741 :defaults
*unicode-character-database
*))
742 (loop for line
= (read-line s nil nil
) while line
743 unless
(eql 0 (position #\
# line
))
744 collect
(mapcar #'parse-codepoints
(split-string line
#\
<))))
745 "List of confusable codepoint sets")
747 (defparameter *bidi-mirroring-glyphs
*
748 (with-open-file (s (make-pathname :name
"BidiMirroring" :type
"txt"
749 :defaults
*unicode-character-database
*))
750 (loop for line
= (read-line s nil nil
) while line
751 when
(and (plusp (length line
))
752 (char/= (char line
0) #\
#))
755 #'(lambda (c) (parse-codepoints c
:singleton-list nil
))
756 (split-string (subseq line
0 (position #\
# line
)) #\
;))))
757 "List of BIDI mirroring glyph pairs")
759 (defparameter *block-ranges
*
760 (with-open-file (stream (make-pathname :name
"Blocks" :type
"txt"
761 :defaults
*unicode-character-database
*))
762 (loop with result
= (make-array (* 252 2) :fill-pointer
0)
763 for line
= (read-line stream nil nil
) while line
764 unless
(or (string= line
"") (position #\
# line
))
766 (map nil
#'(lambda (x) (vector-push x result
))
767 (parse-codepoint-range (car (split-string line
#\
;))))
768 finally
(return result
)))
769 "Vector of block starts and ends in a form acceptable to `ordered-ranges-position`.
770 Used to look up block data.")
773 (defun write-codepoint (code-point stream
)
774 (declare (type (unsigned-byte 32) code-point
))
775 (write-byte (ldb (byte 8 16) code-point
) stream
)
776 (write-byte (ldb (byte 8 8) code-point
) stream
)
777 (write-byte (ldb (byte 8 0) code-point
) stream
))
779 (defun write-4-byte (value stream
)
780 (declare (type (unsigned-byte 32) value
))
781 (write-byte (ldb (byte 8 24) value
) stream
)
782 (write-byte (ldb (byte 8 16) value
) stream
)
783 (write-byte (ldb (byte 8 8) value
) stream
)
784 (write-byte (ldb (byte 8 0) value
) stream
))
786 (defun output-misc-data ()
787 (with-open-file (stream (make-pathname :name
"ucdmisc"
789 :defaults
*output-directory
*)
791 :element-type
'(unsigned-byte 8)
792 :if-exists
:supersede
793 :if-does-not-exist
:create
)
794 (loop for
(gc-index bidi-index ccc digit decomposition-info flags
795 script line-break age
)
797 ;; three bits spare here
798 do
(write-byte gc-index stream
)
799 ;; three bits spare here
800 (write-byte bidi-index stream
)
801 (write-byte ccc stream
)
802 ;; bits 0-3 encode [0,9], bit 7 is for non-digit status,
803 ;; bit 6 is the decimal-digit flag. Two bits spare
804 (write-byte digit stream
)
805 (write-byte decomposition-info stream
)
806 (write-byte flags stream
) ; includes EAW in bits 0-3, bit 4 is free
807 (write-byte script stream
)
808 (write-byte line-break stream
)
809 (write-byte age stream
))))
811 (defun output-ucd-data ()
812 (with-open-file (high-pages (make-pathname :name
"ucdhigh"
814 :defaults
*output-directory
*)
816 :element-type
'(unsigned-byte 8)
817 :if-exists
:supersede
818 :if-does-not-exist
:create
)
819 (with-open-file (low-pages (make-pathname :name
"ucdlow"
821 :defaults
*output-directory
*)
823 :element-type
'(unsigned-byte 8)
824 :if-exists
:supersede
825 :if-does-not-exist
:create
)
826 ;; Output either the index into the misc array (if all the points in the
827 ;; high-page have the same misc value) or an index into the law-pages
828 ;; array / 256. For indexes into the misc array, set bit 15 (high bit).
829 ;; We should never have that many misc entries, so that's not a problem.
831 ;; If Unicode ever allocates an all-decomposing <First>/<Last> block (the
832 ;; only way to get a high page that outputs as the same and has a
833 ;; non-zero decomposition-index, which there's nowhere to store now),
834 ;; find me, slap me with a fish, and have fun fixing this mess.
835 (loop with low-pages-index
= 0
836 for high-page from
0 to
(ash #x10FFFF -
8)
837 for uniq-ucd-entries
= nil do
838 (loop for low-page from
0 to
#xFF do
840 (gethash (logior low-page
(ash high-page
8)) *ucd-entries
*)
841 uniq-ucd-entries
:test
#'equalp
))
842 (flet ((write-2-byte (int stream
)
843 (declare (type (unsigned-byte 16) int
))
844 (write-byte (ldb (byte 8 8) int
) stream
)
845 (write-byte (ldb (byte 8 0) int
) stream
)))
846 (case (length uniq-ucd-entries
)
847 (0 (error "Somehow, a high page has no codepoints in it."))
848 (1 (write-2-byte (logior
850 (ucd-misc (car uniq-ucd-entries
)))
852 (t (loop for low-page from
0 to
#xFF
853 for cp
= (logior low-page
(ash high-page
8))
854 for entry
= (gethash cp
*ucd-entries
*) do
855 (write-2-byte (ucd-misc entry
) low-pages
)
856 (write-2-byte (ucd-decomp entry
) low-pages
)
857 finally
(write-2-byte low-pages-index high-pages
)
858 (incf low-pages-index
)))))
859 finally
(assert (< low-pages-index
(ash 1 15))) (print low-pages-index
)))))
861 (defun output-decomposition-data ()
862 (with-open-file (stream (make-pathname :name
"decomp" :type
"dat"
863 :defaults
*output-directory
*)
865 :element-type
'(unsigned-byte 8)
866 :if-exists
:supersede
867 :if-does-not-exist
:create
)
868 (loop for cp across
*decompositions
* do
869 (write-codepoint cp stream
)))
870 (print (length *decompositions
*)))
872 (defun output-composition-data ()
873 (with-open-file (stream (make-pathname :name
"comp" :type
"dat"
874 :defaults
*output-directory
*)
876 :element-type
'(unsigned-byte 8)
877 :if-exists
:supersede
:if-does-not-exist
:create
)
879 (maphash (lambda (k v
) (push (cons k v
) comp
)) *compositions
*)
880 (setq comp
(sort comp
#'< :key
#'cdr
))
881 (loop for
(k . v
) in comp
882 do
(write-codepoint (car k
) stream
)
883 (write-codepoint (cdr k
) stream
)
884 (write-codepoint v stream
)))))
886 (defun output-case-data ()
887 (let (casing-pages points-with-case
)
888 (with-open-file (stream (make-pathname :name
"case" :type
"dat"
889 :defaults
*output-directory
*)
891 :element-type
'(unsigned-byte 8)
892 :if-exists
:supersede
:if-does-not-exist
:create
)
893 (loop for cp being the hash-keys in
*case-mapping
*
894 do
(push cp points-with-case
))
895 (setf points-with-case
(sort points-with-case
#'<))
896 (loop for cp in points-with-case
897 for
(upper . lower
) = (gethash cp
*case-mapping
*) do
898 (pushnew (ash cp -
6) casing-pages
)
899 (write-codepoint cp stream
)
900 (write-byte (if (atom upper
) 0 (length upper
)) stream
)
901 (if (atom upper
) (write-codepoint upper stream
)
902 (map 'nil
(lambda (c) (write-codepoint c stream
)) upper
))
903 (write-byte (if (atom lower
) 0 (length lower
)) stream
)
904 (if (atom lower
) (write-codepoint lower stream
)
905 (map 'nil
(lambda (c) (write-codepoint c stream
)) lower
))))
906 (setf casing-pages
(sort casing-pages
#'<))
907 (assert (< (length casing-pages
) 256))
908 (let* ((size (1+ (reduce #'max casing-pages
)))
909 (array (make-array size
:initial-element
255))
911 (dolist (entry casing-pages
)
912 (setf (aref array entry
) (incf page
)))
913 (with-open-file (stream (make-pathname :name
"casepages" :type
"dat"
914 :defaults
*output-directory
*)
916 :element-type
'(unsigned-byte 8)
917 :if-exists
:supersede
:if-does-not-exist
:create
)
919 (write-byte (aref array i
) stream
))))
920 (with-open-file (stream (make-pathname :name
"casepages" :type
"lisp-expr"
921 :defaults
*output-directory
*)
923 :if-exists
:supersede
:if-does-not-exist
:create
)
924 (with-standard-io-syntax
925 (let ((*print-pretty
* t
)) (print casing-pages stream
))))))
927 (defun output-collation-data ()
928 (with-open-file (stream (make-pathname :name
"collation" :type
"dat"
929 :defaults
*output-directory
*)
931 :element-type
'(unsigned-byte 8)
932 :if-exists
:supersede
:if-does-not-exist
:create
)
933 (flet ((length-tag (list1 list2
)
934 ;; takes two lists of UB32 (with the caveat that list1[0]
935 ;; needs its high 8 bits free (codepoints always have
937 (let* ((l1 (length list1
)) (l2 (length list2
))
938 (tag (dpb l1
(byte 4 28) (dpb l2
(byte 5 23) (car list1
)))))
940 (write-4-byte tag stream
)
941 (map nil
#'(lambda (l) (write-4-byte l stream
)) (append (cdr list1
) list2
)))))
943 (maphash (lambda (k v
) (push (cons k v
) coll
)) *collation-table
*)
944 (labels ((sorter (o1 o2
)
948 (t (or (< (car o1
) (car o2
))
949 (and (= (car o1
) (car o2
))
950 (sorter (cdr o1
) (cdr o2
))))))))
951 (setq coll
(sort coll
#'sorter
:key
#'car
)))
952 (loop for
(k . v
) in coll
953 do
(length-tag k v
)))))
954 (with-open-file (*standard-output
*
955 (make-pathname :name
"other-collation-info"
957 :defaults
*output-directory
*)
959 :if-exists
:supersede
960 :if-does-not-exist
:create
)
961 (with-standard-io-syntax
962 (let ((*print-pretty
* t
))
963 (write-string ";;; The highest primary variable collation index")
965 (prin1 *maximum-variable-key
*) (terpri)))))
970 (output-decomposition-data)
971 (output-composition-data)
973 (output-collation-data)
974 (with-open-file (*standard-output
*
975 (make-pathname :name
"misc-properties" :type
"lisp-expr"
976 :defaults
*output-directory
*)
978 :if-exists
:supersede
979 :if-does-not-exist
:create
)
980 (with-standard-io-syntax
981 (let ((*print-pretty
* t
))
982 (prin1 **proplist-properties
**))))
984 (with-open-file (f (make-pathname :name
"ucd-names" :type
"lisp-expr"
985 :defaults
*output-directory
*)
987 :if-exists
:supersede
988 :if-does-not-exist
:create
)
989 (with-standard-io-syntax
990 (write-string ";;; Do not edit by hand: generated by ucd.lisp" f
)
991 (maphash (lambda (code name
)
996 (setf *unicode-names
* nil
))
997 (with-open-file (f (make-pathname :name
"ucd1-names" :type
"lisp-expr"
998 :defaults
*output-directory
*)
1000 :if-exists
:supersede
1001 :if-does-not-exist
:create
)
1002 (with-standard-io-syntax
1003 (write-string ";;; Do not edit by hand: generated by ucd.lisp" f
)
1004 (maphash (lambda (code name
)
1009 (setf *unicode-1-names
* nil
))
1011 (with-open-file (*standard-output
*
1012 (make-pathname :name
"numerics"
1014 :defaults
*output-directory
*)
1016 :if-exists
:supersede
1017 :if-does-not-exist
:create
)
1018 (with-standard-io-syntax
1019 (let ((*print-pretty
* t
)
1020 (result (make-array (* (length *different-numerics
*) 2))))
1021 (loop for
(code . value
) in
(sort *different-numerics
* #'< :key
#'car
)
1023 do
(setf (aref result i
) code
1024 (aref result
(1+ i
)) (read-from-string value
)))
1026 (with-open-file (*standard-output
*
1027 (make-pathname :name
"titlecases"
1029 :defaults
*output-directory
*)
1031 :if-exists
:supersede
1032 :if-does-not-exist
:create
)
1033 (with-standard-io-syntax
1034 (let ((*print-pretty
* t
))
1035 (prin1 *different-titlecases
*))))
1036 (with-open-file (*standard-output
*
1037 (make-pathname :name
"foldcases"
1039 :defaults
*output-directory
*)
1041 :if-exists
:supersede
1042 :if-does-not-exist
:create
)
1043 (with-standard-io-syntax
1044 (let ((*print-pretty
* t
))
1045 (prin1 *different-casefolds
*))))
1046 (with-open-file (*standard-output
*
1047 (make-pathname :name
"confusables"
1049 :defaults
*output-directory
*)
1051 :if-exists
:supersede
1052 :if-does-not-exist
:create
)
1053 (with-standard-io-syntax
1054 (let ((*print-pretty
* t
))
1055 (prin1 *confusables
*))))
1056 (with-open-file (*standard-output
*
1057 (make-pathname :name
"bidi-mirrors"
1059 :defaults
*output-directory
*)
1061 :if-exists
:supersede
1062 :if-does-not-exist
:create
)
1063 (with-standard-io-syntax
1064 (let ((*print-pretty
* t
))
1065 (prin1 *bidi-mirroring-glyphs
*))))
1066 (with-open-file (*standard-output
*
1067 (make-pathname :name
"blocks"
1069 :defaults
*output-directory
*)
1071 :if-exists
:supersede
1072 :if-does-not-exist
:create
)
1073 (with-standard-io-syntax
1074 (let ((*print-pretty
* t
))
1075 (prin1 *block-ranges
*))))
