diff options
| -rw-r--r-- | ChangeLog | 23 | ||||
| -rw-r--r-- | doc/info.n | 20 | ||||
| -rw-r--r-- | generic/tclBasic.c | 8 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 12 | ||||
| -rw-r--r-- | generic/tclCompile.c | 186 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclExecute.c | 87 | ||||
| -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, 412 insertions, 65 deletions
@@ -1,3 +1,26 @@ +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 + * generic/tclCompile.c (tclInstructionTable): of [dict for] so that + * generic/tclExecute.c (TEBCresume): it no longer makes any + use of INST_DICT_DONE now that's not needed, and make it clearer in + the implementation of the instruction that it's just a deprecated form + of unset operation. Followup to my commit of 2010-10-16. + 2010-10-19 Donal K. Fellows <dkf@users.sf.net> * generic/tclZlib.c (Tcl_ZlibStreamGet): [Bug 3081008]: Ensure that @@ -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.38.2.1 2010/10/20 01:50:18 kennykb Exp $ +'\" RCS: @(#) $Id: info.n,v 1.38.2.2 2010/10/23 15:49:54 kennykb 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 91e66bb..954426c 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.465.2.3 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.465.2.4 2010/10/23 15:49:54 kennykb 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); @@ -1499,6 +1503,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 473dcb4..4dde235 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.169 2010/04/30 09:23:06 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.169.2.1 2010/10/23 15:49:54 kennykb Exp $ */ #include "tclInt.h" @@ -876,7 +876,8 @@ TclCompileDictForCmd( */ ExceptionRangeTarget(envPtr, loopRange, breakOffset); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); endTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP4, 0, envPtr); @@ -889,7 +890,8 @@ TclCompileDictForCmd( ExceptionRangeTarget(envPtr, catchRange, catchOffset); TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr); TclEmitOpcode( INST_PUSH_RESULT, envPtr); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); TclEmitOpcode( INST_END_CATCH, envPtr); TclEmitOpcode( INST_RETURN_STK, envPtr); @@ -905,7 +907,8 @@ TclCompileDictForCmd( envPtr->codeStart + emptyTargetOffset); TclEmitOpcode( INST_POP, envPtr); TclEmitOpcode( INST_POP, envPtr); - TclEmitInstInt4( INST_DICT_DONE, infoIndex, envPtr); + TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr); + TclEmitInt4( infoIndex, envPtr); /* * Final stage of the command (normal case) is that we push an empty @@ -3613,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 2a6ee34..be688e1 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.187.2.3 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.187.2.4 2010/10/23 15:49:54 kennykb Exp $ */ #include "tclInt.h" @@ -343,14 +343,16 @@ InstructionDesc const tclInstructionTable[] = { * Stack: ... key valueToAppend => ... newDict */ {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, /* Begin iterating over the dictionary, using the local scalar - * indicated by op4 to hold the iterator state. If doneBool is true, - * dictDone *must* be called later on. + * indicated by op4 to hold the iterator state. The local scalar + * should not refer to a named variable as the value is not wholly + * managed correctly. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, - /* Terminate the iterator in op4's local scalar. */ + /* Terminate the iterator in op4's local scalar. Use unsetScalar + * instead (with 0 for flags). */ {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in @@ -450,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. @@ -484,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 */ +}; /* *---------------------------------------------------------------------- @@ -4236,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. @@ -4341,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 e8a40d7..3c9350a 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.126.2.1 2010/09/27 20:33:37 kennykb Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.126.2.2 2010/10/23 15:49:54 kennykb 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 e5a6549..b69d281 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.494.2.7 2010/10/20 01:50:19 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.494.2.8 2010/10/23 15:49:54 kennykb 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)); @@ -3772,6 +3773,29 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); goto gotError; + + /* + * This is really an unset operation these days. Do not issue. + */ + + case INST_DICT_DONE: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u\n", opnd)); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { + if (!TclIsVarUndefined(varPtr)) { + TclDecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = NULL; + } else { + DECACHE_STACK_INFO(); + TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd); + CACHE_STACK_INFO(); + } + NEXT_INST_F(5, 0, 0); } /* @@ -5972,24 +5996,6 @@ TEBCresume( /* TODO: consider opt like INST_FOREACH_STEP4 */ NEXT_INST_F(5, 0, 1); - case INST_DICT_DONE: - opnd = TclGetUInt4AtPtr(pc+1); - TRACE(("%u => ", opnd)); - statePtr = (*LOCAL(opnd)).value.objPtr; - - if (statePtr != NULL && statePtr->typePtr == &dictIteratorType) { - /* - * Set the internal variable to an empty object to signify that we - * don't hold an iterator. - */ - - TclDecrRefCount(statePtr); - TclNewObj(emptyPtr); - (*LOCAL(opnd)).value.objPtr = emptyPtr; - Tcl_IncrRefCount(emptyPtr); - } - NEXT_INST_F(5, 0, 0); - case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); opnd2 = TclGetUInt4AtPtr(pc+5); @@ -6259,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; @@ -7894,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); @@ -8008,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 @@ -8020,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) { @@ -8071,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; @@ -8091,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; } @@ -8159,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; } @@ -8166,6 +8194,7 @@ GetSrcInfoForPc( if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 6d3968f..4dff202 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.482.2.3 2010/09/28 15:43:01 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.482.2.4 2010/10/23 15:49:54 kennykb 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 372d978..e1dfd48 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.212.2.1 2010/10/01 13:34:09 kennykb Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.212.2.2 2010/10/23 15:49:54 kennykb 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..a6e487d 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.33.2.1 2010/10/23 15:49:54 kennykb 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 |