diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/doc/info.n tclnew4/doc/info.n --- tcl.upd/doc/info.n Sun Jun 13 14:37:20 2004 +++ tclnew4/doc/info.n Sun Jun 13 15:03:40 2004 @@ -124,6 +124,52 @@ variable and may be changed by setting \fBtcl_library\fR. See the \fBtclvars\fR manual entry for more information. .TP +\fBinfo line \fISUBCOMMAND ARGS\fR +The \fBline\fR subcommands access line number information +for procs that were defined via the source command. +Five subcommands are currently defined: line, file and find. +.TP +.RS +.TP +\fBinfo line file \fIprocname \fR?\fIfileName\fR? +For procedures defined via the \fBsource\fR command, +returns the file name that the procedure \fIprocname\fR was sourced +from. If \fIfileName\fR is provided, this is used as the new value. +For procedures not defined via the \fBsource\fR command, +this function does nothing and returns nothing. +.VE +.TP +\fBinfo line find \fIfileName lineNum \fR?\fInamespace\fR? +For procedures defined via the \fBsource\fR command, +find the procedure name defined at line \fIlineNum\fR in file path +\fIfileName\fR. +If found, returns fully namespace qualified procedure name. +This will find only procedures defined via the \fBsource\fR command. +.VE +.TP +\fBinfo line level \fInumber\fR +Like the \fIinfo level\fR command, but returns the line number +and file name from which +the call at level \fInumber\fR originates, when using \fItrace execution\fR. +.VE +.TP +\fBinfo line number \fIprocname \fR?\fIlineNum\fR? +For procedures defined via the \fBsource\fR command, +the line number that a procedure \fIprocname\fR +was defined on. +If \fIlineNum\fR is provided, it is used as the new value. +For procedures not defined via the \fBsource\fR command, +this function does nothing and returns nothing. +.VE +.TP +\fBinfo line relativeerror \fR?\fIBOOL\fR +Set to 1 to disable absolute line number and file path +on a procedure error. This demotes procedure traceback errors +to the same format as all other traceback errors, that is, +using the relative the line number and file name. +.VE +.RE +.TP \fBinfo loaded \fR?\fIinterp\fR? Returns a list describing all of the packages that have been loaded into \fIinterp\fR with the \fBload\fR command. @@ -164,6 +210,12 @@ Matching is determined using the same rules as for \fBstring match\fR. .TP +\fBinfo return\fR +If in \fBtrace execution\fR mode, returns the saved last result of the +previously executed command. Otherwise returns an empty string. +Commands executed as part of a trace handler do not affect or change +the saved last result. +.TP \fBinfo script\fR ?\fIfilename\fR? If a Tcl script file is currently being evaluated (i.e. there is a call to \fBTcl_EvalFile\fR active or there is an active invocation diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/doc/trace.n tclnew4/doc/trace.n --- tcl.upd/doc/trace.n Sun Jun 13 14:37:20 2004 +++ tclnew4/doc/trace.n Thu Jun 17 12:42:14 2004 @@ -201,6 +201,9 @@ are unset). Variables are also unset when interpreters are deleted, but traces will not be invoked because there is no interpreter in which to execute them. +.TP +\fBdebug\fR +Prevent execution trace from triggering during a variable trace. .PP When the trace triggers, three arguments are appended to \fIcommand\fR so that the actual command is as follows: @@ -334,6 +337,67 @@ have any traces set, then the result of the command will be an empty string. .RE +.TP +\fBtrace execution ?\fItarget ?level??\fR +Arrange for an execution trace to be setup for commands at +nesting \fBlevel\fR or above, +thereby providing a simple Tcl interface to trace +commands say, to implement a debugger. +With no arguments, the current \fItarget\fR is returned. +If \fItarget\fR is the empty string, the execution trace is removed. +If the argument \fItarget\fR is not an output \fBchannel\fR name such as +\fBstdout\fR, it is assumed to be a \fBcommand\fR string. +\fBLevel\fR defaults to 0 if not specified, meaning trace all commands. +The following list of arguments are appended before the call: +.RS +.TP +\fBlinenumber\fR + The line number the instruction begins on. +.TP +\fBfilename\fR + The fully normalized file name. +.TP +\fBnestlevel\fR + The nesting level of the command. +.TP +\fBstacklevel\fR + The stack call level as per [info level]. +.TP +\fBcurnsfunc\fR + The current fully qualified namespace/function +.TP +\fBcmdname\fR + The fully qualified command name of the command to be invoked. +.TP +\fBcommand\fR + The command and arguments as a list. +.TP +\fBflags\fR + The bit flags. Bit 0 set indicates this was a breakpoint. +.RE +.PP +.RS +If \fItarget\fR is a valid Tcl channel opened for output, the trace data is +written out to it with an appended newline. +Otherwise \fItarget\fR is presumed to be a valid Tcl command +onto which is appended the above arguments before evaluation. +For channels, an error on output will cause the trace to be removed and +a Tcl error to be generated. +For commands, any return from the command other than a normal return +results in the command not being executed. +.RE +.TP +\fBtrace breakpoint ??\fIline file ?state? ...?\fR +The \fItrace breakpoint\fR manages a list of breakpoints that cause an +\fIexecution trace\fR to trigger, even when the nestlevel is exceeded. +With no arguments it returns a ternery list of all breakpoints in sets +of the triples: line, file, and state. With two arguments, the +current state for the breakpoint is returned. With three or more arguments, +new breakpoints are created. If created with a state <= zero, +the breakpoint is considered inactive. Setting the state of a +breakpoint to the empty string effectively deletes the breakpoint. +A state to \fIN\fR greater than zero triggers every \fINth\fR time. +.RE .PP For backwards compatibility, three other subcommands are available: .RS diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tcl.h tclnew4/generic/tcl.h --- tcl.upd/generic/tcl.h Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tcl.h Thu Jun 17 12:47:33 2004 @@ -904,6 +904,8 @@ char *dummy8; int dummy9; char* dummy10; + int lineNum; + Tcl_Obj *fileName; } Tcl_CallFrame; @@ -1049,6 +1051,7 @@ #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 +#define TCL_TRACE_LINE_NUMBERS 0x40000 /* * Flag values passed to Tcl_CreateObjTrace, and used internally @@ -2158,9 +2161,39 @@ * accommodate most commands; dynamic * space is allocated for very large * commands that don't fit here. */ + int lineNum; /* Line number for start of string. */ + int lineCnt; /* Number of lines in parse. */ + Tcl_Obj *fileName; /* File name of parse string. */ } Tcl_Parse; /* + * Breakpoint support for [trace execution]. + */ +typedef struct Tcl_Breakpoint { + Tcl_Obj *fileName; /* Object containing the file name. */ + int lineNum; /* Line number within file of statement. */ + int state; /* 0=disabled, N=trigger every Nth time.*/ + int counter; /* Counter for when state>1. */ + struct Tcl_Breakpoint *next;/* Pointer to next breakpoint in list. */ +} Tcl_Breakpoint; + +/* + * File and line number information maintained during TRACE_LINE_NUMBERS. + * Retrievable with Tcl_GetSourceInfo() in the Stubs 'C' interface. + */ +typedef struct { + Tcl_Obj *curFileName; /* Object containing the file name. */ + int curLineNum; /* Line number of statement within file. */ + int lastTracedLine; /* Line number of last traced statement. */ + int curCharPos; /* Char position in line, or -1 if unknown. */ + int commandLen; /* Length of command string for cmd trace. */ + int stackLevel; /* The current stacklevel as per [info level] */ + Tcl_Obj* lastResultPtr; /* Result from the last executed command. */ + int flags; /* Bit flags: bit 0 = breakpoint. */ + Tcl_Breakpoint *breakpoints; /* List of breakpoints. */ +} Tcl_SourceInfo; + +/* * The following definitions are the error codes returned by the conversion * routines: * diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclBasic.c tclnew4/generic/tclBasic.c --- tcl.upd/generic/tclBasic.c Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclBasic.c Thu Jun 17 09:06:28 2004 @@ -352,6 +352,16 @@ iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->resultSpace[0] = 0; + iPtr->lineNum=0; + iPtr->relError = 0; + iPtr->traceExecCmd = NULL; + iPtr->traceExecId = NULL; + iPtr->sourceInfo.curFileName = NULL; + iPtr->sourceInfo.lastResultPtr = NULL; + iPtr->sourceInfo.curCharPos = -1; + iPtr->sourceInfo.flags = 0; + iPtr->sourceInfo.breakpoints = NULL; + Tcl_InitHashTable(&iPtr->sourcedFiles, TCL_STRING_KEYS); iPtr->globalNsPtr = NULL; /* force creation of global ns below */ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", @@ -1035,6 +1045,16 @@ ckfree((char *) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(&iPtr->mathFuncTable); + /* + * Tear down the sourced files table. + */ + + for (hPtr = Tcl_FirstHashEntry(&iPtr->sourcedFiles, &search); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DecrRefCount((Tcl_Obj *) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(&iPtr->sourcedFiles); /* * Invoke deletion callbacks; note that a callback can create new @@ -1097,6 +1117,10 @@ } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; + if (iPtr->sourceInfo.lastResultPtr != NULL) { + Tcl_DecrRefCount(iPtr->sourceInfo.lastResultPtr); + iPtr->sourceInfo.lastResultPtr = NULL; + } resPtr = iPtr->resolverPtr; while (resPtr) { @@ -1105,6 +1129,11 @@ ckfree((char *) resPtr); resPtr = nextResPtr; } + while (iPtr->sourceInfo.breakpoints != NULL) { + Tcl_Breakpoint *curBP = iPtr->sourceInfo.breakpoints; + iPtr->sourceInfo.breakpoints = curBP->next; + ckfree((char*) curBP); + } /* * Free up literal objects created for scripts compiled by the @@ -3146,6 +3175,21 @@ } code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); iPtr->varFramePtr = savedVarFramePtr; + + /* + * When in [trace execution], make copy of result for [info return], + * except when this is inside a trace callback. + */ + if (!(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) { + if (iPtr->sourceInfo.lastResultPtr != NULL) { + Tcl_DecrRefCount(iPtr->sourceInfo.lastResultPtr); + iPtr->sourceInfo.lastResultPtr = NULL; + } + if (iPtr->flags&TRACE_LINE_NUMBERS) { + iPtr->sourceInfo.lastResultPtr = iPtr->objResultPtr; + Tcl_IncrRefCount(iPtr->sourceInfo.lastResultPtr); + } + } } if (Tcl_AsyncReady()) { code = Tcl_AsyncInvoke(interp, code); @@ -3509,7 +3553,7 @@ Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv, **objvSpace; int expandStatic[NUM_STATIC_OBJS], *expand; Tcl_Token *tokenPtr; - int i, code, commandLength, bytesLeft, expandRequested; + int i, code, commandLength, bytesLeft, expandRequested, lineNum; CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr * in case TCL_EVAL_GLOBAL was set. */ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); @@ -3542,6 +3586,7 @@ p = script; bytesLeft = numBytes; iPtr->evalFlags = 0; + do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { @@ -3549,12 +3594,14 @@ goto error; } gotParse = 1; + parse.lineNum = iPtr->lineNum; + lineNum = iPtr->sourceInfo.curLineNum; /* Save lineNum subeval may change it. */ if (parse.numWords > 0) { /* * Generate an array of objects for the words of the command. */ int objectsNeeded = 0; - + if (parse.numWords > NUM_STATIC_OBJS) { expand = (int *) ckalloc((unsigned) (parse.numWords * sizeof (int))); @@ -3609,7 +3656,7 @@ if ((parse.numWords > NUM_STATIC_OBJS) || (objectsNeeded > NUM_STATIC_OBJS)) { objv = objvSpace = (Tcl_Obj **) ckalloc((unsigned) - (objectsNeeded * sizeof (Tcl_Obj *))); + ((objectsNeeded) * sizeof (Tcl_Obj *))); } objectsUsed = 0; @@ -3636,15 +3683,17 @@ ckfree((char *) copy); } } - + /* * Execute the command and free the objects for its words. */ iPtr->numLevels++; + iPtr->sourceInfo.curFileName = parse.fileName; + iPtr->sourceInfo.curLineNum = parse.lineNum; code = TclEvalObjvInternal(interp, objectsUsed, objv, parse.commandStart, parse.commandSize, 0); - iPtr->numLevels--; + iPtr->numLevels--; if (code != TCL_OK) { if (iPtr->numLevels == 0) { if (code == TCL_RETURN) { @@ -3675,6 +3724,9 @@ expand = expandStatic; } } + if (iPtr != NULL) { + iPtr->lineNum = parse.lineNum + parse.lineCnt; + } /* * Advance to the next command in the script. diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclCmdAH.c tclnew4/generic/tclCmdAH.c --- tcl.upd/generic/tclCmdAH.c Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclCmdAH.c Sun Jun 13 15:03:40 2004 @@ -1688,19 +1688,23 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int result, value; + int result, value, lineNum, curLine; + Interp *iPtr = (Interp*)interp; if (objc != 5) { Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } + lineNum = iPtr->lineNum; + iPtr->lineNum = curLine = iPtr->sourceInfo.curLineNum; + result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); } - return result; + goto doreturn; } while (1) { /* @@ -1710,9 +1714,10 @@ */ Tcl_ResetResult(interp); + iPtr->lineNum = curLine; result = Tcl_ExprBooleanObj(interp, objv[2], &value); if (result != TCL_OK) { - return result; + goto doreturn; } if (!value) { break; @@ -1727,6 +1732,7 @@ } break; } + iPtr->lineNum = curLine; result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { break; @@ -1734,7 +1740,7 @@ if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); } - return result; + goto doreturn; } } if (result == TCL_BREAK) { @@ -1743,6 +1749,10 @@ if (result == TCL_OK) { Tcl_ResetResult(interp); } + +doreturn: + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; return result; } @@ -1777,6 +1787,7 @@ int v; /* v selects a loop variable */ int numLists; /* Count of value lists */ Tcl_Obj *bodyPtr; + Interp *iPtr = (Interp*)interp; /* * We copy the argument object pointers into a local array to avoid @@ -1801,6 +1812,7 @@ 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 */ + int lineNum; if (objc < 4 || (objc%2 != 0)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1883,6 +1895,7 @@ */ bodyPtr = argObjv[objc-1]; + lineNum = iPtr->lineNum; for (j = 0; j < maxj; j++) { for (i = 0; i < numLists; i++) { /* @@ -1933,6 +1946,7 @@ } } + iPtr->lineNum = lineNum; result = Tcl_EvalObjEx(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclCmdIL.c tclnew4/generic/tclCmdIL.c --- tcl.upd/generic/tclCmdIL.c Tue Apr 6 15:25:49 2004 +++ tclnew4/generic/tclCmdIL.c Mon Jun 14 13:09:52 2004 @@ -20,6 +20,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include "tclFileSystem.h" /* * During execution of the "lsort" command, structures of the following @@ -127,6 +128,9 @@ static int InfoLibraryCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int InfoLineCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int InfoLoadedCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -142,6 +146,9 @@ static int InfoProcsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +static int InfoReturnCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int InfoScriptCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); @@ -194,8 +201,12 @@ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int thenScriptIndex = 0; /* then script to be evaled after syntax check */ - int i, result, value; + int i, result, value, lineNum, curLine; char *clause; + Interp *iPtr = (Interp *)interp; + + curLine = iPtr->sourceInfo.curLineNum; + lineNum = iPtr->lineNum; i = 1; while (1) { /* @@ -246,7 +257,8 @@ i++; if (i >= objc) { if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + i = thenScriptIndex; + goto doeval; } return TCL_OK; } @@ -280,9 +292,26 @@ return TCL_ERROR; } if (thenScriptIndex) { - return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + i = thenScriptIndex; } - return Tcl_EvalObjEx(interp, objv[i], 0); +doeval: + if (iPtr->flags&TRACE_LINE_NUMBERS) { + int n; + unsigned int nl=0; + for (n=0; nlineNum = curLine + nl; + } + result = Tcl_EvalObjEx(interp, objv[i], 0); + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; + return result; } /* @@ -410,16 +439,18 @@ static CONST char *subCmds[] = { "args", "body", "cmdcount", "commands", "complete", "default", "exists", "functions", "globals", - "hostname", "level", "library", "loaded", + "hostname", "level", "library", "line", "loaded", "locals", "nameofexecutable", "patchlevel", "procs", - "script", "sharedlibextension", "tclversion", "vars", + "return", "script", "sharedlibextension", "tclversion", + "vars", (char *) NULL}; enum ISubCmdIdx { IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx, ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx, - IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, + IHostnameIdx, ILevelIdx, ILibraryIdx, ILineIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, - IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx + IReturnIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, + IVarsIdx }; int index, result; @@ -471,6 +502,9 @@ case ILibraryIdx: result = InfoLibraryCmd(clientData, interp, objc, objv); break; + case ILineIdx: + result = InfoLineCmd(clientData, interp, objc, objv); + break; case ILoadedIdx: result = InfoLoadedCmd(clientData, interp, objc, objv); break; @@ -486,6 +520,9 @@ case IProcsIdx: result = InfoProcsCmd(clientData, interp, objc, objv); break; + case IReturnIdx: + result = InfoReturnCmd(clientData, interp, objc, objv); + break; case IScriptIdx: result = InfoScriptCmd(clientData, interp, objc, objv); break; @@ -1252,6 +1289,338 @@ /* *---------------------------------------------------------------------- * + * InfoLineCmd -- + * + * Called to implement the "info line" command that accesses the line + * information for procedures created via the source command. + * + * info line SUBCOMMAND ARGS + * + * Current subcommands include: + * info line number PROC ?LINE? + * info line file ?PROC ?FILE?? + * info line find FILE LINE + * info line relerror ?BOOL? + * + * 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 +InfoLineCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Interp *iPtr = (Interp *) interp; + char *subCmd, *procName, *fileName; + Proc *procPtr; + Tcl_Obj *resultPtr, *listPtr, *fileNamePtr = NULL, *nsObj; + char iBuf[50]; + int len, lineNum=0, index, level, i; + Namespace *nsPtr=0; + CallFrame *framePtr = NULL, *callerPtr; + + static CONST char *options[] = { + "current", "number", "find", "file", "files", "level", "relerror", + (char*)NULL + }; + enum options { + ILINE_CURRENT, ILINE_NUMBER, ILINE_FIND, ILINE_FILE, ILINE_FILES, + ILINE_LEVEL, ILINE_RELERROR + }; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "line"); + return TCL_ERROR; + } + + subCmd = Tcl_GetString(objv[2]); + if (Tcl_GetIndexFromObj(interp, objv[2], options, "line", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + + case ILINE_CURRENT: + if (objc != 3) { + Tcl_WrongNumArgs(interp, objc, objv, subCmd); + return TCL_ERROR; + } + resultPtr = Tcl_NewListObj(0, 0); + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewIntObj(iPtr->sourceInfo.curLineNum)); + Tcl_ListObjAppendElement(interp, resultPtr, + iPtr->sourceInfo.curFileName ? iPtr->sourceInfo.curFileName + : Tcl_NewStringObj("",0)); + Tcl_SetObjResult(interp, resultPtr); + break; + + case ILINE_NUMBER: + + /* + * Get/Set the line number + */ + if (objc < 3 && objc > 5) { + Tcl_WrongNumArgs(interp, objc, objv, subCmd); + return TCL_ERROR; + } + + if (objc == 3) { + resultPtr = Tcl_NewIntObj(iPtr->sourceInfo.curLineNum); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + procName = Tcl_GetString(objv[3]); + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", procName, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + if (procPtr->fileName == NULL) { + return TCL_OK; + } + + if (objc >= 5) { + if (Tcl_GetIntFromObj(interp, objv[4], &lineNum) + != TCL_OK) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(objv[4]), + "\" isn't a number", (char *) NULL); + return TCL_ERROR; + } + if ((enum options) index == ILINE_NUMBER) { + procPtr->lineNum=lineNum; + } + } + resultPtr = Tcl_NewIntObj(procPtr->lineNum); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; + + + case ILINE_FILES: + + if (objc != 3) { + Tcl_WrongNumArgs(interp, objc, objv, "line files"); + return TCL_ERROR; + } else { + Tcl_HashEntry *entry; + Tcl_HashSearch se; + Tcl_Obj *cp; + entry=Tcl_FirstHashEntry(&iPtr->sourcedFiles, &se); + resultPtr=Tcl_NewListObj(0,0); + while (entry) { + if ((cp=(Tcl_Obj*)Tcl_GetHashValue(entry))) { + Tcl_ListObjAppendElement(interp,resultPtr, cp); + } + entry=Tcl_NextHashEntry(&se); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + case ILINE_FILE: + /* + * Set/Get the filename a the given PROC + */ + if (objc < 3 && objc > 5) { + Tcl_WrongNumArgs(interp, objc, objv, "line file"); + return TCL_ERROR; + } + + if (objc == 3) { + resultPtr = iPtr->sourceInfo.curFileName; + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + procName = Tcl_GetString(objv[3]); + procPtr = TclFindProc(iPtr, procName); + if (procPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", procName, "\" isn't a procedure", (char *) NULL); + return TCL_ERROR; + } + + if (procPtr->fileName == NULL) { + return TCL_OK; + } + if (objc == 4) { + resultPtr = procPtr->fileName; + Tcl_IncrRefCount(resultPtr); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + + fileName=Tcl_GetStringFromObj(objv[5],&len); + Tcl_SetStringObj(procPtr->fileName,fileName,len); + return TCL_OK; + + + case ILINE_FIND: + + /* + * Find a proc given the filename and line number + optional namespace + * that can reduce the cost of the search. + */ + + if (objc != 5) { + Tcl_WrongNumArgs(interp, objc, objv, "line find fileName lineNum"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[4], &lineNum) != TCL_OK) { + return TCL_ERROR; + } + if (TclFindProcByLine(iPtr, objv[3], lineNum, nsPtr, &resultPtr)) { + Tcl_SetObjResult(interp, resultPtr); + } + + return TCL_OK; + + + /* + * Set to 0 to report relative line number/filename on proc error. + * tcltest needs this to avoid breaking tests. + */ + + case ILINE_RELERROR: + + if (objc < 4 && objc > 5) { + Tcl_WrongNumArgs(interp, objc, objv, subCmd); + return TCL_ERROR; + } + + if (objc >= 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &iPtr->relError) + != TCL_OK) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "\"", Tcl_GetString(objv[4]), + "\" isn't a number", (char *) NULL); + return TCL_ERROR; + } + } + sprintf(iBuf,"%d", iPtr->relError); + resultPtr = Tcl_NewStringObj(iBuf,-1); + Tcl_SetObjResult(interp, resultPtr); + + return TCL_OK; + + case ILINE_LEVEL: + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "?level?"); + return TCL_ERROR; + } + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + if (level > 0) { + goto levelError; + } + } else { + level = 0; + } + + listPtr = resultPtr = Tcl_NewListObj(0,0); + i = 0; + while (1) { + if (i == 0) { + lineNum = iPtr->sourceInfo.lastTracedLine; + fileNamePtr = iPtr->sourceInfo.curFileName; + callerPtr = iPtr->varFramePtr; + } else { + if (i == -1) { + framePtr = iPtr->varFramePtr; + } else { + framePtr = framePtr->callerVarPtr; + } + if (framePtr == NULL) { + if (objc == 4) + goto levelError; + else + break; + } + + lineNum = framePtr->lineNum; + fileNamePtr = framePtr->fileName; + callerPtr = (framePtr?framePtr->callerVarPtr:NULL); + } + if (objc == 3) { + listPtr = Tcl_NewListObj(0,0); + } + if (objc == 3 || level == i) { + /* Append the following: line, file, level, proc, fullcmd */ + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(lineNum)); + Tcl_ListObjAppendElement(interp, listPtr, + fileNamePtr ? fileNamePtr : Tcl_NewStringObj("",0)); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj(callerPtr?callerPtr->level:0)); + + /* Append the current fully namespace qualified function. */ + if (callerPtr == NULL) { + nsObj = Tcl_NewStringObj("::",-1); + } else if (callerPtr->isProcCallFrame) { + Tcl_Command f = Tcl_GetCommandFromObj(interp, + callerPtr->objv[0]); + nsObj = Tcl_NewStringObj("", 0); + Tcl_GetCommandFullName(interp, f, nsObj); + } else if (callerPtr->nsPtr && callerPtr->nsPtr->fullName) { + nsObj = Tcl_NewStringObj(callerPtr->nsPtr->fullName,-1); + Tcl_AppendToObj(nsObj, "::", 2); + } else { + nsObj = Tcl_NewStringObj("", 0); + } + Tcl_ListObjAppendElement(interp, listPtr, nsObj); + + if (callerPtr == NULL) { + nsObj = Tcl_NewStringObj("", 0); + } else { + nsObj = Tcl_NewListObj(callerPtr->objc, callerPtr->objv); + } + Tcl_ListObjAppendElement(interp, listPtr, nsObj); + + if (objc == 4) { + break; + } + } + if (objc == 3) { + Tcl_ListObjAppendElement(interp, resultPtr, listPtr); + } + i--; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + + levelError: + if (resultPtr != NULL) { + Tcl_DecrRefCount(resultPtr); + } + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad level \"", + Tcl_GetString(objv[3]), + "\"", (char *) NULL); + return TCL_ERROR; + + } + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown subcommand: ", + "\"", subCmd, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * InfoLoadedCmd -- * * Called to implement the "info loaded" command that returns the @@ -1670,6 +2039,45 @@ /* *---------------------------------------------------------------------- * + * InfoReturnCmd -- + * + * Called to implement the "info return" command that returns the + * value returned by the previous command when in [trace execution]. + * + * info return + * + * Results: + * Returns TCL_OK. + * + * Side effects: + * Sets the interpreter's result object to the results of the + * previous command. + * + *---------------------------------------------------------------------- + */ + +static int +InfoReturnCmd(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) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + + if (iPtr->sourceInfo.lastResultPtr != NULL && iPtr->flags&TRACE_LINE_NUMBERS) { + Tcl_SetObjResult(interp, iPtr->sourceInfo.lastResultPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * InfoScriptCmd -- * * Called to implement the "info script" command that returns the @@ -1710,6 +2118,8 @@ } iPtr->scriptFile = objv[2]; Tcl_IncrRefCount(iPtr->scriptFile); + iPtr->sourceInfo.curFileName = + TclFSGetSourceFile(interp, iPtr->scriptFile); } if (iPtr->scriptFile != NULL) { Tcl_SetObjResult(interp, iPtr->scriptFile); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclCmdMZ.c tclnew4/generic/tclCmdMZ.c --- tcl.upd/generic/tclCmdMZ.c Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclCmdMZ.c Sun Jun 13 15:03:40 2004 @@ -2657,9 +2657,11 @@ { int i, j, index, mode, matched, result, splitObjs, numMatchesSaved; char *string, *pattern; - Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; + Tcl_Obj *stringObj, *indexVarObj, *matchVarObj, *bodyObj; Tcl_Obj *CONST *savedObjv = objv; Tcl_RegExp regExpr = NULL; + Interp *iPtr = (Interp *)interp; + int lineNum, curLine; static CONST char *options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-regexp", "--", NULL @@ -2668,6 +2670,9 @@ OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_REGEXP, OPT_LAST }; + curLine = iPtr->sourceInfo.curLineNum; + lineNum = iPtr->lineNum; + mode = OPT_EXACT; indexVarObj = NULL; matchVarObj = NULL; @@ -2745,6 +2750,7 @@ if (objc == 1) { Tcl_Obj **listv; + bodyObj = objv[0]; if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -2967,7 +2973,49 @@ break; } } + if (iPtr->flags&TRACE_LINE_NUMBERS) { + CONST char *cp, *match; + int n; + unsigned int mLen, nl=0; + + /* Count the newlines in the preceding code. */ + if (splitObjs) { + /* Search body for matching strings, counting \n as we go. */ + cp = string; + while (*cp) { + if (*cp++ == '\n') + nl++; + } + cp = Tcl_GetString(bodyObj); + for (n=0; n= (j-1)) + break; + while (*cp && mLen-- > 0) { + if (*cp++ == '\n') + nl++; + } + } + } else { + for (n=0; nlineNum = curLine + nl; + } result = Tcl_EvalObjEx(interp, objv[j], 0); + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; if (result == TCL_ERROR) { Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); @@ -3079,14 +3127,18 @@ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int result, value; + int result, value, lineNum, oldLine; + Interp *iPtr = (Interp*)interp; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } + oldLine = iPtr->lineNum; + lineNum = iPtr->sourceInfo.curLineNum; while (1) { + iPtr->lineNum = lineNum; result = Tcl_ExprBooleanObj(interp, objv[1], &value); if (result != TCL_OK) { return result; @@ -3106,6 +3158,7 @@ break; } } + iPtr->lineNum = oldLine; if (result == TCL_BREAK) { result = TCL_OK; } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclCompile.c tclnew4/generic/tclCompile.c --- tcl.upd/generic/tclCompile.c Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclCompile.c Sun Jun 13 15:03:40 2004 @@ -312,7 +312,7 @@ int numSrcBytes, int numCodeBytes)); static void EnterCmdStartData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, - int srcOffset, int codeOffset)); + int srcOffset, int codeOffset, Interp *iPtr)); static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( @@ -943,11 +943,14 @@ p = script; bytesLeft = numBytes; gotParse = 0; + do { + envPtr->startLine = iPtr->lineNum; if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { code = TCL_ERROR; goto error; } + parse.lineNum = iPtr->lineNum; /* Save lineNum subeval may change it. */ gotParse = 1; if (parse.numWords > 0) { int expand = 0; @@ -1013,7 +1016,8 @@ lastTopLevelCmdIndex = currCmdIndex; startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, - (parse.commandStart - envPtr->source), startCodeOffset); + (parse.commandStart - envPtr->source), startCodeOffset, + iPtr); /* * Each iteration of the following loop compiles one word @@ -1189,6 +1193,9 @@ next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; + if (iPtr != NULL) { + iPtr->lineNum = parse.lineNum + parse.lineCnt; + } Tcl_FreeParse(&parse); gotParse = 0; } while (bytesLeft > 0); @@ -2104,7 +2111,7 @@ */ static void -EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset, iPtr) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ @@ -2112,6 +2119,7 @@ * is being set. */ int srcOffset; /* Offset of first char of the command. */ int codeOffset; /* Offset of first byte of command code. */ + Interp *iPtr; /* Interpreter for line number info. */ { CmdLocation *cmdLocPtr; @@ -2157,6 +2165,9 @@ cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->numCodeBytes = -1; + cmdLocPtr->srcLineNum = iPtr->lineNum; + cmdLocPtr->fileName = iPtr->sourceInfo.curFileName; } /* @@ -2932,6 +2943,8 @@ int codeDelta, codeLen, srcDelta, srcLen, prevOffset; register int i; + codePtr->startLineNum = envPtr->startLine; + codePtr->fileName = envPtr->iPtr->sourceInfo.curFileName; /* * Encode the code offset for each command as a sequence of deltas. */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclCompile.h tclnew4/generic/tclCompile.h --- tcl.upd/generic/tclCompile.h Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclCompile.h Sun Jun 13 15:03:40 2004 @@ -117,6 +117,8 @@ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ int numSrcBytes; /* Number of command source chars. */ + int srcLineNum; /* The line number in the source. */ + Tcl_Obj *fileName; /* File containing source, if any. */ } CmdLocation; /* @@ -262,6 +264,7 @@ /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ + int startLine; } CompileEnv; /* @@ -375,6 +378,8 @@ * are always positive. This sequence is * just after the last byte in the source * delta sequence. */ + int startLineNum; /* The line number of the first instruction. */ + Tcl_Obj *fileName; /* Source file. */ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclDecls.h tclnew4/generic/tclDecls.h --- tcl.upd/generic/tclDecls.h Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclDecls.h Sun Jun 13 15:09:09 2004 @@ -3314,6 +3314,12 @@ EXTERN int Tcl_LimitGetGranularity _ANSI_ARGS_(( Tcl_Interp * interp, int type)); #endif +#ifndef Tcl_GetSourceInfo_TCL_DECLARED +#define Tcl_GetSourceInfo_TCL_DECLARED +/* 535 */ +EXTERN Tcl_SourceInfo * Tcl_GetSourceInfo _ANSI_ARGS_(( + Tcl_Interp * interp)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -3890,6 +3896,7 @@ int (*tcl_LimitGetCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 532 */ void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */ int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */ + Tcl_SourceInfo * (*tcl_GetSourceInfo) _ANSI_ARGS_((Tcl_Interp * interp)); /* 535 */ } TclStubs; #ifdef __cplusplus @@ -6070,6 +6077,10 @@ #define Tcl_LimitGetGranularity \ (tclStubsPtr->tcl_LimitGetGranularity) /* 534 */ #endif +#ifndef Tcl_GetSourceInfo +#define Tcl_GetSourceInfo \ + (tclStubsPtr->tcl_GetSourceInfo) /* 535 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclExecute.c tclnew4/generic/tclExecute.c --- tcl.upd/generic/tclExecute.c Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclExecute.c Mon Jun 21 09:55:20 2004 @@ -381,7 +381,7 @@ static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, int catchOnly, ByteCode* codePtr)); static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, - ByteCode* codePtr, int *lengthPtr)); + ByteCode* codePtr, int *lengthPtr, Interp *iPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( Tcl_Interp *interp, unsigned char *pc, @@ -1385,7 +1385,7 @@ int length, opnd; Tcl_Obj *newObjResultPtr; - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); result = Tcl_EvalEx(interp, bytes, length, 0); if (result != TCL_OK) { goto checkForCatch; @@ -1626,12 +1626,13 @@ tracePtr = nextTracePtr) { nextTracePtr = tracePtr->nextPtr; if (tracePtr->level == 0 || - iPtr->numLevels <= tracePtr->level) { + iPtr->numLevels <= tracePtr->level || + iPtr->sourceInfo.breakpoints != NULL) { /* * Traces will be called: get command string */ - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); break; } } @@ -1639,7 +1640,7 @@ Command *cmdPtr; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); } } @@ -4773,7 +4774,7 @@ checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - bytes = GetSrcInfoForPc(pc, codePtr, &length); + bytes = GetSrcInfoForPc(pc, codePtr, &length, iPtr); if (bytes != NULL) { DECACHE_STACK_INFO(); Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); @@ -4993,7 +4994,7 @@ if (checkStack && ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) { int numChars; - char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, iPtr); fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", stackTop, relativePc, stackLowerBound, stackUpperBound); @@ -5176,7 +5177,7 @@ */ static char * -GetSrcInfoForPc(pc, codePtr, lengthPtr) +GetSrcInfoForPc(pc, codePtr, lengthPtr, iPtr) unsigned char *pc; /* The program counter value for which to * return the closest command's source info. * This points to a bytecode instruction @@ -5186,6 +5187,7 @@ int *lengthPtr; /* If non-NULL, the location where the * length of the command's source should be * stored. If NULL, no length is stored. */ + Interp *iPtr; { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -5270,6 +5272,13 @@ if (lengthPtr != NULL) { *lengthPtr = bestSrcLength; } + if (iPtr != NULL) { + iPtr->sourceInfo.curLineNum = iPtr->lineNum; + for (i=0; isource[i] == '\n') + iPtr->sourceInfo.curLineNum++; + } + } return (codePtr->source + bestSrcOffset); } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclFileSystem.h tclnew4/generic/tclFileSystem.h --- tcl.upd/generic/tclFileSystem.h Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclFileSystem.h Sun Jun 13 15:03:40 2004 @@ -78,6 +78,8 @@ FilesystemRecord *fsRecPtr, ClientData clientData )); Tcl_Obj* TclFSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr, ClientData *clientDataPtr)); +Tcl_Obj* TclFSGetSourceFile _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *obj)); + /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclIOUtil.c tclnew4/generic/tclIOUtil.c --- tcl.upd/generic/tclIOUtil.c Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclIOUtil.c Sun Jun 13 15:03:40 2004 @@ -54,6 +54,7 @@ extern CONST char * tclpFileAttrStrings[]; extern CONST TclFileAttrProcs tclpFileAttrProcs[]; + /* * The following functions are obsolete string based APIs, and should * be removed in a future release (Tcl 9 would be a good time). @@ -1571,6 +1572,30 @@ return mode; } +Tcl_Obj* +TclFSGetSourceFile(interp, pathPtr) + Tcl_Interp *interp; + Tcl_Obj *pathPtr; +{ + int isnew; + Tcl_HashEntry *entry; + Interp *iPtr = (Interp *)interp; + Tcl_Obj *newPtr; + + if (!pathPtr) + return NULL; + entry=Tcl_CreateHashEntry(&iPtr->sourcedFiles, + Tcl_GetString(iPtr->scriptFile), &isnew); + if (isnew) { + newPtr = Tcl_DuplicateObj(iPtr->scriptFile); + Tcl_IncrRefCount(newPtr); + Tcl_SetHashValue(entry, newPtr); + } else { + newPtr = (Tcl_Obj*)Tcl_GetHashValue(entry); + } + return newPtr; +} + /* Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument */ int Tcl_FSEvalFile(interp, pathPtr) @@ -1617,6 +1642,7 @@ char *string; Tcl_Channel chan; Tcl_Obj *objPtr; + int lineNum; if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { return TCL_ERROR; @@ -1672,6 +1698,9 @@ iPtr = (Interp *) interp; oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; + iPtr->sourceInfo.curFileName = TclFSGetSourceFile(interp, pathPtr); + lineNum = iPtr->lineNum; + iPtr->lineNum = 1; Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); @@ -1684,6 +1713,7 @@ Tcl_DecrRefCount(iPtr->scriptFile); } iPtr->scriptFile = oldScriptFile; + iPtr->sourceInfo.curFileName = TclFSGetSourceFile(interp, oldScriptFile); if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); @@ -1706,6 +1736,7 @@ TclAppendObjToErrorInfo(interp, msg); Tcl_DecrRefCount(msg); } + iPtr->lineNum = lineNum; end: Tcl_DecrRefCount(objPtr); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclInt.h tclnew4/generic/tclInt.h --- tcl.upd/generic/tclInt.h Sun Jun 13 14:37:21 2004 +++ tclnew4/generic/tclInt.h Sun Jun 13 15:03:40 2004 @@ -658,6 +658,8 @@ CompiledLocal *lastLocalPtr; /* Pointer to the last allocated local * variable or NULL if none. This has * frame index (numCompiledLocals-1). */ + Tcl_Obj *fileName; /* File command is defined in. */ + int lineNum; /* Line number of proc definition. */ } Proc; /* @@ -766,6 +768,8 @@ * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ + int lineNum; /* Line number: meaningful only in "source" */ + Tcl_Obj *fileName; /* Object containing the file name. */ } CallFrame; /* @@ -1330,6 +1334,13 @@ Tcl_Obj *returnLevelKey; /* holds "-level" */ Tcl_Obj *returnOptionsKey; /* holds "-options" */ + int lineNum; /* Line number: meaningfull only in "source" */ + Tcl_SourceInfo sourceInfo; /* Source file/line info. */ + int relError; /* Use relative line # on procedure error. */ + Tcl_HashTable sourcedFiles; /* List of paths for "source"d files */ + Tcl_Obj *traceExecCmd; /* A single command for tracing execution. */ + Tcl_Trace traceExecId; /* Trace associated with traceExecCmd. */ + /* * Resource limiting framework support (TIP#143). */ @@ -1375,6 +1386,17 @@ } Interp; /* + * Stores the file name and newline map for a file. + * Eventually will be used as a symbol table. + */ +typedef struct SourceFileInfo { + Tcl_Obj *fileName; /* Object containing the file name. */ + Tcl_Obj *fileBody; /* Contents of the file.*/ + int *newlineMap; /* Newline map.*/ + int mapSize; /* Map size. */ +} SourceFiles; + +/* * EvalFlag bits for Interp structures: * * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with @@ -1421,6 +1443,7 @@ * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. + * TRACE_LINE_NUMBERS: Tracing line numbers in switch/if/for/while/etc. */ #define DELETED 1 @@ -1433,6 +1456,7 @@ #define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 #define INTERP_TRACE_IN_PROGRESS 0x200 +#define TRACE_LINE_NUMBERS 0x400 /* * Maximum number of levels of nesting permitted in Tcl commands (used @@ -1793,7 +1817,7 @@ Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr)); EXTERN int TclParseBackslash _ANSI_ARGS_((CONST char *src, - int numBytes, int *readPtr, char *dst)); + int numBytes, int *readPtr, char *dst, Tcl_Parse *parsePtr)); EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes, Tcl_UniChar *resultPtr)); EXTERN void TclParseInit _ANSI_ARGS_ ((Tcl_Interp *interp, @@ -1823,6 +1847,9 @@ Tcl_ThreadDataKey *keyPtr)); EXTERN char * TclpFindExecutable _ANSI_ARGS_(( CONST char *argv0)); +EXTERN Proc * TclFindProcByLine _ANSI_ARGS_((Interp *iPtr, + Tcl_Obj *fileName, int lineNum, Namespace *nsPtr, + Tcl_Obj **procName)); EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name, int *lengthPtr)); EXTERN int TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0)); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclNamesp.c tclnew4/generic/tclNamesp.c --- tcl.upd/generic/tclNamesp.c Sun Jun 13 14:37:22 2004 +++ tclnew4/generic/tclNamesp.c Sun Jun 13 15:03:40 2004 @@ -453,6 +453,8 @@ iPtr->framePtr = framePtr; iPtr->varFramePtr = framePtr; + framePtr->lineNum = iPtr->sourceInfo.curLineNum; + framePtr->fileName = iPtr->sourceInfo.curFileName; return TCL_OK; } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclObj.c tclnew4/generic/tclObj.c --- tcl.upd/generic/tclObj.c Sun Jun 13 14:37:22 2004 +++ tclnew4/generic/tclObj.c Sun Jun 13 15:03:40 2004 @@ -184,6 +184,12 @@ SetCmdNameFromAny /* setFromAnyProc */ }; +typedef struct ProcLineInfo { + int lineNum; /* Line Number for proc definitions */ + int lineFeeds; /* New lines in proc body */ + struct ProcLineInfo *next; +} ProcLineInfo; + /* * Structure containing a cached pointer to a command that is the result @@ -218,6 +224,7 @@ * ResolvedCmdName structure as its internal * rep. This structure can be freed when * refCount becomes zero. */ + ProcLineInfo * lineInfo; } ResolvedCmdName; @@ -3096,6 +3103,24 @@ cmdPtr = resPtr->cmdPtr; } } + if (resPtr != NULL && resPtr->lineInfo) { + + /* + * Restore saved line number information for proc's. + */ + ProcLineInfo *lineLast, *lineInfo=resPtr->lineInfo; + while (lineInfo->next != (ProcLineInfo *)NULL) { + lineLast = lineInfo; + lineInfo = lineInfo->next; + } + iPtr->lineNum = lineInfo->lineNum; + if (lineInfo == resPtr->lineInfo) { + resPtr->lineInfo=0; + } else { + lineLast->next=0; + } + ckfree((char *)lineInfo); + } iPtr->varFramePtr = savedFramePtr; return (Tcl_Command) cmdPtr; } @@ -3133,9 +3158,11 @@ register ResolvedCmdName *resPtr; Tcl_ObjType *oldTypePtr = objPtr->typePtr; register Namespace *currNsPtr; + ProcLineInfo *lineInfo; if (oldTypePtr == &tclCmdNameType) { - return; + resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; + goto setlineinfo; } /* @@ -3156,6 +3183,7 @@ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; + resPtr->lineInfo = NULL; if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); @@ -3163,6 +3191,18 @@ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = &tclCmdNameType; +setlineinfo: + if (cmdPtr->objProc != Tcl_ProcObjCmd) { + return; + } + + /* + * Save line number information for proc's + */ + lineInfo = (ProcLineInfo *)ckalloc(sizeof(ProcLineInfo)); + lineInfo->lineNum = iPtr->lineNum; + lineInfo->next = resPtr->lineInfo; + resPtr->lineInfo = lineInfo; } /* @@ -3210,6 +3250,16 @@ Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommand(cmdPtr); + + if (resPtr->lineInfo != NULL) { + ProcLineInfo *lineLast, *lineInfo=resPtr->lineInfo; + while (lineInfo->next != NULL) { + lineLast = lineInfo; + lineInfo = lineInfo->next; + ckfree((char*) lineLast); + } + ckfree((char*) lineInfo); + } ckfree((char *) resPtr); } } @@ -3323,6 +3373,7 @@ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; resPtr->cmdEpoch = cmdPtr->cmdEpoch; resPtr->refCount = 1; + resPtr->lineInfo = NULL; } else { resPtr = NULL; /* no command named "name" was found */ } diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclParse.c tclnew4/generic/tclParse.c --- tcl.upd/generic/tclParse.c Tue Apr 6 15:25:54 2004 +++ tclnew4/generic/tclParse.c Sun Jun 13 15:03:40 2004 @@ -272,6 +272,7 @@ CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ int scanned; + Interp *iPtr = (Interp *) interp; if ((string == NULL) && (numBytes>0)) { if (interp != NULL) { @@ -282,6 +283,11 @@ if (numBytes < 0) { numBytes = strlen(string); } + parsePtr->lineCnt = 0; + if (iPtr != NULL && nested == 0) { + parsePtr->lineNum = iPtr->lineNum; + parsePtr->fileName = TclFSGetSourceFile(interp, iPtr->scriptFile); + } TclParseInit(interp, string, numBytes, parsePtr); parsePtr->commentStart = NULL; parsePtr->commentSize = 0; @@ -299,6 +305,10 @@ */ scanned = ParseComment(string, numBytes, parsePtr); + if (iPtr != NULL && parsePtr->lineCnt) { + iPtr->lineNum += parsePtr->lineCnt; + parsePtr->lineCnt = 0; + } src = (string + scanned); numBytes -= scanned; if (numBytes == 0) { if (nested) { @@ -339,6 +349,9 @@ } if ((type & terminators) != 0) { parsePtr->term = src; + if (*src == '\n') { + parsePtr->lineCnt++; + } src++; break; } @@ -444,6 +457,9 @@ } if ((type & terminators) != 0) { parsePtr->term = src; + if (*src == '\n') { + parsePtr->lineCnt++; + } src++; break; } @@ -463,7 +479,6 @@ parsePtr->term = src; goto error; } - parsePtr->commandSize = src - parsePtr->commandStart; return TCL_OK; @@ -519,6 +534,8 @@ } if (p[1] != '\n') { break; + } else { + parsePtr->lineCnt++; } p+=2; if (--numBytes == 0) { @@ -611,7 +628,7 @@ *---------------------------------------------------------------------- */ int -TclParseBackslash(src, numBytes, readPtr, dst) +TclParseBackslash(src, numBytes, readPtr, dst, parsePtr) CONST char * src; /* Points to the backslash character of a * a backslash sequence */ int numBytes; /* Max number of bytes to scan */ @@ -621,6 +638,7 @@ * encoding of the backslash sequence is to be * written. At most TCL_UTF_MAX bytes will be * written there. */ + Tcl_Parse *parsePtr; { register CONST char *p = src+1; Tcl_UniChar result; @@ -694,6 +712,7 @@ } break; case '\n': + if (parsePtr) parsePtr->lineCnt++; count--; do { p++; count++; @@ -782,6 +801,7 @@ do { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); p += scanned; numBytes -= scanned; + if (*p == '\n') parsePtr->lineCnt++; } while (numBytes && (*p == '\n') && (p++,numBytes--)); if ((numBytes == 0) || (*p != '#')) { break; @@ -801,12 +821,13 @@ * and history indicate that it has been the de facto * rule. Don't change it now. */ - TclParseBackslash(p, numBytes, &scanned, NULL); + TclParseBackslash(p, numBytes, &scanned, NULL, parsePtr); p += scanned; numBytes -= scanned; } } else { p++; numBytes--; if (p[-1] == '\n') { + parsePtr->lineCnt++; break; } } @@ -888,10 +909,15 @@ * This is a simple range of characters. Scan to find the end * of the range. */ + if (*src == '\n') { + parsePtr->lineCnt++; + } while ((++src, --numBytes) && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) { - /* empty loop */ + if (*src == '\n') { + parsePtr->lineCnt++; + } } tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = src - tokenPtr->start; @@ -939,6 +965,7 @@ parsePtr->incomplete = nested.incomplete; return TCL_ERROR; } + parsePtr->lineCnt += nested.lineCnt; src = nested.commandStart + nested.commandSize; numBytes = parsePtr->end - src; @@ -986,7 +1013,7 @@ /* * Backslash substitution. */ - TclParseBackslash(src, numBytes, &tokenPtr->size, NULL); + TclParseBackslash(src, numBytes, &tokenPtr->size, NULL, parsePtr); if (tokenPtr->size == 1) { /* Just a backslash, due to end of string */ @@ -997,6 +1024,7 @@ } if (src[1] == '\n') { + parsePtr->lineCnt++; if (numBytes == 2) { parsePtr->incomplete = 1; } @@ -1568,7 +1596,7 @@ } break; case '\\': - TclParseBackslash(src, numBytes, &length, NULL); + TclParseBackslash(src, numBytes, &length, NULL, parsePtr); if ((length > 1) && (src[1] == '\n')) { /* * A backslash-newline sequence must be collapsed, even @@ -1605,6 +1633,9 @@ numBytes -= length - 1; } break; + case '\n': + parsePtr->lineCnt++; + break; } } } @@ -2254,3 +2285,5 @@ return 1; } + + diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclProc.c tclnew4/generic/tclProc.c --- tcl.upd/generic/tclProc.c Sun Jun 13 14:37:22 2004 +++ tclnew4/generic/tclProc.c Sun Jun 13 15:23:35 2004 @@ -132,6 +132,8 @@ Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, procName, -1); + procPtr->lineNum = iPtr->lineNum; + procPtr->fileName = iPtr->sourceInfo.curFileName; Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), TclProcInterpProc, (ClientData) procPtr, TclProcDeleteProc); @@ -737,6 +739,74 @@ return (Proc *) cmdPtr->clientData; } + +/* + *---------------------------------------------------------------------- + * + * TclFindProcByLine -- + * + * Given a file name and a line number, return a pointer to the + * record describing the procedure, if one exists at that line. + * + * Results: + * NULL is returned if no procedure is found at that line number. + * Otherwise, the return value is a pointer to the procedure's record. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Proc * +TclFindProcByLine(iPtr, fileName, lineNum, nsPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + Tcl_Obj *fileName; /* The file name */ + int lineNum; /* Line number within file. */ + Namespace *nsPtr; /* The namespace to start search from. */ + Tcl_Obj **procName; /* Name of the procedure to call. */ +{ + register Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr; + Namespace *childNsPtr; + Proc *procPtr; + char *fname=Tcl_GetString(fileName); + + if (nsPtr == (Namespace *)NULL) { + nsPtr=iPtr->globalNsPtr; + } + if (nsPtr == (Namespace *)NULL) { + return (Proc *)NULL; + } + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + if ((procPtr=TclIsProc(cmdPtr)) != (Proc *)NULL) { + if (procPtr->fileName && + (!strcmp(fname,Tcl_GetString(procPtr->fileName)))) { + if (lineNum>=procPtr->lineNum /* ??? && + lineNum<=(procPtr->lineNum+procPtr->lineFeeds)*/) { + *procName=Tcl_NewStringObj(nsPtr->fullName,-1); + Tcl_AppendStringsToObj(*procName, + (char*)Tcl_GetHashKey(&nsPtr->cmdTable,entryPtr),0); + return procPtr; + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); + entryPtr != NULL; + entryPtr = Tcl_NextHashEntry(&search)) { + childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); + if ((procPtr=TclFindProcByLine(iPtr, fileName, lineNum, childNsPtr, + procName))) + return procPtr; + } + return (Proc *)NULL; +} + /* *---------------------------------------------------------------------- * @@ -898,7 +968,9 @@ register Var *varPtr; register CompiledLocal *localPtr; char *procName; - int nameLen, localCt, numArgs, argCt, i, result; + int nameLen, localCt, numArgs, argCt, i, result, lineNum; + Tcl_Obj *objResult = Tcl_GetObjResult(interp), *fileName; + Interp *iPtr = (Interp *)interp; /* * This procedure generates an array "compiledLocals" that holds the @@ -910,6 +982,10 @@ Var localStorage[NUM_LOCALS]; Var *compiledLocals = localStorage; + lineNum = iPtr->lineNum; + fileName = iPtr->sourceInfo.curFileName; + iPtr->lineNum = procPtr->lineNum; + iPtr->sourceInfo.curFileName = procPtr->fileName; /* * Get the procedure's name. */ @@ -926,7 +1002,7 @@ result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); - + if (result != TCL_OK) { return result; } @@ -954,8 +1030,10 @@ (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1); if (result != TCL_OK) { - return result; + goto procExit; } + iPtr->lineNum = iPtr->sourceInfo.curLineNum = procPtr->lineNum; + iPtr->sourceInfo.curFileName = procPtr->fileName; framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ @@ -985,11 +1063,13 @@ if (!TclIsVarArgument(localPtr)) { Tcl_Panic("TclObjInterpProc: local variable %s is not argument but should be", localPtr->name); - return TCL_ERROR; + result = TCL_ERROR; + goto procExit; } if (TclIsVarTemporary(localPtr)) { Tcl_Panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i); - return TCL_ERROR; + result = TCL_ERROR; + goto procExit; } /* @@ -1105,6 +1185,10 @@ if (compiledLocals != localStorage) { ckfree((char *) compiledLocals); } + + procExit: + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curFileName = fileName; return result; #undef NUM_LOCALS } @@ -1213,6 +1297,8 @@ (Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0); if (result == TCL_OK) { + procPtr->lineNum = iPtr->lineNum; + procPtr->fileName = iPtr->sourceInfo.curFileName; result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); Tcl_PopCallFrame(interp); } @@ -1221,11 +1307,17 @@ if (result != TCL_OK) { if (result == TCL_ERROR) { + Proc *procPtr; Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); Tcl_Obj *message = Tcl_NewStringObj("\n (compiling ", -1); Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); + procPtr=TclFindProc(iPtr, procName); + if (procPtr && procPtr->fileName && (!iPtr->relError)) { + procName = Tcl_GetString(procPtr->fileName); + Tcl_SetIntObj(errorLine, procPtr->lineNum); + } TclAppendLimitedToObj(message, procName, -1, 50, NULL); Tcl_AppendToObj(message, "\", line ", -1); Tcl_AppendObjToObj(message, errorLine); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclStubInit.c tclnew4/generic/tclStubInit.c --- tcl.upd/generic/tclStubInit.c Sun Jun 13 14:37:22 2004 +++ tclnew4/generic/tclStubInit.c Sun Jun 13 15:11:16 2004 @@ -916,6 +916,7 @@ Tcl_LimitGetCommands, /* 532 */ Tcl_LimitGetTime, /* 533 */ Tcl_LimitGetGranularity, /* 534 */ + Tcl_GetSourceInfo, /* 535 */ }; /* !END!: Do not edit above this line. */ diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclTimer.c tclnew4/generic/tclTimer.c --- tcl.upd/generic/tclTimer.c Tue Apr 6 15:25:55 2004 +++ tclnew4/generic/tclTimer.c Sun Jun 13 15:03:40 2004 @@ -52,6 +52,9 @@ * timer handler. */ struct AfterInfo *nextPtr; /* Next in list of all "after" commands for * this interpreter. */ + int lineNum; /* Line number of after event. */ + int curLine; /* Line number of after event. */ + Tcl_Obj *fileName; /* Source filename. */ } AfterInfo; /* @@ -751,6 +754,7 @@ }; enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; ThreadSpecificData *tsdPtr = InitTimer(); + Interp *iPtr = (Interp*)interp; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -822,6 +826,9 @@ tsdPtr->afterId += 1; afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, (ClientData) afterPtr); + afterPtr->lineNum = iPtr->lineNum; + afterPtr->curLine = iPtr->sourceInfo.curLineNum; + afterPtr->fileName = iPtr->sourceInfo.curFileName; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; sprintf(buf, "after#%d", afterPtr->id); @@ -898,6 +905,9 @@ afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; afterPtr->token = NULL; + afterPtr->lineNum = iPtr->lineNum; + afterPtr->curLine = iPtr->sourceInfo.curLineNum; + afterPtr->fileName = iPtr->sourceInfo.curFileName; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); @@ -1017,10 +1027,12 @@ AfterInfo *afterPtr = (AfterInfo *) clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; AfterInfo *prevPtr; - int result; + int result, lineNum, curLine; Tcl_Interp *interp; char *script; int numBytes; + Tcl_Obj *fileName; + Interp *iPtr; /* * First remove the callback from our list of callbacks; otherwise @@ -1043,9 +1055,21 @@ */ interp = assocPtr->interp; + iPtr = (Interp*)interp; Tcl_Preserve((ClientData) interp); + /* Save/restore file/line number in case of trace. */ + lineNum = iPtr->lineNum; + curLine = iPtr->sourceInfo.curLineNum; + fileName = iPtr->sourceInfo.curFileName; + iPtr->sourceInfo.curFileName = afterPtr->fileName; + iPtr->lineNum = afterPtr->lineNum; + iPtr->sourceInfo.curLineNum = afterPtr->curLine; script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL); + iPtr->sourceInfo.curFileName = fileName; + iPtr->lineNum = lineNum; + iPtr->sourceInfo.curLineNum = curLine; + script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundError(interp); diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclTrace.c tclnew4/generic/tclTrace.c --- tcl.upd/generic/tclTrace.c Sun Jun 13 14:37:22 2004 +++ tclnew4/generic/tclTrace.c Mon Jun 21 14:29:18 2004 @@ -15,6 +15,7 @@ */ #include "tclInt.h" +#include "tclFileSystem.h" /* * Structure used to hold information about variable traces: @@ -133,6 +134,13 @@ Tcl_Command commandInfo, int objc, Tcl_Obj *CONST objv[])); +static int TraceExecProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp* interp, + int level, + CONST char* command, + Tcl_Command commandInfo, + int objc, + Tcl_Obj *CONST objv[])); static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); static void DisposeTraceResult _ANSI_ARGS_((int flags, char *result)); @@ -148,6 +156,152 @@ } StringTraceData; /* + * TraceExecProc -- + * Trace handler for the "trace execution TARGET" command. + * The handler produces the following list: + * + * - The line number the current instruction begins on. + * - The fully normalized file name. + * - The nesting level of the command. + * - The stack call level as per [info level]. + * - The current namespace, including function name if within one. + * - The fully qualified command name of the command to be invoked. + * - The command with arguments as a list. + * - The current fully namespace:: qualified function + * - The flags from sourceInfo. + * + * If TARGET is a valid Tcl channel opened for output, the list + nl is + * output to it, otherwise TARGET is presumed to be a valid Tcl command + * to which the list elements are appended as arguments before eval. + */ +static int +TraceExecProc (clientData, interp, level, command, commandInfo, objc, objv) + ClientData clientData; + Tcl_Interp *interp; + int level; + CONST char *command; + Tcl_Command commandInfo; + int objc; + struct Tcl_Obj * CONST * objv; +{ + Interp *iPtr = (Interp *)interp; + Tcl_SourceInfo *srcInfo; + Tcl_Obj *obj, *nobj, *nsObj = NULL; + Tcl_Obj **listv; + int len, lineNum, curLine, mode = 0, result = TCL_OK; + Tcl_Channel channel = NULL; + CONST char *cmdName; + + srcInfo = &iPtr->sourceInfo; + srcInfo->lastTracedLine = srcInfo->curLineNum; + if (iPtr->traceExecCmd == NULL) + return TCL_OK; + cmdName = Tcl_GetString(iPtr->traceExecCmd); + if (*cmdName == '1' && cmdName[1] == 0) { + return TCL_OK; + } + if (Tcl_ListObjGetElements(interp, iPtr->traceExecCmd, &len, &listv) + != TCL_OK) { + return TCL_ERROR; + } + if (len == 1 && ((channel=Tcl_GetChannel(interp, Tcl_GetString(listv[0]), + &mode)) != NULL) && (mode&TCL_WRITABLE)) { + obj = Tcl_NewListObj(0, 0); + } else { + obj = Tcl_NewListObj(len, listv); + } + Tcl_IncrRefCount(obj); + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(srcInfo->curLineNum)); + Tcl_ListObjAppendElement(interp, obj, + srcInfo->curFileName?srcInfo->curFileName: + Tcl_NewStringObj("",0)); + + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(level)); + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(srcInfo->stackLevel)); + + /* Append the current fully qualified namespace/function. */ + if (iPtr->varFramePtr == NULL) { + nsObj = Tcl_NewStringObj("::",-1); + } else if (iPtr->varFramePtr->isProcCallFrame) { + Tcl_Command f = Tcl_GetCommandFromObj(interp, + iPtr->varFramePtr->objv[0]); + nsObj = Tcl_NewStringObj("", 0); + Tcl_GetCommandFullName(interp, f, nsObj); + } else if (iPtr->varFramePtr->nsPtr && iPtr->varFramePtr->nsPtr->fullName) { + nsObj = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName,-1); + Tcl_AppendToObj(nsObj, "::", 2); + } else { + nsObj = Tcl_NewStringObj("", 0); + } + Tcl_ListObjAppendElement(interp, obj, nsObj); + + nobj = Tcl_NewObj(); + Tcl_GetCommandFullName(interp, commandInfo, nobj); + Tcl_ListObjAppendElement(interp, obj, nobj); + Tcl_ListObjAppendElement(interp, obj, Tcl_NewListObj(objc, objv)); + /* Set the breakpoint flag if necessary. */ + if ((!(srcInfo->flags&1)) && srcInfo->breakpoints != NULL) { + Tcl_Breakpoint *curBP = srcInfo->breakpoints; + + while (curBP != NULL) { + if (curBP->state>0 && curBP->lineNum == srcInfo->curLineNum && + curBP->fileName == srcInfo->curFileName) { + if ((curBP->counter=(curBP->counter+1)%curBP->state)==0) { + break; + } + } + curBP = curBP->next; + } + if (curBP != NULL) { + srcInfo->flags |= 1; + } + } + Tcl_ListObjAppendElement(interp, obj, Tcl_NewIntObj(srcInfo->flags)); + srcInfo->flags &= ~1; /* Clear the breakpoint flag. */ + + lineNum = iPtr->lineNum; + curLine = srcInfo->curLineNum; + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + if (channel != NULL) { + if (Tcl_WriteObj(channel, obj) <0 || Tcl_Write(channel, "\n", 1) <0) { + /* If closed or an IO error occurred, remove the trace. */ + Tcl_GlobalEval(interp, "trace executon {}"); + Tcl_AddErrorInfo(interp, "Execution trace error writing channel: "); + Tcl_BackgroundError( interp ); + } + } else { + Tcl_SavedResult state; + Tcl_Obj *stateReturnOpts; + + Tcl_SaveResult(interp, &state); + stateReturnOpts = iPtr->returnOpts; + Tcl_IncrRefCount(stateReturnOpts); + + result = Tcl_EvalObjEx(interp, obj, TCL_EVAL_DIRECT); + if (result == TCL_OK) { + /* Restore result if trace execution was successful */ + Tcl_RestoreResult(interp, &state); + if (iPtr->returnOpts != stateReturnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); + iPtr->returnOpts = stateReturnOpts; + Tcl_IncrRefCount(iPtr->returnOpts); + } + } else { + Tcl_DiscardResult(&state); + } + Tcl_DecrRefCount(stateReturnOpts); + + } + Tcl_DecrRefCount(obj); + iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + iPtr->lineNum = lineNum; + srcInfo->curLineNum = curLine; + + return result; +} + + +/* *---------------------------------------------------------------------- * * Tcl_TraceObjCmd -- @@ -181,7 +335,7 @@ size_t length; /* Main sub commands to 'trace' */ static CONST char *traceOptions[] = { - "add", "info", "remove", + "add", "info", "remove", "execution", "breakpoint", #ifndef TCL_REMOVE_OBSOLETE_TRACES "variable", "vdelete", "vinfo", #endif @@ -189,7 +343,7 @@ }; /* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptions { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE, + TRACE_ADD, TRACE_INFO, TRACE_REMOVE, TRACE_EXECUTION, TRACE_BREAKPOINT, #ifndef TCL_REMOVE_OBSOLETE_TRACES TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO #endif @@ -245,6 +399,123 @@ return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv); break; } + case TRACE_EXECUTION: { + Interp *iPtr = (Interp *)interp; + int strLen, level=0; + + if (objc == 2) { + if (iPtr->traceExecCmd != NULL) { + Tcl_SetObjResult(interp, iPtr->traceExecCmd); + } + return TCL_OK; + } + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "command ?level?"); + return TCL_ERROR; + } + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &level) != TCL_OK) { + return TCL_ERROR; + } + } + if (iPtr->traceExecCmd != NULL) { + Tcl_DecrRefCount(iPtr->traceExecCmd); + iPtr->traceExecCmd = NULL; + } + p = Tcl_GetStringFromObj(objv[2], &strLen); + if (iPtr->traceExecId != NULL) { + Tcl_DeleteTrace(interp, iPtr->traceExecId); + iPtr->traceExecId = NULL; + } + if (strLen>0 && (strcmp(p,"0"))) { + iPtr->traceExecCmd = objv[2]; + Tcl_IncrRefCount(objv[2]); + iPtr->traceExecId = Tcl_CreateObjTrace(interp, level, TCL_TRACE_LINE_NUMBERS, TraceExecProc, 0, 0); + } + return TCL_OK; + break; + } + case TRACE_BREAKPOINT: { + Interp *iPtr = (Interp *)interp; + Tcl_Breakpoint *curBP = iPtr->sourceInfo.breakpoints; + Tcl_Obj *listPtr; + int idx; + + if (objc == 2) { + if (!curBP) { + return TCL_OK; + } + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + while (curBP) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewIntObj(curBP->lineNum)); + Tcl_ListObjAppendElement(NULL, listPtr, curBP->fileName); + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewIntObj(curBP->state)); + curBP = curBP->next; + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + if ((objc%3) == 0) { + Tcl_WrongNumArgs(interp, 2, objv, "line file ?state ...?"); + return TCL_ERROR; + } + idx = 2; + while ((idx+1)sourceInfo.breakpoints; + while (curBP != NULL) { + if (curBP->lineNum == lineNum + && (!strcmp(Tcl_GetString(fileName), + Tcl_GetString(curBP->fileName)))) { + break; + } + curBP = curBP->next; + } + if ((idx+2)>objc) { + if (curBP == NULL) { + Tcl_AppendResult(interp, "Breakpoint not found", 0); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(curBP->state)); + return TCL_OK; + } + if (curBP == NULL) { + curBP = (Tcl_Breakpoint*) ckalloc(sizeof(Tcl_Breakpoint)); + curBP->next = iPtr->sourceInfo.breakpoints; + iPtr->sourceInfo.breakpoints = curBP; + curBP->lineNum = lineNum; + curBP->fileName = TclFSGetSourceFile(interp, fileName); + } + curBP->counter = 0; + /* The empty state means delete the breakpoint. */ + if (strlen(Tcl_GetString(objv[idx+2])) == 0) { + Tcl_Breakpoint *prevBP = iPtr->sourceInfo.breakpoints; + + while (prevBP != NULL && prevBP->next != curBP) { + prevBP = prevBP->next; + } + if (prevBP != NULL) { + prevBP->next = curBP->next; + } else { + iPtr->sourceInfo.breakpoints = curBP->next; + } + ckfree((char*) curBP); + } else if (Tcl_GetIntFromObj(interp, objv[idx+2], + &curBP->state) != TCL_OK) { + return TCL_ERROR; + } + idx += 3; + } + break; + } #ifndef TCL_REMOVE_OBSOLETE_TRACES case TRACE_OLD_VARIABLE: { @@ -266,6 +537,8 @@ flags |= TCL_TRACE_UNSETS; } else if (*p == 'a') { flags |= TCL_TRACE_ARRAY; + } else if (*p == 'd') { + flags |= TCL_TRACE_LINE_NUMBERS; } else { goto badVarOps; } @@ -382,6 +655,10 @@ *p = 'a'; p++; } + if (tvarPtr->flags & TCL_TRACE_LINE_NUMBERS) { + *p = 'd'; + p++; + } *p = '\0'; /* @@ -876,9 +1153,10 @@ size_t length; enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; static CONST char *opStrings[] = { "array", "read", "unset", "write", + "debug", (char *) NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, - TRACE_VAR_WRITE }; + TRACE_VAR_WRITE, TRACE_VAR_DEBUG }; switch ((enum traceOptions) optionIndex) { case TRACE_ADD: @@ -902,7 +1180,7 @@ } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of array, read, unset, or write", + "one or more of array, read, unset, write, or debug", TCL_STATIC); return TCL_ERROR; } @@ -924,6 +1202,10 @@ case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; + case TRACE_VAR_DEBUG: + /* Disables execution traces during write trace. */ + flags |= TCL_TRACE_LINE_NUMBERS; + break; } } command = Tcl_GetStringFromObj(objv[5], &commandLength); @@ -1010,6 +1292,10 @@ Tcl_ListObjAppendElement(NULL, elemObjPtr, Tcl_NewStringObj("unset", 5)); } + if (tvarPtr->flags & TCL_TRACE_LINE_NUMBERS) { + Tcl_ListObjAppendElement(NULL, elemObjPtr, + Tcl_NewStringObj("debug", 5)); + } eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); @@ -1559,7 +1845,26 @@ active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->level > 0 && curLevel > tracePtr->level) { - continue; + Tcl_Breakpoint *curBP = iPtr->sourceInfo.breakpoints; + + if ((!(tracePtr->flags&TCL_TRACE_LINE_NUMBERS)) || curBP == NULL) { + continue; + } + /* Determine we are at a breakpoint. */ + while (curBP != NULL) { + if (curBP->state>0 && + curBP->lineNum == iPtr->sourceInfo.curLineNum && + curBP->fileName == iPtr->sourceInfo.curFileName) { + if ((curBP->counter=(curBP->counter+1)%curBP->state)==0) { + break; + } + } + curBP = curBP->next; + } + if (curBP == NULL) { + continue; + } + iPtr->sourceInfo.flags |= 1; } if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) { /* @@ -1638,26 +1943,34 @@ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; - char *commandCopy; + char *commandCopy = NULL; int traceCode; - /* - * Copy the command characters into a new string. - */ - - commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); - memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); - commandCopy[numChars] = '\0'; + if (tracePtr->flags&TCL_TRACE_LINE_NUMBERS) { + iPtr->sourceInfo.commandLen = numChars; + iPtr->sourceInfo.stackLevel = iPtr->varFramePtr==NULL ? 0 : + iPtr->varFramePtr->level; + } else { + /* + * Copy the command characters into a new string. + */ + commandCopy = (char *) ckalloc((unsigned) (numChars + 1)); + memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars); + commandCopy[numChars] = '\0'; + command = commandCopy; + } /* * Call the trace procedure then free allocated storage. */ traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr, - iPtr->numLevels, commandCopy, + iPtr->numLevels, command, (Tcl_Command) cmdPtr, objc, objv ); - ckfree((char *) commandCopy); + if (commandCopy != NULL) { + ckfree((char *) commandCopy); + } return(traceCode); } @@ -1926,8 +2239,9 @@ Tcl_SavedResult state; TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; - int code; + int code, setTrace = 0; Tcl_DString cmd; + Interp *iPtr = (Interp *)interp; /* * We might call Tcl_Eval() below, and that might evaluate @@ -1962,6 +2276,8 @@ Tcl_DStringAppend(&cmd, " w", 2); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " u", 2); + } else if (flags & TCL_TRACE_LINE_NUMBERS) { + Tcl_DStringAppend(&cmd, " d", 2); } } else { #endif @@ -1973,6 +2289,8 @@ Tcl_DStringAppend(&cmd, " write", 6); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " unset", 6); + } else if (flags & TCL_TRACE_LINE_NUMBERS) { + Tcl_DStringAppend(&cmd, " debug", 6); } #ifndef TCL_REMOVE_OBSOLETE_TRACES } @@ -1992,8 +2310,16 @@ tvarPtr->flags |= TCL_TRACE_DESTROYED; } + if (flags&TCL_TRACE_LINE_NUMBERS && + (!(iPtr->flags&INTERP_TRACE_IN_PROGRESS))) { + iPtr->flags |= INTERP_TRACE_IN_PROGRESS; + setTrace = 1; + } code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), 0); + if (setTrace) { + iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS; + } if (code != TCL_OK) { /* copy error msg to result */ register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsgObj); @@ -2113,6 +2439,9 @@ } iPtr->tracesForbiddingInline++; } + if (flags & TCL_TRACE_LINE_NUMBERS) { + iPtr->flags |= USE_EVAL_DIRECT|TRACE_LINE_NUMBERS; + } tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; @@ -2309,6 +2638,10 @@ } (*tracePtr2) = (*tracePtr2)->nextPtr; + /* Remove global line number trace. */ + if (tracePtr->flags & TCL_TRACE_LINE_NUMBERS) { + iPtr->flags &= ~(USE_EVAL_DIRECT|TRACE_LINE_NUMBERS); + } /* * If the trace forbids bytecode compilation, change the interpreter's * state. If bytecode compilation is now permitted, flag the fact and @@ -3010,3 +3343,18 @@ varPtr->tracePtr = tracePtr; return TCL_OK; } + +/* + * Tcl_GetSourceInfo -- + * Stubbed interface to get source info associated with a command trace. + */ +Tcl_SourceInfo * +Tcl_GetSourceInfo(interp) + Tcl_Interp *interp; /* Interpreter for traced command. */ +{ + Interp *iPtr = (Interp*) interp; + if (iPtr == NULL) + return NULL; + return &iPtr->sourceInfo; +} + diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/generic/tclUtf.c tclnew4/generic/tclUtf.c --- tcl.upd/generic/tclUtf.c Wed Oct 8 07:24:41 2003 +++ tclnew4/generic/tclUtf.c Sun Jun 13 15:03:40 2004 @@ -788,10 +788,10 @@ int numRead; int result; - result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst); + result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst, NULL); if (numRead == LINE_LENGTH) { /* We ate a whole line. Pay the price of a strlen() */ - result = TclParseBackslash(src, (int)strlen(src), &numRead, dst); + result = TclParseBackslash(src, (int)strlen(src), &numRead, dst, NULL); } if (readPtr != NULL) { *readPtr = numRead; diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/library/tcltest/tcltest.tcl tclnew4/library/tcltest/tcltest.tcl --- tcl.upd/library/tcltest/tcltest.tcl Sun Jun 13 14:37:22 2004 +++ tclnew4/library/tcltest/tcltest.tcl Sun Jun 13 15:03:40 2004 @@ -18,6 +18,9 @@ # # RCS: @(#) $Id: tcltest.tcl,v 1.91 2004/05/26 16:25:00 dgp Exp $ +# Disable absolute line number/filename in proc error. +info line relerror 1 + package require Tcl 8.3 ;# uses [glob -directory] namespace eval tcltest { diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/tests/info.test tclnew4/tests/info.test --- tcl.upd/tests/info.test Sun Jun 13 14:37:23 2004 +++ tclnew4/tests/info.test Sun Jun 13 15:03:40 2004 @@ -622,16 +622,16 @@ } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-21.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg -} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} test info-21.3 {miscellaneous error conditions} { list [catch {info c} msg] $msg -} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} test info-21.4 {miscellaneous error conditions} { list [catch {info l} msg] $msg -} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} test info-21.5 {miscellaneous error conditions} { list [catch {info s} msg] $msg -} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}} +} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, line, loaded, locals, nameofexecutable, patchlevel, procs, return, script, sharedlibextension, tclversion, or vars}} # cleanup catch {namespace delete test_ns_info1 test_ns_info2} diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/tests/trace.test tclnew4/tests/trace.test --- tcl.upd/tests/trace.test Mon Mar 1 09:33:45 2004 +++ tclnew4/tests/trace.test Mon Jun 14 09:37:30 2004 @@ -786,14 +786,14 @@ test trace-14.5 {trace command, invalid option} { list [catch {trace gorp} msg] $msg -} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"] +} [list 1 "bad option \"gorp\": must be add, info, remove, execution, variable, vdelete, or vinfo"] # Again, [trace ... command] and [trace ... variable] share syntax and # error message styles for their opList options; these loops test those # error messages. set i 0 -set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"] +set errs [list "array, read, unset, write, or debug" "delete or rename" "enter, leave, enterstep, or leavestep"] set abbvs [list {a r u w} {d r} {}] proc x {} {} foreach type {variable command execution} err $errs abbvlist $abbvs { @@ -2206,6 +2206,17 @@ # Unset the varaible when done catch {unset info} +test trace-33.1 { + Line number verification using "trace execution" +} { + set dir [file join [pwd] [file dirname [info script]]] + foreach i {1 2 3} { + set result [exec [info nameofexecutable] ../tools/trcline.tcl ../tests/trcline/trcln$i.tcl] + lappend rc [lindex [lindex [split $result \n] end] end] + } + set rc +} [list 3 0 0] + # cleanup ::tcltest::cleanupTests return diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/tests/trcline/trcln1.tcl tclnew4/tests/trcline/trcln1.tcl --- tcl.upd/tests/trcline/trcln1.tcl Wed Dec 31 16:00:00 1969 +++ tclnew4/tests/trcline/trcln1.tcl Mon Jun 14 09:29:05 2004 @@ -0,0 +1,77 @@ +# This is line 1. +# And 2 \ +3 is continue. +proc ::Echo args { + puts "> $args" +} +#trace execution ::Echo +set i \ +1 +set str { + set x 1 + incr x + incr x $i +} +incr i +puts "i=$i" +eval $str +eval { + set l [expr {$i+1}] + puts $l +} +namespace eval y { + #source /tmp/t +} +proc b args { + puts "HI: $args" +} +namespace eval xx { + set j 1 + incr j + proc a args { + set k 1 + if {$k<1} { + set x 0 + } else { + set x 1 + } + incr k + b aa + } + a + uplevel #0 { + set z 0 + } +} +puts $xx::j +xx::a +foreach f {xx::a b} { + puts "$f: FILE=[info line file $f] LINE=[info line number $f]" +} +proc XX args { +set i 1 +set j 0 +while {[incr i]<6} { + incr j + if {$j>4} break + if {$j>2} continue + incr j 2 +} +for {set i 1} {$i<3} {incr i} { + incr j +} +switch y { + x { + set i 1 + } + y { + set i 2 + } + z { + set i 2 + } +} +set q 1 +} +XX +puts DONE diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/tests/trcline/trcln2.tcl tclnew4/tests/trcline/trcln2.tcl --- tcl.upd/tests/trcline/trcln2.tcl Wed Dec 31 16:00:00 1969 +++ tclnew4/tests/trcline/trcln2.tcl Sun Jun 13 15:03:40 2004 @@ -0,0 +1,11 @@ +proc Echo args { + puts stderr "> $args" +} +#trace execution ::Echo +proc foo args { + puts "FOO: $args" + set ::forever 1 +} + +after idle foo +catch {vwait forever} diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/tests/trcline/trcln3.tcl tclnew4/tests/trcline/trcln3.tcl --- tcl.upd/tests/trcline/trcln3.tcl Wed Dec 31 16:00:00 1969 +++ tclnew4/tests/trcline/trcln3.tcl Sun Jun 13 15:03:40 2004 @@ -0,0 +1,20 @@ +#trace execution stdout + proc a args { + set k 1 + if {$k<1} { + set x 0 + } else { + set x 1 + } + incr k + set j 1 + if {$j<1} { + set y 0 + } else { + set y 1 + } + incr j + } +a +a +set z 1 diff -x '*.swp' -P --exclude=tags --exclude=CVS -r -u tcl.upd/tools/trcline.tcl tclnew4/tools/trcline.tcl --- tcl.upd/tools/trcline.tcl Wed Dec 31 16:00:00 1969 +++ tclnew4/tools/trcline.tcl Sun Jun 13 15:53:38 2004 @@ -0,0 +1,63 @@ +#!./tclsh +# This utility runs a script using the new Tcl feature "execution trace". +# It is useful for testing the accuracy of the line numbers reported by Tcl. +# It counts the number of traced lines that do not seem to match the reported +# file/line number. Lines that absolutely do not seem to match are echoed. +# The final output line contains the five numeric counters: +# +# lines - all lines where filenames were not null. +# matched - matched perfectly. +# submatch - matched a substring in the file/line. +# matchcmd - matched only the cmd or first token. +# nomatch - did not even match the cmd. +# +# The "nomatch" metric in particular counts when Tcl probably got it wrong. +# However, one case where this is currently occurs is "eval $str". +# But in the future, evaling a variable should be detected and return 0. +# +# Copyright (c) 2004 PDQ Interfaces Inc. http://pdqi.com +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: trcline.tcl,v 1.0 2004/04/01 17:33:45 pmacdonald Exp $ + +array set pc {matched 0 nomatch 0 matchcmd 0 submatch 0 lines 0} + +# Run the specified script in a sub-interp. +set file [lindex $argv 0] +set i [interp create] +$i eval [list set argv0 $file] +$i eval [list set argv [lrange $argv 1 end]] + +proc CheckTrace {line file nest stack nsfunc fcmd ecmd} { + variable pc + # puts "> $line $file $nest $stack $fcmd $ecmd" + if {![string length $file] || $line == {0}} return + incr pc(lines) + if {![file exists pc(file:$file)]} { + set data [read [set fp [open $file]]] + close $fp + set pc(file:$file) [split $data \n] + } + set mline [string trim [lindex $pc(file:$file) [expr {$line-1}]]] + set eline [string trim [lindex [split $ecmd \n] 0]] + set eword [lindex [split $eline { }] 0] + if {$mline == $eline} { + incr pc(matched) + } else { + if {[string first $eline $mline]>=0} { + incr pc(submatch) + } elseif {[string first $eword $mline]<0} { + incr pc(nomatch) + puts "# MISMATCH: <$mline> <$eline>" + } else { + incr pc(matchcmd) + } + } +} +interp alias $i __ExecTrace__ {} CheckTrace +$i eval trace execution __ExecTrace__ +$i eval source $file +puts "$pc(lines) $pc(matched) $pc(submatch) $pc(matchcmd) $pc(nomatch)" +