merge trunk

7 files changed, 101 insertions, 90 deletions

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 2e5a931..d6bbe79 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2755,7 +2755,7 @@ Tcl_LreplaceObjCmd(
      * (to allow for replacing the last elem).
      */
 
-    if ((first >= listLen) && (listLen > 0)) {
+    if ((first > listLen) && (listLen > 0)) {
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"list doesn't contain element %s", TclGetString(objv[2])));
 	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 9f430ea..ffe39ba 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -1489,6 +1489,15 @@ TclCompileLreplaceCmd(
     }
 
     /*
+     * idx1, idx2 are now in canonical form:
+     *
+     *  - integer:	[0,len+1]
+     *  - end index:    INDEX_END
+     *  - -ive offset:  INDEX_END-[len-1,0]
+     *  - +ive offset:  INDEX_END+1
+     */
+
+    /*
      * Compilation fails when one index is end-based but the other isn't.
      * Fixing this will require more bytecodes, but this is a workaround for
      * now. [Bug 47ac84309b]
@@ -1521,6 +1530,9 @@ TclCompileLreplaceCmd(
 	    idx1 = 0;
 	    goto dropEnd;
 	} else {
+	    if (idx2 < idx1) {
+		idx2 = idx1 - 1;
+	    }
 	    if (idx1 > 0) {
 		tmpObj = Tcl_NewIntObj(idx1);
 		Tcl_IncrRefCount(tmpObj);
@@ -1548,9 +1560,7 @@ TclCompileLreplaceCmd(
 	idx1 = 0;
 	goto replaceTail;
     } else {
-	if (idx1 > 0 && idx2 > 0 && idx2 < idx1) {
-	    idx2 = idx1 - 1;
-	} else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) {
+	if (idx2 < idx1) {
 	    idx2 = idx1 - 1;
 	}
 	if (idx1 > 0) {
@@ -1566,7 +1576,7 @@ TclCompileLreplaceCmd(
      * operate on.
      */
 
-  dropAll:
+  dropAll:			/* This just ensures the arg is a list. */
     TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
     TclEmitOpcode(		INST_POP,			envPtr);
     PushStringLiteral(envPtr,	"");
@@ -1579,12 +1589,21 @@ TclCompileLreplaceCmd(
 
   dropRange:
     if (tmpObj != NULL) {
+	/*
+	 * Emit bytecode to check the list length.
+	 */
+
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
 	TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL),	envPtr);
-	TclEmitOpcode(		INST_GT,			envPtr);
+	TclEmitOpcode(		INST_GE,			envPtr);
 	offset = CurrentOffset(envPtr);
 	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
+
+	/*
+	 * Emit an error if we've been given an empty list.
+	 */
+
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
 	offset2 = CurrentOffset(envPtr);
@@ -1635,16 +1654,30 @@ TclCompileLreplaceCmd(
 
   replaceRange:
     if (tmpObj != NULL) {
+	/*
+	 * Emit bytecode to check the list length.
+	 */
+
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
+
+	/*
+	 * Check the list length vs idx1.
+	 */
+
 	TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL),	envPtr);
-	TclEmitOpcode(		INST_GT,			envPtr);
+	TclEmitOpcode(		INST_GE,			envPtr);
 	offset = CurrentOffset(envPtr);
 	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
+
+	/*
+	 * Emit an error if we've been given an empty list.
+	 */
+
 	TclEmitOpcode(		INST_DUP,			envPtr);
 	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
 	offset2 = CurrentOffset(envPtr);
-	TclEmitInstInt1(	INST_JUMP_TRUE1, 0,		envPtr);
+	TclEmitInstInt1(	INST_JUMP_FALSE1, 0,		envPtr);
 	TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
 		"list doesn't contain element %d", idx1), NULL), envPtr);
 	CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8d37fd0..582d3f3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3085,6 +3085,7 @@ MODULE_SCOPE int	TclTrimLeft(const char *bytes, int numBytes,
 MODULE_SCOPE int	TclTrimRight(const char *bytes, int numBytes,
 			    const char *trim, int numTrim);
 MODULE_SCOPE int	TclUtfCasecmp(const char *cs, const char *ct);
+MODULE_SCOPE int	TclUtfCount(int ch);
 MODULE_SCOPE Tcl_Obj *	TclpNativeToNormalized(ClientData clientData);
 MODULE_SCOPE Tcl_Obj *	TclpFilesystemPathType(Tcl_Obj *pathPtr);
 MODULE_SCOPE int	TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index c5d601f..bf67f18 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -3044,7 +3044,7 @@ ExtendStringRepWithUnicode(
      */
 
     int i, origLength, size = 0;
-    char *dst, buf[TCL_UTF_MAX];
+    char *dst;
     String *stringPtr = GET_STRING(objPtr);
 
     if (numChars < 0) {
@@ -3070,7 +3070,7 @@ ExtendStringRepWithUnicode(
     }
 
     for (i = 0; i < numChars && size >= 0; i++) {
-	size += Tcl_UniCharToUtf((int) unicode[i], buf);
+	size += TclUtfCount(unicode[i]);
     }
     if (size < 0) {
 	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 88d911a..ea87c39 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -84,17 +84,11 @@ static const unsigned char totalBytes[256] = {
     1,1,1,1
 #endif
 };
-
-/*
- * Functions used only in this module.
- */
-
-static int		UtfCount(int ch);
 
 /*
  *---------------------------------------------------------------------------
  *
- * UtfCount --
+ * TclUtfCount --
  *
  *	Find the number of bytes in the Utf character "ch".
  *
@@ -107,8 +101,8 @@ static int		UtfCount(int ch);
  *---------------------------------------------------------------------------
  */
 
-inline static int
-UtfCount(
+int
+TclUtfCount(
     int ch)			/* The Tcl_UniChar whose size is returned. */
 {
     if ((ch > 0) && (ch < UNICODE_SELF)) {
@@ -143,7 +137,7 @@ UtfCount(
  *---------------------------------------------------------------------------
  */
 
-inline int
+int
 Tcl_UniCharToUtf(
     int ch,			/* The Tcl_UniChar to be stored in the
 				 * buffer. */
@@ -829,7 +823,7 @@ Tcl_UtfToUpper(
 	 * char to dst if its size is <= the original char.
 	 */
 
-	if (bytes < UtfCount(upChar)) {
+	if (bytes < TclUtfCount(upChar)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
@@ -882,7 +876,7 @@ Tcl_UtfToLower(
 	 * char to dst if its size is <= the original char.
 	 */
 
-	if (bytes < UtfCount(lowChar)) {
+	if (bytes < TclUtfCount(lowChar)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
@@ -932,7 +926,7 @@ Tcl_UtfToTitle(
 	bytes = TclUtfToUniChar(src, &ch);
 	titleChar = Tcl_UniCharToTitle(ch);
 
-	if (bytes < UtfCount(titleChar)) {
+	if (bytes < TclUtfCount(titleChar)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
@@ -944,7 +938,7 @@ Tcl_UtfToTitle(
 	bytes = TclUtfToUniChar(src, &ch);
 	lowChar = Tcl_UniCharToLower(ch);
 
-	if (bytes < UtfCount(lowChar)) {
+	if (bytes < TclUtfCount(lowChar)) {
 	    memcpy(dst, src, (size_t) bytes);
 	    dst += bytes;
 	} else {
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 7139114..2b03ef4 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -206,7 +206,6 @@ static Tcl_UpdateStringProc	PanicOnUpdateVarName;
 
 static Tcl_FreeInternalRepProc	FreeParsedVarName;
 static Tcl_DupInternalRepProc	DupParsedVarName;
-static Tcl_UpdateStringProc	UpdateParsedVarName;
 
 static Tcl_UpdateStringProc	PanicOnUpdateVarName;
 static Tcl_SetFromAnyProc	PanicOnSetVarName;
@@ -237,7 +236,7 @@ static const Tcl_ObjType localVarNameType = {
 
 static const Tcl_ObjType tclParsedVarNameType = {
     "parsedVarName",
-    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName
+    FreeParsedVarName, DupParsedVarName, PanicOnUpdateVarName, PanicOnSetVarName
 };
 
 /*
@@ -536,7 +535,6 @@ TclObjLookupVarEx(
     const char *errMsg = NULL;
     CallFrame *varFramePtr = iPtr->varFramePtr;
     const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL;
-    char *newPart2 = NULL;
     *arrayPtrPtr = NULL;
 
     if (typePtr == &localVarNameType) {
@@ -583,9 +581,7 @@ TclObjLookupVarEx(
 		}
 		return NULL;
 	    }
-	    part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
-	    if (newPart2) {
-		part2Ptr = Tcl_NewStringObj(newPart2, -1);
+	    if ((part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2)) {
 		if (createPart2) {
 		    Tcl_IncrRefCount(part2Ptr);
 		}
@@ -629,11 +625,7 @@ TclObjLookupVarEx(
 		len2 = len1 - i - 2;
 		len1 = i;
 
-		newPart2 = ckalloc(len2 + 1);
-		memcpy(newPart2, part2, (unsigned) len2);
-		*(newPart2+len2) = '\0';
-		part2 = newPart2;
-		part2Ptr = Tcl_NewStringObj(newPart2, -1);
+		part2Ptr = Tcl_NewStringObj(part2, len2);
 		if (createPart2) {
 		    Tcl_IncrRefCount(part2Ptr);
 		}
@@ -658,7 +650,8 @@ TclObjLookupVarEx(
 		Tcl_IncrRefCount(part1Ptr);
 
 		objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr;
-		objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2;
+		Tcl_IncrRefCount(part2Ptr);
+		objPtr->internalRep.twoPtrValue.ptr2 = part2Ptr;
 
 		typePtr = part1Ptr->typePtr;
 		part1 = TclGetString(part1Ptr);
@@ -683,9 +676,6 @@ TclObjLookupVarEx(
 	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
 		    TclGetString(part1Ptr), NULL);
 	}
-	if (newPart2) {
-	    Tcl_DecrRefCount(part2Ptr);
-	}
 	return NULL;
     }
 
@@ -734,9 +724,6 @@ TclObjLookupVarEx(
 	*arrayPtrPtr = varPtr;
 	varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg,
 		createPart1, createPart2, varPtr, -1);
-	if (newPart2) {
-	    Tcl_DecrRefCount(part2Ptr);
-	}
     }
     return varPtr;
 }
@@ -5393,11 +5380,11 @@ FreeParsedVarName(
     Tcl_Obj *objPtr)
 {
     register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
-    register char *elem = objPtr->internalRep.twoPtrValue.ptr2;
+    register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2;
 
     if (arrayPtr != NULL) {
 	TclDecrRefCount(arrayPtr);
-	ckfree(elem);
+	TclDecrRefCount(elem);
     }
     objPtr->typePtr = NULL;
 }
@@ -5408,58 +5395,17 @@ DupParsedVarName(
     Tcl_Obj *dupPtr)
 {
     register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1;
-    register char *elem = srcPtr->internalRep.twoPtrValue.ptr2;
-    char *elemCopy;
-    unsigned elemLen;
+    register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2;
 
     if (arrayPtr != NULL) {
 	Tcl_IncrRefCount(arrayPtr);
-	elemLen = strlen(elem);
-	elemCopy = ckalloc(elemLen + 1);
-	memcpy(elemCopy, elem, elemLen);
-	*(elemCopy + elemLen) = '\0';
-	elem = elemCopy;
+	Tcl_IncrRefCount(elem);
     }
 
     dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr;
     dupPtr->internalRep.twoPtrValue.ptr2 = elem;
     dupPtr->typePtr = &tclParsedVarNameType;
 }
-
-static void
-UpdateParsedVarName(
-    Tcl_Obj *objPtr)
-{
-    Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1;
-    char *part2 = objPtr->internalRep.twoPtrValue.ptr2;
-    const char *part1;
-    char *p;
-    int len1, len2, totalLen;
-
-    if (arrayPtr == NULL) {
-	/*
-	 * This is a parsed scalar name: what is it doing here?
-	 */
-
-	Tcl_Panic("scalar parsedVarName without a string rep");
-    }
-
-    part1 = TclGetStringFromObj(arrayPtr, &len1);
-    len2 = strlen(part2);
-
-    totalLen = len1 + len2 + 2;
-    p = ckalloc(totalLen + 1);
-    objPtr->bytes = p;
-    objPtr->length = totalLen;
-
-    memcpy(p, part1, (unsigned) len1);
-    p += len1;
-    *p++ = '(';
-    memcpy(p, part2, (unsigned) len2);
-    p += len2;
-    *p++ = ')';
-    *p = '\0';
-}
 
 /*
  *----------------------------------------------------------------------
diff --git a/tests/lreplace.test b/tests/lreplace.test
index 55a36a8..d7f8226 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -98,7 +98,12 @@ test lreplace-1.26 {lreplace command} {
         [set foo [lreplace $foo end end]] \
         [set foo [lreplace $foo end end]]
 } {a {} {}}
-
+test lreplace-1.27 {lreplace command} {
+    lreplace x 1 1
+} x
+test lreplace-1.28 {lreplace command} {
+    lreplace x 1 1 y
+} {x y}
 
 test lreplace-2.1 {lreplace errors} {
     list [catch lreplace msg] $msg
@@ -119,8 +124,8 @@ test lreplace-2.6 {lreplace errors} {
     list [catch {lreplace x 3 2} msg] $msg
 } {1 {list doesn't contain element 3}}
 test lreplace-2.7 {lreplace errors} {
-    list [catch {lreplace x 1 1} msg] $msg
-} {1 {list doesn't contain element 1}}
+    list [catch {lreplace x 2 2} msg] $msg
+} {1 {list doesn't contain element 2}}
 
 test lreplace-3.1 {lreplace won't modify shared argument objects} {
     proc p {} {
@@ -181,6 +186,12 @@ test lreplace-4.11 {lreplace end index first} {
 test lreplace-4.12 {lreplace end index first} {
     lreplace {0 1 2 3 4} end-2 2 a b c
 } {0 1 a b c 3 4}
+test lreplace-4.13 {lreplace empty list} {
+    lreplace {} 1 1 1
+} 1
+test lreplace-4.14 {lreplace empty list} {
+    lreplace {} 2 2 2
+} 2
 
 test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} {
     apply {x {
@@ -192,6 +203,32 @@ test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} {
 	lreplace $x end 0 A
     }} {a b c}
 } {a b A c}
+
+# Testing for compiled behaviour. Far too many variations to check with
+# spelt-out tests. Note that this *just* checks whether the compiled version
+# and the interpreted version are the same, not whether the interpreted
+# version is correct.
+apply {{} {
+    set lss     {{} {a} {a b c} {a b c d}}
+    set ins     {{} A {A B}}
+    set idxs    {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
+    set lreplace lreplace
+
+    foreach ls $lss {
+	foreach a $idxs {
+	    foreach b $idxs {
+		foreach i $ins {
+		    set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
+		    set tester [list lreplace $ls $a $b {*}$i]
+		    set script [list catch $tester m]
+		    set script "list \[$script\] \$m"
+		    test lreplace-6.[incr n] {lreplace battery} \
+			[list apply [list {} $script]] $expected
+		}
+	    }
+	}
+    }
+}}
 
 # cleanup
 catch {unset foo}