merge trunk

See: [https://msdn.microsoft.com/en-us/library/20bw873z%28v=vs.110%29.aspx#WordCharacter]

doc/StringObj.3

@@ -37,7 +37,7 @@ Tcl_UniChar *
 Tcl_UniChar *
 \fBTcl_GetUnicode\fR(\fIobjPtr\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_GetUniChar\fR(\fIobjPtr, index\fR)
 .sp
 int

doc/ToUpper.3

@@ -13,13 +13,13 @@ Tcl_UniCharToUpper, Tcl_UniCharToLower, Tcl_UniCharToTitle, Tcl_UtfToUpper, Tcl_
 .nf
 \fB#include <tcl.h>\fR
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharToUpper\fR(\fIch\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharToLower\fR(\fIch\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharToTitle\fR(\fIch\fR)
 .sp
 int

doc/Utf.3

@@ -63,7 +63,7 @@ const char *
 const char *
 \fBTcl_UtfPrev\fR(\fIsrc, start\fR)
 .sp
-Tcl_UniChar
+int
 \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
 .sp
 const char *
@@ -232,7 +232,7 @@ the start of the UTF-8 string.  If \fIsrc\fR was already at \fIstart\fR, the
 return value will be \fIstart\fR.
 .PP
 \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the
-Pascal Ord() function.  It returns the Tcl_UniChar represented at the
+Pascal Ord() function.  It returns the Unicode character represented at the
 specified character (not byte) \fIindex\fR in the UTF-8 string
 \fIsrc\fR.  The source string must contain at least \fIindex\fR
 characters.  Behavior is undefined if a negative \fIindex\fR is given.

doc/timerate.n

@@ -0,0 +1,114 @@
+'\"
+'\" Copyright (c) 2005 Sergey Brester aka sebres.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH timerate n "" Tcl "Tcl Built-In Commands"
+.so man.macros
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+timerate \- Time-related execution resp. performance measurement of a script
+.SH SYNOPSIS
+\fBtimerate \fIscript\fR \fI?time?\fR
+.sp
+\fBtimerate \fI?-direct?\fR \fI?-overhead double?\fR \fIscript\fR \fI?time?\fR
+.sp
+\fBtimerate \fI?-calibrate?\fR \fI?-direct?\fR \fIscript\fR \fI?time?\fR
+.BE
+.SH DESCRIPTION
+.PP
+The first and second form will evaluate \fIscript\fR until the interval
+\fItime\fR given in milliseconds elapses, or for 1000 milliseconds (1 second)
+if \fItime\fR is not specified. 
+.sp
+It will then return a canonical tcl-list of the form
+.PP
+.CS
+\f0.095977 µs/# 52095836 # 10419167 #/sec 5000.000 nett-ms\fR
+.CE
+.PP
+which indicates:
+.IP \(bu
+the average amount of time required per iteration, in microseconds (lindex $result 0)
+.IP \(bu
+the count how many times it was executed (lindex $result 2)
+.IP \(bu
+the estimated rate per second (lindex $result 4)
+.IP \(bu
+the estimated real execution time without measurement overhead (lindex $result 6)
+.PP
+Time is measured in elapsed time using heighest timer resolution as possible, not CPU time.
+This command may be used to provide information as to how well the script or a tcl-command 
+is performing and can help determine bottlenecks and fine-tune application performance.
+.PP
+\fI-calibrate\fR
+.
+To measure very fast scripts as exact as posible the calibration process
+may be required.
+
+This parameter used to calibrate \fBtimerate\fR calculating the estimated overhead 
+of given \fIscript\fR as default overhead for further execution of \fBtimerate\fR.
+It can take up to 10 seconds if parameter \fItime\fR is not specified.
+.PP
+\fI-overhead double\fR
+.
+This parameter used to supply the measurement overhead of single iteration 
+(in microseconds) that should be ignored during whole evaluation process.
+.PP
+\fI-direct\fR
+.
+Causes direct execution per iteration (not compiled variant of evaluation used).
+.PP
+In opposition to \fBtime\fR the execution limited here by fixed time instead of 
+repetition count.
+Additionally the compiled variant of the script will be used during whole evaluation 
+(as if it were part of a compiled \fBproc\fR), if parameter \fI-direct\fR is not specified.
+Therefore it provides more precise results and prevents very long execution time 
+by slow scripts resp. scripts with unknown speed.
+
+.SH EXAMPLE
+Estimate how fast it takes for a simple Tcl \fBfor\fR loop (including
+operations on variable \fIi\fR) to count to a ten:
+.PP
+.CS
+# calibrate:
+timerate -calibrate {}
+# measure:
+timerate { for {set i 0} {$i<10} {incr i} {} } 5000
+.CE
+.PP
+Estimate how fast it takes for a simple Tcl \fBfor\fR loop only (ignoring the 
+overhead for operations on variable \fIi\fR) to count to a ten:
+.PP
+.CS
+# calibrate for overhead of variable operations:
+set i 0; timerate -calibrate {expr {$i<10}; incr i} 1000
+# measure:
+timerate { for {set i 0} {$i<10} {incr i} {} } 5000
+.CE
+.PP
+Estimate the rate of calculating the hour using \fBclock format\fR only, ignoring 
+overhead of the rest, without measurement how fast it takes for a whole script:
+.PP
+.CS
+# calibrate:
+timerate -calibrate {}
+# estimate overhead:
+set tm 0
+set ovh [lindex [timerate { incr tm [expr {24*60*60}] }] 0]
+# measure using esimated overhead:
+set tm 0
+timerate -overhead $ovh {
+    clock format $tm -format %H
+    incr tm [expr {24*60*60}]; # overhead for this is ignored
+} 5000
+.CE
+.SH "SEE ALSO"
+time(n)
+.SH KEYWORDS
+script, timerate, time
+.\" Local Variables:
+.\" mode: nroff
+.\" End:

generic/tcl.decls

@@ -1148,16 +1148,16 @@ declare 319 {
 	    Tcl_QueuePosition position)
 }
 declare 320 {
-    Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
+    int Tcl_UniCharAtIndex(const char *src, int index)
 }
 declare 321 {
-    Tcl_UniChar Tcl_UniCharToLower(int ch)
+    int Tcl_UniCharToLower(int ch)
 }
 declare 322 {
-    Tcl_UniChar Tcl_UniCharToTitle(int ch)
+    int Tcl_UniCharToTitle(int ch)
 }
 declare 323 {
-    Tcl_UniChar Tcl_UniCharToUpper(int ch)
+    int Tcl_UniCharToUpper(int ch)
 }
 declare 324 {
     int Tcl_UniCharToUtf(int ch, char *buf)
@@ -1351,7 +1351,7 @@ declare 380 {
     int Tcl_GetCharLength(Tcl_Obj *objPtr)
 }
 declare 381 {
-    Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
+    int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
 }
 declare 382 {
     Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)

generic/tcl.h

@@ -2201,7 +2201,7 @@ typedef struct Tcl_EncodingType {
  */
 
 #ifndef TCL_UTF_MAX
-#define TCL_UTF_MAX		3
+#define TCL_UTF_MAX		4
 #endif
 
 /*

generic/tclCmdMZ.c

@@ -309,7 +309,7 @@ Tcl_RegexpObjCmd(
 	    eflags = 0;
 	} else if (offset > stringLength) {
 	    eflags = TCL_REG_NOTBOL;
-	} else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') {
+	} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
 	    eflags = 0;
 	} else {
 	    eflags = TCL_REG_NOTBOL;
@@ -491,7 +491,7 @@ Tcl_RegsubObjCmd(
     Tcl_RegExp regExpr;
     Tcl_RegExpInfo info;
     Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
-    Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
+    Tcl_UniChar ch = 0, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
 
     static const char *const options[] = {
 	"-all",		"-command",	"-expanded",	"-line",
@@ -1218,6 +1218,10 @@ Tcl_SplitObjCmd(
 	for ( ; stringPtr < end; stringPtr += len) {
 	    len = TclUtfToUniChar(stringPtr, &ch);
 
+	    if (!len) {
+	        continue;
+	    }
+
 	    /*
 	     * Assume Tcl_UniChar is an integral type...
 	     */
@@ -1814,8 +1818,14 @@ StringIsCmd(
 	}
 	end = string1 + length1;
 	for (; string1 < end; string1 += length2, failat++) {
+	    int fullchar;
 	    length2 = TclUtfToUniChar(string1, &ch);
-	    if (!chcomp(ch)) {
+	    fullchar = ch;
+	    if (!length2) {
+	    	length2 = TclUtfToUniChar(string1, &ch);
+	    	fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	    }
+	    if (!chcomp(fullchar)) {
 		result = 0;
 		break;
 	    }

generic/tclDate.h

@@ -0,0 +1,512 @@
+/*
+ * tclDate.h --
+ *
+ *	This header file handles common usage of clock primitives
+ *	between tclDate.c (yacc), tclClock.c and tclClockFmt.c.
+ *
+ * Copyright (c) 2014 Serg G. Brester (aka sebres)
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef _TCLCLOCK_H
+#define _TCLCLOCK_H
+
+/*
+ * Constants
+ */
+
+#define JULIAN_DAY_POSIX_EPOCH		2440588
+#define GREGORIAN_CHANGE_DATE		2361222
+#define SECONDS_PER_DAY			86400
+#define JULIAN_SEC_POSIX_EPOCH	      (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \
+					* SECONDS_PER_DAY)
+#define FOUR_CENTURIES			146097	/* days */
+#define JDAY_1_JAN_1_CE_JULIAN		1721424
+#define JDAY_1_JAN_1_CE_GREGORIAN	1721426
+#define ONE_CENTURY_GREGORIAN		36524	/* days */
+#define FOUR_YEARS			1461	/* days */
+#define ONE_YEAR			365	/* days */
+
+#define RODDENBERRY			1946	/* Another epoch (Hi, Jeff!) */
+
+
+#define CLF_OPTIONAL	       (1 << 0) /* token is non mandatory */
+#define CLF_POSIXSEC	       (1 << 1)
+#define CLF_LOCALSEC	       (1 << 2)
+#define CLF_JULIANDAY	       (1 << 3)
+#define CLF_TIME	       (1 << 4)
+#define CLF_CENTURY	       (1 << 6)
+#define CLF_DAYOFMONTH	       (1 << 7)
+#define CLF_DAYOFYEAR	       (1 << 8)
+#define CLF_MONTH	       (1 << 9)
+#define CLF_YEAR	       (1 << 10)
+#define CLF_ISO8601YEAR	       (1 << 12)
+#define CLF_ISO8601	       (1 << 13)
+#define CLF_ISO8601CENTURY     (1 << 14)
+#define CLF_SIGNED	       (1 << 15)
+/* On demand (lazy) assemble flags */
+#define CLF_ASSEMBLE_DATE      (1 << 28) /* assemble year, month, etc. using julianDay */
+#define CLF_ASSEMBLE_JULIANDAY (1 << 29) /* assemble julianDay using year, month, etc. */
+#define CLF_ASSEMBLE_SECONDS   (1 << 30) /* assemble localSeconds (and seconds at end) */
+
+#define CLF_DATE	       (CLF_JULIANDAY | CLF_DAYOFMONTH | CLF_DAYOFYEAR | \
+				CLF_MONTH | CLF_YEAR | CLF_ISO8601YEAR | CLF_ISO8601)
+
+/*
+ * Enumeration of the string literals used in [clock]
+ */
+
+typedef enum ClockLiteral {
+    LIT__NIL,
+    LIT__DEFAULT_FORMAT,
+    LIT_SYSTEM,		LIT_CURRENT,		LIT_C,
+    LIT_BCE,		LIT_CE,
+    LIT_DAYOFMONTH,	LIT_DAYOFWEEK,		LIT_DAYOFYEAR,
+    LIT_ERA,		LIT_GMT,		LIT_GREGORIAN,
+    LIT_INTEGER_VALUE_TOO_LARGE,
+    LIT_ISO8601WEEK,	LIT_ISO8601YEAR,
+    LIT_JULIANDAY,	LIT_LOCALSECONDS,
+    LIT_MONTH,
+    LIT_SECONDS,	LIT_TZNAME,		LIT_TZOFFSET,
+    LIT_YEAR,
+    LIT_TZDATA,
+    LIT_GETSYSTEMTIMEZONE,
+    LIT_SETUPTIMEZONE,
+    LIT_MCGET,
+    LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE,
+    LIT_LOCALIZE_FORMAT,
+    LIT__END
+} ClockLiteral;
+
+#define CLOCK_LITERAL_ARRAY(litarr) static const char *const litarr[] = { \
+    "", \
+    "%a %b %d %H:%M:%S %Z %Y", \
+    "system",		"current",		"C", \
+    "BCE",		"CE", \
+    "dayOfMonth",	"dayOfWeek",		"dayOfYear", \
+    "era",		":GMT",			"gregorian", \
+    "integer value too large to represent", \
+    "iso8601Week",	"iso8601Year", \
+    "julianDay",	"localSeconds", \
+    "month", \
+    "seconds",		"tzName",		"tzOffset", \
+    "year", \
+    "::tcl::clock::TZData", \
+    "::tcl::clock::GetSystemTimeZone", \
+    "::tcl::clock::SetupTimeZone", \
+    "::tcl::clock::mcget", \
+    "::tcl::clock::GetSystemLocale", "::tcl::clock::mclocale", \
+    "::tcl::clock::LocalizeFormat" \
+}
+
+/*
+ * Enumeration of the msgcat literals used in [clock]
+ */
+
+typedef enum ClockMsgCtLiteral {
+    MCLIT__NIL, /* placeholder */
+    MCLIT_MONTHS_FULL,	MCLIT_MONTHS_ABBREV,  MCLIT_MONTHS_COMB,
+    MCLIT_DAYS_OF_WEEK_FULL,  MCLIT_DAYS_OF_WEEK_ABBREV,  MCLIT_DAYS_OF_WEEK_COMB,
+    MCLIT_AM,  MCLIT_PM,
+    MCLIT_LOCALE_ERAS,
+    MCLIT_BCE,	 MCLIT_CE,
+    MCLIT_BCE2,	 MCLIT_CE2,
+    MCLIT_BCE3,	 MCLIT_CE3,
+    MCLIT_LOCALE_NUMERALS,
+    MCLIT__END
+} ClockMsgCtLiteral;
+
+#define CLOCK_LOCALE_LITERAL_ARRAY(litarr, pref) static const char *const litarr[] = { \
+    pref "", \
+    pref "MONTHS_FULL", pref "MONTHS_ABBREV", pref "MONTHS_COMB", \
+    pref "DAYS_OF_WEEK_FULL", pref "DAYS_OF_WEEK_ABBREV", pref "DAYS_OF_WEEK_COMB", \
+    pref "AM", pref "PM", \
+    pref "LOCALE_ERAS", \
+    pref "BCE",	   pref "CE", \
+    pref "b.c.e.", pref "c.e.", \
+    pref "b.c.",   pref "a.d.", \
+    pref "LOCALE_NUMERALS", \
+}
+
+/*
+ * Structure containing the fields used in [clock format] and [clock scan]
+ */
+
+typedef struct TclDateFields {
+
+    /* Cacheable fields:	 */
+
+    Tcl_WideInt seconds;	/* Time expressed in seconds from the Posix
+				 * epoch */
+    Tcl_WideInt localSeconds;	/* Local time expressed in nominal seconds
+				 * from the Posix epoch */
+    int tzOffset;		/* Time zone offset in seconds east of
+				 * Greenwich */
+    int julianDay;		/* Julian Day Number in local time zone */
+    enum {BCE=1, CE=0} era;	/* Era */
+    int gregorian;		/* Flag == 1 if the date is Gregorian */
+    int year;			/* Year of the era */
+    int dayOfYear;		/* Day of the year (1 January == 1) */
+    int month;			/* Month number */
+    int dayOfMonth;		/* Day of the month */
+    int iso8601Year;		/* ISO8601 week-based year */
+    int iso8601Week;		/* ISO8601 week number */
+    int dayOfWeek;		/* Day of the week */
+    int hour;			/* Hours of day (in-between time only calculation) */
+    int minutes;		/* Minutes of day (in-between time only calculation) */
+    int secondOfDay;		/* Seconds of day (in-between time only calculation) */
+
+    /* Non cacheable fields:	 */
+
+    Tcl_Obj *tzName;		/* Name (or corresponding DST-abbreviation) of the
+				 * time zone, if set the refCount is incremented */
+} TclDateFields;
+
+#define ClockCacheableDateFieldsSize \
+    TclOffset(TclDateFields, tzName)
+
+/*
+ * Structure contains return parsed fields.
+ */
+
+typedef struct DateInfo {
+    const char *dateStart;
+    const char *dateInput;
+    const char *dateEnd;
+
+    TclDateFields date;
+
+    int		flags;
+
+    int dateHaveDate;
+
+    int dateMeridian;
+    int dateHaveTime;
+
+    int dateTimezone;
+    int dateDSTmode;
+    int dateHaveZone;
+
+    int dateRelMonth;
+    int dateRelDay;
+    int dateRelSeconds;
+    int dateHaveRel;
+
+    int dateMonthOrdinalIncr;
+    int dateMonthOrdinal;
+    int dateHaveOrdinalMonth;
+
+    int dateDayOrdinal;
+    int dateDayNumber;
+    int dateHaveDay;
+
+    int *dateRelPointer;
+
+    int dateSpaceCount;
+    int dateDigitCount;
+
+    int dateCentury;
+
+    Tcl_Obj* messages;	    /* Error messages */
+    const char* separatrix; /* String separating messages */
+} DateInfo;
+
+#define yydate	    (info->date)  /* Date fields used for converting */
+
+#define yyDay	    (info->date.dayOfMonth)
+#define yyMonth	    (info->date.month)
+#define yyYear	    (info->date.year)
+
+#define yyHour	    (info->date.hour)
+#define yyMinutes   (info->date.minutes)
+#define yySeconds   (info->date.secondOfDay)
+
+#define yyDSTmode   (info->dateDSTmode)
+#define yyDayOrdinal	(info->dateDayOrdinal)
+#define yyDayNumber (info->dateDayNumber)
+#define yyMonthOrdinalIncr  (info->dateMonthOrdinalIncr)
+#define yyMonthOrdinal	(info->dateMonthOrdinal)
+#define yyHaveDate  (info->dateHaveDate)
+#define yyHaveDay   (info->dateHaveDay)
+#define yyHaveOrdinalMonth (info->dateHaveOrdinalMonth)
+#define yyHaveRel   (info->dateHaveRel)
+#define yyHaveTime  (info->dateHaveTime)
+#define yyHaveZone  (info->dateHaveZone)
+#define yyTimezone  (info->dateTimezone)
+#define yyMeridian  (info->dateMeridian)
+#define yyRelMonth  (info->dateRelMonth)
+#define yyRelDay    (info->dateRelDay)
+#define yyRelSeconds	(info->dateRelSeconds)
+#define yyRelPointer	(info->dateRelPointer)
+#define yyInput	    (info->dateInput)
+#define yyDigitCount	(info->dateDigitCount)
+#define yySpaceCount	(info->dateSpaceCount)
+
+static inline void
+ClockInitDateInfo(DateInfo *info) {
+    memset(info, 0, sizeof(DateInfo));
+}
+
+/*
+ * Structure containing the command arguments supplied to [clock format] and [clock scan]
+ */
+
+#define CLF_EXTENDED	(1 << 4)
+#define CLF_STRICT	(1 << 8)
+#define CLF_LOCALE_USED (1 << 15)
+
+typedef struct ClockFmtScnCmdArgs {
+    ClientData clientData;  /* Opaque pointer to literal pool, etc. */
+    Tcl_Interp *interp;	    /* Tcl interpreter */
+
+    Tcl_Obj *formatObj;	    /* Format */
+    Tcl_Obj *localeObj;	    /* Name of the locale where the time will be expressed. */
+    Tcl_Obj *timezoneObj;   /* Default time zone in which the time will be expressed */
+    Tcl_Obj *baseObj;	    /* Base (scan and add) or clockValue (format) */
+    int	     flags;	    /* Flags control scanning */
+
+    Tcl_Obj *mcDictObj;	    /* Current dictionary of tcl::clock package for given localeObj*/
+} ClockFmtScnCmdArgs;
+
+/*
+ * Structure containing the client data for [clock]
+ */
+
+typedef struct ClockClientData {
+    size_t    refCount;		/* Number of live references. */
+    Tcl_Obj **literals;		/* Pool of object literals (common, locale independent). */
+    Tcl_Obj **mcLiterals;	/* Msgcat object literals with mc-keys for search with locale. */
+    Tcl_Obj **mcLitIdxs;	/* Msgcat object indices prefixed with _IDX_,
+				 * used for quick dictionary search */
+
+    /* Cache for current clock parameters, imparted via "configure" */
+    unsigned long LastTZEpoch;
+    int currentYearCentury;
+    int yearOfCenturySwitch;
+    Tcl_Obj *SystemTimeZone;
+    Tcl_Obj *SystemSetupTZData;
+    Tcl_Obj *GMTSetupTimeZone;
+    Tcl_Obj *GMTSetupTZData;
+    Tcl_Obj *AnySetupTimeZone;
+    Tcl_Obj *AnySetupTZData;
+    Tcl_Obj *LastUnnormSetupTimeZone;
+    Tcl_Obj *LastSetupTimeZone;
+    Tcl_Obj *LastSetupTZData;
+
+    Tcl_Obj *CurrentLocale;
+    Tcl_Obj *CurrentLocaleDict;
+    Tcl_Obj *LastUnnormUsedLocale;
+    Tcl_Obj *LastUsedLocale;
+    Tcl_Obj *LastUsedLocaleDict;
+
+    /* Cache for last base (last-second fast convert if base/tz not changed) */
+    struct {
+	Tcl_Obj *timezoneObj;
+	TclDateFields Date;
+    } lastBase;
+    /* Las-period cache for fast UTC2Local conversion */
+    struct {
+	/* keys */
+	Tcl_Obj	   *timezoneObj;
+	int	    changeover;
+	Tcl_WideInt seconds;
+	Tcl_WideInt rangesVal[2];   /* Bounds for cached time zone offset */
+	/* values */
+	int	    tzOffset;
+	Tcl_Obj	   *tzName;
+    } UTC2Local;
+    /* Las-period cache for fast Local2UTC conversion */
+    struct {
+	/* keys */
+	Tcl_Obj	   *timezoneObj;
+	int	    changeover;
+	Tcl_WideInt localSeconds;
+	Tcl_WideInt rangesVal[2];   /* Bounds for cached time zone offset */
+	/* values */
+	int	    tzOffset;
+    } Local2UTC;
+} ClockClientData;
+
+#define ClockDefaultYearCentury 2000
+#define ClockDefaultCenturySwitch 38
+
+/*
+ * Meridian: am, pm, or 24-hour style.
+ */
+
+typedef enum _MERIDIAN {
+    MERam, MERpm, MER24
+} MERIDIAN;
+
+/*
+ * Clock scan and format facilities.
+ */
+
+#define CLOCK_FMT_SCN_STORAGE_GC_SIZE 32
+
+#define CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE 2
+
+typedef struct ClockScanToken ClockScanToken;
+
+
+typedef int ClockScanTokenProc(
+	ClockFmtScnCmdArgs *opts,
+	DateInfo *info,
+	ClockScanToken *tok);
+
+
+typedef enum _CLCKTOK_TYPE {
+   CTOKT_DIGIT = 1, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR,
+   CFMTT_INT, CFMTT_WIDE, CFMTT_PROC
+} CLCKTOK_TYPE;
+
+typedef struct ClockScanTokenMap {
+    unsigned short int	type;
+    unsigned short int	flags;
+    unsigned short int	clearFlags;
+    unsigned short int	minSize;
+    unsigned short int	maxSize;
+    unsigned short int	offs;
+    ClockScanTokenProc *parser;
+    const void	       *data;
+} ClockScanTokenMap;
+
+typedef struct ClockScanToken {
+    ClockScanTokenMap  *map;
+    struct {
+	const char *start;
+	const char *end;
+    } tokWord;
+    unsigned short int	endDistance;
+    unsigned short int	lookAhMin;
+    unsigned short int	lookAhMax;
+    unsigned short int	lookAhTok;
+} ClockScanToken;
+
+
+#define MIN_FMT_RESULT_BLOCK_ALLOC 200
+
+typedef struct DateFormat {
+    char *resMem;
+    char *resEnd;
+    char *output;
+
+    TclDateFields date;
+
+    Tcl_Obj *localeEra;
+} DateFormat;
+
+#define CLFMT_INCR	    (1 << 3)
+#define CLFMT_DECR	    (1 << 4)
+#define CLFMT_CALC	    (1 << 5)
+#define CLFMT_LOCALE_INDX   (1 << 8)
+
+typedef struct ClockFormatToken ClockFormatToken;
+
+typedef int ClockFormatTokenProc(
+	ClockFmtScnCmdArgs *opts,
+	DateFormat *dateFmt,
+	ClockFormatToken *tok,
+	int *val);
+
+typedef struct ClockFormatTokenMap {
+    unsigned short int	type;
+    const char	       *tostr;
+    unsigned short int	width;
+    unsigned short int	flags;
+    unsigned short int	divider;
+    unsigned short int	divmod;
+    unsigned short int	offs;
+    ClockFormatTokenProc *fmtproc;
+    void	       *data;
+} ClockFormatTokenMap;
+typedef struct ClockFormatToken {
+    ClockFormatTokenMap *map;
+    struct {
+	const char *start;
+	const char *end;
+    } tokWord;
+} ClockFormatToken;
+
+
+typedef struct ClockFmtScnStorage ClockFmtScnStorage;
+
+typedef struct ClockFmtScnStorage {
+    int			 objRefCount;	/* Reference count shared across threads */
+    ClockScanToken	*scnTok;
+    unsigned int	 scnTokC;
+    unsigned int	 scnSpaceCount; /* Count of mandatory spaces used in format */
+    ClockFormatToken	*fmtTok;
+    unsigned int	 fmtTokC;
+#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0
+    ClockFmtScnStorage	*nextPtr;
+    ClockFmtScnStorage	*prevPtr;
+#endif
+#if 0
+   +Tcl_HashEntry    hashEntry		/* ClockFmtScnStorage is a derivate of Tcl_HashEntry,
+					 * stored by offset +sizeof(self) */
+#endif
+} ClockFmtScnStorage;
+
+/*
+ * Prototypes of module functions.
+ */
+
+MODULE_SCOPE int    ToSeconds(int Hours, int Minutes,
+			    int Seconds, MERIDIAN Meridian);
+MODULE_SCOPE int    IsGregorianLeapYear(TclDateFields *);
+MODULE_SCOPE void
+		    GetJulianDayFromEraYearWeekDay(
+			    TclDateFields *fields, int changeover);
+MODULE_SCOPE void
+		    GetJulianDayFromEraYearMonthDay(
+			    TclDateFields *fields, int changeover);
+MODULE_SCOPE void
+		    GetJulianDayFromEraYearDay(
+			    TclDateFields *fields, int changeover);
+MODULE_SCOPE int    ConvertUTCToLocal(ClientData clientData, Tcl_Interp *,
+			    TclDateFields *, Tcl_Obj *timezoneObj, int);
+MODULE_SCOPE Tcl_Obj *
+		    LookupLastTransition(Tcl_Interp *, Tcl_WideInt,
+			    int, Tcl_Obj *const *, Tcl_WideInt rangesVal[2]);
+
+MODULE_SCOPE int    TclClockFreeScan(Tcl_Interp *interp, DateInfo *info);
+
+/* tclClock.c module declarations */
+
+MODULE_SCOPE Tcl_Obj *
+		    ClockSetupTimeZone(ClientData clientData,
+		Tcl_Interp *interp, Tcl_Obj *timezoneObj);
+
+MODULE_SCOPE Tcl_Obj *
+		    ClockMCDict(ClockFmtScnCmdArgs *opts);
+MODULE_SCOPE Tcl_Obj *
+		    ClockMCGet(ClockFmtScnCmdArgs *opts, int mcKey);
+MODULE_SCOPE Tcl_Obj *
+		    ClockMCGetIdx(ClockFmtScnCmdArgs *opts, int mcKey);
+MODULE_SCOPE int    ClockMCSetIdx(ClockFmtScnCmdArgs *opts, int mcKey,
+			Tcl_Obj *valObj);
+
+/* tclClockFmt.c module declarations */
+
+MODULE_SCOPE Tcl_Obj*
+		    ClockFrmObjGetLocFmtKey(Tcl_Interp *interp,
+			Tcl_Obj *objPtr);
+
+MODULE_SCOPE ClockFmtScnStorage *
+		    Tcl_GetClockFrmScnFromObj(Tcl_Interp *interp,
+			Tcl_Obj *objPtr);
+MODULE_SCOPE Tcl_Obj *
+		    ClockLocalizeFormat(ClockFmtScnCmdArgs *opts);
+
+MODULE_SCOPE int    ClockScan(register DateInfo *info,
+			Tcl_Obj *strObj, ClockFmtScnCmdArgs *opts);
+
+MODULE_SCOPE int    ClockFormat(register DateFormat *dateFmt,
+			ClockFmtScnCmdArgs *opts);
+
+MODULE_SCOPE void   ClockFrmScnClearCaches(void);
+
+#endif /* _TCLCLOCK_H */

generic/tclDecls.h

@@ -959,13 +959,13 @@ EXTERN void		Tcl_ThreadAlert(Tcl_ThreadId threadId);
 EXTERN void		Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
 				Tcl_Event *evPtr, Tcl_QueuePosition position);
 /* 320 */
-EXTERN Tcl_UniChar	Tcl_UniCharAtIndex(const char *src, int index);
+EXTERN int		Tcl_UniCharAtIndex(const char *src, int index);
 /* 321 */
-EXTERN Tcl_UniChar	Tcl_UniCharToLower(int ch);
+EXTERN int		Tcl_UniCharToLower(int ch);
 /* 322 */
-EXTERN Tcl_UniChar	Tcl_UniCharToTitle(int ch);
+EXTERN int		Tcl_UniCharToTitle(int ch);
 /* 323 */
-EXTERN Tcl_UniChar	Tcl_UniCharToUpper(int ch);
+EXTERN int		Tcl_UniCharToUpper(int ch);
 /* 324 */
 EXTERN int		Tcl_UniCharToUtf(int ch, char *buf);
 /* 325 */
@@ -1117,7 +1117,7 @@ EXTERN void		Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
 /* 380 */
 EXTERN int		Tcl_GetCharLength(Tcl_Obj *objPtr);
 /* 381 */
-EXTERN Tcl_UniChar	Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
+EXTERN int		Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
 /* 382 */
 EXTERN Tcl_UniChar *	Tcl_GetUnicode(Tcl_Obj *objPtr);
 /* 383 */
@@ -2186,10 +2186,10 @@ typedef struct TclStubs {
     Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
     void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
     void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */
-    Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
-    Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */
-    Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
-    Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
+    int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
+    int (*tcl_UniCharToLower) (int ch); /* 321 */
+    int (*tcl_UniCharToTitle) (int ch); /* 322 */
+    int (*tcl_UniCharToUpper) (int ch); /* 323 */
     int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
     CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
     int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
@@ -2247,7 +2247,7 @@ typedef struct TclStubs {
     Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
     void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
     int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
-    Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
+    int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
     Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
     Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
     void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */

generic/tclEncoding.c

@@ -2353,7 +2353,9 @@ UtfToUtfProc(
 	    src += 1;
 	    dst += Tcl_UniCharToUtf(*chPtr, dst);
 	} else {
-	    src += TclUtfToUniChar(src, chPtr);
+	    int n = TclUtfToUniChar(src, chPtr);
+	    src += n;
+	    if (!n) numChars--;
 	    dst += Tcl_UniCharToUtf(*chPtr, dst);
 	}
     }
@@ -2446,7 +2448,9 @@ UnicodeToUtfProc(
 	if (*chPtr && *chPtr < 0x80) {
 	    *dst++ = (*chPtr & 0xFF);
 	} else {
-	    dst += Tcl_UniCharToUtf(*chPtr, dst);
+	    int n = Tcl_UniCharToUtf(*chPtr, dst);
+	    dst += n;
+	    if (!n) --numChars;/* Don't count high surrogates */
 	}
 	src += sizeof(Tcl_UniChar);
     }

generic/tclExecute.c

@@ -5447,7 +5447,7 @@ TEBCresume(
 		    valuePtr->bytes+index, 1);
 	} else {
 	    char buf[TCL_UTF_MAX];
-	    Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index);
+	    int ch = Tcl_GetUniChar(valuePtr, index);
 
 	    /*
 	     * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)

generic/tclParse.c

@@ -979,6 +979,15 @@ TclParseBackslash(
     if (readPtr != NULL) {
 	*readPtr = count;
     }
+    if ((result & 0xF800) == 0xD800) {
+	/* If result is a surrogate, Tcl_UniCharToUtf will try to
+	 * handle that especially, but we don't want that here.
+	 */
+	dst[2] = (char) ((result | 0x80) & 0xBF);
+	dst[1] = (char) (((result >> 6) | 0x80) & 0xBF);
+	dst[0] = (char) ((result >> 12) | 0xE0);
+	return 3;
+    }
     return Tcl_UniCharToUtf(result, dst);
 }
 

generic/tclScan.c

@@ -885,9 +885,15 @@ Tcl_ScanObjCmd(
 	     * Scan a single Unicode character.
 	     */
 
-	    string += TclUtfToUniChar(string, &sch);
+	    offset = TclUtfToUniChar(string, &sch);
+	    i = (int)sch;
+	    if (!offset) {
+		offset = Tcl_UtfToUniChar(string, &sch);
+		i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF);
+	    }
+	    string += offset;
 	    if (!(flags & SCAN_SUPPRESS)) {
-		objPtr = Tcl_NewIntObj((int)sch);
+		objPtr = Tcl_NewIntObj(i);
 		Tcl_IncrRefCount(objPtr);
 		CLANG_ASSERT(objs);
 		objs[objIndex++] = objPtr;

generic/tclStrIdxTree.c

@@ -0,0 +1,527 @@
+/*
+ * tclStrIdxTree.c --
+ *
+ *	Contains the routines for managing string index tries in Tcl.
+ *
+ *	This code is back-ported from the tclSE engine, by Serg G. Brester.
+ *
+ * Copyright (c) 2016 by Sergey G. Brester aka sebres. All rights reserved.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * -----------------------------------------------------------------------
+ *
+ * String index tries are prepaired structures used for fast greedy search of the string
+ * (index) by unique string prefix as key.
+ *
+ * Index tree build for two lists together can be explained in the following datagram
+ *
+ * Lists:
+ *
+ *	{Januar Februar Maerz April Mai Juni Juli August September Oktober November Dezember}
+ *	{Jnr Fbr Mrz Apr Mai Jni Jli Agt Spt Okt Nvb Dzb}
+ *
+ * Index-Tree:
+ *
+ *	j		 0	 *	...
+ *	 anuar		 1	 *
+ *	 u		 0	 *	a		 0
+ *	  ni		 6	 *	 pril		 4
+ *	  li		 7	 *	 ugust		 8
+ *	 n		 0	 *	 gt		 8
+ *	  r		 1	 *	s		 9
+ *	  i		 6	 *	 eptember	 9
+ *	 li		 7	 *	 pt		 9
+ *	f		 2	 *	oktober		10
+ *	 ebruar		 2	 *	n		11
+ *	 br		 2	 *	 ovember	11
+ *	m		 0	 *	 vb		11
+ *	 a		 0	 *	d		12
+ *	  erz		 3	 *	 ezember	12
+ *	  i		 5	 *	 zb		12
+ *	 rz		 3	 *
+ *	...
+ *
+ * Thereby value 0 shows pure group items (corresponding ambigous matches).
+ * But the group may have a value if it contains only same values
+ * (see for example group "f" above).
+ *
+ * StrIdxTree's are very fast, so:
+ *    build of above-mentioned tree takes about 10 microseconds.
+ *    search of string index in this tree takes fewer as 0.1 microseconds.
+ *
+ */
+
+#include "tclInt.h"
+#include "tclStrIdxTree.h"
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclStrIdxTreeSearch --
+ *
+ *  Find largest part of string "start" in indexed tree (case sensitive).
+ *
+ *  Also used for building of string index tree.
+ *
+ * Results:
+ *  Return position of UTF character in start after last equal character
+ *  and found item (with parent).
+ *
+ * Side effects:
+ *  None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE const char*
+TclStrIdxTreeSearch(
+    TclStrIdxTree **foundParent, /* Return value of found sub tree (used for tree build) */
+    TclStrIdx	  **foundItem,	 /* Return value of found item */
+    TclStrIdxTree  *tree,	 /* Index tree will be browsed */
+    const char	*start,		 /* UTF string to find in tree */
+    const char	*end)		 /* End of string */
+{
+    TclStrIdxTree *parent = tree, *prevParent = tree;
+    TclStrIdx  *item = tree->firstPtr, *prevItem = NULL;
+    const char *s = start, *f, *cin, *cinf, *prevf;
+    int offs = 0;
+
+    if (item == NULL) {
+	goto done;
+    }
+
+    /* search in tree */
+    do {
+	cinf = cin = TclGetString(item->key) + offs;
+	f = TclUtfFindEqualNCInLwr(s, end, cin, cin + item->length, &cinf);
+	/* if something was found */
+	if (f > s) {
+	    /* if whole string was found */
+	    if (f >= end) {
+		start = f;
+		goto done;
+	    };
+	    /* set new offset and shift start string */
+	    offs += cinf - cin;
+	    s = f;
+	    /* if match item, go deeper as long as possible */
+	    if (offs >= item->length && item->childTree.firstPtr) {
+		/* save previuosly found item (if not ambigous) for
+		 * possible fallback (few greedy match) */
+		if (item->value != NULL) {
+		    prevf = f;
+		    prevItem = item;
+		    prevParent = parent;
+		}
+		parent = &item->childTree;
+		item = item->childTree.firstPtr;
+		continue;
+	    }
+	    /* no children - return this item and current chars found */
+	    start = f;
+	    goto done;
+	}
+
+	item = item->nextPtr;
+
+    } while (item != NULL);
+
+    /* fallback (few greedy match) not ambigous (has a value) */
+    if (prevItem != NULL) {
+	item = prevItem;
+	parent = prevParent;
+	start = prevf;
+    }
+
+done:
+
+    if (foundParent)
+	*foundParent = parent;
+    if (foundItem)
+	*foundItem = item;
+    return start;
+}
+
+MODULE_SCOPE void
+TclStrIdxTreeFree(
+    TclStrIdx *tree)
+{
+    while (tree != NULL) {
+	TclStrIdx *t;
+	Tcl_DecrRefCount(tree->key);
+	if (tree->childTree.firstPtr != NULL) {
+	    TclStrIdxTreeFree(tree->childTree.firstPtr);
+	}
+	t = tree, tree = tree->nextPtr;
+	ckfree(t);
+    }
+}
+
+/*
+ * Several bidirectional list primitives
+ */
+inline void
+TclStrIdxTreeInsertBranch(
+    TclStrIdxTree *parent,
+    register TclStrIdx *item,
+    register TclStrIdx *child)
+{
+    if (parent->firstPtr == child)
+	parent->firstPtr = item;
+    if (parent->lastPtr == child)
+	parent->lastPtr = item;
+    if ( (item->nextPtr = child->nextPtr) ) {
+	item->nextPtr->prevPtr = item;
+	child->nextPtr = NULL;
+    }
+    if ( (item->prevPtr = child->prevPtr) ) {
+	item->prevPtr->nextPtr = item;
+	child->prevPtr = NULL;
+    }
+    item->childTree.firstPtr = child;
+    item->childTree.lastPtr = child;
+}
+
+inline void
+TclStrIdxTreeAppend(
+    register TclStrIdxTree *parent,
+    register TclStrIdx	   *item)
+{
+    if (parent->lastPtr != NULL) {
+	parent->lastPtr->nextPtr = item;
+    }
+    item->prevPtr = parent->lastPtr;
+    item->nextPtr = NULL;
+    parent->lastPtr = item;
+    if (parent->firstPtr == NULL) {
+	parent->firstPtr = item;
+    }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclStrIdxTreeBuildFromList --
+ *
+ * Build or extend string indexed tree from tcl list.
+ * If the values not given the values of built list are indices starts with 1.
+ * Value of 0 is thereby reserved to the ambigous values.
+ *
+ * Important: by multiple lists, optimal tree can be created only if list with
+ * larger strings used firstly.
+ *
+ * Results:
+ *  Returns a standard Tcl result.
+ *
+ * Side effects:
+ *  None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+MODULE_SCOPE int
+TclStrIdxTreeBuildFromList(
+    TclStrIdxTree *idxTree,
+    int	       lstc,
+    Tcl_Obj  **lstv,
+    ClientData *values)
+{
+    Tcl_Obj  **lwrv;
+    int i, ret = TCL_ERROR;
+    ClientData val;
+    const char *s, *e, *f;
+    TclStrIdx	*item;
+
+    /* create lowercase reflection of the list keys */
+
+    lwrv = ckalloc(sizeof(Tcl_Obj*) * lstc);
+    if (lwrv == NULL) {
+	return TCL_ERROR;
+    }
+    for (i = 0; i < lstc; i++) {
+	lwrv[i] = Tcl_DuplicateObj(lstv[i]);
+	if (lwrv[i] == NULL) {
+	    return TCL_ERROR;
+	}
+	Tcl_IncrRefCount(lwrv[i]);
+	lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i]));
+    }
+
+    /* build index tree of the list keys */
+    for (i = 0; i < lstc; i++) {
+	TclStrIdxTree *foundParent = idxTree;
+	e = s = TclGetString(lwrv[i]);
+	e += lwrv[i]->length;
+	val = values ? values[i] : INT2PTR(i+1);
+
+	/* ignore empty keys (impossible to index it) */
+	if (lwrv[i]->length == 0) continue;
+
+	item = NULL;
+	if (idxTree->firstPtr != NULL) {
+	    TclStrIdx  *foundItem;
+	    f = TclStrIdxTreeSearch(&foundParent, &foundItem,
+		idxTree, s, e);
+	    /* if common prefix was found */
+	    if (f > s) {
+		/* ignore element if fulfilled or ambigous */
+		if (f == e) {
+		    continue;
+		}
+		/* if shortest key was found with the same value,
+		 * just replace its current key with longest key */
+		if ( foundItem->value == val
+		  && foundItem->length < lwrv[i]->length
+		  && foundItem->childTree.firstPtr == NULL
+		) {
+		    Tcl_SetObjRef(foundItem->key, lwrv[i]);
+		    foundItem->length = lwrv[i]->length;
+		    continue;
+		}
+		/* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) )
+		 * but don't split by fulfilled child of found item ( ii->iii->iiii ) */
+		if (foundItem->length != (f - s)) {
+		    /* first split found item (insert one between parent and found + new one) */
+		    item = ckalloc(sizeof(*item));
+		    if (item == NULL) {
+			goto done;
+		    }
+		    Tcl_InitObjRef(item->key, foundItem->key);
+		    item->length = f - s;
+		    /* set value or mark as ambigous if not the same value of both */
+		    item->value = (foundItem->value == val) ? val : NULL;
+		    /* insert group item between foundParent and foundItem */
+		    TclStrIdxTreeInsertBranch(foundParent, item, foundItem);
+		    foundParent = &item->childTree;
+		} else {
+		    /* the new item should be added as child of found item */
+		    foundParent = &foundItem->childTree;
+		}
+	    }
+	}
+	/* append item at end of found parent */
+	item = ckalloc(sizeof(*item));
+	if (item == NULL) {
+	    goto done;
+	}
+	item->childTree.lastPtr = item->childTree.firstPtr = NULL;
+	Tcl_InitObjRef(item->key, lwrv[i]);
+	item->length = lwrv[i]->length;
+	item->value = val;
+	TclStrIdxTreeAppend(foundParent, item);
+    };
+
+    ret = TCL_OK;
+
+done:
+
+    if (lwrv != NULL) {
+	for (i = 0; i < lstc; i++) {
+	    Tcl_DecrRefCount(lwrv[i]);
+	}
+	ckfree(lwrv);
+    }
+
+    if (ret != TCL_OK) {
+	if (idxTree->firstPtr != NULL) {
+	    TclStrIdxTreeFree(idxTree->firstPtr);
+	}
+    }
+
+    return ret;
+}
+
+
+static void
+StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void
+StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr);
+static void
+StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr);
+
+Tcl_ObjType StrIdxTreeObjType = {
+    "str-idx-tree",		    /* name */
+    StrIdxTreeObj_FreeIntRepProc,   /* freeIntRepProc */
+    StrIdxTreeObj_DupIntRepProc,    /* dupIntRepProc */
+    StrIdxTreeObj_UpdateStringProc, /* updateStringProc */
+    NULL			    /* setFromAnyProc */
+};
+
+MODULE_SCOPE Tcl_Obj*
+TclStrIdxTreeNewObj()
+{
+    Tcl_Obj *objPtr = Tcl_NewObj();
+    objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+    objPtr->typePtr = &StrIdxTreeObjType;
+    /* return tree root in internal representation */
+    return objPtr;
+}
+
+static void
+StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
+{
+    /* follow links (smart pointers) */
+    if ( srcPtr->internalRep.twoPtrValue.ptr1 != NULL
+      && srcPtr->internalRep.twoPtrValue.ptr2 == NULL
+    ) {
+	srcPtr = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr1;
+    }
+    /* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */
+    Tcl_InitObjRef(*((Tcl_Obj **)&copyPtr->internalRep.twoPtrValue.ptr1),
+	srcPtr);
+    copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+    copyPtr->typePtr = &StrIdxTreeObjType;
+}
+
+static void
+StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr)
+{
+    /* follow links (smart pointers) */
+    if ( objPtr->internalRep.twoPtrValue.ptr1 != NULL
+      && objPtr->internalRep.twoPtrValue.ptr2 == NULL
+    ) {
+	/* is a link */
+	Tcl_UnsetObjRef(*((Tcl_Obj **)&objPtr->internalRep.twoPtrValue.ptr1));
+    } else {
+	/* is a tree */
+	TclStrIdxTree *tree = (TclStrIdxTree*)&objPtr->internalRep.twoPtrValue.ptr1;
+	if (tree->firstPtr != NULL) {
+	    TclStrIdxTreeFree(tree->firstPtr);
+	}
+	objPtr->internalRep.twoPtrValue.ptr1 = NULL;
+	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+    }
+    objPtr->typePtr = NULL;
+};
+
+static void
+StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr)
+{
+    /* currently only dummy empty string possible */
+    objPtr->length = 0;
+    objPtr->bytes = &tclEmptyString;
+};
+
+MODULE_SCOPE TclStrIdxTree *
+TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr) {
+    /* follow links (smart pointers) */
+    if (objPtr->typePtr != &StrIdxTreeObjType) {
+	return NULL;
+    }
+    if ( objPtr->internalRep.twoPtrValue.ptr1 != NULL
+      && objPtr->internalRep.twoPtrValue.ptr2 == NULL
+    ) {
+	objPtr = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr1;
+    }
+    /* return tree root in internal representation */
+    return (TclStrIdxTree*)&objPtr->internalRep.twoPtrValue.ptr1;
+}
+
+/*
+ * Several debug primitives
+ */
+#if 0
+/* currently unused, debug resp. test purposes only */
+
+void
+TclStrIdxTreePrint(
+    Tcl_Interp *interp,
+    TclStrIdx  *tree,
+    int offs)
+{
+    Tcl_Obj *obj[2];
+    const char *s;
+    Tcl_InitObjRef(obj[0], Tcl_NewStringObj("::puts", -1));
+    while (tree != NULL) {
+	s = TclGetString(tree->key) + offs;
+	Tcl_InitObjRef(obj[1], Tcl_ObjPrintf("%*s%.*s\t:%d",
+		offs, "", tree->length - offs, s, tree->value));
+	Tcl_PutsObjCmd(NULL, interp, 2, obj);
+	Tcl_UnsetObjRef(obj[1]);
+	if (tree->childTree.firstPtr != NULL) {
+	    TclStrIdxTreePrint(interp, tree->childTree.firstPtr, tree->length);
+	}
+	tree = tree->nextPtr;
+    }
+    Tcl_UnsetObjRef(obj[0]);
+}
+
+
+MODULE_SCOPE int
+TclStrIdxTreeTestObjCmd(
+    ClientData clientData, Tcl_Interp *interp,
+    int objc, Tcl_Obj *const objv[])
+{
+    const char *cs, *cin, *ret;
+
+    static const char *const options[] = {
+	"index", "puts-index", "findequal",
+	NULL
+    };
+    enum optionInd {
+	O_INDEX,  O_PUTS_INDEX, O_FINDEQUAL
+    };
+    int optionIndex;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1], options,
+	"option", 0, &optionIndex) != TCL_OK) {
+	Tcl_SetErrorCode(interp, "CLOCK", "badOption",
+		Tcl_GetString(objv[1]), NULL);
+	return TCL_ERROR;
+    }
+    switch (optionIndex) {
+    case O_FINDEQUAL:
+	if (objc < 4) {
+	    Tcl_WrongNumArgs(interp, 1, objv, "");
+	    return TCL_ERROR;
+	}
+	cs = TclGetString(objv[2]);
+	cin = TclGetString(objv[3]);
+	ret = TclUtfFindEqual(
+	    cs, cs + objv[1]->length, cin, cin + objv[2]->length);
+	Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs));
+    break;
+    case O_INDEX:
+    case O_PUTS_INDEX:
+
+    if (1) {
+	Tcl_Obj **lstv;
+	int i, lstc;
+	TclStrIdxTree idxTree = {NULL, NULL};
+	i = 1;
+	while (++i < objc) {
+	    if (TclListObjGetElements(interp, objv[i],
+		    &lstc, &lstv) != TCL_OK) {
+		return TCL_ERROR;
+	    };
+	    TclStrIdxTreeBuildFromList(&idxTree, lstc, lstv, NULL);
+	}
+	if (optionIndex == O_PUTS_INDEX) {
+	    TclStrIdxTreePrint(interp, idxTree.firstPtr, 0);
+	}
+	TclStrIdxTreeFree(idxTree.firstPtr);
+    }
+    break;
+    }
+
+    return TCL_OK;
+}
+
+#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */

