see backport log in ChangeLog for specific file backports from 8.4aCVS

19 files changed, 437 insertions, 341 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index 1333f25..4b9899a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -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: tcl.h,v 1.70.2.1 2000/07/27 01:39:14 hobbs Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.70.2.2 2001/04/03 22:54:36 hobbs Exp $
  */
 
 #ifndef _TCL
@@ -59,10 +59,10 @@ extern "C" {
 #define TCL_MAJOR_VERSION   8
 #define TCL_MINOR_VERSION   3
 #define TCL_RELEASE_LEVEL   TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL  2
+#define TCL_RELEASE_SERIAL  3
 
 #define TCL_VERSION	    "8.3"
-#define TCL_PATCH_LEVEL	    "8.3.2"
+#define TCL_PATCH_LEVEL	    "8.3.3"
 
 /*
  * The following definitions set up the proper options for Windows
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index cbbf822..0dcf2e6 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -13,7 +13,7 @@
  *
  * This code contributed by Karl Lehenbauer and Mark Diekhans
  *
- * RCS: @(#) $Id: tclCkalloc.c,v 1.7.2.1 2000/08/07 21:30:08 hobbs Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.7.2.2 2001/04/03 22:54:36 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -1016,6 +1016,7 @@ TclFinalizeMemorySubsystem()
     }
     if (curTagPtr != NULL) {
 	TclpFree((char *) curTagPtr);
+	curTagPtr = NULL;
     }
     allocHead = NULL;
     Tcl_MutexUnlock(ckallocMutexPtr);
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 24f0642..2668432 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdIL.c,v 1.24 2000/04/04 08:04:41 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.24.2.1 2001/04/03 22:54:36 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -2019,8 +2019,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
     register int objc;		/* Number of arguments. */
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
-    Tcl_Obj *listPtr, *resultPtr;
-    Tcl_ObjType *typePtr;
+    Tcl_Obj *listPtr;
     int index, isDuplicate, len, result;
    
     if (objc < 4) {
@@ -2038,68 +2037,53 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
 	return result;
     }
 
-    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ len, &index);
+    /*
+     * Get the index.  "end" is interpreted to be the index after the last
+     * element, such that using it will cause any inserted elements to be
+     * appended to the list.
+     */
+
+    result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
     if (result != TCL_OK) {
 	return result;
     }
+    if (index > len) {
+	index = len;
+    }
 
     /*
      * If the list object is unshared we can modify it directly. Otherwise
-     * we create a copy to modify: this is "copy on write". We create the
-     * duplicate directly in the interpreter's object result.
+     * we create a copy to modify: this is "copy on write".
      */
-    
+
     listPtr = objv[1];
     isDuplicate = 0;
     if (Tcl_IsShared(listPtr)) {
-	/*
-	 * The following code must reflect the logic in Tcl_DuplicateObj()
-	 * except that it must duplicate the list object directly into the
-	 * interpreter's result.
-	 */
-	
-	Tcl_ResetResult(interp);
-	resultPtr = Tcl_GetObjResult(interp);
-	typePtr = listPtr->typePtr;
-	if (listPtr->bytes == NULL) {
-	    resultPtr->bytes = NULL;
-	} else if (listPtr->bytes != tclEmptyStringRep) {
-	    len = listPtr->length;
-	    TclInitStringRep(resultPtr, listPtr->bytes, len);
-	}
-	if (typePtr != NULL) {
-	    if (typePtr->dupIntRepProc == NULL) {
-		resultPtr->internalRep = listPtr->internalRep;
-		resultPtr->typePtr = typePtr;
-	    } else {
-		(*typePtr->dupIntRepProc)(listPtr, resultPtr);
-	    }
-	}
-	listPtr = resultPtr;
+	listPtr = Tcl_DuplicateObj(listPtr);
 	isDuplicate = 1;
     }
-    
-    if ((objc == 4) && (index == INT_MAX)) {
+
+    if ((objc == 4) && (index == len)) {
 	/*
 	 * Special case: insert one element at the end of the list.
 	 */
-
 	result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
     } else if (objc > 3) {
 	result = Tcl_ListObjReplace(interp, listPtr, index, 0,
 				    (objc-3), &(objv[3]));
     }
     if (result != TCL_OK) {
+	if (isDuplicate) {
+	    Tcl_DecrRefCount(listPtr); /* free unneeded obj */
+	}
 	return result;
     }
-    
+
     /*
      * Set the interpreter's object result.
      */
 
-    if (!isDuplicate) {
-	Tcl_SetObjResult(interp, listPtr);
-    }
+    Tcl_SetObjResult(interp, listPtr);
     return TCL_OK;
 }
 
@@ -2306,9 +2290,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
     Tcl_Obj *CONST objv[];	/* Argument objects. */
 {
     register Tcl_Obj *listPtr;
-    int createdNewObj, first, last, listLen, numToDelete;
-    int firstArgLen, result;
-    char *firstArg;
+    int isDuplicate, first, last, listLen, numToDelete, result;
 
     if (objc < 4) {
 	Tcl_WrongNumArgs(interp, 1, objv,
@@ -2316,53 +2298,43 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
 	return TCL_ERROR;
     }
 
-    /*
-     * If the list object is unshared we can modify it directly, otherwise
-     * we create a copy to modify: this is "copy on write".
-     */
-    
-    listPtr = objv[1];
-    createdNewObj = 0;
-    if (Tcl_IsShared(listPtr)) {
-	listPtr = Tcl_DuplicateObj(listPtr);
-	createdNewObj = 1;
-    }
-    result = Tcl_ListObjLength(interp, listPtr, &listLen);
+    result = Tcl_ListObjLength(interp, objv[1], &listLen);
     if (result != TCL_OK) {
-        errorReturn:
-	if (createdNewObj) {
-	    Tcl_DecrRefCount(listPtr); /* free unneeded obj */
-	}
 	return result;
     }
 
     /*
-     * Get the first and last indexes.
+     * Get the first and last indexes.  "end" is interpreted to be the index
+     * for the last element, such that using it will cause that element to
+     * be included for deletion.
      */
 
-    result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
-	    &first);
+    result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
     if (result != TCL_OK) {
-	goto errorReturn;
+	return result;
     }
-    firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
 
-    result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
-	    &last);
+    result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
     if (result != TCL_OK) {
-	goto errorReturn;
+	return result;
     }
 
     if (first < 0)  {
     	first = 0;
     }
