summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c156
-rw-r--r--generic/tclCompCmds.c39
-rw-r--r--generic/tclCompile.c134
-rw-r--r--generic/tclCompile.h3
-rw-r--r--generic/tclExecute.c12
-rw-r--r--generic/tclInt.h4
6 files changed, 198 insertions, 150 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b39d346..bf0639e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -185,11 +185,16 @@ typedef struct {
Tcl_ObjCmdProc *objProc; /* Object-based function for command. */
CompileProc *compileProc; /* Function called to compile command. */
Tcl_ObjCmdProc *nreProc; /* NR-based function for command */
- int isSafe; /* If non-zero, command will be present in
- * safe interpreter. Otherwise it will be
- * hidden. */
+ int flags; /* Various flag bits, as defined below. */
} CmdInfo;
+#define CMD_IS_SAFE 1 /* Whether this command is part of the set of
+ * commands present by default in a safe
+ * interpreter. */
+/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle
+ * expansion for itself rather than needing the generic layer to take care of
+ * it for it. Defined in tclInt.h. */
+
/*
* The built-in commands, and the functions that implement them:
*/
@@ -199,95 +204,95 @@ static const CmdInfo builtInCmds[] = {
* Commands in the generic core.
*/
- {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1},
- {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1},
- {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1},
+ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
+ {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
+ {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
#ifndef EXCLUDE_OBSOLETE_COMMANDS
- {"case", Tcl_CaseObjCmd, NULL, NULL, 1},
+ {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
- {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1},
- {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1},
- {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1},
- {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1},
- {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1},
- {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1},
- {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
- {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
- {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
- {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1},
- {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1},
- {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1},
- {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1},
- {"join", Tcl_JoinObjCmd, NULL, NULL, 1},
- {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1},
- {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1},
- {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1},
- {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1},
- {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1},
- {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1},
- {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1},
- {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1},
- {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1},
- {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1},
- {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1},
- {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1},
- {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1},
- {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1},
- {"package", Tcl_PackageObjCmd, NULL, NULL, 1},
- {"proc", Tcl_ProcObjCmd, NULL, NULL, 1},
- {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1},
- {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1},
- {"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
- {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
- {"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
- {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1},
- {"split", Tcl_SplitObjCmd, NULL, NULL, 1},
- {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1},
- {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1},
- {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1},
- {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1},
- {"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
- {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1},
- {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1},
- {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
- {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
- {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
- {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1},
- {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1},
- {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1},
+ {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
+ {"concat", Tcl_ConcatObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
+ {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
+ {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
+ {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE},
+ {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE},
+ {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE},
+ {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE},
+ {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE},
+ {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE},
+ {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE},
+ {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE},
+ {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
+ {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
+ {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
+ {"linsert", Tcl_LinsertObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
+ {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
+ {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
+ {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
+ {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
+ {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
+ {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
+ {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
+ {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE},
+ {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE},
+ {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE},
+ {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE},
+ {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE},
+ {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE},
+ {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE},
+ {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE},
+ {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE},
+ {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE},
+ {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE},
+ {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE},
+ {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE},
+ {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
*/
- {"after", Tcl_AfterObjCmd, NULL, NULL, 1},
+ {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE},
{"cd", Tcl_CdObjCmd, NULL, NULL, 0},
- {"close", Tcl_CloseObjCmd, NULL, NULL, 1},
- {"eof", Tcl_EofObjCmd, NULL, NULL, 1},
+ {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE},
{"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0},
{"exec", Tcl_ExecObjCmd, NULL, NULL, 0},
{"exit", Tcl_ExitObjCmd, NULL, NULL, 0},
- {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1},
+ {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE},
{"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0},
- {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1},
- {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1},
- {"flush", Tcl_FlushObjCmd, NULL, NULL, 1},
- {"gets", Tcl_GetsObjCmd, NULL, NULL, 1},
+ {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE},
{"glob", Tcl_GlobObjCmd, NULL, NULL, 0},
{"load", Tcl_LoadObjCmd, NULL, NULL, 0},
{"open", Tcl_OpenObjCmd, NULL, NULL, 0},
- {"pid", Tcl_PidObjCmd, NULL, NULL, 1},
- {"puts", Tcl_PutsObjCmd, NULL, NULL, 1},
+ {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE},
{"pwd", Tcl_PwdObjCmd, NULL, NULL, 0},
- {"read", Tcl_ReadObjCmd, NULL, NULL, 1},
- {"seek", Tcl_SeekObjCmd, NULL, NULL, 1},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE},
{"socket", Tcl_SocketObjCmd, NULL, NULL, 0},
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
- {"tell", Tcl_TellObjCmd, NULL, NULL, 1},
- {"time", Tcl_TimeObjCmd, NULL, NULL, 1},
+ {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
- {"update", Tcl_UpdateObjCmd, NULL, NULL, 1},
- {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1},
+ {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
{NULL, NULL, NULL, NULL, 0}
};
@@ -768,6 +773,9 @@ Tcl_CreateInterp(void)
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
cmdPtr->flags = 0;
+ if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) {
+ cmdPtr->flags |= CMD_COMPILES_EXPANDED;
+ }
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
cmdPtr->nreProc = cmdInfoPtr->nreProc;
@@ -1000,7 +1008,7 @@ TclHideUnsafeCommands(
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
- if (!cmdInfoPtr->isSafe) {
+ if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c2495bd..a5678bf 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4466,7 +4466,7 @@ TclCompileListCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *valueTokenPtr;
- int i, numWords;
+ int i, numWords, concat, build;
Tcl_Obj *listObj, *objPtr;
if (parsePtr->numWords == 1) {
@@ -4521,11 +4521,46 @@ TclCompileListCmd(
numWords = parsePtr->numWords;
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ concat = build = 0;
for (i = 1; i < numWords; i++) {
+ if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) {
+ TclEmitInstInt4( INST_LIST, build, envPtr);
+ if (concat) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
+ build = 0;
+ concat = 1;
+ }
CompileWord(envPtr, valueTokenPtr, interp, i);
+ if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ if (concat) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ } else {
+ concat = 1;
+ }
+ } else {
+ build++;
+ }
valueTokenPtr = TokenAfter(valueTokenPtr);
}
- TclEmitInstInt4( INST_LIST, numWords - 1, envPtr);
+ if (build > 0) {
+ TclEmitInstInt4( INST_LIST, build, envPtr);
+ if (concat) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
+ }
+
+ /*
+ * If there was just one expanded word, we must ensure that it is a list
+ * at this point. We use an [lrange ... 0 end] for this (instead of
+ * [llength], as with literals) as we must drop any string representation
+ * that might be hanging around.
+ */
+
+ if (concat && numWords == 2) {
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( -2, envPtr);
+ }
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 7f6b7d4..1572576 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -280,12 +280,11 @@ const InstructionDesc const tclInstructionTable[] = {
/* Binary exponentiation operator: push (stknext ** stktop) */
/*
- * NOTE: the stack effects of expandStkTop, invokeExpanded and
- * listExpanded are wrong - but it cannot be done right at compile time,
- * the stack effect is only known at run time. The value for both
- * invokeExpanded and listExpanded are estimated better at compile time.
- * See the comments further down in this file, where INST_INVOKE_EXPANDED
- * and INST_LIST_EXPANDED are emitted.
+ * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong -
+ * but it cannot be done right at compile time, the stack effect is only
+ * known at run time. The value for invokeExpanded is estimated better at
+ * compile time. See the comments further down in this file, where
+ * INST_INVOKE_EXPANDED is emitted.
*/
{"expandStart", 1, 0, 0, {OPERAND_NONE}},
/* Start of command with {*} (expanded) arguments */
@@ -539,8 +538,6 @@ const InstructionDesc const tclInstructionTable[] = {
/* Concatenates the two lists at the top of the stack into a single
* list and pushes that resulting list onto the stack.
* Stack: ... list1 list2 => ... [lconcat list1 list2] */
- {"listExpanded", 1, 0, 0, {OPERAND_NONE}},
- /* Construct a list from the words marked by the last 'expandStart' */
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -559,6 +556,8 @@ static void EnterCmdExtentData(CompileEnv *envPtr,
int cmdNumber, int numSrcBytes, int numCodeBytes);
static void EnterCmdStartData(CompileEnv *envPtr,
int cmdNumber, int srcOffset, int codeOffset);
+static Command * FindCommandFromToken(Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, Tcl_Namespace *namespacePtr);
static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
@@ -1775,6 +1774,49 @@ TclWordKnownAtCompileTime(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * FindCommandFromToken --
+ *
+ * A simple helper that looks up a command's compiler from its token.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static Command *
+FindCommandFromToken(
+ Tcl_Interp *interp,
+ Tcl_Token *tokenPtr,
+ Tcl_Namespace *namespacePtr)
+{
+ Tcl_DString ds;
+ Command *cmdPtr;
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ 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),
+ namespacePtr, /*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 --
@@ -1816,7 +1858,6 @@ TclCompileScript(
Command *cmdPtr;
Tcl_Token *tokenPtr;
int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex;
- Tcl_DString ds;
/* TIP #280 */
ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
int *wlines, wlineat, cmdLine, *clNext;
@@ -1826,8 +1867,6 @@ TclCompileScript(
Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
}
- Tcl_DStringInit(&ds);
-
if (numBytes < 0) {
numBytes = strlen(script);
}
@@ -1877,15 +1916,9 @@ TclCompileScript(
parsePtr->commandStart - envPtr->source);
if (parsePtr->numWords > 0) {
- int expand = 0; /* Set if there are dynamic expansions to
+ int expand = 0; /* Set to the relevant expansion instruction
+ * if there are dynamic expansions to
* handle */
- int expandIgnoredWords = 0;
- /* The number of *apparent* words that we are
- * generating code from directly during
- * expansion processing. For [list {*}blah]
- * expansion, we set this to one because we
- * ignore the first word and generate code
- * directly. */
/*
* If not the first command, pop the previous command's result
@@ -1943,6 +1976,22 @@ TclCompileScript(
}
}
+ /*
+ * 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. (That check is done inside FindCommandFromToken.)
+ * This is as it should be.
+ */
+
+ if (expand) {
+ cmdPtr = FindCommandFromToken(interp, parsePtr->tokenPtr,
+ (Tcl_Namespace *) cmdNsPtr);
+ if (cmdPtr && (cmdPtr->flags & CMD_COMPILES_EXPANDED)) {
+ expand = 0;
+ }
+ }
+
envPtr->numCommands++;
currCmdIndex = envPtr->numCommands - 1;
lastTopLevelCmdIndex = currCmdIndex;
@@ -1991,7 +2040,7 @@ TclCompileScript(
TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
- if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ if (expand && tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
TclEmitInstInt4(INST_EXPAND_STKTOP,
envPtr->currStackDepth, envPtr);
}
@@ -2006,24 +2055,10 @@ TclCompileScript(
*/
if ((wordIdx == 0) && !expand) {
- /*
- * 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.
- */
-
- TclDStringClear(&ds);
- TclDStringAppendToken(&ds, &tokenPtr[1]);
-
- cmdPtr = (Command *) Tcl_FindCommand(interp,
- Tcl_DStringValue(&ds),
- (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
+ cmdPtr = FindCommandFromToken(interp, tokenPtr,
+ (Tcl_Namespace *) cmdNsPtr);
if ((cmdPtr != NULL)
- && (cmdPtr->compileProc != NULL)
- && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
- && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
int code, savedNumCmds = envPtr->numCommands;
unsigned savedCodeNext =
@@ -2148,26 +2183,6 @@ TclCompileScript(
TclFetchLiteral(envPtr, objIndex), cmdPtr);
}
} else {
- if (wordIdx == 0 && expand) {
- TclDStringClear(&ds);
- TclDStringAppendToken(&ds, &tokenPtr[1]);
- cmdPtr = (Command *) Tcl_FindCommand(interp,
- Tcl_DStringValue(&ds),
- (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
- if ((cmdPtr != NULL) &&
- (cmdPtr->compileProc == TclCompileListCmd)) {
- /*
- * Special case! [list] command can be expanded
- * directly provided the first word is not the
- * expanded one.
- */
-
- expand = INST_LIST_EXPANDED;
- expandIgnoredWords = 1;
- continue;
- }
- }
-
/*
* Simple argument word of a command. We reach this if and
* only if the command word was not compiled for whatever
@@ -2211,12 +2226,12 @@ TclCompileScript(
* is being prepared and run, INST_EXPAND_STKTOP is not
* stack-neutral in general.
*
- * The opcodes that may be issued here (both assumed to be
- * non-zero) are INST_INVOKE_EXPANDED and INST_LIST_EXPANDED.
+ * The opcode that may be issued here (assumed to be non-zero)
+ * is INST_INVOKE_EXPANDED.
*/
TclEmitOpcode(expand, envPtr);
- TclAdjustStackDepth(1 + expandIgnoredWords - wordIdx, envPtr);
+ TclAdjustStackDepth(1 - wordIdx, envPtr);
} else if (wordIdx > 0) {
/*
* Save PC -> command map for the TclArgumentBC* functions.
@@ -2292,7 +2307,6 @@ TclCompileScript(
envPtr->numSrcBytes = p - script;
TclStackFree(interp, parsePtr);
- Tcl_DStringFree(&ds);
}
/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c68d3ec..bf00df9 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -716,10 +716,9 @@ typedef struct ByteCode {
#define INST_INVOKE_REPLACE 163
#define INST_LIST_CONCAT 164
-#define INST_LIST_EXPANDED 165
/* The last opcode */
-#define LAST_INST_OPCODE 165
+#define LAST_INST_OPCODE 164
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f994ba5..c7817f8 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4437,18 +4437,6 @@ TEBCresume(
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
- case INST_LIST_EXPANDED:
- CLANG_ASSERT(auxObjList);
- objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
- POP_TAUX_OBJ();
- objResultPtr = Tcl_NewListObj(objc, &OBJ_AT_DEPTH(objc-1));
- TRACE_WITH_OBJ(("(%u) => ", objc), objResultPtr);
- while (objc--) {
- valuePtr = POP_OBJECT();
- TclDecrRefCount(valuePtr);
- }
- NEXT_INST_F(1, 0, 1);
-
case INST_LIST_LENGTH:
valuePtr = OBJ_AT_TOS;
if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5b113bf..9e1ba09 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1681,6 +1681,9 @@ typedef struct Command {
* CMD_HAS_EXEC_TRACES - 1 means that this command has at least one
* execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
+ * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that
+ * can handle expansion (provided it is not the
+ * first word).
* TCL_TRACE_RENAME - A rename trace is in progress. Further
* recursive renames will not be traced.
* TCL_TRACE_DELETE - A delete trace is in progress. Further
@@ -1691,6 +1694,7 @@ typedef struct Command {
#define CMD_IS_DELETED 0x1
#define CMD_TRACE_ACTIVE 0x2
#define CMD_HAS_EXEC_TRACES 0x4
+#define CMD_COMPILES_EXPANDED 0x8
/*
*----------------------------------------------------------------
generated by cgit v0.12 at 2024-11-06 19:05:49 (GMT)