generic/tclStrIdxTree.h

@@ -0,0 +1,169 @@
+/*
+ * tclStrIdxTree.h --
+ *
+ *	Declarations of string index tries and other primitives currently
+ *  back-ported from tclSE.
+ *
+ * Copyright (c) 2016 Serg G. Brester (aka sebres)
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef _TCLSTRIDXTREE_H
+#define _TCLSTRIDXTREE_H
+
+
+/*
+ * Main structures declarations of index tree and entry
+ */
+
+typedef struct TclStrIdxTree {
+    struct TclStrIdx *firstPtr;
+    struct TclStrIdx *lastPtr;
+} TclStrIdxTree;
+
+typedef struct TclStrIdx {
+    struct TclStrIdxTree childTree;
+    struct TclStrIdx *nextPtr;
+    struct TclStrIdx *prevPtr;
+    Tcl_Obj	*key;
+    int		 length;
+    ClientData	 value;
+} TclStrIdx;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclUtfFindEqual, TclUtfFindEqualNC --
+ *
+ *  Find largest part of string cs in string cin (case sensitive and not).
+ *
+ * Results:
+ *  Return position of UTF character in cs after last equal character.
+ *
+ * Side effects:
+ *  None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline const char *
+TclUtfFindEqual(
+    register const char *cs,	/* UTF string to find in cin. */
+    register const char *cse,	/* End of cs */
+    register const char *cin,	/* UTF string will be browsed. */
+    register const char *cine)	/* End of cin */
+{
+    register const char *ret = cs;
+    Tcl_UniChar ch1, ch2;
+    do {
+	cs += TclUtfToUniChar(cs, &ch1);
+	cin += TclUtfToUniChar(cin, &ch2);
+	if (ch1 != ch2) break;
+    } while ((ret = cs) < cse && cin < cine);
+    return ret;
+}
+
+static inline const char *
+TclUtfFindEqualNC(
+    register const char *cs,	/* UTF string to find in cin. */
+    register const char *cse,	/* End of cs */
+    register const char *cin,	/* UTF string will be browsed. */
+    register const char *cine,	/* End of cin */
+    const char	     **cinfnd)	/* Return position in cin */
+{
+    register const char *ret = cs;
+    Tcl_UniChar ch1, ch2;
+    do {
+	cs += TclUtfToUniChar(cs, &ch1);
+	cin += TclUtfToUniChar(cin, &ch2);
+	if (ch1 != ch2) {
+	    ch1 = Tcl_UniCharToLower(ch1);
+	    ch2 = Tcl_UniCharToLower(ch2);
+	    if (ch1 != ch2) break;
+	}
+	*cinfnd = cin;
+    } while ((ret = cs) < cse && cin < cine);
+    return ret;
+}
+
+static inline const char *
+TclUtfFindEqualNCInLwr(
+    register const char *cs,	/* UTF string (in anycase) to find in cin. */
+    register const char *cse,	/* End of cs */
+    register const char *cin,	/* UTF string (in lowercase) will be browsed. */
+    register const char *cine,	/* End of cin */
+    const char	     **cinfnd)	/* Return position in cin */
+{
+    register const char *ret = cs;
+    Tcl_UniChar ch1, ch2;
+    do {
+	cs += TclUtfToUniChar(cs, &ch1);
+	cin += TclUtfToUniChar(cin, &ch2);
+	if (ch1 != ch2) {
+	    ch1 = Tcl_UniCharToLower(ch1);
+	    if (ch1 != ch2) break;
+	}
+	*cinfnd = cin;
+    } while ((ret = cs) < cse && cin < cine);
+    return ret;
+}
+
+static inline const char *
+TclUtfNext(
+    register const char *src)	/* The current location in the string. */
+{
+    if (((unsigned char) *(src)) < 0xC0) {
+	return ++src;
+    } else {
+	Tcl_UniChar ch;
+	return src + TclUtfToUniChar(src, &ch);
+    }
+}
+
+
+/*
+ * Primitives to safe set, reset and free references.
+ */
+
+#define Tcl_UnsetObjRef(obj) \
+  if (obj != NULL) { Tcl_DecrRefCount(obj); obj = NULL; }
+#define Tcl_InitObjRef(obj, val) \
+  obj = val; if (obj) { Tcl_IncrRefCount(obj); }
+#define Tcl_SetObjRef(obj, val) \
+if (1) { \
+  Tcl_Obj *nval = val; \
+  if (obj != nval) { \
+    Tcl_Obj *prev = obj; \
+    Tcl_InitObjRef(obj, nval); \
+    if (prev != NULL) { Tcl_DecrRefCount(prev); }; \
+  } \
+}
+
+/*
+ * Prototypes of module functions.
+ */
+
+MODULE_SCOPE const char*
+		    TclStrIdxTreeSearch(TclStrIdxTree **foundParent,
+			TclStrIdx **foundItem, TclStrIdxTree *tree,
+			const char *start, const char *end);
+
+MODULE_SCOPE int    TclStrIdxTreeBuildFromList(TclStrIdxTree *idxTree,
+			int lstc, Tcl_Obj **lstv, ClientData *values);
+
+MODULE_SCOPE Tcl_Obj*
+		    TclStrIdxTreeNewObj();
+
+MODULE_SCOPE TclStrIdxTree*
+		    TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr);
+
+#if 1
+
+MODULE_SCOPE int    TclStrIdxTreeTestObjCmd(ClientData, Tcl_Interp *,
+			int, Tcl_Obj *const objv[]);
+#endif
+
+#endif /* _TCLSTRIDXTREE_H */