-    if ((first >= listLen) && (listLen > 0)
-	    && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
+
+    /*
+     * Complain if the user asked for a start element that is greater than the
+     * list length.  This won't ever trigger for the "end*" case as that will
+     * be properly constrained by TclGetIntForIndex because we use listLen-1
+     * (to allow for replacing the last elem).
+     */
+
+    if ((first >= listLen) && (listLen > 0)) {
 	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 		"list doesn't contain element ",
 		Tcl_GetString(objv[2]), (int *) NULL);
-	result = TCL_ERROR;
-	goto errorReturn;
+	return TCL_ERROR;
     }
     if (last >= listLen) {
     	last = (listLen - 1);
@@ -2373,6 +2345,17 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
 	numToDelete = 0;
     }
 
+    /*
+     * If the list object is unshared we can modify it directly, otherwise
+     * we create a copy to modify: this is "copy on write".
+     */
+
+    listPtr = objv[1];
+    isDuplicate = 0;
+    if (Tcl_IsShared(listPtr)) {
+	listPtr = Tcl_DuplicateObj(listPtr);
+	isDuplicate = 1;
+    }
     if (objc > 4) {
 	result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
 	        (objc-4), &(objv[4]));
@@ -2381,7 +2364,10 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
 		0, NULL);
     }
     if (result != TCL_OK) {
-	goto errorReturn;
+	if (isDuplicate) {
+	    Tcl_DecrRefCount(listPtr); /* free unneeded obj */
+	}
+	return result;
     }
 
     /*
@@ -2578,7 +2564,6 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
 			!= TCL_OK) {
 		    return TCL_ERROR;
 		}
-		cmdPtr = objv[i+1];
 		i++;
 		break;
 	    case 6:			/* -integer */
@@ -2616,12 +2601,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
 
     sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
 	    &length, &listObjPtrs);
-    if (sortInfo.resultCode != TCL_OK) {
+    if (sortInfo.resultCode != TCL_OK || length <= 0) {
 	goto done;
     }
-    if (length <= 0) {
-        return TCL_OK;
-    }
     elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
     for (i=0; i < length; i++){
 	elementArray[i].objPtr = listObjPtrs[i];
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index cbb2f83..5695702 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.26 2000/04/10 21:08:26 ericm Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.26.2.1 2001/04/03 22:54:36 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -402,6 +402,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv)
 	}
 	offset += info.matches[0].end;
 	all++;
+	eflags |= TCL_REG_NOTBOL;
 	if (offset >= stringLength) {
 	    break;
 	}
@@ -908,15 +909,34 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
 	 * Do nothing.
 	 */
     } else if (splitCharLen == 0) {
+	Tcl_HashTable charReuseTable;
+	Tcl_HashEntry *hPtr;
+	int isNew;
+
 	/*
 	 * Handle the special case of splitting on every character.
+	 *
+	 * Uses a hash table to ensure that each kind of character has
+	 * only one Tcl_Obj instance (multiply-referenced) in the
+	 * final list.  This is a *major* win when splitting on a long
+	 * string (especially in the megabyte range!) - DKF
 	 */
 
+	Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
 	for ( ; string < end; string += len) {
 	    len = Tcl_UtfToUniChar(string, &ch);
-	    objPtr = Tcl_NewStringObj(string, len);
+	    /* Assume Tcl_UniChar is an integral type... */
+	    hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
+	    if (isNew) {
+		objPtr = Tcl_NewStringObj(string, len);
+		/* Don't need to fiddle with refcount... */
+		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
+	    } else {
+		objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
+	    }
 	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
 	}
+	Tcl_DeleteHashTable(&charReuseTable);
     } else {
 	char *element, *p, *splitEnd;
 	int splitLen;
@@ -1021,10 +1041,10 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	    for (i = 2; i < objc-2; i++) {
 		string2 = Tcl_GetStringFromObj(objv[i], &length2);
 		if ((length2 > 1)
-			&& strncmp(string2, "-nocase", (size_t) length2) == 0) {
+			&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
 		    nocase = 1;
 		} else if ((length2 > 1)
-			&& strncmp(string2, "-length", (size_t) length2) == 0) {
+			&& strncmp(string2, "-length", (size_t)length2) == 0) {
 		    if (i+1 >= objc-2) {
 			goto str_cmp_args;
 		    }
@@ -1201,25 +1221,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 	     */
 
 	    if (objv[2]->typePtr == &tclByteArrayType) {
-
 		string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
 
 		if (TclGetIntForIndex(interp, objv[3], length1 - 1,
 			&index) != TCL_OK) {
 		    return TCL_ERROR;
 		}
-		Tcl_SetByteArrayObj(resultPtr,
-			(unsigned char *)(&string1[index]), 1);
+		if ((index >= 0) && (index < length1)) {
+		    Tcl_SetByteArrayObj(resultPtr,
+			    (unsigned char *)(&string1[index]), 1);
+		}
 	    } else {
 		string1 = Tcl_GetStringFromObj(objv[2], &length1);
-		
+
 		/*
 		 * convert to Unicode internal rep to calulate what
 		 * 'end' really means.
 		 */
 
 		length2 = Tcl_GetCharLength(objv[2]);
-    
+
 		if (TclGetIntForIndex(interp, objv[3], length2 - 1,
 			&index) != TCL_OK) {
 		    return TCL_ERROR;
@@ -1645,6 +1666,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
 		 * empty charMap, just return whatever string was given
 		 */
 		Tcl_SetObjResult(interp, objv[objc-1]);
+		return TCL_OK;
 	    } else if (mapElemc & 1) {
 		/*
 		 * The charMap must be an even number of key/value items
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index c70dd0b..1ceebe2 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclEncoding.c,v 1.5 2000/01/21 02:25:26 hobbs Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.5.2.1 2001/04/03 22:54:36 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -1328,14 +1328,31 @@ LoadTableEncoding(interp, name, type, chan)
     TableEncodingData *dataPtr;
     unsigned short *pageMemPtr;
     Tcl_EncodingType encType;
-    char *hex;
+
+    /*
+     * Speed over memory. Use a full 256 character table to decode hex
+     * sequences in the encoding files.
+     */
+
     static char staticHex[] = {
-	0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0,
-	10, 11, 12, 13, 14, 15
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*   0 ...  15 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  16 ...  31 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  32 ...  47 */
+      0,  1,  2,  3,  4,  5,  6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /*  48 ...  63 */
+      0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  64 ...  79 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  80 ...  95 */
+      0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /*  96 ... 111 */
+      0,  1,  2,  3,  4,  5,  6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 112 ... 127 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 128 ... 143 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 144 ... 159 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160 ... 175 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 176 ... 191 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */
+      0,  0,  0,  0,  0,  0,  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */
     };
 
-    hex = staticHex - '0';
-
     Tcl_DStringInit(&lineString);
     Tcl_Gets(chan, &lineString);
     line = Tcl_DStringValue(&lineString);
@@ -1383,15 +1400,15 @@ LoadTableEncoding(interp, name, type, chan)
 
 	Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
 	p = Tcl_GetString(objPtr);
-	hi = (hex[(int)p[0]] << 4) + hex[(int)p[1]];
+	hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]];
 	dataPtr->toUnicode[hi] = pageMemPtr;
 	p += 2;
 	for (lo = 0; lo < 256; lo++) {
 	    if ((lo & 0x0f) == 0) {
 		p++;
 	    }
-	    ch = (hex[(int)p[0]] << 12) + (hex[(int)p[1]] << 8)
-		+ (hex[(int)p[2]] << 4) + hex[(int)p[3]];
+	    ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8)
+		+ (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]];
 	    if (ch != 0) {
 		used[ch >> 8] = 1;
 	    }
@@ -1510,7 +1527,6 @@ LoadTableEncoding(interp, name, type, chan)
     encType.nullSize	    = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
     encType.clientData	    = (ClientData) dataPtr;
     return Tcl_CreateEncoding(&encType);
-
 }
 
 /*
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 74ab36f..a1d8184 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.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: tclEnv.c,v 1.7.2.1 2000/08/07 21:33:02 hobbs Exp $
+ * RCS: @(#) $Id: tclEnv.c,v 1.7.2.2 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -356,7 +356,7 @@ TclUnsetEnv(name)
     CONST char *name;		/* Name of variable to remove (UTF-8). */
 {
     char *oldValue;
-    unsigned int length;
+    int length;
     int index;
 #ifdef USE_PUTENV
     Tcl_DString envString;
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index ce43e94..bb0323e 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -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: tclEvent.c,v 1.8 2000/04/18 23:10:04 hobbs Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.8.2.1 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -99,6 +99,11 @@ typedef struct ThreadSpecificData {
 static Tcl_ThreadDataKey dataKey;
 
 /*
+ * Common string for the library path for sharing across threads.
+ */
+char *tclLibraryPathStr;
+
+/*
  * Prototypes for procedures referenced only in this file:
  */
 
@@ -596,6 +601,12 @@ TclSetLibraryPath(pathPtr)
 	Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
     }
     tsdPtr->tclLibraryPath = pathPtr;
+
+    /*
+     *  No mutex locking is needed here as up the stack we're within
+     *  TclpInitLock().
+     */
+    tclLibraryPathStr = Tcl_GetStringFromObj(pathPtr, NULL);
 }
 
 /*
@@ -619,6 +630,17 @@ Tcl_Obj *
 TclGetLibraryPath()
 {
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    if (tsdPtr->tclLibraryPath == NULL) {
+	/*
+	 * Grab the shared string and place it into a new thread specific
+	 * Tcl_Obj.
+	 */
+	tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1);
+
+	/* take ownership */
+	Tcl_IncrRefCount(tsdPtr->tclLibraryPath);
+    }
     return tsdPtr->tclLibraryPath;
 }
 
