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