Commit 3dba7588 authored by rtoy's avatar rtoy
Browse files

tools/build-unidata.lisp: 

o Add support for reading SpecialCasing.txt to support full-casing
  operation.  (Currently does not support language-specific cases or
  context dependent cases.)
o Update some prints
o Add check to write-unidata to produce an error if we try to write
  more objects than we have allocated space for in the index table.

code/unidata.lisp:
o Support loading the full case tables
o Add functions to produce the full case string for a codepoint.
parent 3bedf46b

code/unidata.lisp

+66 −1
Original line number Diff line number Diff line
@@ -4,7 +4,7 @@ 
;;; This code was written by Paul Foley and has been placed in the public

;;; domain.

;;; 

(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unidata.lisp,v 1.1.2.26 2009/06/04 15:47:40 rtoy Exp $")

(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unidata.lisp,v 1.1.2.27 2009/06/05 16:22:09 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -31,6 +31,9 @@ 
  qc-nfc

  qc-nfkc

  comp-exclusions

  full-case-lower

  full-case-title

  full-case-upper

  )



(defvar *unicode-data* (make-unidata))
@@ -248,6 +251,9 @@ 
(defstruct (decomp (:include ntrie32))

  (tabl (ext:required-argument) :read-only t :type simple-string))



(defstruct (full-case (:include ntrie32))

  (tabl (ext:required-argument) :read-only t :type simple-string))



(defstruct (bidi (:include ntrie16))

  (tabl (ext:required-argument) :read-only t

	:type (simple-array (unsigned-byte 16) (*))))
@@ -563,6 +569,36 @@ 
    (read-vector ex stm :endian-swap :network-order)

    (setf (unidata-comp-exclusions *unicode-data*) ex)))