generic/tclStringObj.c

@@ -466,7 +466,7 @@ Tcl_GetCharLength(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_GetUniChar(
     Tcl_Obj *objPtr,		/* The object to get the Unicode charater
 				 * from. */
@@ -483,7 +483,7 @@ Tcl_GetUniChar(
     if (TclIsPureByteArray(objPtr)) {
 	unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL);
 
-	return (Tcl_UniChar) bytes[index];
+	return (int) bytes[index];
     }
 
     /*
@@ -493,7 +493,7 @@ Tcl_GetUniChar(
     SetStringFromAny(NULL, objPtr);
     stringPtr = GET_STRING(objPtr);
 
-    if (stringPtr->hasUnicode == 0) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE) == 0) {
 	/*
 	 * If numChars is unknown, compute it.
 	 */
@@ -507,7 +507,7 @@ Tcl_GetUniChar(
 	FillUnicodeRep(objPtr);
 	stringPtr = GET_STRING(objPtr);
     }
-    return stringPtr->unicode[index];
+    return (int) stringPtr->unicode[index];
 }
 
 /*
@@ -569,7 +569,7 @@ Tcl_GetUnicodeFromObj(
     SetStringFromAny(NULL, objPtr);
     stringPtr = GET_STRING(objPtr);
 
-    if (stringPtr->hasUnicode == 0) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE) == 0) {
 	FillUnicodeRep(objPtr);
 	stringPtr = GET_STRING(objPtr);
     }
@@ -607,6 +607,7 @@ Tcl_GetRange(
 {
     Tcl_Obj *newObjPtr;		/* The Tcl object to find the range of. */
     String *stringPtr;
+    int i, firstoffset = 0, lastoffset = 0;
 
     /*
      * Optimize the case where we're really dealing with a bytearray object
@@ -627,7 +628,7 @@ Tcl_GetRange(
     SetStringFromAny(NULL, objPtr);
     stringPtr = GET_STRING(objPtr);
 
-    if (stringPtr->hasUnicode == 0) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE) == 0) {
 	/*
 	 * If numChars is unknown, compute it.
 	 */
@@ -651,7 +652,17 @@ Tcl_GetRange(
 	stringPtr = GET_STRING(objPtr);
     }
 
-    return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1);
+    for (i = 0; i <= last + lastoffset + firstoffset; i++) {
+        if ((stringPtr->unicode[i] & 0xfc00) == 0xd800) {
+            if (i < first + firstoffset) {
+                firstoffset++;
+            } else {
+                lastoffset++;
+            }
+        }
+    }
+
+    return Tcl_NewUnicodeObj(stringPtr->unicode + first + firstoffset, last-first+1 + lastoffset + firstoffset);
 }
 
 /*
@@ -783,7 +794,7 @@ Tcl_SetObjLength(
 	 */
 
 	stringPtr->numChars = -1;
