diff options
author | stanton <stanton@noemail.net> | 1999-04-16 00:46:29 (GMT) |
---|---|---|
committer | stanton <stanton@noemail.net> | 1999-04-16 00:46:29 (GMT) |
commit | 98569293dc21e22480004e4e3f2ce85ec0bfd80f (patch) | |
tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /tools/uniParse.tcl | |
parent | 6a4a1d8213f4de5bce0eaafa8f4d86117022bf1a (diff) | |
download | tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.zip tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.tar.gz tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.tar.bz2 |
merged tcl 8.1 branch back into the main trunk
FossilOrigin-Name: f3b32fb71c9011ac220779bd9dbe5617c9dc87d9
Diffstat (limited to 'tools/uniParse.tcl')
-rw-r--r-- | tools/uniParse.tcl | 369 |
1 files changed, 369 insertions, 0 deletions
diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl new file mode 100644 index 0000000..f92275f --- /dev/null +++ b/tools/uniParse.tcl @@ -0,0 +1,369 @@ +namespace eval uni { + set shift 9 ;# number of bits of data within a page + variable pMap ;# map from page to page index, each entry is + # an index into the pages table, indexed by + # page number + variable pages ;# map from page index to page info, each + # entry is a list of indices into the groups + # table, the list is indexed by the offset + variable groups ;# list of character info values, indexed by + # group number, initialized with the + # unassigned character group + + variable categories { + Cn Lu Ll Lt Lm Lo Mn Me Mc Nd Nl No Zs Zl Zp + Cc Cf Co Cs Pc Pd Ps Pe Pi Pf Po Sm Sc Sk So + } ;# Ordered list of character categories, must + # match the enumeration in the header file. + + variable titleCount 0 ;# Count of the number of title case + # characters. This value is used in the + # regular expression code to allocate enough + # space for the title case variants. +} + +proc uni::getValue {items index} { + variable categories + variable titleCount + + # Extract character info + + set category [lindex $items 2] + if {[scan [lindex $items 12] %4x toupper] == 1} { + set toupper [expr {$index - $toupper}] + } else { + set toupper {} + } + if {[scan [lindex $items 13] %4x tolower] == 1} { + set tolower [expr {$tolower - $index}] + } else { + set tolower {} + } + if {[scan [lindex $items 14] %4x totitle] == 1} { + set totitle [expr {$index - $totitle}] + } else { + set totitle {} + } + + set categoryIndex [lsearch -exact $categories $category] + if {$categoryIndex < 0} { + puts "Unexpected character category: $index($category)" + set categoryIndex 0 + } elseif {$category == "Lt"} { + incr titleCount + } + + return "$categoryIndex,$toupper,$tolower,$totitle" +} + +proc uni::getGroup {value} { + variable groups + + set gIndex [lsearch -exact $groups $value] + if {$gIndex == -1} { + set gIndex [llength $groups] + lappend groups $value + } + return $gIndex +} + +proc uni::addPage {info} { + variable pMap + variable pages + + set pIndex [lsearch -exact $pages $info] + if {$pIndex == -1} { + set pIndex [llength $pages] + lappend pages $info + } + lappend pMap $pIndex + return +} + +proc uni::buildTables {data} { + variable shift + + variable pMap {} + variable pages {} + variable groups {{0,,,}} + set info {} ;# temporary page info + + set mask [expr {(1 << $shift) - 1}] + + set next 0 + + foreach line [split $data \n] { + if {$line == ""} { + set line "FFFF;;Cn;0;ON;;;;;N;;;;;\n" + } + + set items [split $line \;] + + scan [lindex $items 0] %4x index + set index [format 0x%0.4x $index] + + set gIndex [getGroup [getValue $items $index]] + + # Since the input table omits unassigned characters, these will + # show up as gaps in the index sequence. There are a few special cases + # where the gaps correspond to a uniform block of assigned characters. + # These are indicated as such in the character name. + + # Enter all unassigned characters up to the current character. + if {($index > $next) \ + && ![regexp "Last>$" [lindex $items 1]]} { + for {} {$next < $index} {incr next} { + lappend info 0 + if {($next & $mask) == $mask} { + addPage $info + set info {} + } + } + } + + # Enter all assigned characters up to the current character + for {set i $next} {$i <= $index} {incr i} { + # Split character index into offset and page number + set offset [expr {$i & $mask}] + set page [expr {($i >> $shift)}] + + # Add the group index to the info for the current page + lappend info $gIndex + + # If this is the last entry in the page, add the page + if {$offset == $mask} { + addPage $info + set info {} + } + } + set next [expr {$index + 1}] + } + return +} + +proc uni::main {} { + global argc argv0 argv + variable pMap + variable pages + variable groups + variable shift + variable titleCount + + if {$argc != 2 && $argc != 3} { + puts stderr "\nusage: $argv0 <datafile> <outdir> ?optimize?\n" + exit 1 + } + set f [open [lindex $argv 0] r] + set data [read $f] + close $f + + set shift 6 + buildTables $data + puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]" + set size [expr {[llength $pMap] + [llength $pages]*(1<<$shift)}] + puts "shift = 6, space = $size" + puts "title case count = $titleCount" + + set f [open [file join [lindex $argv 1] tclUniData.c] w] + puts $f "/* + * tclUtfData.c -- + * + * Declarations of Unicode character information tables. This file is + * automatically generated by the tools/uniParse.tcl script. Do not + * modify this file by hand. + * + * Copyright (c) 1998 by Scriptics Corporation. + * All rights reserved. + * + * RCS: @(#) \$Id\$ + */ + +/* + * A 16-bit Unicode character is split into two parts in order to index + * into the following tables. The lower OFFSET_BITS comprise an offset + * into a page of characters. The upper bits comprise the page number. + */ + +#define OFFSET_BITS $shift + +/* + * The pageMap is indexed by page number and returns an alternate page number + * that identifies a unique page of characters. Many Unicode characters map + * to the same alternate page number. + */ + +static char pageMap\[\] = {" + set line " " + set last [expr {[llength $pMap] - 1}] + for {set i 0} {$i <= $last} {incr i} { + append line [lindex $pMap $i] + if {$i != $last} { + append line ", " + } + if {[string length $line] > 70} { + puts $f $line + set line " " + } + } + puts $f $line + puts $f "}; + +/* + * The groupMap is indexed by combining the alternate page number with + * the page offset and returns a group number that identifies a unique + * set of character attributes. + */ + +static char groupMap\[\] = {" + set line " " + set lasti [expr {[llength $pages] - 1}] + for {set i 0} {$i <= $lasti} {incr i} { + set page [lindex $pages $i] + set lastj [expr {[llength $page] - 1}] + for {set j 0} {$j <= $lastj} {incr j} { + append line [lindex $page $j] + if {$j != $lastj || $i != $lasti} { + append line ", " + } + if {[string length $line] > 70} { + puts $f $line + set line " " + } + } + } + puts $f $line + puts $f "}; + +/* + * Each group represents a unique set of character attributes. The attributes + * are encoded into a 32-bit value as follows: + * + * Bits 0-4 Character category: see the constants listed below. + * + * Bits 5-7 Case delta type: 000 = identity + * 010 = add delta for lower + * 011 = add delta for lower, add 1 for title + * 100 = sutract delta for title/upper + * 101 = sub delta for upper, sub 1 for title + * 110 = sub delta for upper, add delta for lower + * + * Bits 8-21 Reserved for future use. + * + * Bits 22-31 Case delta: delta for case conversions. This should be the + * highest field so we can easily sign extend. + */ + +static int groups\[\] = {" + set line " " + set last [expr {[llength $groups] - 1}] + for {set i 0} {$i <= $last} {incr i} { + foreach {type toupper tolower totitle} [split [lindex $groups $i] ,] {} + + # Compute the case conversion type and delta + + if {$totitle != ""} { + if {$totitle == $toupper} { + # subtract delta for title or upper + set case 4 + set delta $toupper + } elseif {$toupper != ""} { + # subtract delta for upper, subtract 1 for title + set case 5 + set delta $toupper + } else { + # add delta for lower, add 1 for title + set case 3 + set delta $tolower + } + } elseif {$toupper != ""} { + # subtract delta for upper, add delta for lower + set case 6 + set delta $toupper + } elseif {$tolower != ""} { + # add delta for lower + set case 2 + set delta $tolower + } else { + # noop + set case 0 + set delta 0 + } + + set val [expr {($delta << 22) | ($case << 5) | $type}] + + append line [format "%d" $val] + if {$i != $last} { + append line ", " + } + if {[string length $line] > 65} { + puts $f $line + set line " " + } + } + puts $f $line + puts $f "}; + +/* + * The following constants are used to determine the category of a + * Unicode character. + */ + +#define UNICODE_CATEGORY_MASK 0X1F + +enum { + UNASSIGNED, + UPPERCASE_LETTER, + LOWERCASE_LETTER, + TITLECASE_LETTER, + MODIFIER_LETTER, + OTHER_LETTER, + NON_SPACING_MARK, + ENCLOSING_MARK, + COMBINING_SPACING_MARK, + DECIMAL_DIGIT_NUMBER, + LETTER_NUMBER, + OTHER_NUMBER, + SPACE_SEPARATOR, + LINE_SEPARATOR, + PARAGRAPH_SEPARATOR, + CONTROL, + FORMAT, + PRIVATE_USE, + SURROGATE, + CONNECTOR_PUNCTUATION, + DASH_PUNCTUATION, + OPEN_PUNCTUATION, + CLOSE_PUNCTUATION, + INITIAL_QUOTE_PUNCTUATION, + FINAL_QUOTE_PUNCTUATION, + OTHER_PUNCTUATION, + MATH_SYMBOL, + CURRENCY_SYMBOL, + MODIFIER_SYMBOL, + OTHER_SYMBOL +}; + +/* + * The following macros extract the fields of the character info. The + * GetDelta() macro is complicated because we can't rely on the C compiler + * to do sign extension on right shifts. + */ + +#define GetCaseType(info) (((info) & 0xE0) >> 5) +#define GetCategory(info) ((info) & 0x1F) +#define GetDelta(infO) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22))) + +/* + * This macro extracts the information about a character from the + * Unicode character tables. + */ + +#define GetUniCharInfo(ch) (groups\[groupMap\[(pageMap\[(((int)(ch)) & 0xffff) >> OFFSET_BITS\] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1))\]\]) +" + + close $f +} + +uni::main + +return |