From 2cd91050a0972e257b9bc1a320d996030f01ce5d Mon Sep 17 00:00:00 2001 From: andreas_kupries Date: Tue, 28 Nov 2006 22:20:27 +0000 Subject: * generic/tclBasic.c: TIP #280 implementation. * 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: --- ChangeLog | 22 ++ doc/info.n | 110 +++++++- generic/tclBasic.c | 487 +++++++++++++++++++++++++++++++-- generic/tclCmdAH.c | 28 +- generic/tclCmdIL.c | 278 ++++++++++++++++++- generic/tclCmdMZ.c | 106 +++++++- generic/tclCompCmds.c | 362 ++++++++++++++++++------- generic/tclCompExpr.c | 6 +- generic/tclCompile.c | 394 ++++++++++++++++++++++++++- generic/tclCompile.h | 37 ++- generic/tclDictObj.c | 20 +- generic/tclExecute.c | 111 +++++++- generic/tclIOUtil.c | 5 +- generic/tclInt.decls | 5 +- generic/tclInt.h | 154 ++++++++++- generic/tclIntDecls.h | 7 +- generic/tclInterp.c | 6 +- generic/tclNamesp.c | 9 +- generic/tclParse.c | 63 ++++- generic/tclProc.c | 198 +++++++++++++- generic/tclUtil.c | 85 +++++- library/tcltest/tcltest.tcl | 5 +- tests/info.test | 635 +++++++++++++++++++++++++++++++++++++++++++- 23 files changed, 2928 insertions(+), 205 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4757839..fefc447 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,25 @@ +2006-11-28 Andreas Kupries + + * generic/tclBasic.c: TIP #280 implementation. + * 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 * unix/tclUnixChan.c (TclUnixWaitForFile): diff --git a/doc/info.n b/doc/info.n index 8bfee19..5b23525 100644 --- a/doc/info.n +++ b/doc/info.n @@ -7,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: info.n,v 1.17 2005/05/30 00:04:45 dkf Exp $ +'\" RCS: @(#) $Id: info.n,v 1.18 2006/11/28 22:20:27 andreas_kupries Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" @@ -82,6 +82,114 @@ into variable \fIvarname\fR. Returns \fB1\fR if the variable named \fIvarName\fR exists in the current context (either as a global or local variable) and has been defined by being given a value, returns \fB0\fR otherwise. + +.TP +\fBinfo frame\fR ?\fInumber\fR? +This command provides access to all frames on the stack, even those +hidden from \fBinfo level\fR. If \fInumber\fR is not specified, this +command returns a number giving the frame level of the command. This +is 1 if the command is invoked at top-level. If \fInumber\fR is +specified, then the result is a dictionary containing the location +information for the command at the \fInumber\fRed level on the stack. +.sp +If \fInumber\fR is positive (> 0) then it selects a particular stack +level (1 refers to the top-most active command, i.e., \fBinfo frame\fR +itself, 2 to the command it was called from, and so on); otherwise it +gives a level relative to the current command (0 refers to the current +command, i.e., \fBinfo frame\fR itself, -1 to its caller, and so on). +.sp +This is similar to how \fBinfo level\fR works, except that this +subcommand reports all frames, like \fBsource\fR'd scripts, +\fBeval\fR's, \fBuplevel\fR's, etc. +.sp +Note that for nested commands, like "foo [[bar [[x]]]]" only "x" will +be seen by an \fBinfo frame\fR invoked within "x". This is the same as +for \fBinfo level\fR and error stack traces. +.sp +The result dictionary may contain the keys listed below, with the +specified meanings for their values: +.RS +.TP +\fItype\fR +This entry is always present and describes the nature of the location +for the command. The recognized values are \fBsource\fR, \fBproc\fR, +\fBeval\fR, and \fBprecompiled\fR. +.RS +.TP +\fBsource\fR +means that the command is found in a script loaded by the \fBsource\fR +command. +.TP +\fBproc\fR +means that the command is found in dynamically created procedure body. +.TP +\fBeval\fR +means that the command is executed by \fBeval\fR or \fBuplevel\fR. +.TP +\fBprecompiled\fR +means that the command is found in a precompiled script (loadable by +the package \fBtbcload\fR), and no further information will be +available. +.RE +.TP +\fIline\fR +This entry provides the number of the line the command is at inside of +the script it is a part of. This information is not present for type +\fBprecompiled\fR. For type \fBsource\fR this information is counted +relative to the beginning of the file, whereas for the last two types +the line is counted relative to the start of the script. +.TP +\fIfile\fR +This entry is present only for type \fBsource\fR. It provides the +normalized path of the file the command is in. +.TP +\fIcmd\fR +This entry provides the string representation of the command. This is +usually the unsubstituted form, however for commands which are a pure +list executed by eval it is the substituted form as they have no other +string representation. Care is taken that the pure-List property of +the latter is not spoiled. +.TP +\fIproc\fR +This entry is present only if the command is found in the body of a +regular Tcl procedure. It then provides the name of that procedure. +.TP +\fIlambda\fR +This entry is present only if the command is found in the body of an +anonymous Tcl procedure, i.e. a lambda. It then provides the entire +definition of the lambda in question. +.TP +\fIlevel\fR +This entry is present only if the queried frame has a corresponding +frame returned by \fBinfo level\fR. It provides the index of this +frame, relative to the current level (0 and negative numbers). +.RE +.sp +.RS +A thing of note is that for procedures statically defined in files the +locations of commands in their bodies will be reported with type +\fBsource\fR and absolute line numbers, and not as type +\fBproc\fR. The same is true for procedures nested in statically +defined procedures, and literal eval scripts in files or statically +defined procedures. +.sp +In contrast, a procedure definition or \fBeval\fR within a dynamically +\fBeval\fRuated environment count linenumbers relative to the start of +their script, even if they would be able to count relative to the +start of the outer dynamic script. That type of number usually makes +more sense. +.sp +A different way of describing this behaviour is that file based +locations are tracked as deeply as possible, and where this is not +possible the lines are counted based on the smallest possible +\fBeval\fR or procedure body, as that scope is usually easier to find +than any dynamic outer scope. +.sp +The syntactic form \fB{expand}\fR is handled like \fBeval\fR. I.e. if it +is given a literal list argument the system tracks the linenumber +within the list words as well, and otherwise all linenumbers are +counted relative to the start of each word (smallest scope) +.RE .TP \fBinfo functions \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the math diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 127620d..ef01194 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.220 2006/11/23 15:24:28 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.221 2006/11/28 22:20:27 andreas_kupries Exp $ */ #include "tclInt.h" @@ -357,6 +357,17 @@ Tcl_CreateInterp(void) iPtr->maxNestingDepth = MAX_NESTING_DEPTH; iPtr->framePtr = NULL; /* initialise as soon as :: is available */ iPtr->varFramePtr = NULL; /* initialise as soon as :: is available */ + + /* + * 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); + iPtr->activeVarTracePtr = NULL; iPtr->returnOpts = NULL; @@ -1213,6 +1224,60 @@ DeleteInterpProc( */ TclDeleteLiteralTable(interp, &(iPtr->literalTable)); + + /* 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; + } ckfree((char *) iPtr); } @@ -3731,7 +3796,7 @@ Tcl_EvalTokensStandard( int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { - return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL); + return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1); } /* @@ -3785,7 +3850,7 @@ Tcl_EvalTokens( /* *---------------------------------------------------------------------- * - * Tcl_EvalEx -- + * Tcl_EvalEx, TclEvalEx -- * * This function evaluates a Tcl script without using the compiler or * byte-code interpreter. It just parses the script, creates values for @@ -3799,6 +3864,7 @@ Tcl_EvalTokens( * Side effects: * Depends on the script. * + * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ @@ -3814,18 +3880,44 @@ Tcl_EvalEx( * evaluation of the script. Only * TCL_EVAL_GLOBAL is currently supported. */ { + return TclEvalEx (interp, script, numBytes, flags, 1); +} + +int +TclEvalEx(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. */ +{ Interp *iPtr = (Interp *) interp; CONST char *p, *next; Tcl_Parse parse; #define NUM_STATIC_OBJS 20 Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace; - int expandStatic[NUM_STATIC_OBJS], *expand; + int expandStatic [NUM_STATIC_OBJS], *expand; + int linesStatic [NUM_STATIC_OBJS], *lines, *lineSpace; Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft, expandRequested; + int code = TCL_OK; + int i, commandLength, bytesLeft, expandRequested; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + /* TIP #280. The array 'expand' has become tri-valued. + * 0 = no expansion + * 1 = expansion, value is dynamically constructed ($var, [cmd]). + * 2 = NEW expansion of a literal value. Here the system determines + * the actual line numbers within the literal. + */ + /* * The variables below keep track of how much state has been allocated * while evaluating the script, so that it can be freed properly if an @@ -3834,6 +3926,9 @@ Tcl_EvalEx( int gotParse = 0, objectsUsed = 0; + /* TIP #280 Structures for tracking of command locations. */ + CmdFrame eeFrame; + if (numBytes < 0) { numBytes = strlen(script); } @@ -3849,19 +3944,91 @@ Tcl_EvalEx( * the script and then executes it. */ - objv = objvSpace = staticObjArray; - expand = expandStatic; - p = script; + objv = objvSpace = staticObjArray; + lines = lineSpace = linesStatic; + expand = expandStatic; + p = script; bytesLeft = numBytes; + + /* 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; + iPtr->evalFlags = 0; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { code = TCL_ERROR; goto error; } + + /* + * TIP #280 Track lines. The parser may have skipped text till it + * found the command we are now at. We have to count the lines in this + * block. + */ + + TclAdvanceLines (&line, p, parse.commandStart); + gotParse = 1; if (parse.numWords > 0) { /* + * TIP #280. Track lines within the words of the current + * command. + */ + + int wordLine = line; + CONST char* wordStart = parse.commandStart; + + /* * Generate an array of objects for the words of the command. */ @@ -3869,17 +4036,45 @@ Tcl_EvalEx( if (parse.numWords > NUM_STATIC_OBJS) { expand = (int *) - ckalloc((unsigned) (parse.numWords * sizeof(int))); + ckalloc((unsigned) (parse.numWords * sizeof(int))); objvSpace = (Tcl_Obj **) - ckalloc((unsigned) (parse.numWords*sizeof(Tcl_Obj *))); + ckalloc((unsigned) (parse.numWords * sizeof(Tcl_Obj *))); + lineSpace = (int*) + ckalloc((unsigned) (parse.numWords * sizeof(int))); } expandRequested = 0; - objv = objvSpace; + objv = objvSpace; + lines = lineSpace; + for (objectsUsed = 0, tokenPtr = parse.tokenPtr; objectsUsed < parse.numWords; objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { + + /* + * 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; + + lines [objectsUsed] = ((TclWordKnownAtCompileTime (tokenPtr, NULL) || + TclWordSimpleExpansion (tokenPtr)) + ? wordLine + : -1); + + if (eeFrame.type == TCL_LOCATION_SOURCE) { + iPtr->evalFlags |= TCL_EVAL_FILE; + } + code = TclSubstTokens(interp, tokenPtr+1, - tokenPtr->numComponents, NULL); + tokenPtr->numComponents, NULL, wordLine); + + iPtr->evalFlags = 0; + if (code != TCL_OK) { goto error; } @@ -3901,31 +4096,67 @@ Tcl_EvalEx( goto error; } expandRequested = 1; - expand[objectsUsed] = 1; + expand[objectsUsed] = (TclWordSimpleExpansion (tokenPtr) + ? 2 + : 1); + objectsNeeded += (numElements ? numElements : 1); } else { expand[objectsUsed] = 0; objectsNeeded++; } - } + } /* for loop */ if (expandRequested) { /* * Some word expansion was requested. Check for objv resize. */ - Tcl_Obj **copy = objvSpace; + Tcl_Obj **copy = objvSpace; + int *lcopy = lineSpace; int wordIdx = parse.numWords; - int objIdx = objectsNeeded - 1; + int objIdx = objectsNeeded - 1; if ((parse.numWords > NUM_STATIC_OBJS) || (objectsNeeded > NUM_STATIC_OBJS)) { objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned) (objectsNeeded * sizeof(Tcl_Obj *))); + lines = lineSpace = (int*) ckalloc((unsigned) + (objectsNeeded * sizeof(int))); } objectsUsed = 0; while (wordIdx--) { - if (expand[wordIdx]) { + if (expand[wordIdx] == 2) { + /* TIP #280. The expansion is for a simple literal. Not only + * crack the list into its elements, determine the + * line numbers within it as well. + * + * The qualification of 'simple' ensures that the word + * does not contain backslash-subst, no way to get + * thrown off by embedded \n sequnces. + */ + + int numElements; + Tcl_Obj **elements, *temp = copy[wordIdx]; + int* eline; + + Tcl_ListObjGetElements(NULL, temp, + &numElements, &elements); + + eline = (int*) ckalloc (numElements * sizeof(int)); + TclListLines (TclGetString(temp),lcopy[wordIdx], + numElements, eline); + + objectsUsed += numElements; + while (numElements--) { + lines[objIdx] = eline [numElements]; + objv [objIdx--] = elements[numElements]; + Tcl_IncrRefCount(elements[numElements]); + } + Tcl_DecrRefCount(temp); + ckfree((char*) eline); + + } else if (expand[wordIdx]) { int numElements; Tcl_Obj **elements, *temp = copy[wordIdx]; @@ -3933,12 +4164,14 @@ Tcl_EvalEx( &numElements, &elements); objectsUsed += numElements; while (numElements--) { - objv[objIdx--] = elements[numElements]; + lines[objIdx] = -1; + objv [objIdx--] = elements[numElements]; Tcl_IncrRefCount(elements[numElements]); } Tcl_DecrRefCount(temp); } else { - objv[objIdx--] = copy[wordIdx]; + lines[objIdx] = lcopy[wordIdx]; + objv [objIdx--] = copy [wordIdx]; objectsUsed++; } } @@ -3947,16 +4180,41 @@ Tcl_EvalEx( if (copy != staticObjArray) { ckfree((char *) copy); } + if (lcopy != linesStatic) { + ckfree((char *) lcopy); + } } /* * 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. */ + eeFrame.cmd.str.cmd = parse.commandStart; + eeFrame.cmd.str.len = parse.commandSize; + + if (parse.term == parse.commandStart + parse.commandSize - 1) { + eeFrame.cmd.str.len --; + } + + eeFrame.nline = objectsUsed; + eeFrame.line = lines; + + iPtr->cmdFramePtr = &eeFrame; iPtr->numLevels++; code = TclEvalObjvInternal(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); iPtr->numLevels--; + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + + eeFrame.line = NULL; + eeFrame.nline = 0; + if (code != TCL_OK) { goto error; } @@ -3967,6 +4225,8 @@ Tcl_EvalEx( if (objvSpace != staticObjArray) { ckfree((char *) objvSpace); objvSpace = staticObjArray; + ckfree ((char*) lineSpace); + lineSpace = linesStatic; } /* @@ -3982,16 +4242,21 @@ Tcl_EvalEx( /* * 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; + TclAdvanceLines (&line, parse.commandStart, p); Tcl_FreeParse(&parse); gotParse = 0; } while (bytesLeft > 0); iPtr->varFramePtr = savedVarFramePtr; - return TCL_OK; + code = TCL_OK; + goto cleanup_return; error: /* @@ -4034,17 +4299,59 @@ Tcl_EvalEx( } if (objvSpace != staticObjArray) { ckfree((char *) objvSpace); + ckfree ((char*) lineSpace); } if (expand != expandStatic) { ckfree((char *) expand); } iPtr->varFramePtr = savedVarFramePtr; + 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); + } return code; } /* *---------------------------------------------------------------------- * + * 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) ++; + } + } +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Eval -- * * Execute a Tcl command in a string. This function executes the script @@ -4120,7 +4427,7 @@ Tcl_GlobalEvalObj( /* *---------------------------------------------------------------------- * - * 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 is @@ -4136,6 +4443,7 @@ Tcl_GlobalEvalObj( * the bytecode instructions for the commands. Executing the commands * will almost certainly have side effects that depend on those commands. * + * TIP #280 : Keep public API, internally extended API. *---------------------------------------------------------------------- */ @@ -4149,6 +4457,24 @@ Tcl_EvalObjEx( * evaluation of the script. Supported values * are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */ { + 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 */ +{ register Interp *iPtr = (Interp *) interp; char *script; int numSrcBytes; @@ -4185,17 +4511,53 @@ Tcl_EvalObjEx( if (objPtr->bytes == NULL || /* ...without a string rep */ listRepPtr->canonicalFlag) {/* ...or that is canonical */ + /* TIP #280 Structures for tracking lines. + * As we know that this is dynamic execution we ignore the + * invoker, even if known. + */ + int line, i; + char* w; + CmdFrame eoFrame; + Tcl_Obj **elements = &listRepPtr->elements; + + 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 = listRepPtr->elemCount; + eoFrame.line = (int*) ckalloc (eoFrame.nline * sizeof (int)); + + eoFrame.cmd.listPtr = objPtr; + Tcl_IncrRefCount (eoFrame.cmd.listPtr); + eoFrame.data.eval.path = NULL; + /* * Increase the reference count of the List structure, 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. */ listRepPtr->refCount++; + line = 1; + for (i=0; i < eoFrame.nline; i++) { + eoFrame.line [i] = line; + w = Tcl_GetString (elements[i]); + TclAdvanceLines (&line, w, w + strlen(w)); + } + + iPtr->cmdFramePtr = &eoFrame; result = Tcl_EvalObjv(interp, listRepPtr->elemCount, &listRepPtr->elements, flags); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount (eoFrame.cmd.listPtr); + /* * If we are the last users of listRepPtr, free it. */ @@ -4209,14 +4571,91 @@ Tcl_EvalObjEx( } ckfree((char *) listRepPtr); } + + ckfree ((char*) eoFrame.line); + eoFrame.line = NULL; + eoFrame.nline = 0; + goto done; } } - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); + + /* + * 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 = TclEvalEx(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); + } + } + } } 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; @@ -4224,7 +4663,7 @@ Tcl_EvalObjEx( iPtr->varFramePtr = iPtr->rootFramePtr; } - result = TclCompEvalObj(interp, objPtr); + result = TclCompEvalObj(interp, objPtr, invoker, word); /* * If we are again at the top level, process any unusual return code diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a0aba43..414666a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.80 2006/11/15 20:08:43 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.81 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -230,6 +230,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) Tcl_Obj *varNamePtr = NULL; Tcl_Obj *optionVarNamePtr = NULL; int result; + Interp* iPtr = (Interp*) interp; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -244,7 +245,8 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) optionVarNamePtr = objv[3]; } - result = Tcl_EvalObjEx(interp, objv[1], 0); + /* TIP #280. Make invoking context available to caught script */ + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1); /* * We disable catch in interpreters where the limit has been exceeded. @@ -641,6 +643,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) { int result; register Tcl_Obj *objPtr; + Interp* iPtr = (Interp*) interp; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); @@ -648,7 +651,9 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT); + /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT, + iPtr->cmdFramePtr,1); } else { /* * More than one argument: concatenate them together with spaces @@ -657,7 +662,8 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) */ objPtr = Tcl_ConcatObj(objc-1, objv+1); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -1580,13 +1586,15 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; + Interp* iPtr = (Interp*) interp; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } - result = Tcl_EvalObjEx(interp, objv[1], 0); + /* TIP #280. Make invoking context available to initial script */ + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); @@ -1608,7 +1616,8 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) if (!value) { break; } - result = Tcl_EvalObjEx(interp, objv[4], 0); + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -1616,7 +1625,8 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) } break; } - result = Tcl_EvalObjEx(interp, objv[3], 0); + /* TIP #280. Make invoking context available to next script */ + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { @@ -1690,6 +1700,7 @@ 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 */ + Interp* iPtr = (Interp*) interp; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1813,7 +1824,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObjEx(interp, bodyPtr, 0); + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8519de8..712cbc0 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.95 2006/11/15 20:08:43 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.96 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -114,6 +114,10 @@ static int InfoDefaultCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoExistsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); +/* TIP #280 - New 'info' subcommand 'frame' */ +static int InfoFrameCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[]); static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, @@ -182,6 +186,7 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) { int thenScriptIndex = 0; /* "then" script to be evaled after * syntax check */ + Interp* iPtr = (Interp*) interp; int i, result, value; char *clause; i = 1; @@ -233,7 +238,9 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) i++; if (i >= objc) { if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + /* TIP #280. Make invoking context available to branch */ + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr,thenScriptIndex); } return TCL_OK; } @@ -267,9 +274,11 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + /* TIP #280. Make invoking context available to branch/else */ + return TclEvalObjEx(interp, objv[thenScriptIndex], 0, + iPtr->cmdFramePtr,thenScriptIndex); } - return Tcl_EvalObjEx(interp, objv[i], 0); + return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i); } /* @@ -358,15 +367,15 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) { static CONST char *subCmds[] = { "args", "body", "cmdcount", "commands", - "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", + "complete", "default", "exists", "frame", "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, IFrameIdx, IFunctionsIdx, + IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx }; @@ -405,6 +414,10 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) case IExistsIdx: result = InfoExistsCmd(clientData, interp, objc, objv); break; + case IFrameIdx: + /* TIP #280 - New method 'frame' */ + result = InfoFrameCmd(clientData, interp, objc, objv); + break; case IFunctionsIdx: result = InfoFunctionsCmd(clientData, interp, objc, objv); break; @@ -1073,6 +1086,255 @@ InfoExistsCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * 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; + + if (namePtr) { + /* Regular command. */ + 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); + } else { + /* Lambda execution. The lambda in question is stored + * in the clientData of the cmdPtr. See the #280 HACK + * in Tcl_ApplyObjCmd. There is no separate namespace + * to consider, if any is used it is part of the + * lambda term. + */ + + lv [lc ++] = Tcl_NewStringObj ("lambda",-1); + lv [lc ++] = ((Tcl_Obj*) procPtr->cmdPtr->clientData); + } + } + 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; +} + +/* + *---------------------------------------------------------------------- + * * InfoFunctionsCmd -- * * Called to implement the "info functions" command that returns the list diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 21a54e0..5a39466 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.142 2006/11/22 23:22:23 dkf Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.143 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2635,6 +2635,13 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; Tcl_RegExp regExpr = NULL; + 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 */ /* * If you add options that make -e and -g not unique prefixes of -exact or @@ -2734,15 +2741,21 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) stringObj = objv[i]; objc -= i + 1; objv += i + 1; + bidx = i+1; /* First after the match string */ /* * 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; + blist = objv[0]; if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; @@ -2956,6 +2969,52 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) */ matchFound: + 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; + + TclListLines (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;} + } + } + for (j = i + 1; ; j += 2) { if (j >= objc) { /* @@ -2970,7 +3029,15 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObjEx(interp, objv[j], 0); + /* 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); + } + } /* * Generate an error message if necessary. @@ -3110,6 +3177,7 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; + Interp* iPtr = (Interp*) interp; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); @@ -3124,7 +3192,8 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) if (!value) { break; } - result = Tcl_EvalObjEx(interp, objv[2], 0); + /* TIP #280. */ + result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -3142,6 +3211,37 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) return result; } +void +TclListLines(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; + } + } +} + /* * Local Variables: * mode: c diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index aa522c0..02bf071 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.92 2006/11/25 17:18:09 dkf Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.93 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -23,18 +23,31 @@ * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, - * Tcl_Interp *interp); + * Tcl_Interp *interp, int word); */ -#define CompileWord(envPtr, tokenPtr, interp) \ +#define CompileWord(envPtr, tokenPtr, interp, word) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ (tokenPtr)[1].size), (envPtr)); \ } else { \ + envPtr->line = mapPtr->loc [eclIndex].line [word]; \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); \ } +/* 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. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + /* * Convenience macro for use when compiling bodies of commands. The ANSI C * "prototype" for this macro is: @@ -121,7 +134,7 @@ static void FreeJumptableInfo(ClientData clientData); static int PushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, - int *simpleVarNamePtr, int *isScalarPtr); + int *simpleVarNamePtr, int *isScalarPtr, int line); /* * Flags bits used by PushVarName. @@ -174,6 +187,8 @@ TclCompileAppendCmd( Tcl_Token *varTokenPtr, *valueTokenPtr; int simpleVarName, isScalar, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -200,7 +215,8 @@ TclCompileAppendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar); + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); /* * We are doing an assignment, otherwise TclCompileSetCmd was called, so @@ -210,7 +226,7 @@ TclCompileAppendCmd( if (numWords > 2) { valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, 2); } /* @@ -310,6 +326,8 @@ TclCompileCatchCmd( int resultIndex, optsIndex, nameChars, range; int savedStackDepth = envPtr->currStackDepth; + DefineLineInformation; /* TIP #280 */ + /* * If syntax does not match what we expect for [catch], do not compile. * Let runtime checks determine if syntax has changed. @@ -383,6 +401,7 @@ TclCompileCatchCmd( * range so that errors in the substitution are not catched [Bug 219184] */ + envPtr->line = mapPtr->loc [eclIndex].line [1]; if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, cmdTokenPtr, interp); @@ -547,6 +566,8 @@ TclCompileDictCmd( const char *cmd; Proc *procPtr = envPtr->procPtr; + DefineLineInformation; /* TIP #280 */ + /* * There must be at least one argument after the command. */ @@ -603,7 +624,7 @@ TclCompileDictCmd( dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); for (i=1 ; icurrStackDepth; + DefineLineInformation; /* TIP #280 */ + if (numWords != 3 || procPtr == NULL) { return TCL_ERROR; } @@ -738,7 +761,7 @@ TclCompileDictCmd( * of errors at this point. */ - CompileWord(envPtr, dictTokenPtr, interp); + CompileWord(envPtr, dictTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr); emptyTargetOffset = CurrentOffset(envPtr); TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr); @@ -773,6 +796,7 @@ TclCompileDictCmd( * Compile the loop body itself. It should be stack-neutral. */ + envPtr->line = mapPtr->loc [eclIndex].line [4]; CompileBody(envPtr, bodyTokenPtr, interp); envPtr->currStackDepth = savedStackDepth + 1; TclEmitOpcode( INST_POP, envPtr); @@ -914,7 +938,7 @@ TclCompileDictCmd( keyTmpIndex = TclFindCompiledLocal(NULL, 0, 1, VAR_SCALAR, procPtr); for (i=0 ; i 3) { @@ -1003,8 +1027,8 @@ TclCompileDictCmd( } dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR, procPtr); - CompileWord(envPtr, keyTokenPtr, interp); - CompileWord(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, valueTokenPtr, interp, 4); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } @@ -1046,6 +1070,9 @@ TclCompileExprCmd( return TCL_ERROR; } + /* TIP #280 : Use the per-word line information of the current command. + */ + envPtr->line = envPtr->extCmdMapPtr->loc [envPtr->extCmdMapPtr->nuloc - 1].line [1]; firstWordPtr = TokenAfter(parsePtr->tokenPtr); TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); return TCL_OK; @@ -1082,6 +1109,8 @@ TclCompileForCmd( int bodyRange, nextRange; int savedStackDepth = envPtr->currStackDepth; + DefineLineInformation; /* TIP #280 */ + if (parsePtr->numWords != 5) { return TCL_ERROR; } @@ -1123,6 +1152,7 @@ TclCompileForCmd( * Inline compile the initial command. */ + envPtr->line = mapPtr->loc [eclIndex].line [1]; CompileBody(envPtr, startTokenPtr, interp); TclEmitOpcode(INST_POP, envPtr); @@ -1145,6 +1175,7 @@ TclCompileForCmd( */ bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange); + envPtr->line = mapPtr->loc [eclIndex].line [4]; CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, bodyRange); envPtr->currStackDepth = savedStackDepth + 1; @@ -1157,6 +1188,7 @@ TclCompileForCmd( envPtr->currStackDepth = savedStackDepth; nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange); + envPtr->line = mapPtr->loc [eclIndex].line [3]; CompileBody(envPtr, nextTokenPtr, interp); ExceptionRangeEnds(envPtr, nextRange); envPtr->currStackDepth = savedStackDepth + 1; @@ -1177,6 +1209,7 @@ TclCompileForCmd( testCodeOffset += 3; } + envPtr->line = mapPtr->loc [eclIndex].line [2]; envPtr->currStackDepth = savedStackDepth; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; @@ -1252,6 +1285,9 @@ TclCompileForeachCmd( int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; int savedStackDepth = envPtr->currStackDepth; + DefineLineInformation; /* TIP #280 */ + int bodyIndex; + /* * We parse the variable list argument words and create two arrays: * varcList[i] is number of variables in i-th var list @@ -1290,6 +1326,8 @@ TclCompileForeachCmd( return TCL_ERROR; } + bodyIndex = i-1; + /* * Allocate storage for the varcList and varvList arrays if necessary. */ @@ -1414,6 +1452,7 @@ TclCompileForeachCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { if ((i%2 == 0) && (i > 0)) { + envPtr->line = mapPtr->loc [eclIndex].line [i]; CompileTokens(envPtr, tokenPtr, interp); tempVar = (firstValueTemp + loopIndex); if (tempVar <= 255) { @@ -1445,6 +1484,7 @@ TclCompileForeachCmd( * Inline compile the loop body. */ + envPtr->line = mapPtr->loc [eclIndex].line [bodyIndex]; ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -1653,6 +1693,8 @@ TclCompileIfCmd( int boolVal; /* Value of static condition */ int compileScripts = 1; + DefineLineInformation; /* TIP #280 */ + /* * Only compile the "if" command if all arguments are simple words, in * order to insure correct substitution [Bug 219166] @@ -1728,6 +1770,7 @@ TclCompileIfCmd( compileScripts = 0; } } else { + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx]; Tcl_ResetResult(interp); TclCompileExprWords(interp, testTokenPtr, 1, envPtr); if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { @@ -1770,6 +1813,7 @@ TclCompileIfCmd( */ if (compileScripts) { + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx]; envPtr->currStackDepth = savedStackDepth; CompileBody(envPtr, tokenPtr, interp); } @@ -1857,6 +1901,7 @@ TclCompileIfCmd( * Compile the else command body. */ + envPtr->line = mapPtr->loc [eclIndex].line [wordIdx]; CompileBody(envPtr, tokenPtr, interp); } @@ -1948,6 +1993,8 @@ TclCompileIncrCmd( Tcl_Token *varTokenPtr, *incrTokenPtr; int simpleVarName, isScalar, localIndex, haveImmValue, immValue; + DefineLineInformation; /* TIP #280 */ + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { return TCL_ERROR; } @@ -1955,7 +2002,8 @@ TclCompileIncrCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX|TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar); + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); /* * If an increment is given, push it, but see first if it's a small @@ -1981,6 +2029,7 @@ TclCompileIncrCmd( PushLiteral(envPtr, word, numBytes); } } else { + envPtr->line = mapPtr->loc [eclIndex].line [2]; CompileTokens(envPtr, incrTokenPtr, interp); } } else { /* No incr amount given so use 1 */ @@ -2062,6 +2111,8 @@ TclCompileLappendCmd( Tcl_Token *varTokenPtr; int simpleVarName, isScalar, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + /* * If we're not in a procedure, don't compile. */ @@ -2091,7 +2142,8 @@ TclCompileLappendCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar); + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); /* * If we are doing an assignment, push the new value. In the no values @@ -2100,7 +2152,7 @@ TclCompileLappendCmd( if (numWords > 2) { Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, 2); } /* @@ -2164,6 +2216,8 @@ TclCompileLassignCmd( Tcl_Token *tokenPtr; int simpleVarName, isScalar, localIndex, numWords, idx; + DefineLineInformation; /* TIP #280 */ + numWords = parsePtr->numWords; /* * Check for command syntax error, but we'll punt that to runtime @@ -2176,7 +2230,7 @@ TclCompileLassignCmd( * Generate code to push list being taken apart by [lassign]. */ tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, 1); /* * Generate code to assign values from the list to variables @@ -2188,7 +2242,8 @@ TclCompileLassignCmd( * Generate the next variable name */ PushVarName(interp, tokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar); + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [idx+2]); /* * Emit instructions to get the idx'th item out of the list value on @@ -2269,6 +2324,8 @@ TclCompileLindexCmd( Tcl_Token *varTokenPtr; int i, numWords = parsePtr->numWords; + DefineLineInformation; /* TIP #280 */ + /* * Quit if too few args */ @@ -2291,13 +2348,13 @@ TclCompileLindexCmd( /* * All checks have been completed, and we have exactly this * construct: - * lindex + * lindex * This is best compiled as a push of the arbitrary value followed * by an "immediate lindex" which is the most efficient variety. */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr); return TCL_OK; } @@ -2313,7 +2370,7 @@ TclCompileLindexCmd( */ for (i=1 ; itokenPtr); for (i = 1; i < numWords; i++) { - CompileWord(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } TclEmitInstInt4(INST_LIST, numWords - 1, envPtr); @@ -2416,12 +2475,14 @@ TclCompileLlengthCmd( { Tcl_Token *varTokenPtr; + DefineLineInformation; /* TIP #280 */ + if (parsePtr->numWords != 2) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, varTokenPtr, interp); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode(INST_LIST_LENGTH, envPtr); return TCL_OK; } @@ -2482,6 +2543,8 @@ TclCompileLsetCmd( int isScalar; /* Flag == 1 if scalar, 0 if array */ int i; + DefineLineInformation; /* TIP #280 */ + /* * Check argument count. */ @@ -2504,7 +2567,8 @@ TclCompileLsetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar); + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); /* * Push the "index" args and the new element value. @@ -2512,7 +2576,7 @@ TclCompileLsetCmd( for (i=2 ; inumWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp); + CompileWord(envPtr, varTokenPtr, interp, i); } /* @@ -2632,6 +2696,8 @@ TclCompileRegexpCmd( int i, len, nocase, anchorLeft, anchorRight, start; char *str; + DefineLineInformation; /* TIP #280 */ + /* * We are only interested in compiling simple regexp cases. Currently * supported compile cases are: @@ -2793,7 +2859,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); if (anchorLeft && anchorRight && !nocase) { TclEmitOpcode(INST_STR_EQ, envPtr); @@ -2843,6 +2909,8 @@ TclCompileReturnCmd( int objc; Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + DefineLineInformation; /* TIP #280 */ + /* * Check for special case which can always be compiled: * return -options @@ -2858,8 +2926,8 @@ TclCompileReturnCmd( Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr); Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr); - CompileWord(envPtr, optsTokenPtr, interp); - CompileWord(envPtr, msgTokenPtr, interp); + CompileWord(envPtr, optsTokenPtr, interp, 2); + CompileWord(envPtr, msgTokenPtr, interp, 3); TclEmitOpcode(INST_RETURN_STK, envPtr); return TCL_OK; } @@ -2915,7 +2983,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp); + CompileWord(envPtr, wordTokenPtr, interp, numWords-1); } else { /* * No explict result argument, so default result is empty string. @@ -2996,6 +3064,8 @@ TclCompileSetCmd( Tcl_Token *varTokenPtr, *valueTokenPtr; int isAssignment, isScalar, simpleVarName, localIndex, numWords; + DefineLineInformation; /* TIP #280 */ + numWords = parsePtr->numWords; if ((numWords != 2) && (numWords != 3)) { return TCL_ERROR; @@ -3012,7 +3082,8 @@ TclCompileSetCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); PushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR, - &localIndex, &simpleVarName, &isScalar); + &localIndex, &simpleVarName, &isScalar, + mapPtr->loc [eclIndex].line [1]); /* * If we are doing an assignment, push the new value. @@ -3020,7 +3091,7 @@ TclCompileSetCmd( if (isAssignment) { valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp); + CompileWord(envPtr, valueTokenPtr, interp, 2); } /* @@ -3111,6 +3182,8 @@ TclCompileStringCmd( STR_WORDEND, STR_WORDSTART }; + DefineLineInformation; /* TIP #280 */ + if (parsePtr->numWords < 2) { /* * Fail at run time, not in compilation. @@ -3148,7 +3221,7 @@ TclCompileStringCmd( */ for (i = 0; i < 2; i++) { - CompileWord(envPtr, varTokenPtr, interp); + CompileWord(envPtr, varTokenPtr, interp, i); varTokenPtr = TokenAfter(varTokenPtr); } @@ -3170,7 +3243,7 @@ TclCompileStringCmd( */ for (i = 0; i < 2; i++) { - CompileWord(envPtr, varTokenPtr, interp); + CompileWord(envPtr, varTokenPtr, interp, i); varTokenPtr = TokenAfter(varTokenPtr); } @@ -3225,6 +3298,7 @@ TclCompileStringCmd( } PushLiteral(envPtr, str, length); } else { + envPtr->line = mapPtr->loc [eclIndex].line [i]; CompileTokens(envPtr, varTokenPtr, interp); } varTokenPtr = TokenAfter(varTokenPtr); @@ -3260,6 +3334,7 @@ TclCompileStringCmd( PushLiteral(envPtr, buf, len); return TCL_OK; } else { + envPtr->line = mapPtr->loc [eclIndex].line [2]; CompileTokens(envPtr, varTokenPtr, interp); } TclEmitOpcode(INST_STR_LEN, envPtr); @@ -3314,6 +3389,7 @@ TclCompileSwitchCmd( Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ + int *bodyLines; /* Array of line numbers for body list items */ int foundDefault; /* Flag to indicate whether a "default" clause * is present. */ @@ -3332,6 +3408,9 @@ TclCompileSwitchCmd( int isListedArms = 0; int i; + DefineLineInformation; /* TIP #280 */ + int valueIndex; + /* * Only handle the following versions: * switch -- word {pattern body ...} @@ -3347,6 +3426,7 @@ TclCompileSwitchCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); + valueIndex = 1; numWords = parsePtr->numWords-1; /* @@ -3380,6 +3460,7 @@ TclCompileSwitchCmd( } mode = Switch_Exact; foundMode = 1; + valueIndex++; continue; } else if ((size <= 5) && !memcmp(chrs, "-glob", size)) { if (foundMode) { @@ -3387,11 +3468,14 @@ TclCompileSwitchCmd( } mode = Switch_Glob; foundMode = 1; + valueIndex++; continue; } else if ((size <= 7) && !memcmp(chrs, "-nocase", size)) { noCase = 1; + valueIndex++; continue; } else if ((size == 2) && !memcmp(chrs, "--", 2)) { + valueIndex++; break; } @@ -3423,6 +3507,7 @@ TclCompileSwitchCmd( */ valueTokenPtr = tokenPtr; + /* valueIndex see previous loop */ tokenPtr = TokenAfter(tokenPtr); numWords--; @@ -3440,6 +3525,14 @@ TclCompileSwitchCmd( int isTokenBraced; CONST char *tokenStartPtr; + /* TIP #280: line of the pattern/action list, and start of list for + * when tracking the location. This list comes immediately after the + * value we switch on. + */ + + int bline = mapPtr->loc [eclIndex].line [valueIndex+1]; + CONST char* p; + /* * Test that we've got a suitable body list as a simple (i.e. braced) * word, and that the elements of the body are simple words too. This @@ -3449,6 +3542,7 @@ TclCompileSwitchCmd( if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { return TCL_ERROR; } + Tcl_DStringInit(&bodyList); Tcl_DStringAppend(&bodyList, tokenPtr[1].start, tokenPtr[1].size); if (Tcl_SplitList(NULL, Tcl_DStringValue(&bodyList), &numWords, @@ -3470,14 +3564,15 @@ TclCompileSwitchCmd( } isListedArms = 1; - bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); + bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords); + bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); + bodyLines = (int*) ckalloc(sizeof(int) * numWords); /* * Locate the start of the arms within the overall word. */ - tokenStartPtr = tokenPtr[1].start; + p = tokenStartPtr = tokenPtr[1].start; while (isspace(UCHAR(*tokenStartPtr))) { tokenStartPtr++; } @@ -3487,6 +3582,8 @@ TclCompileSwitchCmd( } else { isTokenBraced = 0; } + + /* TIP #280. Count lines within the literal list */ for (i=0 ; i= tokenPtr[1].start+tokenPtr[1].size) { @@ -3534,6 +3642,7 @@ TclCompileSwitchCmd( if (tokenStartPtr != tokenPtr[1].start+tokenPtr[1].size) { ckfree((char *) bodyToken); ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); return TCL_ERROR; } @@ -3549,7 +3658,10 @@ TclCompileSwitchCmd( return TCL_ERROR; } else { - bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); + /* Multi-word definition of patterns & actions */ + + bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords); + bodyLines = (int*) ckalloc(sizeof(int) * numWords); bodyTokenArray = NULL; for (i=0 ; itype != TCL_TOKEN_SIMPLE_WORD || tokenPtr->numComponents != 1) { ckfree((char *) bodyToken); + ckfree((char *) bodyLines); return TCL_ERROR; } bodyToken[i] = tokenPtr+1; + /* #280 Copy line information from regular cmd info */ + bodyLines[i] = mapPtr->loc [eclIndex].line [valueIndex+1+i]; tokenPtr = TokenAfter(tokenPtr); } } @@ -3576,6 +3691,7 @@ TclCompileSwitchCmd( if (bodyToken[numWords-1]->size == 1 && bodyToken[numWords-1]->start[0] == '-') { ckfree((char *) bodyToken); + ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } @@ -3587,6 +3703,7 @@ TclCompileSwitchCmd( * First, we push the value we're matching against on the stack. */ + envPtr->line = mapPtr->loc [eclIndex].line [valueIndex]; CompileTokens(envPtr, valueTokenPtr, interp); /* @@ -3707,6 +3824,8 @@ TclCompileSwitchCmd( * Compile the body of the arm. */ + /* #280 */ + envPtr->line = bodyLines [i+1]; TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); /* @@ -3757,6 +3876,7 @@ TclCompileSwitchCmd( ckfree((char *) finalFixups); ckfree((char *) bodyToken); + ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } @@ -3856,6 +3976,8 @@ TclCompileSwitchCmd( TclEmitOpcode(INST_POP, envPtr); envPtr->currStackDepth = savedStackDepth + 1; + /* #280 */ + envPtr->line = bodyLines [i+1]; TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr); if (!foundDefault) { @@ -3865,7 +3987,13 @@ TclCompileSwitchCmd( fixupTargetArray[nextArmFixupIndex] = CurrentOffset(envPtr); } } + + /* + * Clean up all our temporary space and return. + */ + ckfree((char *) bodyToken); + ckfree((char *) bodyLines); if (bodyTokenArray != NULL) { ckfree((char *) bodyTokenArray); } @@ -4071,6 +4199,8 @@ TclCompileWhileCmd( Tcl_Obj *boolObj; int boolVal; + DefineLineInformation; /* TIP #280 */ + if (parsePtr->numWords != 3) { return TCL_ERROR; } @@ -4150,6 +4280,7 @@ TclCompileWhileCmd( * Compile the loop body. */ + envPtr->line = mapPtr->loc [eclIndex].line [2]; bodyCodeOffset = ExceptionRangeStarts(envPtr, range); CompileBody(envPtr, bodyTokenPtr, interp); ExceptionRangeEnds(envPtr, range); @@ -4169,6 +4300,7 @@ TclCompileWhileCmd( testCodeOffset += 3; } envPtr->currStackDepth = savedStackDepth; + envPtr->line = mapPtr->loc [eclIndex].line [1]; TclCompileExprWords(interp, testTokenPtr, 1, envPtr); envPtr->currStackDepth = savedStackDepth + 1; @@ -4234,7 +4366,8 @@ PushVarName( int flags, /* TCL_CREATE_VAR or TCL_NO_LARGE_INDEX */ int *localIndexPtr, /* Must not be NULL */ int *simpleVarNamePtr, /* Must not be NULL */ - int *isScalarPtr) /* Must not be NULL */ + int *isScalarPtr, /* Must not be NULL */ + int line) /* line the token starts on */ { register CONST char *p; CONST char *name, *elName; @@ -4418,6 +4551,7 @@ PushVarName( if (elName != NULL) { if (elNameChars) { + envPtr->line = line; TclCompileTokens(interp, elemTokenPtr, elemTokenCount, envPtr); } else { PushLiteral(envPtr, "", 0); @@ -4428,6 +4562,7 @@ PushVarName( * The var name isn't simple: compile and push it. */ + envPtr->line = line; CompileTokens(envPtr, varTokenPtr, interp); } @@ -4468,12 +4603,13 @@ TclCompileInvertOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode(INST_BITNOT, envPtr); return TCL_OK; } @@ -4485,12 +4621,13 @@ TclCompileNotOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 2) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode(INST_LNOT, envPtr); return TCL_OK; } @@ -4502,6 +4639,7 @@ TclCompileAddOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4509,10 +4647,10 @@ TclCompileAddOpCmd( return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_ADD, envPtr); } return TCL_OK; @@ -4525,6 +4663,7 @@ TclCompileMulOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4532,10 +4671,10 @@ TclCompileMulOpCmd( return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_MULT, envPtr); } return TCL_OK; @@ -4548,6 +4687,7 @@ TclCompileAndOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4555,10 +4695,10 @@ TclCompileAndOpCmd( return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_BITAND, envPtr); } return TCL_OK; @@ -4571,6 +4711,7 @@ TclCompileOrOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4578,10 +4719,10 @@ TclCompileOrOpCmd( return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_BITOR, envPtr); } return TCL_OK; @@ -4594,6 +4735,7 @@ TclCompileXorOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4601,10 +4743,10 @@ TclCompileXorOpCmd( return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_BITXOR, envPtr); } return TCL_OK; @@ -4617,6 +4759,7 @@ TclCompilePowOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4624,10 +4767,10 @@ TclCompilePowOpCmd( return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); } for (; words>2 ; words--) { TclEmitOpcode(INST_EXPON, envPtr); @@ -4642,20 +4785,21 @@ TclCompileMinusOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); if (parsePtr->numWords == 2) { TclEmitOpcode(INST_UMINUS, envPtr); return TCL_OK; } for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_SUB, envPtr); } return TCL_OK; @@ -4668,6 +4812,7 @@ TclCompileDivOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ int words; if (parsePtr->numWords == 1) { @@ -4675,15 +4820,15 @@ TclCompileDivOpCmd( } else if (parsePtr->numWords == 2) { PushLiteral(envPtr, "1.0", 3); tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); TclEmitOpcode(INST_DIV, envPtr); return TCL_OK; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); for (words=2 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); TclEmitOpcode(INST_DIV, envPtr); } return TCL_OK; @@ -4696,14 +4841,15 @@ TclCompileLshiftOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_LSHIFT, envPtr); return TCL_OK; } @@ -4715,14 +4861,15 @@ TclCompileRshiftOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_RSHIFT, envPtr); return TCL_OK; } @@ -4734,14 +4881,15 @@ TclCompileModOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_MOD, envPtr); return TCL_OK; } @@ -4753,14 +4901,15 @@ TclCompileNeqOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_NEQ, envPtr); return TCL_OK; } @@ -4772,14 +4921,15 @@ TclCompileStrneqOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_STR_NEQ, envPtr); return TCL_OK; } @@ -4791,14 +4941,15 @@ TclCompileInOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_LIST_IN, envPtr); return TCL_OK; } @@ -4810,14 +4961,15 @@ TclCompileNiOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords != 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_LIST_NOT_IN, envPtr); return TCL_OK; } @@ -4829,14 +4981,15 @@ TclCompileLessOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { PushLiteral(envPtr, "1", 1); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_LT, envPtr); } else if (envPtr->procPtr == NULL) { /* @@ -4850,15 +5003,15 @@ TclCompileLessOpCmd( int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); TclEmitOpcode(INST_LT, envPtr); for (words=3 ; wordsnumWords ;) { TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } @@ -4878,14 +5031,15 @@ TclCompileLeqOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { PushLiteral(envPtr, "1", 1); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_LE, envPtr); } else if (envPtr->procPtr == NULL) { /* @@ -4899,15 +5053,15 @@ TclCompileLeqOpCmd( int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); TclEmitOpcode(INST_LE, envPtr); for (words=3 ; wordsnumWords ;) { TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); if (++words < parsePtr->numWords) { TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } @@ -4927,14 +5081,15 @@ TclCompileGreaterOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { PushLiteral(envPtr, "1", 1); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_GT, envPtr); } else if (envPtr->procPtr == NULL) { /* @@ -4948,15 +5103,15 @@ TclCompileGreaterOpCmd( int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); TclEmitOpcode(INST_GT, envPtr); for (words=3 ; wordsnumWords ;) { TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,words); if (++words < parsePtr->numWords) { TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } @@ -4976,14 +5131,15 @@ TclCompileGeqOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { PushLiteral(envPtr, "1", 1); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_GE, envPtr); } else if (envPtr->procPtr == NULL) { /* @@ -4997,15 +5153,15 @@ TclCompileGeqOpCmd( int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); TclEmitOpcode(INST_GE, envPtr); for (words=3 ; wordsnumWords ;) { TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } @@ -5025,14 +5181,15 @@ TclCompileEqOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { PushLiteral(envPtr, "1", 1); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_EQ, envPtr); } else if (envPtr->procPtr == NULL) { /* @@ -5046,15 +5203,15 @@ TclCompileEqOpCmd( int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); TclEmitOpcode(INST_EQ, envPtr); for (words=3 ; wordsnumWords ;) { TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } @@ -5074,14 +5231,15 @@ TclCompileStreqOpCmd( CompileEnv *envPtr) { Tcl_Token *tokenPtr; + DefineLineInformation; /* TIP #280 */ if (parsePtr->numWords < 3) { PushLiteral(envPtr, "1", 1); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitOpcode(INST_STR_EQ, envPtr); } else if (envPtr->procPtr == NULL) { /* @@ -5095,15 +5253,15 @@ TclCompileStreqOpCmd( int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,1); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp,2); TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); TclEmitOpcode(INST_STR_EQ, envPtr); for (words=3 ; wordsnumWords ;) { TclEmitInstInt4(INST_LOAD_SCALAR4, tmpIndex, envPtr); tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp); + CompileWord(envPtr, tokenPtr, interp, words); if (++words < parsePtr->numWords) { TclEmitInstInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2ca5b0a..8be348c 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.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: tclCompExpr.c,v 1.37 2006/11/15 20:08:43 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.38 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1261,6 +1261,10 @@ TclCompileExpr( if (TCL_OK != Tcl_ParseExpr(interp, script, numBytes, &parse)) { return TCL_ERROR; } + + /* TIP #280 : Track Lines within the expression */ + TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start); + CompileSubExpr(interp, parse.tokenPtr, &needsNumConversion, envPtr); if (needsNumConversion) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index fe587ef..2683cd2 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.100 2006/11/15 20:08:43 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.101 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -392,6 +392,13 @@ static void RecordByteCodeStats(ByteCode *codePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +/* TIP #280 : Helper for building the per-word line information of all + * compiled commands */ +static void EnterCmdWordData( + ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr, + CONST char* cmd, int len, int numWords, int line, + int** lines); + /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. @@ -438,9 +445,7 @@ TclSetByteCodeFromAny( CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ ClientData clientData) /* Hook procedure private data. */ { -#ifdef TCL_COMPILE_DEBUG Interp *iPtr = (Interp *) interp; -#endif /*TCL_COMPILE_DEBUG*/ CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); @@ -461,7 +466,16 @@ TclSetByteCodeFromAny( #endif stringPtr = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, stringPtr, length); + + /* + * 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, stringPtr, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); TclCompileScript(interp, stringPtr, length, &compEnv); /* @@ -647,6 +661,7 @@ TclCleanupByteCode( register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; + Interp* iPtr = (Interp*) interp; int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; register Tcl_Obj **objArrayPtr, *objPtr; @@ -745,6 +760,36 @@ TclCleanupByteCode( auxDataPtr++; } + /* + * 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); + } + } + TclHandleRelease(codePtr->interpHandle); ckfree((char *) codePtr); } @@ -773,7 +818,10 @@ TclInitCompileEnv( register CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ char *stringPtr, /* The source string to be compiled. */ - int numBytes) /* Number of bytes in source string. */ + int numBytes, /* Number of bytes in source string. */ + CONST CmdFrame* invoker, /* Location context invoking the bcc */ + int word) /* Index of the word in that context + * getting compiled */ { Interp *iPtr = (Interp *) interp; @@ -807,6 +855,72 @@ TclInitCompileEnv( envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; + /* + * 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); + } + } + } + } + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; @@ -934,6 +1048,29 @@ TclWordKnownAtCompileTime( return 1; } +int +TclWordSimpleExpansion( + Tcl_Token *tokenPtr) /* Points to Tcl_Token we should check */ +{ + int numComponents = tokenPtr->numComponents; + + if (tokenPtr->type != TCL_TOKEN_EXPAND_WORD) { + return 0; + } + tokenPtr++; + while (numComponents--) { + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + break; + + default: + return 0; + } + tokenPtr++; + } + return 1; +} + /* *---------------------------------------------------------------------- * @@ -980,6 +1117,11 @@ TclCompileScript( int commandLength, objIndex, code; Tcl_DString ds; + /* TIP #280 */ + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + int* wlines; + int wlineat, cmdLine; + Tcl_DStringInit(&ds); if (numBytes < 0) { @@ -1002,6 +1144,7 @@ TclCompileScript( p = script; bytesLeft = numBytes; gotParse = 0; + cmdLine = envPtr->line; do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { /* Compile bytecodes to report the parse error at runtime */ @@ -1047,7 +1190,24 @@ TclCompileScript( } gotParse = 1; if (parse.numWords > 0) { - int expand = 0; + int expand = 0; /* Set if there are dynamic expansions + * to handle */ + int eliterals = 0; /* Set if there are literal expansions + * to handle. Actually the number of + * words in the expanded literals. */ + int* exp = NULL; /* For literal expansions, #words in the + * expansion. Only valid if the + * associated expLen[] value is not + * NULL. Can be 0, expansion to nothing */ + int** expLen = NULL; /* Array of array of integers. Each + * array holds the lengths of the items + * in the expanded list. NULL indicates + * unexpanded words, or dynamically + * expanded words. */ + char*** expItem = NULL; /* Array of arrays of strings, holding + * pointers to the list elements, inside + * of the parsed script. No copies. For + * NULL, see expLen */ /* * If not the first command, pop the previous command's result @@ -1092,19 +1252,110 @@ TclCompileScript( #endif /* - * Check whether expansion has been requested for any of the words + * Check whether expansion has been requested for any of the + * words. NOTE: If a word to be expanded is actually a literal + * list we will do the expansion here, directly manipulating the + * token array. + * + * Due to the search for literal expansions it is not possible + * (anymore) to abort when a dynamic expansion is found. There + * might be a literal one coming after. */ + exp = (int*) ckalloc (sizeof(int) * parse.numWords); + expLen = (int**) ckalloc (sizeof(int*) * parse.numWords); + expItem = (char***) ckalloc (sizeof(char**) * parse.numWords); + for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + exp [wordIdx] = -1; + expLen [wordIdx] = NULL; + expItem [wordIdx] = NULL; + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - TclEmitOpcode(INST_EXPAND_START, envPtr); - break; + if (TclWordSimpleExpansion(tokenPtr)) { + CONST char* start = (tokenPtr+1)->start; + CONST char* end = ((tokenPtr+tokenPtr->numComponents)->start + + (tokenPtr+tokenPtr->numComponents)->size); + + TclMarkList (interp, start, end, + &(exp [wordIdx]), + &(expLen [wordIdx]), + &(expItem [wordIdx])); + + eliterals += exp [wordIdx] ? exp[wordIdx] : 1; + + } else if (!expand) { + expand = 1; + TclEmitOpcode(INST_EXPAND_START, envPtr); + } + } + } + + if (eliterals) { + Tcl_Token* copy = parse.tokenPtr; + int new; + int objIdx; + + parse.tokensAvailable += eliterals + eliterals; + /* eliterals times 2 - simple_word, and text tokens */ + + parse.tokenPtr = (Tcl_Token*) ckalloc (sizeof(Tcl_Token) * parse.tokensAvailable); + parse.numTokens = 0; + + for (objIdx = 0, wordIdx = 0, tokenPtr = copy, new = 0; + wordIdx < parse.numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents+1)) { + if (expLen[wordIdx]) { + /* Expansion of a simple literal. We already have the + * list elements which become the words. Now we `just` + * have to create their tokens. The token array + * already has the proper size to contain them all. + */ + + int k; + for (k = 0; k < exp[wordIdx]; k++) { + Tcl_Token* t = &parse.tokenPtr [objIdx]; + t->type = TCL_TOKEN_SIMPLE_WORD; + t->start = expItem [wordIdx][k]; + t->size = expLen [wordIdx][k]; + t->numComponents = 1; + t++; + + t->type = TCL_TOKEN_TEXT; + t->start = expItem [wordIdx][k]; + t->size = expLen [wordIdx][k]; + t->numComponents = 0; + + objIdx += 2; + new ++; + } + + ckfree ((char*) expLen [wordIdx]); + ckfree ((char*) expItem[wordIdx]); + } else { + /* Regular word token. Copy as is, including subtree. */ + + int k; + new ++; + for (k=0;k<=tokenPtr->numComponents;k++) { + parse.tokenPtr [objIdx++] = tokenPtr[k]; + } + } + } + parse.numTokens = objIdx; + parse.numWords = new; + + if (copy != parse.staticTokens) { + ckfree ((char*) copy); } } + ckfree ((char*) exp); + ckfree ((char*) expLen); + ckfree ((char*) expItem); + envPtr->numCommands++; currCmdIndex = (envPtr->numCommands - 1); lastTopLevelCmdIndex = currCmdIndex; @@ -1112,6 +1363,19 @@ TclCompileScript( EnterCmdStartData(envPtr, currCmdIndex, (parse.commandStart - envPtr->source), startCodeOffset); + /* 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; + /* * Each iteration of the following loop compiles one word from the * command. @@ -1121,6 +1385,7 @@ TclCompileScript( wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + envPtr->line = eclPtr->loc [wlineat].line [wordIdx]; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * The word is not a simple string of characters. @@ -1233,7 +1498,7 @@ TclCompileScript( tokenPtr[1].start, tokenPtr[1].size); } TclEmitPush(objIndex, envPtr); - } + } /* for loop */ /* * Emit an invoke instruction for the command. We skip this if a @@ -1276,6 +1541,12 @@ TclCompileScript( EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; + + /* 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; } /* end if parse.numWords > 0 */ /* @@ -1285,6 +1556,8 @@ TclCompileScript( next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; + /* TIP #280 : Track lines in the just compiled command */ + TclAdvanceLines (&cmdLine, parse.commandStart, p); Tcl_FreeParse(&parse); gotParse = 0; } while (bytesLeft > 0); @@ -1721,6 +1994,7 @@ TclInitByteCodeObj( int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; int i; + int new; Interp *iPtr; iPtr = envPtr->iPtr; @@ -1830,6 +2104,14 @@ TclInitByteCodeObj( TclFreeIntRep(objPtr); objPtr->internalRep.otherValuePtr = (void *) codePtr; objPtr->typePtr = &tclByteCodeType; + + /* 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; } /* @@ -2108,6 +2390,96 @@ EnterCmdExtentData( /* *---------------------------------------------------------------------- + * 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, NULL) + ? wordLine + : -1); + ePtr->line [wordIdx] = wordLine; + last = tokenPtr->start; + } + + *wlines = wwlines; + eclPtr->nuloc ++; +} + +/* + *---------------------------------------------------------------------- * * TclCreateExceptRange -- * diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 21871aa..b5416cd 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.61 2005/11/30 14:59:40 dkf Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.62 2006/11/28 22:20:28 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -114,6 +114,31 @@ typedef struct CmdLocation { } CmdLocation; /* + * 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; + +/* * CompileProcs need the ability to record information during compilation that * can be used by bytecode instructions during execution. The AuxData * structure provides this "auxiliary data" mechanism. An arbitrary number of @@ -253,6 +278,12 @@ typedef struct CompileEnv { /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ + /* 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. */ } CompileEnv; /* @@ -788,7 +819,8 @@ MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompilation(void); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, - CompileEnv *envPtr, char *string, int numBytes); + CompileEnv *envPtr, char *string, int numBytes, + CONST CmdFrame* invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); #ifdef TCL_COMPILE_STATS @@ -819,6 +851,7 @@ MODULE_SCOPE int TclCompileVariableCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr); MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); +MODULE_SCOPE int TclWordSimpleExpansion(Tcl_Token *tokenPtr); /* *---------------------------------------------------------------- diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 660a989..3a55669 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.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: tclDictObj.c,v 1.45 2006/11/15 20:08:44 dgp Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.46 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2159,6 +2159,7 @@ DictForCmd( int objc, Tcl_Obj *CONST *objv) { + Interp* iPtr = (Interp*) interp; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch search; @@ -2178,9 +2179,9 @@ DictForCmd( "must have exactly two variable names", -1)); return TCL_ERROR; } - keyVarObj = varv[0]; - valueVarObj = varv[1]; - scriptObj = objv[4]; + keyVarObj = varv[0]; + valueVarObj = varv[1]; + scriptObj = objv[4]; if (Tcl_DictObjFirst(interp, objv[3], &search, &keyObj, &valueObj, &done) != TCL_OK) { @@ -2222,7 +2223,8 @@ DictForCmd( break; } - result = Tcl_EvalObjEx(interp, scriptObj, 0); + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 4); if (result == TCL_CONTINUE) { result = TCL_OK; } else if (result != TCL_OK) { @@ -2395,6 +2397,7 @@ DictFilterCmd( int objc, Tcl_Obj *CONST *objv) { + Interp* iPtr = (Interp*) interp; static CONST char *filters[] = { "key", "script", "value", NULL }; @@ -2545,7 +2548,8 @@ DictFilterCmd( goto abnormalResult; } - result = Tcl_EvalObjEx(interp, scriptObj, 0); + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 5); switch (result) { case TCL_OK: boolObj = Tcl_GetObjResult(interp); @@ -2761,6 +2765,7 @@ DictWithCmd( int objc, Tcl_Obj *CONST *objv) { + Interp* iPtr = (Interp*) interp; Tcl_Obj *dictPtr, *keysPtr, *keyPtr, *valPtr, **keyv, *leafPtr; Tcl_DictSearch s; Tcl_InterpState state; @@ -2816,7 +2821,8 @@ DictWithCmd( * Execute the body. */ - result = Tcl_EvalObjEx(interp, objv[objc-1], 0); + /* TIP #280. Make invoking context available to loop body */ + result = TclEvalObjEx(interp, objv[objc-1], 0, iPtr->cmdFramePtr, objc-1); if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")"); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c3808f5..d2d802a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.253 2006/11/27 15:10:45 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.254 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -784,7 +784,8 @@ Tcl_ExprObj( } } if (objPtr->typePtr != &tclByteCodeType) { - TclInitCompileEnv(interp, &compEnv, string, length); + /* TIP #280 : No invoker (yet) - Expression compilation */ + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); result = TclCompileExpr(interp, string, length, &compEnv); /* @@ -914,7 +915,9 @@ Tcl_ExprObj( int TclCompEvalObj( Tcl_Interp *interp, - Tcl_Obj *objPtr) + Tcl_Obj *objPtr, + CONST CmdFrame* invoker, + int word) { register Interp *iPtr = (Interp *) interp; register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ @@ -946,7 +949,17 @@ TclCompEvalObj( if (objPtr->typePtr != &tclByteCodeType) { recompileObj: iPtr->errorLine = 1; + + /* 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; result = tclByteCodeType.setFromAnyProc(interp, objPtr); + iPtr->invokeCmdFramePtr = NULL; if (result != TCL_OK) { iPtr->numLevels--; return result; @@ -1180,6 +1193,9 @@ TclExecuteByteCode( int result = TCL_OK; /* Return code returned after execution. */ + /* TIP #280 : Structures for tracking lines */ + CmdFrame bcFrame; + /* * Locals - variables that are used within opcodes or bounded sections of * the file (jumps between opcodes within a family). @@ -1212,6 +1228,24 @@ TclExecuteByteCode( } initStackTop = tosPtr - eePtr->stackPtr; + /* 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; + #ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); @@ -1788,12 +1822,18 @@ TclExecuteByteCode( /* * Finally, let TclEvalObjvInternal handle the command. + * + * TIP #280 : Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. */ + bcFrame.data.tebc.pc = pc; + iPtr->cmdFramePtr = &bcFrame; DECACHE_STACK_INFO(); /*Tcl_ResetResult(interp);*/ result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); CACHE_STACK_INFO(); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; /* * If the old stack is going to be released, it is safe to do so @@ -1853,7 +1893,13 @@ TclExecuteByteCode( objPtr = *tosPtr; DECACHE_STACK_INFO(); - result = TclCompEvalObj(interp, objPtr); + + /* 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); CACHE_STACK_INFO(); if (result == TCL_OK) { /* @@ -6386,7 +6432,7 @@ IllegalExprOperandType( /* *---------------------------------------------------------------------- * - * GetSrcInfoForPc -- + * TclGetSrcInfoForPc, GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -6407,6 +6453,61 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ +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. + */ + } +} + static char * GetSrcInfoForPc( unsigned char *pc, /* The program counter value for which to diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index f10c757..affc185 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.137 2006/11/15 20:08:44 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.138 2006/11/28 22:20:28 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1806,6 +1806,9 @@ Tcl_FSEvalFileEx( iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); + /* TIP #280 Force the evaluator to open a frame for a sourced + * file. */ + iPtr->evalFlags |= TCL_EVAL_FILE; result = Tcl_EvalEx(interp, string, length, 0); /* diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 7abc31b..bf5158f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -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.decls,v 1.104 2006/11/12 23:15:40 dkf Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.105 2006/11/28 22:20:28 andreas_kupries Exp $ library tcl @@ -804,7 +804,8 @@ declare 183 generic { # Added in tcl8.5a5 for compiler/executor experimentation. # declare 197 generic { - int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr) + int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr, + CONST CmdFrame* invoker, int word) } declare 198 generic { diff --git a/generic/tclInt.h b/generic/tclInt.h index 116846a..0fb2ebf 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.298 2006/11/23 15:24:29 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.299 2006/11/28 22:20:29 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -936,6 +936,111 @@ typedef struct CallFrame { #define FRAME_IS_PROC 0x1 /* + * 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 */ + +/* *---------------------------------------------------------------- * Data structures and procedures related to TclHandles, which are a very * lightweight method of preserving enough information to determine if an @@ -1575,6 +1680,30 @@ typedef struct Interp { * NULL), takes precedence over a POSIX error * code returned by a channel operation. */ + /* 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. + */ /* * TIP #268. The currently active selection mode, i.e. the package require * preferences. @@ -1640,6 +1769,8 @@ typedef struct InterpList { */ #define TCL_ALLOW_EXCEPTIONS 4 +#define TCL_EVAL_FILE 2 +#define TCL_EVAL_CTX 8 /* * Flag bits for Interp structures: @@ -2071,6 +2202,8 @@ MODULE_SCOPE char tclEmptyString; *---------------------------------------------------------------- */ +MODULE_SCOPE void TclAdvanceLines(int* line, CONST char* start, + CONST char* end); MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj); MODULE_SCOPE double TclBignumToDouble(mp_int *bignum); @@ -2086,6 +2219,12 @@ MODULE_SCOPE void TclCleanupLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE int TclDoubleDigits(char *buf, double value, int *signum); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); +/* TIP #280 - Modified token based evulation, with line information */ +MODULE_SCOPE int TclEvalEx (Tcl_Interp *interp, CONST char *script, + int numBytes, int flags, int line); +MODULE_SCOPE int TclEvalObjEx(Tcl_Interp *interp, + register Tcl_Obj *objPtr, int flags, + CONST CmdFrame* invoker, int word); MODULE_SCOPE void TclExpandTokenArray(Tcl_Parse *parsePtr); MODULE_SCOPE int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -2129,6 +2268,7 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, CONST char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); +MODULE_SCOPE void TclGetSrcInfoForPc (CmdFrame* cfPtr); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); @@ -2156,6 +2296,9 @@ MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *CONST indexArray[]); +/* TIP #280 */ +MODULE_SCOPE void TclListLines (CONST char* listStr, int line, + int n, int* lines); MODULE_SCOPE int TclLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, int symc, CONST char *symbols[], Tcl_PackageInitProc **procPtrs[], @@ -2167,6 +2310,9 @@ MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *CONST indexArray[], Tcl_Obj *valuePtr); +MODULE_SCOPE int TclMarkList (Tcl_Interp *interp, CONST char *list, + CONST char* end, int *argcPtr, + CONST int** argszPtr, CONST char ***argvPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); @@ -2261,7 +2407,7 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - int count, int *tokensLeftPtr); + int count, int *tokensLeftPtr, int line); MODULE_SCOPE void TclTransferResult(Tcl_Interp *sourceInterp, int result, Tcl_Interp *targetInterp); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); @@ -3207,6 +3353,10 @@ MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum, #include "tclIntPlatDecls.h" #include "tclTomMathDecls.h" + + +MODULE_SCOPE void TclPrintTokens (Tcl_Token* token, int words, int level); + #endif /* _TCLINT */ /* diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 442d500..97bb498 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -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: tclIntDecls.h,v 1.95 2006/11/15 14:58:27 dgp Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.96 2006/11/28 22:20:29 andreas_kupries Exp $ */ #ifndef _TCLINTDECLS @@ -867,7 +867,8 @@ EXTERN struct tm * TclpGmtime (CONST time_t * clock); #define TclCompEvalObj_TCL_DECLARED /* 197 */ EXTERN int TclCompEvalObj (Tcl_Interp * interp, - Tcl_Obj * objPtr); + Tcl_Obj * objPtr, CONST CmdFrame* invoker, + int word); #endif #ifndef TclObjGetFrame_TCL_DECLARED #define TclObjGetFrame_TCL_DECLARED @@ -1237,7 +1238,7 @@ typedef struct TclIntStubs { void *reserved194; void *reserved195; void *reserved196; - int (*tclCompEvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr); /* 197 */ + int (*tclCompEvalObj) (Tcl_Interp * interp, Tcl_Obj * objPtr, CONST CmdFrame* invoker, int word); /* 197 */ int (*tclObjGetFrame) (Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr); /* 198 */ void *reserved199; int (*tclpObjRemoveDirectory) (Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr); /* 200 */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ccdef95..0bd79c4 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.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: tclInterp.c,v 1.69 2006/11/02 16:39:06 dkf Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.70 2006/11/28 22:20:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2484,7 +2484,9 @@ SlaveEval( Tcl_AllowExceptions(slaveInterp); if (objc == 1) { - result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); + /* TIP #280 : Make invoker available to eval'd script */ + Interp* iPtr = (Interp*) interp; + result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0); } else { objPtr = Tcl_ConcatObj(objc, objv); Tcl_IncrRefCount(objPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 645943a..91ab1a8 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,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.119 2006/11/15 20:08:44 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.120 2006/11/28 22:20:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -3441,7 +3441,9 @@ NamespaceEvalCmd( framePtr->objv = objv; if (objc == 4) { - result = Tcl_EvalObjEx(interp, objv[3], 0); + /* TIP #280 : Make invoker available to eval'd script */ + Interp* iPtr = (Interp*) interp; + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3); } else { /* * More than one argument: concatenate them together with spaces @@ -3450,7 +3452,8 @@ NamespaceEvalCmd( */ objPtr = Tcl_ConcatObj(objc-3, objv+3); - result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); + /* TIP #280. Make invoking context available to eval'd script */ + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); } if (result == TCL_ERROR) { diff --git a/generic/tclParse.c b/generic/tclParse.c index d8a2655..07b88c6 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.48 2006/11/03 00:34:52 hobbs Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.49 2006/11/28 22:20:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1460,7 +1460,7 @@ Tcl_ParseVar( return "$"; } - code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL); + code = TclSubstTokens(interp, parse.tokenPtr, parse.numTokens, NULL, 1); if (code != TCL_OK) { return NULL; } @@ -1973,7 +1973,7 @@ Tcl_SubstObj( endTokenPtr = parse.tokenPtr + parse.numTokens; tokensLeft = parse.numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, - &tokensLeft); + &tokensLeft, 1); if (code == TCL_OK) { Tcl_FreeParse(&parse); if (errMsg != NULL) { @@ -2015,7 +2015,7 @@ Tcl_SubstObj( } code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, - &tokensLeft); + &tokensLeft, 1); } } @@ -2050,9 +2050,10 @@ TclSubstTokens( * evaluate and concatenate. */ int count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ - int *tokensLeftPtr) /* If not NULL, points to memory where an + int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ + int line) /* The line the script starts on. */ { Tcl_Obj *result; int code = TCL_OK; @@ -2092,8 +2093,9 @@ TclSubstTokens( iPtr->numLevels++; code = TclInterpReady(interp); if (code == TCL_OK) { - code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, - 0); + /* TIP #280: Transfer line information to nested command */ + code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, + 0, line); } iPtr->numLevels--; appendObj = Tcl_GetObjResult(interp); @@ -2110,7 +2112,7 @@ TclSubstTokens( */ code = TclSubstTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1, NULL); + tokenPtr->numComponents - 1, NULL, line); arrayIndex = Tcl_GetObjResult(interp); Tcl_IncrRefCount(arrayIndex); } @@ -2362,6 +2364,51 @@ TclIsLocalScalar( return 1; } + + + + + + #define TCL_TOKEN_WORD 1 +#define TCL_TOKEN_SIMPLE_WORD 2 +#define TCL_TOKEN_TEXT 4 +#define TCL_TOKEN_BS 8 +#define TCL_TOKEN_COMMAND 16 +#define TCL_TOKEN_VARIABLE 32 +#define TCL_TOKEN_SUB_EXPR 64 +#define TCL_TOKEN_OPERATOR 128 +#define TCL_TOKEN_EXPAND_WORD 256 + +static void +TclPrintToken (Tcl_Token* token, int idx, int level) +{ + int i; + for (i=0;istart, + token->size); + if (token->numComponents == 0) { + fprintf(stdout," <%.*s>\n", token->size, token->start); + } else { + fprintf(stdout,"\n"); + } + fflush (stdout); + if (token->numComponents > 0) { + TclPrintTokens (token+1,token->numComponents, level); + } +} +void +TclPrintTokens (Tcl_Token* token, int words, int level) +{ + int k; + for (k=0; k < words; k++, token += (1+token->numComponents)) { + TclPrintToken (token, k, level); + } +} + /* * Local Variables: * mode: c diff --git a/generic/tclProc.c b/generic/tclProc.c index c0a3549..92e81af 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.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: tclProc.c,v 1.107 2006/11/15 20:08:45 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.108 2006/11/28 22:20:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -195,6 +195,67 @@ Tcl_ProcObjCmd( procPtr->cmdPtr = (Command *) cmd; + /* 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. + * + * This code is nearly identical to the #280 code in SetLambdaFromAny, see + * this file. The differences are the different index of the body in the + * line array of the context, and the lamdba code requires some special + * processing. Find a way to factor the common elements into a single + * function. + */ + + 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 ((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); + } + } + /* * Optimize for no-op procs: if the body is not precompiled (like a TclPro * procbody), and the argument list is just "args" and the body is empty, @@ -1432,7 +1493,12 @@ TclObjInterpProcCore( */ procPtr->refCount++; - result = TclCompEvalObj(interp, procPtr->bodyPtr); + + /* 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); procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); @@ -1680,7 +1746,20 @@ ProcCompileProc( (Tcl_Namespace *) nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { + /* 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); result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); } @@ -1802,6 +1881,9 @@ TclProcCleanupProc( Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; + Tcl_HashEntry* hePtr = NULL; + CmdFrame* cfPtr = NULL; + Interp* iPtr = procPtr->iPtr; if (bodyPtr != NULL) { Tcl_DecrRefCount(bodyPtr); @@ -1826,6 +1908,26 @@ TclProcCleanupProc( localPtr = nextPtr; } ckfree((char *) procPtr); + + /* 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); } /* @@ -2045,6 +2147,7 @@ SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { + Interp* iPtr = (Interp*) interp; char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; int objc; @@ -2089,6 +2192,78 @@ SetLambdaFromAny( procPtr->cmdPtr = NULL; + /* TIP #280 Remember the line the apply 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. + * + * NOTE: The body is the second word in the 'objPtr'. Its location, + * accessible through 'context.line[1]' (see below) is therefore only the + * first approximation of the actual line the body is on. We have to use + * the string rep of the 'objPtr' to determine the exact line. This is + * available already through 'name'. Use 'TclListLines', see 'switch' + * (tclCmdMZ.c). + * + * This code is nearly identical to the #280 code in Tcl_ProcObjCmd, see + * this file. The differences are the different index of the body in the + * line array of the context, and the special processing mentioned in the + * previous paragraph to track into the list. Find a way to factor the + * common elements into a single function. + */ + + 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 ((context.type == TCL_LOCATION_SOURCE) && + context.line && + (context.nline >= 2) && + (context.line [1] >= 0)) { + int new, buf [2]; + CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame)); + + /* Move from approximation (line of list cmd word) to actual + * location (line of 2nd list element) */ + TclListLines (name, context.line [1], 2, buf); + + cfPtr->level = -1; + cfPtr->type = context.type; + cfPtr->line = (int*) ckalloc (sizeof (int)); + cfPtr->line [0] = buf [1]; + 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); + } + } + /* * Set the namespace for this lambda: given by objv[2] understood as a * global reference, or else global per default. @@ -2195,8 +2370,21 @@ Tcl_ApplyObjCmd( } procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } + + memset (&cmd, 0, sizeof(Command)); procPtr->cmdPtr = &cmd; + /* TIP#280 HACK ! + * + * Using cmd.clientData to remember the 'lambdaPtr' for 'info frame'. The + * InfoFrameCmd will detect this case by testing cmd.hPtr for NULL. This + * condition holds here because of the 'memset' above, and nowhere + * else. Regular commands always have a valid 'hPtr', and lambda's never. + */ + + cmd.clientData = (ClientData) lambdaPtr; + Tcl_IncrRefCount (lambdaPtr); + /* * Find the namespace where this lambda should run, and push a call frame * for that namespace. Note that TclObjInterpProc() will pop it. @@ -2235,7 +2423,11 @@ Tcl_ApplyObjCmd( iPtr->ensembleRewrite.numRemovedObjs = 0; iPtr->ensembleRewrite.numInsertedObjs = 0; } - return result; + + /* TIP #280 Undo the reference held inside of 'cmd, see HACK above. */ + Tcl_DecrRefCount (lambdaPtr); + + return result; } /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8981ff6..bed09bd 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.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: tclUtil.c,v 1.76 2006/11/15 20:08:45 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.77 2006/11/28 22:20:29 andreas_kupries Exp $ */ #include "tclInt.h" @@ -483,6 +483,89 @@ Tcl_SplitList( return TCL_OK; } +int +TclMarkList( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, no error message is left. */ + CONST char *list, /* Pointer to string with list structure. */ + CONST char* end, /* Pointer to first char after the list. */ + int *argcPtr, /* Pointer to location to fill in with the + * number of elements in the list. */ + CONST int** argszPtr, /* Pointer to place to store length of list + * elements. */ + CONST char ***argvPtr) /* Pointer to place to store pointer to array + * of pointers to list elements. */ +{ + CONST char **argv; + int* argn; + CONST char *l; + int length, size, i, result, elSize, brace; + CONST char *element; + + /* + * Figure out how much space to allocate. There must be enough space for + * the array of pointers and lengths. To estimate the number of pointers + * needed, count the number of whitespace characters in the list. + */ + + for (size = 2, l = list; l != end; l++) { + if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ + size++; + /* Consecutive space can only count as a single list delimiter */ + while (1) { + char next = *(l + 1); + if ((l+1) == end) { + break; + } + ++l; + if (isspace(UCHAR(next))) { + continue; + } + break; + } + } + } + length = l - list; + argv = (CONST char **) ckalloc((unsigned) + ((size * sizeof(char *)))); + argn = (int*) ckalloc((unsigned) + ((size * sizeof(int *)))); + + for (i = 0; list != end; i++) { + CONST char *prevList = list; + + result = TclFindElement(interp, list, length, &element, + &list, &elSize, &brace); + length -= (list - prevList); + if (result != TCL_OK) { + ckfree((char *) argv); + ckfree((char *) argn); + return result; + } + if (*element == 0) { + break; + } + if (i >= size) { + ckfree((char *) argv); + ckfree((char *) argn); + if (interp != NULL) { + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + } + return TCL_ERROR; + } + argv[i] = element; + argn[i] = elSize; + } + + argv[i] = NULL; + argn[i] = 0; + *argvPtr = argv; + *argszPtr = argn; + *argcPtr = i; + return TCL_OK; +} + /* *---------------------------------------------------------------------- * diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d9d37bc..8399565 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -16,7 +16,7 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.98 2006/10/16 15:22:06 dgp Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.99 2006/11/28 22:20:29 andreas_kupries Exp $ package require Tcl 8.5 ;# To provide an alpha version package require Tcl 8.3 ;# uses [glob -directory] @@ -1615,8 +1615,7 @@ proc tcltest::Eval {script {ignoreOutput 1}} { set outData {} set errData {} rename ::puts [namespace current]::Replace::Puts - namespace eval :: \ - [list namespace import [namespace origin Replace::puts]] + namespace eval :: [list namespace import [namespace origin Replace::puts]] namespace import Replace::puts } set result [uplevel 1 $script] diff --git a/tests/info.test b/tests/info.test index d330ada..7b7b867 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.39 2006/10/31 13:46:33 dkf Exp $ +# RCS: @(#) $Id: info.test,v 1.40 2006/11/28 22:20:29 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -664,16 +666,639 @@ test info-21.1 {miscellaneous error conditions} { } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} { 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}} +} {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} { 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}} +} {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} { 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}} +} {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} { 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}} +} {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-4] + 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} { + info frame +} 7 + +test info-22.1 {info frame, bad level relative} { + # 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} { + # 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} { + info frame 0 +} {type eval line 2 cmd {info frame 0}} + +test info-22.4 {info frame, current, relative, nested} { + set res [info frame 0] +} {type eval line 2 cmd {info frame 0}} + +test info-22.5 {info frame, current, absolute} { + reduce [info frame 7] +} {type eval line 2 cmd {info frame 7}} + +test info-22.6 {info frame, global, relative} { + reduce [info frame -6] +} {type source line 755 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ level 0} + +test info-22.7 {info frame, global, absolute} { + reduce [info frame 1] +} {type source line 759 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut level 0} + +test info-22.8 {info frame, basic trace} { + join [etrace] \n +} {8 {type source line 719 file info.test cmd {info frame $level} proc ::etrace level 0} +7 {type eval line 2 cmd etrace} +6 {type source line 2290 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} +5 {type eval line 1 cmd {::tcltest::RunTest info-22}} +4 {type source line 1621 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ info-22} +2 {type source line 1967 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} +1 {type source line 763 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac level 1}} +## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 +test info-23.0 {eval'd info frame} { + eval {info frame} +} 8 + +test info-23.1 {eval'd info frame, semi-dynamic} { + eval info frame +} 8 + +test info-23.2 {eval'd info frame, dynamic} { + set script {info frame} + eval $script +} 8 + +test info-23.3 {eval'd info frame, literal} { + eval { + info frame 0 + } +} {type eval line 2 cmd {info frame 0}} + +test info-23.4 {eval'd info frame, semi-dynamic} { + eval info frame 0 +} {type eval line 1 cmd {info frame 0}} + +test info-23.5 {eval'd info frame, dynamic} { + set script {info frame 0} + eval $script +} {type eval line 1 cmd {info frame 0}} + +test info-23.6 {eval'd info frame, trace} { + set script {etrace} + join [eval $script] \n +} {9 {type source line 719 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 2290 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest} +5 {type eval line 1 cmd {::tcltest::RunTest info-23}} +4 {type source line 1621 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval} +3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ info-23} +2 {type source line 1967 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test} +1 {type source line 802 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac level 1}} +## The line 1967 is off by 5 from the true value of 1972. 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} { + reduce [foo::bar] +} {type source line 828 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} { + reduce [foo::bar] +} {type source line 842 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} { + reduce [foo::bar] +} {type source line 856 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} { + reduce [foo::bar] +} {type source line 870 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} { + reduce [foo::bar] +} {type source line 883 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} { + reduce [foo::bar] +} {type source line 897 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} { + reduce [bar] +} {type source line 910 file info.test cmd {info frame 0} proc ::bar level 0} + +proc bar {} {info frame 0} +test info-25.1 {info frame, regular proc} { + reduce [bar] +} {type source line 917 file info.test cmd {info frame 0} proc ::bar level 0} +rename bar {} + +# ------------------------------------------------------------------------- + +test info-30.0 {bs+nl in literal words} 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} { + 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} { + if 1 $body + set res +} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest} + +test info-31.1a {if, script in variable} { + 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} { + 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} { + 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} { + 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} { + 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} { + reduce [foo::bar] +} {type source line 992 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} { + reduce [foo::bar] +} {type source line 1008 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} { + 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} { + 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} { + reduce [foo::bar] +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace {expand}{ + eval + foo + {proc bar {} {info frame 0}} +} +test info-33.0 {expand, literal, direct} { + reduce [foo::bar] +} {type source line 1072 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set flag 1 + if {expand}{ + {$flag} + {info frame 0} + } +} +test info-33.1 {expand, literal, simple, bytecompiled} { + reduce [foo::bar] +} {type source line 1087 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +set body { + eval + foo + {proc bar {} { + info frame 0 + }} +} +namespace {expand}$body +test info-34.0 {expand, dynamic, direct} { + reduce [foo::bar] +} {type proc line 2 cmd {info frame 0} proc ::foo::bar level 0} + +unset body +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +set body { + {$flag} + {info frame 0} +} +proc foo::bar {} { + global body ; set flag 1 + if {expand}$body +} +test info-34.1 {expand, literal, bytecompiled} { + reduce [foo::bar] +} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0} + +unset body +namespace delete foo + +# ------------------------------------------------------------------------- + +proc foo {} { + apply { + {x y} + {info frame 0} + } 0 0 +} +test info-35.0 {apply, literal} { + reduce [foo] +} {type source line 1136 file info.test cmd {info frame 0} lambda { + {x y} + {info frame 0} + } level 0} +rename foo {} + +set lambda { + {x y} + {info frame 0} +} +test info-35.1 {apply, dynamic} { + reduce [apply $lambda 0 0] +} {type proc line 1 cmd {info frame 0} lambda { + {x y} + {info frame 0} +} level 0} +unset lambda + +# ------------------------------------------------------------------------- + +namespace eval foo {} +dict for {k v} {foo bar} { + proc ::foo::bar {} {info frame 0} +} + +test info-24.7 {info frame, interaction, dict for} { + reduce [foo::bar] +} {type source line 1163 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +set thedict {foo bar} +dict with thedict { + proc ::foo::bar {} {info frame 0} +} + +test info-24.8 {info frame, interaction, dict with} { + reduce [foo::bar] +} {type source line 1177 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset thedict + +# ------------------------------------------------------------------------- + +namespace eval foo {} +dict filter {foo bar} script {k v} { + proc ::foo::bar {} {info frame 0} + set x 1 +} + +test info-24.9 {info frame, interaction, dict filter} { + reduce [foo::bar] +} {type source line 1191 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo +unset x + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + dict for {k v} {foo bar} { + set x [info frame 0] + } + set x +} +test info-36.0 {info frame, dict for, bcc} { + reduce [foo::bar] +} {type source line 1207 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set x foo + switch -exact -- $x { + foo {set y [info frame 0]} + } + set y +} + +test info-36.1.0 {switch, list literal, bcc} { + reduce [foo::bar] +} {type source line 1223 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set x foo + switch -exact -- $x foo {set y [info frame 0]} + set y +} + +test info-36.1.1 {switch, multi-body literals, bcc} { + reduce [foo::bar] +} {type source line 1239 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace {expand}" + eval + foo + {proc bar {} {info frame 0}} +" +test info-33.2 {expand, literal, direct} { + reduce [foo::bar] +} {type source line 1254 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace {expand}"eval\nfoo\n{proc bar {} {info frame 0}}\n" + +test info-33.2a {expand, literal, not simple, direct} { + reduce [foo::bar] +} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set flag 1 + if {expand}" + {1} + {info frame 0} + " +} +test info-33.3 {expand, literal, simple, bytecompiled} { + reduce [foo::bar] +} {type source line 1279 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- + +namespace eval foo {} +proc foo::bar {} { + set flag 1 + if {expand}"\n{1}\n{info frame 0}" +} +test info-33.3a {expand, literal, not simple, bytecompiled} { + reduce [foo::bar] +} {type eval line 1 cmd {info frame 0} proc ::foo::bar level 0} + +namespace delete foo + +# ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} -- cgit v0.12