summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCompCmds.c8
-rw-r--r--generic/tclEnsemble.c154
-rw-r--r--tests/info.test26
-rw-r--r--tests/nre.test26
4 files changed, 118 insertions, 96 deletions
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 160fa3c..8fa191b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -5791,7 +5791,7 @@ TclCompileVariableCmd(
*/
valueTokenPtr = parsePtr->tokenPtr;
- for (i=2; i<=numWords; i+=2) {
+ for (i=1; i<numWords; i+=2) {
varTokenPtr = TokenAfter(valueTokenPtr);
valueTokenPtr = TokenAfter(varTokenPtr);
@@ -5801,15 +5801,15 @@ TclCompileVariableCmd(
return TCL_ERROR;
}
- CompileWord(envPtr, varTokenPtr, interp, 1);
+ CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
- if (i != numWords) {
+ if (i+1 < numWords) {
/*
* A value has been given: set the variable, pop the value
*/
- CompileWord(envPtr, valueTokenPtr, interp, 1);
+ CompileWord(envPtr, valueTokenPtr, interp, i+1);
Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 8cd9717..5bef6e8 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -37,12 +37,10 @@ static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
static int CompileToCompiledCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Tcl_Token *tokenPtr,
- int len, Tcl_Obj **elems, Command *cmdPtr,
- CompileEnv *envPtr);
+ int depth, Command *cmdPtr, CompileEnv *envPtr);
static void CompileToInvokedCommand(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, Tcl_Token *tokenPtr,
- Tcl_Obj *replacements, Command *cmdPtr,
- CompileEnv *envPtr);
+ Tcl_Parse *parsePtr, Tcl_Obj *replacements,
+ Command *cmdPtr, CompileEnv *envPtr);
/*
* The lists of subcommands and options for the [namespace ensemble] command.
@@ -86,6 +84,26 @@ const Tcl_ObjType tclEnsembleCmdType = {
StringOfEnsembleCmdRep, /* updateStringProc */
NULL /* setFromAnyProc */
};
+
+/*
+ * Copied from tclCompCmds.c
+ */
+
+#define DefineLineInformation \
+ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
+ int eclIndex = mapPtr->nuloc - 1
+#define CompileWord(envPtr, tokenPtr, interp, word) \
+ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
+ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
+ (tokenPtr)[1].size), (envPtr)); \
+ } else { \
+ if (mapPtr->loc[eclIndex].next) { \
+ envPtr->line = mapPtr->loc[eclIndex].line[word]; \
+ envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
+ } \
+ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
+ (envPtr)); \
+ }
static inline Tcl_Obj *
NewNsObj(
@@ -2743,11 +2761,14 @@ TclCompileEnsemble(
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
- int len, result, flags = 0, i, depth = 1;
+ Command *oldCmdPtr = cmdPtr, *newCmdPtr;
+ int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
+ int ourResult = TCL_ERROR;
unsigned numBytes;
const char *word;
Tcl_IncrRefCount(replaced);
+ checkNextWord:
if (parsePtr->numWords < depth + 1) {
goto failed;
}
@@ -2915,6 +2936,7 @@ TclCompileEnsemble(
*/
if (matched != 1) {
+ invokeAnyway = 1;
goto failed;
}
}
@@ -2933,29 +2955,33 @@ TclCompileEnsemble(
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto failed;
}
- if (len > 1 || Tcl_IsSafe(interp)) {
+ if (len != 1) {
goto failed;
}
targetCmdObj = elems[0];
+ oldCmdPtr = cmdPtr;
Tcl_IncrRefCount(targetCmdObj);
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
+ newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
TclDecrRefCount(targetCmdObj);
- if (cmdPtr == NULL
- || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
- || cmdPtr->flags * CMD_HAS_EXEC_TRACES
+ if (newCmdPtr == NULL || Tcl_IsSafe(interp)
+ || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
+ || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
/*
* Maps to an undefined command or a command without a compiler.
* Cannot compile.
*/
- goto failed;
+ goto cleanup;
}
+ cmdPtr = newCmdPtr;
depth++;
if (cmdPtr->compileProc == TclCompileEnsemble) {
- // TODO: Back round the loop to parse the next level down.
+ tokenPtr = TokenAfter(tokenPtr);
+ ensemble = (Tcl_Command) cmdPtr;
+ goto checkNextWord;
}
/*
@@ -2965,26 +2991,44 @@ TclCompileEnsemble(
* invoke at runtime.
*/
- if (cmdPtr->compileProc != NULL &&
- CompileToCompiledCommand(interp, parsePtr, tokenPtr,
- len, elems, cmdPtr, envPtr) == TCL_OK) {
- goto succeeded;
- } else if (len != 1) {
- goto failed;
- }
- CompileToInvokedCommand(interp, parsePtr, tokenPtr, replaced,
- cmdPtr, envPtr);
- succeeded:
- if (replaced != NULL) {
- Tcl_DecrRefCount(replaced);
+ invokeAnyway = 1;
+ if (cmdPtr->compileProc != NULL) {
+ if (CompileToCompiledCommand(interp, parsePtr, tokenPtr, depth,
+ cmdPtr, envPtr) == TCL_OK) {
+ ourResult = TCL_OK;
+ goto cleanup;
+ }
}
- return TCL_OK;
+
+ /*
+ * Failed to do a full compile for some reason. Try to do a direct invoke
+ * instead of going through the ensemble lookup process again.
+ */
failed:
+ if (len == 1 && depth < 250) {
+ if (depth > 1) {
+ if (!invokeAnyway) {
+ cmdPtr = oldCmdPtr;
+ depth--;
+ }
+ (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL);
+ }
+ CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
+ ourResult = TCL_OK;
+ }
+
+ /*
+ * Release the memory we allocated. If we've got here, we've either done
+ * something useful or we're in a case that we can't compile at all and
+ * we're just giving up.
+ */
+
+ cleanup:
if (replaced != NULL) {
Tcl_DecrRefCount(replaced);
}
- return TCL_ERROR;
+ return ourResult;
}
/*
@@ -2998,46 +3042,44 @@ CompileToCompiledCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Token *tokenPtr,
- int len,
- Tcl_Obj **elems,
+ int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Parse synthetic;
+ Tcl_Token *tokPtr;
int result, i;
TclParseInit(interp, NULL, 0, &synthetic);
- synthetic.numWords = parsePtr->numWords - 2 + len;
- TclGrowParseTokenArray(&synthetic, 2*len);
- synthetic.numTokens = 2*len;
+ synthetic.numWords = parsePtr->numWords - depth + 1;
+ TclGrowParseTokenArray(&synthetic, 2);
+ synthetic.numTokens = 2;
/*
- * Now we have the space to work in, install something rewritten. Note
- * that we are here praying for all our might that none of these words are
- * a script; the error detection code will crash if that happens and there
- * is nothing we can do to avoid it!
+ * Now we have the space to work in, install something rewritten. The
+ * first word will "officially" be the structured ensemble name.
*/
- for (i=0 ; i<len ; i++) {
- int sclen;
- const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
-
- synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
- synthetic.tokenPtr[2*i].start = str;
- synthetic.tokenPtr[2*i].size = sclen;
- synthetic.tokenPtr[2*i].numComponents = 1;
-
- synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
- synthetic.tokenPtr[2*i+1].start = str;
- synthetic.tokenPtr[2*i+1].size = sclen;
- synthetic.tokenPtr[2*i+1].numComponents = 0;
+ 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;
+ tokPtr = parsePtr->tokenPtr;
+ for (i=0 ; i<depth ; i++) {
+ int sclen = (tokPtr->start-synthetic.tokenPtr[0].start)+tokPtr->size;
+
+ synthetic.tokenPtr[0].size = sclen;
+ synthetic.tokenPtr[1].size = sclen;
+ tokPtr = TokenAfter(tokPtr);
}
/*
* Copy over the real argument tokens.
*/
- for (i=len; i<synthetic.numWords; i++) {
+ for (i=1; i<synthetic.numWords; i++) {
int toCopy;
tokenPtr = TokenAfter(tokenPtr);
@@ -3066,7 +3108,6 @@ static void
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
- Tcl_Token *tokenPtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
@@ -3074,18 +3115,19 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords;
+ int length, i, numWords, cmdLit;
+ DefineLineInformation;
// TODO: Generate magic (with new instruction) for setting up the ensemble
// rewriting...
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
- if (i > 0 && i-1 < numWords) {
+ if (i > 0 && i < numWords+1) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
} else {
- TclCompileTokens(interp, tokPtr+1, tokPtr->numComponents, envPtr);
+ CompileWord(envPtr, tokPtr, interp, i);
}
tokPtr = TokenAfter(tokPtr);
}
@@ -3098,7 +3140,9 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
- PushLiteral(envPtr, bytes, length);
+ cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr);
+ TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
/*
diff --git a/tests/info.test b/tests/info.test
index 5078e11..ebc853a 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -692,31 +692,31 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
##
# ### ### ### ######### ######### #########
## info frame
+
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
+
proc reduce {frame} {
- set pos [lsearch -exact $frame cmd]
- incr pos
- set cmd [lindex $frame $pos]
+ set cmd [dict get $frame cmd]
if {[regexp \n $cmd]} {
- set first [string range [lindex [split $cmd \n] 0] 0 end-4]
- set frame [lreplace $frame $pos $pos $first]
+ dict set frame cmd \
+ [string range [lindex [split $cmd \n] 0] 0 end-4]
}
- set pos [lsearch -exact $frame file]
- if {$pos >=0} {
- incr pos
- set tail [file tail [lindex $frame $pos]]
- set frame [lreplace $frame $pos $pos $tail]
+ if {[dict exists $frame file]} {
+ dict set frame file \
+ [file tail [dict get $frame file]]
}
- set frame
+ return $frame
}
+
proc subinterp {} { interp create sub ; interp debug sub -frame 1;
interp eval sub [list proc reduce [info args reduce] [info body reduce]]
}
+
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
@@ -1454,9 +1454,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body {
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
- [reduce [info frame 0]];# line 1457
+ [info frame 0];# line 1457
}
- return $xxx::res
+ return [reduce $xxx::res]
} {type source line 1457 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {
diff --git a/tests/nre.test b/tests/nre.test
index b8ef2e0..b5eb032 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -74,7 +74,6 @@ test nre-1.1 {self-recursive procs} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-1.2 {self-recursive lambdas} -setup {
set a [list i [makebody {apply $::a $i}]]
} -body {
@@ -85,7 +84,6 @@ test nre-1.2 {self-recursive lambdas} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-1.3 {mutually recursive procs and lambdas} -setup {
proc a i {
apply $::b [incr i]
@@ -164,8 +162,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup {
namespace delete ::foo
} -constraints {
testnrelevels
-} -result {{0 3 2 2} 0}
-
+} -result {{0 2 2 2} 0}
test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
@@ -177,7 +174,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace delete ::foo
} -constraints {
testnrelevels
-} -result {{0 3 2 2} 0}
+} -result {{0 2 2 2} 0}
test nre-6.1 {[uplevel] is not recursive} -setup {
proc a i [makebody {uplevel 1 [list a $i]}]
@@ -189,7 +186,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-6.2 {[uplevel] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
@@ -211,7 +207,6 @@ test nre-7.1 {[catch] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
-
test nre-7.2 {[if] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
@@ -222,7 +217,6 @@ test nre-7.2 {[if] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.3 {[while] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
@@ -233,7 +227,6 @@ test nre-7.3 {[while] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.4 {[for] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
@@ -244,7 +237,6 @@ test nre-7.4 {[for] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.5 {[foreach] is not recursive} -setup {
#
# Enable once [foreach] is NR-enabled
@@ -258,7 +250,6 @@ test nre-7.5 {[foreach] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
-
test nre-7.6 {[eval] is not recursive} -setup {
proc a i [makebody {eval [list a $i]}]
} -body {
@@ -269,7 +260,6 @@ test nre-7.6 {[eval] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
-
test nre-7.7 {[eval] is not recursive} -setup {
proc a i [makebody {eval "a $i"}]
} -body {
@@ -280,7 +270,6 @@ test nre-7.7 {[eval] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
-
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
proc foo args {}
foo
@@ -295,18 +284,15 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
} -body {
# if switching to plain eval is not nre aware, this will cause a "cannot
# yield" error
-
list [bar] [bar] [bar]
} -cleanup {
rename bar {}
rename foo {}
} -result {1 2 3}
-
test nre-8.1 {nre and {*}} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the TEBCdataPtr. This crashes on failure.
-
proc inner {} {
set long [lrepeat 1000000 1]
list {*}$long
@@ -321,21 +307,18 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the bcFramePtr. This causes an NRE assertion to fail if it is not
# done properly.
-
proc nop {} {}
proc crash {} {
foreach val [list {*}[lrepeat 100000 x]] {
nop
}
}
-
crash
} -cleanup {
rename nop {}
rename crash {}
}
-
#
# Basic TclOO tests
#
@@ -351,7 +334,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {[self] bar $i}]
@@ -363,7 +345,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.3 {really deep calls in oo - private calls} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {my bar $i}]
@@ -375,7 +356,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.4 {really deep calls in oo - overriding} -setup {
oo::class create foo {
method bar i [makebody {my bar $i}]
@@ -392,7 +372,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.5 {really deep calls in oo - forwards} -setup {
oo::object create foo
set body [makebody {my boo $i}]
@@ -409,7 +388,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup {
testnrelevels
} -result {{0 2 1 1} 0}
-
#
# NASTY BUG found by tcllib's interp package
#
generated by cgit v0.12 at 2024-11-05 10:11:06 (GMT)