another test

Exposes problems with the interface.

generic/tclInt.h

@@ -4098,6 +4098,11 @@ MODULE_SCOPE Tcl_Obj *	TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    int flags);
 MODULE_SCOPE Tcl_Obj *	TclStringReverse(Tcl_Obj *objPtr, int flags);
 
+MODULE_SCOPE int	TclUtf16Ncmp(const unsigned short int *units1,
+			    const unsigned short int *units2,
+			    size_t numUnits1, size_t numUnits2,
+			    size_t numChars);
+
 /* Flag values for the [string] ensemble functions. */
 
 #define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */

generic/tclStringObj.c

@@ -3435,7 +3435,55 @@ TclStringCmp(
 			s1len *= sizeof(Tcl_UniChar);
 			s2len *= sizeof(Tcl_UniChar);
 		    } else {
+#if TCL_UTF_MAX > 3
 			memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp;
+#else
+	int numUnits1, numUnits2;
+	const unsigned short int *units1
+		= Tcl_GetUnicodeFromObj(value1Ptr, &numUnits1);
+	const unsigned short int *units2
+		= Tcl_GetUnicodeFromObj(value2Ptr, &numUnits2);
+
+/*
+ * WARNING WARNING!  s1len and s2len were set above as the values
+ * returned by calls to Tcl_GetCharLength().  The name of this routine
+ * would suggest it reports the number of characters, but it reports
+ * the number of code units.
+ */
+
+	length = (s1len < s2len) ? s1len : s2len;
+	/* length is # chars in shorter sequence */
+
+	if (reqlength > 0 && reqlength < length) {
+	    /* Trim back to request it it matters */
+	    length = reqlength;
+	} else if (reqlength < 0) {
+	    /*
+	     * The requested length is negative, so we ignore it by setting it
+	     * to length + 1 so we correct the match var.
+	     */
+/* TODO: Check this */
+
+	    reqlength = length + 1;
+	}
+
+	if (checkEq && (s1len != s2len)) {
+/* TODO: Check this */
+	    match = 1;		/* This will be reversed below. */
+	} else {
+	    /*
+	     * The comparison function should compare up to the minimum byte
+	     * length only.
+	     */
+
+	    match = TclUtf16Ncmp(units1, units2, numUnits1, numUnits2, length);
+	}
+	if ((match == 0) && (reqlength > length)) {
+	    match = s1len - s2len;
+	}
+	match = (match > 0) ? 1 : (match < 0) ? -1 : 0;
+	goto matchdone;
+#endif
 		    }
 		}
 	    }

generic/tclUtf.c

@@ -1800,6 +1800,78 @@ Tcl_UniCharNcmp(
     return 0;
 #endif /* WORDS_BIGENDIAN */
 }
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclUTF16Ncmp --
+ *
+ *	Compare at most numChars characters from UTF-16 sequence units1
+ *	against characters from UTF-16 sequence units2.  Caller is expected
+ *	to guarantee that each sequence contains at least numChars characters.
+ *
+ * Results:
+ *	Return	<0 if units1 < units2,
+ *		0  if units1 == units2,
+ *		>0 if units1 > units,
+ *	when considering up to numChar characters from each.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+UTF16ToUCS4(
+    const unsigned short int *units,
+				/* Pointer into an array of UCS-2 units */
+    size_t count,               /* How many units are available to read. */
+    int *ucs4Ptr)               /* Write the UCS-4 result here. */
+{
+    if (count == 0) {
+        /* Is this reasonable? Better to panic? */
+        *ucs4Ptr = 0;
+        return 0;
+    }
+    if ((sizeof(Tcl_UniChar) > 2) || (count == 1)
+            || ((units[0] & 0xF800) != 0xD800)
+            || ((units[1] & 0xF800) != 0xDC00)) {
+        /* We do not see a surrogate pair. Return 1st unit. */
+        *ucs4Ptr = units[0];
+        return 1;
+    }
+    /* Surrogate pair. Generate extended code point */
+    *ucs4Ptr = (0x10000 + ((units[0] & 0x3FF) << 10)) | (units[1] & 0x3FF);
+    return 2;
+}
+
+int
+TclUtf16Ncmp(
+    const unsigned short int *units1,	/* 1st UTF-16 sequence to compare */
+    const unsigned short int *units2,	/* 2nd UTF-16 sequence to compare */
+    size_t numUnits1,			/* # code units in 1st sequence */
+    size_t numUnits2,			/* # code units in 2nd sequence */
+    size_t numChars)			/* max # characters to compare */
+{
+    while ((numChars > 0) && (numUnits1 > 0) && (numUnits2 > 0)) {
+	int ch1, ch2;
+	int delta1 = UTF16ToUCS4(units1, numUnits1, &ch1);
+	int delta2 = UTF16ToUCS4(units2, numUnits2, &ch2);
+
+	if (ch1 != ch2) {
+	    return (ch1 - ch2);
+	}
+	units1 += delta1;
+	numUnits1 -= delta1;
+	units2 += delta2;
+	numUnits2 -= delta2;
+	numChars--;
+    }
+    if (numChars == 0) {
+	return 0;
+    }
+    /* Ran out of at least one sequence before seeing numChars characters */
+    Tcl_Panic("TclUtf16Ncmp request to compare too many characters");
+}
 
 /*
  *----------------------------------------------------------------------
@@ -1819,6 +1891,46 @@ Tcl_UniCharNcmp(
  *----------------------------------------------------------------------
  */
 
