Merge trunk

13 files changed, 214 insertions, 61 deletions

diff --git a/doc/TraceCmd.3 b/doc/TraceCmd.3
index 1244576..db2f5d5 100644
--- a/doc/TraceCmd.3
+++ b/doc/TraceCmd.3
@@ -86,11 +86,14 @@ operation is being performed on the command.  The bit
 \fBTCL_TRACE_DESTROYED\fR will be set in \fIflags\fR if the trace is about
 to be destroyed; this information may be useful to \fIproc\fR so that
 it can clean up its own internal data structures (see the section
-\fBTCL_TRACE_DESTROYED\fR below for more details).  Lastly, the bit
-\fBTCL_INTERP_DESTROYED\fR will be set if the entire interpreter is being
-destroyed.  When this bit is set, \fIproc\fR must be especially
-careful in the things it does (see the section \fBTCL_INTERP_DESTROYED\fR
-below).
+\fBTCL_TRACE_DESTROYED\fR below for more details).  Because the
+deletion of commands can take place as part of the deletion of the interp
+that contains them, \fIproc\fR must be careful about checking what
+the passed in \fIinterp\fR value can be called upon to do.
+The routine \fBTcl_InterpDeleted\fR is an important tool for this.
+When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able
+to invoke any scripts in \fIinterp\fR.  The function of \fIproc\fR
+in that circumstance is limited to the cleanup of its own data structures.
 .PP
 \fBTcl_UntraceCommand\fR may be used to remove a trace.  If the
 command specified by \fIinterp\fR, \fIcmdName\fR, and \fIflags\fR has
@@ -123,7 +126,8 @@ traces for a given command that have the same \fIproc\fR.
 .PP
 During rename traces, the command being renamed is visible with both
 names simultaneously, and the command still exists during delete
-traces (if \fBTCL_INTERP_DESTROYED\fR is not set).  However, there is no
+traces, unless the interp that contains it is being deleted.
+However, there is no
 mechanism for signaling that an error occurred in a trace procedure,
 so great care should be taken that errors do not get silently lost.
 .SH "MULTIPLE TRACES"
@@ -142,22 +146,5 @@ rename the command, the last renaming takes precedence.
 In a delete callback to \fIproc\fR, the \fBTCL_TRACE_DESTROYED\fR bit
 is set in \fIflags\fR.
 .\" Perhaps need some more comments here? - DKF
-.SH "TCL_INTERP_DESTROYED"
-.PP
-When an interpreter is destroyed, unset traces are called for
-all of its commands.
-The \fBTCL_INTERP_DESTROYED\fR bit will be set in the \fIflags\fR
-argument passed to the trace procedures.
-Trace procedures must be extremely careful in what they do if
-the \fBTCL_INTERP_DESTROYED\fR bit is set.
-It is not safe for the procedures to invoke any Tcl procedures
-on the interpreter, since its state is partially deleted.
-All that trace procedures should do under these circumstances is
-to clean up and free their own internal data structures.
-.SH BUGS
-.PP
-Tcl does not do any error checking to prevent trace procedures
-from misusing the interpreter during traces with \fBTCL_INTERP_DESTROYED\fR
-set.
 .SH KEYWORDS
 clientData, trace, command
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index ae61e85..cda1f38 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -31,7 +31,7 @@
  * until Tcl uses config.h properly.
  */
 
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)
+#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
 typedef unsigned long caddr_t;
 #endif
 
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 431f0af..18f4564 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -301,7 +301,8 @@ TclCompileArraySetCmd(
      * a proc, we cannot do a better compile than generic.
      */
 
-    if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) {
+    if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) ||
+	    (envPtr->procPtr == NULL && !(isDataEven && len == 0))) {
 	code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
 	goto done;
     }
