Index: generic/tclListObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclListObj.c,v
retrieving revision 1.42
diff -u -r1.42 tclListObj.c
--- generic/tclListObj.c	17 Mar 2007 05:04:16 -0000	1.42
+++ generic/tclListObj.c	17 Mar 2007 18:13:10 -0000
@@ -1255,6 +1255,158 @@
 				/* Index args. */
     Tcl_Obj *valuePtr)		/* Value arg to 'lset'. */
 {
+#if 1
+    int index, result;
+    Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
+
+    /*
+     * If there are no indices, simply return the new value.
+     * (Without indices, [lset] is a synonym for [set].
+     */
+
+    if (indexCount == 0) {
+	Tcl_IncrRefCount(valuePtr);
+	return valuePtr;
+    }
+
+    /*
+     * If the list is shared, make a copy we can modify (copy-on-write).
+     * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few
+     * reasons: 1) we have not yet confirmed listPtr is actually a list;
+     * 2) We make a verbatim copy of any existing string rep, and when
+     * we combine that with the delayed invalidation of string reps of
+     * modified Tcl_Obj's implemented below, the outcome is that any
+     * error condition that causes this routine to return NULL, will
+     * leave the string rep of listPtr and all elements to be unchanged.
+     */
+
+    subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
+
+    /*
+     * Anchor the linked list of Tcl_Obj's whose string reps must be
+     * invalidated if the operation succeeds.
+     */
+
+    retValuePtr = subListPtr;
+    chainPtr = NULL;
+
+    /*
+     * Loop through all the index arguments, and for each one dive
+     * into the appropriate sublist.
+     */
+
+    do {
+	int elemCount;
+	Tcl_Obj *parentList, **elemPtrs;
+
+	/* Check for the possible error conditions... */
+	result = TCL_ERROR;
+	if (Tcl_ListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
+		!= TCL_OK) {
+	    /* ...the sublist we're indexing into isn't a list at all. */
+	    break;
+	}
+
+	if (TclGetIntForIndex(interp, *indexArray++, elemCount - 1, &index)
+		!= TCL_OK)  {
+	    /* ...the index we're trying to use isn't an index at all. */
+	    break;
+	}
+
+	if (index < 0 || index >= elemCount) {
+	    /* ...the index points outside the sublist. */
+	    Tcl_SetObjResult(interp,
+		    Tcl_NewStringObj("list index out of range", -1));
+	    break;
+	}
+
+	/*
+	 * No error conditions.  As long as we're not yet on the last
+	 * index, determine the next sublist for the next pass through
+	 * the loop, and take steps to make sure it is an unshared copy,
+	 * as we intend to modify it.
+	 */
+
+	result = TCL_OK;
+	if (--indexCount) {
+	    parentList = subListPtr;
+	    subListPtr = elemPtrs[index];
+	    if (Tcl_IsShared(subListPtr)) {
+		subListPtr = Tcl_DuplicateObj(subListPtr);
+	    }
+
+	    /*
+	     * Replace the original elemPtr[index] in parentList with a copy
+	     * we know to be unshared.  This call will also deal with the
+	     * situation where parentList shares its intrep with other
+	     * Tcl_Obj's.  Dealing with the shared intrep case can cause
+	     * subListPtr to become shared again, so detect that case and
+	     * make and store another copy.
+	     */
+
+	    TclListObjSetElement(NULL, parentList, index, subListPtr);
+	    if (Tcl_IsShared(subListPtr)) {
+		subListPtr = Tcl_DuplicateObj(subListPtr);
+		TclListObjSetElement(NULL, parentList, index, subListPtr);
+	    }
+
+	    /*
+	     * The TclListObjSetElement() calls do not spoil the string
+	     * rep of parentList, and that's fine for now, since all we've
+	     * done so far is replace a list element with an unshared copy.
+	     * The list value remains the same, so the string rep. is still
+	     * valid, and unchanged, which is good because if this whole
+	     * routine returns NULL, we'd like to leave no change to the
+	     * value of the lset variable.  Later on, when we set valuePtr
+	     * in its proper place, then all containing lists will have
+	     * their values changed, and will need their string reps spoiled.
+	     * We maintain a list of all those Tcl_Obj's (via a little intrep
+	     * surgery) so we can spoil them at that time.
+	     */
+
+	    parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr;
+	    chainPtr = parentList;
+	}
+    } while (indexCount > 0);
+
+    /*
+     * Either we've detected and error condition, and exited the loop
+     * with result == TCL_ERROR, or we've successfully reached the last
+     * index, and we're ready to store valuePtr.  In either case, we
+     * need to clean up our string spoiling list of Tcl_Obj's.
+     */
+
+    while (chainPtr) {
+	Tcl_Obj *objPtr = chainPtr;
+
+	if (result == TCL_OK) {
+
+	    /*
+	     * We're going to store valuePtr, so spoil string reps
+	     * of all containing lists.
+	     */
+
+	    Tcl_InvalidateStringRep(objPtr);
+	}
+
+	/* Clear away our intrep surgery mess */
+	chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
+	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+    }
+
+    if (result != TCL_OK) {
+	/* Error return; message is already in interp */
+	return NULL;
+    }
+
+    /* Store valuePtr in proper sublist and return */
+    TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+    Tcl_InvalidateStringRep(subListPtr);
+    Tcl_IncrRefCount(retValuePtr);
+    return retValuePtr;
+
+#else
+
     int duplicated;		/* Flag == 1 if the obj has been duplicated, 0
 				 * otherwise. */
     Tcl_Obj *retValuePtr;	/* Pointer to the list to be returned. */
@@ -1436,6 +1588,7 @@
 	Tcl_DecrRefCount(retValuePtr);
     }
     return NULL;
+#endif
 }
 
 /*
Index: tests/lset.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/lset.test,v
retrieving revision 1.7
diff -u -r1.7 lset.test
--- tests/lset.test	20 Oct 2005 12:27:29 -0000	1.7
+++ tests/lset.test	17 Mar 2007 18:13:10 -0000
@@ -390,6 +390,23 @@
     list $a [lindex $a 1]
 } "{ { 1 2 } { 3 4 } } { 3 4 }"
 
+testConstraint testobj [llength [info commands testobj]]
+test lset-15.1 {lset: shared intrep [Bug 1677512]} -setup {
+    teststringobj set 1 {{1 2} 3}
+    testobj convert 1 list
+    testobj duplicate 1 2
+    variable x [teststringobj get 1]
+    variable y [teststringobj get 2]
+    testobj freeallvars
+    set l [list $y z]
+    unset y
+} -constraints testobj -body {
+    lset l 0 0 0 5
+    lindex $x 0 0
+} -cleanup {
+    unset -nocomplain x l
+} -result 1
+
 catch {unset noRead}
 catch {unset noWrite}
 catch {rename failTrace {}}
