summaryrefslogtreecommitdiffstats
path: root/tcl8.6/tools/uniParse.tcl
blob: 8125790aab8d4db4531aaf2333dd3fa1845129b3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
# 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.txt
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.


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.
}

proc uni::getValue {items index} {
    variable categories

    # Extract character info

    set category [lindex $items 2]
    if {[scan [lindex $items 12] %x toupper] == 1} {
	set toupper [expr {$index - $toupper}]
    } else {
	set toupper 0
    }
    if {[scan [lindex $items 13] %x tolower] == 1} {
	set tolower [expr {$tolower - $index}]
    } else {
	set tolower 0
    }
    if {[scan [lindex $items 14] %x totitle] == 1} {
	set totitle [expr {$index - $totitle}]
    } elseif {$tolower} {
	set totitle 0
    } else {
	set totitle $toupper
    }

    set categoryIndex [lsearch -exact $categories $category]
    if {$categoryIndex < 0} {
	error "Unexpected character category: $index($category)"
    }

    return [list $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
    variable shift

    set pIndex [lsearch -exact $pages $info]
    if {$pIndex == -1} {
	set pIndex [llength $pages]
	lappend pages $info
    }
    lappend pMap [expr {$pIndex << $shift}]
    return
}

proc uni::buildTables {data} {
    variable shift

    variable pMap {}
    variable pages {}
    variable groups {{0 0 0 0}}
    variable next 0
    set info {}			;# temporary page info

    set mask [expr {(1 << $shift) - 1}]

    foreach line [split $data \n] {
	if {$line eq ""} {
	    if {!($next & $mask)} {
		# next character is already on page boundary
		continue
	    }
	    # fill remaining page
	    set line [format %X [expr {($next-1)|$mask}]]
	    append line ";;Cn;0;ON;;;;;N;;;;;\n"
	}

	set items [split $line \;]

	scan [lindex $items 0] %x index
	if {$index > 0x2ffff} then {
	    # Ignore non-BMP characters, as long as Tcl doesn't support them
	    continue
	}
	set index [format %d $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} {
	    # 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 {($i & $mask) == $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 next

    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]*2 + ([llength $pages]<<$shift)}]
    puts "shift = $shift, space = $size"

    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.
 */

/*
 * 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 const unsigned short pageMap\[\] = {"
    set line "    "
    set last [expr {[llength $pMap] - 1}]
    for {set i 0} {$i <= $last} {incr i} {
	if {$i == [expr {0x10000 >> $shift}]} {
	    set line [string trimright $line " \t,"]
	    puts $f $line
	    set lastpage [expr {[lindex $line end] >> $shift}]
	    puts stdout "lastpage: $lastpage"
	    puts $f "#if TCL_UTF_MAX > 3"
	    set line "    ,"
	}
	append line [lindex $pMap $i]
	if {$i != $last} {
	    append line ", "
	}
	if {[string length $line] > 70} {
	    puts $f [string trimright $line]
	    set line "    "
	}
    }
    puts $f $line
    puts $f "#endif /* TCL_UTF_MAX > 3 */"
    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 const 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}]
	if {$i == ($lastpage + 1)} {
	    puts $f [string trimright $line " \t,"]
	    puts $f "#if TCL_UTF_MAX > 3"
	    set line "    ,"
	}
	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 [string trimright $line]
		set line "    "
	    }
	}
    }
    puts $f $line
    puts $f "#endif /* TCL_UTF_MAX > 3 */"
    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 = subtract delta for title/upper
 *				 101 = sub delta for upper, sub 1 for title
 *				 110 = sub delta for upper, add delta for lower
 *
 * Bits 8-31	Case delta: delta for case conversions.  This should be the
 *			    highest field so we can easily sign extend.
 */

static const int groups\[\] = {"
    set line "    "
    set last [expr {[llength $groups] - 1}]
    for {set i 0} {$i <= $last} {incr i} {
	foreach {type toupper tolower totitle} [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
		if {$tolower} {
		    error "New case conversion type needed: $toupper $tolower $totitle"
		}
	    } elseif {$toupper} {
		# subtract delta for upper, subtract 1 for title
		set case 5
		set delta $toupper
		if {($totitle != 1) || $tolower} {
		    error "New case conversion type needed: $toupper $tolower $totitle"
		}
	    } else {
		# add delta for lower, add 1 for title
		set case 3
		set delta $tolower
		if {$totitle != -1} {
		    error "New case conversion type needed: $toupper $tolower $totitle"
		}
	    }
	} elseif {$toupper} {
	    # subtract delta for upper, add delta for lower
	    set case 6
	    set delta $toupper
	    if {$tolower != $toupper} {
		error "New case conversion type needed: $toupper $tolower $totitle"
	    }
	} elseif {$tolower} {
	    # add delta for lower
	    set case 2
	    set delta $tolower
	} else {
	    # noop
	    set case 0
	    set delta 0
	}

	append line [expr {($delta << 8) | ($case << 5) | $type}]
	if {$i != $last} {
	    append line ", "
	}
	if {[string length $line] > 65} {
	    puts $f [string trimright $line]
	    set line "    "
	}
    }
    puts $f $line
    puts -nonewline $f "};

#if TCL_UTF_MAX > 3
#   define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= [format 0x%x $next])
#else
#   define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0)
#endif

/*
 * The following constants are used to determine the category of a
 * Unicode character.
 */

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(ch) (GetUniCharInfo(ch) & 0x1f)
#define GetDelta(info) ((info) >> 8)

/*
 * This macro extracts the information about a character from the
 * Unicode character tables.
 */

#if TCL_UTF_MAX > 3
#   define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1fffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#else
#   define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#endif
"

    close $f
}

uni::main

return