@@ -342,8 +343,9 @@ TclCompileArraySetCmd(
 	 * a non-local variable: upvar from a local one! This consumes the
 	 * variable name that was left at stacktop.
 	 */
-	
-	localIndex = AnonymousLocal(envPtr);
+
+	localIndex = TclFindCompiledLocal(varTokenPtr->start,
+		varTokenPtr->size, 1, envPtr);
 	PushStringLiteral(envPtr, "0");
 	TclEmitInstInt4(INST_REVERSE, 2,        		envPtr);
 	TclEmitInstInt4(INST_UPVAR, localIndex, 		envPtr);
@@ -2401,7 +2403,6 @@ TclCompileForCmd(
 
     SetLineInformation(2);
     TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
-    TclClearNumConversion(envPtr);
 
     jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
     if (jumpDist > 127) {
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index 603c51d..9d258fc 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -281,7 +281,6 @@ TclCompileIfCmd(
 		SetLineInformation(wordIdx);
 		Tcl_ResetResult(interp);
 		TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
-		TclClearNumConversion(envPtr);
 		if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
 		    TclExpandJumpFixupArray(&jumpFalseFixupArray);
 		}
@@ -531,7 +530,6 @@ TclCompileIncrCmd(
 	} else {
 	    SetLineInformation(2);
 	    CompileTokens(envPtr, incrTokenPtr, interp);
-	    TclClearNumConversion(envPtr);
 	}
     } else {			/* No incr amount given so use 1. */
 	haveImmValue = 1;
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 2b83fd2..382d2d1 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -322,8 +322,8 @@ TclCompileStringCatCmd(
 	    CompileWord(envPtr, wordTokenPtr, interp, i);
 	    numArgs ++;
 	    if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
-		TclEmitInstInt1(INST_STR_CONCAT1, 254, envPtr);
-		numArgs -= 253;	/* concat pushes 1 obj, the result */
+		TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
+		numArgs = 1;	/* concat pushes 1 obj, the result */
 	    }
 	}
 	wordTokenPtr = TokenAfter(wordTokenPtr);
@@ -3782,7 +3782,6 @@ TclCompileWhileCmd(
 	}
 	SetLineInformation(1);
 	TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
-	TclClearNumConversion(envPtr);
 
 	jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
 	if (jumpDist > 127) {
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 01b78d9..51f0b34 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1414,18 +1414,6 @@ MODULE_SCOPE int	TclPushProcCallFrame(ClientData clientData,
     } while (0)
 
 /*
- * If the expr compiler finished with TRY_CONVERT, macro to remove it when the
- * job is done by the following instruction.
- */
-
-#define TclClearNumConversion(envPtr) \
-    do {								\
-	if (*(envPtr->codeNext - 1) == INST_TRY_CVT_TO_NUMERIC) {	\
-	    envPtr->codeNext--;						\
-	}								\
-    } while (0)
-
-/*
  * Macros to update a (signed or unsigned) integer starting at a pointer. The
  * two variants depend on the number of bytes. The ANSI C "prototypes" for
  * these macros are:
diff --git a/generic/tclIO.c b/generic/tclIO.c
index dcde8d1..9283bf5 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -3894,7 +3894,10 @@ Tcl_Write(
     if (srcLen < 0) {
 	srcLen = strlen(src);
     }
-    return WriteBytes(chanPtr, src, srcLen);
+    if (WriteBytes(chanPtr, src, srcLen) < 0) {
+	return -1;
+    }
+    return srcLen;
 }
 
 /*
@@ -6046,12 +6049,11 @@ ReadChars(
 	    /* 
 	     * We read more chars than allowed.  Reset limits to
 	     * prevent that and try again.  Don't forget the extra
-	     * padding of TCL_UTF_MAX - 1 bytes demanded by the
+	     * padding of TCL_UTF_MAX bytes demanded by the
 	     * Tcl_ExternalToUtf() call!
 	     */
 
-	    dstLimit = Tcl_UtfAtIndex(dst, charsToRead + 1) 
-		    + TCL_UTF_MAX - 1 - dst;
+	    dstLimit = Tcl_UtfAtIndex(dst, charsToRead) + TCL_UTF_MAX - dst;
 	    statePtr->flags = savedFlags;
 	    statePtr->inputEncodingFlags = savedIEFlags;
 	    statePtr->inputEncodingState = savedState;
@@ -9021,7 +9023,7 @@ MBRead(
     }
 
     code = GetInput(inStatePtr->topChanPtr);
-    if (code == 0) {
+    if (code == 0 || GotFlag(inStatePtr, CHANNEL_BLOCKED)) {
 	return TCL_OK;
     } else {
 	MBError(csPtr, TCL_READABLE, code);
@@ -9271,6 +9273,10 @@ CopyData(
 			csPtr);
 	    }
 	    if (size == 0) {
+		if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
+		    /* We allowed a short read.  Keep trying. */
+		    continue;
+		}
 		if (bufObj != NULL) {
 		    TclDecrRefCount(bufObj);
 		    bufObj = NULL;
@@ -9503,21 +9509,39 @@ DoRead(
 	}
 
 	/*
-	 * If there is not enough data in the buffers to possibly
-	 * complete the read, then go get more.
+	 * Don't read more data if we have what we need. 
 	 */
 
-	if (bufPtr == NULL || BytesLeft(bufPtr) < bytesToRead) {
+	while (!bufPtr ||			/* We got no buffer!   OR */
+		(!IsBufferFull(bufPtr) && 	/* Our buffer has room AND */
+		(BytesLeft(bufPtr) < bytesToRead) ) ) {
+						/* Not enough bytes in it 
+						 * yet to fill the dst */
+	    int code;
+
 	moreData:
-	    if (GetInput(chanPtr)) {
+	    code = GetInput(chanPtr);
+	    bufPtr = statePtr->inQueueHead;
+
+	    assert (bufPtr != NULL);
+
+	    if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
+		/* Further reads cannot do any more */
+		break;
+	    }
+
+	    if (code) {
 		/* Read error */
 		UpdateInterest(chanPtr);
 		TclChannelRelease((Tcl_Channel)chanPtr);
 		return -1;
 	    }
-	    bufPtr = statePtr->inQueueHead;
+
+	    assert (IsBufferFull(bufPtr));
 	}
 
+	assert (bufPtr != NULL);
+
 	bytesRead = BytesLeft(bufPtr);
 	bytesWritten = bytesToRead;
 
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index c0cde49..6184a89 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -2511,6 +2511,9 @@ TclObjCallVarTraces(
     if (!part1Ptr) {
 	part1Ptr = localName(iPtr->varFramePtr, index);
     }
+    if (!part1Ptr) {
+	Tcl_Panic("Cannot trace a variable with no name");
+    }
     part1 = TclGetString(part1Ptr);
     part2 = part2Ptr? TclGetString(part2Ptr) : NULL;
 
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 05b58c9..205da67 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -726,6 +726,20 @@ test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
     catch {namespace delete ::cotest}
     catch {rename cotest ""}
 } -result {yieldto called in deleted namespace}
+test coroutine-7.12 {coro floor above street level #3008307} -body {
+    proc c {} {
+	yield
+    }
+    proc cc {} {
+	coroutine C c
+    }
+    proc boom {} {
+	cc ; # coro created at level 2
+	C  ; # and called at level 1
+    }
+    boom   ; # does not crash: the coro floor is a good insulator
+    list
+} -result {}
 
 
 # cleanup
diff --git a/tests/io.test b/tests/io.test
index 639691a..d9a5167 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -1484,6 +1484,39 @@ test io-12.6 {ReadChars: too many chars read} {
     }
     close $c
 } {}
+test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
+    proc driver {cmd args} {
+        variable buffer
+        variable index
+        set chan [lindex $args 0]
+        switch -- $cmd {
+            initialize {
+                set index($chan) 0
+                set buffer($chan) [encoding convertto utf-8 \
+                        [string repeat \uBEEF 10]....\uBEEF]
+                return {initialize finalize watch read}
+            }
+            finalize {
+                unset index($chan) buffer($chan)
+                return
+            }
+            watch {}
+            read {
+                set n [lindex $args 1]
+                set new [expr {$index($chan) + $n}]
+                set result [string range $buffer($chan) $index($chan) $new-1]
+                set index($chan) $new
+                return $result
+            }
+        }
+    }
+    set c [chan create read [namespace which driver]]
+    chan configure $c -encoding utf-8
+    while {![eof $c]} {
+        read $c 7
+    }
+    close $c
+} {}
 
 test io-13.1 {TranslateInputEOL: cr mode} {} {
     set f [open $path(test1) w]
@@ -7675,6 +7708,94 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup {
     removeFile in
     rename driver {}
 } -result {error writing "*": *} -returnCodes error -match glob
+test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
+    proc driver {cmd args} {
+        variable buffer
+        variable index
+        variable blocked
+        set chan [lindex $args 0]
+        switch -- $cmd {
+            initialize {
+                set index($chan) 0
+                set buffer($chan) [encoding convertto utf-8 \
+                        [string repeat a 100]]
+                set blocked($chan) 1
+                return {initialize finalize watch read}
+            }
+            finalize {
+                unset index($chan) buffer($chan) blocked($chan)
+                return
+            }
+            watch {}
+            read {
+                if {$blocked($chan)} {
+                    set blocked($chan) [expr {!$blocked($chan)}]
+                    return -code error EAGAIN
+                }
+                set n [lindex $args 1]
+                set new [expr {$index($chan) + $n}]
+                set result [string range $buffer($chan) $index($chan) $new-1]
+                set index($chan) $new
+                return $result
+            }
+        }
+    }
+    set c [chan create read [namespace which driver]]
+    chan configure $c -encoding utf-8
+    set out [makeFile {} out]
+    set outChan [open $out w]
+    chan configure $outChan -encoding utf-8
+} -body {
+    chan copy $c $outChan
+} -cleanup {
+    close $outChan
+    close $c
+    removeFile out
+} -result 100
+test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
+    proc driver {cmd args} {
+        variable buffer
+        variable index
+        variable blocked
+        set chan [lindex $args 0]
+        switch -- $cmd {
+            initialize {
+                set index($chan) 0
+                set buffer($chan) [encoding convertto utf-8 \
+                        [string repeat a 100]]
+                set blocked($chan) 1
+                return {initialize finalize watch read}
+            }
+            finalize {
+                unset index($chan) buffer($chan) blocked($chan)
+                return
+            }
+            watch {}
+            read {
+                if {$blocked($chan)} {
+                    set blocked($chan) [expr {!$blocked($chan)}]
+                    return -code error EAGAIN
+                }
+                set n [lindex $args 1]
+                set new [expr {$index($chan) + $n}]
+                set result [string range $buffer($chan) $index($chan) $new-1]
+                set index($chan) $new
+                return $result
+            }
+        }
+    }
+    set c [chan create read [namespace which driver]]
+    chan configure $c -encoding utf-8 -translation lf
+    set out [makeFile {} out]
+    set outChan [open $out w]
+    chan configure $outChan -encoding utf-8 -translation lf
+} -body {
+    chan copy $c $outChan
+} -cleanup {
+    close $outChan
+    close $c
+    removeFile out
+} -result 100
 
 test io-54.1 {Recursive channel events} {socket fileevent} {
     # This test checks to see if file events are delivered during recursive
diff --git a/tests/utf.test b/tests/utf.test
index 2fcac49..83daddf 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -287,9 +287,11 @@ test utf-18.5 {Tcl_UniCharToTitle, no delta} {
     string totitle !
 } !
 
-test utf-19.1 {TclUniCharLen} {
+test utf-19.1 {TclUniCharLen} -body {
     list [regexp \\d abc456def foo] $foo
-} {1 4}
+} -cleanup {
+    unset -nocomplain foo
+} -result {1 4}
 
 test utf-20.1 {TclUniCharNcmp} {
 } {}
diff --git a/tests/var.test b/tests/var.test
index 8e862f7..7ff394e 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -865,6 +865,22 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
     }}
     array size x
 } -result 0
+test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup {
+    variable foo
+    variable lambda
+    unset -nocomplain lambda foo
+    array set foo {}
+    lappend lambda {}
+    lappend lambda [list array set [namespace which -variable foo] {a 1}]
+} -body {
+    after 0 [list apply $lambda]
+    vwait [namespace which -variable foo]
+} -cleanup {
+    unset -nocomplain lambda foo
+} -result {}
+test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
+    apply {{} {set name foo(bar); array set $name {a 1}}}
+} -returnCodes error -match glob -result *
 
 test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
     proc linenumber {} {dict get [info frame -1] line}
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 652cd06..ca6b2bf 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -433,17 +433,17 @@ typedef DWORD_PTR * PDWORD_PTR;
  * EDEADLK as the same value, which confuses Tcl_ErrnoId().
  */
 
-#if defined(_MSC_VER) || defined(__MINGW32__)
+#if defined(_MSC_VER) || defined(__MSVCRT__)
 #   define environ _environ
 #   if defined(_MSC_VER) && (_MSC_VER < 1600)
 #	define hypot _hypot
 #   endif
 #   define exception _exception
 #   undef EDEADLOCK
-#   if defined(__MINGW32__) && !defined(__MSVCRT__)
+#   if defined(_MSC_VER) && (_MSC_VER >= 1700)
 #	define timezone _timezone
 #   endif
-#endif /* _MSC_VER || __MINGW32__ */
+#endif /* _MSC_VER || __MSVCRT__ */
 
 /*
  * Borland's timezone and environ functions.
@@ -505,7 +505,7 @@ typedef DWORD_PTR * PDWORD_PTR;
  * Msvcrt's putenv() copies the string rather than takes ownership of it.
  */
 
-#if defined(_MSC_VER) || defined(__MINGW32__)
+#if defined(_MSC_VER) || defined(__MSVCRT__)
 #   define HAVE_PUTENV_THAT_COPIES 1
 #endif