(defloader load-full-case-lower (stm 13)

  (multiple-value-bind (split hvec mvec lvec)

      (read-ntrie 32 stm)

    (let* ((tlen (read16 stm))

	   (tabl (make-array tlen :element-type '(unsigned-byte 16))))

      (read-vector tabl stm :endian-swap :network-order)

      (setf (unidata-full-case-lower *unicode-data*)

	    (make-full-case :split split :hvec hvec :mvec mvec :lvec lvec

			    :tabl (map 'simple-string #'code-char tabl))))))



(defloader load-full-case-title (stm 14)

  (multiple-value-bind (split hvec mvec lvec)

      (read-ntrie 32 stm)

    (let* ((tlen (read16 stm))

	   (tabl (make-array tlen :element-type '(unsigned-byte 16))))

      (read-vector tabl stm :endian-swap :network-order)

      (setf (unidata-full-case-title *unicode-data*)

	    (make-full-case :split split :hvec hvec :mvec mvec :lvec lvec

			    :tabl (map 'simple-string #'code-char tabl))))))



(defloader load-full-case-upper (stm 15)

  (multiple-value-bind (split hvec mvec lvec)

      (read-ntrie 32 stm)

    (let* ((tlen (read16 stm))

	   (tabl (make-array tlen :element-type '(unsigned-byte 16))))

      (read-vector tabl stm :endian-swap :network-order)

      (setf (unidata-full-case-upper *unicode-data*)

	    (make-full-case :split split :hvec hvec :mvec mvec :lvec lvec

			    :tabl (map 'simple-string #'code-char tabl))))))





;;; Accessor functions.
@@ -884,6 +920,35 @@ 
    (load-composition-exclusions))

  (unidata-comp-exclusions *unicode-data*))



(defun %unicode-full-case (code data default)

  (let* ((n (qref32 data code)))

    (if (= n 0)

	(let ((s (make-string 2)))

	  (multiple-value-bind (hi lo)

	      (surrogates code)

	    (setf (schar s 0) hi)

	    (if lo

		(setf (schar s 1) lo)

		(shrink-vector s 1))))

	(let ((off (logand n #xffff))

	      (len (ldb (byte 6 16) n)))

	  (subseq (full-case-tabl data) off (+ off len))))))



(defun unicode-full-case-lower (code)

  (unless (unidata-full-case-lower *unicode-data*)

    (load-full-case-lower))

  (%unicode-full-case code (unidata-full-case-lower *unicode-data*) #'unicode-lower))



(defun unicode-full-case-title (code)

  (unless (unidata-full-case-title *unicode-data*)

    (load-full-case-title))

  (%unicode-full-case code (unidata-full-case-title *unicode-data*) #'unicode-title))

  

(defun unicode-full-case-upper (code)

  (unless (unidata-full-case-upper *unicode-data*)

    (load-full-case-upper))

  (%unicode-full-case code (unidata-full-case-upper *unicode-data*) #'unicode-upper))

	 

;; Build the composition pair table.

(defun build-composition-table ()

  (let ((table (make-hash-table)))

tools/build-unidata.lisp

+111 −21
Original line number Diff line number Diff line
@@ -4,7 +4,7 @@ 
;;; This code was written by Paul Foley and has been placed in the public

;;; domain.

;;; 

(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/build-unidata.lisp,v 1.1.2.10 2009/05/29 16:12:40 rtoy Exp $")

(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/build-unidata.lisp,v 1.1.2.11 2009/06/05 16:22:09 rtoy Exp $")

;;;

;;; **********************************************************************

;;;
@@ -38,6 +38,9 @@ 
  qc-nfc

  qc-nfkc

  comp-exclusions

  full-case-lower

  full-case-title

  full-case-upper

  )



(defvar *unicode-data* (make-unidata))
@@ -113,6 +116,10 @@ 
	;; it as a vector of integers here

	:type (simple-array (unsigned-byte 16) (*))))



(defstruct (full-case (:include ntrie32))

  (tabl (ext:required-argument) :read-only t

	:type (simple-array (unsigned-byte 16) (*))))



(defstruct (bidi (:include ntrie16))

  (tabl (ext:required-argument) :read-only t

	:type (simple-array (unsigned-byte 16) (*))))
@@ -401,10 +408,14 @@ 
	     (write-byte (ldb (byte 8 0) n) stm))

	   (write32 (n stm)

	     (write16 (ldb (byte 16 16) n) stm)

	     (write16 (ldb (byte 16 0) n) stm)))

	     (write16 (ldb (byte 16 0) n) stm))

	   (update-index (val array)

	     (let ((result (vector-push val array)))

	       (unless result

		 (error "Index array too short for the data being written")))))

    (with-open-file (stm path :direction :io :if-exists :rename-and-delete

			 :element-type '(unsigned-byte 8))

      (let ((index (make-array 13 :fill-pointer 0)))

      (let ((index (make-array 16 :fill-pointer 0)))

	;; File header

	(write32 +unicode-magic-number+ stm)	; identification "magic"

	;; File format version
@@ -418,12 +429,12 @@ 
	(write32 0 stm)			; end marker

	;; Range data

	(let ((data (unidata-range *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write32 (length (range-codes data)) stm)

	  (write-vector (range-codes data) stm :endian-swap :network-order))

	;; Character name data

	(let ((data (unidata-name+ *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (1- (length (dictionary-cdbk data))) stm)

	  (write16 (length (dictionary-keyv data)) stm)

	  (write32 (length (dictionary-codev data)) stm)
@@ -439,7 +450,7 @@ 
	  (write-vector (dictionary-namev data) stm :endian-swap :network-order))

	;; Codepoint-to-name mapping

	(let ((data (unidata-name *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (ntrie32-split data) stm)

	  (write16 (length (ntrie32-hvec data)) stm)

	  (write16 (length (ntrie32-mvec data)) stm)
@@ -449,7 +460,7 @@ 
	  (write-vector (ntrie32-lvec data) stm :endian-swap :network-order))

	;; Codepoint-to-category table

	(let ((data (unidata-category *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (ntrie8-split data) stm)

	  (write16 (length (ntrie8-hvec data)) stm)

	  (write16 (length (ntrie8-mvec data)) stm)
@@ -459,7 +470,7 @@ 
	  (write-vector (ntrie8-lvec data) stm :endian-swap :network-order))

	;; Simple case mapping table

	(let ((data (unidata-scase *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (scase-split data) stm)

	  (write16 (length (scase-hvec data)) stm)

	  (write16 (length (scase-mvec data)) stm)
@@ -471,7 +482,7 @@ 
	  (write-vector (scase-svec data) stm :endian-swap :network-order))

	;; Numeric data

	(let ((data (unidata-numeric *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (ntrie32-split data) stm)

	  (write16 (length (ntrie32-hvec data)) stm)

	  (write16 (length (ntrie32-mvec data)) stm)
@@ -481,7 +492,7 @@ 
	  (write-vector (ntrie32-lvec data) stm :endian-swap :network-order))

	;; Decomposition data

	(let ((data (unidata-decomp *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (decomp-split data) stm)

	  (write16 (length (decomp-hvec data)) stm)

	  (write16 (length (decomp-mvec data)) stm)
@@ -493,7 +504,7 @@ 
	  (write-vector (decomp-tabl data) stm :endian-swap :network-order))

	;; Combining classes

	(let ((data (unidata-combining *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (ntrie8-split data) stm)

	  (write16 (length (ntrie8-hvec data)) stm)

	  (write16 (length (ntrie8-mvec data)) stm)
@@ -503,7 +514,7 @@ 
	  (write-vector (ntrie8-lvec data) stm :endian-swap :network-order))

	;; Bidi data

	(let ((data (unidata-bidi *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (bidi-split data) stm)

	  (write16 (length (bidi-hvec data)) stm)

	  (write16 (length (bidi-mvec data)) stm)
@@ -515,7 +526,7 @@ 
	  (write-vector (bidi-tabl data) stm :endian-swap :network-order))

	;; Unicode 1.0 names

	(let ((data (unidata-name1+ *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (1- (length (dictionary-cdbk data))) stm)

	  (write16 (length (dictionary-keyv data)) stm)

	  (write32 (length (dictionary-codev data)) stm)
@@ -530,7 +541,7 @@ 
	  (write-vector (dictionary-nextv data) stm :endian-swap :network-order)

	  (write-vector (dictionary-namev data) stm :endian-swap :network-order))

	(let ((data (unidata-name1 *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write-byte (ntrie32-split data) stm)

	  (write16 (length (ntrie32-hvec data)) stm)

	  (write16 (length (ntrie32-mvec data)) stm)
@@ -539,7 +550,7 @@ 
	  (write-vector (ntrie32-mvec data) stm :endian-swap :network-order)

	  (write-vector (ntrie32-lvec data) stm :endian-swap :network-order))

	;; Normalization quick-check data

	(vector-push (file-position stm) index)

	(update-index (file-position stm) index)

	(let ((data (unidata-qc-nfd *unicode-data*)))

	  (write-byte (ntrie1-split data) stm)

	  (write16 (length (ntrie1-hvec data)) stm)
@@ -574,9 +585,24 @@ 
	  (write-vector (ntrie2-lvec data) stm :endian-swap :network-order))

	;; Write composition exclusion table

	(let ((data (unidata-comp-exclusions *unicode-data*)))

	  (vector-push (file-position stm) index)

	  (update-index (file-position stm) index)

	  (write16 (length data) stm)

	  (write-vector data stm :endian-swap :network-order))

	;; Write full-case lower data

	(flet ((dump-full-case (data)

		 (update-index (file-position stm) index)

		 (write-byte (full-case-split data) stm)

		 (write16 (length (full-case-hvec data)) stm)

		 (write16 (length (full-case-mvec data)) stm)

		 (write16 (length (full-case-lvec data)) stm)

		 (write-vector (full-case-hvec data) stm :endian-swap :network-order)

		 (write-vector (full-case-mvec data) stm :endian-swap :network-order)

		 (write-vector (full-case-lvec data) stm :endian-swap :network-order)

		 (write16 (length (full-case-tabl data)) stm)

		 (write-vector (full-case-tabl data) stm :endian-swap :network-order))) 

	  (dump-full-case (unidata-full-case-lower *unicode-data*))

	  (dump-full-case (unidata-full-case-title *unicode-data*))

	  (dump-full-case (unidata-full-case-upper *unicode-data*)))

	;; Patch up index

	(file-position stm 8)

	(dotimes (i (length index))
@@ -596,12 +622,16 @@ 
  mcode

  norm-qc

  comp-exclusion

  full-case-lower

  full-case-title

  full-case-upper

  ;; ...

  )



;; ucd-directory should be the directory where UnicodeData.txt is

;; located.

(defun foreach-ucd (name ucd-directory fn)

   (format t "~&  ~A~%" name)

  (with-open-file (s (make-pathname :name name :type "txt"

				    :defaults ucd-directory))

    (cond
@@ -746,6 +776,18 @@ 
      (lambda (min)		 

	(let ((entry (find min vec :key #'ucdent-code)))

	  (setf (ucdent-comp-exclusion entry) t))))



    (foreach-ucd "SpecialCasing"

		 ucd-directory

      (lambda (min max lower title upper &rest condition)

	(declare (ignore max))

	(when (string= (car condition) "")

	  (flet ((parse-casing (string)

		   (rest (parse-decomposition string))))

	    (let ((ent (find min vec :key #'ucdent-code)))

	      (setf (ucdent-full-case-lower ent) (parse-casing lower))

	      (setf (ucdent-full-case-title ent) (parse-casing title))

	      (setf (ucdent-full-case-upper ent) (parse-casing upper)))))))

    (values vec (make-range :codes range))))
@@ -814,6 +856,22 @@ 
			       +decomposition-type+ :test #'equalp)

		     27)))))



(defun pack-full-case (ucdent tabl entry)

  (if (not (funcall entry ucdent))

      0

      (let* ((d (loop for i in (funcall entry ucdent)

		  if (<= i #xFFFF) collect i

		  else collect (logior (ldb (byte 10 10) (- i #x10000)) #xD800)

		   and collect (logior (ldb (byte 10 0) (- i #x10000)) #xDC00)))

	     (l (length d))

	     (n (search d tabl)))

	(unless n

	  (setq n (fill-pointer tabl))

	  (dolist (x d) (vector-push-extend x tabl)))

	;; next 6 bits: length, in code units

	;; low 16 bits: index into tabl

	(logior n (ash l 16)))))



(defun pack-bidi (ucdent tabl)

  (logior (position (ucdent-bidi ucdent) +bidi-class+ :test #'string=)

	  (if (ucdent-mirror ucdent) #x20 #x00)
@@ -939,4 +997,36 @@ 
	   (when (ucdent-comp-exclusion ent)

	     (vector-push-extend (ucdent-code ent) exclusions)))

      (setf (unidata-comp-exclusions *unicode-data*) (copy-seq exclusions)))

    (format t "~&Building full case mapping tables~%")

    (format t "~&  Lower...~%")

    (let ((tabl (make-array 100 :element-type '(unsigned-byte 16)

			    :fill-pointer 0 :adjustable t))

	  (split #x65))

      (multiple-value-bind (hvec mvec lvec)

	  (pack ucd range (lambda (x) (pack-full-case x tabl #'ucdent-full-case-lower))

		0 32 split)

	(setf (unidata-full-case-lower *unicode-data*)

	      (make-full-case :split split :hvec hvec :mvec mvec :lvec lvec

			      :tabl (copy-seq tabl)))))

    (format t "~&  Title...~%")

    (let ((tabl (make-array 100 :element-type '(unsigned-byte 16)

			    :fill-pointer 0 :adjustable t))

	  (split #x65))

      (multiple-value-bind (hvec mvec lvec)

	  (pack ucd range (lambda (x) (pack-full-case x tabl #'ucdent-full-case-title))

		0 32 split)

	(setf (unidata-full-case-title *unicode-data*)

	      (make-full-case :split split :hvec hvec :mvec mvec :lvec lvec

			      :tabl (copy-seq tabl)))))

    (format t "~&  Upper...~%")

    (let ((tabl (make-array 100 :element-type '(unsigned-byte 16)

			    :fill-pointer 0 :adjustable t))

	  (split #x65))

      (multiple-value-bind (hvec mvec lvec)

	  (pack ucd range (lambda (x) (pack-full-case x tabl #'ucdent-full-case-upper))

		0 32 split)

	(setf (unidata-full-case-upper *unicode-data*)

	      (make-full-case :split split :hvec hvec :mvec mvec :lvec lvec

			      :tabl (copy-seq tabl)))))

    nil))