@@ -744,10 +766,11 @@ Tcl_Finalize()
     ThreadSpecificData *tsdPtr;
 
     TclpInitLock();
-    tsdPtr = TCL_TSD_INIT(&dataKey);
     if (subsystemsInitialized != 0) {
 	subsystemsInitialized = 0;
 
+	tsdPtr = TCL_TSD_INIT(&dataKey);
+
 	/*
 	 * Invoke exit handlers first.
 	 */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index bc026b3..2e1f841 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -5,11 +5,12 @@
  *	commands.
  *
  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
  *
  * 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.10 2000/03/27 22:18:55 hobbs Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.10.2.1 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -113,6 +114,17 @@ static char *resultStrings[] = {
 #endif
 
 /*
+ * These are used by evalstats to monitor object usage in Tcl.
+ */
+
+#ifdef TCL_COMPILE_STATS
+long		tclObjsAlloced = 0;
+long		tclObjsFreed   = 0;
+#define TCL_MAX_SHARED_OBJ_STATS 5
+long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
+#endif /* TCL_COMPILE_STATS */
+
+/*
  * Macros for testing floating-point values for certain special cases. Test
  * for not-a-number by comparing a value against itself; test for infinity
  * by comparing against the largest floating-point value.
@@ -425,7 +437,7 @@ void
 TclDeleteExecEnv(eePtr)
     ExecEnv *eePtr;		/* Execution environment to free. */
 {
-    ckfree((char *) eePtr->stackPtr);
+    Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);
     ckfree((char *) eePtr);
 }
 
@@ -495,7 +507,7 @@ GrowEvaluationStack(eePtr)
  
     memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
 	   (size_t) currBytes);
-    ckfree((char *) eePtr->stackPtr);
+    Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);
     eePtr->stackPtr = newStackPtr;
     eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
 }
@@ -732,15 +744,19 @@ TclExecuteByteCode(interp, codePtr)
 		Tcl_Obj **objv;	 /* The array of argument objects. */
 		Command *cmdPtr; /* Points to command's Command struct. */
 		int newPcOffset; /* New inst offset for break, continue. */
+		Tcl_Obj **preservedStack;
+				 /* Reference to memory block containing
+				  * objv array (must be kept live throughout
+				  * trace and command invokations.) */
 #ifdef TCL_COMPILE_DEBUG
 		int isUnknownCmd = 0;
 		char cmdNameBuf[21];
 #endif /* TCL_COMPILE_DEBUG */
-		
+
 		/*
 		 * If the interpreter was deleted, return an error.
 		 */
-		
+
 		if (iPtr->flags & DELETED) {
 		    Tcl_ResetResult(interp);
 		    Tcl_AppendToObj(Tcl_GetObjResult(interp),
@@ -751,7 +767,7 @@ TclExecuteByteCode(interp, codePtr)
 		    result = TCL_ERROR;
 		    goto checkForCatch;
 		}
-    
+
 		/*
 		 * Find the procedure to execute this command. If the
 		 * command is not found, handle it with the "unknown" proc.
@@ -783,14 +799,26 @@ TclExecuteByteCode(interp, codePtr)
 		    objv[0] = Tcl_NewStringObj("unknown", -1);
 		    Tcl_IncrRefCount(objv[0]);
 		}
-		
+
+		/*
+		 * A reference to part of the stack vector itself
+		 * escapes our control, so must use preserve/release
+		 * to stop it from being deallocated by a recursive
+		 * call to ourselves.  The extra variable is needed
+		 * because all others are liable to change due to the
+		 * trace procedures.
+		 */
+
+		Tcl_Preserve((ClientData)stackPtr);
+		preservedStack = stackPtr;
+
 		/*
 		 * Call any trace procedures.
 		 */
 
 		if (iPtr->tracePtr != NULL) {
 		    Trace *tracePtr, *nextTracePtr;
-
+		    
 		    for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
 		            tracePtr = nextTracePtr) {
 			nextTracePtr = tracePtr->nextPtr;
@@ -807,14 +835,14 @@ TclExecuteByteCode(interp, codePtr)
 			}
 		    }
 		}