+#if 0
+int
+Tcl_UniCharNcasecmp(
+    const Tcl_UniChar *ucs,     /* Unicode string to compare to uct. */
+    const Tcl_UniChar *uct,     /* Unicode string ucs is compared to. */
+    unsigned long numChars)     /* Number of unichars to compare. */
+{
+    unsigned long snum = numChars;
+    unsigned long tnum = numChars;
+
+    while ((snum != 0) && (tnum != 0)) {
+        int sch, tch;
+        int sdelta = UTF16ToUCS4(ucs, snum, &sch);
+        int tdelta = UTF16ToUCS4(uct, tnum, &tch);
+
+        /* TODO: Are two replacement characters always the same? */
+        /* Should replacement characters sort according to code point */
+        if (sch != tch) {
+            int lsch = Tcl_UniCharToLower(sch);
+            int ltch = Tcl_UniCharToLower(tch);
+
+            if (lsch != ltch) {
+                return (lsch - ltch);
+            }
+        }
+
+        ucs += sdelta;
+        snum -= sdelta;
+
+        uct += tdelta;
+        tnum -= tdelta;
+    }
+    /* All examined chars were same (modulo case)
+     * Then the longer string is greater.
+     */
+    return snum ? 1 : tnum ? -1 : 0;
+}
+
+#else
+
 int
 Tcl_UniCharNcasecmp(
     const Tcl_UniChar *ucs,	/* Unicode string to compare to uct. */
@@ -1837,6 +1949,7 @@ Tcl_UniCharNcasecmp(
     }
     return 0;
 }
+#endif
 
 /*
  *----------------------------------------------------------------------

tests/utf.test

@@ -1210,10 +1210,10 @@ test utf-19.1 {TclUniCharLen} -body {
     unset -nocomplain foo
 } -result {1 4}
 
-test utf-20.1 {TclUniCharNcmp} {ucs4} {
+test utf-20.1 {TclUniCharNcmp} {fullutf} {
     string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
 } -1
-test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} knownBug {
+test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {
     set one [format %c 0xFFFF]
     set two [format %c 0x10000]
     set first [string compare $one $two]
@@ -1222,6 +1222,15 @@ test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} knownBug {
     set second [string compare $one $two]
     expr {($first == $second) ? "agree" : "disagree"}
 } agree
+test utf-20.3 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {
+    set one [format %c 0xFFFF]
+    set two [format %c 0x10000]
+    set first [string compare -length 1 $one $two]
+    string range $one 0 0
+    string range $two 0 0 
+    set second [string compare -length 1 $one $two]
+    expr {($first == $second) ? "agree" : "disagree"}
+} agree
 
 test utf-21.1 {TclUniCharIsAlnum} {
     # this returns 1 with Unicode 7 compliance
@@ -1340,10 +1349,10 @@ UniCharCaseCmpTest < a b
 UniCharCaseCmpTest > b a
 UniCharCaseCmpTest > B a
 UniCharCaseCmpTest > aBcB abca
-UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4	
-UniCharCaseCmpTest < \uFFFF \U10000		{Uesc ucs4}
-UniCharCaseCmpTest > [format %c 0x10000] \uFFFF	ucs4	
-UniCharCaseCmpTest > \U10000 \uFFFF		{Uesc ucs4}
+UniCharCaseCmpTest < \uFFFF [format %c 0x10000]	{fullutf}
+UniCharCaseCmpTest < \uFFFF \U10000		{Uesc fullutf}
+UniCharCaseCmpTest > [format %c 0x10000] \uFFFF	{fullutf}
+UniCharCaseCmpTest > \U10000 \uFFFF		{Uesc fullutf}