clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/cl-unicode/build/dump.lisp

@@ -0,0 +1,239 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-unicode/build/dump.lisp,v 1.37 2008/07/21 23:02:25 edi Exp $
+
+;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-unicode)
+
+(defun build-range-list (reader test)
+  "Loops through all non-NIL elements of *CHAR-DATABASE*, looks at
+each element using the reader READER and builds an alist of the form
+\((X1 . A1) (X2 . A2)) where the Xi are code points and the Ai are the
+corresponding attributes as returned by READER.  The interesting part
+is that the Xi can also be code point ranges like \(Y1 . Y2) meaning
+that all code points from Y1 to \(including) Y2 have the same
+attribute Ai and the function tries to make the alist as short as
+possible, i.e. to partition it into as few ranges as possible.
+Whether two attributes are the same is determined by the test function
+TEST.  The resulting list is sorted."
+  (let (range-list
+        (last-attribute (funcall reader (aref *char-database* 0)))
+        (last-code-point 0)
+        (code-point 0))
+    (flet ((add ()
+             "Adds the range from LAST-CODE-POINT to \(excluding)
+CODE-POINT with the attribute LAST-ATTRIBUTE to the result."
+             (push (cons (cons last-code-point (1- code-point))
+                         last-attribute)
+                   range-list)))
+      (loop
+       (incf code-point)
+       (when (= code-point #.(1- +code-point-limit+))
+         (add)
+         (return))
+       (let* ((char-info (aref *char-database* code-point))
+              (attribute (and char-info (funcall reader char-info))))
+         (unless (funcall test attribute last-attribute)
+           (add)
+           (setq last-attribute attribute
+                 last-code-point code-point)))))
+    (nreverse range-list)))
+
+(defun split-range-list (range-list)
+  "Recursively splits a range list as returned by BUILD-RANGE-LIST in
+the middle and thus converts it into a binary search tree which can be
+used by the TREE-LOOKUP function."
+  (let ((length (length range-list)))
+    (cond ((zerop length) nil)
+          (t (let ((middle (round (1- length) 2)))
+               (list (nth middle range-list)
+                     (split-range-list (subseq range-list 0 middle))
+                     (split-range-list (subseq range-list (1+ middle)))))))))
+
+(defun build-tree (reader &optional (test #'eq))
+  "Uses BUILD-RANGE-LIST and SPLIT-RANGE-LIST to build a binary search
+tree for READER which is one of the readers of the CHAR-INFO class.
+Attributes are compared with TEST."
+  (split-range-list (build-range-list reader test)))
+
+(defun dump-method (name reader stream &optional (test #'eq test-provided-p))
+  "Writes a method definition for a unary method called NAME
+specialized for integer \(code points) to the stream STREAM which
+returns a value equivalent to
+
+  \(APPLY READER \(AREF *CHAR-DATABASE* <code-point>))
+
+but uses compact binary search trees instead of the *CHAR-DATABASE*
+array.  TEST is used by BUILD-TREE to decide whether two adjacent
+characters have the same attribute.  If TEST isn't provided, it is
+assumed that the attribute is a property symbol and the method will
+return two values - the symbol and the canonical name of the symbol."
+  (let ((definition (if test-provided-p
+                      `(defmethod ,name ((code-point integer))
+                         (tree-lookup code-point ',(build-tree reader test)))
+                      `(defmethod ,name ((code-point integer))
+                         (let ((symbol (tree-lookup code-point ',(build-tree reader))))
+                           (values (property-name symbol) symbol))))))
+    (print definition stream)))
+
+(defmacro with-output-to-source-file ((stream relative-path &key no-header-p) &body body)
+  "Executes BODY with STREAM bound to an output file stream which
+writes to the file denoted by RELATIVE-PATH - a path relative to the
+location of this source file.  Writes a Lisp header to the files
+unless NO-HEADER-P is true."
+  `(let ((pathname (merge-pathnames ,relative-path *this-file*)))
+     (format t "~&;;; Writing source file ~A" (file-namestring pathname))
+     (force-output)
+     (with-open-file (,stream pathname
+                              :direction :output
+                              :if-exists :supersede)
+       (with-standard-io-syntax ()
+         (let ((*package* (find-package :cl-unicode)))
+           ,@(unless no-header-p
+               '((format out ";;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*-~%")))
+           (format out ";;; This file was auto-generated by the BUILD-CL-UNICODE system~2%")
+           ,@(unless no-header-p
+               '((print '(in-package :cl-unicode) out)))
+           ,@body)))))
+
+(defun dump-methods ()
+  "Dumps several methods to the CL-UNICODE source file methods.lisp
+using DUMP-METHOD."
+  (with-output-to-source-file (out "../methods.lisp")
+    (dump-method 'script 'script* out)
+    (dump-method 'code-block 'code-block* out)
+    (dump-method 'age 'age* out #'equal)
+    (dump-method 'general-category 'general-category* out)
+    (dump-method 'bidi-class 'bidi-class* out)
+    (dump-method 'numeric-type 'numeric-type* out)
+    (dump-method 'numeric-value 'numeric-value* out #'eql)
+    (dump-method 'combining-class 'combining-class* out #'eql)
+    (dump-method 'bidi-mirroring-glyph% 'bidi-mirroring-glyph* out #'eql)
+    (dump-method 'binary-props 'binary-props* out #'equal)))
+
+(defun dump-hash-table (hash-table-name stream)
+  "Writes code to the STREAM which reinitializes the hash table
+contained in the global special variable named HASH-TABLE-NAME to its
+current state.  It is assumed that all keys and values of the hash
+table can be printed readably."
+  (print `(clrhash ,hash-table-name) stream)
+  (let ((key-value-alist
+         (loop for key being the hash-keys of (symbol-value hash-table-name)
+               using (hash-value value)
+               when value
+               collect (cons key value))))
+    (print `(loop for (key . value) in ',key-value-alist
+                  do (setf (gethash key ,hash-table-name) value))
+           stream)))
+
+(defun dump-hash-tables ()
+  "Dumps several hash tables to the CL-UNICODE source file
+hash-tables.lisp using DUMP-HASH-TABLE."
+  (with-output-to-source-file (out "../hash-tables.lisp")
+    (dump-hash-table '*canonical-names* out)
+    (dump-hash-table '*names-to-code-points* out)
+    (dump-hash-table '*code-points-to-names* out)
+    (dump-hash-table '*unicode1-names-to-code-points* out)
+    (dump-hash-table '*code-points-to-unicode1-names* out)
+    (dump-hash-table '*case-mappings* out)
+    (dump-hash-table '*jamo-short-names* out)
+    ;; finally add code which adds the computed Hangul syllable names
+    ;; at load time
+    (print '(add-hangul-names) out)))
+
+(defun dump-list (list-name stream)
+  "Writes code to the STREAM which reinitializes the list contained in
+the global special variable named LIST-NAME to its current state.  It
+is assumed that all elements of the list can be printed readably."
+  (print `(setq ,list-name ',(symbol-value list-name)) stream))
+
+(defun dump-lists ()
+  "Dumps several list to the CL-UNICODE source file lists.lisp using
+DUMP-LIST."
+  (with-output-to-source-file (out "../lists.lisp")
+    (dump-list '*general-categories* out)
+    (dump-list '*scripts* out)
+    (dump-list '*code-blocks* out)
+    (dump-list '*binary-properties* out)
+    (dump-list '*bidi-classes* out)))
+
+(defun dump-derived-tests ()
+  "Parses the Unicode data file \"DerivedCoreProperties.txt\" \(which
+is not used in read.lisp) and uses it to create a file
+\"derived-properties\" which will be used by CL-UNICODE-TEST."
+  (with-output-to-source-file (out (make-pathname :name "derived-properties"
+                                                  :type :unspecific
+                                                  :directory '(:relative :up "test"))
+                                   :no-header-p t)
+    (let (last-test)
+      (labels ((really-add-test (test)
+                 "Writes the test designator from ADD-TEST in a
+\"delayed\" fashion to make sure that the previous test \(which hasn't
+been written to disk yet) doesn't contradict the current test.  This
+is necessary because the file we're parsing contains several adjacent
+ranges."
+                 (when last-test
+                   (unless (= (first last-test) (first test))
+                     (print last-test out)))
+                 (setq last-test test))
+               (add-test (code-point property &optional (successp t))
+                 "Writes a test designator \(used by the function
+CL-UNICODE-TEST::PROPERTY-TESTS) for a check whether CODE-POINT has
+the property PROPERTY to the stream OUT, but only does this if
+CODE-POINT is below +CODE-POINT-LIMIT+.  Tests for the inverse if
+SUCCESSP is NIL.  The test designator isn't actually written to the
+stream, though, but handed over to REALLY-ADD-TEST."
+                 (when (< code-point +code-point-limit+)
+                   (really-add-test `(,code-point ,property ,successp)))))
+        (with-unicode-file ((code-point-range property) "DerivedCoreProperties.txt")
+          (cond ((atom code-point-range)
+                 (add-test code-point-range property)
+                 (add-test (1+ code-point-range) property nil))
+                (t
+                 (add-test (car code-point-range) property)
+                 (add-test (cdr code-point-range) property)
+                 (add-test (1+ (cdr code-point-range)) property nil))))       
+        (print last-test out)))))
+
+(defun dump-data-structures ()
+  "Dumps all the information contained in *CHAR-DATABASE* and the
+related hash tables and lists to the corresponding Lisp and test
+source files."
+  (dump-methods)
+  (dump-hash-tables)
+  (dump-lists)
+  (dump-derived-tests)
+  (setq *char-database* nil))
+
+(defun create-source-files ()
+  "Combines BUILD-DATA-STRUCTURES and DUMP-DATA-STRUCTURES to create
+the \"missing\" CL-UNICODE source files."
+  (build-data-structures)
+  (dump-data-structures)
+  (setq *char-database* nil))
+
+(create-source-files)

data/lib/clucumber/vendor/cl-unicode/build/read.lisp

@@ -0,0 +1,280 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-UNICODE; Base: 10 -*-
+;;; $Header: /usr/local/cvsrep/cl-unicode/build/read.lisp,v 1.32 2008/07/22 02:42:15 edi Exp $
+
+;;; Copyright (c) 2008, Dr. Edmund Weitz. All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;;   * Redistributions of source code must retain the above copyright
+;;;     notice, this list of conditions and the following disclaimer.
+
+;;;   * Redistributions in binary form must reproduce the above
+;;;     copyright notice, this list of conditions and the following
+;;;     disclaimer in the documentation and/or other materials
+;;;     provided with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
+;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
+;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :cl-unicode)
+
+(defmacro with-unicode-file (((&rest bindings) file-name &optional two-line-ranges) &body body)
+  "Utility macro to parse a file which is formatted as described in
+<http://unicode.org/Public/UNIDATA/UCD.html#UCD_File_Format>.  The
+file named FILE-NAME is searched for in the directory \"data/\"
+relative to this source file.  The code then iterates through the file
+and executes BODY for each non-comment line binding the variables in
+BINDINGS to the parsed fields of the line.  For the details of
+BINDINGS see the EXTRACT-FOO functions in util.lisp or the usage of
+this macro below.  If TWO-LINE-RANGES is true, then the macro expects
+a file like \"UnicodeData.txt\" where ranges aren't denoted as usual
+but rather using <..., First> and <..., Last>."
+  (let ((variables (extract-variables bindings))
+        (types (extract-types bindings)))
+    `(let ((pathname (merge-pathnames ,file-name (merge-pathnames "data/" *this-file*))))
+       (format t "~&;;; Parsing Unicode file ~A" (file-namestring pathname))
+       (force-output)
+       (with-open-file (binary-in pathname :element-type 'flex:octet)
+         ;; Unicode data files must be read as UTF-8
+         (let ((in (flex:make-flexi-stream binary-in :external-format '(:utf-8 :eol-style :lf))))
+           (loop
+            (flet ((get-line-contents ()
+                     (let ((line (or (read-line in nil) (return))))
+                       (and (not (ppcre:scan "^\\s*(?:#|$)" line))
+                            (ppcre:split "\\s*#.*$|\\s*;\\s*" line :limit most-positive-fixnum)))))
+              (let ((contents (get-line-contents)))
+                (when contents
+                  (destructuring-bind ,variables
+                      (parse-one-line contents ',types (list ,@(extract-defaults bindings)))
+                    ,@(when two-line-ranges
+                        `((when (ppcre:scan "^<.*, First>$" ,(second variables))
+                            (let ((range-end (first (parse-one-line (list (first (get-line-contents)))))))
+                              (setq ,(first variables) (cons ,(first variables) range-end))))))
+                    ,@body))))))))))
+
+(defmacro with-code-point-range ((var range) &body body)
+  "Utility macro which executes BODY with VAR bound to each code point
+in RANGE in turn.  VAR can either be an integer \(for one code point)
+or a cons of two integers \(for an inclusive range)."
+  (with-rebinding (range)
+    `(flet ((thunk (,var) ,@body))
+       (cond ((atom ,range) (thunk ,range))
+             (t (loop for point from (car ,range) to (cdr ,range)
+                      do (thunk point)))))))
+
+(defun read-character-data ()
+  "Parses the file \"UnicodeData.txt\" and generates one CHAR-INFO
+entry per code point which is stored in *CHAR-DATABASE*."
+  ;; by definition, we'll never see this property in the file, so we
+  ;; have to add it to *GENERAL-CATEGORIES* explicitly
+  (setq *general-categories* (list '#.(property-symbol "Cn")))
+  (with-unicode-file ((code-point-range
+                       name
+                       (general-category symbol)
+                       (combining-class integer)
+                       (bidi-class symbol)
+                       ;; decomposition mapping, ignored for now
+                       _
+                       (decimal-digit integer nil)
+                       (digit integer nil)
+                       (numeric rational nil)
+                       (bidi-mirrored boolean)
+                       (unicode1-name string nil)
+                       ;; ISO comment, ignored
+                       _
+                       (uppercase-mapping hex nil)
+                       (lowercase-mapping hex nil)
+                       (titlecase-mapping hex nil))
+                      "UnicodeData.txt" t)
+    (pushnew general-category *general-categories* :test #'eq)
+    (pushnew bidi-class *bidi-classes* :test #'eq)
+    ;; if the name starts with #\<, it's not really a name but denotes
+    ;; a range - some of these names (CJK unified ideographs and
+    ;; Hangul syllables) will be computed later, the others are NIL
+    (when (char= (char name 0) #\<)
+      (setq name nil))
+    (with-code-point-range (code-point code-point-range)
+      (setf (aref *char-database* code-point)
+            (make-instance 'char-info
+                           :code-point code-point
+                           :name name
+                           :general-category general-category
+                           :combining-class combining-class
+                           :bidi-class bidi-class
+                           :numeric-type (cond (decimal-digit '#.(property-symbol "Decimal"))
+                                               (digit '#.(property-symbol "Digit"))
+                                               (numeric '#.(property-symbol "Numeric")))
+                           :numeric-value numeric
+                           :binary-props (and bidi-mirrored
+                                              (list '#.(property-symbol "BidiMirrored")))
+                           :unicode1-name unicode1-name
+                           :uppercase-mapping uppercase-mapping
+                           :lowercase-mapping lowercase-mapping
+                           :titlecase-mapping titlecase-mapping)))))
+
+(defun read-scripts ()
+  "Parses the file \"Scripts.txt\" and adds the information about the
+script to the corresponding entries in *CHAR-DATABASE*."
+  (with-unicode-file ((code-point-range (script symbol)) "Scripts.txt")
+    (pushnew script *scripts* :test #'eq)
+    (with-code-point-range (code-point code-point-range)
+      (let ((char-info (aref *char-database* code-point)))
+        (when char-info
+          (setf (script* char-info) script))))))
+
+(defun read-code-blocks ()
+  "Parses the file \"Blocks.txt\" and adds the information about the
+code block to the corresponding entries in *CHAR-DATABASE*."
+  (with-unicode-file ((code-point-range (code-block symbol)) "Blocks.txt")
+    (pushnew code-block *code-blocks* :test #'eq)
+    (with-code-point-range (code-point code-point-range)
+      (let ((char-info (aref *char-database* code-point)))
+        (when char-info
+          (setf (code-block* char-info) code-block))))))
+
+(defun read-binary-properties ()
+  "Parses the file \"PropList.txt\" and adds information about binary
+properties to the corresponding entries in *CHAR-DATABASE*."
+  ;; this property was derived from UnicodeData.txt already
+  (setq *binary-properties* (list '#.(property-symbol "BidiMirrored")))
+  (with-unicode-file ((code-point-range (property symbol)) "PropList.txt")
+    ;; we don't need this information as we derive it from a code
+    ;; point not being mentioned in UnicodeData.txt - see also the
+    ;; initform for GENERAL-CATEGORY in the definition of CHAR-INFO
+    (unless (eq property '#.(property-symbol "NoncharacterCodePoint"))
+      (pushnew property *binary-properties* :test #'eq)
+      (with-code-point-range (code-point code-point-range)
+        (let ((char-info (aref *char-database* code-point)))
+          (unless char-info
+            ;; this file actually contains some information for
+            ;; unassigned (but reserved) code points, like e.g. #xfff0
+            (setf char-info (make-instance 'char-info :code-point code-point)
+                  (aref *char-database* code-point) char-info))
+          (push property (binary-props* char-info)))))))
+
+(defun read-derived-age ()
+  "Parses the file \"DerivedAge.txt\" and adds information about the
+\"age\" to the corresponding entries in *CHAR-DATABASE*."
+  (with-unicode-file ((code-point-range (age age)) "DerivedAge.txt")
+    (with-code-point-range (code-point code-point-range)
+      (let ((char-info (aref *char-database* code-point)))
+        (when char-info
+          (setf (age* char-info) age))))))
+
+(defun read-mirroring-glyphs ()
+  "Parses the file \"BidiMirroring.txt\" and adds information about
+mirroring glyphs to the corresponding entries in *CHAR-DATABASE*."
+  (with-unicode-file ((code-point-range (mirroring-glyph hex)) "BidiMirroring.txt")
+    (with-code-point-range (code-point code-point-range)
+      (let ((char-info (aref *char-database* code-point)))
+        (when char-info
+          (setf (bidi-mirroring-glyph* char-info) mirroring-glyph))))))
+
+(defun read-jamo ()
+  "Parses the file \"Jamo.txt\" and stores information about Jamo
+short names in the *JAMO-SHORT-NAMES* hash table.  This information is
+later used to compute Hangul syllable names."
+  (clrhash *jamo-short-names*)
+  (with-unicode-file ((code-point-range (short-name string "")) "Jamo.txt")
+    (with-code-point-range (code-point code-point-range)
+      (setf (gethash code-point *jamo-short-names*) short-name))))
+
+(defun default-bidi-class (char-info)
+  "Returns the default Bidi class for the character described by the
+CHAR-INFO object CHAR-INFO.  The default is computed as explained in
+<http://unicode.org/Public/UNIDATA/extracted/DerivedBidiClass.txt>."
+  (let ((code-point (code-point char-info)))
+    (cond ((and (or (<= #x0600 code-point #x07BF)
+                    (<= #xFB50 code-point #xFDFF)
+                    (<= #xFE70 code-point #xFEFF))
+                (not (find '#.(property-symbol "NoncharacterCodePoint")
+                           (binary-props* code-point))))
+           '#.(property-symbol "AL"))
+          ((or (<= #x0590 code-point #x05FF)
+               (<= #x07C0 code-point #x08ff)
+               (<= #xFB1D code-point #xFB4F)
+               (<= #x10800 code-point #x10FFF))
+           '#.(property-symbol "R"))
+          (t '#.(property-symbol "L")))))
+
+(defun set-default-bidi-classes ()
+  "Loops through all assigned characters in *CHAR-DATABASE* and
+defaults their Bidi class if it wasn't set already."
+  (loop for char-info across *char-database*
+        when (and char-info (not (bidi-class* char-info)))
+        do (let ((default-bidi-class (default-bidi-class char-info)))
+             (pushnew default-bidi-class *bidi-classes* :test #'eq)
+             (setf (bidi-class* char-info) default-bidi-class))))
+
+(defun fill-database ()
+  "Initializes all relevant datastructures and parses all Unicode data
+files in the \"data/\" directory to build up enough information in
+memory \(specifically the *CHAR-DATABASE* array) to write the missing
+source code files for CL-UNICODE."
+  (setq *char-database* (make-empty-char-database)
+        *general-categories* nil
+        *scripts* nil
+        *code-blocks* nil
+        *binary-properties* nil
+        *bidi-classes* nil)
+  (initialize-property-symbols)
+  (read-character-data)
+  (read-scripts)
+  (read-code-blocks)
+  (read-binary-properties)
+  (read-derived-age)
+  (read-mirroring-glyphs)
+  (read-jamo)
+  (set-default-bidi-classes))
+
+(defun build-name-mappings ()
+  "Initializes and fills the hash tables which map code points to
+\(Unicode 1.0) names and vice versa using the information in
+*CHAR-DATABASE*."
+  (clrhash *names-to-code-points*)
+  (clrhash *unicode1-names-to-code-points*)
+  (clrhash *code-points-to-names*)
+  (clrhash *code-points-to-unicode1-names*)
+  (loop for char-info across *char-database*
+        for name = (and char-info (name char-info))
+        for unicode1-name = (and char-info (unicode1-name char-info))
+        for code-point = (and char-info (code-point char-info))
+        when name
+        do (setf (gethash code-point *code-points-to-names*) name
+                 (gethash (canonicalize-name name) *names-to-code-points*) code-point)
+        when unicode1-name
+        do (setf (gethash code-point *code-points-to-unicode1-names*) unicode1-name
+                 (gethash (canonicalize-name unicode1-name) *unicode1-names-to-code-points*) code-point)))
+
+(defun build-case-mapping ()
+  "Initializes and filles the *CASE-MAPPINGS* hash table from
+*CHAR-DATABASE*."
+  (clrhash *case-mappings*)
+  (loop for char-info across *char-database*
+        for mappings = (and char-info
+                            (list (uppercase-mapping* char-info)
+                                  (lowercase-mapping* char-info)
+                                  (titlecase-mapping* char-info)))
+        when (and mappings (some #'identity mappings))
+        do (setf (gethash (code-point char-info) *case-mappings*) mappings)))
+
+(defun build-data-structures ()
+  "One function to combine the complete process of parsing all Unicode
+data files and building the corresponding Lisp datastructures in
+memory."
+  (fill-database)
+  (format t "~&;;; Building hash tables")
+  (force-output)
+  (build-name-mappings)
+  (build-case-mapping))