-		
+
 		/*
 		 * Finally, invoke the command's Tcl_ObjCmdProc. First reset
 		 * the interpreter's string and object results to their
 		 * default empty values since they could have gotten changed
 		 * by earlier invocations.
 		 */
-		
+
 		Tcl_ResetResult(interp);
 		if (tclTraceExec >= 2) {
 #ifdef TCL_COMPILE_DEBUG
@@ -850,6 +878,14 @@ TclExecuteByteCode(interp, codePtr)
 		CACHE_STACK_INFO();
 
 		/*
+		 * If the old stack is going to be released, it is
+		 * safe to do so now, since no references to objv are
+		 * going to be used from now on.
+		 */
+
+		Tcl_Release((ClientData)preservedStack);
+
+		/*
 		 * If the interpreter has a non-empty string result, the
 		 * result object is either empty or stale because some
 		 * procedure set interp->result directly. If so, move the
@@ -2307,15 +2343,18 @@ TclExecuteByteCode(interp, codePtr)
 	case INST_LNOT:
 	    {
 		/*
-		 * The operand must be numeric. If the operand object is
-		 * unshared modify it directly, otherwise create a copy to
-		 * modify: this is "copy on write". free any old string
-		 * representation since it is now invalid.
+		 * The operand must be numeric or a boolean string as
+		 * accepted by Tcl_GetBooleanFromObj(). If the operand
+		 * object is unshared modify it directly, otherwise
+		 * create a copy to modify: this is "copy on write".
+		 * Free any old string representation since it is now
+		 * invalid.
 		 */
-		
+
 		double d;
+		int boolvar;
 		Tcl_ObjType *tPtr;
-		
+
 		valuePtr = POP_OBJECT();
 		tPtr = valuePtr->typePtr;
 		if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
@@ -2332,6 +2371,11 @@ TclExecuteByteCode(interp, codePtr)
 			    result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
 				    valuePtr, &d);
 			}
+			if (result == TCL_ERROR && *pc == INST_LNOT) {
+			    result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
+				    valuePtr, &boolvar);
+			    i = (long)boolvar; /* i is long, not int! */
+			}
 			if (result != TCL_OK) {
 			    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
 				    s, (tPtr? tPtr->name : "null")));
@@ -2342,12 +2386,12 @@ TclExecuteByteCode(interp, codePtr)
 		    }
 		    tPtr = valuePtr->typePtr;
 		}
-		
+
 		if (Tcl_IsShared(valuePtr)) {
 		    /*
 		     * Create a new object.
 		     */
-		    if (tPtr == &tclIntType) {
+		    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
 			i = valuePtr->internalRep.longValue;
 			objPtr = Tcl_NewLongObj(
 			        (*pc == INST_UMINUS)? -i : !i);
@@ -2371,7 +2415,7 @@ TclExecuteByteCode(interp, codePtr)
 		    /*
 		     * valuePtr is unshared. Modify it directly.
 		     */
-		    if (tPtr == &tclIntType) {
+		    if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
 			i = valuePtr->internalRep.longValue;
 			Tcl_SetLongObj(valuePtr,
 			        (*pc == INST_UMINUS)? -i : !i);
@@ -3844,11 +3888,21 @@ ExprRandFunc(interp, eePtr, clientData)
     register int stackTop;	/* Cached top index of evaluation stack. */
     Interp *iPtr = (Interp *) interp;
     double dResult;
-    int tmp;
+    long tmp;			/* Algorithm assumes at least 32 bits.
+				 * Only long guarantees that.  See below. */
 
     if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
 	iPtr->flags |= RAND_SEED_INITIALIZED;
 	iPtr->randSeed = TclpGetClicks();
+
+	/*
+	 * Make sure 1 <= randSeed <= (2^31) - 2.  See below.
+	 */
+
+        iPtr->randSeed &= (unsigned long) 0x7fffffff;
+	if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
+	    iPtr->randSeed ^= 123459876;
+	}
     }
     
     /*
@@ -3861,11 +3915,20 @@ ExprRandFunc(interp, eePtr, clientData)
      * Generate the random number using the linear congruential
      * generator defined by the following recurrence:
      *		seed = ( IA * seed ) mod IM
-     * where IA is 16807 and IM is (2^31) - 1.  In order to avoid
-     * potential problems with integer overflow, the  code uses
-     * additional constants IQ and IR such that
+     * where IA is 16807 and IM is (2^31) - 1.  The recurrence maps
+     * a seed in the range [1, IM - 1] to a new seed in that same range.
+     * The recurrence maps IM to 0, and maps 0 back to 0, so those two
+     * values must not be allowed as initial values of seed.
+     *
+     * In order to avoid potential problems with integer overflow, the
+     * recurrence is implemented in terms of additional constants
+     * IQ and IR such that
      *		IM = IA*IQ + IR
-     * For details on how this algorithm works, refer to the following
+     * None of the operations in the implementation overflows a 32-bit
+     * signed integer, and the C type long is guaranteed to be at least
+     * 32 bits wide.
+     *
+     * For more details on how this algorithm works, refer to the following
      * papers: 
      *
      *	S.K. Park & K.W. Miller, "Random number generators: good ones
@@ -3881,14 +3944,6 @@ ExprRandFunc(interp, eePtr, clientData)
 #define RAND_IR		2836
 #define RAND_MASK	123459876
 
-    if (iPtr->randSeed == 0) {
-	/*
-	 * Don't allow a 0 seed, since it breaks the generator.  Shift
-	 * it to some other value.
-	 */
-
-	iPtr->randSeed = 123459876;
-    }
     tmp = iPtr->randSeed/RAND_IQ;
     iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
     if (iPtr->randSeed < 0) {
@@ -3896,14 +3951,10 @@ ExprRandFunc(interp, eePtr, clientData)
     }
 
     /*
-     * On 64-bit architectures we need to mask off the upper bits to
-     * ensure we only have a 32-bit range.  The constant has the
-     * bizarre form below in order to make sure that it doesn't
-     * get sign-extended (the rules for sign extension are very
-     * concat, particularly on 64-bit machines).
+     * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
+     * dividing by RAND_IM yields a double in the range (0, 1).
      */
 
