From 54e58f9d2df63783abd9492926ed2cd4e4c6393a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Mar 2011 07:54:04 +0000 Subject: gcc warning: unused variable "key" --- generic/tclHash.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index 53d9919..b5baf22 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -1191,8 +1191,6 @@ RebuildTable(tablePtr) for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; - key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); - #if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { @@ -1203,6 +1201,7 @@ RebuildTable(tablePtr) hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; #else + key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr); if (typePtr->hashKeyProc) { unsigned int hash; hash = typePtr->hashKeyProc (tablePtr, (VOID *) key); -- cgit v0.12 From ce1706f3395619dee86a51d89a76c9537e4d8fe3 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 29 Mar 2011 15:06:26 +0000 Subject: More generation of errorCode information, notably when lists are mis-parsed. --- ChangeLog | 4 +++ generic/tclCmdMZ.c | 42 ++++++++++++++++++++++ generic/tclConfig.c | 7 +++- generic/tclUtil.c | 101 ++++++++++++++++++++++++++++------------------------ 4 files changed, 107 insertions(+), 47 deletions(-) diff --git a/ChangeLog b/ChangeLog index 703dc72..8e81f98 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,9 @@ 2011-03-28 Donal K. Fellows + * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More + generation of errorCode information, notably when lists are + mis-parsed. + * generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the error messages generated by the variable management code rather than creating our own. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e39ae06..61de8de 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1794,6 +1794,8 @@ StringMapCmd( } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -1856,6 +1858,8 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", + "UNBALANCED", NULL); return TCL_ERROR; } } @@ -2057,6 +2061,8 @@ StringMatchCmd( } else { Tcl_AppendResult(interp, "bad option \"", string, "\": must be -nocase", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -2189,6 +2195,7 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } length2 = length1 * count; @@ -2209,6 +2216,7 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow, out of memory allocating %u bytes", length2 + 1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } for (index = 0; index < count; index++) { @@ -2514,6 +2522,8 @@ StringEqualCmd( } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -2661,6 +2671,8 @@ StringCmpCmd( } else { Tcl_AppendResult(interp, "bad option \"", string2, "\": must be -nocase or -length", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -3558,6 +3570,8 @@ TclNRSwitchObjCmd( Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]), "\": ", options[mode], " option already found", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "DOUBLEOPT", NULL); return TCL_ERROR; } foundmode = 1; @@ -3574,6 +3588,8 @@ TclNRSwitchObjCmd( if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-indexvar", " option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3584,6 +3600,8 @@ TclNRSwitchObjCmd( if (i >= objc-2) { Tcl_AppendResult(interp, "missing variable name argument to ", "-matchvar", " option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3601,11 +3619,15 @@ TclNRSwitchObjCmd( if (indexVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-indexvar option requires -regexp option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { Tcl_AppendResult(interp, "-matchvar option requires -regexp option", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } @@ -3653,6 +3675,8 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3669,6 +3693,8 @@ TclNRSwitchObjCmd( "comment incorrectly placed outside of a " "switch body - see the \"switch\" " "documentation", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "BADARM", "COMMENT?", NULL); break; } } @@ -3686,6 +3712,8 @@ TclNRSwitchObjCmd( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "no body specified for pattern \"", TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + "FALLTHROUGH", NULL); return TCL_ERROR; } @@ -4006,6 +4034,8 @@ Tcl_ThrowObjCmd( return TCL_ERROR; } else if (len < 1) { Tcl_AppendResult(interp, "type must be non-empty list", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", + NULL); return TCL_ERROR; } @@ -4189,12 +4219,16 @@ TclNRTryObjCmd( if (i < objc-2) { Tcl_AppendResult(interp, "finally clause must be last", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "NONTERMINAL", NULL); return TCL_ERROR; } else if (i == objc-1) { Tcl_AppendResult(interp, "wrong # args to finally clause: ", "must be \"", TclGetString(objv[0]), " ... finally script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "ARGUMENT", NULL); return TCL_ERROR; } finallyObj = objv[++i]; @@ -4206,6 +4240,8 @@ TclNRTryObjCmd( "must be \"", TclGetString(objv[0]), " ... on code variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", + "ARGUMENT", NULL); return TCL_ERROR; } if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) { @@ -4221,6 +4257,8 @@ TclNRTryObjCmd( "must be \"... trap pattern variableList script\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "ARGUMENT", NULL); return TCL_ERROR; } code = 1; @@ -4229,6 +4267,8 @@ TclNRTryObjCmd( "bad prefix '%s': must be a list", Tcl_GetString(objv[i+1]))); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "EXNFORMAT", NULL); return TCL_ERROR; } info[2] = objv[i+1]; @@ -4260,6 +4300,8 @@ TclNRTryObjCmd( "last non-finally clause must not have a body of \"-\"", NULL); Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", + NULL); return TCL_ERROR; } if (!haveHandlers) { diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 8d42e21..3ad5dfd 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -237,6 +237,8 @@ QueryConfigObjCmd( */ Tcl_SetResult(interp, "package not known", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", + Tcl_GetString(pkgName), NULL); return TCL_ERROR; } @@ -247,9 +249,11 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK + if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK || val == NULL) { Tcl_SetResult(interp, "key not known", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", + Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } @@ -268,6 +272,7 @@ QueryConfigObjCmd( if (!listPtr) { Tcl_SetResult(interp, "insufficient memory to create list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 69bd4d2..5e1efde 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -221,6 +221,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -280,6 +282,8 @@ TclFindElement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", + NULL); } return TCL_ERROR; } @@ -297,12 +301,16 @@ TclFindElement( if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", + NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", + NULL); } return TCL_ERROR; } @@ -451,9 +459,6 @@ Tcl_SplitList( &elSize, &brace); length -= (list - prevList); if (result != TCL_OK) { - if (interp != NULL) { - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL); - } ckfree(argv); return result; } @@ -2119,10 +2124,9 @@ Tcl_PrintDouble( char *p, c; int exponent; int signum; - char* digits; - char* end; - - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int)); + char *digits; + char *end; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* * Handle NaN. @@ -2156,26 +2160,26 @@ Tcl_PrintDouble( if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); + &exponent, &signum, &end); } else { /* * There are at least two possible interpretations for tcl_precision. * * The first is, "choose the decimal representation having - * $tcl_precision digits of significance that is nearest to the - * given number, breaking ties by rounding to even, and then - * trimming trailing zeros." This gives the greatest possible - * precision in the decimal string, but offers the anomaly that - * [expr 0.1] will be "0.10000000000000001". + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". * - * The second is "choose the decimal representation having at - * most $tcl_precision digits of significance that is nearest - * to the given number. If no such representation converts - * exactly to the given number, choose the one that is closest, - * breaking ties by rounding to even. If more than one such - * representation converts exactly to the given number, choose - * the shortest, breaking ties in favour of the nearest, breaking - * remaining ties in favour of the one ending in an even digit." + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: @@ -2188,13 +2192,13 @@ Tcl_PrintDouble( * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, - * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we - * prefer the first (the recommended zero value for tcl_precision - * avoids the problem entirely). + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). * - * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the - * method that allows floating point values to be shortened if - * it can be done without loss of precision. + * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. */ digits = TclDoubleDigits(value, *precisionPtr, @@ -2219,10 +2223,12 @@ Tcl_PrintDouble( c = *++p; } } + /* * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ + if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { @@ -2410,6 +2416,7 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ + return 1; } switch (*end) { @@ -2434,19 +2441,19 @@ TclNeedSpace( * This procedure formats an integer into a sequence of decimal digit * characters in a buffer. If the integer is negative, a minus sign is * inserted at the start of the buffer. A null character is inserted at - * the end of the formatted characters. It is the caller's - * responsibility to ensure that enough storage is available. This - * procedure has the effect of sprintf(buffer, "%ld", n) but is faster - * as proven in benchmarks. This is key to UpdateStringOfInt, which - * is a common path for a lot of code (e.g. int-indexed arrays). + * the end of the formatted characters. It is the caller's responsibility + * to ensure that enough storage is available. This procedure has the + * effect of sprintf(buffer, "%ld", n) but is faster as proven in + * benchmarks. This is key to UpdateStringOfInt, which is a common path + * for a lot of code (e.g. int-indexed arrays). * * Results: * An integer representing the number of characters formatted, not * including the terminating \0. * * Side effects: - * The formatted characters are written into the storage pointer to - * by the "buffer" argument. + * The formatted characters are written into the storage pointer to by + * the "buffer" argument. * *---------------------------------------------------------------------- */ @@ -2733,7 +2740,7 @@ SetEndOffsetFromAny( */ if (isspace(UCHAR(bytes[4]))) { - return TCL_ERROR; + goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; @@ -2746,6 +2753,7 @@ SetEndOffsetFromAny( * Conversion failed. Report the error. */ + badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, @@ -2853,7 +2861,8 @@ ClearHash( for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } @@ -2910,7 +2919,7 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); @@ -2996,8 +3005,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -3273,9 +3281,10 @@ TclReToGlob( if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* - * At most, the glob pattern has length 2*reStrLen + 2 to - * backslash escape every character and have * at each end. + * At most, the glob pattern has length 2*reStrLen + 2 to backslash + * escape every character and have * at each end. */ + Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; @@ -3299,8 +3308,8 @@ TclReToGlob( } /* - * At most, the glob pattern has length reStrLen + 2 to account - * for possible * at each end. + * At most, the glob pattern has length reStrLen + 2 to account for + * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); @@ -3310,9 +3319,8 @@ TclReToGlob( * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * - * Keep track of the last char being an unescaped star to prevent - * multiple instances. Simpler than checking that the last star - * may be escaped. + * Keep track of the last char being an unescaped star to prevent multiple + * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; @@ -3420,6 +3428,7 @@ TclReToGlob( * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ + msg = "excessive recursive glob backtrack potential"; goto invalidGlob; } -- cgit v0.12 From 6266f2e3593c1f443d49334bad71f9a5dde9a4f6 Mon Sep 17 00:00:00 2001 From: andreask Date: Wed, 30 Mar 2011 22:29:19 +0000 Subject: Fixed execute permission for unix/ldAix on this branch. core-8-4-branch and trunk are ok, so a merge is not required. --- tools/configure | 0 unix/ldAix | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) mode change 100755 => 100644 tools/configure mode change 100644 => 100755 unix/ldAix diff --git a/tools/configure b/tools/configure old mode 100755 new mode 100644 diff --git a/unix/ldAix b/unix/ldAix old mode 100644 new mode 100755 index cf37d40..51b2995 --- a/unix/ldAix +++ b/unix/ldAix @@ -1,5 +1,5 @@ #!/bin/sh -# +# # ldAix ldCmd ldArg ldArg ... # # This shell script provides a wrapper for ld under AIX in order to -- cgit v0.12 From 86d9abcd45aaf8619a159ae299d8df3fd30f2acf Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 31 Mar 2011 10:04:07 +0000 Subject: TclClockOldscanObjCmd: More generation of errorCode information. --- ChangeLog | 5 +++++ generic/tclDate.c | 8 ++++++++ generic/tclGetDate.y | 8 ++++++++ generic/tclThreadAlloc.c | 0 4 files changed, 21 insertions(+) mode change 100755 => 100644 generic/tclThreadAlloc.c diff --git a/ChangeLog b/ChangeLog index 8e81f98..e3d93dd 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-03-31 Donal K. Fellows + + * generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd): + More generation of errorCode information. + 2011-03-28 Donal K. Fellows * generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More diff --git a/generic/tclDate.c b/generic/tclDate.c index 8aebbf3..14bac51 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -2800,10 +2800,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -2811,6 +2813,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -2818,26 +2821,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 720b71c..da4c3fd 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -1011,10 +1011,12 @@ TclClockOldscanObjCmd( if (status == 1) { Tcl_SetObjResult(interp, dateInfo.messages); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL); return TCL_ERROR; } else if (status == 2) { Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } else if (status != 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned " @@ -1022,6 +1024,7 @@ TclClockOldscanObjCmd( "report this error as a " "bug in Tcl.", -1)); Tcl_DecrRefCount(dateInfo.messages); + Tcl_SetErrorCode(interp, "TCL", "BUG", NULL); return TCL_ERROR; } Tcl_DecrRefCount(dateInfo.messages); @@ -1029,26 +1032,31 @@ TclClockOldscanObjCmd( if (yyHaveDate > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one date in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveTime > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time of day in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveZone > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one time zone in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveDay > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one weekday in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } if (yyHaveOrdinalMonth > 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj("more than one ordinal month in string", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL); return TCL_ERROR; } diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c old mode 100755 new mode 100644 -- cgit v0.12 From c8eb649431a107df0b9828649d96894768c00591 Mon Sep 17 00:00:00 2001 From: max Date: Fri, 1 Apr 2011 09:29:24 +0000 Subject: Implement TIP#131 --- ChangeLog | 4 ++++ library/init.tcl | 15 +++++++++++++++ 2 files changed, 19 insertions(+) diff --git a/ChangeLog b/ChangeLog index e3d93dd..86ef9e4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2011-04-01 Reinhard Max + + * library/init.tcl: TIP#131 implementation. + 2011-03-31 Donal K. Fellows * generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd): diff --git a/library/init.tcl b/library/init.tcl index 33b6b33..e6e69c3 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -821,3 +821,18 @@ proc tcl::CopyDirectory {action src dest} { } return } + +# TIP 131 +proc tcl::rmmadwiw {} { + set magic { + 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe + ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9 + ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed + } + foreach mystic [lassign $magic tragic] { + set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic] + append logic [format %x $comic] + set tragic $mystic + } + binary format H* $logic +} -- cgit v0.12 From 4502b1fa0696dd647f8a38b72b8f689433bf98cd Mon Sep 17 00:00:00 2001 From: max Date: Fri, 1 Apr 2011 10:48:21 +0000 Subject: mathematical version of TIP#131 --- library/init.tcl | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/library/init.tcl b/library/init.tcl index e6e69c3..d85fe2a 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -836,3 +836,14 @@ proc tcl::rmmadwiw {} { } binary format H* $logic } + +proc tcl::mathfunc::rmmadwiw {} { + set age [expr {9*6}] + set mind "" + while {$age} { + lappend mind [expr {$age%13}] + set age [expr {$age/13}] + } + set matter [lreverse $mind] + return [join $matter ""] +} -- cgit v0.12 From f4b7658650c49deb8518bb22558332a16264cdf6 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 2 Apr 2011 12:17:32 +0000 Subject: More generation of errorCode information (default [bgerror] and [glob]). --- ChangeLog | 5 +++++ generic/tclEvent.c | 2 ++ generic/tclFileName.c | 17 +++++++++++++++++ 3 files changed, 24 insertions(+) diff --git a/ChangeLog b/ChangeLog index 86ef9e4..f0d5bcc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2011-04-02 Donal K. Fellows + + * generic/tclEvent.c, generic/tclFileName.c: More generation of + errorCode information (default [bgerror] and [glob]). + 2011-04-01 Reinhard Max * library/init.tcl: TIP#131 implementation. diff --git a/generic/tclEvent.c b/generic/tclEvent.c index a8bab0b..6816487 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -333,6 +333,7 @@ TclDefaultBgErrorHandlerObjCmd( if (valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-level\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { @@ -345,6 +346,7 @@ TclDefaultBgErrorHandlerObjCmd( if (valuePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing return option \"-code\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { diff --git a/generic/tclFileName.c b/generic/tclFileName.c index d53c271..05ecb04 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1258,11 +1258,14 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-directory\" cannot be used with \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1280,11 +1283,14 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-path\" cannot be used with \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1295,6 +1301,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1314,6 +1321,8 @@ Tcl_GlobObjCmd( Tcl_AppendResult(interp, "\"-tails\" must be used with either " "\"-directory\" or \"-path\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } @@ -1523,6 +1532,7 @@ Tcl_GlobObjCmd( Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); Tcl_AppendObjToObj(resultPtr, look); Tcl_SetObjResult(interp, resultPtr); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1532,6 +1542,7 @@ Tcl_GlobObjCmd( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); join = 0; goto endOfGlob; } @@ -1620,6 +1631,8 @@ Tcl_GlobObjCmd( } } Tcl_AppendResult(interp, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", + NULL); result = TCL_ERROR; } } @@ -2250,11 +2263,15 @@ DoGlob( } Tcl_SetResult(interp, "unmatched open-brace in file name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } else if (*p == '}') { Tcl_SetResult(interp, "unmatched close-brace in file name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } } -- cgit v0.12 From d2275aefb3bc8e96e7ae22e4609ba2c7604f86fe Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 2 Apr 2011 17:22:01 +0000 Subject: More generation of errorCodes ([interp], [lset], [load], [unload]). --- ChangeLog | 3 + generic/tclInterp.c | 161 +++++++++++++++++++++++++-------------------------- generic/tclListObj.c | 6 ++ generic/tclLoad.c | 36 +++++++++++- 4 files changed, 122 insertions(+), 84 deletions(-) diff --git a/ChangeLog b/ChangeLog index f0d5bcc..3179b6e 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 2011-04-02 Donal K. Fellows + * generic/tclInterp.c, generic/tclListObj.c, generic/tclLoad.c: + More generation of errorCodes ([interp], [lset], [load], [unload]). + * generic/tclEvent.c, generic/tclFileName.c: More generation of errorCode information (default [bgerror] and [glob]). diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 67761ed..a156a57 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -300,8 +300,8 @@ Tcl_Init( { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return (TCL_ERROR); - }; + return TCL_ERROR; + } } /* @@ -559,6 +559,7 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + Tcl_Interp *slaveInterp; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", @@ -588,7 +589,7 @@ Tcl_InterpObjCmd( } switch ((enum option) index) { case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; + Tcl_Interp *masterInterp; if (objc < 4) { aliasArgs: @@ -622,18 +623,13 @@ Tcl_InterpObjCmd( } goto aliasArgs; } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; - + case OPT_ALIASES: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return AliasList(interp, slaveInterp); - } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; - + case OPT_BGERROR: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); return TCL_ERROR; @@ -643,10 +639,8 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_CANCEL: { int i, flags; - Tcl_Interp *slaveInterp; Tcl_Obj *resultObjPtr; static const char *const cancelOptions[] = { "-unwind", "--", NULL @@ -680,8 +674,7 @@ Tcl_InterpObjCmd( } } - endOfForLoop: - + endOfForLoop: if ((i + 2) < objc) { Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? ?--? ?path? ?result?"); @@ -689,35 +682,34 @@ Tcl_InterpObjCmd( } /* - * Did they specify a slave interp to cancel the script in - * progress in? If not, use the current interp. + * Did they specify a slave interp to cancel the script in progress + * in? If not, use the current interp. */ if (i < objc) { slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } i++; } else { slaveInterp = interp; } - if (slaveInterp != NULL) { - if (i < objc) { - resultObjPtr = objv[i]; - - /* - * Tcl_CancelEval removes this reference. - */ + if (i < objc) { + resultObjPtr = objv[i]; - Tcl_IncrRefCount(resultObjPtr); - i++; - } else { - resultObjPtr = NULL; - } + /* + * Tcl_CancelEval removes this reference. + */ - return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); + Tcl_IncrRefCount(resultObjPtr); + i++; } else { - return TCL_ERROR; + resultObjPtr = NULL; } + + return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags); } case OPT_CREATE: { int i, last, safe; @@ -787,13 +779,11 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, slavePtr); return TCL_OK; } - case OPT_DEBUG: { - /* TIP #378 */ - Tcl_Interp *slaveInterp; - + case OPT_DEBUG: /* TIP #378 */ /* * Currently only -frame supported, otherwise ?-option ?value?? */ + if (objc < 3 || objc > 5) { Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??"); return TCL_ERROR; @@ -803,11 +793,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_DELETE: { int i; InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; for (i = 2; i < objc; i++) { slaveInterp = GetInterp(interp, objv[i]); @@ -816,6 +804,8 @@ Tcl_InterpObjCmd( } else if (slaveInterp == interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot delete the current interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "DELETESELF", NULL); return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; @@ -824,9 +814,7 @@ Tcl_InterpObjCmd( } return TCL_OK; } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; - + case OPT_EVAL: if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); return TCL_ERROR; @@ -836,12 +824,9 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; + int exists = 1; - exists = 1; slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { if (objc > 3) { @@ -853,9 +838,7 @@ Tcl_InterpObjCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); return TCL_OK; } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - + case OPT_EXPOSE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); return TCL_ERROR; @@ -865,10 +848,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDE: if ((objc < 4) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); return TCL_ERROR; @@ -878,30 +858,22 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ - + case OPT_HIDDEN: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } return SlaveHidden(interp, slaveInterp); - } - case OPT_ISSAFE: { - Tcl_Interp *slaveInterp; - + case OPT_ISSAFE: slaveInterp = GetInterp2(interp, objc, objv); if (slaveInterp == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); return TCL_OK; - } case OPT_INVOKEHID: { int i; const char *namespaceName; - Tcl_Interp *slaveInterp; static const char *const hiddenOptions[] = { "-global", "-namespace", "--", NULL }; @@ -944,7 +916,6 @@ Tcl_InterpObjCmd( objv + i); } case OPT_LIMIT: { - Tcl_Interp *slaveInterp; static const char *const limitTypes[] = { "commands", "time", NULL }; @@ -973,9 +944,7 @@ Tcl_InterpObjCmd( return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); } } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; - + case OPT_MARKTRUSTED: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "path"); return TCL_ERROR; @@ -985,10 +954,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveMarkTrusted(interp, slaveInterp); - } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; - + case OPT_RECLIMIT: if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); return TCL_ERROR; @@ -998,9 +964,7 @@ Tcl_InterpObjCmd( return TCL_ERROR; } return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); - } case OPT_SLAVES: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -1024,8 +988,7 @@ Tcl_InterpObjCmd( } case OPT_TRANSFER: case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Interp *masterInterp; /* The master of the slave. */ Tcl_Channel chan; if (objc != 5) { @@ -1060,7 +1023,6 @@ Tcl_InterpObjCmd( return TCL_OK; } case OPT_TARGET: { - Tcl_Interp *slaveInterp; InterpInfo *iiPtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; @@ -1093,6 +1055,8 @@ Tcl_InterpObjCmd( Tcl_AppendResult(interp, "target interpreter for alias \"", aliasName, "\" in path \"", Tcl_GetString(objv[2]), "\" is not my descendant", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "TARGETSHROUDED", NULL); return TCL_ERROR; } return TCL_OK; @@ -1437,6 +1401,8 @@ TclPreventAliasLoop( Tcl_AppendResult(interp, "cannot define or rename alias \"", Tcl_GetCommandName(cmdInterp, cmd), "\": would create a loop", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "ALIASLOOP", NULL); return TCL_ERROR; } @@ -2292,6 +2258,8 @@ SlaveBgerror( || (length < 1)) { Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BGERRORFORMAT", NULL); return TCL_ERROR; } TclSetBgErrorHandler(slaveInterp, objv[0]); @@ -2728,8 +2696,8 @@ SlaveDebugCmd( Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME)); Tcl_SetObjResult(interp, resultPtr); } else { - if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, - "debug option", 0, &debugType) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option", + 0, &debugType) != TCL_OK) { return TCL_ERROR; } if (debugType == DEBUG_TYPE_FRAME) { @@ -2738,11 +2706,13 @@ SlaveDebugCmd( != TCL_OK) { return TCL_ERROR; } + /* - * Quietly ignore attempts to disable interp debugging. - * This is a one-way switch as frame debug info is maintained - * in a stack that must be consistent once turned on. + * Quietly ignore attempts to disable interp debugging. This + * is a one-way switch as frame debug info is maintained in a + * stack that must be consistent once turned on. */ + if (debugType) { iPtr->flags |= INTERP_DEBUG_FRAME; } @@ -2847,6 +2817,8 @@ SlaveExpose( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -2890,6 +2862,8 @@ SlaveRecursionLimit( if (Tcl_IsSafe(interp)) { Tcl_AppendResult(interp, "permission denied: " "safe interpreters cannot change recursion limit", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { @@ -2898,6 +2872,8 @@ SlaveRecursionLimit( if (limit <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "recursion limit must be > 0", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT", + NULL); return TCL_ERROR; } Tcl_SetRecursionLimit(slaveInterp, limit); @@ -2905,6 +2881,7 @@ SlaveRecursionLimit( if (interp == slaveInterp && iPtr->numLevels > limit) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "falling back due to new recursion limit", -1)); + Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); @@ -2946,6 +2923,8 @@ SlaveHide( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -3028,6 +3007,8 @@ SlaveInvokeHidden( Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } @@ -3082,6 +3063,8 @@ SlaveMarkTrusted( Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot mark trusted", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE", + NULL); return TCL_ERROR; } ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; @@ -3339,6 +3322,7 @@ Tcl_LimitCheck( } else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "command count limit exceeded", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -3364,6 +3348,7 @@ Tcl_LimitCheck( } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "time limit exceeded", NULL); + Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL); Tcl_Release(interp); return TCL_ERROR; } @@ -4429,8 +4414,7 @@ SlaveCommandLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, limitLen = 0; @@ -4455,6 +4439,8 @@ SlaveCommandLimitCmd( if (gran < 1) { Tcl_AppendResult(interp, "granularity must be at " "least 1", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4470,6 +4456,8 @@ SlaveCommandLimitCmd( if (limit < 0) { Tcl_AppendResult(interp, "command limit value must be at " "least 0", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4617,8 +4605,7 @@ SlaveTimeLimitCmd( } return TCL_OK; } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) { - Tcl_WrongNumArgs(interp, consumedObjc, objv, - "?-option value ...?"); + Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?"); return TCL_ERROR; } else { int i, scriptLen = 0, milliLen = 0, secLen = 0; @@ -4647,6 +4634,8 @@ SlaveTimeLimitCmd( if (gran < 1) { Tcl_AppendResult(interp, "granularity must be at " "least 1", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } break; @@ -4662,6 +4651,8 @@ SlaveTimeLimitCmd( if (tmp < 0) { Tcl_AppendResult(interp, "milliseconds must be at least 0", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } limitMoment.usec = ((long)tmp)*1000; @@ -4678,6 +4669,8 @@ SlaveTimeLimitCmd( if (tmp < 0) { Tcl_AppendResult(interp, "seconds must be at least 0", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADVALUE", NULL); return TCL_ERROR; } limitMoment.sec = tmp; @@ -4694,11 +4687,15 @@ SlaveTimeLimitCmd( if (secObj != NULL && secLen == 0 && milliLen > 0) { Tcl_AppendResult(interp, "may only set -milliseconds " "if -seconds is not also being reset", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } if (milliLen == 0 && (secObj == NULL || secLen > 0)) { Tcl_AppendResult(interp, "may only reset -milliseconds " "if -seconds is also being reset", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", + "BADUSAGE", NULL); return TCL_ERROR; } } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b27163d..9128333 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1339,6 +1339,8 @@ TclLsetFlat( /* ...the index points outside the sublist. */ Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); break; } @@ -1511,6 +1513,8 @@ TclListObjSetElement( if (!length) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); return TCL_ERROR; } result = SetListFromAny(interp, listPtr); @@ -1531,6 +1535,8 @@ TclListObjSetElement( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); } return TCL_ERROR; } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 371a437..707d6ec 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -160,6 +160,8 @@ Tcl_LoadObjCmd( Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -226,6 +228,8 @@ Tcl_LoadObjCmd( Tcl_AppendResult(interp, "file \"", fullFileName, "\" is already loaded for package \"", pkgPtr->packageName, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "SPLITPERSONALITY", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -261,6 +265,8 @@ Tcl_LoadObjCmd( if (fullFileName[0] == 0) { Tcl_AppendResult(interp, "package \"", packageName, "\" isn't loaded statically", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", + NULL); code = TCL_ERROR; goto done; } @@ -312,6 +318,8 @@ Tcl_LoadObjCmd( Tcl_AppendResult(interp, "couldn't figure out package name for ", fullFileName, NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "WHATPACKAGE", NULL); code = TCL_ERROR; goto done; } @@ -407,11 +415,22 @@ Tcl_LoadObjCmd( Tcl_AppendResult(interp, "can't use package in a safe interpreter: no ", pkgPtr->packageName, "_SafeInit procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", + NULL); code = TCL_ERROR; goto done; } code = pkgPtr->safeInitProc(target); } else { + if (pkgPtr->initProc == NULL) { + Tcl_AppendResult(interp, + "can't attach package to interpreter: no ", + pkgPtr->packageName, "_Init procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", + NULL); + code = TCL_ERROR; + goto done; + } code = pkgPtr->initProc(target); } @@ -555,6 +574,8 @@ Tcl_UnloadObjCmd( Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -626,6 +647,8 @@ Tcl_UnloadObjCmd( Tcl_AppendResult(interp, "package \"", packageName, "\" is loaded statically and cannot be unloaded", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", + NULL); code = TCL_ERROR; goto done; } @@ -636,6 +659,8 @@ Tcl_UnloadObjCmd( Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -663,6 +688,8 @@ Tcl_UnloadObjCmd( Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded in this interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -677,6 +704,8 @@ Tcl_UnloadObjCmd( if (pkgPtr->safeUnloadProc == NULL) { Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded under a safe interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } @@ -685,6 +714,8 @@ Tcl_UnloadObjCmd( if (pkgPtr->unloadProc == NULL) { Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded under a trusted interpreter", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } @@ -771,8 +802,7 @@ Tcl_UnloadObjCmd( */ if (pkgPtr->fileName[0] != '\0') { - - Tcl_MutexLock(&packageMutex); + Tcl_MutexLock(&packageMutex); if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. @@ -824,6 +854,8 @@ Tcl_UnloadObjCmd( #else Tcl_AppendResult(interp, "file \"", fullFileName, "\" cannot be unloaded: unloading disabled", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", + NULL); code = TCL_ERROR; #endif } -- cgit v0.12 From 2db0d44d63bad5e5d32e84a38b8a4756d7dab1d0 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sat, 2 Apr 2011 21:55:39 +0000 Subject: Replaced another couple of 'double' declarations with 'volatile double' to work around misrounding issues in mingw-gcc 3.4.5. --- ChangeLog | 6 ++++++ generic/tclStrToD.c | 6 ++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/ChangeLog b/ChangeLog index 168dc0b..f1ab8a4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2011-04-02 Kevin B. Kenny + + * generic/tclStrToD.c (QuickConversion): Replaced another couple + of 'double' declarations with 'volatile double' to work around + misrounding issues in mingw-gcc 3.4.5. + 2011-03-24 Donal K. Fellows * generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d5c6e9c..139b8f2 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2668,7 +2668,7 @@ StrictQuickFormat(double d, /* Number to convert */ */ inline static char* -QuickConversion(double d, /* Number to format */ +QuickConversion(double e, /* Number to format */ int k, /* floor(log10(d)), approximately */ int k_check, /* 0 if k is exact, 1 if it may be too high */ int flags, /* Flags passed to dtoa: @@ -2686,11 +2686,13 @@ QuickConversion(double d, /* Number to format */ char* retval; /* Returned string */ char* end; /* Pointer to the terminal null byte in the * returned string */ + volatile double d; /* Workaround for a bug in mingw gcc 3.4.5 */ /* * Bring d into the range [1 .. 10) */ - ieps = AdjustRange(&d, k); + ieps = AdjustRange(&e, k); + d = e; /* * If the guessed value of k didn't get d into range, adjust it -- cgit v0.12 From 2205a28b9e00ec29977d2b21e2f2bda3b77aaaf4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 3 Apr 2011 06:05:13 +0000 Subject: More generation of error codes (namespace creation, path normalization, pipeline creation, package handling, procedures, [scan] formats) --- ChangeLog | 8 +++++++ generic/tclNamesp.c | 4 ++++ generic/tclObj.c | 2 ++ generic/tclPathObj.c | 6 +++++ generic/tclPipe.c | 18 ++++++++++++++ generic/tclPkg.c | 44 +++++++++++++++++++++++----------- generic/tclProc.c | 68 ++++++++++++++++++++++++++++++++++++++-------------- generic/tclResult.c | 15 +++++++----- generic/tclScan.c | 11 +++++++++ tests/ioCmd.test | 6 ++--- 10 files changed, 141 insertions(+), 41 deletions(-) diff --git a/ChangeLog b/ChangeLog index 23b3f1e..b734896 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2011-04-03 Donal K. Fellows + + * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: + * generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c: + * generic/tclScan.c: More generation of error codes (namespace + creation, path normalization, pipeline creation, package handling, + procedures, [scan] formats) + 2011-04-02 Kevin B. Kenny * generic/tclStrToD.c (QuickConversion): Replaced another couple diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3a08221..45b9f6d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -690,6 +690,8 @@ Tcl_CreateNamespace( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't create namespace \"\": " "only global namespace can have empty name", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -725,6 +727,8 @@ Tcl_CreateNamespace( ) { Tcl_AppendResult(interp, "can't create namespace \"", name, "\": already exists", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } diff --git a/generic/tclObj.c b/generic/tclObj.c index 321ed67..630226f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2265,6 +2265,8 @@ Tcl_GetDoubleFromObj( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN", + NULL); } return TCL_ERROR; } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 81007a2..01a297b 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -1523,6 +1523,8 @@ TclFSMakePathFromNormalized( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't find object" "string representation", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", + NULL); } return TCL_ERROR; } @@ -2423,6 +2425,8 @@ SetFsPathFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment " "variable to expand path", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); } return TCL_ERROR; } @@ -2440,6 +2444,8 @@ SetFsPathFromAny( Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", name+1, "\" doesn't exist", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); } Tcl_DStringFree(&temp); if (split != len) { diff --git a/generic/tclPipe.c b/generic/tclPipe.c index c24d136..5f59c38 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -109,6 +109,8 @@ FileForRedirect( Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan), "\" wasn't opened for ", ((writing) ? "writing" : "reading"), NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADCHAN", NULL); } return NULL; } @@ -151,6 +153,7 @@ FileForRedirect( badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL); return NULL; } @@ -342,6 +345,8 @@ TclCleanupChildren( } else { Tcl_AppendResult(interp, "child wait status didn't make sense\n", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "ODDWAITRESULT", msg1, NULL); } } } @@ -539,6 +544,8 @@ TclCreatePipeline( if ((i == (lastBar + 1)) || (i == (argc - 1))) { Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } } @@ -565,6 +572,8 @@ TclCreatePipeline( if (inputLiteral == NULL) { Tcl_AppendResult(interp, "can't specify \"", argv[i], "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } skip = 2; @@ -673,6 +682,8 @@ TclCreatePipeline( if (i != argc-1) { Tcl_AppendResult(interp, "must specify \"", argv[i], "\" as last word in command", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "PIPESYNTAX", NULL); goto error; } errorFile = outputFile; @@ -713,6 +724,8 @@ TclCreatePipeline( Tcl_SetResult(interp, "illegal use of | or |& in command", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX", + NULL); goto error; } @@ -1063,11 +1076,15 @@ Tcl_OpenCommandChannel( if ((flags & TCL_STDOUT) && (outPipe == NULL)) { Tcl_AppendResult(interp, "can't read output from command:" " standard output was redirected", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } if ((flags & TCL_STDIN) && (inPipe == NULL)) { Tcl_AppendResult(interp, "can't write input to command:" " standard input was redirected", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", + "BADREDIRECT", NULL); goto error; } } @@ -1078,6 +1095,7 @@ Tcl_OpenCommandChannel( if (channel == NULL) { Tcl_AppendResult(interp, "pipe for command could not be created", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL); goto error; } return channel; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 53be4af..67503cb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -156,6 +156,7 @@ Tcl_PkgProvideEx( } Tcl_AppendResult(interp, "conflicting versions provided for package \"", name, "\": ", pkgPtr->version, ", then ", version, NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -286,6 +287,7 @@ Tcl_PkgRequireEx( Tcl_AppendResult(interp, "Cannot load package \"", name, "\" in standalone executable: This package is not " "compiled with stub support", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); return NULL; } @@ -376,6 +378,7 @@ PkgRequireCore( "attempt to provide ", name, " ", (char *) pkgPtr->clientData, " requires ", name, NULL); AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return NULL; } @@ -422,7 +425,9 @@ PkgRequireCore( } } - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ if (reqc > 0) { /* Check satisfaction of requirements. */ @@ -493,6 +498,8 @@ PkgRequireCore( name, " ", versionToProvide, " failed: no version of package ", name, " provided", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); } else { char *pvi, *vi; @@ -515,6 +522,8 @@ PkgRequireCore( versionToProvide, " failed: package ", name, " ", pkgPtr->version, " provided instead", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); } } } @@ -525,6 +534,7 @@ PkgRequireCore( Tcl_AppendResult(interp, "attempt to provide package ", name, " ", versionToProvide, " failed: bad return code: ", TclGetString(codePtr), NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); code = TCL_ERROR; } @@ -582,9 +592,11 @@ PkgRequireCore( if ((code != TCL_OK) && (code != TCL_ERROR)) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad return code: ", TclGetString(codePtr), NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } @@ -599,6 +611,7 @@ PkgRequireCore( if (pkgPtr->version == NULL) { Tcl_AppendResult(interp, "can't find package ", name, NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return NULL; } @@ -608,27 +621,28 @@ PkgRequireCore( * provided version meets the current requirements. */ - if (reqc == 0) { - satisfies = 1; - } else { + if (reqc != 0) { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); - } - if (satisfies) { - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + if (!satisfies) { + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need", NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; } - return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; + + *ptr = pkgPtr->clientData; + } + return pkgPtr->version; } /* @@ -1328,6 +1342,7 @@ CheckVersionAndConvert( ckfree(ibuf); Tcl_AppendResult(interp, "expected version number but got \"", string, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); return TCL_ERROR; } @@ -1590,6 +1605,7 @@ CheckRequirement( Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL); return TCL_ERROR; } diff --git a/generic/tclProc.c b/generic/tclProc.c index 6cd5bb2..9f4ba29 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -154,11 +154,13 @@ Tcl_ProcObjCmd( if (nsPtr == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": unknown namespace", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (procName == NULL) { Tcl_AppendResult(interp, "can't create procedure \"", fullName, "\": bad procedure name", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if ((nsPtr != iPtr->globalNsPtr) @@ -166,6 +168,7 @@ Tcl_ProcObjCmd( Tcl_AppendResult(interp, "can't create procedure \"", procName, "\" in non-global namespace with name starting with \":\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -490,6 +493,8 @@ TclCreateProc( "procedure \"%s\": arg list contains %d entries, " "precompiled header expects %d", procName, numArgs, procPtr->numArgs)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -516,11 +521,15 @@ TclCreateProc( Tcl_AppendResult(interp, "too many fields in argument specifier \"", argArray[i], "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree(fieldValues); Tcl_AppendResult(interp, "argument with no name", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } @@ -547,12 +556,16 @@ TclCreateProc( Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is an array element", NULL); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((*p == ':') && (*(p+1) == ':')) { Tcl_AppendResult(interp, "formal parameter \"", fieldValues[0], "\" is not a simple name", NULL); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "FORMALARGUMENTFORMAT", NULL); goto procError; } p++; @@ -580,6 +593,8 @@ TclCreateProc( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } @@ -599,6 +614,8 @@ TclCreateProc( "default value inconsistent with precompiled body", procName, fieldValues[0])); ckfree(fieldValues); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "BYTECODELIES", NULL); goto procError; } } @@ -752,6 +769,7 @@ TclGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -884,7 +902,7 @@ TclObjGetFrame( levelError: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); return -1; } @@ -1863,6 +1881,7 @@ InterpProcNR2( Tcl_AppendResult(interp, "invoked \"", ((result == TCL_BREAK) ? "break" : "continue"), "\" outside of a loop", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; /* @@ -1980,6 +1999,8 @@ TclProcCompileProc( if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_AppendResult(interp, "a precompiled script jumped interps", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", + "CROSSINTERPBYTECODE", NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2468,6 +2489,7 @@ SetLambdaFromAny( Tcl_AppendObjToObj(errPtr, objPtr); Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1); Tcl_SetObjResult(interp, errPtr); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL); return TCL_ERROR; } @@ -2893,26 +2915,28 @@ Tcl_DisassembleObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "procName"); return TCL_ERROR; - } else { - procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); - if (procPtr == NULL) { - Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), - "\" isn't a procedure", NULL); - return TCL_ERROR; - } + } - /* - * Compile (if uncompiled) and disassemble a procedure. - */ + procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2])); + if (procPtr == NULL) { + Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), + "\" isn't a procedure", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC", + TclGetString(objv[2]), NULL); + return TCL_ERROR; + } - result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); - if (result != TCL_OK) { - return result; - } - TclPopStackFrame(interp); - codeObjPtr = procPtr->bodyPtr; - break; + /* + * Compile (if uncompiled) and disassemble a procedure. + */ + + result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1); + if (result != TCL_OK) { + return result; } + TclPopStackFrame(interp); + codeObjPtr = procPtr->bodyPtr; + break; case DISAS_SCRIPT: /* * Compile and disassemble a script. @@ -2947,6 +2971,8 @@ Tcl_DisassembleObjCmd( if (oPtr->classPtr == NULL) { Tcl_AppendResult(interp, "\"", TclGetString(objv[2]), "\" is not a class", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", + TclGetString(objv[2]), NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, @@ -2980,12 +3006,16 @@ Tcl_DisassembleObjCmd( unknownMethod: Tcl_AppendResult(interp, "unknown method \"", TclGetString(objv[3]), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", + TclGetString(objv[3]), NULL); return TCL_ERROR; } procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr)); if (procPtr == NULL) { Tcl_AppendResult(interp, "body not available for this kind of method", NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "METHODTYPE", NULL); return TCL_ERROR; } if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { @@ -3019,6 +3049,8 @@ Tcl_DisassembleObjCmd( if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", + "BYTECODE", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr)); diff --git a/generic/tclResult.c b/generic/tclResult.c index fad3b82..6a71ee2 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1487,9 +1487,10 @@ TclMergeReturnOptions( */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad -errorstack value: " - "expected a list but got \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); + "expected a list but got \"", TclGetString(valuePtr), + "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", + NULL); goto error; } if (length % 2) { @@ -1497,9 +1498,11 @@ TclMergeReturnOptions( * Errorstack must always be an even-sized list */ Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "forbidden odd-sized list for -errorstack: \"", - TclGetString(valuePtr), "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); + Tcl_AppendResult(interp, + "forbidden odd-sized list for -errorstack: \"", + TclGetString(valuePtr), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", + "ODDSIZEDLIST_ERRORSTACK", NULL); goto error; } } diff --git a/generic/tclScan.c b/generic/tclScan.c index c862be4..68b8d21 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -331,6 +331,7 @@ ValidateFormat( Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL); goto error; } @@ -377,6 +378,7 @@ ValidateFormat( Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL); goto error; } /* @@ -390,6 +392,7 @@ ValidateFormat( Tcl_AppendResult(interp, "field size modifier may not be specified in %", buf, " conversion", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL); goto error; } /* @@ -408,6 +411,7 @@ ValidateFormat( if (flags & SCAN_BIG) { Tcl_SetResult(interp, "unsigned bignum scans are invalid", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); goto error; } break; @@ -444,11 +448,13 @@ ValidateFormat( badSet: Tcl_SetResult(interp, "unmatched [ in format string", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL); goto error; default: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad scan conversion character \"", buf, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL); goto error; } if (!(flags & SCAN_SUPPRESS)) { @@ -495,6 +501,7 @@ ValidateFormat( Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL); goto error; } else if (!xpgSize && (nassign[i] == 0)) { /* @@ -505,6 +512,7 @@ ValidateFormat( Tcl_SetResult(interp, "variable is not assigned by any conversion specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL); goto error; } } @@ -516,10 +524,12 @@ ValidateFormat( if (gotXpg) { Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL); } else { Tcl_SetResult(interp, "different numbers of variable names and field specifiers", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL); } error: @@ -991,6 +1001,7 @@ Tcl_ScanObjCmd( continue; } result++; +#warning Why make your own error message? Why? if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", TclGetString(objv[i+3]), "\"", NULL); diff --git a/tests/ioCmd.test b/tests/ioCmd.test index c83d174..82f83db 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -386,13 +386,13 @@ test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode -} {1 {can't write input to command: standard input was redirected} NONE} +} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.4 {I/O to command pipelines} unixOrPc { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} -- cgit v0.12 From 25e4dca4916e5ae7be29bb21c40e59f3adb4b5ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2011 13:40:01 +0000 Subject: Better error-message in case of errors related to setting a variable --- ChangeLog | 11 +++++++++++ generic/tclCmdAH.c | 10 ++-------- generic/tclCmdIL.c | 22 ++++++++-------------- generic/tclDictObj.c | 20 ++++---------------- generic/tclScan.c | 8 ++++---- generic/tclTest.c | 4 +--- tests/error.test | 38 +++++++++++++++++++------------------- tests/info.test | 6 +++--- tests/scan.test | 14 +++++++------- 9 files changed, 59 insertions(+), 74 deletions(-) diff --git a/ChangeLog b/ChangeLog index b734896..63e4391 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2011-04-04 Jan Nijtmans + + * generic/tclCmdAH.c: Better error-message in case of errors + * generic/tclCmdIL.c: related to setting a variable. This fixes + * generic/tclDictObj.c: a warning: "Why make your own error + * generic/tclScan.c: message? Why?" + * generic/tclTest.c: + * test/error.test: + * test/info.test: + * test/scan.test: + 2011-04-03 Donal K. Fellows * generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c: diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 3edfa54..8b5f13d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -345,10 +345,7 @@ CatchObjCmdCallback( if (objc >= 3) { if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), 0)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save command result in variable", NULL); + Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } } @@ -356,11 +353,8 @@ CatchObjCmdCallback( Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, - options, 0)) { + options, TCL_LEAVE_ERR_MSG)) { Tcl_DecrRefCount(options); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save return options in variable", NULL); return TCL_ERROR; } } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b38ec9f..c42a54b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -966,7 +966,7 @@ InfoDefaultCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - const char *procName, *argName, *varName; + const char *procName, *argName; Proc *procPtr; CompiledLocal *localPtr; Tcl_Obj *valueObjPtr; @@ -993,18 +993,18 @@ InfoDefaultCmd( && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - localPtr->defValuePtr, 0); + localPtr->defValuePtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, - nullObjPtr, 0); + nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { - goto defStoreError; + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } @@ -1016,12 +1016,6 @@ InfoDefaultCmd( "\" doesn't have an argument \"", argName, "\"", NULL); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL); return TCL_ERROR; - - defStoreError: - varName = TclGetString(objv[3]); - Tcl_AppendResult(interp, "couldn't store default value in variable \"", - varName, "\"", NULL); - return TCL_ERROR; } /* @@ -1058,7 +1052,7 @@ InfoErrorStackCmd( Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - + target = interp; if (objc == 2) { target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); @@ -1069,7 +1063,7 @@ InfoErrorStackCmd( iPtr = (Interp *) target; Tcl_SetObjResult(interp, iPtr->errorStack); - + return TCL_OK; } @@ -1163,7 +1157,7 @@ InfoFrameCmd( CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; CmdFrame *runPtr = iPtr->cmdFramePtr; CmdFrame *lastPtr = NULL; - + topLevel += corPtr->caller.cmdFramePtr->level; while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) { lastPtr = runPtr; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3da91a3..508c2af 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2456,18 +2456,12 @@ DictForNRCmd( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); goto error; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { goto error; } @@ -2540,19 +2534,13 @@ DictForLoopCallback( */ Tcl_IncrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set key variable: \"", - TclGetString(keyVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) { TclDecrRefCount(valueObj); result = TCL_ERROR; goto done; } TclDecrRefCount(valueObj); - if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't set value variable: \"", - TclGetString(valueVarObj), "\"", NULL); + if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; goto done; } diff --git a/generic/tclScan.c b/generic/tclScan.c index 68b8d21..06e66e4 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1001,10 +1001,10 @@ Tcl_ScanObjCmd( continue; } result++; -#warning Why make your own error message? Why? - if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i+3]), "\"", NULL); + /* In case of multiple errors in setting variables, just report + * the first one. */ + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], + (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { code = TCL_ERROR; } Tcl_DecrRefCount(objs[i]); diff --git a/generic/tclTest.c b/generic/tclTest.c index b757185..bac0c7f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3939,10 +3939,8 @@ TestregexpObjCmd( info.matches[ii].end - 1); } } - valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0); + valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - Tcl_GetString(varPtr), "\"", NULL); return TCL_ERROR; } } diff --git a/tests/error.test b/tests/error.test index c34ccb0..97bcc0a 100644 --- a/tests/error.test +++ b/tests/error.test @@ -138,7 +138,7 @@ test error-3.3 {errors in catch command} { catch {unset a} set a(0) 22 list [catch {catch {format 44} a} msg] $msg -} {1 {couldn't save command result in variable}} +} {1 {can't set "a": variable is array}} catch {unset a} # More tests related to errorInfo and errorCode @@ -417,7 +417,7 @@ test error-12.4 {try with result/opts variable assignment in on handler} { } {bar,FOO} test error-12.5 {try with result/opts variable assignment in on handler, vars remain in scope} { try { throw FOO bar } on error {res opts} { list d e f } - set r "$res,[dict get $opts -errorcode]" + set r "$res,[dict get $opts -errorcode]" } {bar,FOO} test error-12.6 {try result is propagated if no matching handler} { try { list a b c } on error {} { list d e f } @@ -459,7 +459,7 @@ test error-13.8 {try with multiple handlers and finally (ok)} { try list on error {} {} trap {} {} {} finally {} } {} test error-13.9 {last handler body can't be a fallthrough #1} -body { - try list on error {} {} on break {} - + try list on error {} {} on break {} - } -returnCodes error -result {last non-finally clause must not have a body of "-"} test error-13.10 {last handler body can't be a fallthrough #2} -body { try list on error {} {} on break {} - finally { list d e f } @@ -471,7 +471,7 @@ test error-14.1 {try with multiple handlers (only one matches) #1} { try { throw FOO bar } on ok {} { list a b c } trap FOO {} { list d e f } } {d e f} test error-14.2 {try with multiple handlers (only one matches) #2} { - try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } + try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } } {d e f} test error-14.3 {try with multiple handlers (only one matches) #3} { try { @@ -482,7 +482,7 @@ test error-14.3 {try with multiple handlers (only one matches) #3} { list d e f } on ok {} { list a b c - } + } } {d e f} test error-14.4 {try with multiple matching handlers (only the first in left-to-right order runs) #1} { try { throw FOO bar } on error {} { list a b c } trap FOO {} { list d e f } @@ -593,16 +593,16 @@ test error-16.6 {try with variable assignment and propagation #1} { catch { try { throw FOO bar } trap FOO {em} { throw BAR baz } } - set em + set em } {bar} test error-16.7 {try with variable assignment and propagation #2} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-16.8 {exception chaining (try=ok, handler=error)} { - #FIXME is the intent of this test correct? + #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts @@ -686,7 +686,7 @@ test error-17.11 {successful finally doesn't affect variable assignment or propa catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { list d e f } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} # try tests - propagation (exceptions in finally, exception chaining) @@ -707,11 +707,11 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { throw BAZ zing } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-18.6 {exception chaining in finally (try=ok)} { catch { - list a b c + list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } @@ -782,14 +782,14 @@ test error-19.1 {try with fallthrough body #1} { } {1} test error-19.2 {try with fallthrough body #2} { set RES {} - try { - throw FOO bar + try { + throw FOO bar } trap BAR {} { } trap FOO {} - trap {} {} { set RES foo } on error {} { set RES err - } + } set RES } {foo} test error-19.3 {try with cascade fallthrough} { @@ -805,22 +805,22 @@ test error-19.4 {multiple unrelated fallthroughs #1} { set RES {} try { throw FOO bar - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {foo} test error-19.5 {multiple unrelated fallthroughs #2} { set RES {} try { throw BAZ zing - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {err} proc addmsg msg { @@ -1054,7 +1054,7 @@ namespace delete ::tcl::test::error # cleanup catch {rename p ""} ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/info.test b/tests/info.test index 9977054..3323281 100644 --- a/tests/info.test +++ b/tests/info.test @@ -215,14 +215,14 @@ test info-6.9 {info default option} -returnCodes error -setup { set a(0) 88 proc t1 {a b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.10 {info default option} -setup { catch {unset a} } -cleanup {unset a} -body { set a(0) 88 proc t1 {{a 18} b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.11 {info default option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { @@ -1826,7 +1826,7 @@ test info-30.46 {TIP 280 for compiled [subst]} { } YES test info-30.47 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 + set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 subst {$a( [dict get [info frame 0] line])} ; # 1831 } YES diff --git a/tests/scan.test b/tests/scan.test index 6e1ccb0..84f22b4 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -328,7 +328,7 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} { $msg $x $y] unset z set result -} {1 {couldn't set variable "z"} abc ghi} +} {1 {can't set "z": variable is array} abc ghi} test scan-4.61 {Tcl_ScanObjCmd, set errors} { set x {} catch {unset y}; array set y {} @@ -338,7 +338,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} { unset y unset z set result -} {1 {couldn't set variable "z"couldn't set variable "y"} abc} +} {1 {can't set "z": variable is array} abc} # procedure that returns the range of integers @@ -545,27 +545,27 @@ test scan-8.12 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %d a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.13 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %c a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.14 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %s a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.15 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.16 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} catch {unset a} test scan-8.17 {error conditions} { list [catch {scan 44 %2c a} msg] $msg -- cgit v0.12 From 6965ff95a63177a766b1be29435d3cf3592f593b Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 13:46:33 +0000 Subject: Minor tinkering with style. --- generic/tclScan.c | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/generic/tclScan.c b/generic/tclScan.c index 06e66e4..d21bfaf 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1001,8 +1001,12 @@ Tcl_ScanObjCmd( continue; } result++; - /* In case of multiple errors in setting variables, just report - * the first one. */ + + /* + * In case of multiple errors in setting variables, just report + * the first one. + */ + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) { code = TCL_ERROR; @@ -1050,7 +1054,7 @@ Tcl_ScanObjCmd( } return code; } - + /* * Local Variables: * mode: c -- cgit v0.12 From 875ed401f93f459fbac8cfd682d6e015b10f7ad3 Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 13:55:06 +0000 Subject: More generation of error codes ([format], [after], [trace], RE optimizer). --- ChangeLog | 6 +++ generic/tclBasic.c | 126 ++++++++++++++++++++++++------------------------- generic/tclStringObj.c | 22 ++++++++- generic/tclTimer.c | 34 +++++++------ generic/tclTrace.c | 8 ++++ generic/tclUtil.c | 11 ++++- 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 + + * 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 * 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; -- cgit v0.12 From caf48c369e8ba6e8bcbb7f3a0aa6a0303dc2b56e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2011 14:01:30 +0000 Subject: Remove unused header file: unix/tclUnixThrd.h --- ChangeLog | 1 + macosx/Tcl.xcode/project.pbxproj | 2 -- macosx/Tcl.xcodeproj/project.pbxproj | 2 -- 3 files changed, 1 insertion(+), 4 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4724598..fd79840 100644 --- a/ChangeLog +++ b/ChangeLog @@ -14,6 +14,7 @@ * test/error.test: * test/info.test: * test/scan.test: + * unix/tclUnixThrd.h: Remove this unused header file. 2011-04-03 Donal K. Fellows diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj index e62ded2..54d9e02 100644 --- a/macosx/Tcl.xcode/project.pbxproj +++ b/macosx/Tcl.xcode/project.pbxproj @@ -829,7 +829,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = ""; }; F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = ""; }; F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = ""; }; - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixThrd.h; sourceTree = ""; }; F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = ""; }; F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = ""; }; F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = ""; }; @@ -1732,7 +1731,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */, F96D446808F272B9004A47F5 /* tclUnixTest.c */, F96D446908F272B9004A47F5 /* tclUnixThrd.c */, - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */, F96D446B08F272B9004A47F5 /* tclUnixTime.c */, F96D446C08F272B9004A47F5 /* tclXtNotify.c */, F96D446D08F272B9004A47F5 /* tclXtTest.c */, diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 002ab80..3cc34d7 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -829,7 +829,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = ""; }; F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = ""; }; F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = ""; }; - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixThrd.h; sourceTree = ""; }; F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = ""; }; F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = ""; }; F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = ""; }; @@ -1732,7 +1731,6 @@ F96D446708F272B9004A47F5 /* tclUnixSock.c */, F96D446808F272B9004A47F5 /* tclUnixTest.c */, F96D446908F272B9004A47F5 /* tclUnixThrd.c */, - F96D446A08F272B9004A47F5 /* tclUnixThrd.h */, F96D446B08F272B9004A47F5 /* tclUnixTime.c */, F96D446C08F272B9004A47F5 /* tclXtNotify.c */, F96D446D08F272B9004A47F5 /* tclXtTest.c */, -- cgit v0.12 From 0d695fcd80cec0f53ad553a4b0abacbd29aad68c Mon Sep 17 00:00:00 2001 From: dkf Date: Mon, 4 Apr 2011 14:10:01 +0000 Subject: Disable tcl::mathfunc::rmmadwiw by default to make test suite work; automated test frameworks have no mind to read... --- ChangeLog | 3 +++ library/init.tcl | 2 ++ 2 files changed, 5 insertions(+) diff --git a/ChangeLog b/ChangeLog index fd79840..976cc58 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,8 @@ 2011-04-04 Donal K. Fellows + * library/init.tcl (tcl::mathfunc::rmmadwiw): Disable by default to + make test suite work. + * 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). diff --git a/library/init.tcl b/library/init.tcl index d85fe2a..f1d6a64 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -823,6 +823,7 @@ proc tcl::CopyDirectory {action src dest} { } # TIP 131 +if 0 { proc tcl::rmmadwiw {} { set magic { 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe @@ -847,3 +848,4 @@ proc tcl::mathfunc::rmmadwiw {} { set matter [lreverse $mind] return [join $matter ""] } +} -- cgit v0.12