From fcd17ae019c89d4f1cd1f82e1c04ba022c275f77 Mon Sep 17 00:00:00 2001
From: Miguel Sofer <miguel.sofer@gmail.com>
Date: Thu, 9 Aug 2007 12:20:04 +0000
Subject: 	* generic/tclExecute.c (INST_STORE_ARRAY): 	*
 tests/trace.test (trace-2.6): whole array write traces on 	compiled local
 variables were not firing [Bug 1770591]

---
 ChangeLog            |  6 ++++++
 generic/tclExecute.c | 37 +++++++++++++------------------------
 tests/trace.test     | 18 +++++++++++++++++-
 3 files changed, 36 insertions(+), 25 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 704637b..2b13d81 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2007-08-09  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclExecute.c (INST_STORE_ARRAY):
+	* tests/trace.test (trace-2.6): whole array write traces on
+	compiled local variables were not firing [Bug 1770591]
+	
 2007-08-08  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* generic/tclProc.c (InitLocalCache): reference firstLocalPtr via
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ebbd040..abb30e8 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclExecute.c,v 1.311 2007/08/08 20:52:20 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.312 2007/08/09 12:20:07 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2314,16 +2314,14 @@ TclExecuteByteCode(
 	TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
 	if (TclIsVarArray(arrayPtr) && !(arrayPtr->flags & VAR_TRACED_READ)) {
 	    varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
-	    if (varPtr) {
-		if (TclIsVarDirectReadable(varPtr)) {
-		    /*
-		     * No errors, no traces: just get the value.
-		     */
+	    if (varPtr && TclIsVarDirectReadable(varPtr)) {
+		/*
+		 * No errors, no traces: just get the value.
+		 */
 
-		    objResultPtr = varPtr->value.objPtr;
-		    TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
-		    NEXT_INST_F(pcAdjustment, 1, 1);
-		}
+		objResultPtr = varPtr->value.objPtr;
+		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+		NEXT_INST_F(pcAdjustment, 1, 1);
 	    }
 	}
 	varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
@@ -2433,13 +2431,11 @@ TclExecuteByteCode(
 	}
 	if (TclIsVarArray(arrayPtr) && !(arrayPtr->flags & VAR_TRACED_WRITE)) {
 	    varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
-	    if (varPtr) {
-		if (TclIsVarDirectWritable(varPtr)) {
-		    tosPtr--;
-		    Tcl_DecrRefCount(OBJ_AT_TOS);
-		    OBJ_AT_TOS = valuePtr;
-		    goto doStoreVarDirect;
-		}
+	    if (varPtr && TclIsVarDirectWritable(varPtr)) {
+		tosPtr--;
+		Tcl_DecrRefCount(OBJ_AT_TOS);
+		OBJ_AT_TOS = valuePtr;
+		goto doStoreVarDirect;
 	    }
 	}
 	cleanup = 2;
@@ -2596,13 +2592,6 @@ TclExecuteByteCode(
 	varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
 		TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
 	if (varPtr) {
-	    if ((storeFlags == TCL_LEAVE_ERR_MSG) && TclIsVarDirectWritable(varPtr)) {
-		tosPtr--;
-		Tcl_DecrRefCount(OBJ_AT_TOS);
-		OBJ_AT_TOS = valuePtr;		
-		goto doStoreVarDirect;
-	    }
-	    part1Ptr = NULL;
 	    goto doCallPtrSetVar;
 	} else {
 	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
diff --git a/tests/trace.test b/tests/trace.test
index a736228..c2d7b17 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,7 +11,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: trace.test,v 1.56 2007/06/27 18:21:52 dgp Exp $
+# RCS: @(#) $Id: trace.test,v 1.57 2007/08/09 12:20:08 msofer Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -231,6 +231,22 @@ test trace-2.5 {trace variable writes} {
     unset x
     set info
 } {}
+test trace-2.6 {trace variable writes on compiled local} {
+    #
+    # Check correct function of whole array traces on compiled local
+    # arrays [Bug 1770591]. The corresponding function for read traces is
+    # already indirectly tested in trace-1.7
+    #
+    catch {unset x}
+    set info {}
+    proc p {} {
+	trace add variable x write traceArray
+	set x(X) willy
+    }
+    p
+    set info
+} {x X write 0 willy}
+
 
 # append no longer triggers read traces when fetching the old values of
 # variables before doing the append operation. However, lappend _does_
-- 
cgit v0.12