summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2013-09-07 21:19:47 (GMT)
committerdgp <dgp@users.sourceforge.net>2013-09-07 21:19:47 (GMT)
commit7d65b0f9b214a041c9007cf45220fe7c8a5c88f0 (patch)
treee37a1e5e986f7b58a0b5da2d438f30df452ee611
parent4bba36ca59c3760f9e2a593e8135aa6f8352919e (diff)
parent133768540d48de8f9bf0638fd9983178588bd18a (diff)
downloadtcl-7d65b0f9b214a041c9007cf45220fe7c8a5c88f0.zip
tcl-7d65b0f9b214a041c9007cf45220fe7c8a5c88f0.tar.gz
tcl-7d65b0f9b214a041c9007cf45220fe7c8a5c88f0.tar.bz2
merge trunkbug_86ceb4e2b6
-rw-r--r--ChangeLog22
-rw-r--r--doc/AddErrInfo.312
-rw-r--r--doc/CrtInterp.37
-rw-r--r--doc/Environment.32
-rw-r--r--doc/Method.35
-rw-r--r--doc/NRE.312
-rw-r--r--doc/bgerror.n5
-rw-r--r--doc/binary.n2
-rw-r--r--doc/catch.n3
-rw-r--r--doc/eval.n3
-rw-r--r--doc/info.n12
-rw-r--r--doc/library.n10
-rw-r--r--doc/return.n4
-rw-r--r--doc/tclsh.18
-rw-r--r--doc/throw.n2
-rw-r--r--generic/regc_nfa.c2
-rw-r--r--generic/regexec.c7
-rw-r--r--generic/tclAssembly.c40
-rw-r--r--generic/tclBasic.c813
-rw-r--r--generic/tclBinary.c43
-rw-r--r--generic/tclCmdIL.c34
-rw-r--r--generic/tclCompCmds.c24
-rw-r--r--generic/tclCompCmdsGR.c5
-rw-r--r--generic/tclCompCmdsSZ.c11
-rw-r--r--generic/tclCompile.c909
-rw-r--r--generic/tclCompile.h26
-rw-r--r--generic/tclEnsemble.c158
-rw-r--r--generic/tclExecute.c114
-rw-r--r--generic/tclInt.h69
-rw-r--r--generic/tclInterp.c56
-rw-r--r--generic/tclNamesp.c2
-rw-r--r--generic/tclOOBasic.c14
-rw-r--r--generic/tclOODefineCmds.c49
-rw-r--r--generic/tclOOInt.h6
-rw-r--r--generic/tclOOMethod.c23
-rw-r--r--generic/tclObj.c38
-rw-r--r--generic/tclParse.c15
-rw-r--r--generic/tclProc.c8
-rw-r--r--generic/tclTest.c28
-rw-r--r--generic/tclUtf.c2
-rw-r--r--generic/tclUtil.c3
-rw-r--r--library/auto.tcl14
-rw-r--r--library/clock.tcl2
-rw-r--r--library/tcltest/pkgIndex.tcl2
-rw-r--r--library/tcltest/tcltest.tcl2
-rw-r--r--tests/assemble.test3
-rw-r--r--tests/binary.test28
-rw-r--r--tests/coroutine.test33
-rw-r--r--tests/error.test10
-rw-r--r--tests/interp.test14
-rw-r--r--tests/misc.test7
-rw-r--r--tests/oo.test99
-rw-r--r--tests/parse.test27
-rw-r--r--tests/reg.test3
-rw-r--r--tests/regexp.test4
-rw-r--r--tests/rename.test7
-rw-r--r--tests/safe.test80
-rw-r--r--tests/subst.test4
-rw-r--r--tests/trace.test7
-rw-r--r--tests/unixForkEvent.test45
-rw-r--r--tests/zlib.test21
-rw-r--r--unix/Makefile.in14
-rwxr-xr-xunix/configure113
-rw-r--r--unix/configure.in1
-rw-r--r--unix/tcl.m410
-rw-r--r--unix/tclUnixFCmd.c4
-rw-r--r--unix/tclUnixNotfy.c113
-rw-r--r--unix/tclUnixSock.c2
-rw-r--r--unix/tclUnixTest.c49
-rw-r--r--win/Makefile.in4
70 files changed, 1777 insertions, 1553 deletions
diff --git a/ChangeLog b/ChangeLog
index d7ada95..e0b623b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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.
diff --git a/doc/NRE.3 b/doc/NRE.3
index 7ebeb39..ce609e6 100644
--- a/doc/NRE.3
+++ b/doc/NRE.3
@@ -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:
diff --git a/doc/eval.n b/doc/eval.n
index da88757..13b54be 100644
--- a/doc/eval.n
+++ b/doc/eval.n
@@ -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:
diff --git a/doc/info.n b/doc/info.n
index e65a083..14a9e50 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -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(&notifierMutex);
+#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(&notifierThread, 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";