-    iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
     dResult = iPtr->randSeed * (1.0/RAND_IM);
 
     /*
@@ -4050,11 +4101,16 @@ ExprSrandFunc(interp, eePtr, clientData)
     }
     
     /*
-     * Reset the seed.
+     * Reset the seed.  Make sure 1 <= randSeed <= 2^31 - 2.
+     * See comments in ExprRandFunc() for more details.
      */
 
     iPtr->flags |= RAND_SEED_INITIALIZED;
     iPtr->randSeed = i;
+    iPtr->randSeed &= (unsigned long) 0x7fffffff;
+    if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
+	iPtr->randSeed ^= 123459876;
+    }
 
     /*
      * To avoid duplicating the random number generation code we simply
@@ -4449,7 +4505,7 @@ EvalStatsCmd(unused, interp, argc, argv)
     fprintf(stdout, "  Mean code/source		%.1f\n",
 	    totalCodeBytes / statsPtr->totalSrcBytes);
 
-    fprintf(stdout, "\nCurrent ByteCodes		%ld\n",
+    fprintf(stdout, "\nCurrent (active) ByteCodes	%ld\n",
 	    numCurrentByteCodes);
     fprintf(stdout, "  Source bytes			%.6g\n",
 	    statsPtr->currentSrcBytes);
@@ -4472,6 +4528,29 @@ EvalStatsCmd(unused, interp, argc, argv)
 	    (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
 
     /*
+     * Tcl_IsShared statistics check
+     *
+     * This gives the refcount of each obj as Tcl_IsShared was called
+     * for it.  Shared objects must be duplicated before they can be
+     * modified.
+     */
+
+    numSharedMultX = 0;
+    fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
+    fprintf(stdout, "  Object had refcount <=1 (not shared)	%ld\n",
+	    tclObjsShared[1]);
+    for (i = 2;  i < TCL_MAX_SHARED_OBJ_STATS;  i++) {
+	fprintf(stdout, "  refcount ==%d		%ld\n",
+		i, tclObjsShared[i]);
+	numSharedMultX += tclObjsShared[i];
+    }
+    fprintf(stdout, "  refcount >=%d		%ld\n",
+	    i, tclObjsShared[0]);
+    numSharedMultX += tclObjsShared[0];
+    fprintf(stdout, "  Total shared objects			%d\n",
+	    numSharedMultX);
+
+    /*
      * Literal table statistics.
      */
 
@@ -4511,7 +4590,7 @@ EvalStatsCmd(unused, interp, argc, argv)
 	    (tclObjsAlloced - tclObjsFreed));
     fprintf(stdout, "Total literal objects		%ld\n",
 	    statsPtr->numLiteralsCreated);
-    
+
     fprintf(stdout, "\nCurrent literal objects		%d (%0.1f%% of current objects)\n",
 	    globalTablePtr->numEntries,
 	    (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
@@ -4662,7 +4741,7 @@ EvalStatsCmd(unused, interp, argc, argv)
 		decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
     }
 
-    fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
+    fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
     fprintf(stdout, "	       Up to ms		Percentage\n");
     minSizeDecade = maxSizeDecade = 0;
     for (i = 0;  i < 31;  i++) {
diff --git a/generic/tclIO.c b/generic/tclIO.c
index c6c0e62..5eb2b31 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIO.c,v 1.20.2.5 2000/08/08 00:57:40 hobbs Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.20.2.6 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -41,18 +41,6 @@ typedef struct ThreadSpecificData {
      * as only one ChannelState exists per set of stacked channels.
      */
     ChannelState *firstCSPtr;
-#ifdef oldcode
-    /*
-     * Has a channel exit handler been created yet?
-     */
-    int channelExitHandlerCreated;
-
-    /*
-     * Has the channel event source been created and registered with the
-     * notifier?
-     */
-    int channelEventSourceCreated;
-#endif
     /*
      * Static variables to hold channels for stdin, stdout and stderr.
      */
@@ -2059,20 +2047,6 @@ CloseChannel(interp, chanPtr, errorCode)
         c = (char) statePtr->outEofChar;
         (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy);
     }
-#if 0
-    /*
-     * Remove TCL_READABLE and TCL_WRITABLE from statePtr->flags, so
-     * that close callbacks can not do input or output (assuming they
-     * squirreled the channel away in their clientData). This also
-     * prevents infinite loops if the callback calls any C API that
-     * could call FlushChannel.
-     */
-
-    /*
-     * This prevents any data from being flushed from stacked channels.
-     */
-    statePtr->flags &= (~(TCL_READABLE|TCL_WRITABLE));
-#endif
 
     /*
      * Splice this channel out of the list of all channels.
@@ -2148,23 +2122,6 @@ CloseChannel(interp, chanPtr, errorCode)
      */
 
     if (chanPtr->downChanPtr != (Channel *) NULL) {
-#if 0
-	int code = TCL_OK;
-
-	while (chanPtr->downChanPtr != (Channel *) NULL) {
-	    /*
-	     * Unwind the state of the transformation, and then restore the
-	     * state of (unstack) the underlying channel into the TOP channel
-	     * structure.
-	     */
-	    code = Tcl_UnstackChannel(interp, (Tcl_Channel) chanPtr);
-	    if (code == TCL_ERROR) {
-		errorCode = Tcl_GetErrno();
-		break;
-	    }
-	    chanPtr = chanPtr->downChanPtr;
-	}
-#else
 	Channel *downChanPtr = chanPtr->downChanPtr;
 
 	statePtr->nextCSPtr	= tsdPtr->firstCSPtr;
@@ -2176,7 +2133,6 @@ CloseChannel(interp, chanPtr, errorCode)
 
 	Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
 	return Tcl_Close(interp, (Tcl_Channel) downChanPtr);
-#endif
     }
 
     /*
@@ -2185,6 +2141,7 @@ CloseChannel(interp, chanPtr, errorCode)
      */
     chanPtr->typePtr = NULL;
 
+    Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC);
     Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
 
     return errorCode;
@@ -5932,7 +5889,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
 		 * coded later.
 		 */
 
-		if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) {
+		if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) {
 		    statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
 		} else {
 		    statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
@@ -6090,7 +6047,6 @@ Tcl_NotifyChannel(channel, mask)
     ChannelHandler *chPtr;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
     NextChannelHandler nh;
-#ifdef TCL_CHANNEL_VERSION_2
     Channel* upChanPtr;
     Tcl_ChannelType* upTypePtr;
 
@@ -6148,6 +6104,7 @@ Tcl_NotifyChannel(channel, mask)
      */
      
     Tcl_Preserve((ClientData) channel);
+    Tcl_Preserve((ClientData) statePtr);
 
     /*
      * If we are flushing in the background, be sure to call FlushChannel
@@ -6196,82 +6153,10 @@ Tcl_NotifyChannel(channel, mask)
         UpdateInterest(chanPtr);
     }
 
+    Tcl_Release((ClientData) statePtr);
     Tcl_Release((ClientData) channel);
 
     tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
-#else
-    /* Walk all channels in a stack ! and notify them in order.
-     */
-
-    while (chanPtr != (Channel *) NULL) {
-        /*
-	 * Preserve the channel struct in case the script closes it.
-	 */
-     
-        Tcl_Preserve((ClientData) channel);
-
-	/*
-	 * If we are flushing in the background, be sure to call FlushChannel
-	 * for writable events.  Note that we have to discard the writable
-	 * event so we don't call any write handlers before the flush is
-	 * complete.
-	 */
-
-	if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
-	    FlushChannel(NULL, chanPtr, 1);
-	    mask &= ~TCL_WRITABLE;
-	}
-
-	/*
-	 * Add this invocation to the list of recursive invocations of
-	 * ChannelHandlerEventProc.
-	 */
-    
-	nh.nextHandlerPtr = (ChannelHandler *) NULL;
-	nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr;
-	tsdPtr->nestedHandlerPtr = &nh;
-
-	for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; ) {
-
-	    /*
-	     * If this channel handler is interested in any of the events that
-	     * have occurred on the channel, invoke its procedure.
-	     */
-        
-	    if ((chPtr->mask & mask) != 0) {
-		nh.nextHandlerPtr = chPtr->nextPtr;
-		(*(chPtr->proc))(chPtr->clientData, mask);
-		chPtr = nh.nextHandlerPtr;
-	    } else {
-		chPtr = chPtr->nextPtr;
-	    }
-	}
-
-	/*
-	 * Update the notifier interest, since it may have changed after
-	 * invoking event handlers. Skip that if the channel was deleted
-	 * in the call to the channel handler.
-	 */
-
-	if (chanPtr->typePtr != NULL) {
-	    UpdateInterest(chanPtr);
-
-	    /* Walk down the stack.
-	     */
-	    chanPtr = chanPtr->downChanPtr;
-	} else {
-	    /* Stop walking the chain, the whole stack was destroyed!
-	     */
-	    chanPtr = (Channel *) NULL;
-	}
-
-	Tcl_Release((ClientData) channel);
-
-	tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
-
-	channel = (Tcl_Channel) chanPtr;
-    }
-#endif
 }
 
 /*
@@ -7052,6 +6937,18 @@ CopyData(csPtr, mask)
 	}
 
 	/*
+	 * Update the current byte count.  Do it now so the count is
+	 * valid before a return or break takes us out of the loop.
+	 * The invariant at the top of the loop should be that 
+	 * csPtr->toRead holds the number of bytes left to copy.
+	 */
+
+	if (csPtr->toRead != -1) {
+	    csPtr->toRead -= size;
+	}
+	csPtr->total += size;
+
+	/*
 	 * Check to see if the write is happening in the background.  If so,
 	 * stop copying and wait for the channel to become writable again.
 	 */
