Commit 178e0362 authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

Merge branch 'update-ucd' into 'develop'

Update the unicode character database

See merge request embeddable-common-lisp/ecl!250
parents 88917314 5a4c337b
;;; Load names of all unicode characters from the Unicode Character
;;; Database
;;;
;;; The names are compressed by splitting up the name into words and
;;; encoding each word by an index in a hash table. The data is then
;;; stored in the list *data* in the following format
;;;
;;; (char-code name index1 index2 ...)
;;;
;;; For example `0` and `1` are encoded as
;;; (48 "DIGIT_ZERO" 22 23)
;;; (49 "DIGIT_ONE" 22 24)
;;; in *data*. 22 is the index for the word "DIGIT" while 23 and 24
;;; are the indices for "ZERO" and "ONE" respectively
(defun split-words (text &key (set '(#\Space)) (exclude t))
(loop with start = 0
with output = '()
......@@ -63,7 +77,7 @@
(defvar *words*)
(defparameter *data*
(with-open-file (in "~/src/sbcl/tools-for-build/UnicodeData.txt" :direction :input)
(with-open-file (in "UnicodeData.txt" :direction :input)
(loop with words = (setf *words* (make-hash-table :size 1024 :test #'equal))
for ucd-line = (read-line in nil nil nil)
while ucd-line
......
......@@ -11,17 +11,17 @@
;; used anywhere else
;;
(loop with used-code = (make-array (1+ last-code) :initial-element nil)
for line in translated-data
for pair-code = (third line)
do (cond ((/= (length line) 3)
(error "Error in compressed data: too long code ~A" line))
((or (aref used-code pair-code)
(< pair-code first-code))
(let ((new-pair (cons pair-code 0)))
(setf pairs (acons (incf last-code) new-pair pairs)
(third line) last-code)))
(t
(setf (aref used-code pair-code) t))))
for line in translated-data
for pair-code = (third line)
do (cond ((/= (length line) 3)
(error "Error in compressed data: too long code ~A" line))
((or (aref used-code pair-code)
(< pair-code first-code))
(let ((new-pair (cons pair-code 0)))
(setf pairs (acons (incf last-code) new-pair pairs)
(third line) last-code)))
(t
(setf (aref used-code pair-code) t))))
;;
;; We now renumber all pairs.
;;
......@@ -35,18 +35,18 @@
(error "Unknown code ~A" old-code))))
;; First of all we add the words
(loop for i from 0 below first-code
do (add-code i))
do (add-code i))
;; Then we add all pairs that represent characters, so that they
;; are consecutive, too.
(loop for line in translated-data
do (setf (third line) (add-code (third line))))
do (setf (third line) (add-code (third line))))
;; Finally, we add the remaining pairs
(loop for record in pairs
do (setf (car record) (add-code (car record))))
do (setf (car record) (add-code (car record))))
;; ... and we fix the definitions
(loop for (code . pair) in pairs
do (setf (car pair) (translate (car pair))
(cdr pair) (translate (cdr pair))))))
do (setf (car pair) (translate (car pair))
(cdr pair) (translate (cdr pair))))))
(defparameter *sorted-compressed-data* translated-data)
(defparameter *sorted-pairs* (sort pairs #'< :key #'car))
(print 'finished)
......@@ -82,6 +82,8 @@
:if-exists :supersede)
(format s "/*
* UNICODE NAMES DATABASE
*
* auto-generated, do not edit! (see contrib/unicode/)
*/
#ifndef ECL_UCD_NAMES_H
#define ECL_UCD_NAMES_H 1
......@@ -93,7 +95,7 @@
#define ECL_UCD_TOTAL_NAMES ~D
typedef struct {
unsigned char codes[4];
unsigned char codes[6];
} ecl_ucd_names_pair_type;
typedef struct {
......@@ -125,6 +127,8 @@ extern const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES];
:if-exists :supersede)
(format s "/*
* Pairs of symbols.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/
#include <ecl/ecl.h>
......@@ -134,12 +138,13 @@ const ecl_ucd_names_pair_type ecl_ucd_names_pair[ECL_UCD_TOTAL_PAIRS] = {
"
(length *sorted-pairs*) (length *sorted-pairs*))
(loop for i from 0
for (pair-code . (a . b)) in *sorted-pairs*
do (format s "~A{~D, ~D, ~D, ~D}~%"
(if (plusp i) "," "")
(logand a #xff) (ash a -8)
(logand b #xff) (ash b -8)
))
for (pair-code . (a . b)) in *sorted-pairs*
do (assert (< a (ash 1 24)))
(assert (< b (ash 1 24)))
(format s "~A{~D, ~D, ~D, ~D, ~D, ~D}~%"
(if (plusp i) "," "")
(logand a #xff) (logand (ash a -8) #xff) (ash a -16)
(logand b #xff) (logand (ash b -8) #xff) (ash b -16)))
(format s "};~%"))
(with-open-file (s (merge-pathnames "ucd_names_codes.c" *destination*)
......@@ -147,6 +152,8 @@ const ecl_ucd_names_pair_type ecl_ucd_names_pair[ECL_UCD_TOTAL_PAIRS] = {
:if-exists :supersede)
(format s "/*
* Sorted character names.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/
#include <ecl/ecl.h>
......@@ -155,13 +162,15 @@ const ecl_ucd_names_pair_type ecl_ucd_names_pair[ECL_UCD_TOTAL_PAIRS] = {
const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES] = {
")
(loop with l = (sort (copy-tree *sorted-compressed-data*) #'string<= :key #'second)
for (ucd-code name code) in l
for i from 0
do (format s "~A{{~D, ~D}, {~D, ~D, ~D}}~%"
(if (plusp i) "," "")
(logand code #xff) (ash code -8)
(logand ucd-code #xff) (logand (ash ucd-code -8) #xff)
(logand (ash ucd-code -16) #xff)))
for (ucd-code name code) in l
for i from 0
do (assert (< code (ash 1 16)))
(assert (< ucd-code (ash 1 24)))
(format s "~A{{~D, ~D}, {~D, ~D, ~D}}~%"
(if (plusp i) "," "")
(logand code #xff) (ash code -8)
(logand ucd-code #xff) (logand (ash ucd-code -8) #xff)
(logand (ash ucd-code -16) #xff)))
(format s "};"))
(with-open-file (s (merge-pathnames "ucd_names_str.c" *destination*)
......@@ -169,6 +178,8 @@ const ecl_ucd_code_and_pair ecl_ucd_sorted_pairs[ECL_UCD_TOTAL_NAMES] = {
:if-exists :supersede)
(format s "/*
* Dictionary words.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/
#include <ecl/ecl.h>
......@@ -186,6 +197,8 @@ const char *ecl_ucd_names_word[ECL_UCD_FIRST_PAIR] = {
:if-exists :supersede)
(format s "/*
* Dictionary words.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/
#include <string.h>
......@@ -234,9 +247,11 @@ fill_pair_name(char *buffer, int pair)
printf(\"c1=%d\\n\", ecl_ucd_names_pair[pair - ECL_UCD_FIRST_PAIR].codes[1]);
printf(\"c2=%d\\n\", ecl_ucd_names_pair[pair - ECL_UCD_FIRST_PAIR].codes[2]);
printf(\"c3=%d\\n\", ecl_ucd_names_pair[pair - ECL_UCD_FIRST_PAIR].codes[3]);
printf(\"c4=%d\\n\", ecl_ucd_names_pair[pair - ECL_UCD_FIRST_PAIR].codes[4]);
printf(\"c5=%d\\n\", ecl_ucd_names_pair[pair - ECL_UCD_FIRST_PAIR].codes[5]);
*/
fill_pair_name(buffer, (((unsigned int)p.codes[1]) << 8) | p.codes[0]);
fill_pair_name(buffer, (((unsigned int)p.codes[3]) << 8) | p.codes[2]);
fill_pair_name(buffer, (((unsigned int)p.codes[2]) << 16) | (((unsigned int)p.codes[1]) << 8) | p.codes[0]);
fill_pair_name(buffer, (((unsigned int)p.codes[5]) << 16) | (((unsigned int)p.codes[4]) << 8) | p.codes[3]);
}
}
......@@ -294,5 +309,3 @@ _ecl_ucd_name_to_code(cl_object name)
}
"))
;(ext:run-program "/bin/sh" '("-c" "cp *.c *.h ~/devel/ecl/src/c/unicode/"))
(load "./load-names.lisp")
(declaim (optimize (debug 0) (speed 3)))
(setf *print-circle* t)
(defun compute-pairs (data table)
;; Compute the frequency of consecutive pairs of words and store
;; them in table.
(clrhash table)
(loop with max = 0
with max-pair = nil
for (code name . l) in data
do (loop for l2 on l
for a = (car l2)
for b = (cadr l2)
for a = (first l2)
for b = (second l2)
while b
do (let* ((pair (cons a b))
(c (gethash pair table)))
(freq (gethash pair table)))
(setf (gethash pair table)
(setf c (if c (1+ c) 1))
(setf freq (if freq (1+ freq) 1))
a b)
(when (> c max)
(setf max c max-pair pair))))
(when (> freq max)
(setf max freq max-pair pair))))
finally (return (cons max max-pair))))
(defun replace-pair (pair code data)
;; For all characters in data, replace the pair representing two
;; consecutive words by code (which is a single integer).
;; Returns the total number of pairs left.
(let ((old-a (car pair))
(old-b (cdr pair)))
(loop with more = 0
......@@ -32,14 +35,17 @@
for b = (second l2)
while b
do (when (and (eql a old-a) (eql b old-b))
;; replace (a b . c) with (pair . c)
;; replace (a b . rest) with (code . rest)
(setf (car l2) code
(cdr l2) (cddr l2)))
do (setf l2 (cdr l2)))
do (setf more (+ more (1- (length l))))
(incf more (1- (length l)))
finally (return more))))
(defun compress (data)
;; Compress data by replacing the pair of consecutive words with
;; maximum frequency with a new code until no pairs with frequency >
;; 1 are left.
(loop with last-length = 0
with table = (make-hash-table :size 2048 :test #'equal)
with pairs = '()
......
;;; Common
(defparameter *destination*
(merge-pathnames "../../src/c/unicode/"
(or *load-truename* *compile-pathname*)))
(defvar *extension-directory*
(make-pathname :directory (pathname-directory *load-truename*)))
......@@ -130,12 +134,22 @@
hash))
(defparameter *general-categories*
;; Do not change the order of this list!
;; As an optimization, the categories for ordinary lower and
;; uppercase characters are put first in ecl_ucd_misc_table. This
;; allows us to check whether a character is lower or uppercase
;; simply by checking the index without having to consult the table
;; itself.
;; Moreover, order of the categories is used in src/c/char_ctype.d
(init-indices '("Lu" "Ll" "Lt" "Lm" "Lo" "Cc" "Cf" "Co" "Cs" "Mc"
"Me" "Mn" "Nd" "Nl" "No" "Pc" "Pd" "Pe" "Pf" "Pi"
"Po" "Ps" "Sc" "Sk" "Sm" "So" "Zl" "Zp" "Zs")))
(defparameter *bidi-classes*
(init-indices '("AL" "AN" "B" "BN" "CS" "EN" "ES" "ET" "L" "LRE" "LRO"
"NSM" "ON" "PDF" "R" "RLE" "RLO" "S" "WS")))
(init-indices '("AL" "AN" "B" "BN" "CS" "EN" "ES" "ET" "FSI" "L"
"LRE" "LRI" "LRO" "NSM" "ON" "PDF" "PDI" "R" "RLE"
"RLI" "RLO" "S" "WS")))
(defparameter *block-first* nil)
......@@ -411,7 +425,7 @@
collect i)))))
(values))
(defmacro with-c-file ((stream-var name) &rest body)
(defmacro with-c-file ((stream-var name) &body body)
`(with-open-file (,stream-var ,name
:direction :output
:external-format #-unicode :default #+unicode :us-ascii
......@@ -419,6 +433,16 @@
:if-does-not-exist :create)
,@body))
(defun write-enums (hash-table name-creator stream)
(let (enums)
(format stream "~%enum {~%")
(maphash #'(lambda (k v)
(push (cons v (funcall name-creator k)) enums))
hash-table)
(setf enums (sort enums #'< :key #'car))
(mapc #'(lambda (e) (format stream "~A,~%" (cdr e))) enums)
(format stream "};~%")))
(defun output-c (&optional small-unicode)
(let* ((num-pages (/ (if small-unicode #x10000 *unicode-char-limit*)
*page-size*))
......@@ -426,17 +450,53 @@
(hash (make-hash-table :test #'equalp))
(index 0)
array)
(with-c-file (stream (make-pathname :name ucd-file-name
:type "h"
:defaults *destination*))
(format stream "/*
* Unicode character database.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/")
(write-enums *general-categories*
#'(lambda (name) (format nil "ECL_UCD_GENERAL_CATEGORY_~A" name))
stream)
(write-enums *bidi-classes*
#'(lambda (name) (format nil "ECL_UCD_BIDIRECTIONAL_CLASS_~A" name))
stream)
(assert (and (= (gethash "Lu" *general-categories*) 0)
(= (gethash "Ll" *general-categories*) 1)))
(let* ((uppercase-limit
(position-if-not #'(lambda (entry)
;; gc-index = 0, both-case-p = t
(and (= (first entry) 0) (first (last entry))))
*misc-table*))
(lowercase-limit
(position-if-not #'(lambda (entry)
;; gc-index = 1, both-case-p = t
(and (= (first entry) 1) (first (last entry))))
*misc-table*
:start uppercase-limit)))
(format stream "#define ECL_UCD_UPPERCASE_LIMIT ~D~%"
uppercase-limit)
(format stream "#define ECL_UCD_LOWERCASE_LIMIT ~D~%"
lowercase-limit)))
(with-c-file (stream (make-pathname :name ucd-file-name
:type "c"
:defaults *extension-directory*))
(format stream "~%extern const char ecl_ucd_page_table_0[];")
:defaults *destination*))
(format stream "/*
* Unicode character database.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/")
(format stream "~%extern const unsigned char ecl_ucd_page_table_0[];")
(loop for page across *ucd-base*
for i from 0 below num-pages
do (when page
(unless (gethash page hash)
(setf (gethash page hash) (incf index))
(print index)
(format stream "~%extern const char ecl_ucd_page_table_~D[];" index))))
(format stream "~%extern const unsigned char ecl_ucd_page_table_~D[];" index))))
(setf array (make-array (incf index)))
(maphash #'(lambda (key value)
(setf (aref array value) key))
......@@ -481,7 +541,7 @@
for c-file = (format nil "~A-~4,'0D" ucd-file-name i)
do (with-c-file (stream (make-pathname :name c-file
:type "c"
:defaults *extension-directory*))
:defaults *destination*))
(loop for j from i below next
for page = (aref array j)
do (format stream "~%const unsigned char ecl_ucd_page_table_~D[] = {" j)
......
#!/bin/bash
set -e
curl https://www.unicode.org/Public/UCD/latest/ucd/UnicodeData.txt -o UnicodeData.txt
curl https://www.unicode.org/Public/UCD/latest/ucd/Jamo.txt -o Jamo.txt
ecl --norc --load ucd.lisp --eval "(slurp-ucd)" --eval "(output-c)" --eval "(output-c t)" --eval "(ext:quit)"
ecl --norc --compile load-names.lisp --compile names-pairs.lisp --load load-names.fas --load names-pairs.fas --load names-pairs-sort.lisp --eval "(ext:quit)"
rm load-names.fas names-pairs.fas
rm UnicodeData.txt Jamo.txt
......@@ -23,7 +23,8 @@ THREADS_OBJ=
ECL_UNICODE_FLAG=21
ECL_UCD_OBJ = ucd.obj ucd-0000.obj ucd-0016.obj \
ucd-0032.obj ucd-0048.obj ucd-0064.obj \
ucd-0080.obj ucd-0096.obj ucd_names_char.obj ucd_names_codes.obj ucd_names_pair.obj ucd_names_str.obj
ucd-0080.obj ucd-0096.obj ucd-0112.obj \
ucd-0128.obj ucd-0144.obj ucd_names_char.obj ucd_names_codes.obj ucd_names_pair.obj ucd_names_str.obj
!else
ECL_UNICODE_FLAG=0
......
......@@ -65,6 +65,8 @@ ecl_char_downcase(ecl_character code)
#else /* ECL_UNICODE */
#include "unicode/ucd.h"
extern const unsigned char ecl_ucd_misc_table[];
extern const unsigned char *ecl_ucd_page_table[];
extern const unsigned char ecl_ucd_page_table_1[];
......@@ -136,39 +138,41 @@ ecl_graphic_char_p(ecl_character code)
bool
ecl_alpha_char_p(ecl_character code)
{
return ucd_general_category(code) < 5;
return ucd_general_category(code) <= ECL_UCD_GENERAL_CATEGORY_Lo;
}
bool
ecl_upper_case_p(ecl_character code)
{
return ucd_value_0(code) == 0;
return ucd_value_0(code) < ECL_UCD_UPPERCASE_LIMIT;
}
bool
ecl_lower_case_p(ecl_character code)
{
return ucd_value_0(code) == 1;
return ucd_value_0(code) >= ECL_UCD_UPPERCASE_LIMIT
&& ucd_value_0(code) < ECL_UCD_LOWERCASE_LIMIT;
}
bool
ecl_both_case_p(ecl_character code)
{
return ucd_value_0(code) < 2;
/* Does code have both lower and uppercase variants? */
return ucd_value_0(code) < ECL_UCD_LOWERCASE_LIMIT;
}
bool
ecl_alphanumericp(ecl_character i)
{
int gc = ucd_general_category(i);
return (gc < 5) || (gc == 12);
return gc <= ECL_UCD_GENERAL_CATEGORY_Lo || gc == ECL_UCD_GENERAL_CATEGORY_Nd;
}
ecl_character
ecl_char_upcase(ecl_character code)
{
const unsigned char *c = ucd_char_data(code);
if (c[0] == 1) {
if (c[0] >= ECL_UCD_UPPERCASE_LIMIT && c[0] < ECL_UCD_LOWERCASE_LIMIT) {
return read_case_bytes(c);
} else {
return code;
......@@ -179,7 +183,7 @@ ecl_character
ecl_char_downcase(ecl_character code)
{
const unsigned char *c = ucd_char_data(code);
if (c[0] == 0) {
if (c[0] < ECL_UCD_UPPERCASE_LIMIT) {
return read_case_bytes(c);
} else {
return code;
......
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
/*
* Unicode character database.
*
* auto-generated, do not edit! (see contrib/unicode/)
*/
enum {
ECL_UCD_GENERAL_CATEGORY_Lu,
ECL_UCD_GENERAL_CATEGORY_Ll,
ECL_UCD_GENERAL_CATEGORY_Lt,
ECL_UCD_GENERAL_CATEGORY_Lm,
ECL_UCD_GENERAL_CATEGORY_Lo,
ECL_UCD_GENERAL_CATEGORY_Cc,
ECL_UCD_GENERAL_CATEGORY_Cf,
ECL_UCD_GENERAL_CATEGORY_Co,
ECL_UCD_GENERAL_CATEGORY_Cs,
ECL_UCD_GENERAL_CATEGORY_Mc,
ECL_UCD_GENERAL_CATEGORY_Me,
ECL_UCD_GENERAL_CATEGORY_Mn,
ECL_UCD_GENERAL_CATEGORY_Nd,
ECL_UCD_GENERAL_CATEGORY_Nl,
ECL_UCD_GENERAL_CATEGORY_No,
ECL_UCD_GENERAL_CATEGORY_Pc,
ECL_UCD_GENERAL_CATEGORY_Pd,
ECL_UCD_GENERAL_CATEGORY_Pe,
ECL_UCD_GENERAL_CATEGORY_Pf,
ECL_UCD_GENERAL_CATEGORY_Pi,
ECL_UCD_GENERAL_CATEGORY_Po,
ECL_UCD_GENERAL_CATEGORY_Ps,
ECL_UCD_GENERAL_CATEGORY_Sc,
ECL_UCD_GENERAL_CATEGORY_Sk,
ECL_UCD_GENERAL_CATEGORY_Sm,
ECL_UCD_GENERAL_CATEGORY_So,
ECL_UCD_GENERAL_CATEGORY_Zl,
ECL_UCD_GENERAL_CATEGORY_Zp,
ECL_UCD_GENERAL_CATEGORY_Zs,
};
enum {
ECL_UCD_BIDIRECTIONAL_CLASS_AL,
ECL_UCD_BIDIRECTIONAL_CLASS_AN,
ECL_UCD_BIDIRECTIONAL_CLASS_B,
ECL_UCD_BIDIRECTIONAL_CLASS_BN,
ECL_UCD_BIDIRECTIONAL_CLASS_CS,
ECL_UCD_BIDIRECTIONAL_CLASS_EN,
ECL_UCD_BIDIRECTIONAL_CLASS_ES,
ECL_UCD_BIDIRECTIONAL_CLASS_ET,
ECL_UCD_BIDIRECTIONAL_CLASS_FSI,
ECL_UCD_BIDIRECTIONAL_CLASS_L,
ECL_UCD_BIDIRECTIONAL_CLASS_LRE,
ECL_UCD_BIDIRECTIONAL_CLASS_LRI,
ECL_UCD_BIDIRECTIONAL_CLASS_LRO,
ECL_UCD_BIDIRECTIONAL_CLASS_NSM,
ECL_UCD_BIDIRECTIONAL_CLASS_ON,
ECL_UCD_BIDIRECTIONAL_CLASS_PDF,
ECL_UCD_BIDIRECTIONAL_CLASS_PDI,
ECL_UCD_BIDIRECTIONAL_CLASS_R,
ECL_UCD_BIDIRECTIONAL_CLASS_RLE,
ECL_UCD_BIDIRECTIONAL_CLASS_RLI,
ECL_UCD_BIDIRECTIONAL_CLASS_RLO,
ECL_UCD_BIDIRECTIONAL_CLASS_S,
ECL_UCD_BIDIRECTIONAL_CLASS_WS,
};
#define ECL_UCD_UPPERCASE_LIMIT 2
#define ECL_UCD_LOWERCASE_LIMIT 4
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment