More generation of error codes ([format], [after], [trace], RE optimizer).

6 files changed, 125 insertions, 82 deletions

diff --git a/ChangeLog b/ChangeLog
index 63e4391..4724598 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c,
+	* generic/tclTrace.c, generic/tclUtil.c: More generation of error
+	codes ([format], [after], [trace], RE optimizer).
+
 2011-04-04  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclCmdAH.c:  Better error-message in case of errors
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b34209b..f00864f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2498,7 +2498,8 @@ TclRenameCommand(
     if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
 	Tcl_AppendResult(interp, "can't rename to \"", newName,
 		 "\": command already exists", NULL);
-        Tcl_SetErrorCode(interp, "TCL", "RENAME", "TARGET_EXISTS", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
+                "TARGET_EXISTS", NULL);
 	result = TCL_ERROR;
 	goto done;
     }
@@ -3883,82 +3884,79 @@ Tcl_Canceled(
     register Interp *iPtr = (Interp *) interp;
 
     /*
-	 * Has the current script in progress for this interpreter been
-	 * canceled or is the stack being unwound due to the previous script
-	 * cancellation?
-	 */
+     * Has the current script in progress for this interpreter been canceled
+     * or is the stack being unwound due to the previous script cancellation?
+     */
 
-    if (TclCanceled(iPtr)) {
-	    /*
-	     * The CANCELED flag is a one-shot flag that is reset immediately
-	     * upon being detected; however, if the TCL_CANCEL_UNWIND flag is
-	     * set we will continue to report that the script in progress has
-	     * been canceled thereby allowing the evaluation stack for the
-	     * interp to be fully unwound.
-	     */
+    if (!TclCanceled(iPtr)) {
+        return TCL_OK;
+    }
 
-	    iPtr->flags &= ~CANCELED;
+    /*
+     * The CANCELED flag is a one-shot flag that is reset immediately upon
+     * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will
+     * continue to report that the script in progress has been canceled
+     * thereby allowing the evaluation stack for the interp to be fully
+     * unwound.
+     */
 
-	    /*
-	     * The CANCELED flag was detected and reset; however, if the
-	     * caller specified the TCL_CANCEL_UNWIND flag, we only return
-	     * TCL_ERROR (indicating that the script in progress has been
-	     * canceled) if the evaluation stack for the interp is being fully
-	     * unwound.
-	     */
+    iPtr->flags &= ~CANCELED;
 
-	    if (!(flags & TCL_CANCEL_UNWIND)
-		    || (iPtr->flags & TCL_CANCEL_UNWIND)) {
-		/*
-		 * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error
-		 * in the interp's result; otherwise, we leave it alone.
-		 */
+    /*
+     * The CANCELED flag was detected and reset; however, if the caller
+     * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
+     * (indicating that the script in progress has been canceled) if the
+     * evaluation stack for the interp is being fully unwound.
+     */
 
-		if (flags & TCL_LEAVE_ERR_MSG) {
-		    const char *id, *message = NULL;
-		    int length;
+    if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) {
+        return TCL_OK;
+    }
 
-		    /*
-		     * Setup errorCode variables so that we can differentiate
-		     * between being canceled and unwound.
-		     */
+    /*
+     * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
+     * interp's result; otherwise, we leave it alone.
+     */
 
-		    if (iPtr->asyncCancelMsg != NULL) {
-			message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg,
-				&length);
-		    } else {
-			length = 0;
-		    }
+    if (flags & TCL_LEAVE_ERR_MSG) {
+        const char *id, *message = NULL;
+        int length;
 
-		    if (iPtr->flags & TCL_CANCEL_UNWIND) {
-			id = "IUNWIND";
-			if (length == 0) {
-			    message = "eval unwound";
-			}
-		    } else {
-			id = "ICANCEL";
-			if (length == 0) {
-			    message = "eval canceled";
-			}
-		    }
+        /*
+         * Setup errorCode variables so that we can differentiate between
+         * being canceled and unwound.
+         */
 
-		    Tcl_ResetResult(interp);
-		    Tcl_AppendResult(interp, message, NULL);
-		    Tcl_SetErrorCode(interp, "TCL", id, message, NULL);
-		}
+        if (iPtr->asyncCancelMsg != NULL) {
+            message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+        } else {
+            length = 0;
+        }
 
-		/*
-		 * Return TCL_ERROR to the caller (not necessarily just the
-		 * Tcl core itself) that indicates further processing of the
-		 * script or command in progress should halt gracefully and as
-		 * soon as possible.
-		 */
+        if (iPtr->flags & TCL_CANCEL_UNWIND) {
+            id = "IUNWIND";
+            if (length == 0) {
+                message = "eval unwound";
+            }
+        } else {
+            id = "ICANCEL";
+            if (length == 0) {
+                message = "eval canceled";
+            }
+        }
 
-		return TCL_ERROR;
-	    }
+        Tcl_ResetResult(interp);
+        Tcl_AppendResult(interp, message, NULL);
+        Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
     }
 
-    return TCL_OK;
+    /*
+     * Return TCL_ERROR to the caller (not necessarily just the Tcl core
+     * itself) that indicates further processing of the script or command in
+     * progress should halt gracefully and as soon as possible.
+     */
+
+    return TCL_ERROR;
 }
 
 /*
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index cf635bc..fe6d0af 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1609,7 +1609,6 @@ AppendUtfToUtfRep(
     objPtr->bytes[newLength] = 0;
     objPtr->length = newLength;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -1706,7 +1705,7 @@ Tcl_AppendFormatToObj(
     int objc,
     Tcl_Obj *const objv[])
 {
-    const char *span = format, *msg;
+    const char *span = format, *msg, *errCode;
     int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
     int originalLength, limit;
     static const char *mixedXPG =
@@ -1744,6 +1743,7 @@ Tcl_AppendFormatToObj(
 	if (numBytes) {
 	    if (numBytes > limit) {
 		msg = overflow;
+		errCode = "OVERFLOW";
 		goto errorMsg;
 	    }
 	    Tcl_AppendToObj(appendObj, span, numBytes);
@@ -1783,18 +1783,21 @@ Tcl_AppendFormatToObj(
 	if (newXpg) {
 	    if (gotSequential) {
 		msg = mixedXPG;
+		errCode = "MIXEDSPECTYPES";
 		goto errorMsg;
 	    }
 	    gotXpg = 1;
 	} else {
 	    if (gotXpg) {
 		msg = mixedXPG;
+		errCode = "MIXEDSPECTYPES";
 		goto errorMsg;
 	    }
 	    gotSequential = 1;
 	}
 	if ((objIndex < 0) || (objIndex >= objc)) {
 	    msg = badIndex[gotXpg];
+	    errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
 	    goto errorMsg;
 	}
 
@@ -1842,6 +1845,7 @@ Tcl_AppendFormatToObj(
 	} else if (ch == '*') {
 	    if (objIndex >= objc - 1) {
 		msg = badIndex[gotXpg];
+		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
 		goto errorMsg;
 	    }
 	    if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
@@ -1857,6 +1861,7 @@ Tcl_AppendFormatToObj(
 	}
 	if (width > limit) {
 	    msg = overflow;
+	    errCode = "OVERFLOW";
 	    goto errorMsg;
 	}
 
@@ -1877,6 +1882,7 @@ Tcl_AppendFormatToObj(
 	} else if (ch == '*') {
 	    if (objIndex >= objc - 1) {
 		msg = badIndex[gotXpg];
+		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
 		goto errorMsg;
 	    }
 	    if (TclGetIntFromObj(interp, objv[objIndex], &precision)
@@ -1934,6 +1940,7 @@ Tcl_AppendFormatToObj(
 	switch (ch) {
 	case '\0':
 	    msg = "format string ended in middle of field specifier";
+	    errCode = "INCOMPLETE";
 	    goto errorMsg;
 	case 's':
 	    if (gotPrecision) {
@@ -1963,6 +1970,7 @@ Tcl_AppendFormatToObj(
 	case 'u':
 	    if (useBig) {
 		msg = "unsigned bignum format is invalid";
+		errCode = "BADUNSIGNED";
 		goto errorMsg;
 	    }
 	case 'd':
@@ -2110,6 +2118,7 @@ Tcl_AppendFormatToObj(
 		}
 		if (toAppend > segmentLimit) {
 		    msg = overflow;
+		    errCode = "OVERFLOW";
 		    goto errorMsg;
 		}
 		Tcl_AppendToObj(segment, bytes, toAppend);
@@ -2165,6 +2174,7 @@ Tcl_AppendFormatToObj(
 		    }
 		    if (numDigits > INT_MAX) {
 			msg = overflow;
+			errCode = "OVERFLOW";
 			goto errorMsg;
 		    }
 		} else if (!useBig) {
@@ -2232,6 +2242,7 @@ Tcl_AppendFormatToObj(
 		}
 		if (toAppend > segmentLimit) {
 		    msg = overflow;
+		    errCode = "OVERFLOW";
 		    goto errorMsg;
 		}
 		Tcl_AppendObjToObj(segment, pure);
@@ -2285,6 +2296,7 @@ Tcl_AppendFormatToObj(
 		p += sprintf(p, "%d", precision);
 		if (precision > INT_MAX - length) {
 		    msg = overflow;
+		    errCode = "OVERFLOW";
 		    goto errorMsg;
 		}
 		length += precision;
@@ -2301,11 +2313,13 @@ Tcl_AppendFormatToObj(
 	    allocSegment = 1;
 	    if (!Tcl_AttemptSetObjLength(segment, length)) {
 		msg = overflow;
+		errCode = "OVERFLOW";
 		goto errorMsg;
 	    }
 	    bytes = TclGetString(segment);
 	    if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
 		msg = overflow;
+		errCode = "OVERFLOW";
 		goto errorMsg;
 	    }
 	    break;
@@ -2314,6 +2328,7 @@ Tcl_AppendFormatToObj(
 	    if (interp != NULL) {
 		Tcl_SetObjResult(interp,
 			Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
 	    }
 	    goto error;
 	}
@@ -2345,6 +2360,7 @@ Tcl_AppendFormatToObj(
 		Tcl_DecrRefCount(segment);
 	    }
 	    msg = overflow;
+	    errCode = "OVERFLOW";
 	    goto errorMsg;
 	}
 	Tcl_AppendObjToObj(appendObj, segment);
@@ -2367,6 +2383,7 @@ Tcl_AppendFormatToObj(
     if (numBytes) {
 	if (numBytes > limit) {
 	    msg = overflow;
+	    errCode = "OVERFLOW";
 	    goto errorMsg;
 	}
 	Tcl_AppendToObj(appendObj, span, numBytes);
@@ -2379,6 +2396,7 @@ Tcl_AppendFormatToObj(
   errorMsg:
     if (interp != NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+	Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
     }
   error:
     Tcl_SetObjLength(appendObj, originalLength);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index b6c9208..6682d21 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -831,9 +831,12 @@ Tcl_AfterObjCmd(
 		    &index) != TCL_OK)) {
 	index = -1;
 	if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
-	    Tcl_AppendResult(interp, "bad argument \"",
-		    Tcl_GetString(objv[1]),
+            const char *arg = Tcl_GetString(objv[1]);
+
+	    Tcl_AppendResult(interp, "bad argument \"", arg,
 		    "\": must be cancel, idle, info, or an integer", NULL);
+            Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
+                    arg, NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -947,9 +950,7 @@ Tcl_AfterObjCmd(
 	Tcl_DoWhenIdle(AfterProc, afterPtr);
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
 	break;
-    case AFTER_INFO: {
-	Tcl_Obj *resultListPtr;
-
+    case AFTER_INFO:
 	if (objc == 2) {
 	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
 		    afterPtr = afterPtr->nextPtr) {
@@ -966,17 +967,22 @@ Tcl_AfterObjCmd(
 	}
 	afterPtr = GetAfterEvent(assocPtr, objv[2]);
 	if (afterPtr == NULL) {
-	    Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]),
-		    "\" doesn't exist", NULL);
+            const char *eventStr = TclGetString(objv[2]);
+
+	    Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist",
+                    NULL);
+            Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
 	    return TCL_ERROR;
-	}
-	resultListPtr = Tcl_NewObj();
-	Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
-	Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
-		(afterPtr->token == NULL) ? "idle" : "timer", -1));
-	Tcl_SetObjResult(interp, resultListPtr);
+	} else {
+            Tcl_Obj *resultListPtr = Tcl_NewObj();
+
+            Tcl_ListObjAppendElement(interp, resultListPtr,
+                    afterPtr->commandPtr);
+            Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+		    (afterPtr->token == NULL) ? "idle" : "timer", -1));
+            Tcl_SetObjResult(interp, resultListPtr);
+        }
 	break;
-    }
     default:
 	Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
     }
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index d5fb6f6..a60a80b 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -368,6 +368,7 @@ Tcl_TraceObjCmd(
   badVarOps:
     Tcl_AppendResult(interp, "bad operations \"", flagOps,
 	    "\": should be one or more of rwua", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
     return TCL_ERROR;
 }
 
@@ -436,6 +437,8 @@ TraceExecutionObjCmd(
 	    Tcl_SetResult(interp, "bad operation list \"\": must be "
 		    "one or more of enter, leave, enterstep, or leavestep",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	for (i = 0; i < listLen; i++) {
@@ -676,6 +679,8 @@ TraceCommandObjCmd(
 	if (listLen == 0) {
 	    Tcl_SetResult(interp, "bad operation list \"\": must be "
 		    "one or more of delete or rename", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 
@@ -872,6 +877,8 @@ TraceVariableObjCmd(
 	if (listLen == 0) {
 	    Tcl_SetResult(interp, "bad operation list \"\": must be "
 		    "one or more of array, read, unset, or write", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	for (i = 0; i < listLen ; i++) {
@@ -2021,6 +2028,7 @@ TraceVarProc(
 	    }
 	    if (code != TCL_OK) {		/* copy error msg to result */
 		Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+
 		Tcl_IncrRefCount(errMsgObj);
 		result = (char *) errMsgObj;
 	    }
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 5e1efde..64aa824 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -470,6 +470,8 @@ Tcl_SplitList(
 	    if (interp != NULL) {
 		Tcl_SetResult(interp, "internal error in Tcl_SplitList",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
+			NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -3270,7 +3272,7 @@ TclReToGlob(
 {
     int anchorLeft, anchorRight, lastIsStar, numStars;
     char *dsStr, *dsStrStart;
-    const char *msg, *p, *strEnd;
+    const char *msg, *p, *strEnd, *code;
 
     strEnd = reStr + reStrLen;
     Tcl_DStringInit(dsPtr);
@@ -3324,6 +3326,7 @@ TclReToGlob(
      */
 
     msg = NULL;
+    code = NULL;
     p = reStr;
     anchorRight = 0;
     lastIsStar = 0;
@@ -3380,6 +3383,7 @@ TclReToGlob(
 		break;
 	    default:
 		msg = "invalid escape sequence";
+		code = "BADESCAPE";
 		goto invalidGlob;
 	    }
 	    break;
@@ -3408,6 +3412,7 @@ TclReToGlob(
 	case '$':
 	    if (p+1 != strEnd) {
 		msg = "$ not anchor";
+		code = "NONANCHOR";
 		goto invalidGlob;
 	    }
 	    anchorRight = 1;
@@ -3415,8 +3420,8 @@ TclReToGlob(
 	case '*': case '+': case '?': case '|': case '^':
 	case '{': case '}': case '(': case ')': case '[': case ']':
 	    msg = "unhandled RE special char";
+	    code = "UNHANDLED";
 	    goto invalidGlob;
-	    break;
 	default:
 	    *dsStr++ = *p;
 	    break;
@@ -3430,6 +3435,7 @@ TclReToGlob(
 	 */
 
 	msg = "excessive recursive glob backtrack potential";
+	code = "OVERCOMPLEX";
 	goto invalidGlob;
     }
 
@@ -3458,6 +3464,7 @@ TclReToGlob(
 #endif
     if (interp != NULL) {
 	Tcl_AppendResult(interp, msg, NULL);
+	Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
     }
     Tcl_DStringFree(dsPtr);
     return TCL_ERROR;