source: downloads/tcl8.5.2/tools/uniParse.tcl @ 45

# uniParse.tcl --
#
#       This program parses the UnicodeData file and generates the
#       corresponding tclUniData.c file with compressed character
#       data tables.  The input to this program should be the latest
#       UnicodeData file from:
#           ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData-Latest.txt
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id: uniParse.tcl,v 1.4 2001/05/28 04:37:57 hobbs Exp $


namespace eval uni {
    set shift 5;                # number of bits of data within a page
                                # This value can be adjusted to find the
                                # best split to minimize table size

    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} {
        puts stderr "\nusage: $argv0 <datafile> <outdir>\n"
        exit 1
    }
    set f [open [lindex $argv 0] r]
    set data [read $f]
    close $f

    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]
    fconfigure $f -translation lf
    puts $f "/*
 * tclUniData.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 unsigned 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 unsigned 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