@@ -7059,7 +6956,7 @@ CopyData(csPtr, mask)
 	if (outStatePtr->flags & BG_FLUSH_SCHEDULED) {
 	    if (!(mask & TCL_WRITABLE)) {
 		if (mask & TCL_READABLE) {
-		    Tcl_DeleteChannelHandler(outChan, CopyEventProc,
+		    Tcl_DeleteChannelHandler(inChan, CopyEventProc,
 			    (ClientData) csPtr);
 		}
 		Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
@@ -7069,15 +6966,6 @@ CopyData(csPtr, mask)
 	}
 
 	/*
-	 * Update the current byte count if we care.
-	 */
-
-	if (csPtr->toRead != -1) {
-	    csPtr->toRead -= size;
-	}
-	csPtr->total += size;
-
-	/*
 	 * For background copies, we only do one buffer per invocation so
 	 * we don't starve the rest of the system.
 	 */
@@ -7769,6 +7657,7 @@ StopCopy(csPtr)
 		nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
     }
     if (csPtr->readPtr != csPtr->writePtr) {
+	nonBlocking = (csPtr->writeFlags & CHANNEL_NONBLOCKING);
 	if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
 	    SetBlockMode(NULL, csPtr->writePtr,
 		    nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
@@ -7928,15 +7817,30 @@ Tcl_GetChannelNamesEx(interp, pattern)
     Tcl_Interp *interp;		/* Interp for error reporting. */
     char *pattern;		/* pattern to filter on. */
 {
-    ChannelState *statePtr;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-    char *name;
-    Tcl_Obj *resultPtr;
+    ChannelState *statePtr;
+    char *name;			/* name for channel */
+    Tcl_Obj *resultPtr;		/* pointer to result object */
+    Tcl_HashTable *hTblPtr;	/* Hash table of channels. */
+    Tcl_HashEntry *hPtr;	/* Search variable. */
+    Tcl_HashSearch hSearch;	/* Search variable. */
 
-    resultPtr = Tcl_GetObjResult(interp);
-    for (statePtr = tsdPtr->firstCSPtr;
-	 statePtr != NULL;
-	 statePtr = statePtr->nextCSPtr) {
+    if (interp == (Tcl_Interp *) NULL) {
+	return TCL_OK;
+    }
+
+    /*
+     * Get the channel table that stores the channels registered
+     * for this interpreter.
+     */
+    hTblPtr	= GetChannelTable(interp);
+    resultPtr	= Tcl_GetObjResult(interp);
+
+    for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+	 hPtr != (Tcl_HashEntry *) NULL;
+	 hPtr = Tcl_NextHashEntry(&hSearch)) {
+
+	statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
         if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
 	    name = "stdin";
 	} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
@@ -7944,8 +7848,13 @@ Tcl_GetChannelNamesEx(interp, pattern)
 	} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
 	    name = "stderr";
 	} else {
+	    /*
+	     * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr),
+	     * but it's simpler to just grab the name from the statePtr.
+	     */
 	    name = statePtr->channelName;
 	}
+
 	if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
 		(Tcl_ListObjAppendElement(interp, resultPtr,
 			Tcl_NewStringObj(name, -1)) != TCL_OK)) {
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 28095af..542b5d9 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * CVS: $Id: tclIOGT.c,v 1.1.4.2 2000/08/06 00:20:10 hobbs Exp $
+ * CVS: $Id: tclIOGT.c,v 1.1.4.3 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -171,7 +171,7 @@ struct ResultBuffer {
  * out information waiting in buffers (fileevent support).
  */
 
-#define DELAY (5)
+#define FLUSH_DELAY (5)
 
 /*
  * Convenience macro to make some casts easier to use.
@@ -1046,7 +1046,7 @@ TransformWatchProc (instanceData, mask)
 	 * to flush that.
 	 */
 
-	dataPtr->timer = Tcl_CreateTimerHandler (DELAY,
+	dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY,
 		TransformChannelHandlerTimer, (ClientData) dataPtr);
     }
 }
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index d0bc2a1..496a2ff 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIndexObj.c,v 1.4.10.1 2000/08/07 21:33:15 hobbs Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.4.10.2 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -36,6 +36,16 @@ Tcl_ObjType tclIndexType = {
 };
 
 /*
+ * DKF - Just noting that the data format used in objects with the
+ * above type is that the ptr1 field will contain a pointer to the
+ * table that the last lookup was performed in, and the ptr2 field
+ * will contain the sizeof(char) offset of the string within that
+ * table.  Note that we assume that each table is only ever called
+ * with a single offset, but this is a pretty safe assumption in
+ * practise...
+ */
+
+/*
  * Boolean flag indicating whether or not the tclIndexType object
  * type has been registered with the Tcl compiler.
  */
@@ -90,7 +100,8 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
 
     if ((objPtr->typePtr == &tclIndexType)
 	    && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
-	*indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
+	*indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2)
+	                   / sizeof(char *);
 	return TCL_OK;
     }
     return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
