diff options
Diffstat (limited to 'generic/tclCompile.c')
| -rw-r--r-- | generic/tclCompile.c | 178 |
1 files changed, 177 insertions, 1 deletions
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: */ |