diff options
| -rw-r--r-- | ChangeLog | 24 | ||||
| -rw-r--r-- | generic/tclBasic.c | 548 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 59 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 297 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 137 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 305 | ||||
| -rw-r--r-- | generic/tclCompExpr.c | 7 | ||||
| -rw-r--r-- | generic/tclCompile.c | 345 | ||||
| -rw-r--r-- | generic/tclCompile.h | 54 | ||||
| -rw-r--r-- | generic/tclExecute.c | 145 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 8 | ||||
| -rw-r--r-- | generic/tclInt.h | 166 | ||||
| -rw-r--r-- | generic/tclInterp.c | 8 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 13 | ||||
| -rw-r--r-- | generic/tclProc.c | 123 | ||||
| -rw-r--r-- | tests/info.test | 421 | ||||
| -rw-r--r-- | tests/platform.test | 1 | ||||
| -rw-r--r-- | tests/safe.test | 6 |
18 files changed, 2611 insertions, 56 deletions
@@ -1,3 +1,25 @@ +2006-11-28 Andreas Kupries <andreask@activestate.com> + + * generic/tclBasic.c: TIP #280 implementation, conditional on the define TCL_TIP280. + * generic/tclCmdAH.c: + * generic/tclCmdIL.c: + * generic/tclCmdMZ.c: + * generic/tclCompCmds.c: + * generic/tclCompExpr.c: + * generic/tclCompile.c: + * generic/tclCompile.h: + * generic/tclExecute.c: + * generic/tclIOUtil.c: + * generic/tclInt.h: + * generic/tclInterp.c: + * generic/tclNamesp.c: + * generic/tclObj.c: + * generic/tclProc.c: + * tests/compile.test: + * tests/info.test: + * tests/platform.test: + * tests/safe.test: + 2006-11-27 Kevin Kenny <kennykb@acm.org> * unix/tclUnixChan.c (TclUnixWaitForFile): @@ -19,7 +41,7 @@ 2006-11-03 Miguel Sofer <msofer@users.sf.net> - * generic/tclBasic.c (TEOVI): fix por possible leak of a Command + * generic/tclBasic.c (TEOVI): fix for possible leak of a Command in the presence of execution traces that delete it. * generic/tclBasic.c (TEOVI): diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f55c531..76f439c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,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.75.2.25 2006/11/04 01:37:55 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.26 2006/11/28 22:19:59 andreas_kupries Exp $ */ #include "tclInt.h" @@ -41,6 +41,17 @@ static int StringTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Obj *CONST objv[])); static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); +#ifdef TCL_TIP280 +/* TIP #280 - Modified token based evulation, with line information */ +static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, + int numBytes, int flags, int line)); + +static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, + int count, int line)); + +#endif + extern TclStubs tclStubs; /* @@ -334,6 +345,19 @@ Tcl_CreateInterp() iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; + +#ifdef TCL_TIP280 + /* + * TIP #280 - Initialize the arrays used to extend the ByteCode and + * Proc structures. + */ + iPtr->cmdFramePtr = NULL; + iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); +#endif + iPtr->activeVarTracePtr = NULL; iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; @@ -589,6 +613,10 @@ Tcl_CreateInterp() Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1", TCL_GLOBAL_ONLY); #endif +#ifdef TCL_TIP280 + Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1", + TCL_GLOBAL_ONLY); +#endif #ifdef Tcl_InitStubs #undef Tcl_InitStubs #endif @@ -1108,6 +1136,62 @@ DeleteInterpProc(interp) */ TclDeleteLiteralTable(interp, &(iPtr->literalTable)); + +#ifdef TCL_TIP280 + /* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents. + */ + { + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + CmdFrame* cfPtr; + ExtCmdLoc* eclPtr; + int i; + + for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr); + + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (cfPtr->data.eval.path); + } + ckfree ((char*) cfPtr->line); + ckfree ((char*) cfPtr); + Tcl_DeleteHashEntry (hPtr); + + } + Tcl_DeleteHashTable (iPtr->linePBodyPtr); + ckfree ((char*) iPtr->linePBodyPtr); + iPtr->linePBodyPtr = NULL; + + /* See also tclCompile.c, TclCleanupByteCode */ + + for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + + eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr); + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree ((char*) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree ((char*) eclPtr->loc); + } + + ckfree ((char*) eclPtr); + Tcl_DeleteHashEntry (hPtr); + } + Tcl_DeleteHashTable (iPtr->lineBCPtr); + ckfree((char*) iPtr->lineBCPtr); + iPtr->lineBCPtr = NULL; + } +#endif ckfree((char *) iPtr); } @@ -3353,7 +3437,7 @@ Tcl_LogCommandInfo(interp, script, command, length) /* *---------------------------------------------------------------------- * - * Tcl_EvalTokensStandard -- + * Tcl_EvalTokensStandard, EvalTokensStandard -- * * Given an array of tokens parsed from a Tcl command (e.g., the * tokens that make up a word or the index for an array variable) @@ -3367,7 +3451,8 @@ Tcl_LogCommandInfo(interp, script, command, length) * * Side effects: * Depends on the array of tokens being evaled. - * + * + * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ @@ -3381,6 +3466,22 @@ Tcl_EvalTokensStandard(interp, tokenPtr, count) int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { +#ifdef TCL_TIP280 + return EvalTokensStandard (interp, tokenPtr, count, 1); +} + +static int +EvalTokensStandard(interp, tokenPtr, count, line) + Tcl_Interp *interp; /* Interpreter in which to lookup + * variables, execute nested commands, + * and report errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ + int line; /* The line the script starts on. */ +{ +#endif Tcl_Obj *resultPtr, *indexPtr, *valuePtr; char buffer[TCL_UTF_MAX]; #ifdef TCL_MEM_DEBUG @@ -3429,8 +3530,14 @@ Tcl_EvalTokensStandard(interp, tokenPtr, count) iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { +#ifndef TCL_TIP280 code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, 0); +#else + /* TIP #280: Transfer line information to nested command */ + code = EvalEx(interp, + tokenPtr->start+1, tokenPtr->size-2, 0, line); +#endif } iPtr->numLevels--; if (code != TCL_OK) { @@ -3445,8 +3552,14 @@ Tcl_EvalTokensStandard(interp, tokenPtr, count) indexPtr = NULL; index = NULL; } else { +#ifndef TCL_TIP280 code = Tcl_EvalTokensStandard(interp, tokenPtr+2, tokenPtr->numComponents - 1); +#else + /* TIP #280: Transfer line information to nested command */ + code = EvalTokensStandard(interp, tokenPtr+2, + tokenPtr->numComponents - 1, line); +#endif if (code != TCL_OK) { goto done; } @@ -3526,8 +3639,7 @@ Tcl_EvalTokensStandard(interp, tokenPtr, count) } return code; } - - + /* *---------------------------------------------------------------------- * @@ -3583,7 +3695,7 @@ Tcl_EvalTokens(interp, tokenPtr, count) /* *---------------------------------------------------------------------- * - * Tcl_EvalEx -- + * Tcl_EvalEx, EvalEx -- * * This procedure evaluates a Tcl script without using the compiler * or byte-code interpreter. It just parses the script, creates @@ -3598,6 +3710,7 @@ Tcl_EvalTokens(interp, tokenPtr, count) * Side effects: * Depends on the script. * + * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ @@ -3614,13 +3727,33 @@ Tcl_EvalEx(interp, script, numBytes, flags) * TCL_EVAL_GLOBAL is currently * supported. */ { +#ifdef TCL_TIP280 + return EvalEx (interp, script, numBytes, flags, 1); +} + +static int +EvalEx(interp, script, numBytes, flags, line) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * script. Also used for error reporting. */ + CONST char *script; /* First character of script to evaluate. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ + int line; /* The line the script starts on. */ +{ +#endif Interp *iPtr = (Interp *) interp; CONST char *p, *next; Tcl_Parse parse; #define NUM_STATIC_OBJS 20 Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft, nested; + int code = TCL_OK; + int i, commandLength, bytesLeft, nested; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); @@ -3633,6 +3766,11 @@ Tcl_EvalEx(interp, script, numBytes, flags) int gotParse = 0, objectsUsed = 0; +#ifdef TCL_TIP280 + /* TIP #280 Structures for tracking of command locations. */ + CmdFrame eeFrame; +#endif + if (numBytes < 0) { numBytes = strlen(script); } @@ -3656,6 +3794,62 @@ Tcl_EvalEx(interp, script, numBytes, flags) } else { nested = 0; } + +#ifdef TCL_TIP280 + /* TIP #280 Initialize tracking. Do not push on the frame stack yet. */ + /* + * We may cont. counting based on a specific context (CTX), or open a new + * context, either for a sourced script, or 'eval'. For sourced files we + * always have a path object, even if nothing was specified in the interp + * itself. That makes code using it simpler as NULL checks can be left + * out. Sourced file without path in the 'scriptFile' is possible during + * Tcl initialization. + */ + + if (iPtr->evalFlags & TCL_EVAL_CTX) { + /* Path information comes out of the context. */ + + eeFrame.type = TCL_LOCATION_SOURCE; + eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; + Tcl_IncrRefCount (eeFrame.data.eval.path); + } else if (iPtr->evalFlags & TCL_EVAL_FILE) { + /* Set up for a sourced file */ + + eeFrame.type = TCL_LOCATION_SOURCE; + + if (iPtr->scriptFile) { + /* Normalization here, to have the correct pwd. Should have + * negligible impact on performance, as the norm should have been + * done already by the 'source' invoking us, and it caches the + * result + */ + + Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile); + if (!norm) { + /* Error message in the interp result */ + return TCL_ERROR; + } + eeFrame.data.eval.path = norm; + Tcl_IncrRefCount (eeFrame.data.eval.path); + } else { + eeFrame.data.eval.path = Tcl_NewStringObj ("",-1); + } + } else { + /* Set up for plain eval */ + + eeFrame.type = TCL_LOCATION_EVAL; + eeFrame.data.eval.path = NULL; + } + + eeFrame.level = (iPtr->cmdFramePtr == NULL + ? 1 + : iPtr->cmdFramePtr->level + 1); + eeFrame.framePtr = iPtr->framePtr; + eeFrame.nextPtr = iPtr->cmdFramePtr; + eeFrame.nline = 0; + eeFrame.line = NULL; +#endif + iPtr->evalFlags = 0; do { if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) @@ -3676,7 +3870,27 @@ Tcl_EvalEx(interp, script, numBytes, flags) goto error; } +#ifdef TCL_TIP280 + /* + * TIP #280 Track lines. The parser may have skipped text till it + * found the command we are now at. We have count the lines in this + * block. + */ + + TclAdvanceLines (&line, p, parse.commandStart); +#endif + if (parse.numWords > 0) { +#ifdef TCL_TIP280 + /* + * TIP #280. Track lines within the words of the current + * command. + */ + + int wordLine = line; + CONST char* wordStart = parse.commandStart; +#endif + /* * Generate an array of objects for the words of the command. */ @@ -3687,11 +3901,45 @@ Tcl_EvalEx(interp, script, numBytes, flags) objv = (Tcl_Obj **) ckalloc((unsigned) (parse.numWords * sizeof (Tcl_Obj *))); } + +#ifdef TCL_TIP280 + eeFrame.nline = parse.numWords; + eeFrame.line = (int*) ckalloc((unsigned) + (parse.numWords * sizeof (int))); +#endif + for (objectsUsed = 0, tokenPtr = parse.tokenPtr; - objectsUsed < parse.numWords; - objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { + objectsUsed < parse.numWords; + objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { +#ifndef TCL_TIP280 code = Tcl_EvalTokensStandard(interp, tokenPtr+1, tokenPtr->numComponents); +#else + /* + * TIP #280. Track lines to current word. Save the + * information on a per-word basis, signaling dynamic words as + * needed. Make the information available to the recursively + * called evaluator as well, including the type of context + * (source vs. eval). + */ + + TclAdvanceLines (&wordLine, wordStart, tokenPtr->start); + wordStart = tokenPtr->start; + + eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr) + ? wordLine + : -1); + + if (eeFrame.type == TCL_LOCATION_SOURCE) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } + + code = EvalTokensStandard(interp, tokenPtr+1, + tokenPtr->numComponents, wordLine); + + iPtr->evalFlags = 0; +#endif + if (code == TCL_OK) { objv[objectsUsed] = Tcl_GetObjResult(interp); Tcl_IncrRefCount(objv[objectsUsed]); @@ -3702,12 +3950,36 @@ Tcl_EvalEx(interp, script, numBytes, flags) /* * Execute the command and free the objects for its words. + * + * TIP #280: Remember the command itself for 'info frame'. We + * shorten the visible command by one char to exclude the + * termination character, if necessary. Here is where we put our + * frame on the stack of frames too. _After_ the nested commands + * have been executed. */ +#ifdef TCL_TIP280 + eeFrame.cmd.str.cmd = parse.commandStart; + eeFrame.cmd.str.len = parse.commandSize; + + if (parse.term == parse.commandStart + parse.commandSize - 1) { + eeFrame.cmd.str.len --; + } + + iPtr->cmdFramePtr = &eeFrame; +#endif iPtr->numLevels++; code = TclEvalObjvInternal(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); iPtr->numLevels--; +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + + ckfree ((char*) eeFrame.line); + eeFrame.line = NULL; + eeFrame.nline = 0; +#endif + if (code != TCL_OK) { goto error; } @@ -3723,11 +3995,17 @@ Tcl_EvalEx(interp, script, numBytes, flags) /* * Advance to the next command in the script. + * + * TIP #280 Track Lines. Now we track how many lines were in the + * executed command. */ next = parse.commandStart + parse.commandSize; bytesLeft -= next - p; p = next; +#ifdef TCL_TIP280 + TclAdvanceLines (&line, parse.commandStart, p); +#endif Tcl_FreeParse(&parse); gotParse = 0; if (nested && (*parse.term == ']')) { @@ -3740,7 +4018,12 @@ Tcl_EvalEx(interp, script, numBytes, flags) iPtr->termOffset = (p - 1) - script; iPtr->varFramePtr = savedVarFramePtr; +#ifndef TCL_TIP280 return TCL_OK; +#else + code = TCL_OK; + goto cleanup_return; +#endif } } while (bytesLeft > 0); @@ -3755,7 +4038,12 @@ Tcl_EvalEx(interp, script, numBytes, flags) iPtr->termOffset = p - script; iPtr->varFramePtr = savedVarFramePtr; +#ifndef TCL_TIP280 return TCL_OK; +#else + code = TCL_OK; + goto cleanup_return; +#endif error: /* @@ -3812,7 +4100,11 @@ Tcl_EvalEx(interp, script, numBytes, flags) if (!nested) { iPtr->termOffset = p - script; +#ifndef TCL_TIP280 return code; +#else + goto cleanup_return; +#endif } /* @@ -3840,7 +4132,11 @@ Tcl_EvalEx(interp, script, numBytes, flags) } else { iPtr->termOffset = (next - 1) - script; } +#ifndef TCL_TIP280 return code; +#else + goto cleanup_return; +#endif } next = parse.commandStart + parse.commandSize; bytesLeft -= next - p; @@ -3863,7 +4159,12 @@ Tcl_EvalEx(interp, script, numBytes, flags) iPtr->termOffset = parse.term - script; Tcl_SetObjResult(interp, Tcl_NewStringObj("missing close-bracket", -1)); +#ifndef TCL_TIP280 return TCL_ERROR; +#else + code = TCL_ERROR; + goto cleanup_return; +#endif } else if (*parse.term != ']') { /* * There was no close-bracket. Syntax error. @@ -3872,16 +4173,67 @@ Tcl_EvalEx(interp, script, numBytes, flags) iPtr->termOffset = (parse.term + 1) - script; Tcl_SetObjResult(interp, Tcl_NewStringObj("missing close-bracket", -1)); +#ifndef TCL_TIP280 return TCL_ERROR; +#else + code = TCL_ERROR; + goto cleanup_return; +#endif } else { /* * parse.term points to the close-bracket. */ iPtr->termOffset = parse.term - script; } + +#ifdef TCL_TIP280 + cleanup_return: + /* TIP #280. Release the local CmdFrame, and its contents. */ + + if (eeFrame.line != NULL) { + ckfree ((char*) eeFrame.line); + } + if (eeFrame.type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eeFrame.data.eval.path); + } +#endif return code; } +#ifdef TCL_TIP280 +/* + *---------------------------------------------------------------------- + * + * TclAdvanceLines -- + * + * This procedure is a helper which counts the number of lines + * in a block of text and advances an external counter. + * + * Results: + * None. + * + * Side effects: + * The specified counter is advanced per the number of lines found. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +void +TclAdvanceLines (line,start,end) + int* line; + CONST char* start; + CONST char* end; +{ + CONST char* p; + for (p = start; p < end; p++) { + if (*p == '\n') { + (*line) ++; + } + } +} +#endif + /* *---------------------------------------------------------------------- * @@ -3963,7 +4315,7 @@ Tcl_GlobalEvalObj(interp, objPtr) /* *---------------------------------------------------------------------- * - * Tcl_EvalObjEx -- + * Tcl_EvalObjEx, TclEvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT @@ -3983,6 +4335,7 @@ Tcl_GlobalEvalObj(interp, objPtr) * Just as in Tcl_Eval, interp->termOffset is set to the offset of the * last character executed in the objPtr's string. * + * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ @@ -3999,6 +4352,26 @@ Tcl_EvalObjEx(interp, objPtr, flags) * TCL_EVAL_GLOBAL and * TCL_EVAL_DIRECT. */ { +#ifdef TCL_TIP280 + return TclEvalObjEx (interp, objPtr, flags, NULL, 0); +} + +int +TclEvalObjEx(interp, objPtr, flags, invoker, word) + Tcl_Interp *interp; /* Token for command interpreter + * (returned by a previous call to + * Tcl_CreateInterp). */ + register Tcl_Obj *objPtr; /* Pointer to object containing + * commands to execute. */ + int flags; /* Collection of OR-ed bits that + * control the evaluation of the + * script. Supported values are + * TCL_EVAL_GLOBAL and + * TCL_EVAL_DIRECT. */ + CONST CmdFrame* invoker; /* Frame of the command doing the eval */ + int word; /* Index of the word which is in objPtr */ +{ +#endif register Interp *iPtr = (Interp *) interp; char *script; int numSrcBytes; @@ -4030,36 +4403,171 @@ Tcl_EvalObjEx(interp, objPtr, flags) register List *listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1; int i, objc = listRepPtr->elemCount; + #define TEOE_PREALLOC 10 Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv; +#ifdef TCL_TIP280 + /* TIP #280 Structures for tracking lines. + * As we know that this is dynamic execution we ignore the + * invoker, even if known. + */ + int line; + CmdFrame eoFrame; + + eoFrame.type = TCL_LOCATION_EVAL_LIST; + eoFrame.level = (iPtr->cmdFramePtr == NULL ? + 1 : + iPtr->cmdFramePtr->level + 1); + eoFrame.framePtr = iPtr->framePtr; + eoFrame.nextPtr = iPtr->cmdFramePtr; + eoFrame.nline = objc; + eoFrame.line = (int*) ckalloc (objc * sizeof (int)); + + /* NOTE: Getting the string rep of the list to eval to fill the + * command information required by 'info frame' implies that + * further calls for the same list would not be optimized, as it + * would not be 'pure' anymore. It would also be a waste of time + * as most of the time this information is not needed at all. What + * we do instead is to keep the list obj itself around and have + * 'info frame' sort it out. + */ + + eoFrame.cmd.listPtr = objPtr; + Tcl_IncrRefCount (eoFrame.cmd.listPtr); + eoFrame.data.eval.path = NULL; +#endif if (objc > TEOE_PREALLOC) { objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *)); } #undef TEOE_PREALLOC /* - * Copy the list elements here, to avoid a segfault if objPtr - * loses its List internal rep [Bug 1119369] + * Copy the list elements here, to avoid a segfault if + * objPtr loses its List internal rep [Bug 1119369]. + * + * TIP #280 Computes all the line numbers for the + * words in the command. */ - + +#ifdef TCL_TIP280 + line = 1; +#endif for (i=0; i < objc; i++) { objv[i] = listRepPtr->elements[i]; Tcl_IncrRefCount(objv[i]); +#ifdef TCL_TIP280 + eoFrame.line [i] = line; + { + char* w = Tcl_GetString (objv [i]); + TclAdvanceLines (&line, w, w+ strlen(w)); + } +#endif } + +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = &eoFrame; +#endif result = Tcl_EvalObjv(interp, objc, objv, flags); +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount (eoFrame.cmd.listPtr); +#endif + for (i=0; i < objc; i++) { TclDecrRefCount(objv[i]); } if (objv != staticObjv) { ckfree((char *) objv); } +#ifdef TCL_TIP280 + ckfree ((char*) eoFrame.line); + eoFrame.line = NULL; + eoFrame.nline = 0; +#endif } else { +#ifndef TCL_TIP280 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); +#else + /* + * TIP #280. Propagate context as much as we can. Especially if + * the script to evaluate is a single literal it makes sense to + * look if our context is one with absolute line numbers we can + * then track into the literal itself too. + * + * See also tclCompile.c, TclInitCompileEnv, for the equivalent + * code in the bytecode compiler. + */ + + if (invoker == NULL) { + /* No context, force opening of our own */ + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } else { + /* We have an invoker, describing the command asking for the + * evaluation of a subordinate script. This script may + * originate in a literal word, or from a variable, etc. Using + * the line array we now check if we have good line + * information for the relevant word. The type of context is + * relevant as well. In a non-'source' context we don't have + * to try tracking lines. + * + * First see if the word exists and is a literal. If not we go + * through the easy dynamic branch. No need to perform more + * complex invokations. + */ + + if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + /* Dynamic script, or dynamic context, force our own + * context */ + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + + } else { + /* Try to get an absolute context for the evaluation + */ + + CmdFrame ctx = *invoker; + int pc = 0; + + if (invoker->type == TCL_LOCATION_BC) { + /* Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + TclGetSrcInfoForPc (&ctx); + pc = 1; + } + + if (ctx.type == TCL_LOCATION_SOURCE) { + /* Absolute context to reuse. */ + + iPtr->invokeCmdFramePtr = &ctx; + iPtr->evalFlags |= TCL_EVAL_CTX; + + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]); + + if (pc) { + /* Death of SrcInfo reference */ + Tcl_DecrRefCount (ctx.data.eval.path); + } + } else { + /* Dynamic context or script, easier to make our own as + * well */ + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + } + } + } +#endif } } else { /* * Let the compiler/engine subsystem do the evaluation. + * + * TIP #280 The invoker provides us with the context for the + * script. We transfer this to the byte code compiler. */ savedVarFramePtr = iPtr->varFramePtr; @@ -4067,7 +4575,11 @@ Tcl_EvalObjEx(interp, objPtr, flags) iPtr->varFramePtr = NULL; } +#ifndef TCL_TIP280 result = TclCompEvalObj(interp, objPtr); +#else + result = TclCompEvalObj(interp, objPtr, invoker, word); +#endif /* * If we are again at the top level, process any unusual @@ -5570,4 +6082,12 @@ Tcl_GetVersion(majorV, minorV, patchLevelV, type) *type = TCL_RELEASE_LEVEL; } } - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c3402ef..6621714 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.27.2.15 2005/10/23 22:01:29 msofer Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -235,6 +235,9 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) { Tcl_Obj *varNamePtr = NULL; int result; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?"); @@ -245,7 +248,12 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) varNamePtr = objv[2]; } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[1], 0); +#else + /* TIP #280. Make invoking context available to caught script */ + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1); +#endif if (objc == 3) { if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, @@ -592,6 +600,9 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) { int result; register Tcl_Obj *objPtr; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); @@ -599,7 +610,13 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } if (objc == 2) { +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); +#else + /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, + iPtr->cmdFramePtr,1); +#endif } else { /* * More than one argument: concatenate them together with spaces @@ -607,7 +624,12 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) * the object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-1, objv+1); +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); +#else + /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); +#endif } if (result == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; @@ -1607,13 +1629,21 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[1], 0); +#else + /* TIP #280. Make invoking context available to initial script */ + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1); +#endif if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); @@ -1635,7 +1665,12 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) if (!value) { break; } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[4], 0); +#else + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4); +#endif if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; @@ -1645,7 +1680,12 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) } break; } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[3], 0); +#else + /* TIP #280. Make invoking context available to next script */ + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3); +#endif if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { @@ -1719,6 +1759,9 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */ int *argcList = argcListArray; /* Array of value list sizes */ Tcl_Obj ***argvList = argvListArray; /* Array of value lists */ +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1848,7 +1891,12 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, bodyPtr, 0); +#else + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1); +#endif if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; @@ -2394,3 +2442,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a867272..d44ba7a 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -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: tclCmdIL.c,v 1.47.2.9 2005/12/09 14:39:25 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.10 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -109,6 +109,12 @@ static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +#ifdef TCL_TIP280 +/* TIP #280 - New 'info' subcommand 'frame' */ +static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +#endif static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -188,6 +194,9 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int thenScriptIndex = 0; /* then script to be evaled after syntax check */ +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif int i, result, value; char *clause; i = 1; @@ -240,7 +249,13 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) i++; if (i >= objc) { if (thenScriptIndex) { +#ifndef TCL_TIP280 return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); +#else + /* TIP #280. Make invoking context available to branch */ + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr,thenScriptIndex); +#endif } return TCL_OK; } @@ -274,9 +289,19 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if (thenScriptIndex) { +#ifndef TCL_TIP280 return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); +#else + /* TIP #280. Make invoking context available to branch/else */ + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr,thenScriptIndex); +#endif } +#ifndef TCL_TIP280 return Tcl_EvalObjEx(interp, objv[i], 0); +#else + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i); +#endif } /* @@ -397,16 +422,24 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *subCmds[] = { - "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", + "args", "body", "cmdcount", "commands", + "complete", "default", "exists", +#ifdef TCL_TIP280 + "frame", +#endif + "functions", + "globals", "hostname", "level", "library", "loaded", "locals", "nameofexecutable", "patchlevel", "procs", "script", "sharedlibextension", "tclversion", "vars", (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, - ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, - IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, + ICompleteIdx, IDefaultIdx, IExistsIdx, +#ifdef TCL_TIP280 + IFrameIdx, +#endif + IFunctionsIdx, + IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx }; @@ -445,6 +478,12 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case IExistsIdx: result = InfoExistsCmd(clientData, interp, objc, objv); break; +#ifdef TCL_TIP280 + case IFrameIdx: + /* TIP #280 - New method 'frame' */ + result = InfoFrameCmd(clientData, interp, objc, objv); + break; +#endif case IFunctionsIdx: result = InfoFunctionsCmd(clientData, interp, objc, objv); break; @@ -997,6 +1036,243 @@ InfoExistsCmd(dummy, interp, objc, objv) return TCL_OK; } +#ifdef TCL_TIP280 +/* + *---------------------------------------------------------------------- + * + * InfoFrameCmd -- + * TIP #280 + * + * Called to implement the "info frame" command that returns the + * location of either the currently executing command, or its caller. + * Handles the following syntax: + * + * info frame ?number? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is + * an error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoFrameCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + + if (objc == 2) { + /* just "info frame" */ + int levels = (iPtr->cmdFramePtr == NULL + ? 0 + : iPtr->cmdFramePtr->level); + + Tcl_SetIntObj(Tcl_GetObjResult(interp), levels); + return TCL_OK; + + } else if (objc == 3) { + /* "info frame level" */ + int level; + CmdFrame *framePtr; + + if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level <= 0) { + /* Relative adressing */ + + if (iPtr->cmdFramePtr == NULL) { + levelError: + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad level \"", + Tcl_GetString(objv[2]), + "\"", (char *) NULL); + return TCL_ERROR; + } + /* Convert to absolute. */ + + level += iPtr->cmdFramePtr->level; + } + for (framePtr = iPtr->cmdFramePtr; + framePtr != NULL; + framePtr = framePtr->nextPtr) { + + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + + /* + * Pull the information and construct the dictionary to return, as + * list. Regarding use of the CmdFrame fields see tclInt.h, and its + * definition. + */ + + { + Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */ + int lc = 0; + + /* This array is indexed by the TCL_LOCATION_... values, except + * for _LAST. + */ + + static CONST char* typeString [TCL_LOCATION_LAST] = { + "eval", "eval", "eval", "precompiled", "source", "proc" + }; + + switch (framePtr->type) { + case TCL_LOCATION_EVAL: + /* Evaluation, dynamic script. Type, line, cmd, the latter + * through str. */ + + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, + framePtr->cmd.str.len); + break; + + case TCL_LOCATION_EVAL_LIST: + /* List optimized evaluation. Type, line, cmd, the latter + * through listPtr, possibly a frame. */ + + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); + + /* We put a duplicate of the command list obj into the result + * to ensure that the 'pure List'-property of the command + * itself is not destroyed. Otherwise the query here would + * disable the list optimization path in Tcl_EvalObjEx. + */ + + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr); + break; + + case TCL_LOCATION_PREBC: + /* Precompiled. Result contains the type as signal, nothing + * else */ + + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + break; + + case TCL_LOCATION_BC: { + /* Execution of bytecode. Talk to the BC engine to fill out + * the frame. */ + + CmdFrame f = *framePtr; + Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL; + + /* Note: Type BC => f.data.eval.path is not used. + * f.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc (&f); + /* Now filled: cmd.str.(cmd,len), line */ + /* Possibly modified: type, path! */ + + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (f.line[0]); + + if (f.type == TCL_LOCATION_SOURCE) { + lv [lc ++] = Tcl_NewStringObj ("file",-1); + lv [lc ++] = f.data.eval.path; + /* Death of reference by TclGetSrcInfoForPc */ + Tcl_DecrRefCount (f.data.eval.path); + } + + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len); + + if (procPtr != NULL) { + Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr; + char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr); + char* nsName = procPtr->cmdPtr->nsPtr->fullName; + + lv [lc ++] = Tcl_NewStringObj ("proc",-1); + lv [lc ++] = Tcl_NewStringObj (nsName,-1); + + if (strcmp (nsName, "::") != 0) { + Tcl_AppendToObj (lv [lc-1], "::", -1); + } + Tcl_AppendToObj (lv [lc-1], procName, -1); + } + break; + } + + case TCL_LOCATION_SOURCE: + /* Evaluation of a script file */ + + lv [lc ++] = Tcl_NewStringObj ("type",-1); + lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1); + lv [lc ++] = Tcl_NewStringObj ("line",-1); + lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]); + lv [lc ++] = Tcl_NewStringObj ("file",-1); + lv [lc ++] = framePtr->data.eval.path; + /* Refcount framePtr->data.eval.path goes up when lv + * is converted into the result list object. + */ + lv [lc ++] = Tcl_NewStringObj ("cmd",-1); + lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd, + framePtr->cmd.str.len); + break; + + case TCL_LOCATION_PROC: + Tcl_Panic ("TCL_LOCATION_PROC found in standard frame"); + break; + } + + + /* 'level'. Common to all frame types. Conditional on having an + * associated _visible_ CallFrame */ + + if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) { + CallFrame* current = framePtr->framePtr; + CallFrame* top = iPtr->varFramePtr; + CallFrame* idx; + + for (idx = top; + idx != NULL; + idx = idx->callerVarPtr) { + if (idx == current) { + int c = framePtr->framePtr->level; + int t = iPtr->varFramePtr->level; + + lv [lc ++] = Tcl_NewStringObj ("level",-1); + lv [lc ++] = Tcl_NewIntObj (t - c); + break; + } + } + } + + Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv)); + return TCL_OK; + } + } + + Tcl_WrongNumArgs(interp, 2, objv, "?number?"); + + return TCL_ERROR; +} +#endif + /* *---------------------------------------------------------------------- * @@ -3993,3 +4269,12 @@ DictionaryCompare(left, right) } return diff; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1613799..d4a8732 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.82.2.26 2006/04/11 14:37:04 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.27 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -138,6 +138,10 @@ static void TraceCommandProc _ANSI_ARGS_((ClientData clientData, CONST char *newName, int flags)); static Tcl_CmdObjTraceProc TraceExecutionProc; +#ifdef TCL_TIP280 +static void ListLines _ANSI_ARGS_((CONST char* listStr, int line, + int n, int* lines)); +#endif /* *---------------------------------------------------------------------- * @@ -2729,6 +2733,15 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) char *string, *pattern; Tcl_Obj *stringObj; Tcl_Obj *CONST *savedObjv = objv; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; + int pc = 0; + int bidx = 0; /* Index of body argument */ + Tcl_Obj* blist = NULL; /* List obj which is the body */ + CmdFrame ctx; /* Copy of the topmost cmdframe, + * to allow us to mess with the + * line information */ +#endif static CONST char *options[] = { "-exact", "-glob", "-regexp", "--", NULL @@ -2763,16 +2776,25 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) stringObj = objv[i]; objc -= i + 1; objv += i + 1; +#ifdef TCL_TIP280 + bidx = i+1; /* First after the match string */ +#endif /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. + * + * TIP #280: Determine the lines the words in the list start at, based on + * the same data for the list word itself. The cmdFramePtr line information + * is manipulated directly. */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - +#ifdef TCL_TIP280 + blist = objv[0]; +#endif if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -2871,8 +2893,58 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) /* * We've got a match. Find a body to execute, skipping bodies * that are "-". + * + * TIP#280: Now is also the time to determine a line number for the + * single-word case. */ +#ifdef TCL_TIP280 + ctx = *iPtr->cmdFramePtr; + + if (splitObjs) { + /* We have to perform the GetSrc and other type dependent handling + * of the frame here because we are munging with the line numbers, + * something the other commands like if, etc. are not doing. Them + * are fine with simply passing the CmdFrame through and having + * the special handling done in 'info frame', or the bc compiler + */ + + if (ctx.type == TCL_LOCATION_BC) { + /* Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + TclGetSrcInfoForPc (&ctx); + pc = 1; + /* The line information in the cmdFrame is now a copy we do + * not own */ + } + + if (ctx.type == TCL_LOCATION_SOURCE) { + int bline = ctx.line [bidx]; + if (bline >= 0) { + ctx.line = (int*) ckalloc (objc * sizeof(int)); + ctx.nline = objc; + + ListLines (Tcl_GetString (blist), bline, objc, ctx.line); + } else { + int k; + /* Dynamic code word ... All elements are relative to themselves */ + + ctx.line = (int*) ckalloc (objc * sizeof(int)); + ctx.nline = objc; + for (k=0; k < objc; k++) {ctx.line[k] = -1;} + } + } else { + int k; + /* Anything else ... No information, or dynamic ... */ + + ctx.line = (int*) ckalloc (objc * sizeof(int)); + ctx.nline = objc; + for (k=0; k < objc; k++) {ctx.line[k] = -1;} + } + } +#endif + for (j = i + 1; ; j += 2) { if (j >= objc) { /* @@ -2885,7 +2957,19 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) break; } } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[j], 0); +#else + /* TIP #280. Make invoking context available to switch branch */ + result = TclEvalObjEx(interp, objv[j], 0, &ctx, j); + if (splitObjs) { + ckfree ((char*) ctx.line); + if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { + /* Death of SrcInfo reference */ + Tcl_DecrRefCount (ctx.data.eval.path); + } + } +#endif if (result == TCL_ERROR) { char msg[100 + TCL_INTEGER_SPACE]; @@ -4860,6 +4944,9 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); @@ -4874,7 +4961,12 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) if (!value) { break; } +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[2], 0); +#else + /* TIP #280. */ + result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2); +#endif if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { char msg[32 + TCL_INTEGER_SPACE]; @@ -4894,4 +4986,45 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) } return result; } + +#ifdef TCL_TIP280 +static void +ListLines(listStr, line, n, lines) + CONST char* listStr; /* Pointer to string with list structure. + * Assumed to be valid. Assumed to contain + * n elements. + */ + int line; /* line the list as a whole starts on */ + int n; /* #elements in lines */ + int* lines; /* Array of line numbers, to fill */ +{ + int i; + int length = strlen( listStr); + CONST char *element = NULL; + CONST char* next = NULL; + + for (i = 0; i < n; i++) { + TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); + + TclAdvanceLines (&line, listStr, element); /* Leading whitespace */ + lines [i] = line; + length -= (next - listStr); + TclAdvanceLines (&line, element, next); /* Element */ + listStr = next; + + if (*element == 0) { + /* ASSERT i == n */ + break; + } + } +} +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 300feb2..0737ab2 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.39.2.3 2005/03/18 15:32:29 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.39.2.4 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -23,9 +23,16 @@ static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData)); +#ifndef TCL_TIP280 static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr)); +#else +static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, + int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr, + int line)); +#endif /* * Flags bits used by TclPushVarName. @@ -78,6 +85,16 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) int simpleVarName, isScalar, localIndex, numWords; int code = TCL_OK; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + numWords = parsePtr->numWords; if (numWords == 1) { Tcl_ResetResult(interp); @@ -109,7 +126,12 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) + (parsePtr->tokenPtr->numComponents + 1); code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, +#ifndef TCL_TIP280 &localIndex, &simpleVarName, &isScalar); +#else + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); +#endif if (code != TCL_OK) { goto done; } @@ -126,6 +148,9 @@ TclCompileAppendCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif code = TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -246,6 +271,16 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) int code; int savedStackDepth = envPtr->currStackDepth; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -308,6 +343,9 @@ TclCompileCatchCmd(interp, parsePtr, envPtr) * errors in the substitution are not catched [Bug 219184] */ +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [1]; +#endif if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { startOffset = (envPtr->codeNext - envPtr->codeStart); code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr); @@ -462,6 +500,11 @@ TclCompileExprCmd(interp, parsePtr, envPtr) return TCL_ERROR; } +#ifdef TCL_TIP280 + /* TIP #280 : Use the per-word line information of the current command. + */ + envPtr->line = envPtr->extCmdMapPtr->loc [envPtr->extCmdMapPtr->nuloc - 1].line [1]; +#endif firstWordPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), @@ -500,6 +543,16 @@ TclCompileForCmd(interp, parsePtr, envPtr) char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + if (parsePtr->numWords != 5) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -548,6 +601,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) * Inline compile the initial command. */ +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [1]; +#endif code = TclCompileCmdWord(interp, startTokenPtr+1, startTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -579,6 +635,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [4]; +#endif code = TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); envPtr->currStackDepth = savedStackDepth + 1; @@ -601,6 +660,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) nextCodeOffset = (envPtr->codeNext - envPtr->codeStart); +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [3]; +#endif envPtr->currStackDepth = savedStackDepth; code = TclCompileCmdWord(interp, nextTokenPtr+1, nextTokenPtr->numComponents, envPtr); @@ -631,7 +693,9 @@ TclCompileForCmd(interp, parsePtr, envPtr) nextCodeOffset += 3; testCodeOffset += 3; } - +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif envPtr->currStackDepth = savedStackDepth; code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (code != TCL_OK) { @@ -722,6 +786,17 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) char buffer[32 + TCL_INTEGER_SPACE]; int savedStackDepth = envPtr->currStackDepth; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; + int bodyIndex; +#endif + /* * We parse the variable list argument words and create two arrays: * varcList[i] is number of variables in i-th var list @@ -763,6 +838,9 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_OUT_LINE_COMPILE; } +#ifdef TCL_TIP280 + bodyIndex = i-1; +#endif /* * Allocate storage for the varcList and varvList arrays if necessary. @@ -886,6 +964,9 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) i < numWords-1; i++, tokenPtr += (tokenPtr->numComponents + 1)) { if ((i%2 == 0) && (i > 0)) { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif code = TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -923,6 +1004,9 @@ TclCompileForeachCmd(interp, parsePtr, envPtr) * Inline compile the loop body. */ +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [bodyIndex]; +#endif envPtr->exceptArrayPtr[range].codeOffset = (envPtr->codeNext - envPtr->codeStart); code = TclCompileCmdWord(interp, bodyTokenPtr+1, @@ -1152,6 +1236,16 @@ TclCompileIfCmd(interp, parsePtr, envPtr) int boolVal; /* value of static condition */ int compileScripts = 1; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + /* * Only compile the "if" command if all arguments are simple * words, in order to insure correct substitution [Bug 219166] @@ -1233,6 +1327,9 @@ TclCompileIfCmd(interp, parsePtr, envPtr) } } else { Tcl_ResetResult(interp); +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx]; +#endif code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (code != TCL_OK) { if (code == TCL_ERROR) { @@ -1289,6 +1386,9 @@ TclCompileIfCmd(interp, parsePtr, envPtr) */ if (compileScripts) { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx]; +#endif envPtr->currStackDepth = savedStackDepth; code = TclCompileCmdWord(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); @@ -1391,7 +1491,9 @@ TclCompileIfCmd(interp, parsePtr, envPtr) /* * Compile the else command body. */ - +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx]; +#endif code = TclCompileCmdWord(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -1503,6 +1605,16 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) int simpleVarName, isScalar, localIndex, haveImmValue, immValue; int code = TCL_OK; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -1515,7 +1627,12 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) code = TclPushVarName(interp, varTokenPtr, envPtr, (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR), +#ifndef TCL_TIP280 &localIndex, &simpleVarName, &isScalar); +#else + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); +#endif if (code != TCL_OK) { goto done; } @@ -1555,6 +1672,9 @@ TclCompileIncrCmd(interp, parsePtr, envPtr) TclRegisterNewLiteral(envPtr, word, numBytes), envPtr); } } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif code = TclCompileTokens(interp, incrTokenPtr+1, incrTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -1647,6 +1767,16 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) int simpleVarName, isScalar, localIndex, numWords; int code = TCL_OK; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + /* * If we're not in a procedure, don't compile. */ @@ -1680,7 +1810,12 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) + (parsePtr->tokenPtr->numComponents + 1); code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, +#ifndef TCL_TIP280 &localIndex, &simpleVarName, &isScalar); +#else + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); +#endif if (code != TCL_OK) { goto done; } @@ -1696,6 +1831,9 @@ TclCompileLappendCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif code = TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -1773,6 +1911,16 @@ TclCompileLindexCmd(interp, parsePtr, envPtr) Tcl_Token *varTokenPtr; int code, i; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + int numWords; numWords = parsePtr->numWords; @@ -1797,6 +1945,9 @@ TclCompileLindexCmd(interp, parsePtr, envPtr) TclRegisterNewLiteral( envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -1850,6 +2001,16 @@ TclCompileListCmd(interp, parsePtr, envPtr) * command created by Tcl_ParseCommand. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + /* * If we're not in a procedure, don't compile. */ @@ -1879,6 +2040,9 @@ TclCompileListCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif code = TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -1924,6 +2088,16 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr) Tcl_Token *varTokenPtr; int code; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + if (parsePtr->numWords != 2) { Tcl_SetResult(interp, "wrong # args: should be \"llength list\"", TCL_STATIC); @@ -1940,6 +2114,9 @@ TclCompileLlengthCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [1]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2015,6 +2192,16 @@ TclCompileLsetCmd( interp, parsePtr, envPtr ) int i; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + /* Check argument count */ if ( parsePtr->numWords < 3 ) { @@ -2033,7 +2220,12 @@ TclCompileLsetCmd( interp, parsePtr, envPtr ) varTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); result = TclPushVarName( interp, varTokenPtr, envPtr, +#ifndef TCL_TIP280 TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar ); +#else + TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); +#endif if (result != TCL_OK) { return result; } @@ -2052,6 +2244,9 @@ TclCompileLsetCmd( interp, parsePtr, envPtr ) TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif result = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if ( result != TCL_OK ) { @@ -2182,6 +2377,16 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr) int i, len, code, nocase, anchorLeft, anchorRight, start; char *str; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + /* * We are only interested in compiling simple regexp cases. * Currently supported compile cases are: @@ -2329,6 +2534,9 @@ TclCompileRegexpCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [parsePtr->numWords-1]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2379,6 +2587,16 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) int code; int index = envPtr->exceptArrayNext - 1; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + /* * If we're not in a procedure, don't compile. */ @@ -2436,6 +2654,9 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) * "return" will be byte-compiled; otherwise it will be * out line compiled. */ +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [1]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2496,6 +2717,16 @@ TclCompileSetCmd(interp, parsePtr, envPtr) int isAssignment, isScalar, simpleVarName, localIndex, numWords; int code = TCL_OK; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { Tcl_ResetResult(interp); @@ -2517,7 +2748,12 @@ TclCompileSetCmd(interp, parsePtr, envPtr) + (parsePtr->tokenPtr->numComponents + 1); code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, +#ifndef TCL_TIP280 &localIndex, &simpleVarName, &isScalar); +#else + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); +#endif if (code != TCL_OK) { goto done; } @@ -2532,6 +2768,9 @@ TclCompileSetCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif code = TclCompileTokens(interp, valueTokenPtr+1, valueTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2634,6 +2873,16 @@ TclCompileStringCmd(interp, parsePtr, envPtr) STR_WORDEND, STR_WORDSTART }; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + if (parsePtr->numWords < 2) { /* Fail at run time, not in compilation */ return TCL_OUT_LINE_COMPILE; @@ -2695,6 +2944,9 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2725,6 +2977,9 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start, varTokenPtr[1].size), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2755,6 +3010,9 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr); return TCL_OK; } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2812,6 +3070,9 @@ TclCompileStringCmd(interp, parsePtr, envPtr) TclEmitPush( TclRegisterNewLiteral(envPtr, str, length), envPtr); } else { +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [i]; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -2928,6 +3189,16 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) Tcl_Obj *boolObj; int boolVal; +#ifdef TCL_TIP280 + /* TIP #280 : Remember the per-word line information of the current + * command. An index is used instead of a pointer as recursive compilation + * may reallocate, i.e. move, the array. This is also the reason to save + * the nuloc now, it may change during the course of the function. + */ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; + int eclIndex = mapPtr->nuloc - 1; +#endif + if (parsePtr->numWords != 3) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), @@ -3013,6 +3284,9 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) * Compile the loop body. */ +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [2]; +#endif bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart); code = TclCompileCmdWord(interp, bodyTokenPtr+1, bodyTokenPtr->numComponents, envPtr); @@ -3042,6 +3316,9 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; +#ifdef TCL_TIP280 + envPtr->line = mapPtr->loc [eclIndex].line [1]; +#endif code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (code != TCL_OK) { if (code == TCL_ERROR) { @@ -3114,7 +3391,11 @@ TclCompileWhileCmd(interp, parsePtr, envPtr) static int TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, +#ifndef TCL_TIP280 simpleVarNamePtr, isScalarPtr) +#else + simpleVarNamePtr, isScalarPtr, line) +#endif Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Token *varTokenPtr; /* Points to a variable token. */ CompileEnv *envPtr; /* Holds resulting instructions. */ @@ -3123,6 +3404,9 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, int *localIndexPtr; /* must not be NULL */ int *simpleVarNamePtr; /* must not be NULL */ int *isScalarPtr; /* must not be NULL */ +#ifdef TCL_TIP280 + int line; /* line the token starts on */ +#endif { register CONST char *p; CONST char *name, *elName; @@ -3304,6 +3588,9 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, if (elName != NULL) { if (elNameChars) { +#ifdef TCL_TIP280 + envPtr->line = line; +#endif code = TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); if (code != TCL_OK) { @@ -3318,6 +3605,9 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, * The var name isn't simple: compile and push it. */ +#ifdef TCL_TIP280 + envPtr->line = line; +#endif code = TclCompileTokens(interp, varTokenPtr+1, varTokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -3337,3 +3627,12 @@ TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr, *isScalarPtr = (elName == NULL); return code; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index bedf35d..3ff749b 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -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: tclCompExpr.c,v 1.13.2.2 2005/11/27 02:34:41 das Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.13.2.3 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -258,6 +258,11 @@ TclCompileExpr(interp, script, numBytes, envPtr) goto done; } +#ifdef TCL_TIP280 + /* TIP #280 : Track Lines within the expression */ + TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start); +#endif + code = CompileSubExpr(parse.tokenPtr, &info, envPtr); if (code != TCL_OK) { Tcl_FreeParse(&parse); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 88f029c..4a6fac5 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.43.2.6 2004/06/08 19:45:26 msofer Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.43.2.7 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -301,6 +301,16 @@ static void RecordByteCodeStats _ANSI_ARGS_(( static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); +#ifdef TCL_TIP280 +/* TIP #280 : Helper for building the per-word line information of all + * compiled commands */ +static void EnterCmdWordData _ANSI_ARGS_(( + ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr, + CONST char* cmd, int len, int numWords, int line, + int** lines)); +#endif + + /* * The structure below defines the bytecode Tcl object type by * means of procedures that can be invoked by generic object code. @@ -374,7 +384,19 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) nested = 0; } string = Tcl_GetStringFromObj(objPtr, &length); +#ifndef TCL_TIP280 TclInitCompileEnv(interp, &compEnv, string, length); +#else + /* + * TIP #280. Pick up the CmdFrame in which the BC compiler was invoked + * and use to initialize the tracking in the compiler. This information + * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc + * (tclProc.c). + */ + + TclInitCompileEnv(interp, &compEnv, string, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); +#endif result = TclCompileScript(interp, string, length, nested, &compEnv); if (result == TCL_OK) { @@ -566,6 +588,9 @@ TclCleanupByteCode(codePtr) register ByteCode *codePtr; /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; register Tcl_Obj **objArrayPtr; @@ -663,6 +688,38 @@ TclCleanupByteCode(codePtr) auxDataPtr++; } +#ifdef TCL_TIP280 + /* + * TIP #280. Release the location data associated with this byte code + * structure, if any. NOTE: The interp we belong to may be gone already, + * and the data with it. + * + * See also tclBasic.c, DeleteInterpProc + */ + + if (iPtr) { + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + int i; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree ((char*) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree ((char*) eclPtr->loc); + } + + ckfree ((char*) eclPtr); + Tcl_DeleteHashEntry (hePtr); + } + } +#endif + TclHandleRelease(codePtr->interpHandle); ckfree((char *) codePtr); } @@ -685,13 +742,22 @@ TclCleanupByteCode(codePtr) */ void +#ifndef TCL_TIP280 TclInitCompileEnv(interp, envPtr, string, numBytes) +#else +TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) +#endif Tcl_Interp *interp; /* The interpreter for which a CompileEnv * structure is initialized. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure to * initialize. */ char *string; /* The source string to be compiled. */ int numBytes; /* Number of bytes in source string. */ +#ifdef TCL_TIP280 + CONST CmdFrame* invoker; /* Location context invoking the bcc */ + int word; /* Index of the word in that context + * getting compiled */ +#endif { Interp *iPtr = (Interp *) interp; @@ -724,7 +790,74 @@ TclInitCompileEnv(interp, envPtr, string, numBytes) envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; - + +#ifdef TCL_TIP280 + /* + * TIP #280: Set up the extended command location information, based on + * the context invoking the byte code compiler. This structure is used to + * keep the per-word line information for all compiled commands. + * + * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the + * non-compiling evaluator + */ + + envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc)); + envPtr->extCmdMapPtr->loc = NULL; + envPtr->extCmdMapPtr->nloc = 0; + envPtr->extCmdMapPtr->nuloc = 0; + envPtr->extCmdMapPtr->path = NULL; + + if (invoker == NULL) { + /* Initialize the compiler for relative counting */ + + envPtr->line = 1; + envPtr->extCmdMapPtr->type = (envPtr->procPtr + ? TCL_LOCATION_PROC + : TCL_LOCATION_BC); + } else { + /* Initialize the compiler using the context, making counting absolute + * to that context. Note that the context can be byte code + * execution. In that case we have to fill out the missing pieces + * (line, path, ...). Which may make change the type as well. + */ + + if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + /* Word is not a literal, relative counting */ + + envPtr->line = 1; + envPtr->extCmdMapPtr->type = (envPtr->procPtr + ? TCL_LOCATION_PROC + : TCL_LOCATION_BC); + } else { + CmdFrame ctx = *invoker; + int pc = 0; + + if (invoker->type == TCL_LOCATION_BC) { + /* Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + TclGetSrcInfoForPc (&ctx); + pc = 1; + } + + envPtr->line = ctx.line [word]; + envPtr->extCmdMapPtr->type = ctx.type; + + if (ctx.type == TCL_LOCATION_SOURCE) { + if (pc) { + /* The reference 'TclGetSrcInfoForPc' made is transfered */ + envPtr->extCmdMapPtr->path = ctx.data.eval.path; + ctx.data.eval.path = NULL; + } else { + /* We have a new reference here */ + envPtr->extCmdMapPtr->path = ctx.data.eval.path; + Tcl_IncrRefCount (envPtr->extCmdMapPtr->path); + } + } + } + } +#endif + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; @@ -774,6 +907,54 @@ TclFreeCompileEnv(envPtr) } } +#ifdef TCL_TIP280 +/* + *---------------------------------------------------------------------- + * + * TclWordKnownAtCompileTime -- + * + * Test whether the value of a token is completely known at compile time. + * + * Results: + * Returns true if the tokenPtr argument points to a word value that is + * completely known at compile time. Generally, values that are known at + * compile time can be compiled to their values, while values that cannot + * be known until substitution at runtime must be compiled to bytecode + * instructions that perform that substitution. For several commands, + * whether or not arguments are known at compile time determine whether + * it is worthwhile to compile at all. + * + * Side effects: + * None. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +int +TclWordKnownAtCompileTime (tokenPtr) + Tcl_Token* tokenPtr; +{ + int i; + Tcl_Token* sub; + + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;}; + if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;}; + + /* Check the sub tokens of the word. It is a literal if we find + * only BS and TEXT tokens */ + + for (i=0, sub = tokenPtr + 1; + i < tokenPtr->numComponents; + i++, sub ++) { + if (sub->type == TCL_TOKEN_TEXT) continue; + if (sub->type == TCL_TOKEN_BS) continue; + return 0; + } + return 1; +} +#endif + /* *---------------------------------------------------------------------- * @@ -828,6 +1009,13 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) int commandLength, objIndex, code; Tcl_DString ds; +#ifdef TCL_TIP280 + /* TIP #280 */ + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + int* wlines; + int wlineat, cmdLine; +#endif + Tcl_DStringInit(&ds); if (numBytes < 0) { @@ -844,6 +1032,10 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) p = script; bytesLeft = numBytes; gotParse = 0; +#ifdef TCL_TIP280 + cmdLine = envPtr->line; +#endif + do { if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { code = TCL_ERROR; @@ -952,10 +1144,28 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, (parse.commandStart - envPtr->source), startCodeOffset); - + +#ifdef TCL_TIP280 + /* TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + TclAdvanceLines (&cmdLine, p, parse.commandStart); + EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source), + parse.tokenPtr, parse.commandStart, parse.commandSize, + parse.numWords, cmdLine, &wlines); + wlineat = eclPtr->nuloc - 1; +#endif + for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { +#ifdef TCL_TIP280 + envPtr->line = eclPtr->loc [wlineat].line [wordIdx]; +#endif if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* * If this is the first word and the command has a @@ -1039,7 +1249,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) /* * The word is not a simple string of characters. */ - code = TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); if (code != TCL_OK) { @@ -1070,15 +1279,27 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; + +#ifdef TCL_TIP280 + /* TIP #280: Free full form of per-word line data and insert + * the reduced form now + */ + ckfree ((char*) eclPtr->loc [wlineat].line); + eclPtr->loc [wlineat].line = wlines; +#endif } /* end if parse.numWords > 0 */ /* * Advance to the next command in the script. */ - + next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; +#ifdef TCL_TIP280 + /* TIP #280 : Track lines in the just compiled command */ + TclAdvanceLines (&cmdLine, parse.commandStart, p); +#endif Tcl_FreeParse(&parse); gotParse = 0; if (nested && (*parse.term == ']')) { @@ -1551,6 +1772,9 @@ TclInitByteCodeObj(objPtr, envPtr) int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; int i; +#ifdef TCL_TIP280 + int new; +#endif Interp *iPtr; iPtr = envPtr->iPtr; @@ -1662,6 +1886,16 @@ TclInitByteCodeObj(objPtr, envPtr) } objPtr->internalRep.otherValuePtr = (VOID *) codePtr; objPtr->typePtr = &tclByteCodeType; + +#ifdef TCL_TIP280 + /* TIP #280. Associate the extended per-word line information with the + * byte code object (internal rep), for use with the bc compiler. + */ + + Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new), + envPtr->extCmdMapPtr); + envPtr->extCmdMapPtr = NULL; +#endif } /* @@ -2135,6 +2369,98 @@ EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) cmdLocPtr->numCodeBytes = numCodeBytes; } +#ifdef TCL_TIP280 +/* + *---------------------------------------------------------------------- + * TIP #280 + * + * EnterCmdWordData -- + * + * Registers the lines for the words of a command. This information + * is used at runtime by 'info frame'. + * + * Results: + * None. + * + * Side effects: + * Inserts word location information into the compilation + * environment envPtr for the command at index cmdIndex. The + * compilation environment's ExtCmdLoc.ECL array is grown if necessary. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines) + ExtCmdLoc *eclPtr; /* Points to the map environment + * structure in which to enter command + * location information. */ + int srcOffset; /* Offset of first char of the command. */ + Tcl_Token* tokenPtr; + CONST char* cmd; + int len; + int numWords; + int line; + int** wlines; +{ + ECL* ePtr; + int wordIdx; + CONST char* last; + int wordLine; + int* wwlines; + + if (eclPtr->nuloc >= eclPtr->nloc) { + /* + * Expand the ECL array by allocating more storage from the + * heap. The currently allocated ECL entries are stored from + * eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive). + */ + + size_t currElems = eclPtr->nloc; + size_t newElems = (currElems ? 2*currElems : 1); + size_t currBytes = currElems * sizeof(ECL); + size_t newBytes = newElems * sizeof(ECL); + ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes); + + /* + * Copy from old ECL array to new, free old ECL array if + * needed. + */ + + if (currBytes) { + memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes); + } + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + eclPtr->loc = (ECL *) newPtr; + eclPtr->nloc = newElems; + } + + ePtr = &eclPtr->loc [eclPtr->nuloc]; + ePtr->srcOffset = srcOffset; + ePtr->line = (int*) ckalloc (numWords * sizeof (int)); + ePtr->nline = numWords; + wwlines = (int*) ckalloc (numWords * sizeof (int)); + + last = cmd; + wordLine = line; + for (wordIdx = 0; + wordIdx < numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + TclAdvanceLines (&wordLine, last, tokenPtr->start); + wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr) + ? wordLine + : -1); + ePtr->line [wordIdx] = wordLine; + last = tokenPtr->start; + } + + *wlines = wwlines; + eclPtr->nuloc ++; +} +#endif + /* *---------------------------------------------------------------------- * @@ -3483,3 +3809,12 @@ RecordByteCodeStats(codePtr) statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; } #endif /* TCL_COMPILE_STATS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + diff --git a/generic/tclCompile.h b/generic/tclCompile.h index de6bf24..1769a76 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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: tclCompile.h,v 1.33 2002/10/09 11:54:05 das Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.33.2.1 2006/11/28 22:20:00 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -121,6 +121,33 @@ typedef struct CmdLocation { int numSrcBytes; /* Number of command source chars. */ } CmdLocation; +#ifdef TCL_TIP280 +/* + * TIP #280 + * Structure to record additional location information for byte code. + * This information is internal and not saved. I.e. tbcload'ed code + * will not have this information. It records the lines for all words + * of all commands found in the byte code. The association with a + * ByteCode structure BC is done through the 'lineBCPtr' HashTable in + * Interp, keyed by the address of BC. Also recorded is information + * coming from the context, i.e. type of the frame and associated + * information, like the path of a sourced file. + */ + +typedef struct ECL { + int srcOffset; /* cmd location to find the entry */ + int nline; + int* line; /* line information for all words in the command */ +} ECL; +typedef struct ExtCmdLoc { + int type; /* Context type */ + Tcl_Obj* path; /* Path of the sourced file the command is in */ + ECL* loc; /* Command word locations (lines) */ + int nloc; /* Number of allocated entries in 'loc' */ + int nuloc; /* Number of used entries in 'loc' */ +} ExtCmdLoc; +#endif + /* * CompileProcs need the ability to record information during compilation * that can be used by bytecode instructions during execution. The AuxData @@ -264,6 +291,14 @@ typedef struct CompileEnv { /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ +#ifdef TCL_TIP280 + /* TIP #280 */ + ExtCmdLoc* extCmdMapPtr; /* Extended command location information + * for 'info frame'. */ + int line; /* First line of the script, based on the + * invoking context, then the line of the + * command currently compiled. */ +#endif } CompileEnv; /* @@ -727,8 +762,14 @@ EXTERN int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp)); *---------------------------------------------------------------- */ +#ifndef TCL_TIP280 EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); +#else +EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, CONST CmdFrame* invoker, + int word)); +#endif /* *---------------------------------------------------------------- @@ -784,9 +825,15 @@ EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); EXTERN void TclInitCompilation _ANSI_ARGS_((void)); +#ifndef TCL_TIP280 EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, CompileEnv *envPtr, char *string, int numBytes)); +#else +EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, + CompileEnv *envPtr, char *string, + int numBytes, CONST CmdFrame* invoker, int word)); +#endif EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclInitLiteralTable _ANSI_ARGS_(( @@ -1039,8 +1086,3 @@ EXTERN int TclCompileVariableCmd _ANSI_ARGS_(( # define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLCOMPILATION */ - - - - - diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4717ae2..59412b8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.94.2.19 2006/05/04 12:34:38 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.20 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" @@ -747,7 +747,12 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) } } if (objPtr->typePtr != &tclByteCodeType) { +#ifndef TCL_TIP280 TclInitCompileEnv(interp, &compEnv, string, length); +#else + /* TIP #280 : No invoker (yet) - Expression compilation */ + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); +#endif result = TclCompileExpr(interp, string, length, &compEnv); /* @@ -877,9 +882,17 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) */ int +#ifndef TCL_TIP280 TclCompEvalObj(interp, objPtr) +#else +TclCompEvalObj(interp, objPtr, invoker, word) +#endif Tcl_Interp *interp; Tcl_Obj *objPtr; +#ifdef TCL_TIP280 + CONST CmdFrame* invoker; /* Frame of the command doing the eval */ + int word; /* Index of the word which is in objPtr */ +#endif { register Interp *iPtr = (Interp *) interp; register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ @@ -917,7 +930,22 @@ TclCompEvalObj(interp, objPtr) if (objPtr->typePtr != &tclByteCodeType) { recompileObj: iPtr->errorLine = 1; + +#ifdef TCL_TIP280 + /* TIP #280. Remember the invoker for a moment in the interpreter + * structures so that the byte code compiler can pick it up when + * initializing the compilation environment, i.e. the extended + * location information. + */ + + iPtr->invokeCmdFramePtr = invoker; + iPtr->invokeWord = word; +#endif result = tclByteCodeType.setFromAnyProc(interp, objPtr); +#ifdef TCL_TIP280 + iPtr->invokeCmdFramePtr = NULL; +#endif + if (result != TCL_OK) { iPtr->numLevels--; return result; @@ -1077,6 +1105,12 @@ TclExecuteByteCode(interp, codePtr) char *part1, *part2; Var *varPtr, *arrayPtr; CallFrame *varFramePtr = iPtr->varFramePtr; + +#ifdef TCL_TIP280 + /* TIP #280 : Structures for tracking lines */ + CmdFrame bcFrame; +#endif + #ifdef TCL_COMPILE_DEBUG int traceInstructions = (tclTraceExec == 3); char cmdNameBuf[21]; @@ -1094,6 +1128,26 @@ TclExecuteByteCode(interp, codePtr) int *catchStackPtr = catchStackStorage; int catchTop = -1; +#ifdef TCL_TIP280 + /* TIP #280 : Initialize the frame. Do not push it yet. */ + + bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) + ? TCL_LOCATION_PREBC + : TCL_LOCATION_BC); + bcFrame.level = (iPtr->cmdFramePtr == NULL ? + 1 : + iPtr->cmdFramePtr->level + 1); + bcFrame.framePtr = iPtr->framePtr; + bcFrame.nextPtr = iPtr->cmdFramePtr; + bcFrame.nline = 0; + bcFrame.line = NULL; + + bcFrame.data.tebc.codePtr = codePtr; + bcFrame.data.tebc.pc = NULL; + bcFrame.cmd.str.cmd = NULL; + bcFrame.cmd.str.len = 0; +#endif + #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); @@ -1411,13 +1465,23 @@ TclExecuteByteCode(interp, codePtr) ++*preservedStackRefCountPtr; /* - * Finally, let TclEvalObjvInternal handle the command. + * Finally, let TclEvalObjvInternal handle the command. + * + * TIP #280 : Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. */ +#ifdef TCL_TIP280 + bcFrame.data.tebc.pc = pc; + iPtr->cmdFramePtr = &bcFrame; +#endif DECACHE_STACK_INFO(); Tcl_ResetResult(interp); result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); CACHE_STACK_INFO(); +#ifdef TCL_TIP280 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; +#endif /* * If the old stack is going to be released, it is @@ -1475,7 +1539,16 @@ TclExecuteByteCode(interp, codePtr) objPtr = stackPtr[stackTop]; DECACHE_STACK_INFO(); +#ifndef TCL_TIP280 result = TclCompEvalObj(interp, objPtr); +#else + /* TIP #280: The invoking context is left NULL for a dynamically + * constructed command. We cannot match its lines to the outer + * context. + */ + + result = TclCompEvalObj(interp, objPtr, NULL,0); +#endif CACHE_STACK_INFO(); if (result == TCL_OK) { /* @@ -4609,7 +4682,7 @@ IllegalExprOperandType(interp, pc, opndPtr) /* *---------------------------------------------------------------------- * - * GetSrcInfoForPc -- + * TclGetSrcInfoForPc, GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -4630,6 +4703,63 @@ IllegalExprOperandType(interp, pc, opndPtr) *---------------------------------------------------------------------- */ +#ifdef TCL_TIP280 +void +TclGetSrcInfoForPc (cfPtr) + CmdFrame* cfPtr; +{ + ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr; + + if (cfPtr->cmd.str.cmd == NULL) { + cfPtr->cmd.str.cmd = GetSrcInfoForPc((char*) cfPtr->data.tebc.pc, + codePtr, + &cfPtr->cmd.str.len); + } + + if (cfPtr->cmd.str.cmd != NULL) { + /* We now have the command. We can get the srcOffset back and + * from there find the list of word locations for this command + */ + + ExtCmdLoc* eclPtr; + ECL* locPtr = NULL; + int srcOffset; + + Interp* iPtr = (Interp*) *codePtr->interpHandle; + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + + if (!hePtr) return; + + srcOffset = cfPtr->cmd.str.cmd - codePtr->source; + eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + + { + int i; + for (i=0; i < eclPtr->nuloc; i++) { + if (eclPtr->loc [i].srcOffset == srcOffset) { + locPtr = &(eclPtr->loc [i]); + break; + } + } + } + + if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");} + + cfPtr->line = locPtr->line; + cfPtr->nline = locPtr->nline; + cfPtr->type = eclPtr->type; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + cfPtr->data.eval.path = eclPtr->path; + Tcl_IncrRefCount (cfPtr->data.eval.path); + } + /* Do not set cfPtr->data.eval.path NULL for non-SOURCE + * Needed for cfPtr->data.tebc.codePtr. + */ + } +} +#endif + static char * GetSrcInfoForPc(pc, codePtr, lengthPtr) unsigned char *pc; /* The program counter value for which to @@ -6314,3 +6444,12 @@ StringForResultCode(result) return buf; } #endif /* TCL_COMPILE_DEBUG */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ + diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 61cd561..bda1cab 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.32 2006/10/17 04:36:44 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.33 2006/11/28 22:20:01 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1762,6 +1762,12 @@ Tcl_FSEvalFile(interp, pathPtr) iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); + +#ifdef TCL_TIP280 + /* TIP #280 Force the evaluator to open a frame for a sourced + * file. */ + iPtr->evalFlags |= TCL_EVAL_FILE; +#endif result = Tcl_EvalEx(interp, string, length, 0); /* * Now we have to be careful; the script may have changed the diff --git a/generic/tclInt.h b/generic/tclInt.h index 27681f8..57e9e31 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.118.2.25 2006/10/17 04:36:44 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.118.2.26 2006/11/28 22:20:01 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -804,6 +804,113 @@ typedef struct CallFrame { * using an index into this array. */ } CallFrame; +#ifdef TCL_TIP280 +/* + * TIP #280 + * The structure below defines a command frame. A command frame + * provides location information for all commands executing a tcl + * script (source, eval, uplevel, procedure bodies, ...). The runtime + * structure essentially contains the stack trace as it would be if + * the currently executing command were to throw an error. + * + * For commands where it makes sense it refers to the associated + * CallFrame as well. + * + * The structures are chained in a single list, with the top of the + * stack anchored in the Interp structure. + * + * Instances can be allocated on the C stack, or the heap, the former + * making cleanup a bit simpler. + */ + +typedef struct CmdFrame { + /* General data. Always available. */ + + int type; /* Values see below */ + int level; /* #Frames in stack, prevent O(n) scan of list */ + int* line; /* Lines the words of the command start on */ + int nline; + + CallFrame* framePtr; /* Procedure activation record, may be NULL */ + struct CmdFrame* nextPtr; /* Link to calling frame */ + + /* Data needed for Eval vs TEBC + * + * EXECUTION CONTEXTS and usage of CmdFrame + * + * Field TEBC EvalEx EvalObjEx + * ======= ==== ====== ========= + * level yes yes yes + * type BC/PREBC SRC/EVAL EVAL_LIST + * line0 yes yes yes + * framePtr yes yes yes + * ======= ==== ====== ========= + * + * ======= ==== ====== ========= union data + * line1 - yes - + * line3 - yes - + * path - yes - + * ------- ---- ------ --------- + * codePtr yes - - + * pc yes - - + * ======= ==== ====== ========= + * + * ======= ==== ====== ========= | union cmd + * listPtr - - yes | + * ------- ---- ------ --------- | + * cmd yes yes - | + * cmdlen yes yes - | + * ------- ---- ------ --------- | + */ + + union { + struct { + Tcl_Obj* path; /* Path of the sourced file the command + * is in. */ + } eval; + struct { + CONST void* codePtr; /* Byte code currently executed */ + CONST char* pc; /* and instruction pointer. */ + } tebc; + } data; + + union { + struct { + CONST char* cmd; /* The executed command, if possible */ + int len; /* And its length */ + } str; + Tcl_Obj* listPtr; /* Tcl_EvalObjEx, cmd list */ + } cmd; + +} CmdFrame; + +/* The following macros define the allowed values for the type field + * of the CmdFrame structure above. Some of the values occur only in + * the extended location data referenced via the 'baseLocPtr'. + * + * TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx. + * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list + * optimization path of EvalObjEx. + * TCL_LOCATION_BC : Frame is for bytecode. + * TCL_LOCATION_PREBC : Frame is for precompiled bytecode. + * TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, + * from a sourced file. + * TCL_LOCATION_PROC : Frame is for bytecode of a procedure. + * + * A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and + * _PROC types, per the context of the byte code in execution. + */ + +#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script */ +#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script, list-path */ +#define TCL_LOCATION_BC (2) /* Location in byte code */ +#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no location */ +#define TCL_LOCATION_SOURCE (4) /* Location in a file */ +#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc */ + +#define TCL_LOCATION_LAST (6) /* Number of values in the enum */ +#endif + /* *---------------------------------------------------------------- * Data structures and procedures related to TclHandles, which @@ -1363,6 +1470,32 @@ typedef struct Interp { int tracesForbiddingInline; /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode * compilation */ +#ifdef TCL_TIP280 + /* TIP #280 */ + CmdFrame* cmdFramePtr; /* Points to the command frame containing + * the location information for the current + * command. */ + CONST CmdFrame* invokeCmdFramePtr; /* Points to the command frame which is the + * invoking context of the bytecode compiler. + * NULL when the byte code compiler is not + * active */ + int invokeWord; /* Index of the word in the command which + * is getting compiled. */ + Tcl_HashTable* linePBodyPtr; + /* This table remembers for each + * statically defined procedure the + * location information for its + * body. It is keyed by the address of + * the Proc structure for a procedure. + */ + Tcl_HashTable* lineBCPtr; + /* This table remembers for each + * ByteCode object the location + * information for its body. It is + * keyed by the address of the Proc + * structure for a procedure. + */ +#endif #ifdef TCL_TIP268 /* * TIP #268. @@ -1395,6 +1528,10 @@ typedef struct Interp { #define TCL_BRACKET_TERM 1 #define TCL_ALLOW_EXCEPTIONS 4 +#ifdef TCL_TIP280 +#define TCL_EVAL_FILE 2 +#define TCL_EVAL_CTX 8 +#endif /* * Flag bits for Interp structures: @@ -1671,11 +1808,24 @@ extern char tclEmptyString; *---------------------------------------------------------------- */ +#ifdef TCL_TIP280 +EXTERN void TclAdvanceLines _ANSI_ARGS_((int* line, CONST char* start, + CONST char* end)); +#endif EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, CONST char *value)); EXTERN void TclDeleteNamespaceVars _ANSI_ARGS_((Namespace *nsPtr)); + +#ifdef TCL_TIP280 +EXTERN int TclEvalObjEx _ANSI_ARGS_((Tcl_Interp *interp, + register Tcl_Obj *objPtr, + int flags, + CONST CmdFrame* invoker, + int word)); +#endif + EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -1707,6 +1857,9 @@ EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); EXTERN int TclGetEncodingFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr)); +#ifdef TCL_TIP280 +EXTERN void TclGetSrcInfoForPc _ANSI_ARGS_((CmdFrame* cfPtr)); +#endif EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData* types)); @@ -1749,6 +1902,9 @@ EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string, int numBytes)); EXTERN int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src, int numBytes, Tcl_Parse *parsePtr, char *typePtr)); +#ifdef TCL_TIP280 +EXTERN int TclWordKnownAtCompileTime _ANSI_ARGS_((Tcl_Token* token)); +#endif EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename, int mode)); EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr, @@ -2160,7 +2316,12 @@ EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, (objPtr)->length = 0; \ (objPtr)->typePtr = NULL -#define TclDecrRefCount(objPtr) \ + +#ifdef TCL_MEM_DEBUG +# define TclDecrRefCount(objPtr) \ + Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +#else +# define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ if (((objPtr)->typePtr != NULL) \ && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ @@ -2173,6 +2334,7 @@ EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, TclFreeObjStorage(objPtr); \ TclIncrObjsFreed(); \ } +#endif #ifdef TCL_MEM_DEBUG # define TclAllocObjStorage(objPtr) \ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 851123d..7fae90a 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -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: tclInterp.c,v 1.20.2.2 2003/05/12 22:35:40 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.20.2.3 2006/11/28 22:20:02 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2091,7 +2091,13 @@ SlaveEval(interp, slaveInterp, objc, objv) Tcl_AllowExceptions(slaveInterp); if (objc == 1) { +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); +#else + /* TIP #280 : Make invoker available to eval'd script */ + Interp* iPtr = (Interp*) interp; + result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0); +#endif } else { objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 9955e02..4f72e4c 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -19,7 +19,7 @@ * 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.31.2.12 2006/05/31 23:29:31 hobbs Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.13 2006/11/28 22:20:02 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2997,7 +2997,13 @@ NamespaceEvalCmd(dummy, interp, objc, objv) frame.objv = objv; /* ref counts do not need to be incremented here */ if (objc == 4) { +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objv[3], 0); +#else + /* TIP #280 : Make invoker available to eval'd script */ + Interp* iPtr = (Interp*) interp; + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3); +#endif } else { /* * More than one argument: concatenate them together with spaces @@ -3005,7 +3011,12 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * the object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-3, objv+3); +#ifndef TCL_TIP280 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); +#else + /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); +#endif } if (result == TCL_ERROR) { char msg[256 + TCL_INTEGER_SPACE]; diff --git a/generic/tclProc.c b/generic/tclProc.c index aae5008..3ecf243 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.44.2.5 2006/05/15 16:07:04 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.44.2.6 2006/11/28 22:20:02 andreas_kupries Exp $ */ #include "tclInt.h" @@ -152,6 +152,65 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) procPtr->cmdPtr = (Command *) cmd; +#ifdef TCL_TIP280 + /* TIP #280 Remember the line the procedure body is starting on. In a + * Byte code context we ask the engine to provide us with the necessary + * information. This is for the initialization of the byte code compiler + * when the body is used for the first time. + */ + + if (iPtr->cmdFramePtr) { + CmdFrame context = *iPtr->cmdFramePtr; + + if (context.type == TCL_LOCATION_BC) { + TclGetSrcInfoForPc (&context); + /* May get path in context */ + } else if (context.type == TCL_LOCATION_SOURCE) { + /* context now holds another reference */ + Tcl_IncrRefCount (context.data.eval.path); + } + + /* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We + * cannot assume that 'line' is valid here, we have to check. If the + * outer context is an eval (bc, prebc, eval) we do not save any + * information. Counting relative to the beginning of the proc body is + * more sensible than counting relative to the outer eval block. + */ + + if ((context.type == TCL_LOCATION_SOURCE) && + context.line && + (context.nline >= 4) && + (context.line [3] >= 0)) { + int new; + CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame)); + + cfPtr->level = -1; + cfPtr->type = context.type; + cfPtr->line = (int*) ckalloc (sizeof (int)); + cfPtr->line [0] = context.line [3]; + cfPtr->nline = 1; + cfPtr->framePtr = NULL; + cfPtr->nextPtr = NULL; + + if (context.type == TCL_LOCATION_SOURCE) { + cfPtr->data.eval.path = context.data.eval.path; + /* Transfer of reference. The reference going away (release of + * the context) is replaced by the reference in the + * constructed cmdframe */ + } else { + cfPtr->type = TCL_LOCATION_EVAL; + cfPtr->data.eval.path = NULL; + } + + cfPtr->cmd.str.cmd = NULL; + cfPtr->cmd.str.len = 0; + + Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr, + (char*) procPtr, &new), + cfPtr); + } + } +#endif /* * Optimize for noop procs: if the body is not precompiled (like a TclPro @@ -1101,7 +1160,15 @@ TclObjInterpProc(clientData, interp, objc, objv) iPtr->returnCode = TCL_OK; procPtr->refCount++; +#ifndef TCL_TIP280 result = TclCompEvalObj(interp, procPtr->bodyPtr); +#else + /* TIP #280: No need to set the invoking context here. The body has + * already been compiled, so the part of CompEvalObj using it is bypassed. + */ + + result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0); +#endif procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); @@ -1313,7 +1380,24 @@ ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { +#ifdef TCL_TIP280 + /* TIP #280. We get the invoking context from the cmdFrame + * which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr). + */ + + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); + + /* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd. + */ + iPtr->invokeWord = 0; + iPtr->invokeCmdFramePtr = (hePtr + ? (CmdFrame*) Tcl_GetHashValue (hePtr) + : NULL); +#endif result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); +#ifdef TCL_TIP280 + iPtr->invokeCmdFramePtr = NULL; +#endif Tcl_PopCallFrame(interp); } @@ -1492,6 +1576,11 @@ TclProcCleanupProc(procPtr) Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; +#ifdef TCL_TIP280 + Tcl_HashEntry* hePtr = NULL; + CmdFrame* cfPtr = NULL; + Interp* iPtr = procPtr->iPtr; +#endif if (bodyPtr != NULL) { Tcl_DecrRefCount(bodyPtr); @@ -1516,6 +1605,28 @@ TclProcCleanupProc(procPtr) localPtr = nextPtr; } ckfree((char *) procPtr); + +#ifdef TCL_TIP280 + /* TIP #280. Release the location data associated with this Proc + * structure, if any. The interpreter may not exist (For example for + * procbody structurues created by tbcload. + */ + + if (!iPtr) return; + + hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr); + if (!hePtr) return; + + cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr); + + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (cfPtr->data.eval.path); + cfPtr->data.eval.path = NULL; + } + ckfree ((char*) cfPtr->line); cfPtr->line = NULL; + ckfree ((char*) cfPtr); + Tcl_DeleteHashEntry (hePtr); +#endif } /* @@ -1821,6 +1932,12 @@ TclCompileNoOp(interp, parsePtr, envPtr) TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); return TCL_OK; } - - + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tests/info.test b/tests/info.test index 7a31b27..3c300dc 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1,3 +1,4 @@ +# -*- tcl -*- # Commands covered: info # # This file contains a collection of tests for one or more of the Tcl @@ -7,11 +8,12 @@ # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2006 ActiveState # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.24.2.4 2005/07/29 14:57:28 dkf Exp $ +# RCS: @(#) $Id: info.test,v 1.24.2.5 2006/11/28 22:20:02 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -29,6 +31,9 @@ namespace eval test_ns_info1 { proc q {{y 27} {z {}}} {return "y=$y"} } +testConstraint tip280 [info exists tcl_platform(tip,280)] +testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}] + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} @@ -651,18 +656,424 @@ test info-20.5 {info functions option} { test info-21.1 {miscellaneous error conditions} { list [catch {info} msg] $msg } {1 {wrong # args: should be "info option ?arg arg ...?"}} -test info-21.2 {miscellaneous error conditions} { +test info-21.2 {miscellaneous error conditions} !tip280 { list [catch {info gorp} msg] $msg } {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-21.3 {miscellaneous error conditions} { +test info-21.2-280 {miscellaneous error conditions} tip280 { + list [catch {info gorp} msg] $msg +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-21.3 {miscellaneous error conditions} !tip280 { list [catch {info c} msg] $msg } {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-21.4 {miscellaneous error conditions} { +test info-21.3-280 {miscellaneous error conditions} tip280 { + list [catch {info c} msg] $msg +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-21.4 {miscellaneous error conditions} !tip280 { list [catch {info l} msg] $msg } {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} -test info-21.5 {miscellaneous error conditions} { +test info-21.4-280 {miscellaneous error conditions} tip280 { + list [catch {info l} msg] $msg +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-21.5 {miscellaneous error conditions} !tip280 { list [catch {info s} msg] $msg } {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +test info-21.5-280 {miscellaneous error conditions} tip280 { + list [catch {info s} msg] $msg +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} + +## +# ### ### ### ######### ######### ######### +## info frame + +## Helper +# For the more complex results we cut the file name down to remove +# path dependencies, and we use only part of the first line of the +# reported command. The latter is required because otherwise the whole +# test case may appear in some results, but the result is part of the +# testcase. An infinite string would be required to describe that. The +# cutting-down breaks this. + +proc reduce {frame} { + set pos [lsearch -exact $frame cmd] + incr pos + set cmd [lindex $frame $pos] + if {[regexp \n $cmd]} { + set first [string range [lindex [split $cmd \n] 0] 0 end-11] + set frame [lreplace $frame $pos $pos $first] + } + set pos [lsearch -exact $frame file] + if {$pos >=0} { + incr pos + set tail [file tail [lindex $frame $pos]] + set frame [lreplace $frame $pos $pos $tail] + } + set frame +} + +## Helper +# Generate a stacktrace from the current location to top. This code +# not only depends on the exact location of things, but also on the +# implementation of tcltest. Any changes and these tests will have to +# be updated. + +proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res +} + +## + +test info-22.0 {info frame, levels} tip280 { + info frame +} 7 + +test info-22.1 {info frame, bad level relative} tip280 { + # catch is another level!, i.e. we have 8, not 7 + catch {info frame -8} msg + set msg +} {bad level "-8"} + +test info-22.2 {info frame, bad level absolute} tip280 { + # catch is another level!, i.e. we have 8, not 7 + catch {info frame 9} msg + set msg +} {bad level "9"} + +test info-22.3 {info frame, current, relative} tip280 { + info frame 0 +} {type eval line 2 cmd {info frame 0}} + +test info-22.4 {info frame, current, relative, nested} tip280 { + set res [info frame 0] +} {type eval line 2 cmd {info frame 0}} + +test info-22.5 {info frame, current, absolute} tip280 { + reduce [info frame 7] +} {type eval line 2 cmd {info frame 7}} + +test info-22.6 {info frame, global, relative} tip280 { + reduce [info frame -6] +} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ} + +test info-22.7 {info frame, global, absolute} tip280 { + reduce [info frame 1] +} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut} + +test info-22.8 {info frame, basic trace} tip280 { + join [etrace] \n +} {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +7 {type eval line 2 cmd etrace} +6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} +5 {type eval line 1 cmd {::tcltest::RunTest }} +4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ } +2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} +1 {type source line 767 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac}} +## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0 +test info-23.0 {eval'd info frame} tip280 { + eval {info frame} +} 8 + +test info-23.1 {eval'd info frame, semi-dynamic} tip280 { + eval info frame +} 8 + +test info-23.2 {eval'd info frame, dynamic} tip280 { + set script {info frame} + eval $script +} 8 + +test info-23.3 {eval'd info frame, literal} tip280 { + eval { + info frame 0 + } +} {type eval line 2 cmd {info frame 0}} + +test info-23.4 {eval'd info frame, semi-dynamic} tip280 { + eval info frame 0 +} {type eval line 1 cmd {info frame 0}} + +test info-23.5 {eval'd info frame, dynamic} tip280 { + set script {info frame 0} + eval $script +} {type eval line 1 cmd {info frame 0}} + +test info-23.6 {eval'd info frame, trace} tip280 { + set script {etrace} + join [eval $script] \n +} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0} +8 {type eval line 1 cmd etrace} +7 {type eval line 3 cmd {eval $script}} +6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} +5 {type eval line 1 cmd {::tcltest::RunTest }} +4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ } +2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} +1 {type source line 806 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac}} +## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0 +# ------------------------------------------------------------------------- + +# Procedures defined in scripts which are arguments to control +# structures (like 'namespace eval', 'interp eval', 'if', 'while', +# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute +# location. The command implementations execute such scripts through +# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This +# causes the connection to the context to be lost. Currently only +# procedure bodies are able to remember their context. + +# ------------------------------------------------------------------------- + +namespace eval foo { + proc bar {} {info frame 0} +} + +test info-24.0 {info frame, interaction, namespace eval} tip280 { + reduce [foo::bar] +} {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +set flag 1 +if {$flag} { + namespace eval foo {} + proc ::foo::bar {} {info frame 0} +} + +test info-24.1 {info frame, interaction, if} tip280 { + reduce [foo::bar] +} {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +set flag 1 +while {$flag} { + namespace eval foo {} + proc ::foo::bar {} {info frame 0} + set flag 0 +} + +test info-24.2 {info frame, interaction, while} tip280 { + reduce [foo::bar] +} {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +catch { + namespace eval foo {} + proc ::foo::bar {} {info frame 0} +} + +test info-24.3 {info frame, interaction, catch} tip280 { + reduce [foo::bar] +} {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +foreach var val { + namespace eval foo {} + proc ::foo::bar {} {info frame 0} + break +} + +test info-24.4 {info frame, interaction, foreach} tip280 { + reduce [foo::bar] +} {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +for {} {1} {} { + namespace eval foo {} + proc ::foo::bar {} {info frame 0} + break +} + +test info-24.5 {info frame, interaction, for} tip280 { + reduce [foo::bar] +} {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +eval { + proc bar {} {info frame 0} +} + +test info-25.0 {info frame, proc in eval} tip280 { + reduce [bar] +} {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0} + +proc bar {} {info frame 0} +test info-25.1 {info frame, regular proc} tip280 { + reduce [bar] +} {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0} +rename bar {} + + + +test info-30.0 {bs+nl in literal words} {tip280 knownBug} { + if {1} { + set res \ + [reduce [info frame 0]] + } + set res + # This is reporting line 3 instead of the correct 4 because the + # bs+nl combination is subst by the parser before the 'if' + # command, and the the bcc sees the word. To fix record the + # offsets of all bs+nl sequences in literal words, then use the + # information in the bcc to bump line numbers when parsing over + # the location. Also affected: testcases 22.8 and 23.6. +} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest} + + + +# ------------------------------------------------------------------------- +# See 24.0 - 24.5 for similar situations, using literal scripts. + +set body {set flag 0 + set a c + set res [info frame 0]} ;# line 3! + +test info-31.0 {ns eval, script in variable} tip280 { + namespace eval foo $body + set res +} {type eval line 3 cmd {info frame 0} level 0} +catch {namespace delete foo} + + +test info-31.1 {if, script in variable} tip280 { + if 1 $body + set res +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} + +test info-31.1a {if, script in variable} tip280 { + if 1 then $body + set res +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} + + + +test info-31.2 {while, script in variable} tip280 { + set flag 1 + while {$flag} $body + set res +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} + +# .3 - proc - scoping prevent return of result ... + +test info-31.4 {foreach, script in variable} tip280 { + foreach var val $body + set res +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} + +test info-31.5 {for, script in variable} tip280 { + set flag 1 + for {} {$flag} {} $body + set res +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} + +test info-31.6 {eval, script in variable} tip280 { + eval $body + set res +} {type eval line 3 cmd {info frame 0}} + +# ------------------------------------------------------------------------- + +namespace eval foo {} +set x foo +switch -exact -- $x { + foo { + proc ::foo::bar {} {info frame 0} + } +} + +test info-24.6.0 {info frame, interaction, switch, list body} tip280 { + reduce [foo::bar] +} {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset x + +# ------------------------------------------------------------------------- + +namespace eval foo {} +set x foo +switch -exact -- $x foo { + proc ::foo::bar {} {info frame 0} +} + +test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 { + reduce [foo::bar] +} {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset x + +# ------------------------------------------------------------------------- + +namespace eval foo {} +set x foo +switch -exact -- $x [list foo { + proc ::foo::bar {} {info frame 0} +}] + +test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 { + reduce [foo::bar] +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset x + +# ------------------------------------------------------------------------- + +set body { + foo { + proc ::foo::bar {} {info frame 0} + } +} + +namespace eval foo {} +set x foo +switch -exact -- $x $body + +test info-31.7 {info frame, interaction, switch, dynamic} tip280 { + reduce [foo::bar] +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset x + +# ------------------------------------------------------------------------- + +set body { + proc ::foo::bar {} {info frame 0} +} + +namespace eval foo {} +eval $body + +test info-32.0 {info frame, dynamic procedure} tip280 { + reduce [foo::bar] +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} diff --git a/tests/platform.test b/tests/platform.test index 01bf787..ce72211 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -23,6 +23,7 @@ test platform-1.1 {TclpSetVariables: tcl_platform} { i eval {catch {unset tcl_platform(debug)}} i eval {catch {unset tcl_platform(threaded)}} i eval {catch {unset tcl_platform(tip,268)}} + i eval {catch {unset tcl_platform(tip,280)}} set result [i eval {lsort [array names tcl_platform]}] interp delete i set result diff --git a/tests/safe.test b/tests/safe.test index 15dfa85..938e247 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.13.2.2 2006/09/22 01:26:24 andreas_kupries Exp $ +# RCS: @(#) $Id: safe.test,v 1.13.2.3 2006/11/28 22:20:03 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -191,6 +191,10 @@ test safe-6.3 {test safe interpreters knowledge of the world} { if {$tip != -1} { set r [lreplace $r $tip $tip] } + set tip [lsearch $r "tip,280"] + if {$tip != -1} { + set r [lreplace $r $tip $tip] + } set r } {byteOrder platform wordSize} |