diff options
Diffstat (limited to 'generic')
37 files changed, 721 insertions, 475 deletions
diff --git a/generic/tcl.h b/generic/tcl.h index 2abbb1a..3285c3c 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -799,11 +799,14 @@ typedef struct Tcl_Obj { void *ptr1; void *ptr2; } twoPtrValue; - struct { /* - internal rep as a wide int, tightly - * packed fields. */ - void *ptr; /* Pointer to digits. */ - unsigned long value;/* Alloc, used, and signum packed into a - * single word. */ + struct { /* - internal rep as a pointer and a long, + * the main use of which is a bignum's + * tightly packed fields, where the alloc, + * used and signum flags are packed into a + * single word with everything else hung + * off the pointer. */ + void *ptr; + unsigned long value; } ptrAndLongRep; } internalRep; } Tcl_Obj; @@ -2405,13 +2408,13 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define ckalloc(x) \ ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) # define ckfree(x) \ - Tcl_DbCkfree((VOID *)(x), __FILE__, __LINE__) + Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) # define ckrealloc(x,y) \ - ((VOID *) Tcl_DbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__)) + ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) # define attemptckalloc(x) \ ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) # define attemptckrealloc(x,y) \ - ((VOID *) Tcl_AttemptDbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__)) + ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) #else /* !TCL_MEM_DEBUG */ @@ -2424,13 +2427,13 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define ckalloc(x) \ ((VOID *) Tcl_Alloc((unsigned)(x))) # define ckfree(x) \ - Tcl_Free((VOID *)(x)) + Tcl_Free((char *)(x)) # define ckrealloc(x,y) \ - ((VOID *) Tcl_Realloc((VOID *)(x), (unsigned)(y))) + ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y))) # define attemptckalloc(x) \ ((VOID *) Tcl_AttemptAlloc((unsigned)(x))) # define attemptckrealloc(x,y) \ - ((VOID *) Tcl_AttemptRealloc((VOID *)(x), (unsigned)(y))) + ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f2b301..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; } /* @@ -6018,6 +6016,9 @@ TclNREvalObjEx( * iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ + if (TclInterpReady(interp) != TCL_OK) { + return TCL_ERROR; + } if (flags & TCL_EVAL_GLOBAL) { savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; 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/tclCmdMZ.c b/generic/tclCmdMZ.c index 05f2e5d..61de8de 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -383,12 +383,8 @@ Tcl_RegexpObjCmd( return TCL_ERROR; } } else { - Tcl_Obj *valuePtr; - - valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); - if (valuePtr == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } } @@ -816,9 +812,8 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[3]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } else { /* @@ -1799,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; } } @@ -1861,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; } } @@ -2062,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; } } @@ -2194,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; @@ -2214,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++) { @@ -2519,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; } } @@ -2666,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; } } @@ -3563,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; @@ -3579,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]; @@ -3589,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]; @@ -3606,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; } @@ -3658,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 @@ -3674,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; } } @@ -3691,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; } @@ -4011,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; } @@ -4194,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]; @@ -4211,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)) { @@ -4226,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; @@ -4234,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]; @@ -4265,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/tclCompExpr.c b/generic/tclCompExpr.c index a07d6df..d1d7403 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2152,7 +2152,7 @@ ExecConstantExprTree( TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr; + byteCodePtr = byteCodeObj->internalRep.otherValuePtr; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); Tcl_DecrRefCount(byteCodeObj); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f3d4e9e..82e6758 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1001,7 +1001,7 @@ CompileSubstObj( if (objPtr->typePtr == &substCodeType) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.ptrAndLongRep.ptr; + codePtr = objPtr->internalRep.ptrAndLongRep.ptr; if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) 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/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/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/tclEvent.c b/generic/tclEvent.c index 78bd7b8..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) { @@ -1479,7 +1481,7 @@ Tcl_UpdateObjCmd( int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptions {REGEXP_IDLETASKS}; + enum updateOptions {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1489,7 +1491,7 @@ Tcl_UpdateObjCmd( return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: + case OPT_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 26d3e04..f1b8504 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -189,7 +189,7 @@ typedef struct TEBCdata { TclNRAddCallback(interp, TEBCresume, TD, \ INT2PTR(1), NULL, NULL) -#define TEBC_DATA_DIG() \ +#define TEBC_DATA_DIG() \ pc = TD->pc; \ cleanup = TD->cleanup; \ tosPtr = esPtr->tosPtr @@ -197,15 +197,15 @@ typedef struct TEBCdata { #define PUSH_TAUX_OBJ(objPtr) \ do { \ - objPtr->internalRep.twoPtrValue.ptr2 = auxObjList; \ + objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \ auxObjList = objPtr; \ } while (0) #define POP_TAUX_OBJ() \ - do { \ - tmpPtr = auxObjList; \ - auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2; \ - Tcl_DecrRefCount(tmpPtr); \ + do { \ + tmpPtr = auxObjList; \ + auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr; \ + Tcl_DecrRefCount(tmpPtr); \ } while (0) /* @@ -1460,7 +1460,7 @@ CompileExprObj( if (objPtr->typePtr == &exprCodeType) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1500,7 +1500,7 @@ CompileExprObj( TclInitByteCodeObj(objPtr, &compEnv); objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1572,7 +1572,7 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + ByteCode *codePtr = objPtr->internalRep.otherValuePtr; objPtr->typePtr = NULL; objPtr->internalRep.otherValuePtr = NULL; @@ -1633,7 +1633,7 @@ TclCompileObj( * here. */ - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + codePtr = objPtr->internalRep.otherValuePtr; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1691,67 +1691,59 @@ TclCompileObj( { Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); + ExtCmdLoc *eclPtr; + CmdFrame *ctxPtr; + int redo; - if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - int redo = 0; - - if (invoker) { - CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); - *ctxPtr = *invoker; + if (!hePtr || !invoker) { + return codePtr; + } - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr used instead - */ + eclPtr = Tcl_GetHashValue(hePtr); + redo = 0; + ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxPtr = *invoker; - TclGetSrcInfoForPc(ctxPtr); - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - /* - * The reference made by 'TclGetSrcInfoForPc' is - * dead. - */ + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); - ctxPtr->data.eval.path = NULL; - } - } + TclGetSrcInfoForPc(ctxPtr); + if (ctxPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. + */ - if (word < ctxPtr->nline) { - /* - * Note: We do not care if the line[word] is -1. This - * is a difference and requires a recompile (location - * changed from absolute to relative, literal is used - * fixed and through variable) - * - * Example: - * test info-32.0 using literal of info-24.8 - * (dict with ... vs set body ...). - */ + Tcl_DecrRefCount(ctxPtr->data.eval.path); + ctxPtr->data.eval.path = NULL; + } + } - redo = ((eclPtr->type == TCL_LOCATION_SOURCE) - && (eclPtr->start != ctxPtr->line[word])) - || ((eclPtr->type == TCL_LOCATION_BC) - && (ctxPtr->type == TCL_LOCATION_SOURCE)); - } + if (word < ctxPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This is a + * difference and requires a recompile (location changed from + * absolute to relative, literal is used fixed and through + * variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ - TclStackFree(interp, ctxPtr); - } + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxPtr->type == TCL_LOCATION_SOURCE)); + } - if (redo) { - goto recompileObj; - } + TclStackFree(interp, ctxPtr); + if (!redo) { + return codePtr; } } - - /* - * Increment the code's ref count while it is being executed. If - * afterwards no references to it remain, free the code. - */ - - runCompiledObj: - return codePtr; } recompileObj: @@ -1773,7 +1765,7 @@ TclCompileObj( codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; } - goto runCompiledObj; + return codePtr; } /* @@ -2121,8 +2113,8 @@ TEBCresume( } #endif /* - * Push the call's object result and continue execution with - * the next instruction. + * Push the call's object result and continue execution with the + * next instruction. */ TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", @@ -2132,15 +2124,13 @@ TEBCresume( /* * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult - * to avoid any side effects caused by the resetting of - * errorInfo and errorCode [Bug 804681], which are not needed - * here. We chose instead to manipulate the interp's object - * result directly. + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. * - * Note that the result object is now in objResultPtr, it - * keeps the refCount it had in its role of - * iPtr->objResultPtr. + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. */ TclNewObj(objPtr); @@ -2637,7 +2627,7 @@ TEBCresume( */ TclNewObj(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH; + objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH; PUSH_TAUX_OBJ(objPtr); NEXT_INST_F(1, 0, 0); @@ -2727,8 +2717,7 @@ TEBCresume( case INST_INVOKE_EXPANDED: CLANG_ASSERT(auxObjList); - objc = CURR_DEPTH - - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1; + objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value; POP_TAUX_OBJ(); if (objc) { pcAdjustment = 1; @@ -4415,6 +4404,7 @@ TEBCresume( * strings. We can use memcmp in all (n)eq cases because we * don't need to worry about lexical LE/BE variance. */ + typedef int (*memCmpFn_t)(const void*, const void*, size_t); memCmpFn_t memCmpFn; int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ) @@ -6259,7 +6249,8 @@ TEBCresume( bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); DECACHE_STACK_INFO(); - TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); + TclLogCommandInfo(interp, codePtr->source, bytes, + bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -6270,8 +6261,8 @@ TEBCresume( */ while (auxObjList) { - if ((catchTop != initCatchTop) && (*catchTop > - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) { + if ((catchTop != initCatchTop) && + (*catchTop>auxObjList->internalRep.ptrAndLongRep.value)) { break; } POP_TAUX_OBJ(); diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6d3c013..c3a0a5e 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1067,6 +1067,9 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[0]); + } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1091,6 +1094,9 @@ TclFileAttrsCmd( "option", 0, &index) != TCL_OK) { goto end; } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[i]); + } if (i + 1 == objc) { Tcl_AppendResult(interp, "value for \"", TclGetString(objv[i]), "\" missing", NULL); 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; } } 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/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 10ae67b..0f1c0d1 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -426,5 +426,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TclpLocaltime_unix +#undef TclpGmtime_unix #endif /* _TCLINTPLATDECLS */ 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 46710d6..9128333 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -181,7 +181,7 @@ Tcl_NewListObj( */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; listRepPtr->refCount++; @@ -253,7 +253,7 @@ Tcl_DbNewListObj( */ Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listPtr->internalRep.twoPtrValue.ptr2 = NULL; listPtr->typePtr = &tclListType; listRepPtr->refCount++; @@ -329,7 +329,7 @@ Tcl_SetListObj( if (!listRepPtr) { Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); } - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + objPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclListType; listRepPtr->refCount++; @@ -446,7 +446,7 @@ Tcl_ListObjGetElements( return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -564,7 +564,7 @@ Tcl_ListObjAppendElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; @@ -674,7 +674,7 @@ Tcl_ListObjIndex( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -729,7 +729,7 @@ Tcl_ListObjLength( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -816,7 +816,7 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -887,7 +887,7 @@ Tcl_ListObjReplace( Tcl_Panic("Not enough memory to allocate list"); } - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -1228,8 +1228,8 @@ TclLsetList( * * Results: * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for - * the pointer returned. + * occurred. The returned object includes one reference count for the + * pointer returned. * * Side effects: * On entry, the reference count of the variable value does not reflect @@ -1275,8 +1275,8 @@ TclLsetFlat( Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; /* - * If there are no indices, simply return the new value. - * (Without indices, [lset] is a synonym for [set]. + * If there are no indices, simply return the new value. (Without + * indices, [lset] is a synonym for [set]. */ if (indexCount == 0) { @@ -1285,14 +1285,14 @@ TclLsetFlat( } /* - * If the list is shared, make a copy we can modify (copy-on-write). - * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few - * reasons: 1) we have not yet confirmed listPtr is actually a list; - * 2) We make a verbatim copy of any existing string rep, and when - * we combine that with the delayed invalidation of string reps of - * modified Tcl_Obj's implemented below, the outcome is that any - * error condition that causes this routine to return NULL, will - * leave the string rep of listPtr and all elements to be unchanged. + * If the list is shared, make a copy we can modify (copy-on-write). We + * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: + * 1) we have not yet confirmed listPtr is actually a list; 2) We make a + * verbatim copy of any existing string rep, and when we combine that with + * the delayed invalidation of string reps of modified Tcl_Obj's + * implemented below, the outcome is that any error condition that causes + * this routine to return NULL, will leave the string rep of listPtr and + * all elements to be unchanged. */ subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; @@ -1306,8 +1306,8 @@ TclLsetFlat( chainPtr = NULL; /* - * Loop through all the index arguments, and for each one dive - * into the appropriate sublist. + * Loop through all the index arguments, and for each one dive into the + * appropriate sublist. */ do { @@ -1339,14 +1339,16 @@ 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; } /* - * No error conditions. As long as we're not yet on the last - * index, determine the next sublist for the next pass through - * the loop, and take steps to make sure it is an unshared copy, - * as we intend to modify it. + * No error conditions. As long as we're not yet on the last index, + * determine the next sublist for the next pass through the loop, and + * take steps to make sure it is an unshared copy, as we intend to + * modify it. */ result = TCL_OK; @@ -1366,8 +1368,8 @@ TclLsetFlat( * we know to be unshared. This call will also deal with the * situation where parentList shares its intrep with other * Tcl_Obj's. Dealing with the shared intrep case can cause - * subListPtr to become shared again, so detect that case and - * make and store another copy. + * subListPtr to become shared again, so detect that case and make + * and store another copy. */ if (index == elemCount) { @@ -1381,61 +1383,67 @@ TclLsetFlat( } /* - * The TclListObjSetElement() calls do not spoil the string - * rep of parentList, and that's fine for now, since all we've - * done so far is replace a list element with an unshared copy. - * The list value remains the same, so the string rep. is still - * valid, and unchanged, which is good because if this whole - * routine returns NULL, we'd like to leave no change to the - * value of the lset variable. Later on, when we set valuePtr - * in its proper place, then all containing lists will have - * their values changed, and will need their string reps spoiled. - * We maintain a list of all those Tcl_Obj's (via a little intrep - * surgery) so we can spoil them at that time. + * The TclListObjSetElement() calls do not spoil the string rep of + * parentList, and that's fine for now, since all we've done so + * far is replace a list element with an unshared copy. The list + * value remains the same, so the string rep. is still valid, and + * unchanged, which is good because if this whole routine returns + * NULL, we'd like to leave no change to the value of the lset + * variable. Later on, when we set valuePtr in its proper place, + * then all containing lists will have their values changed, and + * will need their string reps spoiled. We maintain a list of all + * those Tcl_Obj's (via a little intrep surgery) so we can spoil + * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr; + parentList->internalRep.twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); /* - * Either we've detected and error condition, and exited the loop - * with result == TCL_ERROR, or we've successfully reached the last - * index, and we're ready to store valuePtr. In either case, we - * need to clean up our string spoiling list of Tcl_Obj's. + * Either we've detected and error condition, and exited the loop with + * result == TCL_ERROR, or we've successfully reached the last index, and + * we're ready to store valuePtr. In either case, we need to clean up our + * string spoiling list of Tcl_Obj's. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; if (result == TCL_OK) { - /* - * We're going to store valuePtr, so spoil string reps - * of all containing lists. + * We're going to store valuePtr, so spoil string reps of all + * containing lists. */ Tcl_InvalidateStringRep(objPtr); } - /* Clear away our intrep surgery mess */ - chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + /* + * Clear away our intrep surgery mess. + */ + + chainPtr = objPtr->internalRep.twoPtrValue.ptr2; objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { /* - * Error return; message is already in interp. Clean up - * any excess memory. + * Error return; message is already in interp. Clean up any excess + * memory. */ + if (retValuePtr != listPtr) { Tcl_DecrRefCount(retValuePtr); } return NULL; } - /* Store valuePtr in proper sublist and return */ + /* + * Store valuePtr in proper sublist and return. + */ + Tcl_ListObjLength(NULL, subListPtr, &len); if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); @@ -1505,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); @@ -1513,7 +1523,7 @@ TclListObjSetElement( } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; elemCount = listRepPtr->elemCount; elemPtrs = &listRepPtr->elements; @@ -1525,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; } @@ -1550,7 +1562,7 @@ TclListObjSetElement( } listRepPtr->refCount++; listRepPtr->elemCount = elemCount; - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; oldListRepPtr->refCount--; } @@ -1598,7 +1610,7 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + register List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; register Tcl_Obj **elemPtrs = &listRepPtr->elements; register Tcl_Obj *objPtr; int numElems = listRepPtr->elemCount; @@ -1639,10 +1651,10 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = srcPtr->internalRep.twoPtrValue.ptr1; listRepPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclListType; } @@ -1861,7 +1873,7 @@ UpdateStringOfList( { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; - List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1; int numElems = listRepPtr->elemCount; register int i; const char *elem; 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 } diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index ad233b9..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; } } @@ -911,7 +915,7 @@ Tcl_DeleteNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL;) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + cmdPtr = Tcl_GetHashValue(entryPtr); if (cmdPtr->nreProc == NRInterpCoroutine) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr); @@ -1335,6 +1339,7 @@ Tcl_Export( if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendResult(interp, "invalid export pattern \"", pattern, "\": pattern can't specify a namespace", NULL); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1539,6 +1544,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1556,10 +1562,12 @@ Tcl_Import( Tcl_AppendResult(interp, "no namespace specified in import pattern \"", pattern, "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { Tcl_AppendResult(interp, "import pattern \"", pattern, "\" tries to import from namespace \"", importNsPtr->name, "\" into itself", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1681,6 +1689,7 @@ DoImport( "\" would create a loop containing command \"", Tcl_DStringValue(&ds), "\"", NULL); Tcl_DStringFree(&ds); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } @@ -1720,6 +1729,7 @@ DoImport( } Tcl_AppendResult(interp, "can't import command \"", cmdName, "\": already exists", NULL); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -2798,18 +2808,18 @@ GetNamespaceFromObj( * cross interps. */ - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && (!refNsPtr || ((interp == refNsPtr->interp) && - (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) { + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 60c37d1..046cb00 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2238,6 +2238,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; } @@ -4370,7 +4372,7 @@ SetCmdNameFromAny( if (cmdPtr) { cmdPtr->refCount++; - resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + resPtr = objPtr->internalRep.otherValuePtr; if ((objPtr->typePtr == &tclCmdNameType) && resPtr && (resPtr->refCount == 1)) { /* 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..d21bfaf 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,9 +1001,14 @@ Tcl_ScanObjCmd( continue; } result++; - 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]); @@ -1039,7 +1054,7 @@ Tcl_ScanObjCmd( } return code; } - + /* * Local Variables: * mode: c diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d4a3b4b..205b865 100755 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -2710,7 +2710,7 @@ StrictQuickFormat( inline static char * QuickConversion( - double d, /* Number to format. */ + 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: @@ -2729,12 +2729,14 @@ QuickConversion( 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 by one. If diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7cdbb3e..fe6d0af 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -134,10 +134,9 @@ typedef struct String { #define stringAlloc(numChars) \ (String *) ckalloc((unsigned) STRING_SIZE(numChars) ) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((char *) ptr, (unsigned) STRING_SIZE(numChars) ) + (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((char *) ptr, \ - (unsigned) STRING_SIZE(numChars) ) + (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) ) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.otherValuePtr) #define SET_STRING(objPtr, stringPtr) \ @@ -1610,7 +1609,6 @@ AppendUtfToUtfRep( objPtr->bytes[newLength] = 0; objPtr->length = newLength; } - /* *---------------------------------------------------------------------- @@ -1707,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 = @@ -1745,6 +1743,7 @@ Tcl_AppendFormatToObj( if (numBytes) { if (numBytes > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); @@ -1784,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; } @@ -1843,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) { @@ -1858,6 +1861,7 @@ Tcl_AppendFormatToObj( } if (width > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } @@ -1878,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) @@ -1935,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) { @@ -1964,6 +1970,7 @@ Tcl_AppendFormatToObj( case 'u': if (useBig) { msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; goto errorMsg; } case 'd': @@ -2111,6 +2118,7 @@ Tcl_AppendFormatToObj( } if (toAppend > segmentLimit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(segment, bytes, toAppend); @@ -2166,6 +2174,7 @@ Tcl_AppendFormatToObj( } if (numDigits > INT_MAX) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } } else if (!useBig) { @@ -2233,6 +2242,7 @@ Tcl_AppendFormatToObj( } if (toAppend > segmentLimit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(segment, pure); @@ -2286,6 +2296,7 @@ Tcl_AppendFormatToObj( p += sprintf(p, "%d", precision); if (precision > INT_MAX - length) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } length += precision; @@ -2302,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; @@ -2315,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; } @@ -2346,6 +2360,7 @@ Tcl_AppendFormatToObj( Tcl_DecrRefCount(segment); } msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendObjToObj(appendObj, segment); @@ -2368,6 +2383,7 @@ Tcl_AppendFormatToObj( if (numBytes) { if (numBytes > limit) { msg = overflow; + errCode = "OVERFLOW"; goto errorMsg; } Tcl_AppendToObj(appendObj, span, numBytes); @@ -2380,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/tclStubInit.c b/generic/tclStubInit.c index eb9a9be..054ece5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -39,6 +39,8 @@ #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#define TclpLocaltime_unix TclpLocaltime +#define TclpGmtime_unix TclpGmtime /* * WARNING: The contents of this file is automatically generated by the 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/generic/tclTestObj.c b/generic/tclTestObj.c index ca8545a..1ef1dc3 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -523,7 +523,7 @@ TestindexobjCmd( } Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); - indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr; + indexRep = objv[1]->internalRep.otherValuePtr; indexRep->index = index2; result = Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); @@ -560,7 +560,7 @@ TestindexobjCmd( if (objv[3]->typePtr != NULL && !strcmp("index", objv[3]->typePtr->name)) { - indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr; + indexRep = objv[3]->internalRep.otherValuePtr; if (indexRep->tablePtr == (void *) argv) { objv[3]->typePtr->freeIntRepProc(objv[3]); objv[3]->typePtr = NULL; @@ -1200,8 +1200,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = (TestString *) - (varPtr[varIndex])->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.otherValuePtr; length = (int) strPtr->allocated; } else { length = -1; @@ -1255,8 +1254,7 @@ TeststringobjCmd( if (varPtr[varIndex] != NULL) { Tcl_ConvertToType(NULL, varPtr[varIndex], Tcl_GetObjType("string")); - strPtr = (TestString *) - (varPtr[varIndex])->internalRep.otherValuePtr; + strPtr = varPtr[varIndex]->internalRep.otherValuePtr; length = strPtr->maxChars; } else { length = -1; diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index ad1d510..ad1d510 100755..100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c 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 f41830a..64aa824 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; } @@ -465,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; } @@ -1057,7 +1064,7 @@ Tcl_ConcatObj( continue; } } - listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) { break; } @@ -2119,10 +2126,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 +2162,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 +2194,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 +2225,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 +2418,7 @@ TclNeedSpace( * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ + return 1; } switch (*end) { @@ -2434,19 +2443,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 +2742,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 +2755,7 @@ SetEndOffsetFromAny( * Conversion failed. Report the error. */ + badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, @@ -2853,7 +2863,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 +2921,7 @@ static void FreeThreadHash( ClientData clientData) { - Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); @@ -2996,8 +3007,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); } @@ -3262,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); @@ -3273,9 +3283,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 +3310,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,12 +3321,12 @@ 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; + code = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; @@ -3372,6 +3383,7 @@ TclReToGlob( break; default: msg = "invalid escape sequence"; + code = "BADESCAPE"; goto invalidGlob; } break; @@ -3400,6 +3412,7 @@ TclReToGlob( case '$': if (p+1 != strEnd) { msg = "$ not anchor"; + code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; @@ -3407,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; @@ -3420,7 +3433,9 @@ 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"; + code = "OVERCOMPLEX"; goto invalidGlob; } @@ -3449,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; diff --git a/generic/tclVar.c b/generic/tclVar.c index a4b8a69..28151c0 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -5481,7 +5481,7 @@ DeleteArray( /* *---------------------------------------------------------------------- * - * TclTclObjVarErrMsg -- + * TclObjVarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. |