-	stringPtr->hasUnicode = 0;
+	stringPtr->flags = 0;
     } else {
 	/*
 	 * Changing length of pure unicode string.
@@ -802,7 +813,7 @@ Tcl_SetObjLength(
 
 	stringPtr->numChars = length;
 	stringPtr->unicode[length] = 0;
-	stringPtr->hasUnicode = 1;
+	stringPtr->flags |= TCL_HAS_UNICODE;
 
 	/*
 	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
@@ -893,7 +904,7 @@ Tcl_AttemptSetObjLength(
 	 */
 
 	stringPtr->numChars = -1;
-	stringPtr->hasUnicode = 0;
+	stringPtr->flags = 0;
     } else {
 	/*
 	 * Changing length of pure unicode string.
@@ -917,7 +928,7 @@ Tcl_AttemptSetObjLength(
 
 	stringPtr->unicode[length] = 0;
 	stringPtr->numChars = length;
-	stringPtr->hasUnicode = 1;
+	stringPtr->flags |= TCL_HAS_UNICODE;
 
 	/*
 	 * Can only get here when objPtr->bytes == NULL. No need to invalidate
@@ -1000,7 +1011,7 @@ SetUnicodeObj(
     memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
     stringPtr->unicode[numChars] = 0;
     stringPtr->numChars = numChars;
-    stringPtr->hasUnicode = 1;
+    stringPtr->flags |= TCL_HAS_UNICODE;
 
     TclInvalidateStringRep(objPtr);
     stringPtr->allocated = 0;
@@ -1071,7 +1082,7 @@ Tcl_AppendLimitedToObj(
     SetStringFromAny(NULL, objPtr);
     stringPtr = GET_STRING(objPtr);
 
-    if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE) && stringPtr->numChars > 0) {
 	AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
     } else {
 	AppendUtfToUtfRep(objPtr, bytes, toCopy);
@@ -1082,7 +1093,7 @@ Tcl_AppendLimitedToObj(
     }
 
     stringPtr = GET_STRING(objPtr);
-    if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE) && stringPtr->numChars > 0) {
 	AppendUtfToUnicodeRep(objPtr, ellipsis, strlen(ellipsis));
     } else {
 	AppendUtfToUtfRep(objPtr, ellipsis, strlen(ellipsis));
@@ -1161,7 +1172,7 @@ Tcl_AppendUnicodeToObj(
      * objPtr's string rep.
      */
 
-    if (stringPtr->hasUnicode) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE)) {
 	AppendUnicodeToUnicodeRep(objPtr, unicode, length);
     } else {
 	AppendUnicodeToUtfRep(objPtr, unicode, length);
@@ -1267,7 +1278,7 @@ Tcl_AppendObjToObj(
      * appendObjPtr and append it.
      */
 
-    if (stringPtr->hasUnicode) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE)) {
 	/*
 	 * If appendObjPtr is not of the "String" type, don't convert it.
 	 */
@@ -1543,7 +1554,7 @@ AppendUtfToUtfRep(
      */
 
     stringPtr->numChars = -1;
-    stringPtr->hasUnicode = 0;
+    stringPtr->flags = 0;
 
     if (bytes) {
 	memmove(objPtr->bytes + oldLength, bytes, numBytes);
@@ -2724,7 +2735,7 @@ TclStringRepeat(
     if (!binary) {
 	if (objPtr->typePtr == &tclStringType) {
 	    String *stringPtr = GET_STRING(objPtr);
-	    if (stringPtr->hasUnicode) {
+	    if (stringPtr->flags & TCL_HAS_UNICODE) {
 		unichar = 1;
 	    }
 	}
@@ -3444,7 +3455,7 @@ TclStringObjReverse(
     SetStringFromAny(NULL, objPtr);
     stringPtr = GET_STRING(objPtr);
 
-    if (stringPtr->hasUnicode) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE)) {
 	Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
 	Tcl_UniChar *src = from + stringPtr->numChars;
 
@@ -3456,7 +3467,6 @@ TclStringObjReverse(
 	     * Tcl_SetObjLength into growing the unicode rep buffer.
 	     */
 
-	    ch = 0;
 	    objPtr = Tcl_NewUnicodeObj(&ch, 1);
 	    Tcl_SetObjLength(objPtr, stringPtr->numChars);
 	    to = Tcl_GetUnicode(objPtr);
@@ -3558,10 +3568,10 @@ ExtendUnicodeRepWithString(
     int numAppendChars)
 {
     String *stringPtr = GET_STRING(objPtr);
-    int needed, numOrigChars = 0;
-    Tcl_UniChar *dst;
+    int incr, needed, numOrigChars = 0;
+    Tcl_UniChar *dst, unichar = 0;
 
-    if (stringPtr->hasUnicode) {
+    if ((stringPtr->flags & TCL_HAS_UNICODE)) {
 	numOrigChars = stringPtr->numChars;
     }
     if (numAppendChars == -1) {
@@ -3575,14 +3585,19 @@ ExtendUnicodeRepWithString(
 	stringPtr = GET_STRING(objPtr);
     }
 
-    stringPtr->hasUnicode = 1;
+    stringPtr->flags |= TCL_HAS_UNICODE;
     if (bytes) {
 	stringPtr->numChars = needed;
     } else {
 	numAppendChars = 0;
     }
     for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) {
-	bytes += TclUtfToUniChar(bytes, dst);
+	bytes += (incr = TclUtfToUniChar(bytes, &unichar));
+	*dst = unichar;
+	if (!incr) {
+	    bytes += TclUtfToUniChar(bytes, &unichar);
+	    *++dst = unichar;
+	}
     }
     *dst = 0;
 }
@@ -3625,7 +3640,7 @@ DupStringInternalRep(
 	return;
     }
 
-    if (srcStringPtr->hasUnicode) {
+    if (srcStringPtr->flags & TCL_HAS_UNICODE) {
 	int copyMaxChars;
 
 	if (srcStringPtr->maxChars / 2 >= srcStringPtr->numChars) {
@@ -3647,7 +3662,7 @@ DupStringInternalRep(
 	copyStringPtr->maxChars = 0;
 	copyStringPtr->unicode[0] = 0;
     }
-    copyStringPtr->hasUnicode = srcStringPtr->hasUnicode;
+    copyStringPtr->flags = srcStringPtr->flags;
     copyStringPtr->numChars = srcStringPtr->numChars;
 
     /*
@@ -3702,7 +3717,7 @@ SetStringFromAny(
 	stringPtr->numChars = -1;
 	stringPtr->allocated = objPtr->length;
 	stringPtr->maxChars = 0;
-	stringPtr->hasUnicode = 0;
+	stringPtr->flags = 0;
 	SET_STRING(objPtr, stringPtr);
 	objPtr->typePtr = &tclStringType;
     }
@@ -3761,8 +3776,8 @@ ExtendStringRepWithUnicode(
      * Pre-condition: this is the "string" Tcl_ObjType.
      */
 
-    int i, origLength, size = 0;
-    char *dst;
+    int incr, i, origLength, size = 0, offset = 0;
+    char *dst, buf[TCL_UTF_MAX];
     String *stringPtr = GET_STRING(objPtr);
 
     if (numChars < 0) {
@@ -3787,9 +3802,11 @@ ExtendStringRepWithUnicode(
 	goto copyBytes;
     }
 
-    for (i = 0; i < numChars && size >= 0; i++) {
-	size += TclUtfCount(unicode[i]);
+    for (i = 0; i < numChars + offset && size >= 0; i++) {
+	size += (incr = Tcl_UniCharToUtf((int) unicode[i], buf));
+	if (!incr) offset++;
     }
+    offset = 0;
     if (size < 0) {
 	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
     }
@@ -3804,8 +3821,9 @@ ExtendStringRepWithUnicode(
 
   copyBytes:
     dst = objPtr->bytes + origLength;
-    for (i = 0; i < numChars; i++) {
-	dst += Tcl_UniCharToUtf((int) unicode[i], dst);
+    for (i = 0; i < numChars + offset; i++) {
+	dst += (incr = Tcl_UniCharToUtf((int) unicode[i], dst));
+	if (!incr) offset++;
     }
     *dst = '\0';
     objPtr->length = dst - objPtr->bytes;

generic/tclStringRep.h

@@ -45,6 +45,8 @@
  * can be officially modified by altering the definition of Tcl_UniChar in
  * tcl.h, but do not do that unless you are sure what you're doing!
  */
+#define TCL_HAS_UNICODE 1      /* This string has Unicode representation   */
+#define TCL_HAS_BIGUNICODE 2   /* This string contains characters > \uffff */
 
 typedef struct {
     int numChars;		/* The number of chars in the string. -1 means
@@ -57,8 +59,7 @@ typedef struct {
 				 * termination char). */
     int maxChars;		/* Max number of chars that can fit in the
 				 * space allocated for the unicode array. */
-    int hasUnicode;		/* Boolean determining whether the string has
-				 * a Unicode representation. */
+    int flags;	/* Combination of TCL_HAS_UNICODE and TCL_HAS_BIGUNICODE */
     Tcl_UniChar unicode[1];	/* The array of Unicode chars. The actual size
 				 * of this field depends on the 'maxChars'
 				 * field above. */

generic/tclStubLibTbl.c

@@ -1,58 +0,0 @@
-/*
- * tclStubLibTbl.c --
- *
- *	Stub object that will be statically linked into extensions that want
- *	to access Tcl.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 1998 Paul Duffin.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInitStubTable --
- *
- *	Initialize the stub table, using the structure pointed at
- *	by the "version" argument.
- *
- * Results:
- *	Outputs the value of the "version" argument.
- *
- * Side effects:
- *	Sets the stub table pointers.
- *
- *----------------------------------------------------------------------
- */
-MODULE_SCOPE const char *
-TclInitStubTable(
-	const char *version) /* points to the version field of a
-	                        TclStubInfoType structure variable. */
-{
-    tclStubsPtr = ((const TclStubInfoType *) version)->stubs;
-
-    if (tclStubsPtr->hooks) {
-	tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
-	tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
-	tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
-    } else {
-	tclPlatStubsPtr = NULL;
-	tclIntStubsPtr = NULL;
-	tclIntPlatStubsPtr = NULL;
-    }
-
-    return version;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */

generic/tclUtf.c

@@ -483,7 +483,7 @@ Tcl_NumUtfChars(
 				 * for strlen(string). */
 {
     Tcl_UniChar ch = 0;
-    register int i = 0;
+    register int i = 0, n;
 
     /*
      * The separate implementations are faster.
@@ -494,7 +494,11 @@ Tcl_NumUtfChars(
 
     if (length < 0) {
 	while (*src != '\0') {
-	    src += TclUtfToUniChar(src, &ch);
+	    n = TclUtfToUniChar(src, &ch);
+	    if (!n) {
+	        n = Tcl_UtfToUniChar(src, &ch);
+	    }
+	    src += n;
 	    i++;
 	}
 	if (i < 0) i = INT_MAX; /* Bug [2738427] */
@@ -502,12 +506,20 @@ Tcl_NumUtfChars(
 	register const char *endPtr = src + length - TCL_UTF_MAX;
 
 	while (src < endPtr) {
-	    src += TclUtfToUniChar(src, &ch);
+	    n = TclUtfToUniChar(src, &ch);
+	    if (!n) {
+	        n = Tcl_UtfToUniChar(src, &ch);
+	    }
+	    src += n;
 	    i++;
 	}
 	endPtr += TCL_UTF_MAX;
 	while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) {
-	    src += TclUtfToUniChar(src, &ch);
+	    n = TclUtfToUniChar(src, &ch);
+	    if (!n) {
+	        n = Tcl_UtfToUniChar(src, &ch);
+	    }
+	    src += n;
 	    i++;
 	}
 	if (src < endPtr) {
@@ -699,16 +711,25 @@ Tcl_UtfPrev(
  *---------------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharAtIndex(
     register const char *src,	/* The UTF-8 string to dereference. */
     register int index)		/* The position of the desired character. */
 {
-    Tcl_UniChar ch = 0;
+    Tcl_UniChar unichar = 0;
+    int bytes;
+    int ch = 0;
 
-    while (index >= 0) {
-	index--;
-	src += TclUtfToUniChar(src, &ch);
+    while (index-- >= 0) {
+	bytes = TclUtfToUniChar(src, &unichar);
+	ch = unichar;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &unichar);
+	    /* Combine surrogates */
+	    ch = (((ch & 0x3ff) << 10) | (unichar & 0x3ff)) + 0x10000;
+	}
+	src += bytes;
     }
     return ch;
 }
@@ -736,10 +757,15 @@ Tcl_UtfAtIndex(
     register int index)		/* The position of the desired character. */
 {
     Tcl_UniChar ch = 0;
+    int len;
 
     while (index > 0) {
 	index--;
-	src += TclUtfToUniChar(src, &ch);
+	len = TclUtfToUniChar(src, &ch);
+	if (!len) {
+	    len = TclUtfToUniChar(src, &ch);
+	}
+	src += len;
     }
     return src;
 }
@@ -819,7 +845,8 @@ int
 Tcl_UtfToUpper(
     char *str)			/* String to convert in place. */
 {
-    Tcl_UniChar ch = 0, upChar;
+    Tcl_UniChar ch = 0;
+    int upChar;
     char *src, *dst;
     int bytes;
 
@@ -830,7 +857,14 @@ Tcl_UtfToUpper(
     src = dst = str;
     while (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	upChar = Tcl_UniCharToUpper(ch);
+	upChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	upChar = Tcl_UniCharToUpper(upChar);
 
 	/*
 	 * To keep badly formed Utf strings from getting inflated by the
@@ -872,7 +906,8 @@ int
 Tcl_UtfToLower(
     char *str)			/* String to convert in place. */
 {
-    Tcl_UniChar ch = 0, lowChar;
+    Tcl_UniChar ch = 0;
+    int lowChar;
     char *src, *dst;
     int bytes;
 
@@ -883,7 +918,14 @@ Tcl_UtfToLower(
     src = dst = str;
     while (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	lowChar = Tcl_UniCharToLower(ch);
+	lowChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	lowChar = Tcl_UniCharToLower(lowChar);
 
 	/*
 	 * To keep badly formed Utf strings from getting inflated by the
@@ -926,7 +968,8 @@ int
 Tcl_UtfToTitle(
     char *str)			/* String to convert in place. */
 {
-    Tcl_UniChar ch = 0, titleChar, lowChar;
+    Tcl_UniChar ch = 0;
+    int titleChar, lowChar;
     char *src, *dst;
     int bytes;
 
@@ -939,7 +982,14 @@ Tcl_UtfToTitle(
 
     if (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	titleChar = Tcl_UniCharToTitle(ch);
+	titleChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	titleChar = Tcl_UniCharToTitle(titleChar);
 
 	if (bytes < TclUtfCount(titleChar)) {
 	    memcpy(dst, src, (size_t) bytes);
@@ -951,7 +1001,14 @@ Tcl_UtfToTitle(
     }
     while (*src) {
 	bytes = TclUtfToUniChar(src, &ch);
-	lowChar = Tcl_UniCharToLower(ch);
+	lowChar = ch;
+	if (!bytes) {
+	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+	    bytes = TclUtfToUniChar(src, &ch);
+	    /* Combine surrogates */
+	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+	}
+	lowChar = Tcl_UniCharToLower(lowChar);
 
 	if (bytes < TclUtfCount(lowChar)) {
 	    memcpy(dst, src, (size_t) bytes);
@@ -1159,16 +1216,18 @@ TclUtfCasecmp(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharToUpper(
     int ch)			/* Unicode character to convert. */
 {
-    int info = GetUniCharInfo(ch);
+    if (!UNICODE_OUT_OF_RANGE(ch)) {
+	int info = GetUniCharInfo(ch);
 
-    if (GetCaseType(info) & 0x04) {
-	ch -= GetDelta(info);
+	if (GetCaseType(info) & 0x04) {
+	    ch -= GetDelta(info);
+	}
     }
-    return (Tcl_UniChar) ch;
+    return ch & 0x1FFFFF;
 }
 
 /*
@@ -1187,16 +1246,18 @@ Tcl_UniCharToUpper(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharToLower(
     int ch)			/* Unicode character to convert. */
 {
-    int info = GetUniCharInfo(ch);
+    if (!UNICODE_OUT_OF_RANGE(ch)) {
+	int info = GetUniCharInfo(ch);
 
-    if (GetCaseType(info) & 0x02) {
-	ch += GetDelta(info);
+	if (GetCaseType(info) & 0x02) {
+	    ch += GetDelta(info);
+	}
     }
-    return (Tcl_UniChar) ch;
+    return ch & 0x1FFFFF;
 }
 
 /*
@@ -1215,23 +1276,25 @@ Tcl_UniCharToLower(
  *----------------------------------------------------------------------
  */
 
-Tcl_UniChar
+int
 Tcl_UniCharToTitle(
     int ch)			/* Unicode character to convert. */
 {
-    int info = GetUniCharInfo(ch);
-    int mode = GetCaseType(info);
+    if (!UNICODE_OUT_OF_RANGE(ch)) {
+	int info = GetUniCharInfo(ch);
+	int mode = GetCaseType(info);
 
-    if (mode & 0x1) {
-	/*
-	 * Subtract or add one depending on the original case.
-	 */
+	if (mode & 0x1) {
+	    /*
+	     * Subtract or add one depending on the original case.
+	     */
 
-	ch += ((mode & 0x4) ? -1 : 1);
-    } else if (mode == 0x4) {
-	ch -= GetDelta(info);
+	    ch += ((mode & 0x4) ? -1 : 1);
+	} else if (mode == 0x4) {
+	    ch -= GetDelta(info);
+	}
     }
-    return (Tcl_UniChar) ch;
+    return ch & 0x1FFFFF;
 }
 
 /*