diff options
70 files changed, 1777 insertions, 1553 deletions
@@ -1,3 +1,25 @@ +2013-09-01 Donal Fellows <dkf@users.sf.net> + + * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that + whitespace at the end of a string don't cause the decoder to drop the + last decoded byte. + +2013-08-03 Donal Fellows <dkf@users.sf.net> + + * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found + by the autoloading mechanism. + +2013-08-02 Donal Fellows <dkf@users.sf.net> + + * generic/tclOODefineCmds.c (ClassSuperSet): Bug [9d61624b3d]: Stop + crashes when emptying the superclass slot, even when doing elaborate + things with metaclasses. + +2013-08-01 Harald Oehlmann <oehhar@users.sf.net> + + * tclUnixNotify.c (Tcl_InitNotifier): Bug [a0bc856dcd]: Start notifier + thread again if we were forked, to solve Rivet bug 55153. + 2013-07-05 Kevin B. Kenny <kennykb@acm.org> * library/tzdata/Africa/Casablanca: diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index b9c6a63..36f6a20 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -176,16 +176,16 @@ these return options. The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. -The \fB\-errorcode\fR option holds a list of items that +The \fB\-errorcode\fR option holds a Tcl list of items that are intended to be machine-readable. The first item in the \fB\-errorcode\fR value identifies the class of error that occurred -(e.g. POSIX means an error occurred in a POSIX system call) +(e.g., POSIX means an error occurred in a POSIX system call) and additional elements hold additional pieces of information that depend on the class. -See the \fBtclvars\fR manual entry for details on the various -formats for the \fB\-errorcode\fR option used by -Tcl's built-in commands. +See the manual entry on the \fBerrorCode\fR variable for details on the +various formats for the \fB\-errorcode\fR option used by Tcl's built-in +commands. .PP The \fB\-errorinfo\fR option value is gradually built up as an error unwinds through the nested operations. @@ -307,6 +307,6 @@ so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), -Tcl_SetErrno(3), tclvars(n) +Tcl_SetErrno(3), errorCode(n), errorInfo(n) .SH KEYWORDS error, value, value result, stack, trace, variable diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index a248cf4..1156a20 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -41,8 +41,9 @@ may only be passed to Tcl routines called from the same thread as the original \fBTcl_CreateInterp\fR call. It is not safe for multiple threads to pass the same token to Tcl's routines. The new interpreter is initialized with the built-in Tcl commands -and with the variables documented in the \fBtclvars\fR manual page. To bind in -additional commands, call \fBTcl_CreateCommand\fR. +and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To +bind in additional commands, call \fBTcl_CreateCommand\fR, and to +create additional variables, call \fBTcl_SetVar\fR. .PP \fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have @@ -144,6 +145,6 @@ should be used to determine when an interpreter is a candidate for deletion due to inactivity. .VE 8.6 .SH "SEE ALSO" -Tcl_Preserve(3), Tcl_Release(3), tclvars(n) +Tcl_Preserve(3), Tcl_Release(3) .SH KEYWORDS command, create, delete, interpreter diff --git a/doc/Environment.3 b/doc/Environment.3 index 3753f43..46262ab 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -33,6 +33,6 @@ Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" -tclvars(n) +env(n) .SH KEYWORDS environment, variable diff --git a/doc/Method.3 b/doc/Method.3 index 43b3609..2537d5e 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -172,8 +172,9 @@ typedef struct { .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is reserved -for debugging. +\fIname\fR field provides a human-readable name for the type, and is the value +that is exposed via the \fBinfo class methodtype\fR and +\fBinfo object methodtype\fR Tcl commands. .PP The \fIcallProc\fR field gives a function that is called when the method is invoked; it must never be NULL. @@ -8,7 +8,7 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -207,7 +207,7 @@ is something like: .PP .CS int -\fITheCmdObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -225,7 +225,7 @@ int return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, clientData, TheCmdDeleteProc); + \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To enable a command like this one for trampoline-based evaluation, @@ -255,8 +255,8 @@ int int objc, Tcl_Obj *const objv[]) { - return \fBTcl_NRCallObjProc\fR(interp, name, - \fITheCmdNRObjProc\fR, clientData, objc, objv); + return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, + clientData, objc, objv); } .CE .PP @@ -317,7 +317,7 @@ and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData, + \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, TheCmdDeleteProc); .CE .SH "SEE ALSO" diff --git a/doc/bgerror.n b/doc/bgerror.n index ac53eca..16a23a3 100644 --- a/doc/bgerror.n +++ b/doc/bgerror.n @@ -85,6 +85,9 @@ proc bgerror {message} { } .CE .SH "SEE ALSO" -after(n), interp(n), tclvars(n) +after(n), errorCode(n), errorInfo(n), interp(n) .SH KEYWORDS background error, reporting +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/doc/binary.n b/doc/binary.n index 68bf9cc..a40afe6 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -884,7 +884,7 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tclvars(n) +format(n), scan(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: diff --git a/doc/catch.n b/doc/catch.n index a05ca71..9597ccf 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -115,7 +115,8 @@ if { [\fBcatch\fR {open $someFile w} fid] } { There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. .SH "SEE ALSO" -break(n), continue(n), dict(n), error(n), info(n), return(n), tclvars(n) +break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n), +return(n) .SH KEYWORDS catch, error, exception '\" Local Variables: @@ -75,7 +75,8 @@ However, the last line would now normally be written without set var [linsert $var 0 {*}$args] .CE .SH "SEE ALSO" -catch(n), concat(n), error(n), interp(n), list(n), namespace(n), subst(n), tclvars(n), uplevel(n) +catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n), +namespace(n), subst(n), uplevel(n) .SH KEYWORDS concatenate, evaluate, script '\" Local Variables: @@ -296,7 +296,6 @@ Returns the name of the library directory in which standard Tcl scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. -See the \fBtclvars\fR manual entry for more information. .TP \fBinfo loaded \fR?\fIinterp\fR? . @@ -336,8 +335,8 @@ described in \fBOBJECT INTROSPECTION\fR below. .TP \fBinfo patchlevel\fR . -Returns the value of the global variable \fBtcl_patchLevel\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_patchLevel\fR, which holds +the exact version of the Tcl library by default. .TP \fBinfo procs \fR?\fIpattern\fR? . @@ -374,8 +373,8 @@ string is returned. .TP \fBinfo tclversion\fR . -Returns the value of the global variable \fBtcl_version\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_version\fR, which holds the +major and minor version of the Tcl library by default. .TP \fBinfo vars\fR ?\fIpattern\fR? . @@ -763,8 +762,9 @@ proc getDef {obj method} { .VE 8.6 .SH "SEE ALSO" .VS 8.6 -global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n) +global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), .VE 8.6 +tcl_library(n), tcl_patchLevel(n), tcl_version(n) .SH KEYWORDS command, information, interpreter, introspection, level, namespace, .VS 8.6 diff --git a/doc/library.n b/doc/library.n index 2413692..98dcb35 100644 --- a/doc/library.n +++ b/doc/library.n @@ -262,13 +262,17 @@ If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR +. If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations. +search during auto-load operations (including for package index +files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, -the directory named by the \fBtcl_library\fR variable, +the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. +Additional locations to look for files and package indices should +normally be added to this variable using \fBlappend\fR. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing @@ -306,7 +310,7 @@ considered to be a word character. On Windows platforms, words are comprised of any character that is not a space, tab, or newline. Under Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" -info(n), re_syntax(n), tclvars(n) +env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: diff --git a/doc/return.n b/doc/return.n index b59a93d..a1abccf 100644 --- a/doc/return.n +++ b/doc/return.n @@ -317,8 +317,8 @@ proc myReturn {args} { } .CE .SH "SEE ALSO" -break(n), catch(n), continue(n), dict(n), error(n), proc(n), -source(n), tclvars(n), throw(n), try(n) +break(n), catch(n), continue(n), dict(n), error(n), errorCode(n), +errorInfo(n), proc(n), source(n), throw(n), try(n) .SH KEYWORDS break, catch, continue, error, exception, procedure, result, return .\" Local Variables: diff --git a/doc/tclsh.1 b/doc/tclsh.1 index 8e7fb9e..dfc2635 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -102,7 +102,9 @@ but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. .SH "VARIABLES" .PP -\fBTclsh\fR sets the following Tcl variables: +\fBTclsh\fR sets the following global Tcl variables in addition to those +created by the Tcl library itself (such as \fBenv\fR, which maps +environment variables such as \fBPATH\fR into Tcl): .TP 15 \fBargc\fR . @@ -129,7 +131,7 @@ device), 0 otherwise. When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . -You can change the prompt by setting the +You can change the prompt by setting the global variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR @@ -142,6 +144,6 @@ incomplete commands. .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" -encoding(n), fconfigure(n), tclvars(n) +auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell diff --git a/doc/throw.n b/doc/throw.n index d49fb24..b28f2e4 100644 --- a/doc/throw.n +++ b/doc/throw.n @@ -40,7 +40,7 @@ The following produces an error that is identical to that produced by \fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero} .CE .SH "SEE ALSO" -catch(n), error(n), return(n), tclvars(n), try(n) +catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n) .SH "KEYWORDS" error, exception '\" Local Variables: diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index fc0c823..42489dd 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -824,7 +824,7 @@ duptraverse( * make all normal tests (not reg-33.14) pass. */ #ifndef DUPTRAVERSE_MAX_DEPTH -#define DUPTRAVERSE_MAX_DEPTH 700 +#define DUPTRAVERSE_MAX_DEPTH 15000 #endif if (depth++ > DUPTRAVERSE_MAX_DEPTH) { diff --git a/generic/regexec.c b/generic/regexec.c index 9b6a693..ad4b6e6 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -504,12 +504,7 @@ complicatedFindLoop( return er; } if ((shorter) ? end == estop : end == begin) { - /* - * No point in trying again. - */ - - *coldp = cold; - return REG_NOMATCH; + break; } /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 62641e6..100e9ef 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,6 +930,10 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ + int numCommands = envPtr->numCommands; + int offset = envPtr->codeNext - envPtr->codeStart; + int depth = envPtr->currStackDepth; + /* * Make sure that the command has a single arg that is a simple word. */ @@ -943,10 +947,23 @@ TclCompileAssembleCmd( } /* - * Compile the code and return any error from the compilation. + * Compile the code and convert any error from the compilation into + * bytecode reporting the error; */ - return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0); + if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, + tokenPtr[1].size, TCL_EVAL_DIRECT)) { + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s\" body, line %d)", + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + Tcl_GetErrorLine(interp))); + envPtr->numCommands = numCommands; + envPtr->codeNext = envPtr->codeStart + offset; + envPtr->currStackDepth = depth; + TclCompileSyntaxError(interp, envPtr); + } + return TCL_OK; } /* @@ -985,8 +1002,6 @@ TclAssembleCode( const char* instPtr = codePtr; /* Where to start looking for a line of code */ - int instLen; /* Length in bytes of the current line of - * code */ const char* nextPtr; /* Pointer to the end of the line of code */ int bytesLeft = codeLen; /* Number of bytes of source code remaining to * be parsed */ @@ -1000,10 +1015,6 @@ TclAssembleCode( */ status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr); - instLen = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + instLen - 1) { - --instLen; - } /* * Report errors in the parse. @@ -1012,7 +1023,7 @@ TclAssembleCode( if (status != TCL_OK) { if (flags & TCL_EVAL_DIRECT) { Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart, - instLen); + parsePtr->term + 1 - parsePtr->commandStart); } FreeAssemblyEnv(assemEnvPtr); return TCL_ERROR; @@ -1032,6 +1043,13 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { + int instLen = parsePtr->commandSize; + /* Length in bytes of the current command */ + + if (parsePtr->term == parsePtr->commandStart + instLen - 1) { + --instLen; + } + /* * If tracing, show each line assembled as it happens. */ @@ -1107,7 +1125,7 @@ NewAssemblyEnv( assemEnvPtr->envPtr = envPtr; assemEnvPtr->parsePtr = parsePtr; - assemEnvPtr->cmdLine = envPtr->line; + assemEnvPtr->cmdLine = 1; assemEnvPtr->clNext = envPtr->clNext; /* @@ -3029,7 +3047,7 @@ ResolveJumpTableTargets( auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; + realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); realJumpHashPtr = &realJumpTablePtr->hashTable; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b2a505a..a10a11a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -127,15 +127,12 @@ static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; -static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, - Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -static Tcl_NRPostProc NRRunObjProc; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -149,8 +146,8 @@ static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -160,8 +157,11 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; +static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -1609,8 +1609,6 @@ DeleteInterpProc( ckfree(eclPtr->loc); } - Tcl_DeleteHashTable(&eclPtr->litInfo); - ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -2176,12 +2174,8 @@ Tcl_CreateCommand( * future calls to Tcl_GetCommandName. * * Side effects: - * If no command named "cmdName" already exists for interp, one is - * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand - * was called previously for the same command and just set its - * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old - * command. + * If a command named "cmdName" already exists for interp, it is + * first deleted. Then the new command is created from the arguments. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2249,21 +2243,7 @@ Tcl_CreateObjCommand( cmdPtr = Tcl_GetHashValue(hPtr); /* - * Command already exists. If its object-based Tcl_ObjCmdProc is - * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the - * argument "proc". Otherwise, we delete the old command. - */ - - if (cmdPtr->objProc == TclInvokeStringCommand) { - cmdPtr->objProc = proc; - cmdPtr->objClientData = clientData; - cmdPtr->deleteProc = deleteProc; - cmdPtr->deleteData = clientData; - return (Tcl_Command) cmdPtr; - } - - /* - * Otherwise, we delete the old command. Be careful to preserve any + * Command already exists; delete it. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. @@ -2411,8 +2391,8 @@ TclInvokeStringCommand( * A standard Tcl string result value. * * Side effects: - * Besides those side effects of the called Tcl_CmdProc, - * TclInvokeStringCommand allocates and frees storage. + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ @@ -3355,66 +3335,6 @@ CancelEvalProc( /* *---------------------------------------------------------------------- * - * GetCommandSource -- - * - * This function returns a Tcl_Obj with the full source string for the - * command. This insures that traces get a correct NUL-terminated command - * string. The Tcl_Obj has refCount==1. - * - * *** MAINTAINER WARNING *** - * The returned Tcl_Obj is all wrong for any purpose but getting the - * source string for an objc/objv command line in the stringRep (no - * stringRep if no source is available) and the corresponding substituted - * version in the List intrep. - * This means that the intRep and stringRep DO NOT COINCIDE! Using these - * Tcl_Objs normally is likely to break things. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetCommandSource( - Interp *iPtr, - int objc, - Tcl_Obj *const objv[], - int lookup) -{ - Tcl_Obj *objPtr, *obj2Ptr; - CmdFrame *cfPtr = iPtr->cmdFramePtr; - const char *command = NULL; - int numChars; - - objPtr = Tcl_NewListObj(objc, objv); - if (lookup && cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) { - switch (cfPtr->type) { - case TCL_LOCATION_EVAL: - case TCL_LOCATION_SOURCE: - command = cfPtr->cmd.str.cmd; - numChars = cfPtr->cmd.str.len; - break; - case TCL_LOCATION_BC: - case TCL_LOCATION_PREBC: - command = TclGetSrcInfoForCmd(iPtr, &numChars); - break; - case TCL_LOCATION_EVAL_LIST: - /* Got it already */ - break; - } - if (command) { - obj2Ptr = Tcl_NewStringObj(command, numChars); - objPtr->bytes = obj2Ptr->bytes; - objPtr->length = numChars; - obj2Ptr->bytes = NULL; - Tcl_DecrRefCount(obj2Ptr); - } - } - Tcl_IncrRefCount(objPtr); - return objPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclCleanupCommand -- * * This function frees up a Command structure unless it is still @@ -4175,43 +4095,39 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. */ if (iPtr->deferredCallbacks) { - callbackPtr = iPtr->deferredCallbacks; iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; - result = TclInterpReady(interp); - - if ((result != TCL_OK) || (objc == 0)) { - return result; - } - - if (cmdPtr) { - goto commandFound; - } + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = NULL, *preCmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; + int enterTracesDone = 0; + /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4221,61 +4137,150 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + /* * Configure evaluation context to match the requested flags. */ - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (iPtr->lookupNsPtr) { + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. + * TODO: Is that a bug? + */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ iPtr->ensembleRewrite.sourceObjs = NULL; + + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } } /* - * Lookup the command + * Lookup the Command to dispatch. */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + reresolve: + assert(cmdPtr == NULL); + if (preCmdPtr) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } } - - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; + if (cmdPtr == NULL) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } } - /* - * Found a command! The real work begins now ... - */ + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - commandFound: - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + Tcl_IncrRefCount(commandPtr); - result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } - if (result != TCL_OK) { - return result; + if (!enterTracesDone) { + + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); + + /* + * Send any exception from enter traces back as an exception + * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) + */ + + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; + } + + /* + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. + */ + + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; + } } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4296,34 +4301,18 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + iPtr->cmdCount++; + return objProc(clientData, interp, objc, objv); } int @@ -4369,13 +4358,8 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; /* * If there is a tailcall, schedule it @@ -4402,22 +4386,6 @@ NRCommand( return result; } - -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} - /* *---------------------------------------------------------------------- @@ -4681,27 +4649,21 @@ static int TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, + Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length; - Tcl_Obj *commandPtr; - - commandPtr = GetCommandSource(iPtr, objc, objv, 1); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4716,29 +4678,22 @@ TEOV_RunEnterTraces( newEpoch = cmdPtr->cmdEpoch; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + return traceCode; } - - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode), - commandPtr, cmdPtr, NULL); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int @@ -4748,20 +4703,16 @@ TEOV_RunLeaveTraces( int result) { Interp *iPtr = (Interp *) interp; - const char *command; - int length, objc; - Tcl_Obj **objv; - int traceCode = PTR2INT(data[0]); + int traceCode = TCL_OK; + int objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; - - command = Tcl_GetStringFromObj(commandPtr, &length); - if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) { - Tcl_Panic("Who messed with commandPtr?"); - } + Tcl_Obj **objv = data[3]; + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -4770,7 +4721,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4781,8 +4731,18 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { - return traceCode; + if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } @@ -4798,7 +4758,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -5017,31 +4976,22 @@ TclEvalEx( /* * TIP #280 Initialize tracking. Do not push on the frame stack yet. * - * We may continue 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. + * We 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. */ eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1; - eeFramePtr->numLevels = iPtr->numLevels; eeFramePtr->framePtr = iPtr->framePtr; eeFramePtr->nextPtr = iPtr->cmdFramePtr; eeFramePtr->nline = 0; eeFramePtr->line = NULL; + eeFramePtr->cmdObj = NULL; iPtr->cmdFramePtr = eeFramePtr; - if (iPtr->evalFlags & TCL_EVAL_CTX) { - /* - * Path information comes out of the context. - */ - - eeFramePtr->type = TCL_LOCATION_SOURCE; - eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path; - Tcl_IncrRefCount(eeFramePtr->data.eval.path); - } else if (iPtr->evalFlags & TCL_EVAL_FILE) { + if (iPtr->evalFlags & TCL_EVAL_FILE) { /* * Set up for a sourced file. */ @@ -5084,7 +5034,9 @@ TclEvalEx( do { if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { code = TCL_ERROR; - goto error; + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); + goto posterror; } /* @@ -5250,23 +5202,28 @@ TclEvalEx( * have been executed. */ - eeFramePtr->cmd.str.cmd = parsePtr->commandStart; - eeFramePtr->cmd.str.len = parsePtr->commandSize; + eeFramePtr->cmd = parsePtr->commandStart; + eeFramePtr->len = parsePtr->commandSize; if (parsePtr->term == parsePtr->commandStart + parsePtr->commandSize - 1) { - eeFramePtr->cmd.str.len--; + eeFramePtr->len--; } eeFramePtr->nline = objectsUsed; eeFramePtr->line = lines; TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr); - code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR); + code = Tcl_EvalObjv(interp, objectsUsed, objv, + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME); TclArgumentRelease(interp, objv, objectsUsed); eeFramePtr->line = NULL; eeFramePtr->nline = 0; + if (eeFramePtr->cmdObj) { + Tcl_DecrRefCount(eeFramePtr->cmdObj); + eeFramePtr->cmdObj = NULL; + } if (code != TCL_OK) { goto error; @@ -5340,6 +5297,7 @@ TclEvalEx( Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, commandLength); } + posterror: iPtr->flags &= ~ERR_ALREADY_LOGGED; /* @@ -5614,76 +5572,88 @@ TclArgumentBCEnter( int objc, void *codePtr, CmdFrame *cfPtr, + int cmd, int pc) { + ExtCmdLoc *eclPtr; + int word; + ECL *ePtr; + CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - ExtCmdLoc *eclPtr; if (!hePtr) { return; } eclPtr = Tcl_GetHashValue(hePtr); - hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc)); - if (hePtr) { - int word; - int cmd = PTR2INT(Tcl_GetHashValue(hePtr)); - ECL *ePtr = &eclPtr->loc[cmd]; - CFWordBC *lastPtr = NULL; + ePtr = &eclPtr->loc[cmd]; - /* - * A few truths ... - * (1) ePtr->nline == objc - * (2) (ePtr->line[word] < 0) => !literal, for all words - * (3) (word == 0) => !literal - * - * Item (2) is why we can use objv to get the literals, and do not - * have to save them at compile time. - */ + /* + * ePtr->nline is the number of words originally parsed. + * + * objc is the number of elements getting invoked. + * + * If they are not the same, we arrived here by compiling an + * ensemble dispatch. Ensemble subcommands that lead to script + * evaluation are not supposed to get compiled, because a command + * such as [info level] in the script can expose some of the dispatch + * shenanigans. This means that we don't have to tend to the + * housekeeping, and can escape now. + */ + + if (ePtr->nline != objc) { + return; + } - if (ePtr->nline != objc) { - Tcl_Panic ("TIP 280 data structure inconsistency"); - } + /* + * Having disposed of the ensemble cases, we can state... + * A few truths ... + * (1) ePtr->nline == objc + * (2) (ePtr->line[word] < 0) => !literal, for all words + * (3) (word == 0) => !literal + * + * Item (2) is why we can use objv to get the literals, and do not + * have to save them at compile time. + */ - for (word = 1; word < objc; word++) { - if (ePtr->line[word] >= 0) { - int isnew; - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - - cfwPtr->framePtr = cfPtr; - cfwPtr->obj = objv[word]; - cfwPtr->pc = pc; - cfwPtr->word = word; - cfwPtr->nextPtr = lastPtr; - lastPtr = cfwPtr; - - if (isnew) { - /* - * The word is not on the stack yet, remember the current - * location and initialize references. - */ - - cfwPtr->prevPtr = NULL; - } else { - /* - * The object is already on the stack, however it may have - * a different location now (literal sharing may map - * multiple location to a single Tcl_Obj*. Save the old - * information in the new structure. - */ - - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); - } + for (word = 1; word < objc; word++) { + if (ePtr->line[word] >= 0) { + int isnew; + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, + objv[word], &isnew); + CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); - Tcl_SetHashValue(hPtr, cfwPtr); + cfwPtr->framePtr = cfPtr; + cfwPtr->obj = objv[word]; + cfwPtr->pc = pc; + cfwPtr->word = word; + cfwPtr->nextPtr = lastPtr; + lastPtr = cfwPtr; + + if (isnew) { + /* + * The word is not on the stack yet, remember the current + * location and initialize references. + */ + + cfwPtr->prevPtr = NULL; + } else { + /* + * The object is already on the stack, however it may have + * a different location now (literal sharing may map + * multiple location to a single Tcl_Obj*. Save the old + * information in the new structure. + */ + + cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); } - } /* for */ - cfPtr->litarg = lastPtr; - } /* if */ + Tcl_SetHashValue(hPtr, cfwPtr); + } + } /* for */ + + cfPtr->litarg = lastPtr; } /* @@ -5893,6 +5863,11 @@ Tcl_GlobalEvalObj( * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is * specified. * + * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker + * must be NULL. Support for non-NULL invokers in that mode has + * been removed since it was unused and untested. Failure to + * follow this limitation will lead to an assertion panic. + * * Results: * The return value is one of the return codes defined in tcl.h (such as * TCL_OK), and the interpreter's result contains a value to supplement @@ -5961,13 +5936,12 @@ TclNREvalObjEx( */ if (TclListObjIsCanonical(objPtr)) { - Tcl_Obj *listPtr = objPtr; CmdFrame *eoFramePtr = NULL; int objc; - Tcl_Obj **objv; + Tcl_Obj *listPtr, **objv; /* - * Pure List Optimization (no string representation). In this case, we + * Canonical List Optimization: In this case, we * can safely use Tcl_EvalObjv instead and get an appreciable * improvement in execution speed. This is because it allows us to * avoid a setFromAny step that would just pack everything into a @@ -5975,11 +5949,6 @@ TclNREvalObjEx( * * This also preserves any associations between list elements and * location information for such elements. - * - * This restriction has been relaxed a bit by storing in lists whether - * they are "canonical" or not (a canonical list being one that is - * either pure or that has its string rep derived by - * UpdateStringOfList from the internal rep). */ /* @@ -5988,13 +5957,13 @@ TclNREvalObjEx( * we always make a copy. The callback takes care od the refCounts for * both listPtr and objPtr. * + * TODO: Create a test to demo this need, or eliminate it. * FIXME OPT: preserve just the internal rep? */ Tcl_IncrRefCount(objPtr); listPtr = TclListObjCopy(interp, objPtr); Tcl_IncrRefCount(listPtr); - TclDecrRefCount(objPtr); if (word != INT_MIN) { /* @@ -6017,22 +5986,25 @@ TclNREvalObjEx( eoFramePtr->nline = 0; eoFramePtr->line = NULL; - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->numLevels = iPtr->numLevels; eoFramePtr->framePtr = iPtr->framePtr; eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->cmd.listPtr = listPtr; + eoFramePtr->cmdObj = objPtr; + eoFramePtr->cmd = NULL; + eoFramePtr->len = 0; eoFramePtr->data.eval.path = NULL; iPtr->cmdFramePtr = eoFramePtr; + + flags |= TCL_EVAL_SOURCE_IN_FRAME; } TclMarkTailcall(interp); TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, - NULL, NULL); + objPtr, NULL); ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); @@ -6072,14 +6044,6 @@ TclNREvalObjEx( * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). - * - * 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. */ const char *script; @@ -6103,92 +6067,19 @@ TclNREvalObjEx( */ ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr; - ContLineLoc *clLocPtr = TclContinuationsGet(objPtr); - - if (clLocPtr) { - iPtr->scriptCLLocPtr = clLocPtr; - Tcl_Preserve(iPtr->scriptCLLocPtr); - } else { - iPtr->scriptCLLocPtr = NULL; - } - - Tcl_IncrRefCount(objPtr); - 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. - */ - - int pc = 0; - CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); - - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. - */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; - } - - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); - - if ((invoker->nline <= word) || - (invoker->line[word] < 0) || - (ctxPtr->type != TCL_LOCATION_SOURCE)) { - /* - * Dynamic script, or dynamic context, force our own context. - */ - result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - } else { - /* - * Absolute context to reuse. - */ + assert(invoker == NULL); - iPtr->invokeCmdFramePtr = ctxPtr; - iPtr->evalFlags |= TCL_EVAL_CTX; + iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr); - result = TclEvalEx(interp, script, numSrcBytes, flags, - ctxPtr->line[word], NULL, script); - } - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { - /* - * Death of SrcInfo reference. - */ + Tcl_IncrRefCount(objPtr); - Tcl_DecrRefCount(ctxPtr->data.eval.path); - } - TclStackFree(interp, ctxPtr); - } + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + result = Tcl_EvalEx(interp, script, numSrcBytes, flags); - /* - * Now release the lock on the continuation line information, if any, - * and restore the caller's settings. - */ + TclDecrRefCount(objPtr); - if (iPtr->scriptCLLocPtr) { - Tcl_Release(iPtr->scriptCLLocPtr); - } iPtr->scriptCLLocPtr = saveCLLocPtr; - TclDecrRefCount(objPtr); return result; } } @@ -6248,6 +6139,7 @@ TEOEx_ListCallback( Interp *iPtr = (Interp *) interp; Tcl_Obj *listPtr = data[0]; CmdFrame *eoFramePtr = data[1]; + Tcl_Obj *objPtr = data[2]; /* * Remove the cmdFrame @@ -6257,6 +6149,7 @@ TEOEx_ListCallback( iPtr->cmdFramePtr = eoFramePtr->nextPtr; TclStackFree(interp, eoFramePtr); } + TclDecrRefCount(objPtr); TclDecrRefCount(listPtr); return result; @@ -6619,30 +6512,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6658,36 +6553,27 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* - * If an error occurred, record information about what was being executed - * when the error occurred. + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). */ - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; } @@ -8138,39 +8024,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* @@ -8263,7 +8121,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 901237b..7625d39 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2386,29 +2386,32 @@ BinaryDecodeHex( while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { - if (data < dataend) { - c = *data++; - - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { - goto badChar; - } - i--; - continue; - } + if (data >= dataend) { value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + break; + } + + c = *data++; + if (!isxdigit((int) c)) { + if (strict || !isspace(c)) { + goto badChar; } - value |= (c & 0xf); - } else { - value <<= 4; - cut++; + i--; + continue; } + + value <<= 4; + c -= '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + } + if (i < 2) { + cut++; } *cursor++ = UCHAR(value); value = 0; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 0e33392..fa4ead4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1302,28 +1302,12 @@ TclInfoFrame( */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); - ADD_PAIR("cmd", 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. - */ - - ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(1)); - - /* - * 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. - */ - - ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr)); + if (framePtr->line) { + ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + } else { + ADD_PAIR("line", Tcl_NewIntObj(1)); + } + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PREBC: @@ -1371,8 +1355,7 @@ TclInfoFrame( Tcl_DecrRefCount(fPtr->data.eval.path); } - ADD_PAIR("cmd", - Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL)); TclStackFree(interp, fPtr); break; } @@ -1391,8 +1374,7 @@ TclInfoFrame( * the result list object. */ - ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd, - framePtr->cmd.str.len)); + ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; case TCL_LOCATION_PROC: diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 37ce335..8edb2d9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -87,6 +87,7 @@ TclCompileAppendCmd( int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -544,7 +545,6 @@ TclCompileCatchCmd( JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range; - int initStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -742,15 +742,6 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); } - /* - * Result of all this, on either branch, should have been to leave one - * operand -- the return code -- on the stack. - */ - - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); - } return TCL_OK; } @@ -983,6 +974,7 @@ TclCompileDictGetCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1020,6 +1012,7 @@ TclCompileDictExistsCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1057,6 +1050,7 @@ TclCompileDictUnsetCmd( * compile to bytecode. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1202,6 +1196,7 @@ TclCompileDictMergeCmd( * argument, the only thing to do is to verify the dict-ness. */ + /* TODO: Consider support for compiling expanded args. (less likely) */ if (parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; @@ -1722,6 +1717,7 @@ TclCompileDictAppendCmd( * speed quite so much. ;-) */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -1774,6 +1770,8 @@ TclCompileDictLappendCmd( * There must be three arguments after the command. */ + /* TODO: Consider support for compiling expanded args. */ + /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -1820,6 +1818,7 @@ TclCompileDictWithCmd( * There must be at least one argument after the command. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -2536,7 +2535,7 @@ CompileEachloopCmd( Tcl_DStringInit(&varList); TclDStringAppendToken(&varList, &tokenPtr[1]); - code = Tcl_SplitList(interp, Tcl_DStringValue(&varList), + code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList), &varcList[loopIndex], &varvList[loopIndex]); Tcl_DStringFree(&varList); if (code != TCL_OK) { @@ -2978,7 +2977,8 @@ TclCompileFormatCmd( ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { - return TCL_ERROR; + TclCompileSyntaxError(interp, envPtr); + return TCL_OK; } /* diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 2c71dc5..150c378 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -60,6 +60,7 @@ TclCompileGlobalCmd( int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -820,6 +821,7 @@ TclCompileLappendCmd( return TCL_ERROR; } + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -1061,6 +1063,7 @@ TclCompileLindexCmd( * Quit if too few args. */ + /* TODO: Consider support for compiling expanded args. */ if (numWords <= 1) { return TCL_ERROR; } @@ -1583,6 +1586,7 @@ TclCompileLsetCmd( * Check argument count. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. @@ -2531,6 +2535,7 @@ TclCompileSyntaxError( TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); + Tcl_ResetResult(interp); } /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 3a91c83..d1eb9db 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -743,6 +743,9 @@ TclSubstCompile( Tcl_InterpState state = NULL; TclSubstParse(interp, bytes, numBytes, flags, &parse, &state); + if (state != NULL) { + Tcl_ResetResult(interp); + } /* * Tricky point! If the first token does not result in a *guaranteed* push @@ -988,9 +991,6 @@ TclSubstCompile( * Instructions are added to envPtr to execute the "switch" command at * runtime. * - * FIXME: - * Stack depths are probably not calculated correctly. - * *---------------------------------------------------------------------- */ @@ -2818,6 +2818,7 @@ TclCompileUnsetCmd( Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords-1; flags = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3173,6 +3174,7 @@ CompileAssociativeBinaryOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ for (words=1 ; words<parsePtr->numWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); @@ -3256,6 +3258,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { @@ -3593,6 +3596,7 @@ TclCompileMinusOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. @@ -3638,6 +3642,7 @@ TclCompileDivOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 633966e..f5c8d41 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -562,8 +562,6 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); -static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, - Tcl_Token *tokenPtr); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -715,9 +713,7 @@ TclSetByteCodeFromAny( clLocPtr = TclContinuationsGet(objPtr); if (clLocPtr) { - compEnv.clLoc = clLocPtr; - compEnv.clNext = &compEnv.clLoc->loc[0]; - Tcl_Preserve(compEnv.clLoc); + compEnv.clNext = &clLocPtr->loc[0]; } TclCompileScript(interp, stringPtr, length, &compEnv); @@ -744,9 +740,7 @@ TclSetByteCodeFromAny( TclInitCompileEnv(interp, &compEnv, stringPtr, length, iPtr->invokeCmdFramePtr, iPtr->invokeWord); if (clLocPtr) { - compEnv.clLoc = clLocPtr; - compEnv.clNext = &compEnv.clLoc->loc[0]; - Tcl_Preserve(compEnv.clLoc); + compEnv.clNext = &clLocPtr->loc[0]; } compEnv.atCmdStart = 2; /* The disabling magic. */ TclCompileScript(interp, stringPtr, length, &compEnv); @@ -1292,8 +1286,6 @@ ReleaseCmdWordData( ckfree((char *) eclPtr->loc); } - Tcl_DeleteHashTable (&eclPtr->litInfo); - ckfree((char *) eclPtr); } @@ -1378,9 +1370,8 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); - if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) { + if (invoker == NULL) { /* * Initialize the compiler for relative counting in case of a * dynamic context. @@ -1494,7 +1485,6 @@ TclInitCompileEnv( * data is available. */ - envPtr->clLoc = NULL; envPtr->clNext = NULL; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; @@ -1579,16 +1569,6 @@ TclFreeCompileEnv( ReleaseCmdWordData(envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; } - - /* - * If we used data about invisible continuation lines, then now is the - * time to release on our hold on it. The lock was set in function - * TclSetByteCodeFromAny(), found in this file. - */ - - if (envPtr->clLoc) { - Tcl_Release(envPtr->clLoc); - } } /* @@ -1672,54 +1652,6 @@ TclWordKnownAtCompileTime( } /* - * --------------------------------------------------------------------- - * - * FindCompiledCommandFromToken -- - * - * A simple helper that looks up a command's compiler from its token. - * - * --------------------------------------------------------------------- - */ - -static Command * -FindCompiledCommandFromToken( - Tcl_Interp *interp, - Tcl_Token *tokenPtr) -{ - Tcl_DString ds; - Command *cmdPtr; - - /* - * If we have a non-trivial token or are suppressing compilation, we stop - * right now. - */ - - if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE)) { - return NULL; - } - - /* - * We copy the string before trying to find the command by name. We used - * to modify the string in place, but this is not safe because the name - * resolution handlers could have side effects that rely on the unmodified - * string. - */ - - Tcl_DStringInit(&ds); - TclDStringAppendToken(&ds, &tokenPtr[1]); - cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), NULL, - /*flags*/ 0); - if (cmdPtr != NULL && (cmdPtr->compileProc == NULL - || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { - cmdPtr = NULL; - } - Tcl_DStringFree(&ds); - return cmdPtr; -} - -/* *---------------------------------------------------------------------- * * TclCompileScript -- @@ -1737,460 +1669,460 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -void -TclCompileScript( - Tcl_Interp *interp, /* Used for error and status reporting. Also - * serves as context for finding and compiling - * commands. May not be NULL. */ - const char *script, /* The source script to compile. */ - int numBytes, /* Number of bytes in script. If < 0, the - * script consists of all bytes up to the - * first null character. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +static int +ExpandRequested( + Tcl_Token *tokenPtr, + int numWords) { - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized to - * avoid compiler warning. */ - int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p, *next; - Command *cmdPtr; - Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; - /* TIP #280 */ - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse parse, *parsePtr = &parse; + /* Determine whether any words of the command require expansion */ + while (numWords--) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + return 1; + } + tokenPtr = TokenAfter(tokenPtr); + } + return 0; +} - if (envPtr->iPtr == NULL) { - Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); +static void +CompileCmdLiteral( + Tcl_Interp *interp, + Tcl_Obj *cmdObj, + CompileEnv *envPtr) +{ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); } + TclEmitPush(cmdLitIdx, envPtr); +} - if (numBytes < 0) { - numBytes = strlen(script); +void +TclCompileInvocation( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + CompileEnv *envPtr) +{ + int wordIdx = 0; + DefineLineInformation; + + if (cmdObj) { + CompileCmdLiteral(interp, cmdObj, envPtr); + wordIdx = 1; + tokenPtr = TokenAfter(tokenPtr); } - Tcl_ResetResult(interp); - isFirstCmd = 1; - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { + int objIdx; - p = script; - bytesLeft = numBytes; - cmdLine = envPtr->line; - clNext = envPtr->clNext; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - /* - * Compile bytecodes to report the parse error at runtime. - */ + SetLineInformation(wordIdx); - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize); - TclCompileSyntaxError(interp, envPtr); - break; + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + continue; } - /* - * TIP #280: We have to count newlines before the command even in the - * degenerate case when the command has no words. (See test - * info-30.33). - * So make that counting here, and not in the (numWords > 0) branch - * below. - */ + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, envPtr->clNext); + } + TclEmitPush(objIdx, envPtr); + } - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } +} - if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions to - * handle */ +static void +CompileExpanded( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + CompileEnv *envPtr) +{ + int wordIdx = 0; + DefineLineInformation; - /* - * If not the first command, pop the previous command's result - * and, if we're compiling a top level command, update the last - * command's code size to account for the pop instruction. - */ - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; - } + StartExpanding(envPtr); + if (cmdObj) { + CompileCmdLiteral(interp, cmdObj, envPtr); + wordIdx = 1; + tokenPtr = TokenAfter(tokenPtr); + } - /* - * Determine the actual length of the command. - */ + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { + int objIdx; - commandLength = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + commandLength-1) { - /* - * The command terminator character (such as ; or ]) is the - * last character in the parsed command. Reduce the length by - * one so that the trace message doesn't include the - * terminator character. - */ + SetLineInformation(wordIdx); - commandLength -= 1; + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); } + continue; + } -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, envPtr->clNext); + } + TclEmitPush(objIdx, envPtr); + } - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif + /* + * The stack depth during argument expansion can only be + * managed at runtime, as the number of elements in the + * expanded lists is not known at compile time. We adjust here + * the stack depth estimate so that it is correct after the + * command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the + * words of the command are popped from the stack, and the + * result is pushed: the stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command + * is being prepared and run, INST_EXPAND_STKTOP is not + * stack-neutral in general. + */ - /* - * Check whether expansion has been requested for any of the - * words. - */ + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - wordIdx, envPtr); +} - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } +static int +CompileCmdCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, + CompileEnv *envPtr) +{ + int unwind = 0, incrOffset = -1; + DefineLineInformation; + /* + * Emit of the INST_START_CMD instruction is controlled by + * the value of envPtr->atCmdStart: + * + * atCmdStart == 2 : We are not using the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. + * : We do not need to emit another. Instead we + * : increment the number of cmds started at it (except + * : for the special case at the start of a script.) + * atCmdStart == 0 : The last instruction was something else. We need + * : to emit INST_START_CMD here. + */ + + switch (envPtr->atCmdStart) { + case 0: + unwind = tclInstructionTable[INST_START_CMD].numBytes; + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + incrOffset = envPtr->codeNext - envPtr->codeStart; + TclEmitInt4(0, envPtr); + break; + case 1: + if (envPtr->codeNext > envPtr->codeStart) { + incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; + } + break; + case 2: + /* Nothing to do */ + ; + } + + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { + if (incrOffset >= 0) { /* - * If expansion was requested, check if the command declares that - * it knows how to compile it. Note that if expansion is requested - * for the first word, this check will fail as the token type will - * inhibit it. (Checked inside FindCompiledCommandFromToken.) This - * is as it should be. + * We successfully compiled a command. Increment the number + * of commands that start at the currently active INST_START_CMD. */ + unsigned char *incrPtr = envPtr->codeStart + incrOffset; + unsigned char *startPtr = incrPtr - 5; - if (expand) { - cmdPtr = FindCompiledCommandFromToken(interp, - parsePtr->tokenPtr); - if (cmdPtr && (cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = 0; - } + TclIncrUInt4AtPtr(incrPtr, 1); + if (unwind) { + /* We started the INST_START_CMD. Record the code length. */ + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } + } + return TCL_OK; + } - envPtr->numCommands++; - currCmdIndex = envPtr->numCommands - 1; - lastTopLevelCmdIndex = currCmdIndex; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, - parsePtr->commandStart - envPtr->source, startCodeOffset); + envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ - /* - * Should only start issuing instructions after the "command has - * started" so that the command range is correct in the bytecode. - */ + /* + * Throw out any line information generated by the failed + * compile attempt. + */ + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } - if (expand) { - StartExpanding(envPtr); - } + /* + * Reset the index of next command. + * Toss out any from failed nested partial compiles. + */ + envPtr->numCommands = mapPtr->nuloc; - /* - * 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'. - */ + return TCL_ERROR; +} - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; +static int +CompileCommandTokens( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + Tcl_Obj *cmdObj = Tcl_NewObj(); + Command *cmdPtr = NULL; + int code = TCL_ERROR; + int cmdKnown, expand = -1; + int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; - /* - * Each iteration of the following loop compiles one word from the - * command. - */ + assert (parsePtr->numWords > 0); - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; wordIdx++, - tokenPtr += tokenPtr->numComponents + 1) { - /* - * Note the parse location information. - */ + /* Pre-Compile */ - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; + envPtr->numCommands++; + EnterCmdStartData(envPtr, cmdIdx, + parsePtr->commandStart - envPtr->source, startCodeOffset); - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ + /* + * 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'. + */ - CompileTokens(envPtr, tokenPtr, interp); - if (expand && tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; - if ((wordIdx == 0) && !expand) { - cmdPtr = FindCompiledCommandFromToken(interp, tokenPtr); - if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (cmdPtr->compileProc(interp, parsePtr, cmdPtr, - envPtr) == TCL_OK) { - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ + /* Do we know the command word? */ + Tcl_IncrRefCount(cmdObj); + tokenPtr = parsePtr->tokenPtr; + cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); -#ifdef TCL_COMPILE_DEBUG - int diff = envPtr->currStackDepth-startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && savedCodeNext != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before the - * failure to produce bytecode got reported. [Bugs - * 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - - /* - * And the stack depth too!! [Bug 3614102]. - */ - - envPtr->currStackDepth = startStackDepth; - } + /* Is this a command we should (try to) compile with a compileProc ? */ + if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { + /* + * Found a command. Test the ways we can be told + * not to attempt to compile it. + */ + if ((cmdPtr->compileProc == NULL) + || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + cmdPtr = NULL; + } + } + if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + if (expand) { + /* We need to expand, but compileProc cannot. */ + cmdPtr = NULL; + } + } + } - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Mark this as a command name literal to reduce - * shimmering. - */ + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + if (cmdPtr) { + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); + } - objIndex = TclRegisterNewCmdLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, objIndex), cmdPtr); - } - } else { - /* - * Simple argument word of a command. We reach this if and - * only if the command word was not compiled for whatever - * reason. Register the literal's location for use by - * uplevel, etc. commands, should they encounter it - * unmodified. We care only if the we are in a context - * which already allows absolute counting. - */ + if (code == TCL_ERROR) { + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + } - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + if (expand) { + CompileExpanded(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + } else { + TclCompileInvocation(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + } + } - if (envPtr->clNext) { - TclContinuationsEnterDerived( - TclFetchLiteral(envPtr, objIndex), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); - } - } - TclEmitPush(objIndex, envPtr); - } /* for loop */ + Tcl_DecrRefCount(cmdObj); - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - assert(wordIdx > 0); + TclEmitOpcode(INST_POP, envPtr); + EnterCmdExtentData(envPtr, cmdIdx, + parsePtr->term - parsePtr->commandStart, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ + /* + * TIP #280: Free full form of per-word line data and insert the + * reduced form now + */ - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ + envPtr->line = cmdLine; + envPtr->clNext = clNext; + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), - &isnew); + return cmdIdx; +} - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } - } +void +TclCompileScript( + Tcl_Interp *interp, /* Used for error and status reporting. Also + * serves as context for finding and compiling + * commands. May not be NULL. */ + const char *script, /* The source script to compile. */ + int numBytes, /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + * command this routine compiles into bytecode. + * Initial value of -1 indicates this routine + * has not yet generated any bytecode. */ + const char *p = script; /* Where we are in our compile. */ - /* - * Update the compilation environment structure and record the - * offsets of the source and code for the command. - */ + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } - finishCommand: - EnterCmdExtentData(envPtr, currCmdIndex, commandLength, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - isFirstCmd = 0; + /* Each iteration compiles one command from the script. */ + while (numBytes > 0) { + Tcl_Parse parse; + const char *next; + + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now + * Compile bytecodes to report the parse error at runtime. */ - ckfree(eclPtr->loc[wlineat].line); - ckfree(eclPtr->loc[wlineat].next); - eclPtr->loc[wlineat].line = wlines; - eclPtr->loc[wlineat].next = NULL; - } /* end if parsePtr->numWords > 0 */ + Tcl_LogCommandInfo(interp, script, parse.commandStart, + parse.term + 1 - parse.commandStart); + TclCompileSyntaxError(interp, envPtr); + return; + } +#ifdef TCL_COMPILE_DEBUG /* - * Advance to the next command in the script. + * If tracing, print a line for each top level command compiled. + * TODO: Suppress when numWords == 0 ? */ - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; - p = next; + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parse.term - parse.commandStart; + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); + } +#endif /* - * TIP #280: Track lines in the just compiled command. + * TIP #280: Count newlines before the command start. + * (See test info-30.33). */ - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); + TclAdvanceLines(&envPtr->line, p, parse.commandStart); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + parse.commandStart - envPtr->source); - /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ + /* + * Advance parser to the next command in the script. + */ - envPtr->line = cmdLine; - envPtr->clNext = clNext; + next = parse.commandStart + parse.commandSize; + numBytes -= next - p; + p = next; - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ + if (parse.numWords == 0) { + /* + * The "command" parsed has no words. In this case + * we can skip the rest of the loop body. With no words, + * clearly CompileCommandTokens() has nothing to do. Since + * the parser aggressively sucks up leading comment and white + * space, including newlines, parse.commandStart must be + * pointing at either the end of script, or a command-terminating + * semi-colon. In either case, the TclAdvance*() calls have + * nothing to do. Finally, when no words are parsed, no + * tokens have been allocated at parse.tokenPtr so there's + * also nothing for Tcl_FreeParse() to do. + * + * The advantage of this shortcut is that CompileCommandTokens() + * can be written with an assumption that parse.numWords > 0, + * with the implication the CCT() always generates bytecode. + */ + continue; + } - if (envPtr->codeNext == entryCodeNext) { + lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + + /* + * TIP #280: Track lines in the just compiled command. + */ + + TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); + Tcl_FreeParse(&parse); + } + + if (lastCmdIdx == -1) { + /* + * Compiling the script yielded no bytecode. The script must be + * all whitespace, comments, and empty commands. Such scripts + * are defined to successfully produce the empty string result, + * so we emit the simple bytecode that makes that happen. + */ PushStringLiteral(envPtr, ""); + } else { + /* + * We compiled at least one command to bytecode. The routine + * CompileCommandTokens() follows the bytecode of each compiled + * command with an INST_POP, so that stack balance is maintained + * when several commands are in sequence. (The result of each + * command is thrown away before moving on to the next command). + * For the last command compiled, we need to undo that INST_POP + * so that the result of the last command becomes the result of + * the script. The code here removes that trailing INST_POP. + */ + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; + envPtr->codeNext--; + envPtr->currStackDepth++; } } @@ -3962,69 +3894,6 @@ TclFixupForwardJump( } } - /* - * TIP #280: Adjust the mapping from PC values to the per-command - * information about arguments and their line numbers. - * - * Note: We cannot simply remove an out-of-date entry and then reinsert - * with the proper PC, because then we might overwrite another entry which - * was at that location. Therefore we pull (copy + delete) all effected - * entries (beyond the fixed PC) into an array, update them there, and at - * last reinsert them all. - */ - - { - ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - - /* A helper structure */ - - typedef struct { - int pc; - int cmd; - } MAP; - - /* - * And the helper array. At most the whole hashtable is placed into - * this. - */ - - MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); - - Tcl_HashSearch hSearch; - Tcl_HashEntry* hPtr; - int n, k, isnew; - - /* - * Phase I: Locate the affected entries, and save them in adjusted - * form to the array. This removes them from the hash. - */ - - for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); - map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); - - if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { - Tcl_DeleteHashEntry(hPtr); - map [n].pc += 3; - n++; - } - } - - /* - * Phase II: Re-insert the modified entries into the hash. - */ - - for (k=0;k<n;k++) { - hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew); - Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); - } - - ckfree (map); - } - return 1; /* the jump was grown */ } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index cf8475d..5660055 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -193,13 +193,6 @@ typedef struct ExtCmdLoc { ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ - Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the - * information accessible per command and - * argument, not per whole bytecode. Value is - * index of command in 'loc', giving us the - * literals to associate with line information - * as command argument, see - * TclArgumentBCEnter() */ } ExtCmdLoc; /* @@ -372,10 +365,6 @@ typedef struct CompileEnv { * encountered that have not yet been paired * with a corresponding * INST_INVOKE_EXPANDED. */ - ContLineLoc *clLoc; /* If not NULL, the table holding the - * locations of the invisible continuation - * lines in the input script, to adjust the - * line counter. */ int *clNext; /* If not NULL, it refers to the next slot in * clLoc to check for an invisible * continuation line. */ @@ -991,6 +980,9 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, *---------------------------------------------------------------- */ +MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); @@ -1002,6 +994,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); +MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, + CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, int numBytes, CompileEnv *envPtr); @@ -1114,6 +1109,15 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); *---------------------------------------------------------------- */ +/* + * Simplified form to access AuxData. + * + * ClientData TclFetchAuxData(CompileEng *envPtr, int index); + */ + +#define TclFetchAuxData(envPtr, index) \ + (envPtr)->auxDataArrayPtr[(index)].clientData + #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 680ab45d..ad11785 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -35,9 +35,6 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); -static int CompileToCompiledCommand(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, - CompileEnv *envPtr); static void CompileToInvokedCommand(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Obj *replacements, Command *cmdPtr, CompileEnv *envPtr); @@ -2994,8 +2991,8 @@ TclCompileEnsemble( */ invokeAnyway = 1; - if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr, - envPtr) == TCL_OK) { + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr, + envPtr)) { ourResult = TCL_OK; goto cleanup; } @@ -3029,24 +3026,16 @@ TclCompileEnsemble( return ourResult; } -/* - * How to compile a subcommand using its own command compiler. To do that, we - * have to perform some trickery to rewrite the arguments, as compilers *must* - * have parse tokens that refer to addresses in the original script. - */ - -static int -CompileToCompiledCommand( +int +TclAttemptCompileProc( Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Parse synthetic; - Tcl_Token *tokenPtr; int result, i; - int savedNumCmds = envPtr->numCommands; + Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; int savedStackDepth = envPtr->currStackDepth; unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart; DefineLineInformation; @@ -3055,47 +3044,17 @@ CompileToCompiledCommand( return TCL_ERROR; } - TclParseInit(interp, NULL, 0, &synthetic); - synthetic.numWords = parsePtr->numWords - depth + 1; - TclGrowParseTokenArray(&synthetic, 2); - synthetic.numTokens = 2; - - /* - * Now we have the space to work in, install something rewritten. The - * first word will "officially" be the bytes of the structured ensemble - * name. That's technically wrong, but nobody will care; we just need - * *something* here... - */ - - synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD; - synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[0].numComponents = 1; - synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT; - synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start; - synthetic.tokenPtr[1].numComponents = 0; - for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) { - int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start) - + tokenPtr->size; - - synthetic.tokenPtr[0].size = sclen; - synthetic.tokenPtr[1].size = sclen; - tokenPtr = TokenAfter(tokenPtr); - } - /* - * Copy over the real argument tokens. + * Advance parsePtr->tokenPtr so that it points at the last subcommand. + * This will be wrong, but it will not matter, and it will put the + * tokens for the arguments in the right place without the needed to + * allocate a synthetic Tcl_Parse struct, or copy tokens around. */ - for (i=1; i<synthetic.numWords; i++) { - int toCopy; - - toCopy = tokenPtr->numComponents + 1; - TclGrowParseTokenArray(&synthetic, toCopy); - memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr, - sizeof(Tcl_Token) * toCopy); - synthetic.numTokens += toCopy; - tokenPtr = TokenAfter(tokenPtr); + for (i = 0; i < depth - 1; i++) { + parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr); } + parsePtr->numWords -= (depth - 1); /* * Shift the line information arrays to account for different word @@ -3109,7 +3068,7 @@ CompileToCompiledCommand( * Hand off compilation to the subcommand compiler. At last! */ - result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr); + result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr); /* * Undo the shift. @@ -3118,22 +3077,37 @@ CompileToCompiledCommand( mapPtr->loc[eclIndex].line -= (depth - 1); mapPtr->loc[eclIndex].next -= (depth - 1); + parsePtr->numWords += (depth - 1); + parsePtr->tokenPtr = saveTokenPtr; + /* - * If our target fails to compile, revert the number of commands and the - * pointer to the place to issue the next instruction. [Bug 3600328] + * If our target failed to compile, revert any data from failed partial + * compiles. Note that envPtr->numCommands need not be checked because + * we avoid compiling subcommands that recursively call TclCompileScript(). */ if (result != TCL_OK) { - envPtr->numCommands = savedNumCmds; envPtr->currStackDepth = savedStackDepth; envPtr->codeNext = envPtr->codeStart + savedCodeNext; - } +#ifdef TCL_COMPILE_DEBUG + } else { + /* + * Confirm that the command compiler generated a single value on + * the stack as its result. This is only done in debugging mode, + * as it *should* be correct and normal users have no reasonable + * way to fix it anyway. + */ - /* - * Clean up if necessary. - */ + int diff = envPtr->currStackDepth - savedStackDepth; + + if (diff != 1) { + Tcl_Panic("bad stack adjustment when compiling" + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, + parsePtr->tokenPtr->start, diff); + } +#endif + } - Tcl_FreeParse(&synthetic); return result; } @@ -3163,12 +3137,16 @@ CompileToInvokedCommand( */ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words); - for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; + i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { bytes = Tcl_GetStringFromObj(words[i-1], &length); PushLiteral(envPtr, bytes, length); - } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* TODO: Check about registering Cmd Literals here */ + continue; + } + + SetLineInformation(i); + if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { int literal = TclRegisterNewLiteral(envPtr, tokPtr[1].start, tokPtr[1].size); @@ -3176,14 +3154,12 @@ CompileToInvokedCommand( TclContinuationsEnterDerived( TclFetchLiteral(envPtr, literal), tokPtr[1].start - envPtr->source, - mapPtr->loc[eclIndex].next[i]); + envPtr->clNext); } TclEmitPush(literal, envPtr); } else { - SetLineInformation(i); CompileTokens(envPtr, tokPtr, interp); } - tokPtr = TokenAfter(tokPtr); } /* @@ -3229,49 +3205,13 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - DefineLineInformation; + Tcl_Obj *objPtr = Tcl_NewObj(); - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); + Tcl_IncrRefCount(objPtr); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, literal), cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<parsePtr->numWords ; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } + TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, + parsePtr->numWords, envPtr); + Tcl_DecrRefCount(objPtr); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d3a0d32..96004e2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -721,7 +721,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int catchOnly, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, - const unsigned char **pcBeg); + const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, @@ -1426,17 +1426,12 @@ Tcl_NRExprObj( Tcl_Obj *resultPtr) { ByteCode *codePtr; + Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK); - /* TODO: consider saving whole state? */ - Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp); - - Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); codePtr = CompileExprObj(interp, objPtr); - /* TODO: Confirm reset not required? */ - /*Tcl_ResetResult(interp);*/ - Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr, + Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr, NULL, NULL); return TclNRExecuteByteCode(interp, codePtr); } @@ -1447,14 +1442,15 @@ ExprObjCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *saveObjPtr = data[0]; + Tcl_InterpState state = data[0]; Tcl_Obj *resultPtr = data[1]; if (result == TCL_OK) { TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_SetObjResult(interp, saveObjPtr); + (void) Tcl_RestoreInterpState(interp, state); + } else { + Tcl_DiscardInterpState(state); } - TclDecrRefCount(saveObjPtr); return result; } @@ -2002,7 +1998,6 @@ TclNRExecuteByteCode( bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) ? TCL_LOCATION_PREBC : TCL_LOCATION_BC); bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1); - bcFramePtr->numLevels = iPtr->numLevels; bcFramePtr->framePtr = iPtr->framePtr; bcFramePtr->nextPtr = iPtr->cmdFramePtr; bcFramePtr->nline = 0; @@ -2010,8 +2005,9 @@ TclNRExecuteByteCode( bcFramePtr->litarg = NULL; bcFramePtr->data.tebc.codePtr = codePtr; bcFramePtr->data.tebc.pc = NULL; - bcFramePtr->cmd.str.cmd = NULL; - bcFramePtr->cmd.str.len = 0; + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + bcFramePtr->len = 0; #ifdef TCL_COMPILE_STATS iPtr->stats.numExecutions++; @@ -2134,6 +2130,11 @@ TEBCresume( result = TCL_ERROR; } NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); + if (bcFramePtr->cmdObj) { + Tcl_DecrRefCount(bcFramePtr->cmdObj); + bcFramePtr->cmdObj = NULL; + bcFramePtr->cmd = NULL; + } iPtr->cmdFramePtr = bcFramePtr->nextPtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); @@ -2435,8 +2436,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } pc++; @@ -2889,8 +2893,11 @@ TEBCresume( iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } DECACHE_STACK_INFO(); @@ -2898,7 +2905,7 @@ TEBCresume( pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, - TCL_EVAL_NOERR, NULL); + TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); #if TCL_SUPPORT_84_BYTECODE case INST_CALL_BUILTIN_FUNC1: @@ -3035,8 +3042,11 @@ TEBCresume( bcFramePtr->data.tebc.pc = (char *) pc; iPtr->cmdFramePtr = bcFramePtr; if (iPtr->flags & INTERP_DEBUG_FRAME) { - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + int cmd; + if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) { + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, cmd, pc - codePtr->codeStart); + } } iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = opnd; @@ -6971,7 +6981,7 @@ TEBCresume( if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr); @@ -7153,7 +7163,7 @@ TEBCresume( } codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); @@ -8646,7 +8656,7 @@ ValidatePcAndStackTop( if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; - const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL); + const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); @@ -8730,7 +8740,7 @@ IllegalExprOperandType( /* *---------------------------------------------------------------------- * - * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd -- + * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- * * Given a program counter value, finds the closest command in the * bytecode code unit's CmdLocation array and returns information about @@ -8751,16 +8761,26 @@ IllegalExprOperandType( *---------------------------------------------------------------------- */ -const char * -TclGetSrcInfoForCmd( - Interp *iPtr, - int *lenPtr) +Tcl_Obj * +TclGetSourceFromFrame( + CmdFrame *cfPtr, + int objc, + Tcl_Obj *const objv[]) { - CmdFrame *cfPtr = iPtr->cmdFramePtr; - ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - - return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc, - codePtr, lenPtr, NULL); + if (cfPtr == NULL) { + return Tcl_NewListObj(objc, objv); + } + if (cfPtr->cmdObj == NULL) { + if (cfPtr->cmd == NULL) { + ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; + + cfPtr->cmd = GetSrcInfoForPc((unsigned char *) + cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL); + } + cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len); + Tcl_IncrRefCount(cfPtr->cmdObj); + } + return cfPtr->cmdObj; } void @@ -8769,13 +8789,16 @@ TclGetSrcInfoForPc( { ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr; - if (cfPtr->cmd.str.cmd == NULL) { - cfPtr->cmd.str.cmd = GetSrcInfoForPc( + assert(cfPtr->type == TCL_LOCATION_BC); + + if (cfPtr->cmd == NULL) { + + cfPtr->cmd = GetSrcInfoForPc( (unsigned char *) cfPtr->data.tebc.pc, codePtr, - &cfPtr->cmd.str.len, NULL); + &cfPtr->len, NULL, NULL); } - if (cfPtr->cmd.str.cmd != NULL) { + if (cfPtr->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. @@ -8792,7 +8815,7 @@ TclGetSrcInfoForPc( return; } - srcOffset = cfPtr->cmd.str.cmd - codePtr->source; + srcOffset = cfPtr->cmd - codePtr->source; eclPtr = Tcl_GetHashValue(hePtr); for (i=0; i < eclPtr->nuloc; i++) { @@ -8832,9 +8855,12 @@ GetSrcInfoForPc( int *lengthPtr, /* If non-NULL, the location where the length * of the command's source should be stored. * If NULL, no length is stored. */ - const unsigned char **pcBeg)/* If non-NULL, the bytecode location + const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ + int *cmdIdxPtr) /* If non-NULL, the location where the index + * of the command containing the pc should + * be stored. */ { register int pcOffset = (pc - codePtr->codeStart); int numCmds = codePtr->numCommands; @@ -8844,6 +8870,7 @@ GetSrcInfoForPc( int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestCmdIdx = -1; if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { if (pcBeg != NULL) *pcBeg = NULL; @@ -8911,6 +8938,7 @@ GetSrcInfoForPc( bestDist = dist; bestSrcOffset = srcOffset; bestSrcLength = srcLen; + bestCmdIdx = i; } } } @@ -8940,6 +8968,10 @@ GetSrcInfoForPc( *lengthPtr = bestSrcLength; } + if (cmdIdxPtr != NULL) { + *cmdIdxPtr = bestCmdIdx; + } + return (codePtr->source + bestSrcOffset); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b940225..380284f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1175,29 +1175,27 @@ typedef struct CmdFrame { * * 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 - * ======= ==== ====== ========= + * Field TEBC EvalEx + * ======= ==== ====== + * level yes yes + * type BC/PREBC SRC/EVAL + * line0 yes yes + * framePtr yes yes + * ======= ==== ====== * - * ======= ==== ====== ========= union data - * line1 - yes - - * line3 - yes - - * path - yes - - * ------- ---- ------ --------- - * codePtr yes - - - * pc yes - - - * ======= ==== ====== ========= + * ======= ==== ========= union data + * line1 - yes + * line3 - yes + * path - yes + * ------- ---- ------ + * codePtr yes - + * pc yes - + * ======= ==== ====== * - * ======= ==== ====== ========= | union cmd - * listPtr - - yes | - * ------- ---- ------ --------- | - * cmd yes yes - | - * cmdlen yes yes - | - * ------- ---- ------ --------- | + * ======= ==== ========= union cmd + * str.cmd yes yes + * str.len yes yes + * ------- ---- ------ */ union { @@ -1210,15 +1208,9 @@ typedef struct CmdFrame { 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; - int numLevels; /* Value of interp's numLevels when the frame - * was pushed. */ + Tcl_Obj *cmdObj; + const char *cmd; /* The executed command, if possible... */ + int len; /* ... and its length. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by @@ -1282,8 +1274,6 @@ typedef struct ContLineLoc { * 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 @@ -1295,8 +1285,6 @@ typedef struct ContLineLoc { */ #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. */ @@ -2210,9 +2198,10 @@ typedef struct Interp { * other than these should be turned into errors. */ -#define TCL_ALLOW_EXCEPTIONS 4 -#define TCL_EVAL_FILE 2 -#define TCL_EVAL_CTX 8 +#define TCL_ALLOW_EXCEPTIONS 0x04 +#define TCL_EVAL_FILE 0x02 +#define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: @@ -2737,6 +2726,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); @@ -2828,7 +2818,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, @@ -2919,7 +2909,8 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); -MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr); +MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1a4297b..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,6 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ +static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -481,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -590,6 +597,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -2372,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2462,6 +2479,16 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3052,7 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3071,6 +3102,23 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; + + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index aed623a..bdd5386 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1942,7 +1942,7 @@ InvokeImportedNRCmd( Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } static int diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f8cd1a4..aba06a5 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj *invoke[3]; + Tcl_Obj **invoke; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -102,6 +102,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; @@ -115,7 +116,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke[0], invoke[1], invoke[2], NULL); + invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -131,9 +132,12 @@ DecrRefsPostClassConstructor( Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - TclDecrRefCount((Tcl_Obj *) data[2]); + Tcl_Obj **invoke = data[0]; + + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + TclDecrRefCount(invoke[2]); + ckfree(invoke); return result; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index bacab38..f0983cc 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2206,29 +2206,42 @@ ClassSuperSet( /* * Parse the arguments to get the class to use as superclasses. + * + * Note that zero classes is special, as it is equivalent to just the + * class of objects. [Bug 9d61624b3d] */ - for (i=0 ; i<superc ; i++) { - superclasses[i] = GetClassInOuterContext(interp, superv[i], - "only a class can be a superclass"); - if (superclasses[i] == NULL) { - goto failedAfterAlloc; + if (superc == 0) { + superclasses = ckrealloc(superclasses, sizeof(Class *)); + superclasses[0] = oPtr->fPtr->objectCls; + superc = 1; + if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { + superclasses[0] = oPtr->fPtr->classCls; } - for (j=0 ; j<i ; j++) { - if (superclasses[j] == superclasses[i]) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "class should only be a direct superclass once", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL); + } else { + for (i=0 ; i<superc ; i++) { + superclasses[i] = GetClassInOuterContext(interp, superv[i], + "only a class can be a superclass"); + if (superclasses[i] == NULL) { goto failedAfterAlloc; } - } - if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to form circular dependency graph", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); - failedAfterAlloc: - ckfree((char *) superclasses); - return TCL_ERROR; + for (j=0 ; j<i ; j++) { + if (superclasses[j] == superclasses[i]) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "class should only be a direct superclass once", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); + goto failedAfterAlloc; + } + } + if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to form circular dependency graph", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); + failedAfterAlloc: + ckfree((char *) superclasses); + return TCL_ERROR; + } } } diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index ab54964..c0e4022 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -122,12 +122,6 @@ typedef struct ForwardMethod { Tcl_Obj *prefixObj; /* The list of values to use to replace the * object and method name with. Will be a * non-empty list. */ - int fullyQualified; /* If 1, the command name is fully qualified - * and we should let the default Tcl mechanism - * handle the command lookup because it is - * more efficient. If 0, we need to do a - * specialized lookup based on the current - * object's namespace. */ } ForwardMethod; /* diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..81293c7 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -513,8 +513,8 @@ TclOOMakeProcInstanceMethod( cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); @@ -626,8 +626,8 @@ TclOOMakeProcMethod( cfPtr->data.eval.path = context.data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, &isNew); @@ -1338,7 +1338,6 @@ TclOONewForwardInstanceMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1380,7 +1379,6 @@ TclOONewForwardMethod( fmPtr = ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj); - fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0); Tcl_IncrRefCount(prefixObj); return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); @@ -1409,7 +1407,6 @@ InvokeForwardMethod( ForwardMethod *fmPtr = clientData; Tcl_Obj **argObjs, **prefixObjs; int numPrefixes, len, skip = contextPtr->skip; - Command *cmdPtr; /* * Build the real list of arguments to use. Note that we know that the @@ -1421,15 +1418,10 @@ InvokeForwardMethod( Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs); argObjs = InitEnsembleRewrite(interp, objc, objv, skip, numPrefixes, prefixObjs, &len); - - if (fmPtr->fullyQualified) { - cmdPtr = NULL; - } else { - cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]), - contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); - } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + ((Interp *)interp)->lookupNsPtr + = (Namespace *) contextPtr->oPtr->namespacePtr; + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int @@ -1474,7 +1466,6 @@ CloneForwardMethod( ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; - fm2Ptr->fullyQualified = fmPtr->fullyQualified; Tcl_IncrRefCount(fm2Ptr->prefixObj); *newClientData = fm2Ptr; return TCL_OK; diff --git a/generic/tclObj.c b/generic/tclObj.c index 542d6d1..930e1fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -97,7 +97,6 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; -static void ContLineLocFree(char *clientData); static void TclThreadFinalizeContLines(ClientData clientData); static ThreadSpecificData *TclGetContLineTable(void); @@ -805,14 +804,7 @@ TclThreadFinalizeContLines( for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - /* - * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because - * here we can be sure that the compiler will not hold references to - * the data in the hashtable, and using TEF might bork the - * finalization sequence. - */ - - ContLineLocFree(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); @@ -821,30 +813,6 @@ TclThreadFinalizeContLines( } /* - *---------------------------------------------------------------------- - * - * ContLineLocFree -- - * - * The freProc for continuation line location tables. - * - * Results: - * None. - * - * Side effects: - * Releases memory. - * - * TIP #280 - *---------------------------------------------------------------------- - */ - -static void -ContLineLocFree( - char *clientData) -{ - ckfree(clientData); -} - -/* *-------------------------------------------------------------- * * Tcl_RegisterObjType -- @@ -1405,7 +1373,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1496,7 +1464,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } diff --git a/generic/tclParse.c b/generic/tclParse.c index 08615a7..ee0d4c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclParse.h" +#include <assert.h> /* * The following table provides parsing information about each possible 8-bit @@ -1567,6 +1568,7 @@ Tcl_ParseVar( code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); + Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; @@ -1577,16 +1579,13 @@ Tcl_ParseVar( * At this point we should have an object containing the value of a * variable. Just return the string from that object. * - * This should have returned the object for the user to manage, but - * instead we have some weak reference to the string value in the object, - * which is why we make sure the object exists after resetting the result. - * This isn't ideal, but it's the best we can do with the current - * documented interface. -- hobbs + * Since TclSubstTokens above returned TCL_OK, we know that objPtr + * is shared. It is in both the interp result and the value of the + * variable. Returning the string relies on that to be true. */ - if (!Tcl_IsShared(objPtr)) { - Tcl_IncrRefCount(objPtr); - } + assert( Tcl_IsShared(objPtr) ); + Tcl_ResetResult(interp); return TclGetString(objPtr); } diff --git a/generic/tclProc.c b/generic/tclProc.c index 18985a1..1314719 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -271,8 +271,8 @@ Tcl_ProcObjCmd( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr, &isNew); @@ -2595,8 +2595,8 @@ SetLambdaFromAny( cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); - cfPtr->cmd.str.cmd = NULL; - cfPtr->cmd.str.len = 0; + cfPtr->cmd = NULL; + cfPtr->len = 0; } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 27ee89c..f121d0d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1555,14 +1555,14 @@ DelCallbackProc( * * TestdelCmd -- * - * This procedure implements the "testdcall" command. It is used - * to test Tcl_CallWhenDeleted. + * This procedure implements the "testdel" command. It is used + * to test calling of command deletion callbacks. * * Results: * A standard Tcl result. * * Side effects: - * Creates and deletes interpreters. + * Creates a command. * *---------------------------------------------------------------------- */ @@ -4408,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a349846..15529c7 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1558,7 +1558,7 @@ Tcl_UniCharIsSpace( return TclIsSpaceProc((char) ch); } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x180e || (Tcl_UniChar) ch == 0x200b || (Tcl_UniChar) ch == 0x2060 - || (Tcl_UniChar) ch == 0xfeff) { + || (Tcl_UniChar) ch == 0x202f || (Tcl_UniChar) ch == 0xfeff) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..b089132 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; - register int len; + register int len = 3; memcpy(buffer, "end", 4); - len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); diff --git a/library/auto.tcl b/library/auto.tcl index 0848bb1..78c219e 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -617,4 +617,18 @@ auto_mkindex_parser::command namespace {op args} { } } +# AUTO MKINDEX: oo::class create name ?definition? +# Adds an entry to the auto index list for the given class name. +foreach cmd {oo::class class} { + auto_mkindex_parser::command $cmd {ecmd name {body ""}} { + if {$cmd eq "create"} { + variable index + variable scriptFile + append index [format "set %s \[list source \[%s]]\n" \ + [list auto_index([fullname $name])] \ + [list file join $dir {*}[file split $scriptFile]]] + } + } +} + return diff --git a/library/clock.tcl b/library/clock.tcl index 166c377..1e652b4 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -324,7 +324,7 @@ proc ::tcl::clock::Initialize {} { {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires - {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Brasilia + {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b0487e6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { diff --git a/tests/binary.test b/tests/binary.test index 4393245..d424837 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 diff --git a/tests/coroutine.test b/tests/coroutine.test index 1d9040b..03c63ad 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -609,6 +609,39 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} + +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} + +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} + +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} + +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok + # cleanup unset lambda diff --git a/tests/error.test b/tests/error.test index 06f8eca..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself diff --git a/tests/interp.test b/tests/interp.test index 0af9887..ad99fac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * +test interp-20.50.1 {Bug 2486550} -setup { + interp create slave +} -body { + slave hide coroutine + catch {slave invokehidden coroutine} m o + dict get $o -errorinfo +} -cleanup { + unset -nocomplain m 0 + interp delete slave +} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" + while executing +"coroutine" + invoked from within +"slave invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] diff --git a/tests/oo.test b/tests/oo.test index 49fe150..e0e0791 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup { } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} +test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { + oo::object create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::objdefine foo { + method target {} {lappend ::result instance} + forward bar my target + method bump {} { + set ns [info object namespace ::foo] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + foo destroy +} -result {instance instance instance instance instance instance} +test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { + oo::class create fooClass + fooClass create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::define fooClass { + method target {} {lappend ::result class} + forward bar my target + method bump {} { + set ns [info object namespace [self]] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + fooClass destroy +} -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass @@ -3374,6 +3437,42 @@ test oo-34.8 {TIP 380: slots - presence} { test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} + +test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruit { + method eat {} {} + } + set result {} +} -body { + lappend result [fruit create ::apple] [info class superclasses fruit] + oo::define fruit superclass + lappend result [info class superclasses fruit] \ + [info object class apple oo::object] \ + [info class call fruit destroy] \ + [catch { apple }] +} -cleanup { + unset -nocomplain result + fruit destroy +} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1} +test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruitMetaclass { + superclass oo::class + method eat {} {} + } + set result {} +} -body { + lappend result [fruitMetaclass create ::appleClass] \ + [appleClass create orange] \ + [info class superclasses fruitMetaclass] + oo::define fruitMetaclass superclass + lappend result [info class superclasses fruitMetaclass] \ + [info object class appleClass oo::class] \ + [catch { orange }] [info object class orange] \ + [appleClass create pear] +} -cleanup { + unset -nocomplain result + fruitMetaclass destroy +} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear} cleanupTests return diff --git a/tests/parse.test b/tests/parse.test index b9cfe80..01443c9 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -27,6 +27,7 @@ testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevent [llength [info commands testevent]] +testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -678,6 +679,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} + + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -1097,6 +1118,12 @@ test parse-21.0 {Bug 1884496} testevent { testevent queue a head $::script vwait done } {} +test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent { + testevent queue a head {testevent delete a; \ + set ::done [dict get [info frame 0] line]} + vwait done + set ::done +} 2 cleanupTests } diff --git a/tests/reg.test b/tests/reg.test index 559f549..e6ce42c 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -1155,6 +1155,9 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} { (.*) # ConditionalFields }] 0 } 68 +test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} { + lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0 +} 1 # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index 1c30001..1b2bec9 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -876,6 +876,10 @@ test regexp-22.5 {Bug 3610026} -setup { } -cleanup { unset -nocomplain e cp } -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" diff --git a/tests/rename.test b/tests/rename.test index 1fa0441..ebf5425 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { if {[info exists env(value)]} { unset env(value) } +test rename-4.8 {Bug a16752c252} testdel { + set x broken + testdel {} foo {set x ok} + proc foo args {} + rename foo {} + return -level 0 $x[unset x] +} ok # Save the unknown procedure which is modified by the following test. diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..859f352 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i {load {} Safepkg1}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1" + invoked from within +"interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} @@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { + set i [safe::interpCreate -nestedloadok] + catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1 x" + invoked from within +"interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.7.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertfrom} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertfrom ?encoding? data" + while executing +"encoding convertfrom" + invoked from within +"::interp invokehidden interp1 encoding convertfrom" + invoked from within +"encoding convertfrom" + invoked from within +"interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-11.8.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertto} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertto ?encoding? data" + while executing +"encoding convertto" + invoked from within +"::interp invokehidden interp1 encoding convertto" + invoked from within +"encoding convertto" + invoked from within +"interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] @@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { + unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} +test safe-15.1.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] +} -cleanup { + unset -nocomplain msg o + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file + while executing +"file isdirectory ." + invoked from within +"interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { diff --git a/tests/subst.test b/tests/subst.test index 4be4798..7466895 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup { } -cleanup { removeFile subst13.tcl } +test subst-13.2 {Test for segfault} -body { + subst {[} +} -returnCodes error -result * -match glob + # cleanup ::tcltest::cleanupTests diff --git a/tests/trace.test b/tests/trace.test index a3a5604..d830f3c 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -2661,6 +2661,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} + +test trace-40.1 {execution trace errors become command errors} { + proc foo args {} + trace add execution foo enter {rename foo {}; error bar;#} + catch foo m + return -level 0 $m[unset m] +} bar # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test new file mode 100644 index 0000000..120f362 --- /dev/null +++ b/tests/unixForkEvent.test @@ -0,0 +1,45 @@ +# This file contains a collection of tests for the procedures in the file +# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +testConstraint testfork [llength [info commands testfork]] + +# Test if the notifier thread is well initialized in a forked interpreter +# by Tcl_InitNotifier +test unixforkevent-1.1 {fork and test writeable event} \ + -constraints {testfork nonPortable} \ + -body { + set myFolder [makeDirectory unixtestfork] + set pid [testfork] + if {$pid == 0} { + # we are the forked process + set result initialized + set h [open [file join $myFolder test.txt] w] + fileevent $h writable\ + "set result writable;\ + after cancel [after 1000 {set result timeout}]" + vwait result + close $h + makeFile $result result.txt $myFolder + exit + } + # we are the original process + while {![file readable [file join $myFolder result.txt]]} {} + viewFile result.txt $myFolder + } \ + -result {writable} \ + -cleanup { + catch { removeFolder $myFolder } + } + +::tcltest::cleanupTests +return diff --git a/tests/zlib.test b/tests/zlib.test index c469eea..0712929 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict @@ -276,7 +276,10 @@ test zlib-8.10 {transformtion and fconfigure} -setup { puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] @@ -284,7 +287,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +303,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +320,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +337,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +353,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { diff --git a/unix/Makefile.in b/unix/Makefile.in index b5ca879..505f7e0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,10 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o \ + tclTomMathStubLib.o \ + tclOOStubLib.o \ + ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ @@ -346,6 +349,8 @@ NOTIFY_OBJS = tclUnixNotfy.o MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXFCmd.o tclMacOSXNotify.o +CYGWIN_OBJS = tclWinError.o + DTRACE_OBJ = tclDTrace.o ZLIB_OBJS = Zadler32.o Zcompress.o Zcrc32.o Zdeflate.o Zinfback.o \ @@ -575,6 +580,9 @@ MAC_OSX_SRCS = \ $(MAC_OSX_DIR)/tclMacOSXFCmd.c \ $(MAC_OSX_DIR)/tclMacOSXNotify.c +CYGWIN_SRCS = \ + $(TOP_DIR)/win/tclWinError.c + DTRACE_HDR = tclDTrace.h DTRACE_SRC = $(GENERIC_DIR)/tclDTrace.d @@ -842,8 +850,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; diff --git a/unix/configure b/unix/configure index f219255..9b3c298 100755 --- a/unix/configure +++ b/unix/configure @@ -4821,7 +4821,11 @@ echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you m # Does the pthread-implementation provide # 'pthread_attr_setstacksize' ? -for ac_func in pthread_attr_setstacksize + ac_saved_libs=$LIBS + LIBS="$LIBS $THREADS_LIBS" + + +for ac_func in pthread_attr_setstacksize pthread_atfork do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 @@ -4922,6 +4926,7 @@ _ACEOF fi done + LIBS=$ac_saved_libs else TCL_THREADS=0 fi @@ -7068,7 +7073,9 @@ fi SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS='${CYGWIN_OBJS}' + PLAT_SRCS='${CYGWIN_SRCS}' DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" @@ -17948,108 +17955,6 @@ _ACEOF fi done - -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case <limits.h> declares $ac_func. - For example, HP-UX 11i <limits.h> declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer <limits.h> to <assert.h> if __STDC__ is defined, since - <limits.h> exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include <limits.h> -#else -# include <assert.h> -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - fi cat >>confdefs.h <<\_ACEOF diff --git a/unix/configure.in b/unix/configure.in index dca8b8c..1a9bb31 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -576,7 +576,6 @@ if test "`uname -s`" = "Darwin" ; then if test $tcl_corefoundation = yes; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) - AC_CHECK_FUNCS(pthread_atfork) fi AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b9b6532..194cf90 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -676,7 +676,11 @@ AC_DEFUN([SC_ENABLE_THREADS], [ # Does the pthread-implementation provide # 'pthread_attr_setstacksize' ? - AC_CHECK_FUNCS(pthread_attr_setstacksize) + + ac_saved_libs=$LIBS + LIBS="$LIBS $THREADS_LIBS" + AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) + LIBS=$ac_saved_libs else TCL_THREADS=0 fi @@ -1224,7 +1228,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS='${CYGWIN_OBJS}' + PLAT_SRCS='${CYGWIN_SRCS}' DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e27f78f..e270b6a 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -462,10 +462,10 @@ DoCopyFile( switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { - char linkBuf[MAXPATHLEN]; + char linkBuf[MAXPATHLEN+1]; int length; - length = readlink(src, linkBuf, sizeof(linkBuf)); + length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index aacc8d2d..c6c9759 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -120,6 +120,15 @@ static Tcl_ThreadDataKey dataKey; static int notifierCount = 0; /* + * The following static stores the process ID of the initialized notifier + * thread. If it changes, we have passed a fork and we should start a new + * notifier thread. + * + * You must hold the notifierMutex lock before accessing this variable. + */ +static pid_t processIDInitialized = 0; + +/* * The following variable points to the head of a doubly-linked list of * ThreadSpecificData structures for all threads that are currently waiting on * an event. @@ -185,7 +194,13 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#endif +#ifdef HAVE_PTHREAD_ATFORK +static int atForkInit = 0; +static void AtForkPrepare(void); +static void AtForkParent(void); +static void AtForkChild(void); +#endif /* HAVE_PTHREAD_ATFORK */ +#endif /* TCL_THREADS */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* @@ -275,11 +290,38 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); +#ifdef HAVE_PTHREAD_ATFORK + /* + * Install pthread_atfork handlers to reinitialize the notifier in the + * child of a fork. + */ + + if (!atForkInit) { + int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild); + + if (result) { + Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); + } + atForkInit = 1; + } +#endif + /* + * Check if my process id changed, e.g. I was forked + * In this case, restart the notifier thread and close the + * pipe to the original notifier thread + */ + if (notifierCount > 0 && processIDInitialized != getpid()) { + notifierCount = 0; + processIDInitialized = 0; + close(triggerPipe); + triggerPipe = -1; + } if (notifierCount == 0) { if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); } + processIDInitialized = getpid(); } notifierCount++; @@ -1270,6 +1312,75 @@ NotifierThreadProc( TclpThreadExit(0); } + +#ifdef HAVE_PTHREAD_ATFORK +/* + *---------------------------------------------------------------------- + * + * AtForkPrepare -- + * + * Lock the notifier in preparation for a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkPrepare(void) +{ +} + +/* + *---------------------------------------------------------------------- + * + * AtForkParent -- + * + * Unlock the notifier in the parent after a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkParent(void) +{ +} + +/* + *---------------------------------------------------------------------- + * + * AtForkChild -- + * + * Unlock and reinstall the notifier in the child after a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkChild(void) +{ + notifierMutex = NULL; + notifierCV = NULL; + Tcl_InitNotifier(); +} +#endif /* HAVE_PTHREAD_ATFORK */ + #endif /* TCL_THREADS */ #endif /* !HAVE_COREFOUNDATION */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 9c3d7eb..a6360c2 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (port == 0 && chosenport == 0) { @@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (statePtr == NULL) { diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index c10225d..b3e07a4 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -67,6 +67,7 @@ static Tcl_CmdProc TestchmodCmd; static Tcl_CmdProc TestfilehandlerCmd; static Tcl_CmdProc TestfilewaitCmd; static Tcl_CmdProc TestfindexecutableCmd; +static Tcl_ObjCmdProc TestforkObjCmd; static Tcl_CmdProc TestgetdefencdirCmd; static Tcl_CmdProc TestgetopenfileCmd; static Tcl_CmdProc TestgotsigCmd; @@ -103,6 +104,8 @@ TclplatformtestInit( NULL, NULL); Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd, @@ -526,6 +529,52 @@ TestsetdefencdirCmd( Tcl_SetDefaultEncodingDir(argv[1]); return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestforkObjCmd -- + * + * This function implements the "testfork" command. It is used to + * fork the Tcl process for specific test cases. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestforkObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument strings. */ +{ + pid_t pid; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + pid = fork(); + if (pid == -1) { + Tcl_AppendResult(interp, + "Cannot fork", NULL); + return TCL_ERROR; + } +#if !defined(HAVE_PTHREAD_ATFORK) || defined(MAC_OSX_TCL) + /* Only needed when pthread_atfork is not present or on OSX. */ + if (pid==0) { + Tcl_InitNotifier(); + } +#endif + Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); + return TCL_OK; +} /* *---------------------------------------------------------------------- diff --git a/win/Makefile.in b/win/Makefile.in index 47f3fdd..5109e7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -650,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; |