-;;; This is the alist of (character-name . character) for characters
-;;; with long names. The first name in this list for a given character
-;;; is used on typeout and is the preferred form for input.
-(macrolet ((frob (char-names-list)
- (collect ((results))
- (dolist (code char-names-list)
- (destructuring-bind (ccode names) code
- (dolist (name names)
- (results (cons name (code-char ccode))))))
- `(defparameter *char-name-alist* ',(results)))))
+(defvar *character-database*)
+(declaim (type (simple-array (unsigned-byte 8) (*)) *character-database*))
+
+#!+sb-unicode
+(progn
+ (defvar *unicode-character-name-database*)
+ (defvar *unicode-character-name-huffman-tree*))
+
+(macrolet ((frob ()
+ (flet ((file (name type)
+ (merge-pathnames (make-pathname
+ :directory
+ '(:relative :up :up "output")
+ :name name :type type)
+ sb!xc:*compile-file-truename*)))
+ `(progn
+ ,(with-open-file (stream (file "ucd" "dat")
+ :direction :input
+ :element-type '(unsigned-byte 8))
+ (let* ((length (file-length stream))
+ (array (make-array
+ length :element-type '(unsigned-byte 8))))
+ (read-sequence array stream)
+ `(defun !character-database-cold-init ()
+ (setq *character-database* ',array))))
+ ,(with-open-file (stream (file "ucd-names" "lisp-expr")
+ :direction :input
+ :element-type 'character)
+ (let ((names (make-hash-table)))
+ #!+sb-unicode
+ (loop
+ for code-point = (read stream nil nil)
+ for char-name = (string-upcase (read stream nil nil))
+ while code-point
+ do (setf (gethash code-point names) char-name))
+ (let ((tree
+ #!+sb-unicode
+ (make-huffman-tree
+ (let (list)
+ (maphash (lambda (code name)
+ (declare (ignore code))
+ (push name list))
+ names)
+ list)))
+ (code->name
+ (make-array (hash-table-count names)
+ :fill-pointer 0))
+ (name->code nil))
+ (maphash (lambda (code name)
+ (vector-push
+ (cons code (huffman-encode name tree))
+ code->name))
+ names)
+ (setf name->code
+ (sort (copy-seq code->name) #'< :key #'cdr))
+ (setf code->name
+ (sort (copy-seq name->code) #'< :key #'car))
+ (setf names nil)
+ `(defun !character-name-database-cold-init ()
+ #!+sb-unicode
+ (setq *unicode-character-name-database*
+ (cons ',code->name ',name->code)
+ *unicode-character-name-huffman-tree* ',tree)))))))))
+ (frob))
+#+sb-xc-host (!character-database-cold-init)
+#+sb-xc-host (!character-name-database-cold-init)
+
+(defparameter *base-char-name-alist*