diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | doc/info.n | 20 | ||||
| -rw-r--r-- | generic/tclBasic.c | 8 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 3 | ||||
| -rw-r--r-- | generic/tclCompile.c | 178 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclExecute.c | 46 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 109 | ||||
| -rw-r--r-- | tests/error.test | 8 | ||||
| -rw-r--r-- | tests/result.test | 8 |
11 files changed, 369 insertions, 41 deletions
@@ -1,3 +1,17 @@ +2010-10-17 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * doc/info.n : [Patch 2995655] : + * generic/tclBasic.c: Report inner contexts in [info errorstack] + * generic/tclCompCmds.c: + * generic/tclCompile.c: + * generic/tclCompile.h: + * generic/tclExecute.c: + * generic/tclInt.h: + * generic/tclNamesp.c: + * tests/error.test: + * tests/result.test: + + 2010-10-20 Donal K. Fellows <dkf@users.sf.net> * generic/tclCompCmds.c (TclCompileDictForCmd): Update the compilation @@ -8,7 +8,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: info.n,v 1.39 2010/10/17 20:16:55 ferrieux Exp $ +'\" RCS: @(#) $Id: info.n,v 1.40 2010/10/20 20:52:26 ferrieux Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -100,13 +100,17 @@ Returns, in a form that is programmatically easy to parse, the function names and arguments at each level from the call stack of the last error in the given \fIinterp\fR, or in the current one if not specified. -This form is an -even-sized list alternating tokens and parameters. Tokens are currently either -\fBCALL\fR or \fBUP\fR, but other values may be introduced in the -future. \fBCALL\fR indicates a procedure call, and its parameter is the -corresponding [info level 0]; \fBUP\fR indicates a shift in variable frames -generated by uplevel or similar, and applies to the previous CALL item. Its -parameter is the level offset. +This form is an even-sized list alternating tokens and parameters. Tokens are +currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be +introduced in the future. \fBCALL\fR indicates a procedure call, and its +parameter is the corresponding [info level 0]. \fBUP\fR indicates a shift in +variable frames generated by uplevel or similar, and applies to the previous +CALL item. Its parameter is the level offset. \fBINNER\fR identifies the +"inner context", which is the innermost atomic command or bytecode instruction +that raised the error, along with its arguments when available. While +\fBCALL\fR and \fBUP\fR allow to follow complex call paths, \fBINNER\fR homes +in on the offending operation in the innermost proc call, even going to +sub-expr granularity. This information is also present in the \fB\-errorstack\fR entry of the options dictionary returned by 3-argument diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f0d3e5d..fa63953 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.467 2010/10/01 12:52:49 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.468 2010/10/20 20:52:26 ferrieux Exp $ */ #include "tclInt.h" @@ -549,6 +549,10 @@ Tcl_CreateInterp(void) Tcl_IncrRefCount(iPtr->upLiteral); TclNewLiteralStringObj(iPtr->callLiteral,"CALL"); Tcl_IncrRefCount(iPtr->callLiteral); + TclNewLiteralStringObj(iPtr->innerLiteral,"INNER"); + Tcl_IncrRefCount(iPtr->innerLiteral); + iPtr->innerContext = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(iPtr->innerContext); iPtr->errorCode = NULL; TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); @@ -1492,6 +1496,8 @@ DeleteInterpProc( iPtr->errorStack = NULL; Tcl_DecrRefCount(iPtr->upLiteral); Tcl_DecrRefCount(iPtr->callLiteral); + Tcl_DecrRefCount(iPtr->innerLiteral); + Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index a5e1074..cfa6678 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.170 2010/10/20 13:34:10 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.171 2010/10/20 20:52:27 ferrieux Exp $ */ #include "tclInt.h" @@ -3616,6 +3616,7 @@ TclCompileSyntaxError( int numBytes; const char *bytes = TclGetStringFromObj(msg, &numBytes); + TclErrorStackResetIf(interp, bytes, numBytes); TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, Tcl_GetReturnOptions(interp, TCL_ERROR)); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7781066..d40af69 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.192 2010/10/20 13:34:11 dkf Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.193 2010/10/20 20:52:27 ferrieux Exp $ */ #include "tclInt.h" @@ -452,6 +452,8 @@ static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + /* * TIP #280: Helper for building the per-word line information of all compiled * commands. @@ -486,6 +488,19 @@ static const Tcl_ObjType substCodeType = { NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ }; + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; /* *---------------------------------------------------------------------- @@ -4238,6 +4253,165 @@ FormatInstruction( /* *---------------------------------------------------------------------- * + * TclGetInnerContext -- + * + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch(*pc) { + + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + Tcl_ListObjLength(interp, result, &len); + /* reset while keeping the list intrep as much as possible */ + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + for(;objc>0;objc--) { + Tcl_Obj *ob; + + ob = tosPtr[1 - objc + off]; + if (!ob) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if (ob->refCount<=0 || ob->refCount==0x61616161) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p",ob); + } + Tcl_ListObjAppendElement(NULL, result, ob); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction + * + *---------------------------------------------------------------------- + */ +MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst) +{ + Tcl_Obj *objPtr; + + objPtr=Tcl_NewObj(); + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long)inst; + objPtr->bytes = NULL; + + return objPtr; +} + + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfInstName -- + * + * Update the string representation for an instruction name object. + * + *---------------------------------------------------------------------- + */ +static void UpdateStringOfInstName(Tcl_Obj *objPtr) +{ + int inst = objPtr->internalRep.longValue; + char *s,buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + + sprintf(buf, "inst_%d", inst); + s = buf; + } else { + s = (char *)tclInstructionTable[objPtr->internalRep.longValue].name; + } + len = strlen(s); + objPtr->bytes = ckalloc((unsigned) len + 1); + strcpy(objPtr->bytes, s); + objPtr->length = len; +} + + +/* + *---------------------------------------------------------------------- + * * PrintSourceToObj -- * * Appends a quoted representation of a string to a Tcl_Obj. @@ -4343,5 +4517,7 @@ RecordByteCodeStats( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index e6b0411..0df13d9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.127 2010/09/27 19:42:38 msofer Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.128 2010/10/20 20:52:28 ferrieux Exp $ */ #ifndef _TCLCOMPILATION @@ -975,6 +975,14 @@ MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); +MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, + const char *script, + const char *command, int length, + const unsigned char *pc, Tcl_Obj **tosPtr); +MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, + const unsigned char *pc, Tcl_Obj **tosPtr); +MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); + /* *---------------------------------------------------------------- diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5343ecd..a8b408e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.508 2010/10/20 13:34:11 dkf Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.509 2010/10/20 20:52:28 ferrieux Exp $ */ #include "tclInt.h" @@ -697,7 +697,8 @@ static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, - ByteCode *codePtr, int *lengthPtr); + ByteCode *codePtr, int *lengthPtr, + const unsigned char **pcBeg); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, @@ -2445,7 +2446,7 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); @@ -6264,9 +6265,11 @@ TEBCresume( goto abnormalReturn; } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + const unsigned char *pcBeg; + + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); DECACHE_STACK_INFO(); - Tcl_LogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0); + TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -7899,7 +7902,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); @@ -8013,7 +8016,7 @@ TclGetSrcInfoForCmd( ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr); + codePtr, lenPtr, NULL); } void @@ -8025,7 +8028,7 @@ TclGetSrcInfoForPc( if (cfPtr->cmd.str.cmd == NULL) { cfPtr->cmd.str.cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len); + &cfPtr->cmd.str.len, NULL); } if (cfPtr->cmd.str.cmd != NULL) { @@ -8076,15 +8079,18 @@ TclGetSrcInfoForPc( static const char * GetSrcInfoForPc( - const unsigned char *pc, /* The program counter value for which to + const unsigned char *pc, /* The program counter value for which to * return the closest command's source info. - * This points to a bytecode instruction in + * This points within a bytecode instruction in * codePtr's code. */ ByteCode *codePtr, /* The bytecode sequence in which to look up * the command source for the pc. */ - int *lengthPtr) /* If non-NULL, the location where the length + int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ + const unsigned char **pcBeg)/* If non-NULL, the bytecode location + * where the current instruction starts. + * If NULL; no pointer is stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8096,6 +8102,7 @@ GetSrcInfoForPc( int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { + if (pcBeg != NULL) *pcBeg = NULL; return NULL; } @@ -8164,6 +8171,22 @@ GetSrcInfoForPc( } } + if (pcBeg != NULL) { + const unsigned char *curr,*prev; + + /* Walk from beginning of command or BC to pc, by complete + * instructions. Stop when crossing pc; keep previous */ + + curr = prev = ((bestDist == INT_MAX) ? + codePtr->codeStart : + pc - bestDist); + while (curr <= pc) { + prev = curr; + curr += tclInstructionTable[*curr].numBytes; + } + *pcBeg = prev ; + } + if (bestDist == INT_MAX) { return NULL; } @@ -8171,6 +8194,7 @@ GetSrcInfoForPc( if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 1584e4a..c4ab6b3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.484 2010/09/28 15:13:54 rmax Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.485 2010/10/20 20:52:28 ferrieux Exp $ */ #ifndef _TCLINT @@ -2159,6 +2159,8 @@ typedef struct Interp { Tcl_Obj *errorStack; /* [info errorstack] value (as a Tcl_Obj). */ Tcl_Obj *upLiteral; /* "UP" literal for [info errorstack] */ Tcl_Obj *callLiteral; /* "CALL" literal for [info errorstack] */ + Tcl_Obj *innerLiteral; /* "INNER" literal for [info errorstack] */ + Tcl_Obj *innerContext; /* cached list for fast reallocation */ int resetErrorStack; /* controls cleaning up of ::errorStack */ #ifdef TCL_COMPILE_STATS @@ -3099,6 +3101,8 @@ MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); +MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); + /* *---------------------------------------------------------------- * Command procedures in the generic core: diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2d1ce11..89e8a21 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,11 +22,11 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.213 2010/10/01 12:52:49 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.214 2010/10/20 20:52:28 ferrieux Exp $ */ #include "tclInt.h" -#include "tclCompile.h" /* just for NRCommand */ +#include "tclCompile.h" /* for NRCommand; and TclLogCommandInfo visibility */ /* * Thread-local storage used to avoid having a global lock on data that is not @@ -4851,31 +4851,36 @@ TclGetNamespaceChildTable( /* *---------------------------------------------------------------------- * - * Tcl_LogCommandInfo -- + * TclLogCommandInfo -- * * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo field to describe the command that - * was being executed when the error occurred. + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. When pc and + * tosPtr are non-NULL, conveying a bytecode execution "inner context", + * and the offending instruction is suitable, that inner context is + * recorded in errorStack. * * Results: * None. * * Side effects: - * Information about the command is added to errorInfo and the line - * number stored internally in the interpreter is set. + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ void -Tcl_LogCommandInfo( +TclLogCommandInfo( Tcl_Interp *interp, /* Interpreter in which to log information. */ const char *script, /* First character in script containing * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - int length) /* Number of bytes in command (-1 means use + int length, /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ + const unsigned char *pc, /* current pc of bytecode execution context */ + Tcl_Obj **tosPtr) /* current stack of bytecode execution context */ { register const char *p; Interp *iPtr = (Interp *) interp; @@ -4962,6 +4967,18 @@ Tcl_LogCommandInfo( Tcl_ListObjLength(interp, iPtr->errorStack, &len); /* reset while keeping the list intrep as much as possible */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; + + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); + } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(command, length)); + } } if (!iPtr->framePtr->objc) { @@ -4981,6 +4998,80 @@ Tcl_LogCommandInfo( } /* + *---------------------------------------------------------------------- + * + * TclErrorStackResetIf -- + * + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. + * + * Results: + * None. + * + * Side effects: + * Reset errorstack if it needs be, and in that case remember the + * passed-in error message as inner context. + * + *---------------------------------------------------------------------- + */ +void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length) +{ + Interp *iPtr = (Interp *) interp; + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + if (iPtr->resetErrorStack) { + int len; + + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + /* reset while keeping the list intrep as much as possible */ + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(msg, length)); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_LogCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to log information. */ + const char *script, /* First character in script containing + * command (must be <= command). */ + const char *command, /* First character in command that generated + * the error. */ + int length) /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ +{ + TclLogCommandInfo(interp, script, command, length, NULL, NULL); +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/error.test b/tests/error.test index e30fd50..6e2aee5 100644 --- a/tests/error.test +++ b/tests/error.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: error.test,v 1.33 2010/06/02 23:36:26 ferrieux Exp $ +# RCS: @(#) $Id: error.test,v 1.34 2010/10/20 20:52:28 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -174,13 +174,13 @@ test error-4.6 {errorstack via info } -body { proc g x {error G:$x} catch {f 12} info errorstack -} -match glob -result {CALL {g 1212} CALL {f 12} UP 1} +} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} test error-4.7 {errorstack via options dict } -body { proc f x {g $x$x} proc g x {error G:$x} catch {f 12} m d dict get $d -errorstack -} -match glob -result {CALL {g 1212} CALL {f 12} UP 1} +} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} # Errors in error command itself @@ -244,7 +244,7 @@ test error-6.10 {catch must reset errorstack} -body { catch {f 13} set e2 [info errorstack] list $e1 $e2 -} -match glob -result {{CALL {g 1212} CALL {f 12} UP 1} {CALL {g 1313} CALL {f 13} UP 1}} +} -match glob -result {{INNER * CALL {g 1212} CALL {f 12} UP 1} {INNER * CALL {g 1313} CALL {f 13} UP 1}} test error-7.1 {Bug 1397843} -body { variable cmds diff --git a/tests/result.test b/tests/result.test index 8bde7ef..4dfee1d 100644 --- a/tests/result.test +++ b/tests/result.test @@ -135,14 +135,14 @@ test result-6.3 {Bug 2383005} { catch {return -code error -errorcode {{}a} eek} m set m } {bad -errorcode value: expected a list but got "{}a"} -test result-6.4 {non-list -errorstack} { +test result-6.4 {non-list -errorstack} -body { catch {return -code error -errorstack {{}a} eek} m o list $m [dict get $o -errorcode] [dict get $o -errorstack] -} {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {UP 1}} -test result-6.5 {odd-sized-list -errorstack} { +} -match glob -result {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {INNER * UP 1}} +test result-6.5 {odd-sized-list -errorstack} -body { catch {return -code error -errorstack a eek} m o list $m [dict get $o -errorcode] [dict get $o -errorstack] -} {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {UP 1}} +} -match glob -result {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {INNER * UP 1}} # cleanup cleanupTests return |