summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclInt.decls14
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclIntDecls.h15
-rw-r--r--generic/tclStringObj.c2
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclUtf.c18
-rw-r--r--tests/utf.test20
7 files changed, 35 insertions, 39 deletions
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 0605e29..ba4da9e 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -468,6 +468,7 @@ declare 232 {
declare 233 {
void TclGetSrcInfoForPc(CmdFrame *contextPtr)
}
+
# Exports for VarReform compat: Itcl, XOTcl like to peek into our varTables :(
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
@@ -476,10 +477,17 @@ declare 234 {
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
+# TIP 542
+declare 236 {
+ void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode, size_t length)
+}
+
# TIP #285: Script cancellation support.
declare 237 {
int TclResetCancellation(Tcl_Interp *interp, int force)
}
+
# NRE functions for "rogue" extensions to exploit NRE; they will need to
# include NRE.h too.
declare 238 {
@@ -568,7 +576,6 @@ declare 256 {
int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags)
}
-
declare 257 {
void TclStaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
@@ -579,11 +586,6 @@ declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
-# TIP 542
-declare 259 {
- void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, size_t length)
-}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7efd5d3..7e6a92b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4670,7 +4670,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
-#ifdef WORDS_BIGENDIAN
+#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
#endif /* WORDS_BIGENDIAN */
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index aad437a..48eb4b2 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -501,7 +501,9 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
-/* Slot 236 is reserved */
+/* 236 */
+EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
+ const Tcl_UniChar *unicode, size_t length);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
@@ -577,9 +579,6 @@ EXTERN void TclStaticPackage(Tcl_Interp *interp,
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
-/* 259 */
-EXTERN void TclAppendUnicodeToObj(Tcl_Obj *objPtr,
- const Tcl_UniChar *unicode, size_t length);
typedef struct TclIntStubs {
int magic;
@@ -821,7 +820,7 @@ typedef struct TclIntStubs {
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*reserved236)(void);
+ void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
@@ -844,7 +843,6 @@ typedef struct TclIntStubs {
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
- void (*tclAppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t length); /* 259 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
@@ -1215,7 +1213,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
#define TclInitVarHashTable \
(tclIntStubsPtr->tclInitVarHashTable) /* 235 */
-/* Slot 236 is reserved */
+#define TclAppendUnicodeToObj \
+ (tclIntStubsPtr->tclAppendUnicodeToObj) /* 236 */
#define TclResetCancellation \
(tclIntStubsPtr->tclResetCancellation) /* 237 */
#define TclNRInterpProc \
@@ -1260,8 +1259,6 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclStaticPackage) /* 257 */
#define TclpCreateTemporaryDirectory \
(tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
-#define TclAppendUnicodeToObj \
- (tclIntStubsPtr->tclAppendUnicodeToObj) /* 259 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index ce7570a..758997a 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -3348,7 +3348,7 @@ TclStringCmp(
s1 = (char *) Tcl_GetUnicode(value1Ptr);
s2 = (char *) Tcl_GetUnicode(value2Ptr);
if (
-#ifdef WORDS_BIGENDIAN
+#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
1
#else
checkEq
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index c144290..72c3f39 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -527,7 +527,7 @@ static const TclIntStubs tclIntStubs = {
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
- 0, /* 236 */
+ TclAppendUnicodeToObj, /* 236 */
TclResetCancellation, /* 237 */
TclNRInterpProc, /* 238 */
TclNRInterpProcCore, /* 239 */
@@ -550,7 +550,6 @@ static const TclIntStubs tclIntStubs = {
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
- TclAppendUnicodeToObj, /* 259 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index f56abd8..447a5c9 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -1851,7 +1851,7 @@ TclUniCharNcmp(
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
size_t numChars) /* Number of unichars to compare. */
{
-#ifdef WORDS_BIGENDIAN
+#if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX > 3)
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
@@ -1865,6 +1865,14 @@ TclUniCharNcmp(
for ( ; numChars != 0; ucs++, uct++, numChars--) {
if (*ucs != *uct) {
+#if TCL_UTF_MAX < 4
+ /* special case for handling upper surrogates */
+ if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) {
+ return 1;
+ } else if (((*uct & 0xFC00) == 0xD800)) {
+ return -1;
+ }
+#endif
return (*ucs - *uct);
}
}
@@ -1902,6 +1910,14 @@ TclUniCharNcasecmp(
Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
+#if TCL_UTF_MAX < 4
+ /* special case for handling upper surrogates */
+ if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) {
+ return 1;
+ } else if (((lct & 0xFC00) == 0xD800)) {
+ return -1;
+ }
+#endif
return (lcs - lct);
}
}
diff --git a/tests/utf.test b/tests/utf.test
index 75f66b3..b6c4597 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -1212,25 +1212,7 @@ test utf-19.1 {TclUniCharLen} -body {
test utf-20.1 {TclUniCharNcmp} ucs4 {
string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
} -1
-test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs2 {
- set one [format %c 0xFFFF]
- set two [format %c 0x10000]
- set first [string compare $one $two]
- string range $one 0 0
- string range $two 0 0
- set second [string compare $one $two]
- expr {($first == $second) ? "agree" : "disagree"}
-} agree
-test utf-20.2.1 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {utf16 knownBug} {
- set one [format %c 0xFFFF]
- set two [format %c 0x10000]
- set first [string compare $one $two]
- string range $one 0 0
- string range $two 0 0
- set second [string compare $one $two]
- expr {($first == $second) ? "agree" : "disagree"}
-} agree
-test utf-20.2.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 {
+test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
generated by cgit v0.12 at 2024-11-16 03:03:29 (GMT)