@@ -151,7 +162,7 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
 
     if ((objPtr->typePtr == &tclIndexType)
 	    && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
-	*indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
+	*indexPtr = ((int) objPtr->internalRep.twoPtrValue.ptr2) / offset;
 	return TCL_OK;
     }
 
@@ -183,7 +194,7 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
     }
     
     for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; 
-	    entryPtr = (char **) ((long) entryPtr + offset), i++) {
+	    entryPtr = (char **) ((size_t) entryPtr + offset), i++) {
 	for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
 	    if (*p1 == 0) {
 		index = i;
@@ -216,8 +227,7 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
     /*
      * Make sure to account for offsets != sizeof(char *).  [Bug 5153]
      */
-    objPtr->internalRep.twoPtrValue.ptr2 =
-	(VOID *) (index * (offset / sizeof(char *)));
+    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) (index * offset);
     objPtr->typePtr = &tclIndexType;
     *indexPtr = index;
     return TCL_OK;
@@ -229,10 +239,10 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
 	Tcl_AppendStringsToObj(resultPtr,
 		(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
 		key, "\": must be ", *tablePtr, (char *) NULL);
-	for (entryPtr = (char **) ((long) tablePtr + offset), count = 0;
+	for (entryPtr = (char **) ((size_t) tablePtr + offset), count = 0;
 		*entryPtr != NULL;
-		entryPtr = (char **) ((long) entryPtr + offset), count++) {
-	    if ((*((char **) ((long) entryPtr + offset))) == NULL) {
+		entryPtr = (char **) ((size_t) entryPtr + offset), count++) {
+	    if ((*((char **) ((size_t) entryPtr + offset))) == NULL) {
 		Tcl_AppendStringsToObj(resultPtr,
 			(count > 0) ? ", or " : " or ", *entryPtr,
 			(char *) NULL);
@@ -314,7 +324,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message)
 {
     Tcl_Obj *objPtr;
     char **tablePtr;
-    int i;
+    int i, offset;
 
     objPtr = Tcl_GetObjResult(interp);
     Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
@@ -327,19 +337,26 @@ Tcl_WrongNumArgs(interp, objc, objv, message)
 	
 	if (objv[i]->typePtr == &tclIndexType) {
 	    tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
+	    offset = ((int) objv[i]->internalRep.twoPtrValue.ptr2);
 	    Tcl_AppendStringsToObj(objPtr,
-		    tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
+		    *((char **)(((char *)tablePtr)+offset)),
 		    (char *) NULL);
 	} else {
 	    Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
 		    (char *) NULL);
 	}
-	if (i < (objc - 1)) {
+
+	/*
+	 * Append a space character (" ") if there is more text to follow
+	 * (either another element from objv, or the message string).
+	 */
+	if ((i < (objc - 1)) || message) {
 	    Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
 	}
     }
+
     if (message) {
-      Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
+	Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);
     }
     Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
 }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index bd6a314..8ca0b86 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.42 2000/04/09 16:04:18 kupries Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.42.2.1 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #ifndef _TCLINT
@@ -1549,6 +1549,8 @@ extern Tcl_Obj *	tclFreeObjList;
 #ifdef TCL_COMPILE_STATS
 extern long		tclObjsAlloced;
 extern long		tclObjsFreed;
+#define TCL_MAX_SHARED_OBJ_STATS 5
+extern long		tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
 #endif /* TCL_COMPILE_STATS */
 
 /*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 43b074c..9ab5879 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.17 2000/03/27 22:18:56 hobbs Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.17.2.1 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -1265,6 +1265,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
 			        "import pattern \"", pattern,
 				"\" would create a loop containing command \"",
 				Tcl_DStringValue(&ds), "\"", (char *) NULL);
+			Tcl_DStringFree(&ds);
 			return TCL_ERROR;
 		    }
 		}
@@ -1277,6 +1278,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
 		dataPtr->realCmdPtr = cmdPtr;
 		dataPtr->selfPtr = (Command *) importedCmd;
 		dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
+		Tcl_DStringFree(&ds);
 
 		/*
 		 * Create an ImportRef structure describing this new import
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5b3fec7..abc7077 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclObj.c,v 1.12 1999/12/04 06:15:41 hobbs Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.12.2.1 2001/04/03 22:54:37 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -648,15 +648,7 @@ Tcl_DuplicateObj(objPtr)
     if (objPtr->bytes == NULL) {
 	dupPtr->bytes = NULL;
     } else if (objPtr->bytes != tclEmptyStringRep) {
-	int len = objPtr->length;
-	
-	dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
-	if (len > 0) {
-	    memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
-		   (unsigned) len);
-	}
-	dupPtr->bytes[len] = '\0';
-	dupPtr->length = len;
+	TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
     }
     
     if (typePtr != NULL) {
diff --git a/generic/tclParse.c b/generic/tclParse.c
index ab50ac4..8a508cb 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -9,12 +9,12 @@
  *	allow scripts to be evaluated directly, without compiling.
  *
  * Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright (c) 1998-2000 Ajuba Solutions.
  *
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclParse.c,v 1.13 1999/11/10 02:51:57 hobbs Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.13.2.1 2001/04/03 22:54:38 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -1456,15 +1456,51 @@ Tcl_EvalEx(interp, script, numBytes, flags)
 	Tcl_DecrRefCount(objv[i]);
     }
     if (gotParse) {
-	p = parse.commandStart + parse.commandSize;
+	next = parse.commandStart + parse.commandSize;
+	bytesLeft -= next - p;
+	p = next;
 	Tcl_FreeParse(&parse);
-	if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+
+	if ((nested != 0) && (p > script)) {
+	    char *nextCmd = NULL;	/* pointer to start of next command */
+
 	    /*
 	     * We get here in the special case where the TCL_BRACKET_TERM
-	     * flag was set in the interpreter and we reached a close
-	     * bracket in the script.  Return immediately.
+	     * flag was set in the interpreter.
+	     *
+	     * At this point, we want to find the end of the script
+	     * (either end of script or the closing ']').
 	     */
 
+	    while ((p[-1] != ']') && bytesLeft) {
+		if (Tcl_ParseCommand(NULL, p, bytesLeft, nested, &parse)
+			!= TCL_OK) {
+		    /*
+		     * We were looking for the ']' to close the script.
+		     * But if we find a syntax error, it is ok to quit
+		     * early since in that case we no longer need to know
+		     * where the ']' is (if there was one).  We reset the
+		     * pointer to the start of the command that after the
+		     * one causing the return.  -- hobbs
+		     */
+
+		    p = (nextCmd == NULL) ? parse.commandStart : nextCmd;
+		    break;
+		}
+
+		if (nextCmd == NULL) {
+		    nextCmd = parse.commandStart;
+		}
+
+		/*
+		 * Advance to the next command in the script.
+		 */
+
+		next = parse.commandStart + parse.commandSize;
+		bytesLeft -= next - p;
+		p = next;
+		Tcl_FreeParse(&parse);
+	    }
 	    iPtr->termOffset = (p - 1) - script;
 	} else {
 	    iPtr->termOffset = p - script;
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index 08f8b0f..79794b4 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -6,12 +6,21 @@
  * Copyright (c) 1998-1999 by Scriptics Corporation.
  * All rights reserved.
  *
- * RCS: @(#) $Id: tclPlatDecls.h,v 1.5 1999/04/30 22:45:02 stanton Exp $
+ * RCS: @(#) $Id: tclPlatDecls.h,v 1.5.12.1 2001/04/03 22:54:38 hobbs Exp $
  */
 
 #ifndef _TCLPLATDECLS
 #define _TCLPLATDECLS
 
+/*
+ *  Pull in the definition of TCHAR.  Hopefully the compile flags
+ *  of the core are matching against your project build for these
+ *  public functions.  BE AWARE.
+ */
+#if defined(__WIN32__) && !defined(_INC_TCHAR)
+#include <tchar.h>
+#endif
+
 /* !BEGIN!: Do not edit below this line. */
 
 /*
diff --git a/generic/tclScan.c b/generic/tclScan.c
index bf238cf..8d2310e 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclScan.c,v 1.6 1999/11/30 01:42:59 hobbs Exp $
+ * RCS: @(#) $Id: tclScan.c,v 1.6.2.1 2001/04/03 22:54:38 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -694,12 +694,12 @@ Tcl_ScanObjCmd(dummy, interp, objc, objv)
 	    case 'o':
 		op = 'i';
 		base = 8;
-		fn = (long (*)())strtol;
+		fn = (long (*)())strtoul;
 		break;
 	    case 'x':
 		op = 'i';
 		base = 16;
-		fn = (long (*)())strtol;
+		fn = (long (*)())strtoul;
 		break;
 	    case 'u':
 		op = 'i';
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 2733a8c..f36af0a 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.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: tclTestObj.c,v 1.6 1999/06/15 22:06:17 hershey Exp $
+ * RCS: @(#) $Id: tclTestObj.c,v 1.6.10.1 2001/04/03 22:54:38 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -420,7 +420,8 @@ TestindexobjCmd(clientData, interp, objc, objv)
 	if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2;
+	objv[1]->internalRep.twoPtrValue.ptr2 =
+		(VOID *) (index2 * sizeof(char *));
 	result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
 		tablePtr, "token", 0, &index);
 	if (result == TCL_OK) {
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 834a8dc..ee3d63e 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -14,7 +14,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.16 2000/01/21 03:29:14 ericm Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.16.2.1 2001/04/03 22:54:38 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -2870,12 +2870,11 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
     Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
     Tcl_HashEntry *hPtr;
-    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+    Tcl_Obj *resultPtr;
     int notArray;
     char *varName, *msg;
     int index, result;
 
-
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
 	return TCL_ERROR;
@@ -2915,6 +2914,13 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
 	}
     }
 
+    /*
+     * We have to wait to get the resultPtr until here because
+     * CallTraces can affect the result.
+     */
+
+    resultPtr = Tcl_GetObjResult(interp);
+
     switch (index) {
         case ARRAY_ANYMORE: {
 	    ArraySearch *searchPtr;
@@ -4769,7 +4775,6 @@ TclVarTraceExists(interp, varName)
 {
     Var *varPtr;
     Var *arrayPtr;
-    char *msg;
 
     /*
      * The choice of "create" flag values is delicate here, and
@@ -4782,27 +4787,27 @@ TclVarTraceExists(interp, varName)
      */
 
     varPtr = TclLookupVar(interp, varName, (char *) NULL,
-            0, "access",
-            /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
+            0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
+
     if (varPtr == NULL) {
 	return NULL;
     }
-    if ((varPtr != NULL) &&
-	    ((varPtr->tracePtr != NULL)
-	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
-	msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName,
+
+    if ((varPtr->tracePtr != NULL)
+	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
+	CallTraces((Interp *)interp, arrayPtr, varPtr, varName,
 		(char *) NULL, TCL_TRACE_READS);
-	if (msg != NULL) {
-	    /*
-	     * If the variable doesn't exist anymore and no-one's using
-	     * it, then free up the relevant structures and hash table entries.
-	     */
+    }
 
-	    if (TclIsVarUndefined(varPtr)) {
-		CleanupVar(varPtr, arrayPtr);
-	    }
-	    return NULL;
-	}
+    /*
+     * If the variable doesn't exist anymore and no-one's using
+     * it, then free up the relevant structures and hash table entries.
+     */
+
+    if (TclIsVarUndefined(varPtr)) {
+	CleanupVar(varPtr, arrayPtr);
+	return NULL;
     }
+
     return varPtr;
 }