summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2013-08-14 18:00:45 (GMT)
committerdgp <dgp@users.sourceforge.net>2013-08-14 18:00:45 (GMT)
commita733cde27c904a40aae56e93c7daa369e2a4d045 (patch)
tree77fdf9d45381002ae272a660dd3090c4d9459dc5 /generic
parent133a3b34b7419b202d6588f44871ea67176a5064 (diff)
parent2b3657769b1d0b9ae6e10113b1d3c038b4967899 (diff)
downloadtcl-a733cde27c904a40aae56e93c7daa369e2a4d045.zip
tcl-a733cde27c904a40aae56e93c7daa369e2a4d045.tar.gz
tcl-a733cde27c904a40aae56e93c7daa369e2a4d045.tar.bz2
merge trunk
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_locale.c5
-rw-r--r--generic/regc_nfa.c2
-rw-r--r--generic/regexec.c7
-rw-r--r--generic/regguts.h6
-rw-r--r--generic/tcl.h12
-rw-r--r--generic/tclAssembly.c79
-rw-r--r--generic/tclBasic.c578
-rw-r--r--generic/tclCmdAH.c7
-rw-r--r--generic/tclCmdIL.c47
-rw-r--r--generic/tclCmdMZ.c6
-rw-r--r--generic/tclCompCmds.c3611
-rw-r--r--generic/tclCompCmdsGR.c2896
-rw-r--r--generic/tclCompCmdsSZ.c1095
-rw-r--r--generic/tclCompExpr.c4
-rw-r--r--generic/tclCompile.c1333
-rw-r--r--generic/tclCompile.h233
-rw-r--r--generic/tclConfig.c107
-rw-r--r--generic/tclDate.c2
-rw-r--r--generic/tclDecls.h83
-rw-r--r--generic/tclEnsemble.c195
-rw-r--r--generic/tclEvent.c9
-rw-r--r--generic/tclExecute.c336
-rw-r--r--generic/tclIOSock.c4
-rw-r--r--generic/tclIOUtil.c3
-rw-r--r--generic/tclInt.h113
-rw-r--r--generic/tclIntPlatDecls.h2
-rw-r--r--generic/tclMain.c4
-rw-r--r--generic/tclOODefineCmds.c49
-rw-r--r--generic/tclOOMethod.c8
-rw-r--r--generic/tclObj.c72
-rw-r--r--generic/tclOptimize.c428
-rw-r--r--generic/tclPanic.c4
-rw-r--r--generic/tclParse.c15
-rw-r--r--generic/tclProc.c10
-rw-r--r--generic/tclResult.c2
-rwxr-xr-xgeneric/tclStrToD.c4
-rw-r--r--generic/tclStubInit.c86
-rw-r--r--generic/tclTest.c8
-rw-r--r--generic/tclThreadTest.c18
-rw-r--r--generic/tclTimer.c2
-rw-r--r--generic/tclUtf.c44
41 files changed, 6212 insertions, 5317 deletions
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index f3db471..e79dff8 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -259,8 +259,9 @@ static const chr alphaCharTable[] = {
*/
static const crange controlRangeTable[] = {
- {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e},
- {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb}
+ {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f},
+ {0x202a, 0x202e}, {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff},
+ {0xfff9, 0xfffb}
#if TCL_UTF_MAX > 4
,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd}
#endif
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/regguts.h b/generic/regguts.h
index b4944dc..b478e4c 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -341,12 +341,12 @@ struct subre {
#define CAP 010 /* capturing parens below */
#define BACKR 020 /* back reference below */
#define INUSE 0100 /* in use in final tree */
-#define LOCAL 03 /* bits which may not propagate up */
+#define NOPROP 03 /* bits which may not propagate up */
#define LMIX(f) ((f)<<2) /* LONGER -> MIXED */
#define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */
-#define UP(f) (((f)&~LOCAL) | (LMIX(f) & SMIX(f) & MIXED))
+#define UP(f) (((f)&~NOPROP) | (LMIX(f) & SMIX(f) & MIXED))
#define MESSY(f) ((f)&(MIXED|CAP|BACKR))
-#define PREF(f) ((f)&LOCAL)
+#define PREF(f) ((f)&NOPROP)
#define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2))
#define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2))
short retry; /* index into retry memory */
diff --git a/generic/tcl.h b/generic/tcl.h
index 4de18f0..a833218 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -329,10 +329,12 @@ typedef long LONG;
* in ANSI C; maps them to type "char *" in non-ANSI systems.
*/
-#ifndef NO_VOID
-# define VOID void
-#else
-# define VOID char
+#ifndef __VXWORKS__
+# ifndef NO_VOID
+# define VOID void
+# else
+# define VOID char
+# endif
#endif
/*
@@ -2415,7 +2417,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
*/
#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
- (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+ ((Tcl_CreateInterp)()))
EXTERN void Tcl_MainEx(int argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 5786975..100e9ef 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -20,7 +20,7 @@
*- break and continue - if exception ranges can be sorted out.
*- foreach_start4, foreach_step4
*- returnImm, returnStk
- *- expandStart, expandStkTop, invokeExpanded
+ *- expandStart, expandStkTop, invokeExpanded, expandDrop
*- dictFirst, dictNext, dictDone
*- dictUpdateStart, dictUpdateEnd
*- jumpTable testing
@@ -324,29 +324,6 @@ static const Tcl_ObjType assembleCodeType = {
};
/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
-
-/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
@@ -410,9 +387,8 @@ static const TalInstDesc TalInstructionTable[] = {
{"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1},
{"incrImm", ASSEM_LVT1_SINT1,
INST_INCR_SCALAR1_IMM, 0, 1},
- {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
- {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
- 1, 1},
+ {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1},
+ {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1},
{"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1},
{"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
@@ -437,6 +413,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"lindexMulti", ASSEM_LINDEX_MULTI,
INST_LIST_INDEX_MULTI, INT_MIN,1},
{"list", ASSEM_LIST, INST_LIST, INT_MIN,1},
+ {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1},
{"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1},
{"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1},
{"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1},
@@ -447,7 +424,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8
| INST_LOAD_ARRAY4), 1, 1},
{"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1},
- {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1},
+ {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1},
{"lor", ASSEM_1BYTE, INST_LOR, 2, 1},
{"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
{"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
@@ -474,7 +451,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8
| INST_STORE_ARRAY4), 2, 1},
{"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1},
- {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1},
+ {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
@@ -673,7 +650,7 @@ BBEmitOpcode(
}
TclEmitInt1(op, envPtr);
- envPtr->atCmdStart = ((op) == INST_START_CMD);
+ TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
@@ -734,7 +711,7 @@ BBEmitInst1or4(
} else {
TclEmitInt4(param, envPtr);
}
- envPtr->atCmdStart = ((op) == INST_START_CMD);
+ TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
@@ -953,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.
*/
@@ -966,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;
}
/*
@@ -1008,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 */
@@ -1023,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.
@@ -1035,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;
@@ -1055,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.
*/
@@ -1130,7 +1125,7 @@ NewAssemblyEnv(
assemEnvPtr->envPtr = envPtr;
assemEnvPtr->parsePtr = parsePtr;
- assemEnvPtr->cmdLine = envPtr->line;
+ assemEnvPtr->cmdLine = 1;
assemEnvPtr->clNext = envPtr->clNext;
/*
@@ -3052,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 82ce385..fc238ce 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -127,8 +127,6 @@ 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;
@@ -149,7 +147,7 @@ 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,
+ Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static Tcl_NRPostProc RewindCoroutineCallback;
static Tcl_NRPostProc TailcallCleanup;
@@ -186,11 +184,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:
*/
@@ -200,95 +203,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}
};
@@ -482,6 +485,18 @@ Tcl_CreateInterp(void)
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
+#if defined(_WIN32) && !defined(_WIN64)
+ if (sizeof(time_t) != 4) {
+ /*NOTREACHED*/
+ Tcl_Panic("<time.h> is not compatible with MSVC");
+ }
+ if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
+ || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
+ /*NOTREACHED*/
+ Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
+ }
+#endif
+
if (cancelTableInitialized == 0) {
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 0) {
@@ -769,6 +784,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;
@@ -1001,7 +1019,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);
}
}
@@ -1590,8 +1608,6 @@ DeleteInterpProc(
ckfree(eclPtr->loc);
}
- Tcl_DeleteHashTable(&eclPtr->litInfo);
-
ckfree(eclPtr);
Tcl_DeleteHashEntry(hPtr);
}
@@ -2157,12 +2173,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
@@ -2230,21 +2242,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.
@@ -2392,8 +2390,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.
*
*----------------------------------------------------------------------
*/
@@ -3336,66 +3334,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
@@ -4248,7 +4186,9 @@ TclNREvalObjv(
* necessary.
*/
- result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr);
+ result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame(
+ flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
+ objc, objv), objc, objv, lookupNsPtr);
if (!cmdPtr) {
return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
}
@@ -4662,6 +4602,7 @@ static int
TEOV_RunEnterTraces(
Tcl_Interp *interp,
Command **cmdPtrPtr,
+ Tcl_Obj *commandPtr,
int objc,
Tcl_Obj *const objv[],
Namespace *lookupNsPtr)
@@ -4673,9 +4614,8 @@ TEOV_RunEnterTraces(
int newEpoch;
const char *command;
int length;
- Tcl_Obj *commandPtr;
- commandPtr = GetCommandSource(iPtr, objc, objv, 1);
+ Tcl_IncrRefCount(commandPtr);
command = Tcl_GetStringFromObj(commandPtr, &length);
/*
@@ -4708,13 +4648,13 @@ TEOV_RunEnterTraces(
*cmdPtrPtr = cmdPtr;
}
- if (cmdPtr) {
+ if (cmdPtr && (traceCode == TCL_OK)) {
/*
* Command was found: push a record to schedule the leave traces.
*/
- TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode),
- commandPtr, cmdPtr, NULL);
+ TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
+ commandPtr, cmdPtr, objv);
cmdPtr->refCount++;
} else {
Tcl_DecrRefCount(commandPtr);
@@ -4729,20 +4669,18 @@ 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];
+ Tcl_Obj **objv = data[3];
- command = Tcl_GetStringFromObj(commandPtr, &length);
- if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) {
- Tcl_Panic("Who messed with commandPtr?");
- }
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
+ int length;
+ const char *command = Tcl_GetStringFromObj(commandPtr, &length);
+
+ if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
@@ -4998,31 +4936,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.
*/
@@ -5065,7 +4994,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;
}
/*
@@ -5231,23 +5162,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;
@@ -5321,6 +5257,7 @@ TclEvalEx(
Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
commandLength);
}
+ posterror:
iPtr->flags &= ~ERR_ALREADY_LOGGED;
/*
@@ -5595,76 +5532,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));
+
+ 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.
+ */
- Tcl_SetHashValue(hPtr, cfwPtr);
+ cfwPtr->prevPtr = Tcl_GetHashValue(hPtr);
}
- } /* for */
- cfPtr->litarg = lastPtr;
- } /* if */
+ Tcl_SetHashValue(hPtr, cfwPtr);
+ }
+ } /* for */
+
+ cfPtr->litarg = lastPtr;
}
/*
@@ -5874,6 +5823,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
@@ -5942,13 +5896,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
@@ -5956,11 +5909,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).
*/
/*
@@ -5969,13 +5917,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) {
/*
@@ -5998,22 +5946,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);
@@ -6053,14 +6004,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;
@@ -6084,92 +6027,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.
- */
+ assert(invoker == NULL);
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
- } else {
- /*
- * Absolute context to reuse.
- */
-
- 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;
}
}
@@ -6229,6 +6099,7 @@ TEOEx_ListCallback(
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = data[0];
CmdFrame *eoFramePtr = data[1];
+ Tcl_Obj *objPtr = data[2];
/*
* Remove the cmdFrame
@@ -6238,6 +6109,7 @@ TEOEx_ListCallback(
iPtr->cmdFramePtr = eoFramePtr->nextPtr;
TclStackFree(interp, eoFramePtr);
}
+ TclDecrRefCount(objPtr);
TclDecrRefCount(listPtr);
return result;
@@ -7467,7 +7339,7 @@ ExprAbsFunc(
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index eb2a303..f90819a 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -194,8 +194,7 @@ Tcl_CaseObjCmd(
for (i = 0; i < caseObjc; i += 2) {
int patObjc, j;
const char **patObjv;
- const char *pat;
- unsigned char *p;
+ const char *pat, *p;
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
@@ -210,8 +209,8 @@ Tcl_CaseObjCmd(
*/
pat = TclGetString(caseObjv[i]);
- for (p = (unsigned char *) pat; *p != '\0'; p++) {
- if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */
+ for (p = pat; *p != '\0'; p++) {
+ if (TclIsSpaceProc(*p) || (*p == '\\')) {
break;
}
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index c70ba23..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:
@@ -3005,7 +2987,7 @@ Tcl_LsearchObjCmd(
dataType = INTEGER;
break;
case LSEARCH_NOCASE: /* -nocase */
- strCmpFn = strcasecmp;
+ strCmpFn = TclUtfCasecmp;
noCase = 1;
break;
case LSEARCH_NOT: /* -not */
@@ -3400,7 +3382,7 @@ Tcl_LsearchObjCmd(
*/
if (noCase) {
- match = (strcasecmp(bytes, patternBytes) == 0);
+ match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
@@ -3645,7 +3627,8 @@ Tcl_LsortObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- int i, j, index, indices, length, nocase = 0, sortMode, indexc;
+ int i, j, index, indices, length, nocase = 0, indexc;
+ int sortMode = SORTMODE_ASCII;
int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
SortElement *elementArray, *elementPtr;
@@ -3991,7 +3974,7 @@ Tcl_LsortObjCmd(
goto done1;
}
elementArray[i].collationKey.intValue = a;
- } else if (sortInfo.sortMode == SORTMODE_REAL) {
+ } else if (sortMode == SORTMODE_REAL) {
double a;
if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
@@ -4088,7 +4071,7 @@ Tcl_LsortObjCmd(
TclStackFree(interp, elementArray);
done:
- if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ if (sortMode == SORTMODE_COMMAND) {
TclDecrRefCount(sortInfo.compareCmdPtr);
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
@@ -4233,7 +4216,7 @@ SortCompare(
order = strcmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
- order = strcasecmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index f9f2a28..5087fbb 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1565,7 +1565,7 @@ StringIsCmd(
/* TODO */
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType) ||
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
(objPtr->typePtr == &tclWideIntType) ||
#endif
(objPtr->typePtr == &tclBignumType)) {
@@ -1602,7 +1602,7 @@ StringIsCmd(
goto failedIntParse;
case STR_IS_ENTIER:
if ((objPtr->typePtr == &tclIntType) ||
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
(objPtr->typePtr == &tclWideIntType) ||
#endif
(objPtr->typePtr == &tclBignumType)) {
@@ -3527,7 +3527,7 @@ TclNRSwitchObjCmd(
i++;
goto finishedOptions;
case OPT_NOCASE:
- strCmpFn = strcasecmp;
+ strCmpFn = TclUtfCasecmp;
noCase = 1;
break;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 40348fa..8edb2d9 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -7,7 +7,7 @@
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2006 by Donal K. Fellows.
+ * Copyright (c) 2004-2013 by Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,16 +31,6 @@ static void FreeForeachInfo(ClientData clientData);
static void PrintForeachInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
-static void CompileReturnInternal(CompileEnv *envPtr,
- unsigned char op, int code, int level,
- Tcl_Obj *returnOpts);
-static int IndexTailVarIfKnown(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-static int PushVarName(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr,
- int flags, int *localIndexPtr,
- int *simpleVarNamePtr, int *isScalarPtr,
- int line, int *clNext);
static int CompileEachloopCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr, int collect);
@@ -48,67 +38,6 @@ static int CompileDictEachCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr, int collect);
-
-/*
- * Macro that encapsulates an efficiency trick that avoids a function call for
- * the simplest of compiles. The ANSI C "prototype" for this macro is:
- *
- * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp, int word);
- */
-
-#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
- (tokenPtr)[1].size), (envPtr)); \
- } else { \
- envPtr->line = mapPtr->loc[eclIndex].line[word]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr)); \
- }
-
-/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
- PushVarName(i,v,e,f,l,s,sc, \
- mapPtr->loc[eclIndex].line[(word)], \
- mapPtr->loc[eclIndex].next[(word)])
-
-/*
- * Often want to issue one of two versions of an instruction based on whether
- * the argument will fit in a single byte or not. This makes it much clearer.
- */
-
-#define Emit14Inst(nm,idx,envPtr) \
- if (idx <= 255) { \
- TclEmitInstInt1(nm##1,idx,envPtr); \
- } else { \
- TclEmitInstInt4(nm##4,idx,envPtr); \
- }
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
-#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
-
/*
* The structures below define the AuxData types defined in this file.
*/
@@ -155,9 +84,10 @@ TclCompileAppendCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords;
+ int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
+ /* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
@@ -169,10 +99,11 @@ TclCompileAppendCmd(
return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (numWords > 3) {
/*
- * APPEND instructions currently only handle one value.
+ * APPEND instructions currently only handle one value, but we can
+ * handle some multi-value cases by stringing them together.
*/
- return TCL_ERROR;
+ goto appendMultiple;
}
/*
@@ -186,7 +117,7 @@ TclCompileAppendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called, so
@@ -194,16 +125,13 @@ TclCompileAppendCmd(
* each argument.
*/
- if (numWords > 2) {
valueTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
/*
* Emit instructions to set/get the variable.
*/
- if (simpleVarName) {
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_STK, envPtr);
@@ -217,8 +145,38 @@ TclCompileAppendCmd(
Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
}
}
- } else {
- TclEmitOpcode(INST_APPEND_STK, envPtr);
+
+ return TCL_OK;
+
+ appendMultiple:
+ /*
+ * Can only handle the case where we are appending to a local scalar when
+ * there are multiple values to append. Fortunately, this is common.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar || localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Definitely appending to a local scalar; generate the words and append
+ * them.
+ */
+
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ for (i = 2 ; i < numWords ; i++) {
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr);
+ for (i = 2 ; i < numWords ;) {
+ Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr);
+ if (++i < numWords) {
+ TclEmitOpcode(INST_POP, envPtr);
+ }
}
return TCL_OK;
@@ -253,7 +211,7 @@ TclCompileArrayExistsCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
- int simpleVarName, isScalar, localIndex;
+ int isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
@@ -261,7 +219,7 @@ TclCompileArrayExistsCmd(
tokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
@@ -285,9 +243,11 @@ TclCompileArraySetCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *dataTokenPtr;
- int simpleVarName, isScalar, localIndex;
+ int isScalar, localIndex, code = TCL_OK;
+ int isDataLiteral, isDataValid, isDataEven, len;
int dataVar, iterVar, keyVar, valVar, infoIndex;
- int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+ int back, fwd, offsetBack, offsetFwd;
+ Tcl_Obj *literalObj;
ForeachInfo *infoPtr;
if (parsePtr->numWords != 3) {
@@ -295,20 +255,47 @@ TclCompileArraySetCmd(
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
- &localIndex, &simpleVarName, &isScalar, 1);
dataTokenPtr = TokenAfter(varTokenPtr);
- if (!isScalar) {
- return TCL_ERROR;
+ literalObj = Tcl_NewObj();
+ isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
+ isDataValid = (isDataLiteral
+ && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
+ isDataEven = (isDataValid && (len & 1) == 0);
+
+ /*
+ * Special case: literal odd-length argument is always an error.
+ */
+
+ if (isDataValid && !isDataEven) {
+ PushStringLiteral(envPtr, "list must have an even number of elements");
+ PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+ TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr);
+ TclEmitInt4( 0, envPtr);
+ goto done;
}
/*
+ * Except for the special "ensure array" case below, when we're not in
+ * a proc, we cannot do a better compile than generic.
+ */
+
+ if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) {
+ code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ goto done;
+ }
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ /*
* Special case: literal empty value argument is just an "ensure array"
* operation.
*/
- if (dataTokenPtr->type == TCL_TOKEN_SIMPLE_WORD
- && dataTokenPtr[1].size == 0) {
+ if (isDataEven && len == 0) {
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
@@ -317,50 +304,24 @@ TclCompileArraySetCmd(
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr);
- savedStackDepth = envPtr->currStackDepth;
TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
- envPtr->currStackDepth = savedStackDepth;
+ /* Each branch decrements stack depth, but we only take one. */
+ TclAdjustStackDepth(1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
+ PushStringLiteral(envPtr, "");
+ goto done;
}
/*
* Prepare for the internal foreach.
*/
- dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
-
- if (dataVar < 0) {
- /*
- * Right number of arguments, but not compilable as we can't allocate
- * (unnamed) local variables to manage the internal iteration.
- */
-
- Tcl_Obj *objPtr = Tcl_NewObj();
- char *bytes;
- int length, cmdLit;
-
- Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
- TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
- TclEmitPush(cmdLit, envPtr);
- TclDecrRefCount(objPtr);
- if (localIndex >= 0) {
- CompileWord(envPtr, varTokenPtr, interp, 1);
- } else {
- TclEmitInstInt4(INST_REVERSE, 2, envPtr);
- }
- CompileWord(envPtr, dataTokenPtr, interp, 2);
- TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr);
- return TCL_OK;
- }
+ dataVar = AnonymousLocal(envPtr);
+ iterVar = AnonymousLocal(envPtr);
+ keyVar = AnonymousLocal(envPtr);
+ valVar = AnonymousLocal(envPtr);
infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
@@ -377,22 +338,28 @@ TclCompileArraySetCmd(
*/
CompileWord(envPtr, dataTokenPtr, interp, 2);
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- PushLiteral(envPtr, "1", 1);
- TclEmitOpcode( INST_BITAND, envPtr);
- offsetFwd = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
- PushLiteral(envPtr, "list must have an even number of elements",
- strlen("list must have an even number of elements"));
- PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
- strlen("-errorCode {TCL ARGUMENT FORMAT}"));
- TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr);
- TclEmitInt4( 0, envPtr);
- envPtr->currStackDepth = savedStackDepth;
- fwd = CurrentOffset(envPtr) - offsetFwd;
- TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ if (!isDataLiteral || !isDataValid) {
+ /*
+ * Only need this safety check if we're handling a non-literal or list
+ * containing an invalid literal; with valid list literals, we've
+ * already checked (worth it because literals are a very common
+ * use-case with [array set]).
+ */
+
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ PushStringLiteral(envPtr, "1");
+ TclEmitOpcode( INST_BITAND, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
+ PushStringLiteral(envPtr, "list must have an even number of elements");
+ PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+ TclEmitInstInt4(INST_RETURN_IMM, 1, envPtr);
+ TclEmitInt4( 0, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ }
Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
@@ -405,7 +372,6 @@ TclCompileArraySetCmd(
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
@@ -414,7 +380,6 @@ TclCompileArraySetCmd(
TclEmitInstInt1(INST_JUMP1, back, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- envPtr->currStackDepth = savedStackDepth;
} else {
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
@@ -426,7 +391,6 @@ TclCompileArraySetCmd(
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
TclEmitOpcode( INST_DUP, envPtr);
Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
@@ -436,13 +400,16 @@ TclCompileArraySetCmd(
TclEmitInstInt1(INST_JUMP1, back, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- envPtr->currStackDepth = savedStackDepth;
TclEmitOpcode( INST_POP, envPtr);
}
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( dataVar, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
+ if (!isDataLiteral) {
+ TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( dataVar, envPtr);
+ }
+ PushStringLiteral(envPtr, "");
+ done:
+ Tcl_DecrRefCount(literalObj);
+ return code;
}
int
@@ -456,14 +423,14 @@ TclCompileArrayUnsetCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
- int simpleVarName, isScalar, localIndex, savedStackDepth;
+ int isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
@@ -477,13 +444,13 @@ TclCompileArrayUnsetCmd(
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr);
- savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
- envPtr->currStackDepth = savedStackDepth;
+ /* Each branch decrements stack depth, but we only take one. */
+ TclAdjustStackDepth(1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -514,16 +481,37 @@ TclCompileBreakCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxPtr;
+
if (parsePtr->numWords != 1) {
return TCL_ERROR;
}
/*
- * Emit a break instruction.
+ * Find the innermost exception range that contains this command.
*/
- TclEmitOpcode(INST_BREAK, envPtr);
- PushLiteral(envPtr, "", 0); /* Evil hack! */
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ /*
+ * Found the target! No need for a nasty INST_BREAK here.
+ */
+
+ TclCleanupStackForBreakContinue(envPtr, auxPtr);
+ TclAddLoopBreakFixup(envPtr, auxPtr);
+ TclAdjustStackDepth(1, envPtr);
+ } else {
+ /*
+ * Emit a real break.
+ */
+
+ PushStringLiteral(envPtr, "");
+ TclEmitOpcode(INST_DUP, envPtr);
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_BREAK, envPtr);
+ TclEmitInt4(0, envPtr);
+ }
+
return TCL_OK;
}
@@ -556,10 +544,7 @@ TclCompileCatchCmd(
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
- const char *name;
- int resultIndex, optsIndex, nameChars, range;
- int initStackDepth = envPtr->currStackDepth;
- int savedStackDepth;
+ int resultIndex, optsIndex, range;
DefineLineInformation; /* TIP #280 */
/*
@@ -590,17 +575,7 @@ TclCompileCatchCmd(
if (parsePtr->numWords >= 3) {
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
/* DGP */
- if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
-
- name = resultNameTokenPtr[1].start;
- nameChars = resultNameTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
- resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
+ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
@@ -608,16 +583,7 @@ TclCompileCatchCmd(
/* DKF */
if (parsePtr->numWords == 4) {
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
- if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = optsNameTokenPtr[1].start;
- nameChars = optsNameTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
- optsNameTokenPtr[1].size, /*create*/ 1, envPtr);
+ optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
if (optsIndex < 0) {
return TCL_ERROR;
}
@@ -629,7 +595,7 @@ TclCompileCatchCmd(
* uses.
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
/*
* If the body is a simple word, compile a BEGIN_CATCH instruction,
@@ -644,15 +610,13 @@ TclCompileCatchCmd(
* begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
*/
- SetLineInformation(1);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, cmdTokenPtr, interp);
+ BODY(cmdTokenPtr, 1);
} else {
+ SetLineInformation(1);
CompileTokens(envPtr, cmdTokenPtr, interp);
- savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
TclEmitOpcode( INST_DUP, envPtr);
@@ -672,9 +636,9 @@ TclCompileCatchCmd(
*/
TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "0", 1);
+ PushStringLiteral(envPtr, "0");
TclEmitInstInt1( INST_JUMP1, 3, envPtr);
- envPtr->currStackDepth = savedStackDepth;
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, range, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
ExceptionRangeEnds(envPtr, range);
@@ -694,7 +658,7 @@ TclCompileCatchCmd(
* and jump around the "error case" code.
*/
- PushLiteral(envPtr, "0", 1);
+ PushStringLiteral(envPtr, "0");
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
/* Stack at this point: ?script? <mark> result TCL_OK */
@@ -703,7 +667,7 @@ TclCompileCatchCmd(
* return code.
*/
- envPtr->currStackDepth = savedStackDepth;
+ TclAdjustStackDepth(-2, envPtr);
ExceptionRangeTarget(envPtr, range, catchOffset);
/* Stack at this point: ?script? */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
@@ -778,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;
}
@@ -817,6 +772,9 @@ TclCompileContinueCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxPtr;
+
/*
* There should be no argument after the "continue".
*/
@@ -826,11 +784,30 @@ TclCompileContinueCmd(
}
/*
- * Emit a continue instruction.
+ * See if we can find a valid continueOffset (i.e., not -1) in the
+ * innermost containing exception range.
*/
- TclEmitOpcode(INST_CONTINUE, envPtr);
- PushLiteral(envPtr, "", 0); /* Evil hack! */
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ /*
+ * Found the target! No need for a nasty INST_CONTINUE here.
+ */
+
+ TclCleanupStackForBreakContinue(envPtr, auxPtr);
+ TclAddLoopContinueFixup(envPtr, auxPtr);
+ TclAdjustStackDepth(1, envPtr);
+ } else {
+ /*
+ * Emit a real continue.
+ */
+
+ PushStringLiteral(envPtr, "");
+ TclEmitOpcode(INST_DUP, envPtr);
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_CONTINUE, envPtr);
+ TclEmitInt4(0, envPtr);
+ }
+
return TCL_OK;
}
@@ -862,11 +839,9 @@ TclCompileDictSetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
- int numWords, i;
+ int numWords, i, dictVarIndex;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
- int dictVarIndex, nameChars;
- const char *name;
/*
* There must be at least one argument after the command.
@@ -883,15 +858,7 @@ TclCompileDictSetCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
return TCL_ERROR;
}
@@ -928,8 +895,7 @@ TclCompileDictIncrCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr;
- int dictVarIndex, nameChars, incrAmount;
- const char *name;
+ int dictVarIndex, incrAmount;
/*
* There must be at least two arguments after the command.
@@ -975,15 +941,7 @@ TclCompileDictIncrCmd(
* discover what the index is.
*/
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
@@ -1016,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;
}
@@ -1053,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;
}
@@ -1083,14 +1043,14 @@ TclCompileDictUnsetCmd(
{
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
- int i, dictVarIndex, nameChars;
- const char *name;
+ int i, dictVarIndex;
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
@@ -1102,15 +1062,7 @@ TclCompileDictUnsetCmd(
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- name = tokenPtr[1].start;
- nameChars = tokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
@@ -1201,12 +1153,12 @@ TclCompileDictCreateCmd(
*/
nonConstant:
- worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ worker = AnonymousLocal(envPtr);
if (worker < 0) {
return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
TclEmitOpcode( INST_POP, envPtr);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -1244,8 +1196,9 @@ 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) {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
} else if (parsePtr->numWords == 2) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -1262,11 +1215,11 @@ TclCompileDictMergeCmd(
* command when there's an LVT present.
*/
- workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ workerIndex = AnonymousLocal(envPtr);
if (workerIndex < 0) {
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ infoIndex = AnonymousLocal(envPtr);
/*
* Get the first dictionary and verify that it is so.
@@ -1283,7 +1236,7 @@ TclCompileDictMergeCmd(
* For each of the remaining dictionaries...
*/
- outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
ExceptionRangeStarts(envPtr, outLoop);
for (i=2 ; i<parsePtr->numWords ; i++) {
@@ -1325,6 +1278,7 @@ TclCompileDictMergeCmd(
* subsequent) dicts. This is strictly not necessary, but it is nice.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, outLoop, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
@@ -1383,9 +1337,6 @@ CompileDictEachCmd(
int numVars, endTargetOffset;
int collectVar = -1; /* Index of temp var holding the result
* dict. */
- int savedStackDepth = envPtr->currStackDepth;
- /* Needed because jumps confuse the stack
- * space calculator. */
const char **argv;
Tcl_DString buffer;
@@ -1411,8 +1362,7 @@ CompileDictEachCmd(
*/
if (collect == TCL_EACH_COLLECT) {
- collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
- envPtr);
+ collectVar = AnonymousLocal(envPtr);
if (collectVar < 0) {
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
@@ -1437,18 +1387,9 @@ CompileDictEachCmd(
}
nameChars = strlen(argv[0]);
- if (!TclIsLocalScalar(argv[0], nameChars)) {
- ckfree(argv);
- return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
-
+ keyVarIndex = LocalScalar(argv[0], nameChars, envPtr);
nameChars = strlen(argv[1]);
- if (!TclIsLocalScalar(argv[1], nameChars)) {
- ckfree(argv);
- return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
+ valueVarIndex = LocalScalar(argv[1], nameChars, envPtr);
ckfree(argv);
if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
@@ -1462,7 +1403,7 @@ CompileDictEachCmd(
* (at which point it should also have been finished with).
*/
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ infoIndex = AnonymousLocal(envPtr);
if (infoIndex < 0) {
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
@@ -1475,7 +1416,7 @@ CompileDictEachCmd(
*/
if (collect == TCL_EACH_COLLECT) {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
@@ -1486,19 +1427,20 @@ CompileDictEachCmd(
*/
CompileWord(envPtr, dictTokenPtr, interp, 3);
- TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
- emptyTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
/*
* Now we catch errors from here on so that we can finalize the search
* started by Tcl_DictObjFirst above.
*/
- catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
ExceptionRangeStarts(envPtr, catchRange);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ emptyTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+
/*
* Inside the iteration, write the loop variables.
*/
@@ -1513,15 +1455,14 @@ CompileDictEachCmd(
* Set up the loop exception targets.
*/
- loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
ExceptionRangeStarts(envPtr, loopRange);
/*
* Compile the loop body itself. It should be stack-neutral.
*/
- SetLineInformation(3);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, 3);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
TclEmitInstInt4(INST_OVER, 1, envPtr);
@@ -1549,35 +1490,21 @@ CompileDictEachCmd(
TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
-
- /*
- * Now do the final cleanup for the no-error case (this is where we break
- * out of the loop to) by force-terminating the iteration (if not already
- * terminated), ditching the exception info and jumping to the last
- * instruction for this command. In theory, this could be done using the
- * "finally" clause (next generated) but this is faster.
- */
-
- ExceptionRangeTarget(envPtr, loopRange, breakOffset);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP4, 0, envPtr);
+ TclEmitInstInt1( INST_JUMP1, 0, envPtr);
/*
* Error handler "finally" clause, which force-terminates the iteration
* and rethrows the error.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
if (collect == TCL_EACH_COLLECT) {
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
@@ -1590,14 +1517,17 @@ CompileDictEachCmd(
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
*/
- envPtr->currStackDepth = savedStackDepth + 2;
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
+ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
+ TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement,
+ envPtr->codeStart + endTargetOffset);
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, loopRange);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
/*
* Final stage of the command (normal case) is that we push an empty
@@ -1605,15 +1535,14 @@ CompileDictEachCmd(
* last to promote peephole optimization when it's dropped immediately.
*/
- jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
- TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
- envPtr->codeStart + endTargetOffset);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
return TCL_OK;
}
@@ -1628,10 +1557,8 @@ TclCompileDictUpdateCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- const char *name;
- int i, nameChars, dictIndex, numVars, range, infoIndex;
+ int i, dictIndex, numVars, range, infoIndex;
Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
DictUpdateInfo *duiPtr;
JumpFixup jumpFixup;
@@ -1660,17 +1587,9 @@ TclCompileDictUpdateCmd(
*/
dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- name = dictVarTokenPtr[1].start;
- nameChars = dictVarTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr);
if (dictIndex < 0) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ goto issueFallback;
}
/*
@@ -1681,8 +1600,7 @@ TclCompileDictUpdateCmd(
duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
duiPtr->length = numVars;
- keyTokenPtrs = TclStackAlloc(interp,
- sizeof(Tcl_Token *) * numVars);
+ keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
@@ -1691,37 +1609,21 @@ TclCompileDictUpdateCmd(
*/
keyTokenPtrs[i] = tokenPtr;
-
- /*
- * Variables first need to be checked for sanity.
- */
-
tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- goto failedUpdateInfoAssembly;
- }
- name = tokenPtr[1].start;
- nameChars = tokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- goto failedUpdateInfoAssembly;
- }
/*
- * Stash the index in the auxiliary data.
+ * Stash the index in the auxiliary data (if it is indeed a local
+ * scalar that is resolvable at compile-time).
*/
- duiPtr->varIndices[i] =
- TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr);
if (duiPtr->varIndices[i] < 0) {
goto failedUpdateInfoAssembly;
}
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- failedUpdateInfoAssembly:
- ckfree(duiPtr);
- TclStackFree(interp, keyTokenPtrs);
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ goto failedUpdateInfoAssembly;
}
bodyTokenPtr = tokenPtr;
@@ -1737,16 +1639,13 @@ TclCompileDictUpdateCmd(
}
TclEmitInstInt4( INST_LIST, numVars, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- envPtr->currStackDepth++;
- SetLineInformation(parsePtr->numWords - 1);
- CompileBody(envPtr, bodyTokenPtr, interp);
- envPtr->currStackDepth = savedStackDepth;
+ BODY(bodyTokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -1757,7 +1656,7 @@ TclCompileDictUpdateCmd(
TclEmitOpcode( INST_END_CATCH, envPtr);
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
/*
* Jump around the exceptional termination code.
@@ -1778,7 +1677,7 @@ TclCompileDictUpdateCmd(
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
TclEmitOpcode( INST_RETURN_STK, envPtr);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
@@ -1786,8 +1685,17 @@ TclCompileDictUpdateCmd(
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
- envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
+
+ /*
+ * Clean up after a failure to create the DictUpdateInfo structure.
+ */
+
+ failedUpdateInfoAssembly:
+ ckfree(duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ issueFallback:
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
@@ -1809,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;
}
@@ -1818,19 +1727,9 @@ TclCompileDictAppendCmd(
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- } else {
- register const char *name = tokenPtr[1].start;
- register int nameChars = tokenPtr[1].size;
-
- if (!TclIsLocalScalar(name, nameChars)) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
- if (dictVarIndex < 0) {
- return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
- }
+ dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
+ if (dictVarIndex < 0) {
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
/*
@@ -1865,32 +1764,34 @@ TclCompileDictLappendCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
- int dictVarIndex, nameChars;
- const char *name;
+ int dictVarIndex;
/*
* 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;
}
+ /*
+ * Parse the arguments.
+ */
+
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
keyTokenPtr = TokenAfter(varTokenPtr);
valueTokenPtr = TokenAfter(keyTokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
+
+ /*
+ * Issue the implementation.
+ */
+
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
@@ -1907,10 +1808,9 @@ TclCompileDictWithCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1;
- int bodyIsEmpty = 1;
+ int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath;
+ int dictVar, bodyIsEmpty = 1;
Tcl_Token *varTokenPtr, *tokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
JumpFixup jumpFixup;
const char *ptr, *end;
@@ -1918,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;
}
@@ -1958,11 +1859,7 @@ TclCompileDictWithCmd(
*/
gotPath = (parsePtr->numWords > 3);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD &&
- TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) {
- dictVar = TclFindCompiledLocal(varTokenPtr[1].start,
- varTokenPtr[1].size, 1, envPtr);
- }
+ dictVar = LocalScalarFromToken(varTokenPtr, envPtr);
/*
* Special case: an empty body means we definitely have no need to issue
@@ -1989,18 +1886,16 @@ TclCompileDictWithCmd(
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
- PushLiteral(envPtr, "", 0);
} else {
/*
* Case: Direct dict in LVT with empty body.
*/
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
- PushLiteral(envPtr, "", 0);
}
} else {
if (gotPath) {
@@ -2019,7 +1914,6 @@ TclCompileDictWithCmd(
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
- PushLiteral(envPtr, "", 0);
} else {
/*
* Case: Direct dict in non-simple var with empty body.
@@ -2028,15 +1922,14 @@ TclCompileDictWithCmd(
CompileWord(envPtr, varTokenPtr, interp, 0);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_LOAD_STK, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
- PushLiteral(envPtr, "", 0);
}
}
- envPtr->currStackDepth = savedStackDepth + 1;
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -2049,22 +1942,18 @@ TclCompileDictWithCmd(
*/
if (dictVar == -1) {
- varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- } else {
- varNameTmp = -1;
+ varNameTmp = AnonymousLocal(envPtr);
}
if (gotPath) {
- pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- } else {
- pathTmp = -1;
+ pathTmp = AnonymousLocal(envPtr);
}
- keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ keysTmp = AnonymousLocal(envPtr);
/*
* Issue instructions. First, the part to expand the dictionary.
*/
- if (varNameTmp > -1) {
+ if (dictVar == -1) {
CompileWord(envPtr, varTokenPtr, interp, 0);
Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
}
@@ -2086,7 +1975,7 @@ TclCompileDictWithCmd(
if (gotPath) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr);
@@ -2096,14 +1985,11 @@ TclCompileDictWithCmd(
* Now the body of the [dict with].
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- envPtr->currStackDepth++;
- SetLineInformation(parsePtr->numWords-1);
- CompileBody(envPtr, tokenPtr, interp);
- envPtr->currStackDepth = savedStackDepth;
+ BODY(tokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -2111,13 +1997,13 @@ TclCompileDictWithCmd(
*/
TclEmitOpcode( INST_END_CATCH, envPtr);
- if (varNameTmp > -1) {
+ if (dictVar == -1) {
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
}
if (gotPath) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
if (dictVar == -1) {
@@ -2131,17 +2017,18 @@ TclCompileDictWithCmd(
* Now fold the results back into the dictionary in the exception case.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, range, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
- if (varNameTmp > -1) {
+ if (dictVar == -1) {
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
}
if (parsePtr->numWords > 3) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
if (dictVar == -1) {
@@ -2155,7 +2042,6 @@ TclCompileDictWithCmd(
* Prepare for the start of the next command.
*/
- envPtr->currStackDepth = savedStackDepth + 1;
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
@@ -2255,7 +2141,6 @@ TclCompileErrorCmd(
* However, we only deal with the case where there is just a message.
*/
Tcl_Token *messageTokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 2) {
@@ -2263,10 +2148,9 @@ TclCompileErrorCmd(
}
messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushLiteral(envPtr, "-code error -level 0", 20);
+ PushStringLiteral(envPtr, "-code error -level 0");
CompileWord(envPtr, messageTokenPtr, interp, 1);
TclEmitOpcode(INST_RETURN_STK, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
@@ -2346,7 +2230,6 @@ TclCompileForCmd(
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
- int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 5) {
@@ -2378,20 +2261,10 @@ TclCompileForCmd(
}
/*
- * Create ExceptionRange records for the body and the "next" command. The
- * "next" command's ExceptionRange supports break but not continue (and
- * has a -1 continueOffset).
- */
-
- bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
- nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
* Inline compile the initial command.
*/
- SetLineInformation(1);
- CompileBody(envPtr, startTokenPtr, interp);
+ BODY(startTokenPtr, 1);
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -2412,25 +2285,24 @@ TclCompileForCmd(
* Compile the loop body.
*/
+ bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
- SetLineInformation(4);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, 4);
ExceptionRangeEnds(envPtr, bodyRange);
- envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode(INST_POP, envPtr);
/*
- * Compile the "next" subcommand.
+ * Compile the "next" subcommand. Note that this exception range will not
+ * have a continueOffset (other than -1) connected to it; it won't trap
+ * TCL_CONTINUE but rather just TCL_BREAK.
*/
- envPtr->currStackDepth = savedStackDepth;
+ nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0;
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
- SetLineInformation(3);
- CompileBody(envPtr, nextTokenPtr, interp);
+ BODY(nextTokenPtr, 3);
ExceptionRangeEnds(envPtr, nextRange);
- envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode(INST_POP, envPtr);
- envPtr->currStackDepth = savedStackDepth;
/*
* Compile the test expression then emit the conditional jump that
@@ -2447,9 +2319,7 @@ TclCompileForCmd(
}
SetLineInformation(2);
- envPtr->currStackDepth = savedStackDepth;
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
@@ -2470,13 +2340,14 @@ TclCompileForCmd(
ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
ExceptionRangeTarget(envPtr, nextRange, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, bodyRange);
+ TclFinalizeLoopExceptionRange(envPtr, nextRange);
/*
* The for command's result is an empty string.
*/
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -2515,6 +2386,37 @@ TclCompileForeachCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileLmapCmd --
+ *
+ * Procedure called to compile the "lmap" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lmap" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLmapCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_COLLECT);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CompileEachloopCmd --
*
* Procedure called to compile the "foreach" and "lmap" commands.
@@ -2555,9 +2457,8 @@ CompileEachloopCmd(
Tcl_Token *tokenPtr, *bodyTokenPtr;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
- int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
+ int jumpBackDist, jumpBackOffset, infoIndex, range;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
- int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
/*
@@ -2596,8 +2497,6 @@ CompileEachloopCmd(
return TCL_ERROR;
}
- bodyIndex = i-1;
-
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
@@ -2636,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) {
@@ -2668,8 +2567,7 @@ CompileEachloopCmd(
}
if (collect == TCL_EACH_COLLECT) {
- collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
- envPtr);
+ collectVar = AnonymousLocal(envPtr);
if (collectVar < 0) {
return TCL_ERROR;
}
@@ -2688,14 +2586,12 @@ CompileEachloopCmd(
code = TCL_OK;
firstValueTemp = -1;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
- tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, envPtr);
+ tempVar = AnonymousLocal(envPtr);
if (loopIndex == 0) {
firstValueTemp = tempVar;
}
}
- loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, envPtr);
+ loopCtTemp = AnonymousLocal(envPtr);
/*
* Create and initialize the ForeachInfo and ForeachVarList data
@@ -2730,7 +2626,7 @@ CompileEachloopCmd(
* Create an exception record to handle [break] and [continue].
*/
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Evaluate then store each value list in the associated temporary.
@@ -2741,8 +2637,7 @@ CompileEachloopCmd(
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
if ((i%2 == 0) && (i > 0)) {
- SetLineInformation(i);
- CompileTokens(envPtr, tokenPtr, interp);
+ CompileWord(envPtr, tokenPtr, interp, i);
tempVar = (firstValueTemp + loopIndex);
Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
@@ -2755,7 +2650,7 @@ CompileEachloopCmd(
*/
if (collect == TCL_EACH_COLLECT) {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
@@ -2779,11 +2674,9 @@ CompileEachloopCmd(
* Inline compile the loop body.
*/
- SetLineInformation(bodyIndex);
ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, numWords - 1);
ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr);
@@ -2836,21 +2729,20 @@ CompileEachloopCmd(
*/
ExceptionRangeTarget(envPtr, range, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, range);
/*
* The command's result is an empty string if not collecting, or the
* list of results from evaluating the loop body.
*/
- envPtr->currStackDepth = savedStackDepth;
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
- envPtr->currStackDepth = savedStackDepth + 1;
done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
@@ -3085,7 +2977,8 @@ TclCompileFormatCmd(
ckfree(objv);
Tcl_DecrRefCount(formatObj);
if (tmpObj == NULL) {
- return TCL_ERROR;
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
}
/*
@@ -3220,7 +3113,7 @@ TclCompileFormatCmd(
*/
TclEmitOpcode(INST_DUP, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitOpcode(INST_STR_EQ, envPtr);
TclEmitOpcode(INST_POP, envPtr);
}
@@ -3230,2817 +3123,40 @@ TclCompileFormatCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileGlobalCmd --
- *
- * Procedure called to compile the "global" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "global" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileGlobalCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if (numWords < 2) {
- return TCL_ERROR;
- }
-
- /*
- * 'global' has no effect outside of proc bodies; handle that at runtime
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- PushLiteral(envPtr, "::", 2);
-
- /*
- * Loop over the variables.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if (localIndex < 0) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the namespace, and set the result to empty
- */
-
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIfCmd --
- *
- * Procedure called to compile the "if" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "if" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIfCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- JumpFixupArray jumpFalseFixupArray;
- /* Used to fix the ifFalse jump after each
- * test when its target PC is determined. */
- JumpFixupArray jumpEndFixupArray;
- /* Used to fix the jump after each "then" body
- * to the end of the "if" when that PC is
- * determined. */
- Tcl_Token *tokenPtr, *testTokenPtr;
- int jumpIndex = 0; /* Avoid compiler warning. */
- int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
- const char *word;
- int savedStackDepth = envPtr->currStackDepth;
- /* Saved stack depth at the start of the first
- * test; the envPtr current depth is restored
- * to this value at the start of each test. */
- int realCond = 1; /* Set to 0 for static conditions:
- * "if 0 {..}" */
- int boolVal; /* Value of static condition. */
- int compileScripts = 1;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Only compile the "if" command if all arguments are simple words, in
- * order to insure correct substitution [Bug 219166]
- */
-
- tokenPtr = parsePtr->tokenPtr;
- wordIdx = 0;
- numWords = parsePtr->numWords;
-
- for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- TclInitJumpFixupArray(&jumpFalseFixupArray);
- TclInitJumpFixupArray(&jumpEndFixupArray);
- code = TCL_OK;
-
- /*
- * Each iteration of this loop compiles one "if expr ?then? body" or
- * "elseif expr ?then? body" clause.
- */
-
- tokenPtr = parsePtr->tokenPtr;
- wordIdx = 0;
- while (wordIdx < numWords) {
- /*
- * Stop looping if the token isn't "if" or "elseif".
- */
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((tokenPtr == parsePtr->tokenPtr)
- || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- } else {
- break;
- }
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
-
- /*
- * Compile the test expression then emit the conditional jump around
- * the "then" part.
- */
-
- envPtr->currStackDepth = savedStackDepth;
- testTokenPtr = tokenPtr;
-
- if (realCond) {
- /*
- * Find out if the condition is a constant.
- */
-
- Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
- testTokenPtr[1].size);
-
- Tcl_IncrRefCount(boolObj);
- code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- TclDecrRefCount(boolObj);
- if (code == TCL_OK) {
- /*
- * A static condition.
- */
-
- realCond = 0;
- if (!boolVal) {
- compileScripts = 0;
- }
- } else {
- SetLineInformation(wordIdx);
- Tcl_ResetResult(interp);
- TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFalseFixupArray);
- }
- jumpIndex = jumpFalseFixupArray.next;
- jumpFalseFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- jumpFalseFixupArray.fixup+jumpIndex);
- }
- code = TCL_OK;
- }
-
- /*
- * Skip over the optional "then" before the then clause.
- */
-
- tokenPtr = TokenAfter(testTokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "then" command body.
- */
-
- if (compileScripts) {
- SetLineInformation(wordIdx);
- envPtr->currStackDepth = savedStackDepth;
- CompileBody(envPtr, tokenPtr, interp);
- }
-
- if (realCond) {
- /*
- * Jump to the end of the "if" command. Both jumpFalseFixupArray
- * and jumpEndFixupArray are indexed by "jumpIndex".
- */
-
- if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
- TclExpandJumpFixupArray(&jumpEndFixupArray);
- }
- jumpEndFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- jumpEndFixupArray.fixup+jumpIndex);
-
- /*
- * Fix the target of the jumpFalse after the test. Generate a 4
- * byte jump if the distance is > 120 bytes. This is conservative,
- * and ensures that we won't have to replace this jump if we later
- * also need to replace the proceeding jump to the end of the "if"
- * with a 4 byte jump.
- */
-
- if (TclFixupForwardJumpToHere(envPtr,
- jumpFalseFixupArray.fixup+jumpIndex, 120)) {
- /*
- * Adjust the code offset for the proceeding jump to the end
- * of the "if" command.
- */
-
- jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
- }
- } else if (boolVal) {
- /*
- * We were processing an "if 1 {...}"; stop compiling scripts.
- */
-
- compileScripts = 0;
- } else {
- /*
- * We were processing an "if 0 {...}"; reset so that the rest
- * (elseif, else) is compiled correctly.
- */
-
- realCond = 1;
- compileScripts = 1;
- }
-
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- }
-
- /*
- * Restore the current stack depth in the environment; the "else" clause
- * (or its default) will add 1 to this.
- */
-
- envPtr->currStackDepth = savedStackDepth;
-
- /*
- * Check for the optional else clause. Do not compile anything if this was
- * an "if 1 {...}" case.
- */
-
- if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
- /*
- * There is an else clause. Skip over the optional "else" word.
- */
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- }
-
- if (compileScripts) {
- /*
- * Compile the else command body.
- */
-
- SetLineInformation(wordIdx);
- CompileBody(envPtr, tokenPtr, interp);
- }
-
- /*
- * Make sure there are no words after the else clause.
- */
-
- wordIdx++;
- if (wordIdx < numWords) {
- code = TCL_ERROR;
- goto done;
- }
- } else {
- /*
- * No else clause: the "if" command's result is an empty string.
- */
-
- if (compileScripts) {
- PushLiteral(envPtr, "", 0);
- }
- }
-
- /*
- * Fix the unconditional jumps to the end of the "if" command.
- */
-
- for (j = jumpEndFixupArray.next; j > 0; j--) {
- jumpIndex = (j - 1); /* i.e. process the closest jump first. */
- if (TclFixupForwardJumpToHere(envPtr,
- jumpEndFixupArray.fixup+jumpIndex, 127)) {
- /*
- * Adjust the immediately preceeding "ifFalse" jump. We moved it's
- * target (just after this jump) down three bytes.
- */
-
- unsigned char *ifFalsePc = envPtr->codeStart
- + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
- unsigned char opCode = *ifFalsePc;
-
- if (opCode == INST_JUMP_FALSE1) {
- jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else if (opCode == INST_JUMP_FALSE4) {
- jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else {
- Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
- }
- }
- }
-
- /*
- * Free the jumpFixupArray array if malloc'ed storage was used.
- */
-
- done:
- envPtr->currStackDepth = savedStackDepth + 1;
- TclFreeJumpFixupArray(&jumpFalseFixupArray);
- TclFreeJumpFixupArray(&jumpEndFixupArray);
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIncrCmd --
- *
- * Procedure called to compile the "incr" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "incr" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIncrCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr, *incrTokenPtr;
- int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
- DefineLineInformation; /* TIP #280 */
-
- if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
- return TCL_ERROR;
- }
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If an increment is given, push it, but see first if it's a small
- * integer.
- */
-
- haveImmValue = 0;
- immValue = 1;
- if (parsePtr->numWords == 3) {
- incrTokenPtr = TokenAfter(varTokenPtr);
- if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- const char *word = incrTokenPtr[1].start;
- int numBytes = incrTokenPtr[1].size;
- int code;
- Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
-
- Tcl_IncrRefCount(intObj);
- code = TclGetIntFromObj(NULL, intObj, &immValue);
- TclDecrRefCount(intObj);
- if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
- haveImmValue = 1;
- }
- if (!haveImmValue) {
- PushLiteral(envPtr, word, numBytes);
- }
- } else {
- SetLineInformation(2);
- CompileTokens(envPtr, incrTokenPtr, interp);
- }
- } else { /* No incr amount given so use 1. */
- haveImmValue = 1;
- }
-
- /*
- * Emit the instruction to increment the variable.
- */
-
- if (!simpleVarName) {
- if (haveImmValue) {
- TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode( INST_INCR_STK, envPtr);
- }
- } else if (isScalar) { /* Simple scalar variable. */
- if (localIndex >= 0) {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
- TclEmitInt1(immValue, envPtr);
- } else {
- TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
- }
- } else {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode( INST_INCR_SCALAR_STK, envPtr);
- }
- }
- } else { /* Simple array variable. */
- if (localIndex >= 0) {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
- TclEmitInt1(immValue, envPtr);
- } else {
- TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
- }
- } else {
- if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr);
- }
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileInfo*Cmd --
- *
- * Procedures called to compile "info" subcommands.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "info" subcommand at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileInfoCommandsCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr;
- Tcl_Obj *objPtr;
- char *bytes;
-
- /*
- * We require one compile-time known argument for the case we can compile.
- */
-
- if (parsePtr->numWords == 1) {
- return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
- } else if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- objPtr = Tcl_NewObj();
- Tcl_IncrRefCount(objPtr);
- if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- goto notCompilable;
- }
- bytes = Tcl_GetString(objPtr);
-
- /*
- * We require that the argument start with "::" and not have any of "*\[?"
- * in it. (Theoretically, we should look in only the final component, but
- * the difference is so slight given current naming practices.)
- */
-
- if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
- goto notCompilable;
- }
- Tcl_DecrRefCount(objPtr);
-
- /*
- * Confirmed as a literal that will not frighten the horses. Compile. Note
- * that the result needs to be list-ified.
- */
-
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_STR_LEN, envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr);
- TclEmitInstInt4( INST_LIST, 1, envPtr);
- return TCL_OK;
-
- notCompilable:
- Tcl_DecrRefCount(objPtr);
- return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
-}
-
-int
-TclCompileInfoCoroutineCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * Only compile [info coroutine] without arguments.
- */
-
- if (parsePtr->numWords != 1) {
- return TCL_ERROR;
- }
-
- /*
- * Not much to do; we compile to a single instruction...
- */
-
- TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileInfoExistsCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- int isScalar, simpleVarName, localIndex;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
- &simpleVarName, &isScalar, 1);
-
- /*
- * Emit instruction to check the variable for existence.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_EXIST_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_EXIST_STK, envPtr);
- } else {
- TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr);
- } else {
- TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-int
-TclCompileInfoLevelCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * Only compile [info level] without arguments or with a single argument.
- */
-
- if (parsePtr->numWords == 1) {
- /*
- * Not much to do; we compile to a single instruction...
- */
-
- TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
- } else if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- } else {
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Compile the argument, then add the instruction to convert it into a
- * list of arguments.
- */
-
- SetLineInformation(1);
- CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
- TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
- }
- return TCL_OK;
-}
-
-int
-TclCompileInfoObjectClassCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileInfoObjectIsACmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * We only handle [info object isa object <somevalue>]. The first three
- * words are compressed to a single token by the ensemble compilation
- * engine.
- */
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
- || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
-
- /*
- * Issue the code.
- */
-
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileInfoObjectNamespaceCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode( INST_TCLOO_NS, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLappendCmd --
- *
- * Procedure called to compile the "lappend" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lappend" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLappendCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords == 1) {
- return TCL_ERROR;
- }
- if (numWords != 3) {
- /*
- * LAPPEND instructions currently only handle one value appends.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we
- * need to emit code to compute and push the name at runtime. We use a
- * frame slot (entry in the array of local vars) if we are compiling a
- * procedure body and if the name is simple text that does not include
- * namespace qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If we are doing an assignment, push the new value. In the no values
- * case, create an empty object.
- */
-
- if (numWords > 2) {
- Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
-
- CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
-
- /*
- * Emit instructions to set/get the variable.
- */
-
- /*
- * The *_STK opcodes should be refactored to make better use of existing
- * LOAD/STORE instructions.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_LAPPEND_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LAPPEND_STK, envPtr);
- } else {
- Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr);
- } else {
- Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLassignCmd --
- *
- * Procedure called to compile the "lassign" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lassign" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLassignCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, idx;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
-
- /*
- * Check for command syntax error, but we'll punt that to runtime.
- */
-
- if (numWords < 3) {
- return TCL_ERROR;
- }
-
- /*
- * Generate code to push list being taken apart by [lassign].
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
-
- /*
- * Generate code to assign values from the list to variables.
- */
-
- for (idx=0 ; idx<numWords-2 ; idx++) {
- tokenPtr = TokenAfter(tokenPtr);
-
- /*
- * Generate the next variable name.
- */
-
- PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
- &simpleVarName, &isScalar, idx+2);
-
- /*
- * Emit instructions to get the idx'th item out of the list value on
- * the stack and assign it to the variable.
- */
-
- if (!simpleVarName) {
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode( INST_STORE_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- } else if (isScalar) {
- if (localIndex >= 0) {
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- } else {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
- } else {
- if (localIndex >= 0) {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- } else {
- TclEmitInstInt4(INST_OVER, 2, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
- }
- }
-
- /*
- * Generate code to leave the rest of the list on the stack.
- */
-
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( -2 /* == "end" */, envPtr);
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLindexCmd --
- *
- * Procedure called to compile the "lindex" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lindex" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLindexCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *idxTokenPtr, *valTokenPtr;
- int i, numWords = parsePtr->numWords;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Quit if too few args.
- */
-
- if (numWords <= 1) {
- return TCL_ERROR;
- }
-
- valTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (numWords != 3) {
- goto emitComplexLindex;
- }
-
- idxTokenPtr = TokenAfter(valTokenPtr);
- if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_Obj *tmpObj;
- int idx, result;
-
- tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx);
- if (result == TCL_OK) {
- if (idx < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx);
- if (result == TCL_OK && idx > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
-
- if (result == TCL_OK) {
- /*
- * All checks have been completed, and we have exactly one of
- * these constructs:
- * lindex <arbitraryValue> <posInt>
- * lindex <arbitraryValue> end-<posInt>
- * This is best compiled as a push of the arbitrary value followed
- * by an "immediate lindex" which is the most efficient variety.
- */
-
- CompileWord(envPtr, valTokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
- return TCL_OK;
- }
-
- /*
- * If the conversion failed or the value was negative, we just keep on
- * going with the more complex compilation.
- */
- }
-
- /*
- * Push the operands onto the stack.
- */
-
- emitComplexLindex:
- for (i=1 ; i<numWords ; i++) {
- CompileWord(envPtr, valTokenPtr, interp, i);
- valTokenPtr = TokenAfter(valTokenPtr);
- }
-
- /*
- * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
- * multiple index args.
- */
-
- if (numWords == 3) {
- TclEmitOpcode( INST_LIST_INDEX, envPtr);
- } else {
- TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileListCmd --
- *
- * Procedure called to compile the "list" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "list" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileListCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *valueTokenPtr;
- int i, numWords;
-
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- if (parsePtr->numWords == 1) {
- /*
- * [list] without arguments just pushes an empty object.
- */
-
- PushLiteral(envPtr, "", 0);
- } else {
- /*
- * Push the all values onto the stack.
- */
-
- numWords = parsePtr->numWords;
- valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for (i = 1; i < numWords; i++) {
- CompileWord(envPtr, valueTokenPtr, interp, i);
- valueTokenPtr = TokenAfter(valueTokenPtr);
- }
- TclEmitInstInt4( INST_LIST, numWords - 1, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLlengthCmd --
- *
- * Procedure called to compile the "llength" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "llength" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLlengthCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLrangeCmd --
- *
- * How to compile the "lrange" command. We only bother because we needed
- * the opcode anyway for "lassign".
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLrangeCmd(
- Tcl_Interp *interp, /* Tcl interpreter for context. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- Tcl_Token *tokenPtr, *listTokenPtr;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
- int idx1, idx2, result;
-
- if (parsePtr->numWords != 4) {
- return TCL_ERROR;
- }
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Parse the first index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(listTokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx1);
- if (result == TCL_OK) {
- if (idx1 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
- if (result == TCL_OK && idx1 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Parse the second index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx2);
- if (result == TCL_OK) {
- if (idx2 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
- if (result == TCL_OK && idx2 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
- * we've not proved that the 'list' argument is really a list. Not that it
- * is worth trying to do that given current knowledge.
- */
-
- CompileWord(envPtr, listTokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLreplaceCmd --
- *
- * How to compile the "lreplace" command. We only bother with the case
- * where there are no elements to insert and where both the 'first' and
- * 'last' arguments are constant and one can be deterined to be at the
- * end of the list. (This is the case that could also be written with
- * "lrange".)
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLreplaceCmd(
- Tcl_Interp *interp, /* Tcl interpreter for context. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- Tcl_Token *tokenPtr, *listTokenPtr;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
- int idx1, idx2, result, guaranteedDropAll = 0;
-
- if (parsePtr->numWords != 4) {
- return TCL_ERROR;
- }
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Parse the first index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(listTokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx1);
- if (result == TCL_OK) {
- if (idx1 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
- if (result == TCL_OK && idx1 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Parse the second index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx2);
- if (result == TCL_OK) {
- if (idx2 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
- if (result == TCL_OK && idx2 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Sanity check: can only issue when we're removing a range at one or
- * other end of the list. If we're at one end or the other, convert the
- * indices into the equivalent for an [lrange].
- */
-
- if (idx1 == 0) {
- if (idx2 == -2) {
- guaranteedDropAll = 1;
- }
- idx1 = idx2 + 1;
- idx2 = -2;
- } else if (idx2 == -2) {
- idx2 = idx1 - 1;
- idx1 = 0;
- } else {
- return TCL_ERROR;
- }
-
- /*
- * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
- * we've not proved that the 'list' argument is really a list. Not that it
- * is worth trying to do that given current knowledge.
- */
-
- CompileWord(envPtr, listTokenPtr, interp, 1);
- if (guaranteedDropAll) {
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- } else {
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLsetCmd --
- *
- * Procedure called to compile the "lset" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lset" command at
- * runtime.
- *
- * The general template for execution of the "lset" command is:
- * (1) Instructions to push the variable name, unless the variable is
- * local to the stack frame.
- * (2) If the variable is an array element, instructions to push the
- * array element name.
- * (3) Instructions to push each of zero or more "index" arguments to the
- * stack, followed with the "newValue" element.
- * (4) Instructions to duplicate the variable name and/or array element
- * name onto the top of the stack, if either was pushed at steps (1)
- * and (2).
- * (5) The appropriate INST_LOAD_* instruction to place the original
- * value of the list variable at top of stack.
- * (6) At this point, the stack contains:
- * varName? arrayElementName? index1 index2 ... newValue oldList
- * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
- * according as whether there is exactly one index element (LIST) or
- * either zero or else two or more (FLAT). This instruction removes
- * everything from the stack except for the two names and pushes the
- * new value of the variable.
- * (7) Finally, INST_STORE_* stores the new value in the variable and
- * cleans up the stack.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLsetCmd(
- Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- int tempDepth; /* Depth used for emitting one part of the
- * code burst. */
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
- * parse of the variable name. */
- int localIndex; /* Index of var in local var table. */
- int simpleVarName; /* Flag == 1 if var name is simple. */
- int isScalar; /* Flag == 1 if scalar, 0 if array. */
- int i;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Check argument count.
- */
-
- if (parsePtr->numWords < 3) {
- /*
- * Fail at run time, not in compilation.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * Push the "index" args and the new element value.
- */
-
- for (i=2 ; i<parsePtr->numWords ; ++i) {
- varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, i);
- }
-
- /*
- * Duplicate the variable name if it's been pushed.
- */
-
- if (!simpleVarName || localIndex < 0) {
- if (!simpleVarName || isScalar) {
- tempDepth = parsePtr->numWords - 2;
- } else {
- tempDepth = parsePtr->numWords - 1;
- }
- TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
- }
-
- /*
- * Duplicate an array index if one's been pushed.
- */
-
- if (simpleVarName && !isScalar) {
- if (localIndex < 0) {
- tempDepth = parsePtr->numWords - 1;
- } else {
- tempDepth = parsePtr->numWords - 2;
- }
- TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
- }
-
- /*
- * Emit code to load the variable's value.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_LOAD_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr);
- } else {
- Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr);
- } else {
- Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr);
- }
- }
-
- /*
- * Emit the correct variety of 'lset' instruction.
- */
-
- if (parsePtr->numWords == 4) {
- TclEmitOpcode( INST_LSET_LIST, envPtr);
- } else {
- TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
- }
-
- /*
- * Emit code to put the value back in the variable.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_STORE_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr);
- } else {
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
- } else {
- Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLmapCmd --
- *
- * Procedure called to compile the "lmap" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lmap" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLmapCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
- TCL_EACH_COLLECT);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileNamespace*Cmd --
- *
- * Procedures called to compile the "namespace" command; currently, only
- * the subcommands "namespace current" and "namespace upvar" are compiled
- * to bytecodes, and the latter only inside a procedure(-like) context.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "namespace upvar"
- * command at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileNamespaceCurrentCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * Only compile [namespace current] without arguments.
- */
-
- if (parsePtr->numWords != 1) {
- return TCL_ERROR;
- }
-
- /*
- * Not much to do; we compile to a single instruction...
- */
-
- TclEmitOpcode( INST_NS_CURRENT, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceCodeCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * The specification of [namespace code] is rather shocking, in that it is
- * supposed to check if the argument is itself the result of [namespace
- * code] and not apply itself in that case. Which is excessively cautious,
- * but what the test suite checks for.
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
- && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
- /*
- * Technically, we could just pass a literal '::namespace inscope '
- * term through, but that's something which really shouldn't be
- * occurring as something that the user writes so we'll just punt it.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Now we can compile using the same strategy as [namespace code]'s normal
- * implementation does internally. Note that we can't bind the namespace
- * name directly here, because TclOO plays complex games with namespaces;
- * the value needs to be determined at runtime for safety.
- */
-
- PushLiteral(envPtr, "::namespace", 11);
- PushLiteral(envPtr, "inscope", 7);
- TclEmitOpcode( INST_NS_CURRENT, envPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST, 4, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceQualifiersCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
- int off;
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, tokenPtr, interp, 1);
- PushLiteral(envPtr, "0", 1);
- PushLiteral(envPtr, "::", 2);
- TclEmitInstInt4( INST_OVER, 2, envPtr);
- TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
- off = CurrentOffset(envPtr);
- PushLiteral(envPtr, "1", 1);
- TclEmitOpcode( INST_SUB, envPtr);
- TclEmitInstInt4( INST_OVER, 2, envPtr);
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitOpcode( INST_STR_INDEX, envPtr);
- PushLiteral(envPtr, ":", 1);
- TclEmitOpcode( INST_STR_EQ, envPtr);
- off = off - CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr);
- TclEmitOpcode( INST_STR_RANGE, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceTailCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
- JumpFixup jumpFixup;
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- /*
- * Take care; only add 2 to found index if the string was actually found.
- */
-
- CompileWord(envPtr, tokenPtr, interp, 1);
- PushLiteral(envPtr, "::", 2);
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
- TclEmitOpcode( INST_DUP, envPtr);
- PushLiteral(envPtr, "0", 1);
- TclEmitOpcode( INST_GE, envPtr);
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
- PushLiteral(envPtr, "2", 1);
- TclEmitOpcode( INST_ADD, envPtr);
- TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
- PushLiteral(envPtr, "end", 3);
- TclEmitOpcode( INST_STR_RANGE, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceUpvarCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Only compile [namespace upvar ...]: needs an even number of args, >=4
- */
-
- numWords = parsePtr->numWords;
- if ((numWords % 2) || (numWords < 4)) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
-
- /*
- * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
- * local variable, return an error so that the non-compiled command will
- * be called at runtime.
- */
-
- localTokenPtr = tokenPtr;
- for (i=3; i<=numWords; i+=2) {
- otherTokenPtr = TokenAfter(localTokenPtr);
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- if ((localIndex < 0) || !isScalar) {
- return TCL_ERROR;
- }
- TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the namespace, and set the result to empty
- */
-
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceWhichCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *opt;
- int idx;
-
- if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- idx = 1;
-
- /*
- * If there's an option, check that it's "-command". We don't handle
- * "-variable" (currently) and anything else is an error.
- */
-
- if (parsePtr->numWords == 3) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- opt = tokenPtr + 1;
- if (opt->size < 2 || opt->size > 8
- || strncmp(opt->start, "-command", opt->size) != 0) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- idx++;
- }
-
- /*
- * Issue the bytecode.
- */
-
- CompileWord(envPtr, tokenPtr, interp, idx);
- TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileRegexpCmd --
- *
- * Procedure called to compile the "regexp" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "regexp" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileRegexpCmd(
- Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
- * parse of the RE or string. */
- int i, len, nocase, exact, sawLast, simple;
- const char *str;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * We are only interested in compiling simple regexp cases. Currently
- * supported compile cases are:
- * regexp ?-nocase? ?--? staticString $var
- * regexp ?-nocase? ?--? {^staticString$} $var
- */
-
- if (parsePtr->numWords < 3) {
- return TCL_ERROR;
- }
-
- simple = 0;
- nocase = 0;
- sawLast = 0;
- varTokenPtr = parsePtr->tokenPtr;
-
- /*
- * We only look for -nocase and -- as options. Everything else gets pushed
- * to runtime execution. This is different than regexp's runtime option
- * handling, but satisfies our stricter needs.
- */
-
- for (i = 1; i < parsePtr->numWords - 2; i++) {
- varTokenPtr = TokenAfter(varTokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Not a simple string, so punt to runtime.
- */
-
- return TCL_ERROR;
- }
- str = varTokenPtr[1].start;
- len = varTokenPtr[1].size;
- if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
- sawLast++;
- i++;
- break;
- } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
- nocase = 1;
- } else {
- /*
- * Not an option we recognize.
- */
-
- return TCL_ERROR;
- }
- }
-
- if ((parsePtr->numWords - i) != 2) {
- /*
- * We don't support capturing to variables.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Get the regexp string. If it is not a simple string or can't be
- * converted to a glob pattern, push the word for the INST_REGEXP.
- * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
- */
-
- varTokenPtr = TokenAfter(varTokenPtr);
-
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_DString ds;
-
- str = varTokenPtr[1].start;
- len = varTokenPtr[1].size;
-
- /*
- * If it has a '-', it could be an incorrectly formed regexp command.
- */
-
- if ((*str == '-') && !sawLast) {
- return TCL_ERROR;
- }
-
- if (len == 0) {
- /*
- * The semantics of regexp are always match on re == "".
- */
-
- PushLiteral(envPtr, "1", 1);
- return TCL_OK;
- }
-
- /*
- * Attempt to convert pattern to glob. If successful, push the
- * converted pattern as a literal.
- */
-
- if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
- == TCL_OK) {
- simple = 1;
- PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- }
- }
-
- if (!simple) {
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
- }
-
- /*
- * Push the string arg.
- */
-
- varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
-
- if (simple) {
- if (exact && !nocase) {
- TclEmitOpcode( INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr);
- }
- } else {
- /*
- * Pass correct RE compile flags. We use only Int1 (8-bit), but
- * that handles all the flags we want to pass.
- * Don't use TCL_REG_NOSUB as we may have backrefs.
- */
-
- int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
-
- TclEmitInstInt1( INST_REGEXP, cflags, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileRegsubCmd --
- *
- * Procedure called to compile the "regsub" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "regsub" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileRegsubCmd(
- Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- /*
- * We only compile the case with [regsub -all] where the pattern is both
- * known at compile time and simple (i.e., no RE metacharacters). That is,
- * the pattern must be translatable into a glob like "*foo*" with no other
- * glob metacharacters inside it; there must be some "foo" in there too.
- * The substitution string must also be known at compile time and free of
- * metacharacters ("\digit" and "&"). Finally, there must not be a
- * variable mentioned in the [regsub] to write the result back to (because
- * we can't get the count of substitutions that would be the result in
- * that case). The key is that these are the conditions under which a
- * [string map] could be used instead, in particular a [string map] of the
- * form we can compile to bytecode.
- *
- * In short, we look for:
- *
- * regsub -all [--] simpleRE string simpleReplacement
- *
- * The only optional part is the "--", and no other options are handled.
- */
-
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *stringTokenPtr;
- Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
- Tcl_DString pattern;
- const char *bytes;
- int len, exact, result = TCL_ERROR;
-
- if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
- return TCL_ERROR;
- }
-
- /*
- * Parse the "-all", which must be the first argument (other options not
- * supported, non-"-all" substitution we can't compile).
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
- || strncmp(tokenPtr[1].start, "-all", 4)) {
- return TCL_ERROR;
- }
-
- /*
- * Get the pattern into patternObj, checking for "--" in the process.
- */
-
- Tcl_DStringInit(&pattern);
- tokenPtr = TokenAfter(tokenPtr);
- patternObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
- goto done;
- }
- if (Tcl_GetString(patternObj)[0] == '-') {
- if (strcmp(Tcl_GetString(patternObj), "--") != 0
- || parsePtr->numWords == 5) {
- goto done;
- }
- tokenPtr = TokenAfter(tokenPtr);
- Tcl_DecrRefCount(patternObj);
- patternObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
- goto done;
- }
- } else if (parsePtr->numWords == 6) {
- goto done;
- }
-
- /*
- * Identify the code which produces the string to apply the substitution
- * to (stringTokenPtr), and the replacement string (into replacementObj).
- */
-
- stringTokenPtr = TokenAfter(tokenPtr);
- tokenPtr = TokenAfter(stringTokenPtr);
- replacementObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
- goto done;
- }
-
- /*
- * Next, higher-level checks. Is the RE a very simple glob? Is the
- * replacement "simple"?
- */
-
- bytes = Tcl_GetStringFromObj(patternObj, &len);
- if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
- goto done;
- }
- bytes = Tcl_DStringValue(&pattern);
- if (*bytes++ != '*') {
- goto done;
- }
- while (1) {
- switch (*bytes) {
- case '*':
- if (bytes[1] == '\0') {
- /*
- * OK, we've proved there are no metacharacters except for the
- * '*' at each end.
- */
-
- len = Tcl_DStringLength(&pattern) - 2;
- if (len > 0) {
- goto isSimpleGlob;
- }
-
- /*
- * The pattern is "**"! I believe that should be impossible,
- * but we definitely can't handle that at all.
- */
- }
- case '\0': case '?': case '[': case '\\':
- goto done;
- }
- bytes++;
- }
- isSimpleGlob:
- for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
- switch (*bytes) {
- case '\\': case '&':
- goto done;
- }
- }
-
- /*
- * Proved the simplicity constraints! Time to issue the code.
- */
-
- result = TCL_OK;
- bytes = Tcl_DStringValue(&pattern) + 1;
- PushLiteral(envPtr, bytes, len);
- bytes = Tcl_GetStringFromObj(replacementObj, &len);
- PushLiteral(envPtr, bytes, len);
- CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
- TclEmitOpcode( INST_STR_MAP, envPtr);
-
- done:
- Tcl_DStringFree(&pattern);
- if (patternObj) {
- Tcl_DecrRefCount(patternObj);
- }
- if (replacementObj) {
- Tcl_DecrRefCount(replacementObj);
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileReturnCmd --
- *
- * Procedure called to compile the "return" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "return" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileReturnCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * General syntax: [return ?-option value ...? ?result?]
- * An even number of words means an explicit result argument is present.
- */
- int level, code, objc, size, status = TCL_OK;
- int numWords = parsePtr->numWords;
- int explicitResult = (0 == (numWords % 2));
- int numOptionWords = numWords - 1 - explicitResult;
- int savedStackDepth = envPtr->currStackDepth;
- Tcl_Obj *returnOpts, **objv;
- Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Check for special case which can always be compiled:
- * return -options <opts> <msg>
- * Unlike the normal [return] compilation, this version does everything at
- * runtime so it can handle arbitrary words and not just literals. Note
- * that if INST_RETURN_STK wasn't already needed for something else
- * ('finally' clause processing) this piece of code would not be present.
- */
-
- if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
- && (wordTokenPtr[1].size == 8)
- && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
- Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
- Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
-
- CompileWord(envPtr, optsTokenPtr, interp, 2);
- CompileWord(envPtr, msgTokenPtr, interp, 3);
- TclEmitOpcode(INST_RETURN_STK, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- return TCL_OK;
- }
-
- /*
- * Allocate some working space.
- */
-
- objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
-
- /*
- * Scan through the return options. If any are unknown at compile time,
- * there is no value in bytecompiling. Save the option values known in an
- * objv array for merging into a return options dictionary.
- */
-
- for (objc = 0; objc < numOptionWords; objc++) {
- objv[objc] = Tcl_NewObj();
- Tcl_IncrRefCount(objv[objc]);
- if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
- objc++;
- status = TCL_ERROR;
- goto cleanup;
- }
- wordTokenPtr = TokenAfter(wordTokenPtr);
- }
- status = TclMergeReturnOptions(interp, objc, objv,
- &returnOpts, &code, &level);
- cleanup:
- while (--objc >= 0) {
- TclDecrRefCount(objv[objc]);
- }
- TclStackFree(interp, objv);
- if (TCL_ERROR == status) {
- /*
- * Something was bogus in the return options. Clear the error message,
- * and report back to the compiler that this must be interpreted at
- * runtime.
- */
-
- Tcl_ResetResult(interp);
- return TCL_ERROR;
- }
-
- /*
- * All options are known at compile time, so we're going to bytecompile.
- * Emit instructions to push the result on the stack.
- */
-
- if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
- } else {
- /*
- * No explict result argument, so default result is empty string.
- */
-
- PushLiteral(envPtr, "", 0);
- }
-
- /*
- * Check for optimization: When [return] is in a proc, and there's no
- * enclosing [catch], and there are no return options, then the INST_DONE
- * instruction is equivalent, and may be more efficient.
- */
-
- if (numOptionWords == 0 && envPtr->procPtr != NULL) {
- /*
- * We have default return options and we're in a proc ...
- */
-
- int index = envPtr->exceptArrayNext - 1;
- int enclosingCatch = 0;
-
- while (index >= 0) {
- ExceptionRange range = envPtr->exceptArrayPtr[index];
-
- if ((range.type == CATCH_EXCEPTION_RANGE)
- && (range.catchOffset == -1)) {
- enclosingCatch = 1;
- break;
- }
- index--;
- }
- if (!enclosingCatch) {
- /*
- * ... and there is no enclosing catch. Issue the maximally
- * efficient exit instruction.
- */
-
- Tcl_DecrRefCount(returnOpts);
- TclEmitOpcode(INST_DONE, envPtr);
- return TCL_OK;
- }
- }
-
- /* Optimize [return -level 0 $x]. */
- Tcl_DictObjSize(NULL, returnOpts, &size);
- if (size == 0 && level == 0 && code == TCL_OK) {
- Tcl_DecrRefCount(returnOpts);
- return TCL_OK;
- }
-
- /*
- * Could not use the optimization, so we push the return options dict, and
- * emit the INST_RETURN_IMM instruction with code and level as operands.
- */
-
- CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
- return TCL_OK;
-}
-
-static void
-CompileReturnInternal(
- CompileEnv *envPtr,
- unsigned char op,
- int code,
- int level,
- Tcl_Obj *returnOpts)
-{
- TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
- TclEmitInstInt4(op, code, envPtr);
- TclEmitInt4(level, envPtr);
-}
-
-void
-TclCompileSyntaxError(
- Tcl_Interp *interp,
- CompileEnv *envPtr)
-{
- Tcl_Obj *msg = Tcl_GetObjResult(interp);
- int numBytes;
- const char *bytes = TclGetStringFromObj(msg, &numBytes);
-
- TclErrorStackResetIf(interp, bytes, numBytes);
- TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
- CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
- TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileUpvarCmd --
- *
- * Procedure called to compile the "upvar" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "upvar" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileUpvarCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *objPtr = Tcl_NewObj();
-
- if (envPtr->procPtr == NULL) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords < 3) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- /*
- * Push the frame index if it is known at compile time
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- CallFrame *framePtr;
- const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
-
- /*
- * Attempt to convert to a level reference. Note that TclObjGetFrame
- * only changes the obj type when a conversion was successful.
- */
-
- TclObjGetFrame(interp, objPtr, &framePtr);
- newTypePtr = objPtr->typePtr;
- Tcl_DecrRefCount(objPtr);
-
- if (newTypePtr != typePtr) {
- if (numWords%2) {
- return TCL_ERROR;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- otherTokenPtr = TokenAfter(tokenPtr);
- i = 4;
- } else {
- if (!(numWords%2)) {
- return TCL_ERROR;
- }
- PushLiteral(envPtr, "1", 1);
- otherTokenPtr = tokenPtr;
- i = 3;
- }
- } else {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- /*
- * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
- * local variable, return an error so that the non-compiled command will
- * be called at runtime.
- */
-
- for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- if ((localIndex < 0) || !isScalar) {
- return TCL_ERROR;
- }
- TclEmitInstInt4( INST_UPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the frame index, and set the result to empty
- */
-
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileVariableCmd --
- *
- * Procedure called to compile the "variable" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "variable" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileVariableCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr, *valueTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if (numWords < 2) {
- return TCL_ERROR;
- }
-
- /*
- * Bail out if not compiling a proc body
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Loop over the (var, value) pairs.
- */
-
- valueTokenPtr = parsePtr->tokenPtr;
- for (i=1; i<numWords; i+=2) {
- varTokenPtr = TokenAfter(valueTokenPtr);
- valueTokenPtr = TokenAfter(varTokenPtr);
-
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if (localIndex < 0) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, varTokenPtr, interp, i);
- TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
-
- if (i+1 < numWords) {
- /*
- * A value has been given: set the variable, pop the value
- */
-
- CompileWord(envPtr, valueTokenPtr, interp, i+1);
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
- }
-
- /*
- * Set the result to empty
- */
-
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IndexTailVarIfKnown --
- *
- * Procedure used in compiling [global] and [variable] commands. It
- * inspects the variable name described by varTokenPtr and, if the tail
- * is known at compile time, defines a corresponding local variable.
- *
- * Results:
- * Returns the variable's index in the table of compiled locals if the
- * tail is known at compile time, or -1 otherwise.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-IndexTailVarIfKnown(
- Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, /* Token representing the variable name */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Obj *tailPtr;
- const char *tailName, *p;
- int len, n = varTokenPtr->numComponents;
- Tcl_Token *lastTokenPtr;
- int full, localIndex;
-
- /*
- * Determine if the tail is (a) known at compile time, and (b) not an
- * array element. Should any of these fail, return an error so that the
- * non-compiled command will be called at runtime.
- *
- * In order for the tail to be known at compile time, the last token in
- * the word has to be constant and contain "::" if it is not the only one.
- */
-
- if (!EnvHasLVT(envPtr)) {
- return -1;
- }
-
- TclNewObj(tailPtr);
- if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
- full = 1;
- lastTokenPtr = varTokenPtr;
- } else {
- full = 0;
- lastTokenPtr = varTokenPtr + n;
- if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
- }
-
- tailName = TclGetStringFromObj(tailPtr, &len);
-
- if (len) {
- if (*(tailName+len-1) == ')') {
- /*
- * Possible array: bail out
- */
-
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
-
- /*
- * Get the tail: immediately after the last '::'
- */
-
- for (p = tailName + len -1; p > tailName; p--) {
- if ((*p == ':') && (*(p-1) == ':')) {
- p++;
- break;
- }
- }
- if (!full && (p == tailName)) {
- /*
- * No :: in the last component.
- */
-
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
- len -= p - tailName;
- tailName = p;
- }
-
- localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
- Tcl_DecrRefCount(tailPtr);
- return localIndex;
-}
-
-int
-TclCompileObjectSelfCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * We only handle [self] and [self object] (which is the same operation).
- * These are the only very common operations on [self] for which
- * bytecoding is at all reasonable.
- */
-
- if (parsePtr->numWords == 1) {
- goto compileSelfObject;
- } else if (parsePtr->numWords == 2) {
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
- return TCL_ERROR;
- }
-
- subcmd = tokenPtr + 1;
- if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
- goto compileSelfObject;
- } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
- goto compileSelfNamespace;
- }
- }
-
- /*
- * Can't compile; handle with runtime call.
- */
-
- return TCL_ERROR;
-
- compileSelfObject:
-
- /*
- * This delegates the entire problem to a single opcode.
- */
-
- TclEmitOpcode( INST_TCLOO_SELF, envPtr);
- return TCL_OK;
-
- compileSelfNamespace:
-
- /*
- * This is formally only correct with TclOO methods as they are currently
- * implemented; it assumes that the current namespace is invariably when a
- * TclOO context is present is the object's namespace, and that's
- * technically only something that's a matter of current policy. But it
- * avoids creating another opcode, so that's all good!
- */
-
- TclEmitOpcode( INST_TCLOO_SELF, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_NS_CURRENT, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * PushVarName --
+ * TclPushVarName --
*
* Procedure used in the compiling where pushing a variable name is
* necessary (append, lappend, set).
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * The values written to *localIndexPtr and *isScalarPtr signal to
+ * the caller what the instructions emitted by this routine will do:
+ *
+ * *isScalarPtr (*localIndexPtr < 0)
+ * 1 1 Push the varname on the stack. (Stack +1)
+ * 1 0 *localIndexPtr is the index of the compiled
+ * local for this varname. No instructions
+ * emitted. (Stack +0)
+ * 0 1 Push part1 and part2 names of array element
+ * on the stack. (Stack +2)
+ * 0 0 *localIndexPtr is the index of the compiled
+ * local for this array. Element name is pushed
+ * on the stack. (Stack +1)
*
* Side effects:
- * Instructions are added to envPtr to execute the "set" command at
- * runtime.
+ * Instructions are added to envPtr.
*
*----------------------------------------------------------------------
*/
-static int
-PushVarName(
+void
+TclPushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
- int *simpleVarNamePtr, /* Must not be NULL. */
- int *isScalarPtr, /* Must not be NULL. */
- int line, /* Line the token starts on. */
- int *clNext) /* Reference to offset of next hidden cont.
- * line. */
+ int *isScalarPtr) /* Must not be NULL. */
{
register const char *p;
const char *name, *elName;
@@ -6200,8 +3316,7 @@ PushVarName(
*/
if (!hasNsQualifiers) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- 1, envPtr);
+ localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
* We'll push the name.
@@ -6221,12 +3336,10 @@ PushVarName(
if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameChars) {
- envPtr->line = line;
- envPtr->clNext = clNext;
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
}
} else {
@@ -6234,8 +3347,6 @@ PushVarName(
* The var name isn't simple: compile and push it.
*/
- envPtr->line = line;
- envPtr->clNext = clNext;
CompileTokens(envPtr, varTokenPtr, interp);
}
@@ -6246,9 +3357,7 @@ PushVarName(
TclStackFree(interp, elemTokenPtr);
}
*localIndexPtr = localIndex;
- *simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
- return TCL_OK;
}
/*
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
new file mode 100644
index 0000000..150c378
--- /dev/null
+++ b/generic/tclCompCmdsGR.c
@@ -0,0 +1,2896 @@
+/*
+ * tclCompCmdsGR.c --
+ *
+ * This file contains compilation procedures that compile various Tcl
+ * commands (beginning with the letters 'g' through 'r') into a sequence
+ * of instructions ("bytecodes").
+ *
+ * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2002 ActiveState Corporation.
+ * Copyright (c) 2004-2013 by Donal K. Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include <assert.h>
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void CompileReturnInternal(CompileEnv *envPtr,
+ unsigned char op, int code, int level,
+ Tcl_Obj *returnOpts);
+static int IndexTailVarIfKnown(Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, CompileEnv *envPtr);
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileGlobalCmd --
+ *
+ * Procedure called to compile the "global" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "global" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileGlobalCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ int localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ /* TODO: Consider support for compiling expanded args. */
+ numWords = parsePtr->numWords;
+ if (numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 'global' has no effect outside of proc bodies; handle that at runtime
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the namespace
+ */
+
+ PushStringLiteral(envPtr, "::");
+
+ /*
+ * Loop over the variables.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
+
+ if (localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the namespace, and set the result to empty
+ */
+
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIfCmd --
+ *
+ * Procedure called to compile the "if" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "if" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIfCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ JumpFixupArray jumpFalseFixupArray;
+ /* Used to fix the ifFalse jump after each
+ * test when its target PC is determined. */
+ JumpFixupArray jumpEndFixupArray;
+ /* Used to fix the jump after each "then" body
+ * to the end of the "if" when that PC is
+ * determined. */
+ Tcl_Token *tokenPtr, *testTokenPtr;
+ int jumpIndex = 0; /* Avoid compiler warning. */
+ int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
+ const char *word;
+ int realCond = 1; /* Set to 0 for static conditions:
+ * "if 0 {..}" */
+ int boolVal; /* Value of static condition. */
+ int compileScripts = 1;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Only compile the "if" command if all arguments are simple words, in
+ * order to insure correct substitution [Bug 219166]
+ */
+
+ tokenPtr = parsePtr->tokenPtr;
+ wordIdx = 0;
+ numWords = parsePtr->numWords;
+
+ for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ TclInitJumpFixupArray(&jumpFalseFixupArray);
+ TclInitJumpFixupArray(&jumpEndFixupArray);
+ code = TCL_OK;
+
+ /*
+ * Each iteration of this loop compiles one "if expr ?then? body" or
+ * "elseif expr ?then? body" clause.
+ */
+
+ tokenPtr = parsePtr->tokenPtr;
+ wordIdx = 0;
+ while (wordIdx < numWords) {
+ /*
+ * Stop looping if the token isn't "if" or "elseif".
+ */
+
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((tokenPtr == parsePtr->tokenPtr)
+ || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
+ tokenPtr = TokenAfter(tokenPtr);
+ wordIdx++;
+ } else {
+ break;
+ }
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Compile the test expression then emit the conditional jump around
+ * the "then" part.
+ */
+
+ testTokenPtr = tokenPtr;
+
+ if (realCond) {
+ /*
+ * Find out if the condition is a constant.
+ */
+
+ Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
+ testTokenPtr[1].size);
+
+ Tcl_IncrRefCount(boolObj);
+ code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
+ TclDecrRefCount(boolObj);
+ if (code == TCL_OK) {
+ /*
+ * A static condition.
+ */
+
+ realCond = 0;
+ if (!boolVal) {
+ compileScripts = 0;
+ }
+ } else {
+ SetLineInformation(wordIdx);
+ Tcl_ResetResult(interp);
+ TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFalseFixupArray);
+ }
+ jumpIndex = jumpFalseFixupArray.next;
+ jumpFalseFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ jumpFalseFixupArray.fixup+jumpIndex);
+ }
+ code = TCL_OK;
+ }
+
+ /*
+ * Skip over the optional "then" before the then clause.
+ */
+
+ tokenPtr = TokenAfter(testTokenPtr);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
+ tokenPtr = TokenAfter(tokenPtr);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ /*
+ * Compile the "then" command body.
+ */
+
+ if (compileScripts) {
+ BODY(tokenPtr, wordIdx);
+ }
+
+ if (realCond) {
+ /*
+ * Jump to the end of the "if" command. Both jumpFalseFixupArray
+ * and jumpEndFixupArray are indexed by "jumpIndex".
+ */
+
+ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpEndFixupArray);
+ }
+ jumpEndFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ jumpEndFixupArray.fixup+jumpIndex);
+
+ /*
+ * Fix the target of the jumpFalse after the test. Generate a 4
+ * byte jump if the distance is > 120 bytes. This is conservative,
+ * and ensures that we won't have to replace this jump if we later
+ * also need to replace the proceeding jump to the end of the "if"
+ * with a 4 byte jump.
+ */
+
+ TclAdjustStackDepth(-1, envPtr);
+ if (TclFixupForwardJumpToHere(envPtr,
+ jumpFalseFixupArray.fixup+jumpIndex, 120)) {
+ /*
+ * Adjust the code offset for the proceeding jump to the end
+ * of the "if" command.
+ */
+
+ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
+ }
+ } else if (boolVal) {
+ /*
+ * We were processing an "if 1 {...}"; stop compiling scripts.
+ */
+
+ compileScripts = 0;
+ } else {
+ /*
+ * We were processing an "if 0 {...}"; reset so that the rest
+ * (elseif, else) is compiled correctly.
+ */
+
+ realCond = 1;
+ compileScripts = 1;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ wordIdx++;
+ }
+
+ /*
+ * Check for the optional else clause. Do not compile anything if this was
+ * an "if 1 {...}" case.
+ */
+
+ if ((wordIdx < numWords) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
+ /*
+ * There is an else clause. Skip over the optional "else" word.
+ */
+
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
+ tokenPtr = TokenAfter(tokenPtr);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ if (compileScripts) {
+ /*
+ * Compile the else command body.
+ */
+
+ BODY(tokenPtr, wordIdx);
+ }
+
+ /*
+ * Make sure there are no words after the else clause.
+ */
+
+ wordIdx++;
+ if (wordIdx < numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ } else {
+ /*
+ * No else clause: the "if" command's result is an empty string.
+ */
+
+ if (compileScripts) {
+ PushStringLiteral(envPtr, "");
+ }
+ }
+
+ /*
+ * Fix the unconditional jumps to the end of the "if" command.
+ */
+
+ for (j = jumpEndFixupArray.next; j > 0; j--) {
+ jumpIndex = (j - 1); /* i.e. process the closest jump first. */
+ if (TclFixupForwardJumpToHere(envPtr,
+ jumpEndFixupArray.fixup+jumpIndex, 127)) {
+ /*
+ * Adjust the immediately preceeding "ifFalse" jump. We moved it's
+ * target (just after this jump) down three bytes.
+ */
+
+ unsigned char *ifFalsePc = envPtr->codeStart
+ + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
+ unsigned char opCode = *ifFalsePc;
+
+ if (opCode == INST_JUMP_FALSE1) {
+ jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
+ jumpFalseDist += 3;
+ TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
+ } else if (opCode == INST_JUMP_FALSE4) {
+ jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
+ jumpFalseDist += 3;
+ TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
+ } else {
+ Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
+ }
+ }
+ }
+
+ /*
+ * Free the jumpFixupArray array if malloc'ed storage was used.
+ */
+
+ done:
+ TclFreeJumpFixupArray(&jumpFalseFixupArray);
+ TclFreeJumpFixupArray(&jumpEndFixupArray);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIncrCmd --
+ *
+ * Procedure called to compile the "incr" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "incr" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIncrCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *incrTokenPtr;
+ int isScalar, localIndex, haveImmValue, immValue;
+ DefineLineInformation; /* TIP #280 */
+
+ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
+ return TCL_ERROR;
+ }
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
+ &localIndex, &isScalar, 1);
+
+ /*
+ * If an increment is given, push it, but see first if it's a small
+ * integer.
+ */
+
+ haveImmValue = 0;
+ immValue = 1;
+ if (parsePtr->numWords == 3) {
+ incrTokenPtr = TokenAfter(varTokenPtr);
+ if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ const char *word = incrTokenPtr[1].start;
+ int numBytes = incrTokenPtr[1].size;
+ int code;
+ Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
+
+ Tcl_IncrRefCount(intObj);
+ code = TclGetIntFromObj(NULL, intObj, &immValue);
+ TclDecrRefCount(intObj);
+ if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
+ haveImmValue = 1;
+ }
+ if (!haveImmValue) {
+ PushLiteral(envPtr, word, numBytes);
+ }
+ } else {
+ SetLineInformation(2);
+ CompileTokens(envPtr, incrTokenPtr, interp);
+ }
+ } else { /* No incr amount given so use 1. */
+ haveImmValue = 1;
+ }
+
+ /*
+ * Emit the instruction to increment the variable.
+ */
+
+ if (isScalar) { /* Simple scalar variable. */
+ if (localIndex >= 0) {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
+ TclEmitInt1(immValue, envPtr);
+ } else {
+ TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
+ }
+ } else {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
+ } else {
+ TclEmitOpcode( INST_INCR_STK, envPtr);
+ }
+ }
+ } else { /* Simple array variable. */
+ if (localIndex >= 0) {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
+ TclEmitInt1(immValue, envPtr);
+ } else {
+ TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
+ }
+ } else {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
+ } else {
+ TclEmitOpcode( INST_INCR_ARRAY_STK, envPtr);
+ }
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileInfo*Cmd --
+ *
+ * Procedures called to compile "info" subcommands.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "info" subcommand at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileInfoCommandsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ Tcl_Obj *objPtr;
+ char *bytes;
+
+ /*
+ * We require one compile-time known argument for the case we can compile.
+ */
+
+ if (parsePtr->numWords == 1) {
+ return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ } else if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ objPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(objPtr);
+ if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ goto notCompilable;
+ }
+ bytes = Tcl_GetString(objPtr);
+
+ /*
+ * We require that the argument start with "::" and not have any of "*\[?"
+ * in it. (Theoretically, we should look in only the final component, but
+ * the difference is so slight given current naming practices.)
+ */
+
+ if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
+ goto notCompilable;
+ }
+ Tcl_DecrRefCount(objPtr);
+
+ /*
+ * Confirmed as a literal that will not frighten the horses. Compile. Note
+ * that the result needs to be list-ified.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_STR_LEN, envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr);
+ TclEmitInstInt4( INST_LIST, 1, envPtr);
+ return TCL_OK;
+
+ notCompilable:
+ Tcl_DecrRefCount(objPtr);
+ return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileInfoCoroutineCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [info coroutine] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoExistsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int isScalar, localIndex;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we need
+ * to emit code to compute and push the name at runtime. We use a frame
+ * slot (entry in the array of local vars) if we are compiling a procedure
+ * body and if the name is simple text that does not include namespace
+ * qualifiers.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1);
+
+ /*
+ * Emit instruction to check the variable for existence.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_EXIST_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+int
+TclCompileInfoLevelCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [info level] without arguments or with a single argument.
+ */
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
+ } else if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ } else {
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Compile the argument, then add the instruction to convert it into a
+ * list of arguments.
+ */
+
+ CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1);
+ TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectClassCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectIsACmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * We only handle [info object isa object <somevalue>]. The first three
+ * words are compressed to a single token by the ensemble compilation
+ * engine.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
+ || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Issue the code.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectNamespaceCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_NS, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLappendCmd --
+ *
+ * Procedure called to compile the "lappend" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lappend" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLappendCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int isScalar, localIndex, numWords, i, fwd, offsetFwd;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * If we're not in a procedure, don't compile.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* TODO: Consider support for compiling expanded args. */
+ numWords = parsePtr->numWords;
+ if (numWords == 1) {
+ return TCL_ERROR;
+ }
+ if (numWords != 3) {
+ /*
+ * LAPPEND instructions currently only handle one value, but we can
+ * handle some multi-value cases by stringing them together.
+ */
+
+ goto lappendMultiple;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
+
+ /*
+ * If we are doing an assignment, push the new value. In the no values
+ * case, create an empty object.
+ */
+
+ if (numWords > 2) {
+ Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
+
+ CompileWord(envPtr, valueTokenPtr, interp, 2);
+ }
+
+ /*
+ * Emit instructions to set/get the variable.
+ */
+
+ /*
+ * The *_STK opcodes should be refactored to make better use of existing
+ * LOAD/STORE instructions.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ return TCL_OK;
+
+ lappendMultiple:
+ /*
+ * Can only handle the case where we are appending to a local scalar when
+ * there are multiple values to append. Fortunately, this is common.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar || localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Definitely appending to a local scalar; generate the words and append
+ * them.
+ */
+
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ for (i = 2 ; i < numWords ; i++) {
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
+ TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLassignCmd --
+ *
+ * Procedure called to compile the "lassign" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lassign" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLassignCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int isScalar, localIndex, numWords, idx;
+ DefineLineInformation; /* TIP #280 */
+
+ numWords = parsePtr->numWords;
+
+ /*
+ * Check for command syntax error, but we'll punt that to runtime.
+ */
+
+ if (numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Generate code to push list being taken apart by [lassign].
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Generate code to assign values from the list to variables.
+ */
+
+ for (idx=0 ; idx<numWords-2 ; idx++) {
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Generate the next variable name.
+ */
+
+ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
+ &isScalar, idx+2);
+
+ /*
+ * Emit instructions to get the idx'th item out of the list value on
+ * the stack and assign it to the variable.
+ */
+
+ if (isScalar) {
+ if (localIndex >= 0) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ } else {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ } else {
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ } else {
+ TclEmitInstInt4(INST_OVER, 2, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ }
+ }
+
+ /*
+ * Generate code to leave the rest of the list on the stack.
+ */
+
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
+ TclEmitInt4( -2 /* == "end" */, envPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLindexCmd --
+ *
+ * Procedure called to compile the "lindex" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lindex" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLindexCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *idxTokenPtr, *valTokenPtr;
+ int i, numWords = parsePtr->numWords;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Quit if too few args.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (numWords <= 1) {
+ return TCL_ERROR;
+ }
+
+ valTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (numWords != 3) {
+ goto emitComplexLindex;
+ }
+
+ idxTokenPtr = TokenAfter(valTokenPtr);
+ if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_Obj *tmpObj;
+ int idx, result;
+
+ tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx);
+ if (result == TCL_OK) {
+ if (idx < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx);
+ if (result == TCL_OK && idx > -2) {
+ result = TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(tmpObj);
+
+ if (result == TCL_OK) {
+ /*
+ * All checks have been completed, and we have exactly one of
+ * these constructs:
+ * lindex <arbitraryValue> <posInt>
+ * lindex <arbitraryValue> end-<posInt>
+ * This is best compiled as a push of the arbitrary value followed
+ * by an "immediate lindex" which is the most efficient variety.
+ */
+
+ CompileWord(envPtr, valTokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * If the conversion failed or the value was negative, we just keep on
+ * going with the more complex compilation.
+ */
+ }
+
+ /*
+ * Push the operands onto the stack.
+ */
+
+ emitComplexLindex:
+ for (i=1 ; i<numWords ; i++) {
+ CompileWord(envPtr, valTokenPtr, interp, i);
+ valTokenPtr = TokenAfter(valTokenPtr);
+ }
+
+ /*
+ * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
+ * multiple index args.
+ */
+
+ if (numWords == 3) {
+ TclEmitOpcode( INST_LIST_INDEX, envPtr);
+ } else {
+ TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileListCmd --
+ *
+ * Procedure called to compile the "list" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "list" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileListCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *valueTokenPtr;
+ int i, numWords, concat, build;
+ Tcl_Obj *listObj, *objPtr;
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * [list] without arguments just pushes an empty object.
+ */
+
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+ }
+
+ /*
+ * Test if all arguments are compile-time known. If they are, we can
+ * implement with a simple push.
+ */
+
+ numWords = parsePtr->numWords;
+ valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ listObj = Tcl_NewObj();
+ for (i = 1; i < numWords && listObj != NULL; i++) {
+ objPtr = Tcl_NewObj();
+ if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) {
+ (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
+ } else {
+ Tcl_DecrRefCount(objPtr);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
+ }
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ if (listObj != NULL) {
+ int len;
+ const char *bytes = Tcl_GetStringFromObj(listObj, &len);
+
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(listObj);
+ if (len > 0) {
+ /*
+ * Force list interpretation!
+ */
+
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Push the all values onto the stack.
+ */
+
+ 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);
+ }
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLlengthCmd --
+ *
+ * Procedure called to compile the "llength" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "llength" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLlengthCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLrangeCmd --
+ *
+ * How to compile the "lrange" command. We only bother because we needed
+ * the opcode anyway for "lassign".
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLrangeCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *listTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Obj *tmpObj;
+ int idx1, idx2, result;
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+ listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Parse the first index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing).
+ */
+
+ tokenPtr = TokenAfter(listTokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx1);
+ if (result == TCL_OK) {
+ if (idx1 < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
+ if (result == TCL_OK && idx1 > -2) {
+ result = TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(tmpObj);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the second index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing).
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx2);
+ if (result == TCL_OK) {
+ if (idx2 < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
+ if (result == TCL_OK && idx2 > -2) {
+ result = TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(tmpObj);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
+ * we've not proved that the 'list' argument is really a list. Not that it
+ * is worth trying to do that given current knowledge.
+ */
+
+ CompileWord(envPtr, listTokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
+ TclEmitInt4( idx2, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLreplaceCmd --
+ *
+ * How to compile the "lreplace" command. We only bother with the case
+ * where there are no elements to insert and where both the 'first' and
+ * 'last' arguments are constant and one can be deterined to be at the
+ * end of the list. (This is the case that could also be written with
+ * "lrange".)
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLreplaceCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *listTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Obj *tmpObj;
+ int idx1, idx2, result, guaranteedDropAll = 0;
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+ listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Parse the first index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing).
+ */
+
+ tokenPtr = TokenAfter(listTokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx1);
+ if (result == TCL_OK) {
+ if (idx1 < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
+ if (result == TCL_OK && idx1 > -2) {
+ result = TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(tmpObj);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the second index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing).
+ */
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+ result = TclGetIntFromObj(NULL, tmpObj, &idx2);
+ if (result == TCL_OK) {
+ if (idx2 < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
+ if (result == TCL_OK && idx2 > -2) {
+ result = TCL_ERROR;
+ }
+ }
+ TclDecrRefCount(tmpObj);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Sanity check: can only issue when we're removing a range at one or
+ * other end of the list. If we're at one end or the other, convert the
+ * indices into the equivalent for an [lrange].
+ */
+
+ if (idx1 == 0) {
+ if (idx2 == -2) {
+ guaranteedDropAll = 1;
+ }
+ idx1 = idx2 + 1;
+ idx2 = -2;
+ } else if (idx2 == -2) {
+ idx2 = idx1 - 1;
+ idx1 = 0;
+ } else {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
+ * we've not proved that the 'list' argument is really a list. Not that it
+ * is worth trying to do that given current knowledge.
+ */
+
+ CompileWord(envPtr, listTokenPtr, interp, 1);
+ if (guaranteedDropAll) {
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ } else {
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
+ TclEmitInt4( idx2, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLsetCmd --
+ *
+ * Procedure called to compile the "lset" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lset" command at
+ * runtime.
+ *
+ * The general template for execution of the "lset" command is:
+ * (1) Instructions to push the variable name, unless the variable is
+ * local to the stack frame.
+ * (2) If the variable is an array element, instructions to push the
+ * array element name.
+ * (3) Instructions to push each of zero or more "index" arguments to the
+ * stack, followed with the "newValue" element.
+ * (4) Instructions to duplicate the variable name and/or array element
+ * name onto the top of the stack, if either was pushed at steps (1)
+ * and (2).
+ * (5) The appropriate INST_LOAD_* instruction to place the original
+ * value of the list variable at top of stack.
+ * (6) At this point, the stack contains:
+ * varName? arrayElementName? index1 index2 ... newValue oldList
+ * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
+ * according as whether there is exactly one index element (LIST) or
+ * either zero or else two or more (FLAT). This instruction removes
+ * everything from the stack except for the two names and pushes the
+ * new value of the variable.
+ * (7) Finally, INST_STORE_* stores the new value in the variable and
+ * cleans up the stack.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLsetCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ int tempDepth; /* Depth used for emitting one part of the
+ * code burst. */
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
+ * parse of the variable name. */
+ int localIndex; /* Index of var in local var table. */
+ int isScalar; /* Flag == 1 if scalar, 0 if array. */
+ int i;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Check argument count.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 3) {
+ /*
+ * Fail at run time, not in compilation.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we need
+ * to emit code to compute and push the name at runtime. We use a frame
+ * slot (entry in the array of local vars) if we are compiling a procedure
+ * body and if the name is simple text that does not include namespace
+ * qualifiers.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
+
+ /*
+ * Push the "index" args and the new element value.
+ */
+
+ for (i=2 ; i<parsePtr->numWords ; ++i) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, varTokenPtr, interp, i);
+ }
+
+ /*
+ * Duplicate the variable name if it's been pushed.
+ */
+
+ if (localIndex < 0) {
+ if (isScalar) {
+ tempDepth = parsePtr->numWords - 2;
+ } else {
+ tempDepth = parsePtr->numWords - 1;
+ }
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
+ }
+
+ /*
+ * Duplicate an array index if one's been pushed.
+ */
+
+ if (!isScalar) {
+ if (localIndex < 0) {
+ tempDepth = parsePtr->numWords - 1;
+ } else {
+ tempDepth = parsePtr->numWords - 2;
+ }
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
+ }
+
+ /*
+ * Emit code to load the variable's value.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ /*
+ * Emit the correct variety of 'lset' instruction.
+ */
+
+ if (parsePtr->numWords == 4) {
+ TclEmitOpcode( INST_LSET_LIST, envPtr);
+ } else {
+ TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
+ }
+
+ /*
+ * Emit code to put the value back in the variable.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_STORE_STK, envPtr);
+ } else {
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileNamespace*Cmd --
+ *
+ * Procedures called to compile the "namespace" command; currently, only
+ * the subcommands "namespace current" and "namespace upvar" are compiled
+ * to bytecodes, and the latter only inside a procedure(-like) context.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "namespace upvar"
+ * command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileNamespaceCurrentCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [namespace current] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceCodeCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * The specification of [namespace code] is rather shocking, in that it is
+ * supposed to check if the argument is itself the result of [namespace
+ * code] and not apply itself in that case. Which is excessively cautious,
+ * but what the test suite checks for.
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
+ && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
+ /*
+ * Technically, we could just pass a literal '::namespace inscope '
+ * term through, but that's something which really shouldn't be
+ * occurring as something that the user writes so we'll just punt it.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now we can compile using the same strategy as [namespace code]'s normal
+ * implementation does internally. Note that we can't bind the namespace
+ * name directly here, because TclOO plays complex games with namespaces;
+ * the value needs to be determined at runtime for safety.
+ */
+
+ PushStringLiteral(envPtr, "::namespace");
+ PushStringLiteral(envPtr, "inscope");
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST, 4, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceQualifiersCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+ int off;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ PushStringLiteral(envPtr, "0");
+ PushStringLiteral(envPtr, "::");
+ TclEmitInstInt4( INST_OVER, 2, envPtr);
+ TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
+ off = CurrentOffset(envPtr);
+ PushStringLiteral(envPtr, "1");
+ TclEmitOpcode( INST_SUB, envPtr);
+ TclEmitInstInt4( INST_OVER, 2, envPtr);
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_STR_INDEX, envPtr);
+ PushStringLiteral(envPtr, ":");
+ TclEmitOpcode( INST_STR_EQ, envPtr);
+ off = off - CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr);
+ TclEmitOpcode( INST_STR_RANGE, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceTailCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+ JumpFixup jumpFixup;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Take care; only add 2 to found index if the string was actually found.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ PushStringLiteral(envPtr, "::");
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ PushStringLiteral(envPtr, "0");
+ TclEmitOpcode( INST_GE, envPtr);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
+ PushStringLiteral(envPtr, "2");
+ TclEmitOpcode( INST_ADD, envPtr);
+ TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+ PushStringLiteral(envPtr, "end");
+ TclEmitOpcode( INST_STR_RANGE, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceUpvarCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
+ int isScalar, localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Only compile [namespace upvar ...]: needs an even number of args, >=4
+ */
+
+ numWords = parsePtr->numWords;
+ if ((numWords % 2) || (numWords < 4)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the namespace
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
+ * local variable, return an error so that the non-compiled command will
+ * be called at runtime.
+ */
+
+ localTokenPtr = tokenPtr;
+ for (i=3; i<=numWords; i+=2) {
+ otherTokenPtr = TokenAfter(localTokenPtr);
+ localTokenPtr = TokenAfter(otherTokenPtr);
+
+ CompileWord(envPtr, otherTokenPtr, interp, 1);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
+
+ if ((localIndex < 0) || !isScalar) {
+ return TCL_ERROR;
+ }
+ TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the namespace, and set the result to empty
+ */
+
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceWhichCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr, *opt;
+ int idx;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ idx = 1;
+
+ /*
+ * If there's an option, check that it's "-command". We don't handle
+ * "-variable" (currently) and anything else is an error.
+ */
+
+ if (parsePtr->numWords == 3) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ opt = tokenPtr + 1;
+ if (opt->size < 2 || opt->size > 8
+ || strncmp(opt->start, "-command", opt->size) != 0) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ idx++;
+ }
+
+ /*
+ * Issue the bytecode.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, idx);
+ TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileRegexpCmd --
+ *
+ * Procedure called to compile the "regexp" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "regexp" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegexpCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
+ * parse of the RE or string. */
+ int i, len, nocase, exact, sawLast, simple;
+ const char *str;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * We are only interested in compiling simple regexp cases. Currently
+ * supported compile cases are:
+ * regexp ?-nocase? ?--? staticString $var
+ * regexp ?-nocase? ?--? {^staticString$} $var
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ simple = 0;
+ nocase = 0;
+ sawLast = 0;
+ varTokenPtr = parsePtr->tokenPtr;
+
+ /*
+ * We only look for -nocase and -- as options. Everything else gets pushed
+ * to runtime execution. This is different than regexp's runtime option
+ * handling, but satisfies our stricter needs.
+ */
+
+ for (i = 1; i < parsePtr->numWords - 2; i++) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Not a simple string, so punt to runtime.
+ */
+
+ return TCL_ERROR;
+ }
+ str = varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+ if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
+ sawLast++;
+ i++;
+ break;
+ } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
+ nocase = 1;
+ } else {
+ /*
+ * Not an option we recognize.
+ */
+
+ return TCL_ERROR;
+ }
+ }
+
+ if ((parsePtr->numWords - i) != 2) {
+ /*
+ * We don't support capturing to variables.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the regexp string. If it is not a simple string or can't be
+ * converted to a glob pattern, push the word for the INST_REGEXP.
+ * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
+ */
+
+ varTokenPtr = TokenAfter(varTokenPtr);
+
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_DString ds;
+
+ str = varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+
+ /*
+ * If it has a '-', it could be an incorrectly formed regexp command.
+ */
+
+ if ((*str == '-') && !sawLast) {
+ return TCL_ERROR;
+ }
+
+ if (len == 0) {
+ /*
+ * The semantics of regexp are always match on re == "".
+ */
+
+ PushStringLiteral(envPtr, "1");
+ return TCL_OK;
+ }
+
+ /*
+ * Attempt to convert pattern to glob. If successful, push the
+ * converted pattern as a literal.
+ */
+
+ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
+ == TCL_OK) {
+ simple = 1;
+ PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+ }
+
+ if (!simple) {
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+ }
+
+ /*
+ * Push the string arg.
+ */
+
+ varTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+
+ if (simple) {
+ if (exact && !nocase) {
+ TclEmitOpcode( INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr);
+ }
+ } else {
+ /*
+ * Pass correct RE compile flags. We use only Int1 (8-bit), but
+ * that handles all the flags we want to pass.
+ * Don't use TCL_REG_NOSUB as we may have backrefs.
+ */
+
+ int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
+
+ TclEmitInstInt1( INST_REGEXP, cflags, envPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileRegsubCmd --
+ *
+ * Procedure called to compile the "regsub" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "regsub" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegsubCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ /*
+ * We only compile the case with [regsub -all] where the pattern is both
+ * known at compile time and simple (i.e., no RE metacharacters). That is,
+ * the pattern must be translatable into a glob like "*foo*" with no other
+ * glob metacharacters inside it; there must be some "foo" in there too.
+ * The substitution string must also be known at compile time and free of
+ * metacharacters ("\digit" and "&"). Finally, there must not be a
+ * variable mentioned in the [regsub] to write the result back to (because
+ * we can't get the count of substitutions that would be the result in
+ * that case). The key is that these are the conditions under which a
+ * [string map] could be used instead, in particular a [string map] of the
+ * form we can compile to bytecode.
+ *
+ * In short, we look for:
+ *
+ * regsub -all [--] simpleRE string simpleReplacement
+ *
+ * The only optional part is the "--", and no other options are handled.
+ */
+
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr, *stringTokenPtr;
+ Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
+ Tcl_DString pattern;
+ const char *bytes;
+ int len, exact, result = TCL_ERROR;
+
+ if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the "-all", which must be the first argument (other options not
+ * supported, non-"-all" substitution we can't compile).
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
+ || strncmp(tokenPtr[1].start, "-all", 4)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the pattern into patternObj, checking for "--" in the process.
+ */
+
+ Tcl_DStringInit(&pattern);
+ tokenPtr = TokenAfter(tokenPtr);
+ patternObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+ goto done;
+ }
+ if (Tcl_GetString(patternObj)[0] == '-') {
+ if (strcmp(Tcl_GetString(patternObj), "--") != 0
+ || parsePtr->numWords == 5) {
+ goto done;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ Tcl_DecrRefCount(patternObj);
+ patternObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+ goto done;
+ }
+ } else if (parsePtr->numWords == 6) {
+ goto done;
+ }
+
+ /*
+ * Identify the code which produces the string to apply the substitution
+ * to (stringTokenPtr), and the replacement string (into replacementObj).
+ */
+
+ stringTokenPtr = TokenAfter(tokenPtr);
+ tokenPtr = TokenAfter(stringTokenPtr);
+ replacementObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
+ goto done;
+ }
+
+ /*
+ * Next, higher-level checks. Is the RE a very simple glob? Is the
+ * replacement "simple"?
+ */
+
+ bytes = Tcl_GetStringFromObj(patternObj, &len);
+ if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
+ goto done;
+ }
+ bytes = Tcl_DStringValue(&pattern);
+ if (*bytes++ != '*') {
+ goto done;
+ }
+ while (1) {
+ switch (*bytes) {
+ case '*':
+ if (bytes[1] == '\0') {
+ /*
+ * OK, we've proved there are no metacharacters except for the
+ * '*' at each end.
+ */
+
+ len = Tcl_DStringLength(&pattern) - 2;
+ if (len > 0) {
+ goto isSimpleGlob;
+ }
+
+ /*
+ * The pattern is "**"! I believe that should be impossible,
+ * but we definitely can't handle that at all.
+ */
+ }
+ case '\0': case '?': case '[': case '\\':
+ goto done;
+ }
+ bytes++;
+ }
+ isSimpleGlob:
+ for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ switch (*bytes) {
+ case '\\': case '&':
+ goto done;
+ }
+ }
+
+ /*
+ * Proved the simplicity constraints! Time to issue the code.
+ */
+
+ result = TCL_OK;
+ bytes = Tcl_DStringValue(&pattern) + 1;
+ PushLiteral(envPtr, bytes, len);
+ bytes = Tcl_GetStringFromObj(replacementObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
+ TclEmitOpcode( INST_STR_MAP, envPtr);
+
+ done:
+ Tcl_DStringFree(&pattern);
+ if (patternObj) {
+ Tcl_DecrRefCount(patternObj);
+ }
+ if (replacementObj) {
+ Tcl_DecrRefCount(replacementObj);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileReturnCmd --
+ *
+ * Procedure called to compile the "return" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "return" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileReturnCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * General syntax: [return ?-option value ...? ?result?]
+ * An even number of words means an explicit result argument is present.
+ */
+ int level, code, objc, size, status = TCL_OK;
+ int numWords = parsePtr->numWords;
+ int explicitResult = (0 == (numWords % 2));
+ int numOptionWords = numWords - 1 - explicitResult;
+ Tcl_Obj *returnOpts, **objv;
+ Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Check for special case which can always be compiled:
+ * return -options <opts> <msg>
+ * Unlike the normal [return] compilation, this version does everything at
+ * runtime so it can handle arbitrary words and not just literals. Note
+ * that if INST_RETURN_STK wasn't already needed for something else
+ * ('finally' clause processing) this piece of code would not be present.
+ */
+
+ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
+ && (wordTokenPtr[1].size == 8)
+ && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
+ Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
+ Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
+
+ CompileWord(envPtr, optsTokenPtr, interp, 2);
+ CompileWord(envPtr, msgTokenPtr, interp, 3);
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Allocate some working space.
+ */
+
+ objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
+
+ /*
+ * Scan through the return options. If any are unknown at compile time,
+ * there is no value in bytecompiling. Save the option values known in an
+ * objv array for merging into a return options dictionary.
+ */
+
+ for (objc = 0; objc < numOptionWords; objc++) {
+ objv[objc] = Tcl_NewObj();
+ Tcl_IncrRefCount(objv[objc]);
+ if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
+ /*
+ * Non-literal, so punt to run-time.
+ */
+
+ for (; objc>=0 ; objc--) {
+ TclDecrRefCount(objv[objc]);
+ }
+ TclStackFree(interp, objv);
+ goto issueRuntimeReturn;
+ }
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ status = TclMergeReturnOptions(interp, objc, objv,
+ &returnOpts, &code, &level);
+ while (--objc >= 0) {
+ TclDecrRefCount(objv[objc]);
+ }
+ TclStackFree(interp, objv);
+ if (TCL_ERROR == status) {
+ /*
+ * Something was bogus in the return options. Clear the error message,
+ * and report back to the compiler that this must be interpreted at
+ * runtime.
+ */
+
+ Tcl_ResetResult(interp);
+ return TCL_ERROR;
+ }
+
+ /*
+ * All options are known at compile time, so we're going to bytecompile.
+ * Emit instructions to push the result on the stack.
+ */
+
+ if (explicitResult) {
+ CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ } else {
+ /*
+ * No explict result argument, so default result is empty string.
+ */
+
+ PushStringLiteral(envPtr, "");
+ }
+
+ /*
+ * Check for optimization: When [return] is in a proc, and there's no
+ * enclosing [catch], and there are no return options, then the INST_DONE
+ * instruction is equivalent, and may be more efficient.
+ */
+
+ if (numOptionWords == 0 && envPtr->procPtr != NULL) {
+ /*
+ * We have default return options and we're in a proc ...
+ */
+
+ int index = envPtr->exceptArrayNext - 1;
+ int enclosingCatch = 0;
+
+ while (index >= 0) {
+ ExceptionRange range = envPtr->exceptArrayPtr[index];
+
+ if ((range.type == CATCH_EXCEPTION_RANGE)
+ && (range.catchOffset == -1)) {
+ enclosingCatch = 1;
+ break;
+ }
+ index--;
+ }
+ if (!enclosingCatch) {
+ /*
+ * ... and there is no enclosing catch. Issue the maximally
+ * efficient exit instruction.
+ */
+
+ Tcl_DecrRefCount(returnOpts);
+ TclEmitOpcode(INST_DONE, envPtr);
+ TclAdjustStackDepth(1, envPtr);
+ return TCL_OK;
+ }
+ }
+
+ /* Optimize [return -level 0 $x]. */
+ Tcl_DictObjSize(NULL, returnOpts, &size);
+ if (size == 0 && level == 0 && code == TCL_OK) {
+ Tcl_DecrRefCount(returnOpts);
+ return TCL_OK;
+ }
+
+ /*
+ * Could not use the optimization, so we push the return options dict, and
+ * emit the INST_RETURN_IMM instruction with code and level as operands.
+ */
+
+ CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
+ return TCL_OK;
+
+ issueRuntimeReturn:
+ /*
+ * Assemble the option dictionary (as a list as that's good enough).
+ */
+
+ wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (objc=1 ; objc<=numOptionWords ; objc++) {
+ CompileWord(envPtr, wordTokenPtr, interp, objc);
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ TclEmitInstInt4(INST_LIST, numOptionWords, envPtr);
+
+ /*
+ * Push the result.
+ */
+
+ if (explicitResult) {
+ CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
+
+ /*
+ * Issue the RETURN itself.
+ */
+
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ return TCL_OK;
+}
+
+static void
+CompileReturnInternal(
+ CompileEnv *envPtr,
+ unsigned char op,
+ int code,
+ int level,
+ Tcl_Obj *returnOpts)
+{
+ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
+ TclEmitInstInt4(op, code, envPtr);
+ TclEmitInt4(level, envPtr);
+}
+
+void
+TclCompileSyntaxError(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr)
+{
+ Tcl_Obj *msg = Tcl_GetObjResult(interp);
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(msg, &numBytes);
+
+ TclErrorStackResetIf(interp, bytes, numBytes);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
+ CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
+ TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
+ Tcl_ResetResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileUpvarCmd --
+ *
+ * Procedure called to compile the "upvar" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "upvar" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileUpvarCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
+ int isScalar, localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ if (envPtr->procPtr == NULL) {
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ numWords = parsePtr->numWords;
+ if (numWords < 3) {
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the frame index if it is known at compile time
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ CallFrame *framePtr;
+ const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
+
+ /*
+ * Attempt to convert to a level reference. Note that TclObjGetFrame
+ * only changes the obj type when a conversion was successful.
+ */
+
+ TclObjGetFrame(interp, objPtr, &framePtr);
+ newTypePtr = objPtr->typePtr;
+ Tcl_DecrRefCount(objPtr);
+
+ if (newTypePtr != typePtr) {
+ if (numWords%2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ otherTokenPtr = TokenAfter(tokenPtr);
+ i = 4;
+ } else {
+ if (!(numWords%2)) {
+ return TCL_ERROR;
+ }
+ PushStringLiteral(envPtr, "1");
+ otherTokenPtr = tokenPtr;
+ i = 3;
+ }
+ } else {
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
+ * local variable, return an error so that the non-compiled command will
+ * be called at runtime.
+ */
+
+ for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
+ localTokenPtr = TokenAfter(otherTokenPtr);
+
+ CompileWord(envPtr, otherTokenPtr, interp, 1);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
+
+ if ((localIndex < 0) || !isScalar) {
+ return TCL_ERROR;
+ }
+ TclEmitInstInt4( INST_UPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the frame index, and set the result to empty
+ */
+
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileVariableCmd --
+ *
+ * Procedure called to compile the "variable" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "variable" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileVariableCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ numWords = parsePtr->numWords;
+ if (numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Bail out if not compiling a proc body
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Loop over the (var, value) pairs.
+ */
+
+ valueTokenPtr = parsePtr->tokenPtr;
+ for (i=1; i<numWords; i+=2) {
+ varTokenPtr = TokenAfter(valueTokenPtr);
+ valueTokenPtr = TokenAfter(varTokenPtr);
+
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
+
+ if (localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ CompileWord(envPtr, varTokenPtr, interp, i);
+ TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
+
+ if (i+1 < numWords) {
+ /*
+ * A value has been given: set the variable, pop the value
+ */
+
+ CompileWord(envPtr, valueTokenPtr, interp, i+1);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ }
+
+ /*
+ * Set the result to empty
+ */
+
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * IndexTailVarIfKnown --
+ *
+ * Procedure used in compiling [global] and [variable] commands. It
+ * inspects the variable name described by varTokenPtr and, if the tail
+ * is known at compile time, defines a corresponding local variable.
+ *
+ * Results:
+ * Returns the variable's index in the table of compiled locals if the
+ * tail is known at compile time, or -1 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+IndexTailVarIfKnown(
+ Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, /* Token representing the variable name */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Obj *tailPtr;
+ const char *tailName, *p;
+ int len, n = varTokenPtr->numComponents;
+ Tcl_Token *lastTokenPtr;
+ int full, localIndex;
+
+ /*
+ * Determine if the tail is (a) known at compile time, and (b) not an
+ * array element. Should any of these fail, return an error so that the
+ * non-compiled command will be called at runtime.
+ *
+ * In order for the tail to be known at compile time, the last token in
+ * the word has to be constant and contain "::" if it is not the only one.
+ */
+
+ if (!EnvHasLVT(envPtr)) {
+ return -1;
+ }
+
+ TclNewObj(tailPtr);
+ if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
+ full = 1;
+ lastTokenPtr = varTokenPtr;
+ } else {
+ full = 0;
+ lastTokenPtr = varTokenPtr + n;
+ if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+ }
+
+ tailName = TclGetStringFromObj(tailPtr, &len);
+
+ if (len) {
+ if (*(tailName+len-1) == ')') {
+ /*
+ * Possible array: bail out
+ */
+
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+
+ /*
+ * Get the tail: immediately after the last '::'
+ */
+
+ for (p = tailName + len -1; p > tailName; p--) {
+ if ((*p == ':') && (*(p-1) == ':')) {
+ p++;
+ break;
+ }
+ }
+ if (!full && (p == tailName)) {
+ /*
+ * No :: in the last component.
+ */
+
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+ len -= p - tailName;
+ tailName = p;
+ }
+
+ localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
+ Tcl_DecrRefCount(tailPtr);
+ return localIndex;
+}
+
+int
+TclCompileObjectSelfCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * We only handle [self] and [self object] (which is the same operation).
+ * These are the only very common operations on [self] for which
+ * bytecoding is at all reasonable.
+ */
+
+ if (parsePtr->numWords == 1) {
+ goto compileSelfObject;
+ } else if (parsePtr->numWords == 2) {
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
+ return TCL_ERROR;
+ }
+
+ subcmd = tokenPtr + 1;
+ if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
+ goto compileSelfObject;
+ } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
+ goto compileSelfNamespace;
+ }
+ }
+
+ /*
+ * Can't compile; handle with runtime call.
+ */
+
+ return TCL_ERROR;
+
+ compileSelfObject:
+
+ /*
+ * This delegates the entire problem to a single opcode.
+ */
+
+ TclEmitOpcode( INST_TCLOO_SELF, envPtr);
+ return TCL_OK;
+
+ compileSelfNamespace:
+
+ /*
+ * This is formally only correct with TclOO methods as they are currently
+ * implemented; it assumes that the current namespace is invariably when a
+ * TclOO context is present is the object's namespace, and that's
+ * technically only something that's a matter of current policy. But it
+ * avoids creating another opcode, so that's all good!
+ */
+
+ TclEmitOpcode( INST_TCLOO_SELF, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index f73beca..d1eb9db 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -27,11 +27,6 @@ static void FreeJumptableInfo(ClientData clientData);
static void PrintJumptableInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
-static int PushVarName(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr,
- int flags, int *localIndexPtr,
- int *simpleVarNamePtr, int *isScalarPtr,
- int line, int *clNext);
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, const char *identity,
int instruction, CompileEnv *envPtr);
@@ -45,75 +40,28 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int instruction,
CompileEnv *envPtr);
static void IssueSwitchChainedTests(Tcl_Interp *interp,
- CompileEnv *envPtr, ExtCmdLoc *mapPtr,
- int eclIndex, int mode, int noCase,
- int valueIndex, Tcl_Token *valueTokenPtr,
- int numWords, Tcl_Token **bodyToken,
- int *bodyLines, int **bodyNext);
-static void IssueSwitchJumpTable(Tcl_Interp *interp,
- CompileEnv *envPtr, ExtCmdLoc *mapPtr,
- int eclIndex, int valueIndex,
- Tcl_Token *valueTokenPtr, int numWords,
+ CompileEnv *envPtr, int mode, int noCase,
+ int valueIndex, int numWords,
Tcl_Token **bodyToken, int *bodyLines,
- int **bodyContLines);
-static int IssueTryFinallyInstructions(Tcl_Interp *interp,
+ int **bodyNext);
+static void IssueSwitchJumpTable(Tcl_Interp *interp,
+ CompileEnv *envPtr, int valueIndex,
+ int numWords, Tcl_Token **bodyToken,
+ int *bodyLines, int **bodyContLines);
+static int IssueTryClausesInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
Tcl_Obj **matchClauses, int *resultVarIndices,
- int *optionVarIndices, Tcl_Token **handlerTokens,
- Tcl_Token *finallyToken);
-static int IssueTryInstructions(Tcl_Interp *interp,
+ int *optionVarIndices, Tcl_Token **handlerTokens);
+static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
Tcl_Obj **matchClauses, int *resultVarIndices,
- int *optionVarIndices, Tcl_Token **handlerTokens);
-
-/*
- * Macro that encapsulates an efficiency trick that avoids a function call for
- * the simplest of compiles. The ANSI C "prototype" for this macro is:
- *
- * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp, int word);
- */
-
-#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
- (tokenPtr)[1].size), (envPtr)); \
- } else { \
- envPtr->line = mapPtr->loc[eclIndex].line[word]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr)); \
- }
-
-/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
- PushVarName(i,v,e,f,l,s,sc, \
- mapPtr->loc[eclIndex].line[(word)], \
- mapPtr->loc[eclIndex].next[(word)])
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
+ int *optionVarIndices, Tcl_Token **handlerTokens,
+ Tcl_Token *finallyToken);
+static int IssueTryFinallyInstructions(Tcl_Interp *interp,
+ CompileEnv *envPtr, Tcl_Token *bodyToken,
+ Tcl_Token *finallyToken);
/*
* The structures below define the AuxData types defined in this file.
@@ -137,14 +85,16 @@ const AuxDataType tclJumptableInfoType = {
TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
-#define BODY(token,index) \
- SetLineInformation((index));CompileBody(envPtr,(token),interp)
#define PUSH(str) \
- PushLiteral(envPtr,(str),strlen(str))
-#define JUMP(var,name) \
- (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr)
-#define FIXJUMP(var) \
+ PushStringLiteral(envPtr, str)
+#define JUMP4(name,var) \
+ (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr)
+#define FIXJUMP4(var) \
TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
+#define JUMP1(name,var) \
+ (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
+#define FIXJUMP1(var) \
+ TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
@@ -178,7 +128,7 @@ TclCompileSetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int isAssignment, isScalar, simpleVarName, localIndex, numWords;
+ int isAssignment, isScalar, localIndex, numWords;
DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords;
@@ -197,7 +147,7 @@ TclCompileSetCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
/*
* If we are doing an assignment, push the new value.
@@ -212,12 +162,10 @@ TclCompileSetCmd(
* Emit instructions to set/get the variable.
*/
- if (simpleVarName) {
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
- envPtr);
+ INST_STORE_STK : INST_LOAD_STK), envPtr);
} else if (localIndex <= 255) {
TclEmitInstInt1((isAssignment?
INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
@@ -241,9 +189,6 @@ TclCompileSetCmd(
localIndex, envPtr);
}
}
- } else {
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
- }
return TCL_OK;
}
@@ -798,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
@@ -809,7 +757,7 @@ TclSubstCompile(
tokenPtr = parse.tokenPtr;
if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
- PushLiteral(envPtr, "", 0);
+ PUSH("");
count++;
}
@@ -891,7 +839,7 @@ TclSubstCompile(
}
envPtr->line = bline;
- catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, catchRange);
ExceptionRangeStarts(envPtr, catchRange);
@@ -915,6 +863,7 @@ TclSubstCompile(
/* Substitution produced TCL_OK */
OP( END_CATCH);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
+ TclAdjustStackDepth(-1, envPtr);
/* Exceptional return codes processed here */
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
@@ -940,6 +889,7 @@ TclSubstCompile(
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
+ TclAdjustStackDepth(1, envPtr);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
@@ -955,6 +905,7 @@ TclSubstCompile(
OP1(JUMP1, -breakJump);
}
+ TclAdjustStackDepth(2, envPtr);
/* CONTINUE destination */
if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
@@ -964,6 +915,7 @@ TclSubstCompile(
OP( POP);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
+ TclAdjustStackDepth(2, envPtr);
/* RETURN + other destination */
if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
@@ -981,17 +933,6 @@ TclSubstCompile(
OP4( REVERSE, 2);
OP( POP);
- /*
- * We've emitted several POP instructions, and the automatic
- * computations for stack depth requirements have been decrementing
- * for every one. However, we know that every branch actually taken
- * only encounters some of those instructions. No branch passes
- * through them all. So, we now have a stack requirements estimate
- * that is too low. Here we manually fix that up.
- */
-
- TclAdjustStackDepth(5, envPtr);
-
/* OK destination */
if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d",
@@ -1050,9 +991,6 @@ TclSubstCompile(
* Instructions are added to envPtr to execute the "switch" command at
* runtime.
*
- * FIXME:
- * Stack depths are probably not calculated correctly.
- *
*----------------------------------------------------------------------
*/
@@ -1343,13 +1281,15 @@ TclCompileSwitchCmd(
* but it handles the most common case well enough.
*/
+ /* Both methods push the value to match against onto the stack. */
+ CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
+
if (mode == Switch_Exact) {
- IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex,
- valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines);
+ IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken,
+ bodyLines, bodyContLines);
} else {
- IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase,
- valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines,
- bodyContLines);
+ IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex,
+ numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
@@ -1387,13 +1327,9 @@ static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
- * location. */
- int eclIndex,
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
int valueIndex, /* The value to match against. */
- Tcl_Token *valueTokenPtr,
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -1403,7 +1339,6 @@ IssueSwitchChainedTests(
int **bodyContLines) /* Array of continuation line info. */
{
enum {Switch_Exact, Switch_Glob, Switch_Regexp};
- int savedStackDepth = envPtr->currStackDepth;
int foundDefault; /* Flag to indicate whether a "default" clause
* is present. */
JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
@@ -1419,13 +1354,6 @@ IssueSwitchChainedTests(
int i;
/*
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation(valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
* Generate a test for each arm.
*/
@@ -1438,7 +1366,6 @@ IssueSwitchChainedTests(
foundDefault = 0;
for (i=0 ; i<numBodyTokens ; i+=2) {
nextArmFixupIndex = -1;
- envPtr->currStackDepth = savedStackDepth + 1;
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
@@ -1472,7 +1399,7 @@ IssueSwitchChainedTests(
* when the RE == "".
*/
- PushLiteral(envPtr, "1", 1);
+ PUSH("1");
break;
}
@@ -1569,13 +1496,12 @@ IssueSwitchChainedTests(
}
/*
- * Now do the actual compilation. Note that we do not use CompileBody
+ * Now do the actual compilation. Note that we do not use BODY()
* because we may have synthesized the tokens in a non-standard
* pattern.
*/
OP( POP);
- envPtr->currStackDepth = savedStackDepth + 1;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1597,7 +1523,7 @@ IssueSwitchChainedTests(
if (!foundDefault) {
OP( POP);
- PushLiteral(envPtr, "", 0);
+ PUSH("");
}
/*
@@ -1633,8 +1559,6 @@ IssueSwitchChainedTests(
}
TclStackFree(interp, fixupTargetArray);
TclStackFree(interp, fixupArray);
-
- envPtr->currStackDepth = savedStackDepth + 1;
}
/*
@@ -1654,11 +1578,7 @@ static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
- * location. */
- int eclIndex,
int valueIndex, /* The value to match against. */
- Tcl_Token *valueTokenPtr,
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -1668,20 +1588,12 @@ IssueSwitchJumpTable(
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
- int savedStackDepth = envPtr->currStackDepth;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
Tcl_HashEntry *hPtr;
/*
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation(valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
* Compile the switch by using a jump table, which is basically a
* hashtable that maps from literal values to match against to the offset
* (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
@@ -1781,7 +1693,6 @@ IssueSwitchJumpTable(
* Compile the body of the arm.
*/
- envPtr->currStackDepth = savedStackDepth;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1803,6 +1714,7 @@ IssueSwitchJumpTable(
*/
OP4( JUMP4, 0);
+ TclAdjustStackDepth(-1, envPtr);
}
}
@@ -1813,10 +1725,9 @@ IssueSwitchJumpTable(
*/
if (!foundDefault) {
- envPtr->currStackDepth = savedStackDepth;
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
envPtr->codeStart+jumpToDefault+1);
- PushLiteral(envPtr, "", 0);
+ PUSH("");
}
/*
@@ -1834,7 +1745,6 @@ IssueSwitchJumpTable(
*/
TclStackFree(interp, finalFixups);
- envPtr->currStackDepth = savedStackDepth + 1;
}
/*
@@ -1992,9 +1902,9 @@ TclCompileThrowCmd(
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
- int savedStackDepth = envPtr->currStackDepth;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
+ int codeKnown, codeIsList, codeIsValid, len;
if (numWords != 3) {
return TCL_ERROR;
@@ -2004,77 +1914,66 @@ TclCompileThrowCmd(
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
- if (TclWordKnownAtCompileTime(codeToken, objPtr)) {
- Tcl_Obj *errPtr, *dictPtr;
- const char *string;
- int len;
- /*
- * The code is known at compilation time. This allows us to issue a
- * very efficient sequence of instructions.
- */
+ codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr);
- if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) {
- /*
- * Must still do this; might generate an error when getting this
- * "ignored" value prepared as an argument.
- */
+ /*
+ * First we must emit the code to substitute the arguments. This
+ * must come first in case substitution raises errors.
+ */
+ if (!codeKnown) {
+ CompileWord(envPtr, codeToken, interp, 1);
+ PUSH( "-errorcode");
+ }
+ CompileWord(envPtr, msgToken, interp, 2);
- CompileWord(envPtr, msgToken, interp, 2);
- TclCompileSyntaxError(interp, envPtr);
- Tcl_DecrRefCount(objPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- return TCL_OK;
- }
- if (len == 0) {
- /*
- * Must still do this; might generate an error when getting this
- * "ignored" value prepared as an argument.
- */
+ codeIsList = codeKnown && (TCL_OK ==
+ Tcl_ListObjLength(interp, objPtr, &len));
+ codeIsValid = codeIsList && (len != 0);
+
+ if (codeIsValid) {
+ Tcl_Obj *errPtr, *dictPtr;
- CompileWord(envPtr, msgToken, interp, 2);
- goto issueErrorForEmptyCode;
- }
TclNewLiteralStringObj(errPtr, "-errorcode");
TclNewObj(dictPtr);
Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr);
- Tcl_IncrRefCount(dictPtr);
- string = Tcl_GetStringFromObj(dictPtr, &len);
- CompileWord(envPtr, msgToken, interp, 2);
- PushLiteral(envPtr, string, len);
- TclDecrRefCount(dictPtr);
- OP44( RETURN_IMM, 1, 0);
- envPtr->currStackDepth = savedStackDepth + 1;
- } else {
- /*
- * When the code token is not known at compilation time, we need to do
- * a little bit more work. The main tricky bit here is that the error
- * code has to be a list (a [throw] restriction) so we must emit extra
- * instructions to enforce that condition.
- */
+ TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr);
+ }
+ TclDecrRefCount(objPtr);
- CompileWord(envPtr, codeToken, interp, 1);
- PUSH( "-errorcode");
- CompileWord(envPtr, msgToken, interp, 2);
- OP4( REVERSE, 3);
- OP( DUP);
- OP( LIST_LENGTH);
- OP1( JUMP_FALSE1, 16);
- OP4( LIST, 2);
- OP44( RETURN_IMM, 1, 0);
+ /*
+ * Simpler bytecodes when we detect invalid arguments at compile time.
+ */
+ if (codeKnown && !codeIsValid) {
+ OP( POP);
+ if (codeIsList) {
+ /* Must be an empty list */
+ goto issueErrorForEmptyCode;
+ }
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
+ }
+ if (!codeKnown) {
/*
- * Generate an error for being an empty list. Can't leverage anything
- * else to do this for us.
+ * Argument validity checking has to be done by bytecode at
+ * run time.
*/
-
+ OP4( REVERSE, 3);
+ OP( DUP);
+ OP( LIST_LENGTH);
+ OP1( JUMP_FALSE1, 16);
+ OP4( LIST, 2);
+ OP44( RETURN_IMM, 1, 0);
+ TclAdjustStackDepth(2, envPtr);
+ OP( POP);
+ OP( POP);
+ OP( POP);
issueErrorForEmptyCode:
- PUSH( "type must be non-empty list");
- PUSH( "");
- OP44( RETURN_IMM, 1, 0);
+ PUSH( "type must be non-empty list");
+ PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}");
}
- envPtr->currStackDepth = savedStackDepth + 1;
- TclDecrRefCount(objPtr);
+ OP44( RETURN_IMM, 1, 0);
return TCL_OK;
}
@@ -2124,8 +2023,7 @@ TclCompileTryCmd(
*/
DefineLineInformation; /* TIP #280 */
- SetLineInformation(1);
- CompileBody(envPtr, bodyToken, interp);
+ BODY(bodyToken, 1);
return TCL_OK;
}
@@ -2216,12 +2114,11 @@ TclCompileTryCmd(
int len;
const char *varname = Tcl_GetStringFromObj(objv[0], &len);
- if (!TclIsLocalScalar(varname, len)) {
+ resultVarIndices[i] = LocalScalar(varname, len, envPtr);
+ if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
- resultVarIndices[i] =
- TclFindCompiledLocal(varname, len, 1, envPtr);
} else {
resultVarIndices[i] = -1;
}
@@ -2229,12 +2126,11 @@ TclCompileTryCmd(
int len;
const char *varname = Tcl_GetStringFromObj(objv[1], &len);
- if (!TclIsLocalScalar(varname, len)) {
+ optionVarIndices[i] = LocalScalar(varname, len, envPtr);
+ if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
- optionVarIndices[i] =
- TclFindCompiledLocal(varname, len, 1, envPtr);
} else {
optionVarIndices[i] = -1;
}
@@ -2282,14 +2178,17 @@ TclCompileTryCmd(
* Issue the bytecode.
*/
- if (finallyToken) {
+ if (!finallyToken) {
+ result = IssueTryClausesInstructions(interp, envPtr, bodyToken,
+ numHandlers, matchCodes, matchClauses, resultVarIndices,
+ optionVarIndices, handlerTokens);
+ } else if (numHandlers == 0) {
result = IssueTryFinallyInstructions(interp, envPtr, bodyToken,
+ finallyToken);
+ } else {
+ result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken,
numHandlers, matchCodes, matchClauses, resultVarIndices,
optionVarIndices, handlerTokens, finallyToken);
- } else {
- result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers,
- matchCodes, matchClauses, resultVarIndices, optionVarIndices,
- handlerTokens);
}
/*
@@ -2315,12 +2214,13 @@ TclCompileTryCmd(
/*
*----------------------------------------------------------------------
*
- * IssueTryInstructions, IssueTryFinallyInstructions --
+ * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions,
+ * IssueTryFinallyInstructions --
*
* The code generators for [try]. Split from the parsing engine for
- * reasons of developer sanity, and also split between no-finally and
- * with-finally cases because so many of the details of generation vary
- * between the two.
+ * reasons of developer sanity, and also split between no-finally,
+ * just-finally and with-finally cases because so many of the details of
+ * generation vary between the three.
*
* The macros below make the instruction issuing easier to follow.
*
@@ -2328,7 +2228,7 @@ TclCompileTryCmd(
*/
static int
-IssueTryInstructions(
+IssueTryClausesInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
@@ -2341,32 +2241,51 @@ IssueTryInstructions(
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
- int savedStackDepth = envPtr->currStackDepth;
- int i, j, len, forwardsNeedFixing = 0;
+ int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
+ int *noError;
char buf[TCL_INTEGER_SPACE];
- resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ resultVar = AnonymousLocal(envPtr);
+ optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
/*
+ * Check if we're supposed to trap a normal TCL_OK completion of the body.
+ * If not, we can handle that case much more efficiently.
+ */
+
+ for (i=0 ; i<numHandlers ; i++) {
+ if (matchCodes[i] == 0) {
+ trapZero = 1;
+ break;
+ }
+ }
+
+ /*
* Compile the body, trapping any error in it so that we can trap on it
* and/or run a finally clause. Note that there must be at least one
* on/trap clause; when none is present, this whole function is not called
* (and it's never called when there's a finally clause).
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
- PUSH( "0");
- OP4( REVERSE, 2);
- OP1( JUMP1, 4);
+ if (!trapZero) {
+ OP( END_CATCH);
+ JUMP4( JUMP, afterBody);
+ TclAdjustStackDepth(-1, envPtr);
+ } else {
+ PUSH( "0");
+ OP4( REVERSE, 2);
+ OP1( JUMP1, 4);
+ TclAdjustStackDepth(-2, envPtr);
+ }
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
@@ -2386,14 +2305,17 @@ IssueTryInstructions(
addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ noError = TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
+ noError[i] = -1;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
- PUSH( buf);
+ PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
- JUMP(notCodeJumpSource, JUMP_FALSE4);
+ JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
+ const char *p;
Tcl_ListObjLength(NULL, matchClauses[i], &len);
/*
@@ -2405,9 +2327,10 @@ IssueTryInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- PUSH( TclGetString(matchClauses[i]));
+ p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ PushLiteral(envPtr, p, len);
OP( STR_EQ);
- JUMP(notECJumpSource, JUMP_FALSE4);
+ JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1; /* LINT */
}
@@ -2431,8 +2354,10 @@ IssueTryInstructions(
}
if (!handlerTokens[i]) {
forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
+ JUMP4( JUMP, forwardsToFix[i]);
} else {
+ int dontChangeOptions;
+
forwardsToFix[i] = -1;
if (forwardsNeedFixing) {
forwardsNeedFixing = 0;
@@ -2440,19 +2365,44 @@ IssueTryInstructions(
if (forwardsToFix[j] == -1) {
continue;
}
- FIXJUMP(forwardsToFix[j]);
+ FIXJUMP4(forwardsToFix[j]);
forwardsToFix[j] = -1;
}
}
- envPtr->currStackDepth = savedStackDepth;
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
BODY( handlerTokens[i], 5+i*4);
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
+ JUMP4( JUMP, noError[i]);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ TclAdjustStackDepth(-1, envPtr);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, dontChangeOptions);
+ LOAD( optionsVar);
+ OP4( REVERSE, 2);
+ STORE( optionsVar);
+ OP( POP);
+ PUSH( "-during");
+ OP4( REVERSE, 2);
+ OP44( DICT_SET, 1, optionsVar);
+ TclAdjustStackDepth(-1, envPtr);
+ FIXJUMP1( dontChangeOptions);
+ OP4( REVERSE, 2);
+ OP( RETURN_STK);
}
- JUMP(addrsToFix[i], JUMP4);
+ JUMP4( JUMP, addrsToFix[i]);
if (matchClauses[i]) {
- FIXJUMP(notECJumpSource);
+ FIXJUMP4( notECJumpSource);
}
- FIXJUMP(notCodeJumpSource);
+ FIXJUMP4( notCodeJumpSource);
}
/*
@@ -2471,17 +2421,23 @@ IssueTryInstructions(
* [try]).
*/
+ if (!trapZero) {
+ FIXJUMP4(afterBody);
+ }
for (i=0 ; i<numHandlers ; i++) {
- FIXJUMP(addrsToFix[i]);
+ FIXJUMP4(addrsToFix[i]);
+ if (noError[i] != -1) {
+ FIXJUMP4(noError[i]);
+ }
}
+ TclStackFree(interp, noError);
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
- envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
static int
-IssueTryFinallyInstructions(
+IssueTryClausesFinallyInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
@@ -2494,31 +2450,53 @@ IssueTryFinallyInstructions(
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
- int savedStackDepth = envPtr->currStackDepth;
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
+ int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
- resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ resultVar = AnonymousLocal(envPtr);
+ optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
/*
+ * Check if we're supposed to trap a normal TCL_OK completion of the body.
+ * If not, we can handle that case much more efficiently.
+ */
+
+ for (i=0 ; i<numHandlers ; i++) {
+ if (matchCodes[i] == 0) {
+ trapZero = 1;
+ break;
+ }
+ }
+
+ /*
* Compile the body, trapping any error in it so that we can trap on it
* (if any trap matches) and run a finally clause.
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
- envPtr->currStackDepth = savedStackDepth;
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
- PUSH( "0");
- OP4( REVERSE, 2);
- OP1( JUMP1, 4);
+ if (!trapZero) {
+ OP( END_CATCH);
+ STORE( resultVar);
+ OP( POP);
+ PUSH( "-level 0 -code 0");
+ STORE( optionsVar);
+ OP( POP);
+ JUMP4( JUMP, afterBody);
+ } else {
+ PUSH( "0");
+ OP4( REVERSE, 2);
+ OP1( JUMP1, 4);
+ TclAdjustStackDepth(-2, envPtr);
+ }
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
@@ -2528,161 +2506,176 @@ IssueTryFinallyInstructions(
OP( POP);
STORE( resultVar);
OP( POP);
- envPtr->currStackDepth = savedStackDepth + 1;
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
+ *
+ * Slight overallocation, but reduces size of this function.
*/
- if (numHandlers) {
- /*
- * Slight overallocation, but reduces size of this function.
- */
-
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-
- for (i=0 ; i<numHandlers ; i++) {
- sprintf(buf, "%d", matchCodes[i]);
- OP( DUP);
- PUSH( buf);
- OP( EQ);
- JUMP(notCodeJumpSource, JUMP_FALSE4);
- if (matchClauses[i]) {
- Tcl_ListObjLength(NULL, matchClauses[i], &len);
+ addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- /*
- * Match the errorcode according to try/trap rules.
- */
+ for (i=0 ; i<numHandlers ; i++) {
+ int noTrapError, trapError;
+ const char *p;
- LOAD( optionsVar);
- PUSH( "-errorcode");
- OP4( DICT_GET, 1);
- TclAdjustStackDepth(-1, envPtr);
- OP44( LIST_RANGE_IMM, 0, len-1);
- PUSH( TclGetString(matchClauses[i]));
- OP( STR_EQ);
- JUMP(notECJumpSource, JUMP_FALSE4);
- } else {
- notECJumpSource = -1; /* LINT */
- }
+ sprintf(buf, "%d", matchCodes[i]);
+ OP( DUP);
+ PushLiteral(envPtr, buf, strlen(buf));
+ OP( EQ);
+ JUMP4( JUMP_FALSE, notCodeJumpSource);
+ if (matchClauses[i]) {
+ Tcl_ListObjLength(NULL, matchClauses[i], &len);
/*
- * There is a finally clause, so we need a fairly complex sequence
- * of instructions to deal with an on/trap handler because we must
- * call the finally handler *and* we need to substitute the result
- * from a failed trap for the result from the main script.
+ * Match the errorcode according to try/trap rules.
*/
- if (resultVars[i] >= 0 || handlerTokens[i]) {
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- OP4( BEGIN_CATCH4, range);
- ExceptionRangeStarts(envPtr, range);
- }
- if (resultVars[i] >= 0) {
- LOAD( resultVar);
- STORE( resultVars[i]);
- OP( POP);
- if (optionVars[i] >= 0) {
- LOAD( optionsVar);
- STORE( optionVars[i]);
- OP( POP);
- }
+ LOAD( optionsVar);
+ PUSH( "-errorcode");
+ OP4( DICT_GET, 1);
+ TclAdjustStackDepth(-1, envPtr);
+ OP44( LIST_RANGE_IMM, 0, len-1);
+ p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ PushLiteral(envPtr, p, len);
+ OP( STR_EQ);
+ JUMP4( JUMP_FALSE, notECJumpSource);
+ } else {
+ notECJumpSource = -1; /* LINT */
+ }
+ OP( POP);
- if (!handlerTokens[i]) {
- /*
- * No handler. Will not be the last handler (that is a
- * condition that is checked by the caller). Chain to the
- * next one.
- */
+ /*
+ * There is a finally clause, so we need a fairly complex sequence of
+ * instructions to deal with an on/trap handler because we must call
+ * the finally handler *and* we need to substitute the result from a
+ * failed trap for the result from the main script.
+ */
- ExceptionRangeEnds(envPtr, range);
- OP( END_CATCH);
- forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
- goto finishTrapCatchHandling;
- }
- } else if (!handlerTokens[i]) {
+ if (resultVars[i] >= 0 || handlerTokens[i]) {
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ }
+ if (resultVars[i] >= 0) {
+ LOAD( resultVar);
+ STORE( resultVars[i]);
+ OP( POP);
+ if (optionVars[i] >= 0) {
+ LOAD( optionsVar);
+ STORE( optionVars[i]);
+ OP( POP);
+ }
+
+ if (!handlerTokens[i]) {
/*
- * No handler. Will not be the last handler (that condition is
- * checked by the caller). Chain to the next one.
+ * No handler. Will not be the last handler (that is a
+ * condition that is checked by the caller). Chain to the next
+ * one.
*/
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
- goto endOfThisArm;
+ JUMP4( JUMP, forwardsToFix[i]);
+ goto finishTrapCatchHandling;
}
-
+ } else if (!handlerTokens[i]) {
/*
- * Got a handler. Make sure that any pending patch-up actions from
- * previous unprocessed handlers are dealt with now that we know
- * where they are to jump to.
+ * No handler. Will not be the last handler (that condition is
+ * checked by the caller). Chain to the next one.
*/
- if (forwardsNeedFixing) {
- forwardsNeedFixing = 0;
- OP1( JUMP1, 7);
- for (j=0 ; j<i ; j++) {
- if (forwardsToFix[j] == -1) {
- continue;
- }
- FIXJUMP(forwardsToFix[j]);
- forwardsToFix[j] = -1;
- }
- OP4( BEGIN_CATCH4, range);
- }
- envPtr->currStackDepth = savedStackDepth;
- BODY( handlerTokens[i], 5+i*4);
- ExceptionRangeEnds(envPtr, range);
- OP( PUSH_RETURN_OPTIONS);
- OP4( REVERSE, 2);
- OP1( JUMP1, 4);
- forwardsToFix[i] = -1;
-
- /*
- * Error in handler or setting of variables; replace the stored
- * exception with the new one. Note that we only push this if we
- * have either a body or some variable setting here. Otherwise
- * this code is unreachable.
- */
+ forwardsNeedFixing = 1;
+ JUMP4( JUMP, forwardsToFix[i]);
+ goto endOfThisArm;
+ }
- finishTrapCatchHandling:
- ExceptionRangeTarget(envPtr, range, catchOffset);
- OP( PUSH_RETURN_OPTIONS);
- OP( PUSH_RESULT);
- OP( END_CATCH);
- STORE( resultVar);
- OP( POP);
- STORE( optionsVar);
- OP( POP);
+ /*
+ * Got a handler. Make sure that any pending patch-up actions from
+ * previous unprocessed handlers are dealt with now that we know where
+ * they are to jump to.
+ */
- endOfThisArm:
- if (i+1 < numHandlers) {
- JUMP(addrsToFix[i], JUMP4);
- }
- if (matchClauses[i]) {
- FIXJUMP(notECJumpSource);
+ if (forwardsNeedFixing) {
+ forwardsNeedFixing = 0;
+ OP1( JUMP1, 7);
+ for (j=0 ; j<i ; j++) {
+ if (forwardsToFix[j] == -1) {
+ continue;
+ }
+ FIXJUMP4( forwardsToFix[j]);
+ forwardsToFix[j] = -1;
}
- FIXJUMP(notCodeJumpSource);
+ OP4( BEGIN_CATCH4, range);
}
+ BODY( handlerTokens[i], 5+i*4);
+ ExceptionRangeEnds(envPtr, range);
+ PUSH( "0");
+ OP( PUSH_RETURN_OPTIONS);
+ OP4( REVERSE, 3);
+ OP1( JUMP1, 5);
+ TclAdjustStackDepth(-3, envPtr);
+ forwardsToFix[i] = -1;
/*
- * Fix all the jumps from taken clauses to here (the start of the
- * finally clause).
+ * Error in handler or setting of variables; replace the stored
+ * exception with the new one. Note that we only push this if we have
+ * either a body or some variable setting here. Otherwise this code is
+ * unreachable.
*/
- for (i=0 ; i<numHandlers-1 ; i++) {
- FIXJUMP(addrsToFix[i]);
+ finishTrapCatchHandling:
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( PUSH_RESULT);
+ OP( END_CATCH);
+ STORE( resultVar);
+ OP( POP);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, noTrapError);
+ LOAD( optionsVar);
+ PUSH( "-during");
+ OP4( REVERSE, 3);
+ STORE( optionsVar);
+ OP( POP);
+ OP44( DICT_SET, 1, optionsVar);
+ TclAdjustStackDepth(-1, envPtr);
+ JUMP1( JUMP, trapError);
+ FIXJUMP1( noTrapError);
+ STORE( optionsVar);
+ FIXJUMP1( trapError);
+ /* Skip POP at end; can clean up with subsequent POP */
+ if (i+1 < numHandlers) {
+ OP( POP);
+ }
+
+ endOfThisArm:
+ if (i+1 < numHandlers) {
+ JUMP4( JUMP, addrsToFix[i]);
+ TclAdjustStackDepth(1, envPtr);
}
- TclStackFree(interp, forwardsToFix);
- TclStackFree(interp, addrsToFix);
+ if (matchClauses[i]) {
+ FIXJUMP4( notECJumpSource);
+ }
+ FIXJUMP4( notCodeJumpSource);
}
/*
- * Drop the result code.
+ * Drop the result code, and fix all the jumps from taken clauses - which
+ * drop the result code as their first action - to point straight after
+ * (i.e., to the start of the finally clause).
*/
OP( POP);
+ for (i=0 ; i<numHandlers-1 ; i++) {
+ FIXJUMP4( addrsToFix[i]);
+ }
+ TclStackFree(interp, forwardsToFix);
+ TclStackFree(interp, addrsToFix);
/*
* Process the finally clause (at last!) Note that we do not wrap this in
@@ -2692,16 +2685,106 @@ IssueTryFinallyInstructions(
* next command (or some inter-command manipulation).
*/
- envPtr->currStackDepth = savedStackDepth;
+ if (!trapZero) {
+ FIXJUMP4( afterBody);
+ }
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
BODY( finallyToken, 3 + 4*numHandlers);
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
OP( POP);
+ JUMP1( JUMP, finalOK);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, noFinalError);
+ LOAD( optionsVar);
+ PUSH( "-during");
+ OP4( REVERSE, 3);
+ STORE( optionsVar);
+ OP( POP);
+ OP44( DICT_SET, 1, optionsVar);
+ TclAdjustStackDepth(-1, envPtr);
+ OP( POP);
+ JUMP1( JUMP, finalError);
+ TclAdjustStackDepth(1, envPtr);
+ FIXJUMP1( noFinalError);
+ STORE( optionsVar);
+ OP( POP);
+ FIXJUMP1( finalError);
+ STORE( resultVar);
+ OP( POP);
+ FIXJUMP1( finalOK);
LOAD( optionsVar);
LOAD( resultVar);
OP( RETURN_STK);
- envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
+
+static int
+IssueTryFinallyInstructions(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr,
+ Tcl_Token *bodyToken,
+ Tcl_Token *finallyToken)
+{
+ DefineLineInformation; /* TIP #280 */
+ int range, jumpOK, jumpSplice;
+
+ /*
+ * Note that this one is simple enough that we can issue it without
+ * needing a local variable table, making it a universal compilation.
+ */
+
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ BODY( bodyToken, 1);
+ ExceptionRangeEnds(envPtr, range);
+ OP1( JUMP1, 3);
+ TclAdjustStackDepth(-1, envPtr);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( END_CATCH);
+
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ BODY( finallyToken, 3);
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
+ OP( POP);
+ JUMP1( JUMP, jumpOK);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, jumpSplice);
+ PUSH( "-during");
+ OP4( OVER, 3);
+ OP4( LIST, 2);
+ OP( LIST_CONCAT);
+ FIXJUMP1( jumpSplice);
+ OP4( REVERSE, 4);
+ OP( POP);
+ OP( POP);
+ OP1( JUMP1, 7);
+ FIXJUMP1( jumpOK);
+ OP4( REVERSE, 2);
+ OP( RETURN_STK);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -2731,10 +2814,11 @@ TclCompileUnsetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
- int isScalar, simpleVarName, localIndex, numWords, flags, i;
+ int isScalar, localIndex, numWords, flags, i;
Tcl_Obj *leadingWord;
DefineLineInformation; /* TIP #280 */
+ /* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords-1;
flags = 1;
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -2772,15 +2856,13 @@ TclCompileUnsetCmd(
*/
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
/*
* Emit instructions to unset the variable.
*/
- if (!simpleVarName) {
- OP1( UNSET_STK, flags);
- } else if (isScalar) {
+ if (isScalar) {
if (localIndex < 0) {
OP1( UNSET_STK, flags);
} else {
@@ -2796,7 +2878,7 @@ TclCompileUnsetCmd(
varTokenPtr = TokenAfter(varTokenPtr);
}
- PushLiteral(envPtr, "", 0);
+ PUSH("");
return TCL_OK;
}
@@ -2830,7 +2912,6 @@ TclCompileWhileCmd(
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
- int savedStackDepth = envPtr->currStackDepth;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
@@ -2888,7 +2969,7 @@ TclCompileWhileCmd(
* implement break and continue.
*/
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Jump to the evaluation of the condition. This code uses the "loop
@@ -2914,7 +2995,7 @@ TclCompileWhileCmd(
* INST_START_CMD, and hence counted properly. [Bug 1752146]
*/
- envPtr->atCmdStart = 0;
+ envPtr->atCmdStart &= ~1;
testCodeOffset = CurrentOffset(envPtr);
}
@@ -2922,11 +3003,13 @@ TclCompileWhileCmd(
* Compile the loop body.
*/
- SetLineInformation(2);
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ if (!loopMayEnd) {
+ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
+ envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
+ }
+ BODY(bodyTokenPtr, 2);
ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
OP( POP);
/*
@@ -2941,10 +3024,8 @@ TclCompileWhileCmd(
bodyCodeOffset += 3;
testCodeOffset += 3;
}
- envPtr->currStackDepth = savedStackDepth;
SetLineInformation(1);
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
@@ -2968,14 +3049,14 @@ TclCompileWhileCmd(
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
ExceptionRangeTarget(envPtr, range, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, range);
/*
* The while command's result is an empty string.
*/
pushResult:
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
+ PUSH("");
return TCL_OK;
}
@@ -3011,7 +3092,7 @@ TclCompileYieldCmd(
}
if (parsePtr->numWords == 1) {
- PushLiteral(envPtr, "", 0);
+ PUSH("");
} else {
DefineLineInformation; /* TIP #280 */
Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -3025,246 +3106,6 @@ TclCompileYieldCmd(
/*
*----------------------------------------------------------------------
*
- * PushVarName --
- *
- * Procedure used in the compiling where pushing a variable name is
- * necessary (append, lappend, set).
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "set" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-PushVarName(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Token *varTokenPtr, /* Points to a variable token. */
- CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_NO_LARGE_INDEX. */
- int *localIndexPtr, /* Must not be NULL. */
- int *simpleVarNamePtr, /* Must not be NULL. */
- int *isScalarPtr, /* Must not be NULL. */
- int line, /* Line the token starts on. */
- int *clNext) /* Reference to offset of next hidden cont.
- * line. */
-{
- register const char *p;
- const char *name, *elName;
- register int i, n;
- Tcl_Token *elemTokenPtr = NULL;
- int nameChars, elNameChars, simpleVarName, localIndex;
- int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- simpleVarName = 0;
- name = elName = NULL;
- nameChars = elNameChars = 0;
- localIndex = -1;
-
- /*
- * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
- * curly braces surround the variable name. This really matters for array
- * elements to handle things like
- * set {x($foo)} 5
- * which raises an undefined var error if we are not careful here.
- */
-
- if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
- (varTokenPtr->start[0] != '{')) {
- /*
- * A simple variable name. Divide it up into "name" and "elName"
- * strings. If it is not a local variable, look it up at runtime.
- */
-
- simpleVarName = 1;
-
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (name[nameChars-1] == ')') {
- /*
- * last char is ')' => potential array reference.
- */
-
- for (i=0,p=name ; i<nameChars ; i++,p++) {
- if (*p == '(') {
- elName = p + 1;
- elNameChars = nameChars - i - 2;
- nameChars = i;
- break;
- }
- }
-
- if ((elName != NULL) && elNameChars) {
- /*
- * An array element, the element name is a simple string:
- * assemble the corresponding token.
- */
-
- elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
- allocedTokens = 1;
- elemTokenPtr->type = TCL_TOKEN_TEXT;
- elemTokenPtr->start = elName;
- elemTokenPtr->size = elNameChars;
- elemTokenPtr->numComponents = 0;
- elemTokenCount = 1;
- }
- }
- } else if (((n = varTokenPtr->numComponents) > 1)
- && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
- /*
- * Check for parentheses inside first token.
- */
-
- simpleVarName = 0;
- for (i = 0, p = varTokenPtr[1].start;
- i < varTokenPtr[1].size; i++, p++) {
- if (*p == '(') {
- simpleVarName = 1;
- break;
- }
- }
- if (simpleVarName) {
- int remainingChars;
-
- /*
- * Check the last token: if it is just ')', do not count it.
- * Otherwise, remove the ')' and flag so that it is restored at
- * the end.
- */
-
- if (varTokenPtr[n].size == 1) {
- n--;
- } else {
- varTokenPtr[n].size--;
- removedParen = n;
- }
-
- name = varTokenPtr[1].start;
- nameChars = p - varTokenPtr[1].start;
- elName = p + 1;
- remainingChars = (varTokenPtr[2].start - p) - 1;
- elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2;
-
- if (remainingChars) {
- /*
- * Make a first token with the extra characters in the first
- * token.
- */
-
- elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
- allocedTokens = 1;
- elemTokenPtr->type = TCL_TOKEN_TEXT;
- elemTokenPtr->start = elName;
- elemTokenPtr->size = remainingChars;
- elemTokenPtr->numComponents = 0;
- elemTokenCount = n;
-
- /*
- * Copy the remaining tokens.
- */
-
- memcpy(elemTokenPtr+1, varTokenPtr+2,
- (n-1) * sizeof(Tcl_Token));
- } else {
- /*
- * Use the already available tokens.
- */
-
- elemTokenPtr = &varTokenPtr[2];
- elemTokenCount = n - 1;
- }
- }
- }
-
- if (simpleVarName) {
- /*
- * See whether name has any namespace separators (::'s).
- */
-
- int hasNsQualifiers = 0;
-
- for (i = 0, p = name; i < nameChars; i++, p++) {
- if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
- hasNsQualifiers = 1;
- break;
- }
- }
-
- /*
- * Look up the var name's index in the array of local vars in the proc
- * frame. If retrieving the var's value and it doesn't already exist,
- * push its name and look it up at runtime.
- */
-
- if (!hasNsQualifiers) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- 1, envPtr);
- if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
- /*
- * We'll push the name.
- */
-
- localIndex = -1;
- }
- }
- if (localIndex < 0) {
- PushLiteral(envPtr, name, nameChars);
- }
-
- /*
- * Compile the element script, if any.
- */
-
- if (elName != NULL) {
- if (elNameChars) {
- envPtr->line = line;
- envPtr->clNext = clNext;
- TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
- envPtr);
- } else {
- PushLiteral(envPtr, "", 0);
- }
- }
- } else {
- /*
- * The var name isn't simple: compile and push it.
- */
-
- envPtr->line = line;
- envPtr->clNext = clNext;
- CompileTokens(envPtr, varTokenPtr, interp);
- }
-
- if (removedParen) {
- varTokenPtr[removedParen].size++;
- }
- if (allocedTokens) {
- TclStackFree(interp, elemTokenPtr);
- }
- *localIndexPtr = localIndex;
- *simpleVarNamePtr = simpleVarName;
- *isScalarPtr = (elName == NULL);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* CompileUnaryOpCmd --
*
* Utility routine to compile the unary operator commands.
@@ -3333,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);
@@ -3416,8 +3258,9 @@ CompileComparisonOpCmd(
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
+ PUSH("1");
} else if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
@@ -3431,7 +3274,7 @@ CompileComparisonOpCmd(
return TCL_ERROR;
} else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ int tmpIndex = AnonymousLocal(envPtr);
int words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -3588,7 +3431,7 @@ TclCompilePowOpCmd(
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
- PushLiteral(envPtr, "1", 1);
+ PUSH("1");
words++;
}
while (--words > 1) {
@@ -3753,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.
@@ -3798,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.
@@ -3806,7 +3651,7 @@ TclCompileDivOpCmd(
return TCL_ERROR;
}
if (parsePtr->numWords == 2) {
- PushLiteral(envPtr, "1.0", 3);
+ PUSH("1.0");
}
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 3597abe..2a48117 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2401,6 +2401,7 @@ CompileExprTree(
(nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&jumpPtr->next->next->jump);
+ TclAdjustStackDepth(-1, envPtr);
TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127);
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
jumpPtr->next->next->jump.codeOffset += 3;
@@ -2485,8 +2486,7 @@ CompileExprTree(
break;
}
case OT_TOKENS:
- TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
- envPtr);
+ CompileTokens(envPtr, tokenPtr, interp);
tokenPtr += tokenPtr->numComponents + 1;
break;
default:
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0e98385..f5c8d41 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -14,6 +14,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Table of all AuxData types.
@@ -309,7 +310,7 @@ InstructionDesc const tclInstructionTable[] = {
{"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}},
/* Push the interpreter's return option dictionary as an object on the
* stack. */
- {"returnStk", 1, -2, 0, {OPERAND_NONE}},
+ {"returnStk", 1, -1, 0, {OPERAND_NONE}},
/* Compiled [return]; options and result are on the stack, code and
* level are in the options. */
@@ -382,7 +383,8 @@ InstructionDesc const tclInstructionTable[] = {
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
- /* Compiled bytecodes to signal syntax error. */
+ /* Compiled bytecodes to signal syntax error. Equivalent to returnImm
+ * except for the ERR_ALREADY_LOGGED flag in the interpreter. */
{"reverse", 5, 0, 1, {OPERAND_UINT4}},
/* Reverse the order of the arg elements at the top of stack */
@@ -430,7 +432,7 @@ InstructionDesc const tclInstructionTable[] = {
/* Map variable contents back into a dictionary in a variable. Part of
* [dict with].
* Stack: ... dictVarName path keyList => ... */
- {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}},
+ {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}},
/* Map variable contents back into a dictionary in the local variable
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
@@ -534,6 +536,15 @@ InstructionDesc const tclInstructionTable[] = {
* the word at the top of the stack;
* <objc,objv> = <op4,top op4 after popping 1> */
+ {"listConcat", 1, -1, 0, {OPERAND_NONE}},
+ /* 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] */
+
+ {"expandDrop", 1, 0, 0, {OPERAND_NONE}},
+ /* Drops an element from the auxiliary stack, popping stack elements
+ * until the matching stack depth is reached. */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -554,12 +565,15 @@ static void EnterCmdStartData(CompileEnv *envPtr,
static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
+static int IsCompactibleCompileEnv(Tcl_Interp *interp,
+ CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static void RegisterAuxDataType(const AuxDataType *typePtr);
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
+static void StartExpanding(CompileEnv *envPtr);
static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
static void PrintSourceToObj(Tcl_Obj *appendObj,
@@ -614,6 +628,13 @@ static const Tcl_ObjType tclInstNameType = {
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
};
+
+/*
+ * Helper macros.
+ */
+
+#define TclIncrUInt4AtPtr(ptr, delta) \
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
/*
*----------------------------------------------------------------------
@@ -654,6 +675,7 @@ TclSetByteCodeFromAny(
* in frame. */
int length, result = TCL_OK;
const char *stringPtr;
+ Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
#ifdef TCL_COMPILE_DEBUG
@@ -691,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);
@@ -705,6 +725,38 @@ TclSetByteCodeFromAny(
TclEmitOpcode(INST_DONE, &compEnv);
/*
+ * Check for optimizations!
+ *
+ * Test if the generated code is free of most hazards; if so, recompile
+ * but with generation of INST_START_CMD disabled. This produces somewhat
+ * faster code in some cases, and more compact code in more.
+ */
+
+ if (Tcl_GetMaster(interp) == NULL &&
+ !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
+ && IsCompactibleCompileEnv(interp, &compEnv)) {
+ TclFreeCompileEnv(&compEnv);
+ iPtr->compiledProcPtr = procPtr;
+ TclInitCompileEnv(interp, &compEnv, stringPtr, length,
+ iPtr->invokeCmdFramePtr, iPtr->invokeWord);
+ if (clLocPtr) {
+ compEnv.clNext = &clLocPtr->loc[0];
+ }
+ compEnv.atCmdStart = 2; /* The disabling magic. */
+ TclCompileScript(interp, stringPtr, length, &compEnv);
+ assert (compEnv.atCmdStart > 1);
+ TclEmitOpcode(INST_DONE, &compEnv);
+ assert (compEnv.atCmdStart > 1);
+ }
+
+ /*
+ * Apply some peephole optimizations that can cross specific/generic
+ * instruction generator boundaries.
+ */
+
+ TclOptimizeBytecode(&compEnv);
+
+ /*
* Invoke the compilation hook procedure if one exists.
*/
@@ -973,6 +1025,77 @@ TclCleanupByteCode(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * IsCompactibleCompileEnv --
+ *
+ * Checks to see if we may apply some basic compaction optimizations to a
+ * piece of bytecode. Idempotent.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static int
+IsCompactibleCompileEnv(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr)
+{
+ unsigned char *pc;
+ int size;
+
+ /*
+ * Special: procedures in the '::tcl' namespace (or its children) are
+ * considered to be well-behaved and so can have compaction applied even
+ * if it would otherwise be invalid.
+ */
+
+ if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL
+ && envPtr->procPtr->cmdPtr->nsPtr != NULL) {
+ Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr;
+
+ if (strcmp(nsPtr->fullName, "::tcl") == 0
+ || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) {
+ return 1;
+ }
+ }
+
+ /*
+ * Go through and ensure that no operation involved can cause a desired
+ * change of bytecode sequence during running. This comes down to ensuring
+ * that there are no mapped variables (due to traces) or calls to external
+ * commands (traces, [uplevel] trickery). This is actually a very
+ * conservative check; it turns down a lot of code that is OK in practice.
+ */
+
+ for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
+ switch (*pc) {
+ /* Invokes */
+ case INST_INVOKE_STK1:
+ case INST_INVOKE_STK4:
+ case INST_INVOKE_EXPANDED:
+ case INST_INVOKE_REPLACE:
+ return 0;
+ /* Runtime evals */
+ case INST_EVAL_STK:
+ case INST_EXPR_STK:
+ case INST_YIELD:
+ return 0;
+ /* Upvars */
+ case INST_UPVAR:
+ case INST_NSUPVAR:
+ case INST_VARIABLE:
+ return 0;
+ default:
+ size = tclInstructionTable[*pc].numBytes;
+ assert (size > 0);
+ break;
+ }
+ }
+
+ return 1;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_SubstObj --
@@ -1103,7 +1226,12 @@ CompileSubstObj(
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
- /* TODO: Debug printing? */
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile >= 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ fflush(stdout);
+ }
+#endif /* TCL_COMPILE_DEBUG */
}
return codePtr;
}
@@ -1158,8 +1286,6 @@ ReleaseCmdWordData(
ckfree((char *) eclPtr->loc);
}
- Tcl_DeleteHashTable (&eclPtr->litInfo);
-
ckfree((char *) eclPtr);
}
@@ -1194,6 +1320,8 @@ TclInitCompileEnv(
{
Interp *iPtr = (Interp *) interp;
+ assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL);
+
envPtr->iPtr = iPtr;
envPtr->source = stringPtr;
envPtr->numSrcBytes = numBytes;
@@ -1217,6 +1345,7 @@ TclInitCompileEnv(
envPtr->mallocedLiteralArray = 0;
envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
+ envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace;
envPtr->exceptArrayNext = 0;
envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
envPtr->mallocedExceptArray = 0;
@@ -1225,6 +1354,7 @@ TclInitCompileEnv(
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
envPtr->mallocedCmdMap = 0;
envPtr->atCmdStart = 1;
+ envPtr->expandCount = 0;
/*
* TIP #280: Set up the extended command location information, based on
@@ -1240,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.
@@ -1356,7 +1485,6 @@ TclInitCompileEnv(
* data is available.
*/
- envPtr->clLoc = NULL;
envPtr->clNext = NULL;
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
@@ -1429,6 +1557,7 @@ TclFreeCompileEnv(
}
if (envPtr->mallocedExceptArray) {
ckfree(envPtr->exceptArrayPtr);
+ ckfree(envPtr->exceptAuxArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree(envPtr->cmdMapPtr);
@@ -1440,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);
- }
}
/*
@@ -1550,477 +1669,461 @@ TclWordKnownAtCompileTime(
*----------------------------------------------------------------------
*/
+static int
+ExpandRequested(
+ Tcl_Token *tokenPtr,
+ int numWords)
+{
+ /* 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;
+}
+
+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);
+}
+
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. */
+TclCompileInvocation(
+ Tcl_Interp *interp,
+ Tcl_Token *tokenPtr,
+ Tcl_Obj *cmdObj,
+ int numWords,
+ CompileEnv *envPtr)
{
- Interp *iPtr = (Interp *) interp;
- 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;
- Namespace *cmdNsPtr;
- 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;
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ int wordIdx = 0;
+ DefineLineInformation;
- if (envPtr->iPtr == NULL) {
- Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
+ if (cmdObj) {
+ CompileCmdLiteral(interp, cmdObj, envPtr);
+ wordIdx = 1;
+ tokenPtr = TokenAfter(tokenPtr);
}
- Tcl_DStringInit(&ds);
+ for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
+ int objIdx;
- if (numBytes < 0) {
- numBytes = strlen(script);
+ SetLineInformation(wordIdx);
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ CompileTokens(envPtr, tokenPtr, interp);
+ continue;
+ }
+
+ 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);
}
- Tcl_ResetResult(interp);
- isFirstCmd = 1;
- if (envPtr->procPtr != NULL) {
- cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
+ if (wordIdx <= 255) {
+ TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
} else {
- cmdNsPtr = NULL; /* use current NS */
+ TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
}
+}
- /*
- * Each iteration through the following loop compiles the next command
- * from the script.
- */
+static void
+CompileExpanded(
+ Tcl_Interp *interp,
+ Tcl_Token *tokenPtr,
+ Tcl_Obj *cmdObj,
+ int numWords,
+ CompileEnv *envPtr)
+{
+ int wordIdx = 0;
+ DefineLineInformation;
- 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.
- */
- 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;
- }
+ StartExpanding(envPtr);
+ if (cmdObj) {
+ CompileCmdLiteral(interp, cmdObj, envPtr);
+ wordIdx = 1;
+ tokenPtr = TokenAfter(tokenPtr);
+ }
- /*
- * 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.
- */
+ for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
+ int objIdx;
- TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
- TclAdvanceContinuations(&cmdLine, &clNext,
- parsePtr->commandStart - envPtr->source);
+ SetLineInformation(wordIdx);
- if (parsePtr->numWords > 0) {
- int expand = 0; /* Set if there are dynamic expansions to
- * handle */
+ 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;
+ }
- /*
- * 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.
- */
+ 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 (!isFirstCmd) {
- TclEmitOpcode(INST_POP, envPtr);
- envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - startCodeOffset;
- }
+ /*
+ * 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.
+ */
- /*
- * Determine the actual length of the command.
- */
+ TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
+ envPtr->expandCount--;
+ TclAdjustStackDepth(1 - wordIdx, envPtr);
+}
- 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.
- */
+static int
+CompileCmdCompileProc(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr,
+ CompileEnv *envPtr)
+{
+ int unwind = 0, incrOffset = -1;
+ DefineLineInformation;
- commandLength -= 1;
- }
+ /*
+ * 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.
+ */
-#ifdef TCL_COMPILE_DEBUG
+ 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 tracing, print a line for each top level command compiled.
+ * 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 ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- fprintf(stdout, " Compiling: ");
- TclPrintSource(stdout, parsePtr->commandStart,
- TclMin(commandLength, 55));
- fprintf(stdout, "\n");
+ TclIncrUInt4AtPtr(incrPtr, 1);
+ if (unwind) {
+ /* We started the INST_START_CMD. Record the code length. */
+ TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1);
}
-#endif
+ }
+ return TCL_OK;
+ }
- /*
- * Check whether expansion has been requested for any of the
- * words.
- */
+ envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */
- for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
- wordIdx < parsePtr->numWords;
- wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
- if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
- expand = 1;
- break;
- }
- }
+ /*
+ * 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;
+ }
- envPtr->numCommands++;
- currCmdIndex = envPtr->numCommands - 1;
- lastTopLevelCmdIndex = currCmdIndex;
- startCodeOffset = envPtr->codeNext - envPtr->codeStart;
- EnterCmdStartData(envPtr, currCmdIndex,
- parsePtr->commandStart - envPtr->source, startCodeOffset);
+ /*
+ * Reset the index of next command.
+ * Toss out any from failed nested partial compiles.
+ */
+ envPtr->numCommands = mapPtr->nuloc;
- /*
- * Should only start issuing instructions after the "command has
- * started" so that the command range is correct in the bytecode.
- */
+ return TCL_ERROR;
+}
- if (expand) {
- TclEmitOpcode(INST_EXPAND_START, envPtr);
- }
+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;
- /*
- * 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'.
- */
+ assert (parsePtr->numWords > 0);
- EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
- parsePtr->tokenPtr, parsePtr->commandStart,
- parsePtr->commandSize, parsePtr->numWords, cmdLine,
- clNext, &wlines, envPtr);
- wlineat = eclPtr->nuloc - 1;
+ /* Pre-Compile */
- /*
- * Each iteration of the following loop compiles one word from the
- * command.
- */
+ envPtr->numCommands++;
+ EnterCmdStartData(envPtr, cmdIdx,
+ parsePtr->commandStart - envPtr->source, startCodeOffset);
- for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
- wordIdx < parsePtr->numWords; wordIdx++,
- tokenPtr += tokenPtr->numComponents + 1) {
+ /*
+ * 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'.
+ */
- envPtr->line = eclPtr->loc[wlineat].line[wordIdx];
- envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx];
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * The word is not a simple string of characters.
- */
+ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
+ parsePtr->tokenPtr, parsePtr->commandStart,
+ parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ clNext, &wlines, envPtr);
+ wlineat = eclPtr->nuloc - 1;
- TclCompileTokens(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
- TclEmitInstInt4(INST_EXPAND_STKTOP,
- envPtr->currStackDepth, envPtr);
- }
- continue;
- }
+ envPtr->line = eclPtr->loc[wlineat].line[0];
+ envPtr->clNext = eclPtr->loc[wlineat].next[0];
- /*
- * 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.
- */
+ /* Do we know the command word? */
+ Tcl_IncrRefCount(cmdObj);
+ tokenPtr = parsePtr->tokenPtr;
+ cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj);
- 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.
- */
+ /* 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;
+ }
+ }
+ }
- TclDStringClear(&ds);
- TclDStringAppendToken(&ds, &tokenPtr[1]);
-
- cmdPtr = (Command *) Tcl_FindCommand(interp,
- Tcl_DStringValue(&ds),
- (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
-
- 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 =
- envPtr->codeNext - envPtr->codeStart;
- int update = 0;
-#ifdef TCL_COMPILE_DEBUG
- int startStackDepth = envPtr->currStackDepth;
-#endif
+ /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */
+ if (cmdPtr) {
+ code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr);
+ }
- /*
- * 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) {
- 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!
- */
-
- unsigned char *fixPtr = envPtr->codeNext - 4;
-
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
- fixPtr);
- }
- } else {
- TclEmitInstInt4(INST_START_CMD, 0, envPtr);
- TclEmitInt4(1, envPtr);
- update = 1;
- }
-
- code = cmdPtr->compileProc(interp, parsePtr, cmdPtr,
- envPtr);
-
- if (code == 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.
- */
+ if (code == TCL_ERROR) {
+ if (expand < 0) {
+ expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords);
+ }
-#ifdef TCL_COMPILE_DEBUG
- int diff = envPtr->currStackDepth-startStackDepth;
-
- if (diff != 1 && (diff != 0 ||
- *(envPtr->codeNext-1) != INST_DONE)) {
- 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 && 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!
- */
-
- unsigned char *fixPtr = envPtr->codeNext - 4;
-
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1,
- fixPtr);
- }
-
- /*
- * 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;
- }
+ if (expand) {
+ CompileExpanded(interp, parsePtr->tokenPtr,
+ cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr);
+ } else {
+ TclCompileInvocation(interp, parsePtr->tokenPtr,
+ cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr);
+ }
+ }
- /*
- * 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.
- */
+ Tcl_DecrRefCount(cmdObj);
- objIndex = TclRegisterNewCmdLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
- if (cmdPtr != NULL) {
- 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.
- */
+ TclEmitOpcode(INST_POP, envPtr);
+ EnterCmdExtentData(envPtr, cmdIdx,
+ parsePtr->term - parsePtr->commandStart,
+ (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
- objIndex = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ /*
+ * TIP #280: Free full form of per-word line data and insert the
+ * reduced form now
+ */
- if (envPtr->clNext) {
- TclContinuationsEnterDerived(
- TclFetchLiteral(envPtr, objIndex),
- tokenPtr[1].start - envPtr->source,
- eclPtr->loc[wlineat].next[wordIdx]);
- }
- }
- TclEmitPush(objIndex, envPtr);
- } /* for loop */
+ 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;
- /*
- * Emit an invoke instruction for the command. We skip this if a
- * compile procedure was found for the command.
- */
+ return cmdIdx;
+}
- 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.
- */
+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. */
- TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
- TclAdjustStackDepth((1-wordIdx), envPtr);
- } else if (wordIdx > 0) {
- /*
- * Save PC -> command map for the TclArgumentBC* functions.
- */
+ if (envPtr->iPtr == NULL) {
+ Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
+ }
- int isnew;
- Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
- INT2PTR(envPtr->codeNext - envPtr->codeStart),
- &isnew);
+ /* Each iteration compiles one command from the script. */
- Tcl_SetHashValue(hePtr, INT2PTR(wlineat));
- if (wordIdx <= 255) {
- TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
- } else {
- TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
- }
- }
+ while (numBytes > 0) {
+ Tcl_Parse parse;
+ const char *next;
+ if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) {
/*
- * Update the compilation environment structure and record the
- * offsets of the source and code for the command.
+ * Compile bytecodes to report the parse error at runtime.
*/
- finishCommand:
- EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
- (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
- isFirstCmd = 0;
+ Tcl_LogCommandInfo(interp, script, parse.commandStart,
+ parse.term + 1 - parse.commandStart);
+ TclCompileSyntaxError(interp, envPtr);
+ return;
+ }
- /*
- * TIP #280: Free full form of per-word line data and insert the
- * reduced form now
- */
+#ifdef TCL_COMPILE_DEBUG
+ /*
+ * If tracing, print a line for each top level command compiled.
+ * TODO: Suppress when numWords == 0 ?
+ */
- 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 */
+ 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
/*
- * Advance to the next command in the script.
+ * TIP #280: Count newlines before the command start.
+ * (See test info-30.33).
*/
- next = parsePtr->commandStart + parsePtr->commandSize;
- bytesLeft -= next - p;
- p = next;
+ TclAdvanceLines(&envPtr->line, p, parse.commandStart);
+ TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
+ parse.commandStart - envPtr->source);
/*
- * TIP #280: Track lines in the just compiled command.
+ * Advance parser to the next command in the script.
*/
- TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
- TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source);
- Tcl_FreeParse(parsePtr);
- } while (bytesLeft > 0);
+ next = parse.commandStart + parse.commandSize;
+ numBytes -= next - p;
+ p = next;
- /*
- * TIP #280: Bring the line counts in the CompEnv up to date.
- * See tests info-30.33,34,35 .
- */
+ 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;
+ }
- envPtr->line = cmdLine;
- envPtr->clNext = clNext;
+ lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr);
- /*
- * If the source script yielded no instructions (e.g., if it was empty),
- * push an empty string as the command's result.
- */
+ /*
+ * TIP #280: Track lines in the just compiled command.
+ */
- if (envPtr->codeNext == entryCodeNext) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ TclAdvanceLines(&envPtr->line, parse.commandStart, p);
+ TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
+ p - envPtr->source);
+ Tcl_FreeParse(&parse);
}
- envPtr->numSrcBytes = p - script;
- TclStackFree(interp, parsePtr);
- Tcl_DStringFree(&ds);
+ 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++;
+ }
}
/*
@@ -2084,7 +2187,7 @@ TclCompileVarSubst(
localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
}
if (localVar < 0) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr);
+ PushLiteral(envPtr, name, nameBytes);
}
/*
@@ -2096,7 +2199,7 @@ TclCompileVarSubst(
if (tokenPtr->numComponents == 1) {
if (localVar < 0) {
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ TclEmitOpcode(INST_LOAD_STK, envPtr);
} else if (localVar <= 255) {
TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
} else {
@@ -2292,7 +2395,7 @@ TclCompileTokens(
*/
if (envPtr->codeNext == entryCodeNext) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushStringLiteral(envPtr, "");
}
Tcl_DStringFree(&textBuffer);
@@ -2407,9 +2510,9 @@ TclCompileExprWords(
wordPtr = tokenPtr;
for (i = 0; i < numWords; i++) {
- TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr);
+ CompileTokens(envPtr, wordPtr, interp);
if (i < (numWords - 1)) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr);
+ PushStringLiteral(envPtr, " ");
}
wordPtr += wordPtr->numComponents + 1;
}
@@ -2453,21 +2556,17 @@ TclCompileNoOp(
{
Tcl_Token *tokenPtr;
int i;
- int savedStackDepth = envPtr->currStackDepth;
tokenPtr = parsePtr->tokenPtr;
for (i = 1; i < parsePtr->numWords; i++) {
tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
- envPtr->currStackDepth = savedStackDepth;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
- envPtr);
+ CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_POP, envPtr);
}
}
- envPtr->currStackDepth = savedStackDepth;
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -3076,6 +3175,7 @@ TclCreateExceptRange(
* new ExceptionRange structure. */
{
register ExceptionRange *rangePtr;
+ register ExceptionAux *auxPtr;
int index = envPtr->exceptArrayNext;
if (index >= envPtr->exceptArrayEnd) {
@@ -3087,12 +3187,16 @@ TclCreateExceptRange(
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
+ size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
+ size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
ckrealloc(envPtr->exceptArrayPtr, newBytes);
+ envPtr->exceptAuxArrayPtr =
+ ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
@@ -3100,9 +3204,12 @@ TclCreateExceptRange(
*/
ExceptionRange *newPtr = ckalloc(newBytes);
+ ExceptionAux *newPtr2 = ckalloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
+ memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
envPtr->exceptArrayPtr = newPtr;
+ envPtr->exceptAuxArrayPtr = newPtr2;
envPtr->mallocedExceptArray = 1;
}
envPtr->exceptArrayEnd = newElems;
@@ -3117,10 +3224,301 @@ TclCreateExceptRange(
rangePtr->breakOffset = -1;
rangePtr->continueOffset = -1;
rangePtr->catchOffset = -1;
+ auxPtr = &envPtr->exceptAuxArrayPtr[index];
+ auxPtr->supportsContinue = 1;
+ auxPtr->stackDepth = envPtr->currStackDepth;
+ auxPtr->expandTarget = envPtr->expandCount;
+ auxPtr->expandTargetDepth = -1;
+ auxPtr->numBreakTargets = 0;
+ auxPtr->breakTargets = NULL;
+ auxPtr->allocBreakTargets = 0;
+ auxPtr->numContinueTargets = 0;
+ auxPtr->continueTargets = NULL;
+ auxPtr->allocContinueTargets = 0;
return index;
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclGetInnermostExceptionRange --
+ *
+ * Returns the innermost exception range that covers the current code
+ * creation point, and (optionally) the stack depth that is expected at
+ * that point. Relies on the fact that the range has a numCodeBytes = -1
+ * when it is being populated and that inner ranges come after outer
+ * ranges.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+ExceptionRange *
+TclGetInnermostExceptionRange(
+ CompileEnv *envPtr,
+ int returnCode,
+ ExceptionAux **auxPtrPtr)
+{
+ int exnIdx = -1, i;
+
+ for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+
+ if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
+ (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
+ rangePtr->codeOffset+rangePtr->numCodeBytes) &&
+ (returnCode != TCL_CONTINUE ||
+ envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
+ exnIdx = i;
+ }
+ }
+ if (exnIdx == -1) {
+ return NULL;
+ }
+ if (auxPtrPtr) {
+ *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx];
+ }
+ return &envPtr->exceptArrayPtr[exnIdx];
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclAddLoopBreakFixup, TclAddLoopContinueFixup --
+ *
+ * Adds a place that wants to break/continue to the loop exception range
+ * tracking that will be fixed up once the loop can be finalized. These
+ * functions will generate an INST_JUMP4 that will be fixed up during the
+ * loop finalization.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclAddLoopBreakFixup(
+ CompileEnv *envPtr,
+ ExceptionAux *auxPtr)
+{
+ int range = auxPtr - envPtr->exceptAuxArrayPtr;
+
+ if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ Tcl_Panic("trying to add 'break' fixup to full exception range");
+ }
+
+ if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
+ auxPtr->allocBreakTargets *= 2;
+ auxPtr->allocBreakTargets += 2;
+ if (auxPtr->breakTargets) {
+ auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets,
+ sizeof(int) * auxPtr->allocBreakTargets);
+ } else {
+ auxPtr->breakTargets =
+ ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
+ }
+ }
+ auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+}
+
+void
+TclAddLoopContinueFixup(
+ CompileEnv *envPtr,
+ ExceptionAux *auxPtr)
+{
+ int range = auxPtr - envPtr->exceptAuxArrayPtr;
+
+ if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ Tcl_Panic("trying to add 'continue' fixup to full exception range");
+ }
+
+ if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
+ auxPtr->allocContinueTargets *= 2;
+ auxPtr->allocContinueTargets += 2;
+ if (auxPtr->continueTargets) {
+ auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets,
+ sizeof(int) * auxPtr->allocContinueTargets);
+ } else {
+ auxPtr->continueTargets =
+ ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
+ }
+ }
+ auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
+ CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclCleanupStackForBreakContinue --
+ *
+ * Ditch the extra elements from the auxiliary stack and the main
+ * stack. How to do this exactly depends on whether there are any
+ * elements on the auxiliary stack to pop.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclCleanupStackForBreakContinue(
+ CompileEnv *envPtr,
+ ExceptionAux *auxPtr)
+{
+ int savedStackDepth = envPtr->currStackDepth;
+ int toPop = envPtr->expandCount - auxPtr->expandTarget;
+
+ if (toPop > 0) {
+ while (toPop > 0) {
+ TclEmitOpcode(INST_EXPAND_DROP, envPtr);
+ toPop--;
+ }
+ TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth,
+ envPtr);
+ toPop = auxPtr->expandTargetDepth - auxPtr->stackDepth;
+ while (toPop > 0) {
+ TclEmitOpcode(INST_POP, envPtr);
+ toPop--;
+ }
+ } else {
+ toPop = envPtr->currStackDepth - auxPtr->stackDepth;
+ while (toPop > 0) {
+ TclEmitOpcode(INST_POP, envPtr);
+ toPop--;
+ }
+ }
+ envPtr->currStackDepth = savedStackDepth;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * StartExpanding --
+ *
+ * Pushes an INST_EXPAND_START and does some additional housekeeping so
+ * that the [break] and [continue] compilers can use an exception-free
+ * issue to discard it.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static void
+StartExpanding(
+ CompileEnv *envPtr)
+{
+ int i;
+
+ TclEmitOpcode(INST_EXPAND_START, envPtr);
+
+ /*
+ * Update inner exception ranges with information about the environment
+ * where this expansion started.
+ */
+
+ for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+ ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i];
+
+ /*
+ * Ignore loops unless they're still being built.
+ */
+
+ if (rangePtr->codeOffset > CurrentOffset(envPtr)) {
+ continue;
+ }
+ if (rangePtr->numCodeBytes != -1) {
+ continue;
+ }
+
+ /*
+ * Adequate condition: further out loops and further in exceptions
+ * don't actually need this information.
+ */
+
+ if (auxPtr->expandTarget == envPtr->expandCount) {
+ auxPtr->expandTargetDepth = envPtr->currStackDepth;
+ }
+ }
+
+ /*
+ * There's now one more expansion being processed on the auxiliary stack.
+ */
+
+ envPtr->expandCount++;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclFinalizeLoopExceptionRange --
+ *
+ * Finalizes a loop exception range, binding the registered [break] and
+ * [continue] implementations so that they jump to the correct place.
+ * Note that this must only be called after *all* the exception range
+ * target offsets have been set.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclFinalizeLoopExceptionRange(
+ CompileEnv *envPtr,
+ int range)
+{
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range];
+ ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range];
+ int i, offset;
+ unsigned char *site;
+
+ if (rangePtr->type != LOOP_EXCEPTION_RANGE) {
+ Tcl_Panic("trying to finalize a loop exception range");
+ }
+
+ /*
+ * Do the jump fixups. Note that these are always issued as INST_JUMP4 so
+ * there is no need to fuss around with updating code offsets.
+ */
+
+ for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
+ site = envPtr->codeStart + auxPtr->breakTargets[i];
+ offset = rangePtr->breakOffset - auxPtr->breakTargets[i];
+ TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
+ }
+ for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
+ site = envPtr->codeStart + auxPtr->continueTargets[i];
+ if (rangePtr->continueOffset == -1) {
+ int j;
+
+ /*
+ * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough
+ * space to do anything else.
+ */
+
+ *site = INST_CONTINUE;
+ for (j=0 ; j<4 ; j++) {
+ *++site = INST_NOP;
+ }
+ } else {
+ offset = rangePtr->continueOffset - auxPtr->continueTargets[i];
+ TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
+ }
+ }
+
+ /*
+ * Drop the arrays we were holding the only reference to.
+ */
+
+ if (auxPtr->breakTargets) {
+ ckfree(auxPtr->breakTargets);
+ auxPtr->breakTargets = NULL;
+ auxPtr->numBreakTargets = 0;
+ }
+ if (auxPtr->continueTargets) {
+ ckfree(auxPtr->continueTargets);
+ auxPtr->continueTargets = NULL;
+ auxPtr->numContinueTargets = 0;
+ }
+}
+
+/*
*----------------------------------------------------------------------
*
* TclCreateAuxData --
@@ -3480,67 +3878,20 @@ 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));
+ for (k = 0 ; k < envPtr->exceptArrayNext ; k++) {
+ ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k];
+ int i;
- if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) {
- Tcl_DeleteHashEntry(hPtr);
- map [n].pc += 3;
- n++;
+ for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
+ if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) {
+ auxPtr->breakTargets[i] += 3;
}
}
-
- /*
- * 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));
+ for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
+ if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) {
+ auxPtr->continueTargets[i] += 3;
+ }
}
-
- ckfree (map);
}
return 1; /* the jump was grown */
@@ -3692,7 +4043,7 @@ TclInitAuxDataTypeTable(void)
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
/*
- * There are only two AuxData type at this time, so register them here.
+ * There are only three AuxData types at this time, so register them here.
*/
RegisterAuxDataType(&tclForeachInfoType);
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 79497d2..5660055 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -100,6 +100,54 @@ typedef struct ExceptionRange {
} ExceptionRange;
/*
+ * Auxiliary data used when issuing (currently just loop) exception ranges,
+ * but which is not required during execution.
+ */
+
+typedef struct ExceptionAux {
+ int supportsContinue; /* Whether this exception range will have a
+ * continueOffset created for it; if it is a
+ * loop exception range that *doesn't* have
+ * one (see [for] next-clause) then we must
+ * not pick up the range when scanning for a
+ * target to continue to. */
+ int stackDepth; /* The stack depth at the point where the
+ * exception range was created. This is used
+ * to calculate the number of POPs required to
+ * restore the stack to its prior state. */
+ int expandTarget; /* The number of expansions expected on the
+ * auxData stack at the time the loop starts;
+ * we can't currently discard them except by
+ * doing INST_INVOKE_EXPANDED; this is a known
+ * problem. */
+ int expandTargetDepth; /* The stack depth expected at the outermost
+ * expansion within the loop. Not meaningful
+ * if there are no open expansions between the
+ * looping level and the point of jump
+ * issue. */
+ int numBreakTargets; /* The number of [break]s that want to be
+ * targeted to the place where this loop
+ * exception will be bound to. */
+ int *breakTargets; /* The offsets of the INST_JUMP4 instructions
+ * issued by the [break]s that we must
+ * update. Note that resizing a jump (via
+ * TclFixupForwardJump) can cause the contents
+ * of this array to be updated. When
+ * numBreakTargets==0, this is NULL. */
+ int allocBreakTargets; /* The size of the breakTargets array. */
+ int numContinueTargets; /* The number of [continue]s that want to be
+ * targeted to the place where this loop
+ * exception will be bound to. */
+ int *continueTargets; /* The offsets of the INST_JUMP4 instructions
+ * issued by the [continue]s that we must
+ * update. Note that resizing a jump (via
+ * TclFixupForwardJump) can cause the contents
+ * of this array to be updated. When
+ * numContinueTargets==0, this is NULL. */
+ int allocContinueTargets; /* The size of the continueTargets array. */
+} ExceptionAux;
+
+/*
* Structure used to map between instruction pc and source locations. It
* defines for each compiled Tcl command its code's starting offset and its
* source's starting offset and length. Note that the code offset increases
@@ -145,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;
/*
@@ -275,6 +316,11 @@ typedef struct CompileEnv {
* entry. */
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
+ ExceptionAux *exceptAuxArrayPtr;
+ /* Array of information used to restore the
+ * state when processing BREAK/CONTINUE
+ * exceptions. Must be the same size as the
+ * exceptArrayPtr. */
CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array.
* numCommands is the index of the next entry
* to use; (numCommands-1) is the entry index
@@ -296,6 +342,9 @@ typedef struct CompileEnv {
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
+ ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
+ /* Initial static except auxiliary info array
+ * storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
@@ -309,11 +358,13 @@ typedef struct CompileEnv {
int atCmdStart; /* Flag to say whether an INST_START_CMD
* should be issued; they should never be
* issued repeatedly, as that is significantly
- * inefficient. */
- ContLineLoc *clLoc; /* If not NULL, the table holding the
- * locations of the invisible continuation
- * lines in the input script, to adjust the
- * line counter. */
+ * inefficient. If set to 2, that instruction
+ * should not be issued at all (by the generic
+ * part of the command compiler). */
+ int expandCount; /* Number of INST_EXPAND_START instructions
+ * encountered that have not yet been paired
+ * with a corresponding
+ * INST_INVOKE_EXPANDED. */
int *clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
@@ -713,8 +764,12 @@ typedef struct ByteCode {
#define INST_INVOKE_REPLACE 163
+#define INST_LIST_CONCAT 164
+
+#define INST_EXPAND_DROP 165
+
/* The last opcode */
-#define LAST_INST_OPCODE 163
+#define LAST_INST_OPCODE 165
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -848,6 +903,9 @@ typedef struct ForeachInfo {
MODULE_SCOPE const AuxDataType tclForeachInfoType;
+#define FOREACHINFO(envPtr, index) \
+ ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
+
/*
* Structure used to hold information about a switch command that is needed
* during program execution. These structures are stored in CompileEnv and
@@ -861,6 +919,9 @@ typedef struct JumptableInfo {
MODULE_SCOPE const AuxDataType tclJumptableInfoType;
+#define JUMPTABLEINFO(envPtr, index) \
+ ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
+
/*
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
@@ -879,6 +940,9 @@ typedef struct {
MODULE_SCOPE const AuxDataType tclDictUpdateInfoType;
+#define DICTUPDATEINFO(envPtr, index) \
+ ((DictUpdateInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
+
/*
* ClientData type used by the math operator commands.
*/
@@ -916,7 +980,12 @@ 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);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
@@ -925,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);
@@ -971,10 +1043,19 @@ MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
int numBytes, const CmdFrame *invoker, int word);
MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
+MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
+ int returnCode, ExceptionAux **auxPtrPtr);
+MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr,
+ ExceptionAux *auxPtr);
+MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr,
+ ExceptionAux *auxPtr);
+MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
+ int range);
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr);
MODULE_SCOPE int TclLog2(int value);
#endif
+MODULE_SCOPE void TclOptimizeBytecode(CompileEnv *envPtr);
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
@@ -985,6 +1066,10 @@ MODULE_SCOPE void TclPrintObject(FILE *outFile,
Tcl_Obj *objPtr, int maxChars);
MODULE_SCOPE void TclPrintSource(FILE *outFile,
const char *string, int maxChars);
+MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, CompileEnv *envPtr,
+ int flags, int *localIndexPtr,
+ int *isScalarPtr);
MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr,
char *bytes, int length, int flags);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -1024,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
@@ -1090,6 +1184,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
} while (0)
/*
+ * Macros used to update the flag that indicates if we are at the start of a
+ * command, based on whether the opcode is INST_START_COMMAND.
+ *
+ * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr);
+ */
+
+#define TclUpdateAtCmdStart(op, envPtr) \
+ if ((envPtr)->atCmdStart < 2) { \
+ (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \
+ }
+
+/*
* Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C
* "prototype" for this macro is:
*
@@ -1102,7 +1208,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, 0, envPtr); \
} while (0)
@@ -1154,7 +1260,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
@@ -1172,7 +1278,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
(unsigned char) ((unsigned int) (i) >> 8); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) ); \
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
@@ -1305,16 +1411,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j))
/*
- * Convenience macro for use when compiling bodies of commands. The ANSI C
- * "prototype" for this macro is:
+ * Convenience macros for use when compiling bodies of commands. The ANSI C
+ * "prototype" for these macros are:
*
- * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp);
+ * static void BODY(Tcl_Token *tokenPtr, int word);
*/
-#define CompileBody(envPtr, tokenPtr, interp) \
- TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr))
+#define BODY(tokenPtr, word) \
+ SetLineInformation((word)); \
+ TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \
+ envPtr)
/*
* Convenience macro for use when compiling tokens to be pushed. The ANSI C
@@ -1328,15 +1434,19 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
(envPtr));
/*
- * Convenience macro for use when pushing literals. The ANSI C "prototype" for
- * this macro is:
+ * Convenience macros for use when pushing literals. The ANSI C "prototype" for
+ * these macros are:
*
* static void PushLiteral(CompileEnv *envPtr,
* const char *string, int length);
+ * static void PushStringLiteral(CompileEnv *envPtr,
+ * const char *string);
*/
#define PushLiteral(envPtr, string, length) \
TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+#define PushStringLiteral(envPtr, string) \
+ PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1))
/*
* Macro to advance to the next token; it is more mnemonic than the address
@@ -1365,14 +1475,11 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
* of LOOP ranges is an interesting datum for debugging purposes, and that is
* what we compute now.
*
- * static int DeclareExceptionRange(CompileEnv *envPtr, int type);
* static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
* static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
* static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
*/
-#define DeclareExceptionRange(envPtr, type) \
- (TclCreateExceptRange((type), (envPtr)))
#define ExceptionRangeStarts(envPtr, index) \
(((envPtr)->exceptDepth++), \
((envPtr)->maxExceptDepth = \
@@ -1403,6 +1510,76 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
Tcl_DStringLength(dsPtr), /*flags*/ 0)
/*
+ * Macro that encapsulates an efficiency trick that avoids a function call for
+ * the simplest of compiles. The ANSI C "prototype" for this macro is:
+ *
+ * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp, int word);
+ */
+
+#define CompileWord(envPtr, tokenPtr, interp, word) \
+ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
+ PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \
+ } else { \
+ SetLineInformation((word)); \
+ CompileTokens((envPtr), (tokenPtr), (interp)); \
+ }
+
+/*
+ * TIP #280: Remember the per-word line information of the current command. An
+ * index is used instead of a pointer as recursive compilation may reallocate,
+ * i.e. move, the array. This is also the reason to save the nuloc now, it may
+ * change during the course of the function.
+ *
+ * Macro to encapsulate the variable definition and setup.
+ */
+
+#define DefineLineInformation \
+ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
+ int eclIndex = mapPtr->nuloc - 1
+
+#define SetLineInformation(word) \
+ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
+ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
+
+#define PushVarNameWord(i,v,e,f,l,sc,word) \
+ SetLineInformation(word); \
+ TclPushVarName(i,v,e,f,l,sc)
+
+/*
+ * Often want to issue one of two versions of an instruction based on whether
+ * the argument will fit in a single byte or not. This makes it much clearer.
+ */
+
+#define Emit14Inst(nm,idx,envPtr) \
+ if (idx <= 255) { \
+ TclEmitInstInt1(nm##1,idx,envPtr); \
+ } else { \
+ TclEmitInstInt4(nm##4,idx,envPtr); \
+ }
+
+/*
+ * How to get an anonymous local variable (used for holding temporary values
+ * off the stack) or a local simple scalar.
+ */
+
+#define AnonymousLocal(envPtr) \
+ (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr)))
+#define LocalScalar(chars,len,envPtr) \
+ (!TclIsLocalScalar((chars), (len)) ? -1 : \
+ TclFindCompiledLocal((chars), (len), /*create*/ 1, (envPtr)))
+#define LocalScalarFromToken(tokenPtr,envPtr) \
+ ((tokenPtr)->type != TCL_TOKEN_SIMPLE_WORD ? -1 : \
+ LocalScalar((tokenPtr)[1].start, (tokenPtr)[1].size, (envPtr)))
+
+/*
+ * Flags bits used by TclPushVarName.
+ */
+
+#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
+#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
+
+/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index a4ba71a..2fb3e92 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -26,14 +26,15 @@
#define ASSOC_KEY "tclPackageAboutDict"
/*
- * A ClientData struct for the QueryConfig command. Store the two bits
+ * A ClientData struct for the QueryConfig command. Store the three bits
* of data we need; the package name for which we store a config dict,
- * and the (Tcl_Interp *) in which it is stored.
+ * the (Tcl_Interp *) in which it is stored, and the encoding.
*/
typedef struct QCCD {
Tcl_Obj *pkg;
Tcl_Interp *interp;
+ char *encoding;
} QCCD;
/*
@@ -75,22 +76,28 @@ Tcl_RegisterConfig(
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
+ Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
- Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
QCCD *cdPtr = ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
+ if (valEncoding) {
+ cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
+ strcpy(cdPtr->encoding, valEncoding);
+ } else {
+ cdPtr->encoding = NULL;
+ }
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
* Phase I: Adding the provided information to the internal database of
- * package meta data. Only if we have an ok encoding.
+ * package meta data.
*
* Phase II: Create a command for querying this database, specific to the
- * package registerting its configuration. This is the approved interface
+ * package registering its configuration. This is the approved interface
* in TIP 59. In the future a more general interface should be done, as
- * followup to TIP 59. Simply because our database is now general across
+ * follow-up to TIP 59. Simply because our database is now general across
* packages, and not a structure tied to one package.
*
* Note, the created command will have a reference through its clientdata.
@@ -103,51 +110,35 @@ Tcl_RegisterConfig(
* dictionaries visible at Tcl level. I.e. they are not filled
*/
- if (venc != NULL) {
- Tcl_Obj *pkgDict, *pDB = GetConfigDict(interp);
-
- /*
- * Retrieve package specific configuration...
- */
-
- if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
- || (pkgDict == NULL)) {
- pkgDict = Tcl_NewDictObj();
- } else if (Tcl_IsShared(pkgDict)) {
- pkgDict = Tcl_DuplicateObj(pkgDict);
- }
-
- /*
- * Extend the package configuration...
- */
-
- for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
- Tcl_DString conv;
- const char *convValue =
- Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
+ pDB = GetConfigDict(interp);
- /*
- * We know that the keys are in ASCII/UTF-8, so for them is no
- * conversion required.
- */
+ /*
+ * Retrieve package specific configuration...
+ */
- Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
- Tcl_NewStringObj(convValue, -1));
- Tcl_DStringFree(&conv);
- }
+ if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
+ || (pkgDict == NULL)) {
+ pkgDict = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(pkgDict)) {
+ pkgDict = Tcl_DuplicateObj(pkgDict);
+ }
- /*
- * We're now done with the encoding, so drop it.
- */
+ /*
+ * Extend the package configuration...
+ * We cannot assume that the encodings are initialized, therefore
+ * store the value as-is in a byte array. See Bug [9b2e636361].
+ */
- Tcl_FreeEncoding(venc);
+ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
+ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
+ Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
+ }
- /*
- * Write the changes back into the overall database.
- */
+ /*
+ * Write the changes back into the overall database.
+ */
- Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
- }
+ Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
@@ -218,6 +209,9 @@ QueryConfigObjCmd(
enum subcmds {
CFG_GET, CFG_LIST
};
+ Tcl_DString conv;
+ Tcl_Encoding venc = NULL;
+ const char *value;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
@@ -257,7 +251,21 @@ QueryConfigObjCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, val);
+ if (cdPtr->encoding) {
+ venc = Tcl_GetEncoding(interp, cdPtr->encoding);
+ if (!venc) {
+ return TCL_ERROR;
+ }
+ }
+ /*
+ * Value is stored as-is in a byte array, see Bug [9b2e636361],
+ * so we have to decode it first.
+ */
+ value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
+ value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
+ Tcl_DStringLength(&conv)));
+ Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
@@ -324,7 +332,10 @@ QueryConfigDelete(
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
- ckfree(cdPtr);
+ if (cdPtr->encoding) {
+ ckfree((char *)cdPtr->encoding);
+ }
+ ckfree((char *)cdPtr);
}
/*
@@ -366,7 +377,7 @@ GetConfigDict(
*
* This function is associated with the "Package About dict" assoc data
* for an interpreter; it is invoked when the interpreter is deleted in
- * order to free the information assoicated with any pending error
+ * order to free the information associated with any pending error
* reports.
*
* Results:
diff --git a/generic/tclDate.c b/generic/tclDate.c
index 14bac51..6222a8a 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -2686,7 +2686,7 @@ TclDatelex(
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
- while (isspace(UCHAR(*yyInput))) {
+ while (TclIsSpaceProc(*yyInput)) {
yyInput++;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 5fda514..4d40be1 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3818,10 +3818,93 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_PkgRequire
#define Tcl_PkgRequire(interp, name, version, exact) \
Tcl_PkgRequireEx(interp, name, version, exact, NULL)
+#undef Tcl_GetIndexFromObj
+#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \
+ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \
+ sizeof(char *), msg, flags, indexPtr)
+#undef Tcl_NewBooleanObj
+#define Tcl_NewBooleanObj(boolValue) \
+ Tcl_NewIntObj((boolValue)!=0)
+#undef Tcl_DbNewBooleanObj
+#define Tcl_DbNewBooleanObj(boolValue, file, line) \
+ Tcl_DbNewLongObj((boolValue)!=0, file, line)
+#undef Tcl_SetBooleanObj
+#define Tcl_SetBooleanObj(objPtr, boolValue) \
+ Tcl_SetIntObj((objPtr), (boolValue)!=0)
+#undef Tcl_SetVar
+#define Tcl_SetVar(interp, varName, newValue, flags) \
+ Tcl_SetVar2(interp, varName, NULL, newValue, flags)
+#undef Tcl_UnsetVar
+#define Tcl_UnsetVar(interp, varName, flags) \
+ Tcl_UnsetVar2(interp, varName, NULL, flags)
+#undef Tcl_GetVar
+#define Tcl_GetVar(interp, varName, flags) \
+ Tcl_GetVar2(interp, varName, NULL, flags)
+#undef Tcl_TraceVar
+#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \
+ Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData)
+#undef Tcl_UntraceVar
+#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
+ Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
+#undef Tcl_VarTraceInfo
+#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
+ Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
+#undef Tcl_UpVar
+#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
+ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
+
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
+/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
+ * we have to make sure that all stub entries on Cygwin64 follow the
+ * Win64 signature. Cygwin64 stubbed extensions cannot use those stub
+ * entries any more, they should use the 64-bit alternatives where
+ * possible. Tcl 9 must find a better solution, but that cannot be done
+ * without introducing a binary incompatibility.
+ */
+# undef Tcl_DbNewLongObj
+# undef Tcl_GetLongFromObj
+# undef Tcl_NewLongObj
+# undef Tcl_SetLongObj
+# undef Tcl_ExprLong
+# undef Tcl_ExprLongObj
+# undef Tcl_UniCharNcmp
+# undef Tcl_UtfNcmp
+# undef Tcl_UtfNcasecmp
+# undef Tcl_UniCharNcasecmp
+# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj)
+# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
+# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj)
+# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj)
+# define Tcl_ExprLong TclExprLong
+ static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
+ int intValue;
+ int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue);
+ if (result == TCL_OK) *ptr = (long)intValue;
+ return result;
+ }
+# define Tcl_ExprLongObj TclExprLongObj
+ static inline int TclExprLongObj(Tcl_Interp *interp, Tcl_Obj *obj, long *ptr){
+ int intValue;
+ int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue);
+ if (result == TCL_OK) *ptr = (long)intValue;
+ return result;
+ }
+# define Tcl_UniCharNcmp(ucs,uct,n) \
+ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n))
+# define Tcl_UtfNcmp(s1,s2,n) \
+ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
+# define Tcl_UtfNcasecmp(s1,s2,n) \
+ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n))
+# define Tcl_UniCharNcasecmp(ucs,uct,n) \
+ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n))
+# endif
+#endif
/*
* Deprecated Tcl procedures:
*/
+
#undef Tcl_EvalObj
#define Tcl_EvalObj(interp,objPtr) \
Tcl_EvalObjEx((interp),(objPtr),0)
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 813e056..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);
@@ -88,16 +85,6 @@ const Tcl_ObjType tclEnsembleCmdType = {
NULL /* setFromAnyProc */
};
-/*
- * Copied from tclCompCmds.c
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
static inline Tcl_Obj *
NewNsObj(
@@ -1537,6 +1524,14 @@ TclMakeEnsemble(
cmdName = nameParts[nameCount - 1];
}
}
+
+ /*
+ * Switch on compilation always for core ensembles now that we can do
+ * nice bytecode things with them. Do it now. Waiting until later will
+ * just cause pointless epoch bumps.
+ */
+
+ ensembleFlags |= ENSEMBLE_COMPILE;
ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
/*
@@ -1588,14 +1583,6 @@ TclMakeEnsemble(
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
-
- /*
- * Switch on compilation always for core ensembles now that we can do
- * nice bytecode things with them.
- */
-
- Tcl_SetEnsembleFlags(interp, ensemble,
- ensembleFlags | ENSEMBLE_COMPILE);
}
Tcl_DStringFree(&buf);
@@ -3004,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;
}
@@ -3039,95 +3026,88 @@ 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;
if (cmdPtr->compileProc == NULL) {
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...
+ * 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.
*/
- 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);
+ for (i = 0; i < depth - 1; i++) {
+ parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
}
+ parsePtr->numWords -= (depth - 1);
/*
- * Copy over the real argument tokens.
+ * Shift the line information arrays to account for different word
+ * index values.
*/
- 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);
- }
+ mapPtr->loc[eclIndex].line += (depth - 1);
+ mapPtr->loc[eclIndex].next += (depth - 1);
/*
* Hand off compilation to the subcommand compiler. At last!
*/
- result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
+ result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr);
/*
- * If our target fails to compile, revert the number of commands and the
- * pointer to the place to issue the next instruction. [Bug 3600328]
+ * Undo the shift.
+ */
+
+ mapPtr->loc[eclIndex].line -= (depth - 1);
+ mapPtr->loc[eclIndex].next -= (depth - 1);
+
+ parsePtr->numWords += (depth - 1);
+ parsePtr->tokenPtr = saveTokenPtr;
+
+ /*
+ * 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;
}
@@ -3157,11 +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) {
+ continue;
+ }
+
+ SetLineInformation(i);
+ if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterNewLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size);
@@ -3169,16 +3154,12 @@ CompileToInvokedCommand(
TclContinuationsEnterDerived(
TclFetchLiteral(envPtr, literal),
tokPtr[1].start - envPtr->source,
- mapPtr->loc[eclIndex].next[i]);
+ envPtr->clNext);
}
TclEmitPush(literal, envPtr);
} else {
- if (envPtr->clNext) {
- SetLineInformation(i);
- }
CompileTokens(envPtr, tokPtr, interp);
}
- tokPtr = TokenAfter(tokPtr);
}
/*
@@ -3224,51 +3205,13 @@ CompileBasicNArgCommand(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *tokenPtr;
- Tcl_Obj *objPtr;
- char *bytes;
- int length, i, literal;
- DefineLineInformation;
-
- /*
- * Push the name of the command we're actually dispatching to as part of
- * the implementation.
- */
+ Tcl_Obj *objPtr = Tcl_NewObj();
- 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 (envPtr->clNext) {
- SetLineInformation(i);
- }
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size);
- } else {
- 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/tclEvent.c b/generic/tclEvent.c
index c8ba1e6..686b80d 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1030,14 +1030,8 @@ TclInitSubsystems(void)
TclpInitLock();
if (subsystemsInitialized == 0) {
- /*
- * Have to set this bit here to avoid deadlock with the routines
- * below us that call into TclInitSubsystems.
- */
-
- subsystemsInitialized = 1;
- /*
+ /*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
@@ -1061,6 +1055,7 @@ TclInitSubsystems(void)
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ subsystemsInitialized = 1;
}
TclpInitUnlock();
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index be2e3ca..d066476 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -202,6 +202,9 @@ typedef struct TEBCdata {
#define PUSH_TAUX_OBJ(objPtr) \
do { \
+ if (auxObjList) { \
+ objPtr->length += auxObjList->length; \
+ } \
objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \
auxObjList = objPtr; \
} while (0)
@@ -257,7 +260,7 @@ VarHashCreateVar(
/* Verify the stack depth, only when no expansion is in progress */
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
#define CHECK_STACK() \
do { \
ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
@@ -434,7 +437,7 @@ VarHashCreateVar(
* ClientData *ptrPtr, int *tPtr);
*/
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
@@ -450,7 +453,7 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#else /* !NO_WIDE_TYPE */
+#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
@@ -470,7 +473,7 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#endif /* NO_WIDE_TYPE */
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used in this file to save a function call for common uses of
@@ -494,13 +497,13 @@ VarHashCreateVar(
* Tcl_WideInt *wideIntPtr);
*/
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#else /* !NO_WIDE_TYPE */
+#else /* !TCL_WIDE_INT_IS_LONG */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclWideIntType) \
? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
@@ -508,7 +511,7 @@ VarHashCreateVar(
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif /* NO_WIDE_TYPE */
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -718,13 +721,13 @@ 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,
const unsigned char *pc, Tcl_Obj *opndPtr);
static void InitByteCodeExecution(Tcl_Interp *interp);
-static inline int OFFSET(void *ptr);
+static inline int wordSkip(void *ptr);
static void ReleaseDictIterator(Tcl_Obj *objPtr);
/* Useful elsewhere, make available in tclInt.h or stubs? */
static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
@@ -1001,13 +1004,13 @@ TclFinalizeExecution(void)
(TCL_ALLOCALIGN/sizeof(Tcl_Obj *))
/*
- * OFFSET computes how many words have to be skipped until the next aligned
+ * wordSkip computes how many words have to be skipped until the next aligned
* word. Note that we are only interested in the low order bits of ptr, so
* that any possible information loss in PTR2INT is of no consequence.
*/
static inline int
-OFFSET(
+wordSkip(
void *ptr)
{
int mask = TCL_ALLOCALIGN-1;
@@ -1020,7 +1023,7 @@ OFFSET(
*/
#define MEMSTART(markerPtr) \
- ((markerPtr) + OFFSET(markerPtr))
+ ((markerPtr) + wordSkip(markerPtr))
/*
*----------------------------------------------------------------------
@@ -1065,7 +1068,7 @@ GrowEvaluationStack(
} else {
#ifndef PURIFY
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
- int offset = OFFSET(tmpMarkerPtr);
+ int offset = wordSkip(tmpMarkerPtr);
if (needed + offset < 0) {
/*
@@ -1423,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);
}
@@ -1444,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;
}
@@ -1868,7 +1867,7 @@ TclIncrObj(
TclSetLongObj(valuePtr, sum);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
{
Tcl_WideInt w1 = (Tcl_WideInt) augend;
Tcl_WideInt w2 = (Tcl_WideInt) addend;
@@ -1901,7 +1900,7 @@ TclIncrObj(
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
Tcl_WideInt w1, w2, sum;
@@ -1999,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;
@@ -2007,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++;
@@ -2131,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);
@@ -2142,11 +2146,6 @@ TEBCresume(
CACHE_STACK_INFO();
if (result == TCL_OK) {
-#ifndef TCL_COMPILE_DEBUG
- if (*pc == INST_POP) {
- NEXT_INST_V(1, cleanup, 0);
- }
-#endif
/*
* Push the call's object result and continue execution with the
* next instruction.
@@ -2155,8 +2154,6 @@ TEBCresume(
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
- objResultPtr = Tcl_GetObjResult(interp);
-
/*
* Reset the interp's result to avoid possible duplications of
* large objects [Bug 781585]. We do not call Tcl_ResetResult to
@@ -2168,9 +2165,16 @@ TEBCresume(
* the refCount it had in its role of iPtr->objResultPtr.
*/
+ objResultPtr = Tcl_GetObjResult(interp);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
+#ifndef TCL_COMPILE_DEBUG
+ if (*pc == INST_POP) {
+ TclDecrRefCount(objResultPtr);
+ NEXT_INST_V(1, cleanup, 0);
+ }
+#endif
NEXT_INST_V(0, cleanup, -1);
}
@@ -2320,7 +2324,7 @@ TEBCresume(
goto instLoadScalar1;
} else if (inst == INST_PUSH1) {
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
- TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
+ TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS);
inst = *(pc += 2);
goto peepholeStart;
} else if (inst == INST_START_CMD) {
@@ -2331,13 +2335,22 @@ TEBCresume(
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (checkInterp) {
checkInterp = 0;
- if ((codePtr->compileEpoch != iPtr->compileEpoch)
- || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) {
+ if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
+ (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
+ !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
goto instStartCmdFailed;
}
}
inst = *(pc += 9);
goto peepholeStart;
+ } else if (inst == INST_NOP) {
+#ifndef TCL_COMPILE_DEBUG
+ while (inst == INST_NOP)
+#endif
+ {
+ inst = *++pc;
+ }
+ goto peepholeStart;
}
switch (inst) {
@@ -2353,7 +2366,7 @@ TEBCresume(
TRACE(("%u %u => ", code, level));
result = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(9, 1, 0);
}
@@ -2362,6 +2375,7 @@ TEBCresume(
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
cleanup = 2;
+ TRACE_APPEND(("\n"));
goto processExceptionReturn;
}
@@ -2369,15 +2383,30 @@ TEBCresume(
TRACE(("=> "));
objResultPtr = POP_OBJECT();
result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
- Tcl_DecrRefCount(OBJ_AT_TOS);
- OBJ_AT_TOS = objResultPtr;
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = objResultPtr;
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
+ } else if (result == TCL_ERROR) {
+ /*
+ * BEWARE! Must do this in this order, because an error in the
+ * option dictionary overrides the result (and can be verified by
+ * test).
+ */
+
+ Tcl_SetObjResult(interp, objResultPtr);
+ Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = objResultPtr;
+ } else {
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = objResultPtr;
+ Tcl_SetObjResult(interp, objResultPtr);
}
- Tcl_SetObjResult(interp, objResultPtr);
cleanup = 1;
+ TRACE_APPEND(("\n"));
goto processExceptionReturn;
case INST_YIELD: {
@@ -2407,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++;
@@ -2501,9 +2533,6 @@ TEBCresume(
TclDecrRefCount(objPtr);
NEXT_INST_F(1, 0, 0);
- case INST_NOP:
- NEXT_INST_F(1, 0, 0);
-
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
TRACE_WITH_OBJ(("=> "), objResultPtr);
@@ -2610,7 +2639,7 @@ TEBCresume(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
TclFreeIntRep(objResultPtr);
objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
@@ -2646,7 +2675,7 @@ TEBCresume(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
if (!Tcl_IsShared(objResultPtr)) {
bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
length + appendLen);
@@ -2695,9 +2724,26 @@ TEBCresume(
TclNewObj(objPtr);
objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH;
+ objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
NEXT_INST_F(1, 0, 0);
+ case INST_EXPAND_DROP:
+ /*
+ * Drops an element of the auxObjList, popping stack elements to
+ * restore the stack to the state before the point where the aux
+ * element was created.
+ */
+
+ CLANG_ASSERT(auxObjList);
+ objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
+ POP_TAUX_OBJ();
+#ifdef TCL_COMPILE_DEBUG
+ /* Ugly abuse! */
+ starting = 1;
+#endif
+ NEXT_INST_V(1, objc, 0);
+
case INST_EXPAND_STKTOP: {
int i;
ptrdiff_t moved;
@@ -2723,22 +2769,27 @@ TEBCresume(
* stack depth, as seen by the compiler.
*/
- length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
- DECACHE_STACK_INFO();
- moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
- - (Tcl_Obj **) TD;
- if (moved) {
- /*
- * Change the global data to point to the new stack: move the
- * TEBCdataPtr TD, recompute the position of every other
- * stack-allocated parameter, update the stack pointers.
- */
+ auxObjList->length += objc - 1;
+ if ((objc > 1) && (auxObjList->length > 0)) {
+ length = auxObjList->length /* Total expansion room we need */
+ + codePtr->maxStackDepth /* Beyond the original max */
+ - CURR_DEPTH; /* Relative to where we are */
+ DECACHE_STACK_INFO();
+ moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
+ - (Tcl_Obj **) TD;
+ if (moved) {
+ /*
+ * Change the global data to point to the new stack: move the
+ * TEBCdataPtr TD, recompute the position of every other
+ * stack-allocated parameter, update the stack pointers.
+ */
- esPtr = iPtr->execEnvPtr->execStackPtr;
- TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+ esPtr = iPtr->execEnvPtr->execStackPtr;
+ TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
- catchTop += moved;
- tosPtr += moved;
+ catchTop += moved;
+ tosPtr += moved;
+ }
}
/*
@@ -2842,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();
@@ -2851,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:
@@ -2988,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;
@@ -3414,7 +3471,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
#endif
long increment;
@@ -3536,7 +3593,7 @@ TEBCresume(
}
goto doneIncr;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
@@ -3558,7 +3615,7 @@ TEBCresume(
goto doneIncr;
#endif
} /* end if (type == TCL_NUMBER_LONG) */
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt sum;
@@ -3626,7 +3683,7 @@ TEBCresume(
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
- TRACE(("%u %ld => ", opnd, increment));
+ TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
@@ -4191,7 +4248,7 @@ TEBCresume(
} else {
TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0],
O2S(valuePtr),
- (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
+ (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
@@ -4763,6 +4820,29 @@ TEBCresume(
objResultPtr = TCONST(match);
NEXT_INST_F(0, 2, 1);
+ case INST_LIST_CONCAT:
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ if (Tcl_ListObjAppendList(interp, objResultPtr,
+ value2Ptr) != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TclDecrRefCount(objResultPtr);
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ } else {
+ if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+
/*
* End of INST_LIST and related instructions.
* -----------------------------------------------------------------
@@ -5634,7 +5714,7 @@ TEBCresume(
w1 = (Tcl_WideInt) l1;
w2 = (Tcl_WideInt) l2;
wResult = w1 + w2;
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
/*
* Check for overflow.
*/
@@ -5649,7 +5729,7 @@ TEBCresume(
w1 = (Tcl_WideInt) l1;
w2 = (Tcl_WideInt) l2;
wResult = w1 - w2;
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
/*
* Must check for overflow. The macro tests for overflows in
* sums by looking at the sign bits. As we have a subtraction
@@ -6551,7 +6631,7 @@ TEBCresume(
}
#endif
- TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
+ TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
objResultPtr = TCONST(done);
/* TODO: consider opt like INST_FOREACH_STEP4 */
@@ -6565,7 +6645,7 @@ TEBCresume(
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- TRACE(("%u => ", opnd));
+ TRACE(("%u => \n", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
@@ -6694,6 +6774,7 @@ TEBCresume(
O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
goto gotError;
}
+ TRACE((" => "));
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -6781,7 +6862,7 @@ TEBCresume(
*/
processExceptionReturn:
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
@@ -6838,7 +6919,7 @@ TEBCresume(
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
objPtr = Tcl_GetObjResult(interp);
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
@@ -6900,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);
@@ -7082,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));
@@ -7194,7 +7275,7 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *)ptr1);
if (type2 != TCL_NUMBER_BIG) {
@@ -7269,7 +7350,7 @@ ExecuteExtendedBinaryMathOp(
case TCL_NUMBER_LONG:
invalid = (*((const long *)ptr2) < 0L);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
break;
@@ -7353,7 +7434,7 @@ ExecuteExtendedBinaryMathOp(
case TCL_NUMBER_LONG:
zero = (*(const long *)ptr1 > 0L);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
break;
@@ -7374,7 +7455,7 @@ ExecuteExtendedBinaryMathOp(
}
shift = (int)(*(const long *)ptr2);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
* Handle shifts within the native wide range.
*/
@@ -7557,7 +7638,7 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
TclGetWideIntFromObj(NULL, valuePtr, &w1);
TclGetWideIntFromObj(NULL, value2Ptr, &w2);
@@ -7635,7 +7716,7 @@ ExecuteExtendedBinaryMathOp(
negativeExponent = (l2 < 0);
oddExponent = (int) (l2 & 1);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
negativeExponent = (w2 < 0);
@@ -7827,7 +7908,7 @@ ExecuteExtendedBinaryMathOp(
#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
if (type1 == TCL_NUMBER_LONG) {
w1 = l1;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *) ptr1);
#endif
@@ -8030,7 +8111,7 @@ ExecuteExtendedBinaryMathOp(
switch (opcode) {
case INST_ADD:
wResult = w1 + w2;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
{
@@ -8046,7 +8127,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = w1 - w2;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
{
@@ -8172,7 +8253,7 @@ ExecuteExtendedUnaryMathOp(
switch (opcode) {
case INST_BITNOT:
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
@@ -8194,7 +8275,7 @@ ExecuteExtendedUnaryMathOp(
}
TclBNInitBignumFromLong(&big, *(const long *) ptr);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w = *((const Tcl_WideInt *) ptr);
if (w != LLONG_MIN) {
@@ -8246,7 +8327,7 @@ TclCompareTwoNumbers(
mp_int big1, big2;
double d1, d2, tmp;
long l1, l2;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w1, w2;
#endif
@@ -8261,7 +8342,7 @@ TclCompareTwoNumbers(
l2 = *((const long *)ptr2);
longCompare:
return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
w1 = (Tcl_WideInt)l1;
@@ -8313,7 +8394,7 @@ TclCompareTwoNumbers(
return compare;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
@@ -8374,7 +8455,7 @@ TclCompareTwoNumbers(
}
l1 = (long) d1;
goto longCompare;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;
@@ -8418,7 +8499,7 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
#endif
case TCL_NUMBER_LONG:
@@ -8575,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);
@@ -8659,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
@@ -8680,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
@@ -8698,13 +8789,17 @@ 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) {
+ assert(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.
@@ -8721,7 +8816,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++) {
@@ -8761,9 +8856,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;
@@ -8773,6 +8871,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;
@@ -8840,6 +8939,7 @@ GetSrcInfoForPc(
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
+ bestCmdIdx = i;
}
}
}
@@ -8869,6 +8969,10 @@ GetSrcInfoForPc(
*lengthPtr = bestSrcLength;
}
+ if (cmdIdxPtr != NULL) {
+ *cmdIdxPtr = bestCmdIdx;
+ }
+
return (codePtr->source + bestSrcOffset);
}
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 694501f..7d6c462 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -139,7 +139,7 @@ int
TclCreateSocketAddress(
Tcl_Interp *interp, /* Interpreter for querying
* the desired socket family */
- struct addrinfo **addrlist, /* Socket address list */
+ void **addrlist, /* Socket address list */
const char *host, /* Host. NULL implies INADDR_ANY */
int port, /* Port number */
int willBind, /* Is this an address to bind() to or
@@ -213,7 +213,7 @@ TclCreateSocketAddress(
hints.ai_flags |= AI_PASSIVE;
}
- result = getaddrinfo(native, portstring, &hints, addrlist);
+ result = getaddrinfo(native, portstring, &hints, (struct addrinfo **) addrlist);
if (host != NULL) {
Tcl_DStringFree(&ds);
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 25ed57c..6259216 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -3225,6 +3225,9 @@ Tcl_LoadFile(
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
+ if (copyToPtr == NULL) {
+ return TCL_ERROR;
+ }
Tcl_IncrRefCount(copyToPtr);
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 70d6d02..e0e694f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -23,7 +23,6 @@
* Some numerics configuration options.
*/
-#undef NO_WIDE_TYPE
#undef ACCEPT_NAN
/*
@@ -31,8 +30,7 @@
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
* greater modularity. The order of the three groups of #includes is
- * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_
- * declaration in tcl.h is needed by stdlib.h in some configurations.
+ * important. For example, stdio.h is needed by tcl.h.
*/
#include "tclPort.h"
@@ -96,14 +94,6 @@ typedef int ptrdiff_t;
#endif
/*
- * When Tcl_WideInt and long are the same type, there's no value in
- * having a tclWideIntType separate from the tclIntType.
- */
-#ifdef TCL_WIDE_INT_IS_LONG
-#define NO_WIDE_TYPE
-#endif
-
-/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
* to/from pointer from/to integer of different size".
@@ -128,6 +118,10 @@ typedef int ptrdiff_t;
# endif
#endif
+#if defined(_WIN32) && defined(_MSC_VER)
+# define vsnprintf _vsnprintf
+#endif
+
/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
@@ -1181,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 {
@@ -1216,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
@@ -1288,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
@@ -1301,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. */
@@ -1690,6 +1672,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
@@ -1700,6 +1685,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
/*
*----------------------------------------------------------------
@@ -2212,9 +2198,9 @@ 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
/*
* Flag bits for Interp structures:
@@ -2671,7 +2657,7 @@ MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
MODULE_SCOPE const Tcl_ObjType tclWideIntType;
#endif
MODULE_SCOPE const Tcl_ObjType tclRegexpType;
@@ -2831,7 +2817,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,
@@ -2922,7 +2908,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);
@@ -3013,9 +3000,8 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr);
MODULE_SCOPE void TclpFinalizePipes(void);
MODULE_SCOPE void TclpFinalizeSockets(void);
MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp,
- struct addrinfo **addrlist,
- const char *host, int port, int willBind,
- const char **errorMsgPtr);
+ void **addrlist, const char *host, int port,
+ int willBind, const char **errorMsgPtr);
MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
Tcl_ThreadCreateProc *proc, ClientData clientData,
int stackSize, int flags);
@@ -3100,6 +3086,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
+MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
@@ -4409,7 +4396,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*----------------------------------------------------------------
*/
-#define TclSetIntObj(objPtr, i) \
+#define TclSetLongObj(objPtr, i) \
do { \
TclInvalidateStringRep(objPtr); \
TclFreeIntRep(objPtr); \
@@ -4417,8 +4404,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
(objPtr)->typePtr = &tclIntType; \
} while (0)
-#define TclSetLongObj(objPtr, l) \
- TclSetIntObj((objPtr), (l))
+#define TclSetIntObj(objPtr, l) \
+ TclSetLongObj(objPtr, l)
/*
* NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
@@ -4428,9 +4415,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#define TclSetBooleanObj(objPtr, b) \
- TclSetIntObj((objPtr), ((b)? 1 : 0));
+ TclSetLongObj(objPtr, (b)!=0);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
#define TclSetWideIntObj(objPtr, w) \
do { \
TclInvalidateStringRep(objPtr); \
@@ -4466,7 +4453,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#ifndef TCL_MEM_DEBUG
-#define TclNewIntObj(objPtr, i) \
+#define TclNewLongObj(objPtr, i) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
@@ -4477,15 +4464,15 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewLongObj(objPtr, l) \
- TclNewIntObj((objPtr), (l))
+#define TclNewIntObj(objPtr, l) \
+ TclNewLongObj(objPtr, l)
/*
* NOTE: There is to be no such thing as a "pure" boolean.
* See comment above TclSetBooleanObj macro above.
*/
#define TclNewBooleanObj(objPtr, b) \
- TclNewIntObj((objPtr), ((b)? 1 : 0))
+ TclNewLongObj((objPtr), (b)!=0)
#define TclNewDoubleObj(objPtr, d) \
do { \
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index dcf1753..3181d4e 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -545,6 +545,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
+#undef TclpInetNtoa
+#define TclpInetNtoa inet_ntoa
#if defined(__WIN32__) || defined(__CYGWIN__)
# undef TclWinNToHS
diff --git a/generic/tclMain.c b/generic/tclMain.c
index f445383..faea75a 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -313,6 +313,9 @@ Tcl_MainEx(
Tcl_Channel chan;
InteractiveState is;
+ TclpSetInitialEncodings();
+ TclpFindExecutable((const char *)argv[0]);
+
Tcl_InitMemory(interp);
is.interp = interp;
@@ -640,7 +643,6 @@ Tcl_Main(
* function to call after most initialization
* but before starting to execute commands. */
{
- Tcl_FindExecutable(argv[0]);
Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
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/tclOOMethod.c b/generic/tclOOMethod.c
index bd2744a..7595f82 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);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 1bed667..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);
@@ -212,7 +211,7 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
#endif
@@ -272,7 +271,7 @@ const Tcl_ObjType tclIntType = {
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
const Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
NULL, /* freeIntRepProc */
@@ -410,7 +409,7 @@ TclInitObjSubsystem(void)
/* For backward compatibility only ... */
Tcl_RegisterObjType(&oldBooleanType);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_RegisterObjType(&tclWideIntType);
#endif
@@ -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);
}
}
@@ -1915,7 +1883,7 @@ Tcl_GetBooleanFromObj(
*boolPtr = 1;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
@@ -1970,7 +1938,7 @@ TclSetBooleanFromAny(
goto badBoolean;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
goto badBoolean;
}
@@ -2302,7 +2270,7 @@ Tcl_GetDoubleFromObj(
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
@@ -2760,7 +2728,7 @@ Tcl_GetLongFromObj(
*longPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
/*
* We return any integer in the range -ULONG_MAX to ULONG_MAX
@@ -2818,7 +2786,7 @@ Tcl_GetLongFromObj(
return TCL_OK;
}
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
@@ -2834,7 +2802,7 @@ Tcl_GetLongFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
@@ -2876,7 +2844,7 @@ UpdateStringOfWideInt(
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
-#endif /* !NO_WIDE_TYPE */
+#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3031,7 +2999,7 @@ Tcl_SetWideIntObj(
&& (wideValue <= (Tcl_WideInt) LONG_MAX)) {
TclSetLongObj(objPtr, (long) wideValue);
} else {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
TclSetWideIntObj(objPtr, wideValue);
#else
mp_int big;
@@ -3071,7 +3039,7 @@ Tcl_GetWideIntFromObj(
/* Place to store resulting long. */
{
do {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
@@ -3131,7 +3099,7 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
@@ -3157,7 +3125,7 @@ SetWideIntFromAny(
Tcl_WideInt w;
return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
-#endif /* !NO_WIDE_TYPE */
+#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3405,7 +3373,7 @@ GetBignumFromObj(
TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
TclBNInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
@@ -3544,7 +3512,7 @@ Tcl_SetBignumObj(
return;
}
tooLargeForLong:
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
@@ -3656,7 +3624,7 @@ TclGetNumberFromObj(
*clientDataPtr = &objPtr->internalRep.longValue;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
*clientDataPtr = &objPtr->internalRep.wideValue;
diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
new file mode 100644
index 0000000..b7f4173
--- /dev/null
+++ b/generic/tclOptimize.c
@@ -0,0 +1,428 @@
+/*
+ * tclOptimize.c --
+ *
+ * This file contains the bytecode optimizer.
+ *
+ * Copyright (c) 2013 by Donal Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include <assert.h>
+
+/*
+ * Forward declarations.
+ */
+
+static void AdvanceJumps(CompileEnv *envPtr);
+static void ConvertZeroEffectToNOP(CompileEnv *envPtr);
+static void LocateTargetAddresses(CompileEnv *envPtr,
+ Tcl_HashTable *tablePtr);
+static void TrimUnreachable(CompileEnv *envPtr);
+
+/*
+ * Helper macros.
+ */
+
+#define DefineTargetAddress(tablePtr, address) \
+ ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
+#define IsTargetAddress(tablePtr, address) \
+ (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
+#define AddrLength(address) \
+ (tclInstructionTable[*(unsigned char *)(address)].numBytes)
+#define InstLength(instruction) \
+ (tclInstructionTable[(unsigned char)(instruction)].numBytes)
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * LocateTargetAddresses --
+ *
+ * Populate a hash table with places that we need to be careful around
+ * because they're the targets of various kinds of jumps and other
+ * non-local behavior.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+LocateTargetAddresses(
+ CompileEnv *envPtr,
+ Tcl_HashTable *tablePtr)
+{
+ unsigned char *currentInstPtr, *targetInstPtr;
+ int isNew, i;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hSearch;
+
+ Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);
+
+ /*
+ * The starts of commands represent target addresses.
+ */
+
+ for (i=0 ; i<envPtr->numCommands ; i++) {
+ DefineTargetAddress(tablePtr,
+ envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset);
+ }
+
+ /*
+ * Find places where we should be careful about replacing instructions
+ * because they are the targets of various types of jumps.
+ */
+
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext ;
+ currentInstPtr += AddrLength(currentInstPtr)) {
+ switch (*currentInstPtr) {
+ case INST_JUMP1:
+ case INST_JUMP_TRUE1:
+ case INST_JUMP_FALSE1:
+ targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1);
+ goto storeTarget;
+ case INST_JUMP4:
+ case INST_JUMP_TRUE4:
+ case INST_JUMP_FALSE4:
+ case INST_START_CMD:
+ targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1);
+ goto storeTarget;
+ case INST_BEGIN_CATCH4:
+ targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[
+ TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset;
+ storeTarget:
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ break;
+ case INST_JUMP_TABLE:
+ hPtr = Tcl_FirstHashEntry(
+ &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable,
+ &hSearch);
+ for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ targetInstPtr = currentInstPtr +
+ PTR2INT(Tcl_GetHashValue(hPtr));
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ }
+ break;
+ case INST_RETURN_CODE_BRANCH:
+ for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) {
+ DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1);
+ }
+ break;
+ }
+ }
+
+ /*
+ * Add a marker *after* the last bytecode instruction. WARNING: points to
+ * one past the end!
+ */
+
+ DefineTargetAddress(tablePtr, currentInstPtr);
+
+ /*
+ * Enter in the targets of exception ranges.
+ */
+
+ for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+
+ if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
+ targetInstPtr = envPtr->codeStart + rangePtr->catchOffset;
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ } else {
+ targetInstPtr = envPtr->codeStart + rangePtr->breakOffset;
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ if (rangePtr->continueOffset >= 0) {
+ targetInstPtr = envPtr->codeStart + rangePtr->continueOffset;
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ }
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TrimUnreachable --
+ *
+ * Converts code that provably can't be executed into NOPs and reduces
+ * the overall reported length of the bytecode where that is possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+TrimUnreachable(
+ CompileEnv *envPtr)
+{
+ unsigned char *currentInstPtr;
+ Tcl_HashTable targets;
+
+ LocateTargetAddresses(envPtr, &targets);
+
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext-1 ;
+ currentInstPtr += AddrLength(currentInstPtr)) {
+ int clear = 0;
+
+ if (*currentInstPtr != INST_DONE) {
+ continue;
+ }
+
+ while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) {
+ clear += AddrLength(currentInstPtr + 1 + clear);
+ }
+ if (currentInstPtr + 1 + clear == envPtr->codeNext) {
+ envPtr->codeNext -= clear;
+ } else {
+ while (clear --> 0) {
+ *(currentInstPtr + 1 + clear) = INST_NOP;
+ }
+ }
+ }
+
+ Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ConvertZeroEffectToNOP --
+ *
+ * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also
+ * replace PUSH empty/CONCAT and TRY_CVT_NUMERIC (when followed by an
+ * operation that guarantees the check for arithmeticity) and eliminate
+ * LNOT when we can invert the following JUMP condition.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ConvertZeroEffectToNOP(
+ CompileEnv *envPtr)
+{
+ unsigned char *currentInstPtr;
+ int size;
+ Tcl_HashTable targets;
+
+ LocateTargetAddresses(envPtr, &targets);
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext ; currentInstPtr += size) {
+ int blank = 0, i, nextInst;
+
+ size = AddrLength(currentInstPtr);
+ while ((currentInstPtr + size < envPtr->codeNext)
+ && *(currentInstPtr+size) == INST_NOP) {
+ if (IsTargetAddress(&targets, currentInstPtr + size)) {
+ break;
+ }
+ size += InstLength(INST_NOP);
+ }
+ if (IsTargetAddress(&targets, currentInstPtr + size)) {
+ continue;
+ }
+ nextInst = *(currentInstPtr + size);
+ switch (*currentInstPtr) {
+ case INST_PUSH1:
+ if (nextInst == INST_POP) {
+ blank = size + InstLength(nextInst);
+ } else if (nextInst == INST_CONCAT1
+ && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
+ Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
+ TclGetUInt1AtPtr(currentInstPtr + 1));
+ int numBytes;
+
+ (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ if (numBytes == 0) {
+ blank = size + InstLength(nextInst);
+ }
+ }
+ break;
+ case INST_PUSH4:
+ if (nextInst == INST_POP) {
+ blank = size + 1;
+ } else if (nextInst == INST_CONCAT1
+ && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
+ Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
+ TclGetUInt4AtPtr(currentInstPtr + 1));
+ int numBytes;
+
+ (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ if (numBytes == 0) {
+ blank = size + InstLength(nextInst);
+ }
+ }
+ break;
+
+ case INST_LNOT:
+ switch (nextInst) {
+ case INST_JUMP_TRUE1:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_FALSE1;
+ break;
+ case INST_JUMP_FALSE1:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_TRUE1;
+ break;
+ case INST_JUMP_TRUE4:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_FALSE4;
+ break;
+ case INST_JUMP_FALSE4:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_TRUE4;
+ break;
+ }
+ break;
+
+ case INST_TRY_CVT_TO_NUMERIC:
+ switch (nextInst) {
+ case INST_JUMP_TRUE1:
+ case INST_JUMP_TRUE4:
+ case INST_JUMP_FALSE1:
+ case INST_JUMP_FALSE4:
+ case INST_INCR_SCALAR1:
+ case INST_INCR_ARRAY1:
+ case INST_INCR_ARRAY_STK:
+ case INST_INCR_SCALAR_STK:
+ case INST_INCR_STK:
+ case INST_LOR:
+ case INST_LAND:
+ case INST_EQ:
+ case INST_NEQ:
+ case INST_LT:
+ case INST_LE:
+ case INST_GT:
+ case INST_GE:
+ case INST_MOD:
+ case INST_LSHIFT:
+ case INST_RSHIFT:
+ case INST_BITOR:
+ case INST_BITXOR:
+ case INST_BITAND:
+ case INST_EXPON:
+ case INST_ADD:
+ case INST_SUB:
+ case INST_DIV:
+ case INST_MULT:
+ case INST_LNOT:
+ case INST_BITNOT:
+ case INST_UMINUS:
+ case INST_UPLUS:
+ case INST_TRY_CVT_TO_NUMERIC:
+ blank = size;
+ break;
+ }
+ break;
+ }
+
+ if (blank > 0) {
+ for (i=0 ; i<blank ; i++) {
+ *(currentInstPtr + i) = INST_NOP;
+ }
+ size = blank;
+ }
+ }
+ Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AdvanceJumps --
+ *
+ * Advance jumps past NOPs and chained JUMPs. After this runs, the only
+ * JUMPs that jump to a NOP or a JUMP will be length-1 ones that run out
+ * of room in their opcode to be targeted to where they really belong.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AdvanceJumps(
+ CompileEnv *envPtr)
+{
+ unsigned char *currentInstPtr;
+
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext-1 ;
+ currentInstPtr += AddrLength(currentInstPtr)) {
+ int offset, delta;
+
+ switch (*currentInstPtr) {
+ case INST_JUMP1:
+ case INST_JUMP_TRUE1:
+ case INST_JUMP_FALSE1:
+ offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ for (delta=0 ; offset+delta != 0 ;) {
+ if (offset + delta < -128 || offset + delta > 127) {
+ break;
+ }
+ offset += delta;
+ switch (*(currentInstPtr + offset)) {
+ case INST_NOP:
+ delta = InstLength(INST_NOP);
+ continue;
+ case INST_JUMP1:
+ delta = TclGetInt1AtPtr(currentInstPtr + offset + 1);
+ continue;
+ case INST_JUMP4:
+ delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
+ continue;
+ }
+ break;
+ }
+ TclStoreInt1AtPtr(offset, currentInstPtr + 1);
+ continue;
+
+ case INST_JUMP4:
+ case INST_JUMP_TRUE4:
+ case INST_JUMP_FALSE4:
+ for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
+ switch (*(currentInstPtr + offset)) {
+ case INST_NOP:
+ offset += InstLength(INST_NOP);
+ continue;
+ case INST_JUMP1:
+ offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
+ continue;
+ case INST_JUMP4:
+ offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
+ continue;
+ }
+ break;
+ }
+ TclStoreInt4AtPtr(offset, currentInstPtr + 1);
+ continue;
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOptimizeBytecode --
+ *
+ * A very simple peephole optimizer for bytecode.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOptimizeBytecode(
+ CompileEnv *envPtr)
+{
+ ConvertZeroEffectToNOP(envPtr);
+ AdvanceJumps(envPtr);
+ TrimUnreachable(envPtr);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index b87a8df..2a453b9 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -52,6 +52,10 @@ Tcl_SetPanicProc(
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
if ((proc != tclWinDebugPanic) || (panicProc == NULL))
+#elif defined(__CYGWIN__)
+ if (proc == NULL)
+ panicProc = tclWinDebugPanic;
+ else
#endif
panicProc = proc;
}
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 08615a7..c5cb1d1 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -13,6 +13,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <assert.h>
#include "tclInt.h"
#include "tclParse.h"
@@ -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 13f6f8a..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);
@@ -837,7 +837,7 @@ TclObjGetFrame(
}
/* TODO: Consider skipping the typePtr checks */
} else if (objPtr->typePtr == &tclIntType
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
|| objPtr->typePtr == &tclWideIntType
#endif
) {
@@ -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/tclResult.c b/generic/tclResult.c
index 014ea1b..2f2563a 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1112,6 +1112,7 @@ Tcl_SetObjErrorCode(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetErrorLine
int
Tcl_GetErrorLine(
Tcl_Interp *interp)
@@ -1129,6 +1130,7 @@ Tcl_GetErrorLine(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetErrorLine
void
Tcl_SetErrorLine(
Tcl_Interp *interp,
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 2d534a68..883e2ea 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1239,7 +1239,7 @@ TclParseNumber(
if (!octalSignificandOverflow) {
if (octalSignificandWide >
(Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (octalSignificandWide <= (MOST_BITS + signum)) {
objPtr->typePtr = &tclWideIntType;
if (signum) {
@@ -1286,7 +1286,7 @@ TclParseNumber(
if (!significandOverflow) {
if (significandWide >
(Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (significandWide <= MOST_BITS+signum) {
objPtr->typePtr = &tclWideIntType;
if (signum) {
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8bf4f9d..782bbdf 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -43,6 +43,7 @@
#undef TclSockMinimumBuffers
#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
+#undef TclpInetNtoa
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
@@ -197,6 +198,91 @@ Tcl_WinTCharToUtf(
string, len, dsPtr);
}
+#if defined(TCL_WIDE_INT_IS_LONG)
+/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
+ * we have to make sure that all stub entries on Cygwin64 follow the Win64
+ * signature. Tcl 9 must find a better solution, but that cannot be done
+ * without introducing a binary incompatibility.
+ */
+#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj)
+static Tcl_Obj *dbNewLongObj(
+ int intValue,
+ const char *file,
+ int line
+) {
+#ifdef TCL_MEM_DEBUG
+ register Tcl_Obj *objPtr;
+
+ TclDbNewObj(objPtr, file, line);
+ objPtr->bytes = NULL;
+
+ objPtr->internalRep.longValue = (long) intValue;
+ objPtr->typePtr = &tclIntType;
+ return objPtr;
+#else
+ return Tcl_NewIntObj(intValue);
+#endif
+}
+#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj
+#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj
+#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj
+static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
+ long longValue;
+ int result = Tcl_ExprLong(interp, expr, &longValue);
+ if (result == TCL_OK) {
+ if ((longValue >= -(long)(UINT_MAX))
+ && (longValue <= (long)(UINT_MAX))) {
+ *ptr = (int)longValue;
+ } else {
+ Tcl_SetResult(interp,
+ "integer value too large to represent as non-long integer",
+ TCL_STATIC);
+ result = TCL_ERROR;
+ }
+ }
+ return result;
+}
+#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt
+static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
+ long longValue;
+ int result = Tcl_ExprLongObj(interp, expr, &longValue);
+ if (result == TCL_OK) {
+ if ((longValue >= -(long)(UINT_MAX))
+ && (longValue <= (long)(UINT_MAX))) {
+ *ptr = (int)longValue;
+ } else {
+ Tcl_SetResult(interp,
+ "integer value too large to represent as non-long integer",
+ TCL_STATIC);
+ result = TCL_ERROR;
+ }
+ }
+ return result;
+}
+#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
+static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
+ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
+}
+#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp
+static int utfNcmp(const char *s1, const char *s2, unsigned int n){
+ return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
+}
+#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))utfNcmp
+static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
+ return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
+}
+#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp
+static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
+ return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
+}
+#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp
+static int formatInt(char *buffer, int n){
+ return TclFormatInt(buffer, (long)n);
+}
+#define TclFormatInt (int(*)(char *, long))formatInt
+
+#endif
+
#else /* UNIX and MAC */
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 835036b..96973d7 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.
*
*----------------------------------------------------------------------
*/
@@ -1856,7 +1856,7 @@ TestdstringCmd(
if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_DStringTrunc(&dstring, count);
+ Tcl_DStringSetLength(&dstring, count);
} else if (strcmp(argv[1], "start") == 0) {
if (argc != 2) {
goto wrongNumArgs;
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 8708f9a..02ee038 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -337,7 +337,7 @@ ThreadObjCmd(
*/
if (objc == 2) {
- idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread());
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
} else if (objc == 3
&& strcmp("-main", Tcl_GetString(objv[2])) == 0) {
Tcl_MutexLock(&threadMutex);
@@ -355,14 +355,14 @@ ThreadObjCmd(
return TCL_ERROR;
}
case THREAD_JOIN: {
- long id;
+ Tcl_WideInt id;
int result, status;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id");
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
@@ -372,7 +372,7 @@ ThreadObjCmd(
} else {
char buf[20];
- TclFormatInt(buf, id);
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
@@ -384,7 +384,7 @@ ThreadObjCmd(
}
return ThreadList(interp);
case THREAD_SEND: {
- long id;
+ Tcl_WideInt id;
const char *script;
int wait, arg;
@@ -403,7 +403,7 @@ ThreadObjCmd(
wait = 1;
arg = 2;
}
- if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
@@ -523,7 +523,7 @@ ThreadCreate(
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id));
return TCL_OK;
}
@@ -655,7 +655,7 @@ ThreadErrorProc(
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- TclFormatInt(buf, (size_t) Tcl_GetCurrentThread());
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
@@ -773,7 +773,7 @@ ThreadList(
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewLongObj((long)(size_t)tsdPtr->threadId));
+ Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 6b17825..c10986a 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -819,7 +819,7 @@ Tcl_AfterObjCmd(
*/
if (objv[1]->typePtr == &tclIntType
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
|| objv[1]->typePtr == &tclWideIntType
#endif
|| objv[1]->typePtr == &tclBignumType
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 18a82f7..15529c7 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -1106,6 +1106,46 @@ Tcl_UtfNcasecmp(
/*
*----------------------------------------------------------------------
*
+ * Tcl_UtfNcasecmp --
+ *
+ * Compare UTF chars of string cs to string ct case insensitively.
+ * Replacement for strcasecmp in Tcl core, in places where UTF-8 should
+ * be handled.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUtfCasecmp(
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct) /* UTF string cs is compared to. */
+{
+ while (*cs && *ct) {
+ Tcl_UniChar ch1, ch2;
+
+ cs += TclUtfToUniChar(cs, &ch1);
+ ct += TclUtfToUniChar(ct, &ch2);
+ if (ch1 != ch2) {
+ ch1 = Tcl_UniCharToLower(ch1);
+ ch2 = Tcl_UniCharToLower(ch2);
+ if (ch1 != ch2) {
+ return ch1 - ch2;
+ }
+ }
+ }
+ return UCHAR(*cs) - UCHAR(*ct);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UniCharToUpper --
*
* Compute the uppercase equivalent of the given Unicode character.
@@ -1515,10 +1555,10 @@ Tcl_UniCharIsSpace(
*/
if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) {
- return isspace(UCHAR(ch)); /* INTL: ISO space */
+ 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);