summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCompile.c47
-rw-r--r--generic/tclEvent.c3
-rw-r--r--tests/compile.test31
-rw-r--r--win/nmakehlp.c2
-rw-r--r--win/tclWinDde.c18
-rw-r--r--win/tclWinInit.c2
-rw-r--r--win/tclWinReg.c10
7 files changed, 80 insertions, 33 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 8a13eba..122e1b3 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2166,18 +2166,26 @@ TclCompileScript(
/* Each iteration compiles one command from the script. */
- while (numBytes > 0) {
- Tcl_Parse parse;
+ if (numBytes > 0) {
+ /*
+ * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so
+ * many nested compilations (body enclosed in body) can cause abnormal
+ * program termination with a stack overflow exception, bug [fec0c17d39].
+ */
+ Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
+
+ do {
const char *next;
- if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) {
+ if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) {
/*
- * Compile bytecodes to report the parse error at runtime.
+ * Compile bytecodes to report the parsePtr error at runtime.
*/
- Tcl_LogCommandInfo(interp, script, parse.commandStart,
- parse.term + 1 - parse.commandStart);
+ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
+ parsePtr->term + 1 - parsePtr->commandStart);
TclCompileSyntaxError(interp, envPtr);
+ ckfree(parsePtr);
return;
}
@@ -2188,9 +2196,9 @@ TclCompileScript(
*/
if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- int commandLength = parse.term - parse.commandStart;
+ int commandLength = parsePtr->term - parsePtr->commandStart;
fprintf(stdout, " Compiling: ");
- TclPrintSource(stdout, parse.commandStart,
+ TclPrintSource(stdout, parsePtr->commandStart,
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
@@ -2201,48 +2209,51 @@ TclCompileScript(
* (See test info-30.33).
*/
- TclAdvanceLines(&envPtr->line, p, parse.commandStart);
+ TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
- parse.commandStart - envPtr->source);
+ parsePtr->commandStart - envPtr->source);
/*
* Advance parser to the next command in the script.
*/
- next = parse.commandStart + parse.commandSize;
+ next = parsePtr->commandStart + parsePtr->commandSize;
numBytes -= next - p;
p = next;
- if (parse.numWords == 0) {
+ if (parsePtr->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
+ * including newlines, parsePtr->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
+ * allocated at parsePtr->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
+ * can be written with an assumption that parsePtr->numWords > 0, with
* the implication the CCT() always generates bytecode.
*/
continue;
}
- lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr);
+ lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr);
/*
* TIP #280: Track lines in the just compiled command.
*/
- TclAdvanceLines(&envPtr->line, parse.commandStart, p);
+ TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
p - envPtr->source);
- Tcl_FreeParse(&parse);
+ Tcl_FreeParse(parsePtr);
+ } while (numBytes > 0);
+
+ ckfree(parsePtr);
}
if (lastCmdIdx == -1) {
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 571885f..734f114 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1472,8 +1472,7 @@ VwaitVarProc(
int *donePtr = clientData;
*donePtr = 1;
- Tcl_UntraceVar2(interp, name1, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
}
diff --git a/tests/compile.test b/tests/compile.test
index fb9a87a..2aa5ef6 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -466,6 +466,37 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
+# Tests of nested compile (body in body compilation), should not generate stack overflow
+# (with abnormal program termination), bug [fec0c17d39]:
+test compile-13.2 {TclCompileScript: testing nested scripts compilation} -setup {
+ set i [interp create]
+ interp recursionlimit $i [expr {10000+50}]
+ $i eval {proc gencode {nr {cmd eval} {nl 0}} {
+ set code ""
+ set e ""; if {$nl} {set e "\n"}
+ for {set i 0} {$i < $nr} {incr i} {
+ append code "$cmd \{$e"
+ }
+ append code "lappend result 1$e"
+ for {set i 0} {$i < $nr} {incr i} {
+ append code "\}$e"
+ }
+ #puts [format "%% %.40s ... %d bytes" $code [string length $code]]
+ return $code
+ }}
+} -body {
+ # Test different compilation variants (instructions evalStk, invokeStk, etc),
+ # with 2000 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
+ # boxes or systems, please don't decrease it (either provide a constraint)
+ $i eval {foreach cmd {eval "if 1" try catch} {
+ set c [gencode [expr {![::tcl::pkgconfig get debug] ? 2000 : 1000}] $cmd]
+ if 1 $c
+ }}
+ $i eval {set result}
+} -result {1 1 1 1} -cleanup {
+ interp delete $i
+}
+
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
diff --git a/win/nmakehlp.c b/win/nmakehlp.c
index c21de63..fac32ee 100644
--- a/win/nmakehlp.c
+++ b/win/nmakehlp.c
@@ -643,7 +643,7 @@ SubstituteFile(
}
/* debug: dump the list */
-#ifdef _DEBUG
+#ifndef NDEBUG
{
int n = 0;
list_item_t *p = NULL;
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 44cbbbe..2058889 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -101,7 +101,7 @@ static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
static int DdeCreateClient(DdeEnumServices *es);
static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
LPARAM lParam);
-static void DdeExitProc(ClientData clientData);
+static void DdeExitProc(void *clientData);
static int DdeGetServicesList(Tcl_Interp *interp,
const WCHAR *serviceName, const WCHAR *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
@@ -109,13 +109,13 @@ static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
DWORD dwData1, DWORD dwData2);
static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam,
LPARAM lParam);
-static void DeleteProc(ClientData clientData);
+static void DeleteProc(void *clientData);
static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr);
static int MakeDdeConnection(Tcl_Interp *interp,
const WCHAR *name, HCONV *ddeConvPtr);
static void SetDdeError(Tcl_Interp *interp);
-static int DdeObjCmd(ClientData clientData,
+static int DdeObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -503,7 +503,7 @@ DdeGetRegistrationPtr(
static void
DeleteProc(
- ClientData clientData) /* The interp we are deleting passed as
+ void *clientData) /* The interp we are deleting passed as
* ClientData. */
{
RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
@@ -641,7 +641,7 @@ DdeServerProc(
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
- DWORD dwData1, DWORD dwData2)
+ DWORD unused1, DWORD unused2)
/* Transaction-dependent data. */
{
Tcl_DString dString;
@@ -653,6 +653,8 @@ DdeServerProc(
RegisteredInterp *riPtr;
Conversation *convPtr, *prevConvPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ (void)unused1;
+ (void)unused2;
switch(uType) {
case XTYP_CONNECT:
@@ -986,8 +988,9 @@ DdeServerProc(
static void
DdeExitProc(
- ClientData clientData) /* Not used in this handler. */
+ void *dummy) /* Not used. */
{
+ (void)dummy;
DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
DdeUninitialize(ddeInstance);
ddeInstance = 0;
@@ -1288,7 +1291,7 @@ SetDdeError(
static int
DdeObjCmd(
- ClientData clientData, /* Used only for deletion */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
Tcl_Obj *const *objv) /* The arguments */
@@ -1330,6 +1333,7 @@ DdeObjCmd(
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
Tcl_DString serviceBuf, topicBuf, itemBuf;
+ (void)dummy;
/*
* Initialize DDE server/client
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index d0d72bf..852e5f7 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -543,7 +543,7 @@ TclpSetVariables(
TCL_GLOBAL_ONLY);
}
-#ifdef _DEBUG
+#ifndef NDEBUG
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 73208b9..ee13dbb 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -96,7 +96,7 @@ static void AppendSystemError(Tcl_Interp *interp, DWORD error);
static int BroadcastValue(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static DWORD ConvertDWORD(DWORD type, DWORD value);
-static void DeleteCmd(ClientData clientData);
+static void DeleteCmd(void *clientData);
static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
REGSAM mode);
static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
@@ -119,7 +119,7 @@ static int ParseKeyName(Tcl_Interp *interp, char *name,
char **keyNamePtr);
static DWORD RecursiveDeleteKey(HKEY hStartKey,
const WCHAR * pKeyName, REGSAM mode);
-static int RegistryObjCmd(ClientData clientData,
+static int RegistryObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
@@ -214,6 +214,7 @@ Registry_Unload(
{
Tcl_Command cmd;
Tcl_Obj *objv[3];
+ (void)flags;
/*
* Unregister the registry package. There is no Tcl_PkgForget()
@@ -255,7 +256,7 @@ Registry_Unload(
static void
DeleteCmd(
- ClientData clientData)
+ void *clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
@@ -280,7 +281,7 @@ DeleteCmd(
static int
RegistryObjCmd(
- ClientData clientData, /* Not used. */
+ void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
@@ -299,6 +300,7 @@ RegistryObjCmd(
static const char *const modes[] = {
"-32bit", "-64bit", NULL
};
+ (void)dummy;
if (objc < 2) {
wrongArgs:
generated by cgit v0.12 at 2024-09-29 11:28:28 (GMT)