merge trunk to feature branchtip_388_impl

13 files changed, 162 insertions, 80 deletions

diff --git a/generic/tcl.h b/generic/tcl.h
index 7370516..7a94956 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2373,8 +2373,10 @@ const char *		TclTomMathInitializeStubs(Tcl_Interp *interp,
  * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
  */
 
-EXTERN void		Tcl_Main(int argc, char **argv,
-			    Tcl_AppInitProc *appInitProc);
+#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
+	    (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+EXTERN void		Tcl_MainEx(int argc, char **argv,
+			    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
 EXTERN const char *	Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
 			    const char *version, int exact);
 #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f0f0c0f..9758449 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -215,7 +215,7 @@ static const CmdInfo builtInCmds[] = {
     {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	1},
     {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	1},
     {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	1},
-    {"eval",		Tcl_EvalObjCmd,		NULL,			NULL,	1},
+    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	1},
     {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	1},
     {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
     {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	1},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 765c9dc..fc9d39d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -737,6 +737,16 @@ Tcl_EvalObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
+    return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv);    
+}
+
+int
+TclNREvalObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
     register Tcl_Obj *objPtr;
     Interp *iPtr = (Interp *) interp;
     CmdFrame *invoker = NULL;
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index d1d7403..d96670c 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -659,11 +659,6 @@ ParseExpr(
 	Tcl_Obj *literal;	/* Filled by the ParseLexeme() call when a
 				 * literal is parsed that has a Tcl_Obj rep
 				 * worth preserving. */
-	const char *lastStart = start - scanned;
-				/* Compute where the lexeme parsed the
-				 * previous pass through the loop began. This
-				 * is helpful for detecting invalid octals and
-				 * providing more complete error messages. */
 
 	/*
 	 * Each pass through this loop adds up to one more OpNode. Allocate
@@ -754,33 +749,39 @@ ParseExpr(
 		    Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
 			    (scanned < limit) ? scanned : limit - 3,
 			    start, (scanned < limit) ? "" : "...");
-		    if (NotOperator(lastParsed)) {
-			errCode = "BADNUMBER";
-			if ((lastStart[0] == '0')
-				&& ((lastStart[1] == 'o')
-				|| (lastStart[1] == 'O'))
-				&& (lastStart[2] >= '0')
-				&& (lastStart[2] <= '9')) {
-			    const char *end = lastStart + 2;
-			    Tcl_Obj *copy;
-
-			    while (isdigit(UCHAR(*end))) {
-				end++;
-			    }
-			    copy = Tcl_NewStringObj(lastStart, end-lastStart);
-			    if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
+		    errCode = "BAREWORD";
+		    if (start[0] == '0') {
+			const char *stop;
+			TclParseNumber(NULL, NULL, NULL, start, scanned,
+				&stop, TCL_PARSE_NO_WHITESPACE);
+
+			if (isdigit(UCHAR(*stop)) || (stop == start + 1)) {
+			    switch (start[1]) {
+			    case 'b':
+				Tcl_AppendToObj(post,
+					" (invalid binary number?)", -1);
+				parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+				errCode = "BADNUMBER";
+				subErrCode = "BINARY";
+				break;
+			    case 'o':
 				Tcl_AppendToObj(post,
 					" (invalid octal number?)", -1);
+				parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
 				errCode = "BADNUMBER";
 				subErrCode = "OCTAL";
+				break;
+			    default:
+				if (isdigit(UCHAR(start[1]))) {
+				    Tcl_AppendToObj(post,
+					    " (invalid octal number?)", -1);
+				    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+				    errCode = "BADNUMBER";
+				    subErrCode = "OCTAL";
+				}
+				break;
 			    }
-			    Tcl_DecrRefCount(copy);
 			}
-			scanned = 0;
-			insertMark = 1;
-			parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
-		    } else {
-			errCode = "BAREWORD";
 		    }
 		    goto error;
 		}
@@ -824,20 +825,8 @@ ParseExpr(
 	    if (NotOperator(lastParsed)) {
 		msg = Tcl_ObjPrintf("missing operator at %s", mark);
 		errCode = "MISSING";
-		if (lastStart[0] == '0') {
-		    Tcl_Obj *copy = Tcl_NewStringObj(lastStart,
-			    start + scanned - lastStart);
-
-		    if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
-			TclNewLiteralStringObj(post,
-				"looks like invalid octal number");
-			errCode = "BADNUMBER_OCTAL";
-		    }
-		    Tcl_DecrRefCount(copy);
-		}
 		scanned = 0;
 		insertMark = 1;
-		parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
 
 		/* Free any literal to avoid a memleak. */
 		if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) {
@@ -1996,14 +1985,53 @@ ParseLexeme(
     literal = Tcl_NewObj();
     if (TclParseNumber(NULL, literal, NULL, start, numBytes, &end,
 	    TCL_PARSE_NO_WHITESPACE) == TCL_OK) {
-	TclInitStringRep(literal, start, end-start);
-	*lexemePtr = NUMBER;
-	if (literalPtr) {
-	    *literalPtr = literal;
+	if (end < start + numBytes && !isalnum(UCHAR(*end))
+		&& UCHAR(*end) != '_') {
+	
+	number:
+	    TclInitStringRep(literal, start, end-start);
+	    *lexemePtr = NUMBER;
+	    if (literalPtr) {
+		*literalPtr = literal;
+	    } else {
+		Tcl_DecrRefCount(literal);
+	    }
+	    return (end-start);
 	} else {
-	    Tcl_DecrRefCount(literal);
+	    unsigned char lexeme;
+
+	    /*
+	     * We have a number followed directly by bareword characters
+	     * (alpha, digit, underscore).  Is this a number followed by
+	     * bareword syntax error?  Or should we join into one bareword?
+	     * Example: Inf + luence + () becomes a valid function call.
+	     * [Bug 3401704]
+	     */
+	    if (literal->typePtr == &tclDoubleType) {
+		const char *p = start;
+		while (p < end) {
+		    if (!isalnum(UCHAR(*p++))) {
+			/*
+			 * The number has non-bareword characters, so we 
+			 * must treat it as a number.
+			 */
+			goto number;
+		    }
+		}
+	    }
+	    ParseLexeme(end, numBytes-(end-start), &lexeme, NULL);
+	    if ((NODE_TYPE & lexeme) == BINARY) {
+		/*
+		 * The bareword characters following the number take the
+		 * form of an operator (eq, ne, in, ni, ...) so we treat
+		 * as number + operator.
+		 */
+		goto number;
+	    }
+	    /*
+	     * Otherwise, fall through and parse the whole as a bareword.
+	     */
 	}
-	return (end-start);
     }
 
     if (Tcl_UtfCharComplete(start, numBytes)) {
@@ -2015,7 +2043,7 @@ ParseLexeme(
 	utfBytes[numBytes] = '\0';
 	scanned = Tcl_UtfToUniChar(utfBytes, &ch);
     }
-    if (!isalpha(UCHAR(ch))) {
+    if (!isalnum(UCHAR(ch))) {
 	*lexemePtr = INVALID;
 	Tcl_DecrRefCount(literal);
 	return scanned;
@@ -2443,8 +2471,30 @@ CompileExprTree(
 
 		if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
 			== TCL_OK) {
-		    TclEmitPush(TclAddLiteralObj(envPtr,
-			    Tcl_GetObjResult(interp), NULL), envPtr);
+		    int index;
+		    Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
+
+		    /*
+		     * Don't generate a string rep, but if we have one
+		     * already, then use it to share via the literal table.
+		     */
+		    if (objPtr->bytes) {
+			Tcl_Obj *tableValue;
+
+			index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
+				objPtr->length);
+			tableValue = envPtr->literalArrayPtr[index].objPtr;
+			if ((tableValue->typePtr == NULL) &&
+				(objPtr->typePtr != NULL)) {
+			    /* Same intrep surgery as for OT_LITERAL */
+			    tableValue->typePtr = objPtr->typePtr;
+			    tableValue->internalRep = objPtr->internalRep;
+			    objPtr->typePtr = NULL;
+			}
+		    } else {
+			index = TclAddLiteralObj(envPtr, objPtr, NULL);
+		    }
+		    TclEmitPush(index, envPtr);
 		} else {
 		    TclCompileSyntaxError(interp, envPtr);
 		}
diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d
index 0ee592f..360bdff 100644
--- a/generic/tclDTrace.d
+++ b/generic/tclDTrace.d
@@ -25,7 +25,7 @@ provider tcl {
      *		arg1: number of arguments		(int)
      *		arg2: array of proc argument objects	(Tcl_Obj**)
      */
-    probe proc__entry(TclDTraceStr name, int objc, Tcl_Obj **objv);
+    probe proc__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv);
     /*
      *	tcl*:::proc-return probe
      *	    triggered immediately after proc bytecode execution
@@ -42,7 +42,7 @@ provider tcl {
      *		arg3: proc result object		(Tcl_Obj*)
      */
     probe proc__result(TclDTraceStr name, int code, TclDTraceStr result,
-	    Tcl_Obj *resultobj);
+	    struct Tcl_Obj *resultobj);
     /*
      *	tcl*:::proc-args probe
      *	    triggered before proc-entry probe, gives access to string
@@ -79,7 +79,7 @@ provider tcl {
      *		arg1: number of arguments		(int)
      *		arg2: array of command argument objects	(Tcl_Obj**)
      */
-    probe cmd__entry(TclDTraceStr name, int objc, Tcl_Obj **objv);
+    probe cmd__entry(TclDTraceStr name, int objc, struct Tcl_Obj **objv);
     /*
      *	tcl*:::cmd-return probe
      *	    triggered immediately after commmand execution
@@ -96,7 +96,7 @@ provider tcl {
      *		arg3: command result object		(Tcl_Obj*)
      */
     probe cmd__result(TclDTraceStr name, int code, TclDTraceStr result,
-	    Tcl_Obj *resultobj);
+	    struct Tcl_Obj *resultobj);
     /*
      *	tcl*:::cmd-args probe
      *	    triggered before cmd-entry probe, gives access to string
@@ -133,7 +133,7 @@ provider tcl {
      *		arg1: depth of stack			(int)
      *		arg2: top of stack			(Tcl_Obj**)
      */
-    probe inst__start(TclDTraceStr name, int depth, Tcl_Obj **stack);
+    probe inst__start(TclDTraceStr name, int depth, struct Tcl_Obj **stack);
     /*
      *	tcl*:::inst-done probe
      *	    triggered immediately after execution of a bytecode
@@ -141,7 +141,7 @@ provider tcl {
      *		arg1: depth of stack			(int)
      *		arg2: top of stack			(Tcl_Obj**)
      */
-    probe inst__done(TclDTraceStr name, int depth, Tcl_Obj **stack);
+    probe inst__done(TclDTraceStr name, int depth, struct Tcl_Obj **stack);
 
     /***************************** obj probes ******************************/
     /*
@@ -149,13 +149,13 @@ provider tcl {
      *	    triggered immediately after a new Tcl_Obj has been created
      *		arg0: object created			(Tcl_Obj*)
      */
-    probe obj__create(Tcl_Obj* obj);
+    probe obj__create(struct Tcl_Obj* obj);
     /*
      *	tcl*:::obj-free probe
      *	    triggered immediately before a Tcl_Obj is freed
      *		arg0: object to be freed		(Tcl_Obj*)
      */
-    probe obj__free(Tcl_Obj* obj);
+    probe obj__free(struct Tcl_Obj* obj);
 
     /***************************** tcl probes ******************************/
     /*
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 1df7e14..1f7dfe6 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3791,8 +3791,6 @@ extern const TclStubs *tclStubsPtr;
 #   define Tcl_MainEx Tcl_MainExW
     EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
 	    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
-#   define Tcl_Main(argc, argv, proc) Tcl_MainExW(argc, argv, proc, \
-	    (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
 #endif
 
 #undef TCL_STORAGE_CLASS
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 4806690..fa973c7 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -2191,6 +2191,7 @@ DeleteReflectedTransformMap(
 
 	Tcl_ConditionNotify(&resultPtr->done);
     }
+    Tcl_MutexUnlock(&rtForwardMutex);
 
     /*
      * Get the map of all channels handled by the current thread. This is a
@@ -2215,8 +2216,6 @@ DeleteReflectedTransformMap(
 
 	Tcl_DeleteHashEntry(hPtr);
     }
-
-    Tcl_MutexUnlock(&rtForwardMutex);
 #endif
 }
 
@@ -2323,6 +2322,7 @@ DeleteThreadReflectedTransformMap(
 
 	Tcl_ConditionNotify(&resultPtr->done);
     }
+    Tcl_MutexUnlock(&rtForwardMutex);
 
     /*
      * Get the map of all channels handled by the current thread. This is a
@@ -2339,8 +2339,7 @@ DeleteThreadReflectedTransformMap(
 	rtPtr->interp = NULL;
 	Tcl_DeleteHashEntry(hPtr);
     }
-
-    Tcl_MutexUnlock(&rtForwardMutex);
+    ckfree(rtmPtr);
 }
 
 static void
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d65f712..f30e83e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2768,7 +2768,7 @@ MODULE_SCOPE char	tclEmptyString;
  */
 
 MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
-MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
@@ -2778,6 +2778,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index a156a57..5b6d14f 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -4345,6 +4345,19 @@ SlaveCommandLimitCmd(
     ScriptLimitCallback *limitCBPtr;
     Tcl_HashEntry *hPtr;
 
+    /*
+     * First, ensure that we are not reading or writing the calling
+     * interpreter's limits; it may only manipulate its children. Note that
+     * the low level API enforces this with Tcl_Panic, which we want to
+     * avoid. [Bug 3398794]
+     */
+
+    if (interp == slaveInterp) {
+	Tcl_AppendResult(interp,
+		"limits on current interpreter inaccessible", NULL);
+	return TCL_ERROR;
+    }
+
     if (objc == consumedObjc) {
 	Tcl_Obj *dictPtr;
 
@@ -4519,6 +4532,19 @@ SlaveTimeLimitCmd(
     ScriptLimitCallback *limitCBPtr;
     Tcl_HashEntry *hPtr;
 
+    /*
+     * First, ensure that we are not reading or writing the calling
+     * interpreter's limits; it may only manipulate its children. Note that
+     * the low level API enforces this with Tcl_Panic, which we want to
+     * avoid. [Bug 3398794]
+     */
+
+    if (interp == slaveInterp) {
+	Tcl_AppendResult(interp,
+		"limits on current interpreter inaccessible", NULL);
+	return TCL_ERROR;
+    }
+
     if (objc == consumedObjc) {
 	Tcl_Obj *dictPtr;
 
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 114d2c3..373e3f6 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -620,18 +620,19 @@ Tcl_MainEx(
     Tcl_Exit(exitCode);
 }
 
-#ifndef UNICODE
-void
+#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE)
+#undef Tcl_Main
+extern DLLEXPORT void
 Tcl_Main(
     int argc,			/* Number of arguments. */
-    TCHAR **argv,		/* Array of argument strings. */
+    char **argv,		/* Array of argument strings. */
     Tcl_AppInitProc *appInitProc)
 				/* Application-specific initialization
 				 * function to call after most initialization
 				 * but before starting to execute commands. */
 {
     Tcl_FindExecutable(argv[0]);
-	Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
+    Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
 }
 #endif
 
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4e7edb8..708295a 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1595,7 +1595,7 @@ InitEnsembleRewrite(
     if (isRootEnsemble) {
 	iPtr->ensembleRewrite.sourceObjs = objv;
 	iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
-	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength - 1;
     } else {
 	int numIns = iPtr->ensembleRewrite.numInsertedObjs;
 
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index a55ee83..332cfca 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -249,15 +249,6 @@ static const int itens [] = {
     100000000
 };
 
-static const Tcl_WideUInt wtens[] = {
-    1, 10, 100, 1000, 10000, 100000, 1000000,
-    (Tcl_WideUInt) 1000000*10, 		(Tcl_WideUInt) 1000000*100,
-    (Tcl_WideUInt) 1000000*1000, 	(Tcl_WideUInt) 1000000*10000,
-    (Tcl_WideUInt) 1000000*100000, 	(Tcl_WideUInt) 1000000*1000000,
-    (Tcl_WideUInt) 1000000*1000000*10, 	(Tcl_WideUInt) 1000000*1000000*100,
-    (Tcl_WideUInt) 1000000*1000000*1000,(Tcl_WideUInt) 1000000*1000000*10000
-};
-
 static const double bigtens[] = {
     1e016, 1e032, 1e064, 1e128, 1e256
 };
@@ -1101,7 +1092,10 @@ TclParseNumber(
 		    d = 10 + c - 'a';
 		} else if (c >= 'A' && c <= 'F') {
 		    d = 10 + c - 'A';
+		} else {
+		    goto endgame;
 		}
+		numSigDigs++;
 		significandWide = (significandWide << 4) + d;
 		state = sNANHEX;
 		break;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 51508d2..31c9fd3 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -3156,7 +3156,8 @@ TclFormatInt(buffer, n)
      * negating it produces the same value.
      */
 
-    if (n == -n) {
+    intVal = -n;			/* [Bug 3390638] Workaround for*/
+    if (n == -n || intVal == n) {	/* broken compiler optimizers. */
 	return sprintf(buffer, "%ld", n);
     }