summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2006-11-28 22:20:27 (GMT)
committerandreas_kupries <akupries@shaw.ca>2006-11-28 22:20:27 (GMT)
commit2cd91050a0972e257b9bc1a320d996030f01ce5d (patch)
treec4542b66e173006f66825f5cfb1617a4fd9766e1
parentde316a45d4f6dcf7815d5c199f65a0e636f20423 (diff)
downloadtcl-2cd91050a0972e257b9bc1a320d996030f01ce5d.zip
tcl-2cd91050a0972e257b9bc1a320d996030f01ce5d.tar.gz
tcl-2cd91050a0972e257b9bc1a320d996030f01ce5d.tar.bz2
* 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:
-rw-r--r--ChangeLog22
-rw-r--r--doc/info.n110
-rw-r--r--generic/tclBasic.c487
-rw-r--r--generic/tclCmdAH.c28
-rw-r--r--generic/tclCmdIL.c278
-rw-r--r--generic/tclCmdMZ.c106
-rw-r--r--generic/tclCompCmds.c362
-rw-r--r--generic/tclCompExpr.c6
-rw-r--r--generic/tclCompile.c394
-rw-r--r--generic/tclCompile.h37
-rw-r--r--generic/tclDictObj.c20
-rw-r--r--generic/tclExecute.c111
-rw-r--r--generic/tclIOUtil.c5
-rw-r--r--generic/tclInt.decls5
-rw-r--r--generic/tclInt.h154
-rw-r--r--generic/tclIntDecls.h7
-rw-r--r--generic/tclInterp.c6
-rw-r--r--generic/tclNamesp.c9
-rw-r--r--generic/tclParse.c63
-rw-r--r--generic/tclProc.c198
-rw-r--r--generic/tclUtil.c85
-rw-r--r--library/tcltest/tcltest.tcl5
-rw-r--r--tests/info.test635
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 <andreask@activestate.com>
+
+ * 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 <kennykb@acm.org>
* 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 ; i<numWords ; i++) {
- CompileWord(envPtr, tokenPtr, interp);
+ CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
@@ -649,7 +670,7 @@ TclCompileDictCmd(
}
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
procPtr);
- CompileWord(envPtr, keyTokenPtr, interp);
+ CompileWord(envPtr, keyTokenPtr, interp, 3);
TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
@@ -662,7 +683,7 @@ TclCompileDictCmd(
}
for (i=0 ; i<numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
- CompileWord(envPtr, tokenPtr, interp);
+ CompileWord(envPtr, tokenPtr, interp, i);
}
TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
return TCL_OK;
@@ -675,6 +696,8 @@ TclCompileDictCmd(
Tcl_DString buffer;
int savedStackDepth = envPtr->currStackDepth;
+ 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<numVars ; i++) {
- CompileWord(envPtr, keyTokenPtrs[i], interp);
+ CompileWord(envPtr, keyTokenPtrs[i], interp, i);
}
TclEmitInstInt4( INST_LIST, numVars, envPtr);
TclEmitInstInt4( INST_STORE_SCALAR4, keyTmpIndex, envPtr);
@@ -974,7 +998,7 @@ TclCompileDictCmd(
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, VAR_SCALAR,
procPtr);
for (i=1 ; i<numWords ; i++) {
- CompileWord(envPtr, tokenPtr, interp);
+ CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
if (numWords > 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 <posInt> <arbitraryValue>
+ * lindex <arbitraryValue> <posInt>
* 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 ; i<numWords ; i++) {
- CompileWord(envPtr, varTokenPtr, interp);
+ CompileWord(envPtr, varTokenPtr, interp, i);
varTokenPtr = TokenAfter(varTokenPtr);
}
@@ -2356,6 +2413,8 @@ TclCompileListCmd(
* created by Tcl_ParseCommand. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ DefineLineInformation; /* TIP #280 */
+
/*
* If we're not in a procedure, don't compile.
*/
@@ -2380,7 +2439,7 @@ TclCompileListCmd(
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
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 ; i<parsePtr->numWords ; ++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 <opts> <msg>
@@ -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<numWords ; i++) {
bodyTokenArray[i].type = TCL_TOKEN_TEXT;
bodyTokenArray[i].start = tokenStartPtr;
@@ -3508,8 +3605,19 @@ TclCompileSwitchCmd(
ckfree((char *) argv);
ckfree((char *) bodyToken);
ckfree((char *) bodyTokenArray);
+ ckfree((char *) bodyLines);
return TCL_ERROR;
}
+
+ /* TIP #280 Now determine the line the list element starts on
+ * (There is no need to do it earlier, due to the possibility of
+ * aborting, see above).
+ */
+
+ TclAdvanceLines (&bline, p, bodyTokenArray[i].start);
+ bodyLines [i] = bline;
+ p = bodyTokenArray[i].start;
+
while (isspace(UCHAR(*tokenStartPtr))) {
tokenStartPtr++;
if (tokenStartPtr >= 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 ; i<numWords ; i++) {
/*
@@ -3561,9 +3673,12 @@ TclCompileSwitchCmd(
if (tokenPtr->type != 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ; 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 ; words<parsePtr->numWords ;) {
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 ; words<parsePtr->numWords ;) {
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 ; words<parsePtr->numWords ;) {
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 ; words<parsePtr->numWords ;) {
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 ; words<parsePtr->numWords ;) {
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 ; words<parsePtr->numWords ;) {
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;i<level;i++) fprintf(stdout," ");
+ level++;
+
+ fprintf(stdout,"[%3d] @%p/%4d",
+ idx,
+ token->start,
+ 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}