summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog60
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclCompCmds.c128
-rw-r--r--generic/tclCompile.c19
-rw-r--r--generic/tclCompile.h10
-rw-r--r--generic/tclExecute.c820
-rw-r--r--generic/tclInt.h12
-rw-r--r--generic/tclVar.c72
8 files changed, 724 insertions, 401 deletions
diff --git a/ChangeLog b/ChangeLog
index c4656c5..0f7713d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,30 +1,40 @@
+2010-01-30 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompile.c (tclInstructionTable): Bytecode instructions
+ * generic/tclCompCmds.c (TclCompileUnsetCmd): to allow the [unset]
+ * generic/tclExecute.c (TclExecuteByteCode): command to be compiled
+ with the compiler being a complete compilation for all compile-time
+ decidable uses.
+
+ * generic/tclVar.c (TclPtrUnsetVar): Var reference version of the code
+ to unset a variable. Required for INST_UNSET bytecodes.
+
2010-01-29 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tcl.h Reverted Tcl_ThreadDataKey type change,
- see Bug #2942081
- Changed some Tcl_CallFrame fields from "char *"
- to "void *". This saves unnecessary space on
- Cray's (and it's simply more correct).
-
- * tools/genStubs.tcl: No longer generate a space after "*" and
- immediately after a function name, so the
- format of function definitions in tcl*Decls.h
- match all other tcl*.h header files.
- * doc/ParseArgs.3: Change Tcl_ArgvFuncProc, Tcl_ArgvGenFuncProc
- * generic/tcl.h and GetFrameInfoValueProc to be function
- * generic/tclInt.h definitions, not pointers, for consistency
- * generic/tclOOInt.h with all other Tcl function definitions.
- * generic/tclIndexObj.c
- * generic/regguts.h: CONST -> const
- * generic/tcl.decls Formatting
- * generic/tclTomMath.decls Formatting
- * generic/tclDecls.h (regenerated)
- * generic/tclIntDecls.h
- * generic/tclIntPlatDecls.h
- * generic/tclOODecls.h
- * generic/tclOOIntDecls.h
- * generic/tclPlatDecls.h
- * generic/tclTomMathDecls.h
+ * generic/tcl.h: [Bug 2942081]: Reverted Tcl_ThreadDataKey type change
+ Changed some Tcl_CallFrame fields from "char *"
+ to "void *". This saves unnecessary space on
+ Cray's (and it's simply more correct).
+
+ * tools/genStubs.tcl: No longer generate a space after "*" and
+ immediately after a function name, so the
+ format of function definitions in tcl*Decls.h
+ match all other tcl*.h header files.
+ * doc/ParseArgs.3: Change Tcl_ArgvFuncProc, Tcl_ArgvGenFuncProc
+ * generic/tcl.h: and GetFrameInfoValueProc to be function
+ * generic/tclInt.h: definitions, not pointers, for consistency
+ * generic/tclOOInt.h: with all other Tcl function definitions.
+ * generic/tclIndexObj.c:
+ * generic/regguts.h: CONST -> const
+ * generic/tcl.decls: Formatting
+ * generic/tclTomMath.decls: Formatting
+ * generic/tclDecls.h: (regenerated)
+ * generic/tclIntDecls.h:
+ * generic/tclIntPlatDecls.h:
+ * generic/tclOODecls.h:
+ * generic/tclOOIntDecls.h:
+ * generic/tclPlatDecls.h:
+ * generic/tclTomMathDecls.h:
2010-01-28 Donal K. Fellows <dkf@users.sf.net>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 254760d..2612aef 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.438 2010/01/03 20:29:11 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.439 2010/01/30 16:33:25 dkf Exp $
*/
#include "tclInt.h"
@@ -242,7 +242,7 @@ static const CmdInfo builtInCmds[] = {
{"throw", Tcl_ThrowObjCmd, NULL, NULL, 1},
{"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
{"try", Tcl_TryObjCmd, NULL, TclNRTryObjCmd, 1},
- {"unset", Tcl_UnsetObjCmd, NULL, NULL, 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},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 6ec2265..5455e5d 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.157 2009/09/11 20:13:27 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.158 2010/01/30 16:33:25 dkf Exp $
*/
#include "tclInt.h"
@@ -27,14 +27,14 @@
*/
#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_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]; \
+ (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)); \
+ (envPtr)); \
}
/*
@@ -124,13 +124,13 @@
#define DeclareExceptionRange(envPtr, type) \
(TclCreateExceptRange((type), (envPtr)))
#define ExceptionRangeStarts(envPtr, index) \
- (((envPtr)->exceptDepth++), \
- ((envPtr)->maxExceptDepth = \
- TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
+ (((envPtr)->exceptDepth++), \
+ ((envPtr)->maxExceptDepth = \
+ TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \
((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr)))
#define ExceptionRangeEnds(envPtr, index) \
- (((envPtr)->exceptDepth--), \
- ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
+ (((envPtr)->exceptDepth--), \
+ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \
CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset))
#define ExceptionRangeTarget(envPtr, index, targetType) \
((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr))
@@ -184,9 +184,9 @@ static void CompileReturnInternal(CompileEnv *envPtr,
Tcl_Obj *returnOpts);
#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)])
+ PushVarName(i,v,e,f,l,s,sc, \
+ mapPtr->loc[eclIndex].line[(word)], \
+ mapPtr->loc[eclIndex].next[(word)])
/*
* Flags bits used by PushVarName.
@@ -5019,6 +5019,104 @@ PrintJumptableInfo(
/*
*----------------------------------------------------------------------
*
+ * TclCompileUnsetCmd --
+ *
+ * Procedure called to compile the "unset" 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 "unset" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileUnsetCmd(
+ 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 isScalar, simpleVarName, localIndex, numWords, flags, i;
+ Tcl_Obj *leadingWord;
+ DefineLineInformation; /* TIP #280 */
+
+ numWords = parsePtr->numWords-1;
+ flags = 1;
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ leadingWord = Tcl_NewObj();
+ if (TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
+ int len;
+ const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
+
+ if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
+ flags = 0;
+ varTokenPtr = TokenAfter(varTokenPtr);
+ numWords--;
+ } else if (len == 2 && !strncmp("--", bytes, 2)) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ numWords--;
+ }
+ } else {
+ /*
+ * Cannot guarantee that the first word is not '-nocomplain' at
+ * evaluation with reasonable effort, so spill to interpreted version.
+ */
+
+ return TCL_ERROR;
+ }
+ TclDecrRefCount(leadingWord);
+
+ for (i=0 ; i<numWords ; i++) {
+ /*
+ * 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.
+ */
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &simpleVarName, &isScalar, 1);
+
+ /*
+ * Emit instructions to unset the variable.
+ */
+
+ if (!simpleVarName) {
+ TclEmitInstInt1( INST_UNSET_STK, flags, envPtr);
+ } else if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitInstInt1(INST_UNSET_STK, flags, envPtr);
+ } else {
+ TclEmitInstInt1(INST_UNSET_SCALAR, flags, envPtr);
+ TclEmitInt4( localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitInstInt1(INST_UNSET_ARRAY_STK, flags, envPtr);
+ } else {
+ TclEmitInstInt1(INST_UNSET_ARRAY, flags, envPtr);
+ TclEmitInt4( localIndex, envPtr);
+ }
+ }
+
+ varTokenPtr = TokenAfter(varTokenPtr);
+ }
+ PushLiteral(envPtr, "", 0);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileWhileCmd --
*
* Procedure called to compile the "while" command.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 57e3a9d..726aefb 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.179 2009/11/18 21:59:50 nijtmans Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.180 2010/01/30 16:33:25 dkf Exp $
*/
#include "tclInt.h"
@@ -399,6 +399,7 @@ InstructionDesc const tclInstructionTable[] = {
* stknext */
{"existStk", 1, 0, 0, {OPERAND_NONE}},
/* Test if general variable exists; unparsed variable name is stktop*/
+
{"nop", 1, 0, 0, {OPERAND_NONE}},
/* Do nothing */
{"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}},
@@ -406,9 +407,23 @@ InstructionDesc const tclInstructionTable[] = {
* ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7;
* Other non-OK: +9
*/
+
+ {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}},
+ /* Make scalar variable at index op2 in call frame cease to exist;
+ * op1 is 1 for errors on problems, 0 otherwise */
+ {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}},
+ /* Make array element cease to exist; array at slot op2, element is
+ * stktop; op1 is 1 for errors on problems, 0 otherwise */
+ {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}},
+ /* Make array element cease to exist; element is stktop, array name is
+ * stknext; op1 is 1 for errors on problems, 0 otherwise */
+ {"unsetStk", 2, -1, 1, {OPERAND_UINT1}},
+ /* Make general variable cease to exist; unparsed variable name is
+ * stktop; op1 is 1 for errors on problems, 0 otherwise */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
-
+
/*
* Prototypes for procedures defined later in this file:
*/
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3c514d0..18dad76 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.121 2010/01/21 17:23:49 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.122 2010/01/30 16:33:25 dkf Exp $
*/
#ifndef _TCLCOMPILATION
@@ -672,8 +672,14 @@ typedef struct ByteCode {
#define INST_NOP 132
#define INST_RETURN_CODE_BRANCH 133
+/* For [unset] compilation */
+#define INST_UNSET_SCALAR 134
+#define INST_UNSET_ARRAY 135
+#define INST_UNSET_ARRAY_STK 136
+#define INST_UNSET_STK 137
+
/* The last opcode */
-#define LAST_INST_OPCODE 133
+#define LAST_INST_OPCODE 137
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 812e68b..cbf59c9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.470 2010/01/22 10:22:51 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.471 2010/01/30 16:33:25 dkf Exp $
*/
#include "tclInt.h"
@@ -1879,6 +1879,7 @@ TclExecuteByteCode(
#define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
#define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
+#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET)
/*
* Bottom of allocated stack holds the NR data
@@ -2041,6 +2042,7 @@ TclExecuteByteCode(
if (iPtr->execEnvPtr->corPtr) {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
if (!corPtr->base.cmdFramePtr) {
/*
* First coroutine run, incomplete init:
@@ -2167,10 +2169,6 @@ TclExecuteByteCode(
*/
if ((TAUX.instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
- /*
- * Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
- */
int localResult;
if (TclAsyncReady(iPtr)) {
@@ -2383,19 +2381,17 @@ TclExecuteByteCode(
NEXT_INST_F(1, 0, 1);
case INST_OVER: {
- int opnd;
+ int opnd = TclGetUInt4AtPtr(pc+1);
- opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = OBJ_AT_DEPTH(opnd);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(5, 0, 1);
}
case INST_REVERSE: {
- int opnd;
Tcl_Obj **a, **b;
+ int opnd = TclGetUInt4AtPtr(pc+1);
- opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
@@ -2659,11 +2655,11 @@ TclExecuteByteCode(
goto nonRecursiveCallStart;
}
- {
/*
* INVOCATION BLOCK
*/
+ {
int objc, pcAdjustment;
Tcl_Obj **objv;
@@ -2703,7 +2699,7 @@ TclExecuteByteCode(
*/
iPtr->numLevels++;
- Tcl_NRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ Tcl_NRAddCallback(interp, NRCommand, NULL,NULL,NULL,NULL);
goto doInvocationFromEval;
}
}
@@ -2737,15 +2733,15 @@ TclExecuteByteCode(
if (objc) {
pcAdjustment = 1;
goto doInvocation;
- } else {
- /*
- * Nothing was expanded, return {}.
- */
-
- TclNewObj(objResultPtr);
- NEXT_INST_F(1, 0, 1);
}
+ /*
+ * Nothing was expanded, return {}.
+ */
+
+ TclNewObj(objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_INVOKE_STK4:
objc = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
@@ -2756,230 +2752,226 @@ TclExecuteByteCode(
pcAdjustment = 2;
doInvocation:
- {
- objv = &OBJ_AT_DEPTH(objc-1);
- cleanup = objc;
+ objv = &OBJ_AT_DEPTH(objc-1);
+ cleanup = objc;
doInvocationFromEval:
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
- int i;
+ if (tclTraceExec >= 2) {
+ int i;
- if (traceInstructions) {
- strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
- TRACE(("%u => call ", objc));
- } else {
- fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
- (unsigned)(pc - codePtr->codeStart));
- }
- for (i = 0; i < objc; i++) {
- TclPrintObject(stdout, objv[i], 15);
- fprintf(stdout, " ");
- }
- fprintf(stdout, "\n");
- fflush(stdout);
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ TRACE(("%u => call ", objc));
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
}
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
#endif /*TCL_COMPILE_DEBUG*/
- /*
- * Finally, let TclEvalObjv handle the command.
- *
- * TIP #280: Record the last piece of info needed by
- * 'TclGetSrcInfoForPc', and push the frame.
- */
+ /*
+ * Finally, let TclEvalObjv handle the command.
+ *
+ * TIP #280: Record the last piece of info needed by
+ * 'TclGetSrcInfoForPc', and push the frame.
+ */
- bcFramePtr->data.tebc.pc = (char *) pc;
- iPtr->cmdFramePtr = bcFramePtr;
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
- /*
- * Reset the instructionCount variable, since we're about to check
- * for async stuff anyway while processing TclEvalObjv
- */
+ /*
+ * Reset the instructionCount variable, since we're about to check for
+ * async stuff anyway while processing TclEvalObjv
+ */
- TAUX.instructionCount = 1;
+ TAUX.instructionCount = 1;
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
- DECACHE_STACK_INFO();
+ DECACHE_STACK_INFO();
- TRESULT = TclNREvalObjv(interp, objc, objv,
- (*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL);
- TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
- CACHE_STACK_INFO();
+ TRESULT = TclNREvalObjv(interp, objc, objv,
+ (*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL);
+ TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1);
+ CACHE_STACK_INFO();
- if (TOP_CB(interp) != BP->rootPtr) {
- NRE_ASSERT(TRESULT == TCL_OK);
- pc += pcAdjustment;
+ if (TOP_CB(interp) != BP->rootPtr) {
+ NRE_ASSERT(TRESULT == TCL_OK);
+ pc += pcAdjustment;
- nonRecursiveCallSetup: {
- TEOV_callback *callbackPtr = TOP_CB(interp);
- int type = PTR2INT(callbackPtr->data[0]);
- ClientData param = callbackPtr->data[1];
+ nonRecursiveCallSetup:
+ {
+ TEOV_callback *callbackPtr = TOP_CB(interp);
+ int type = PTR2INT(callbackPtr->data[0]);
+ ClientData param = callbackPtr->data[1];
- pcAdjustment = 0; /* silence warning */
+ pcAdjustment = 0; /* silence warning */
- NRE_ASSERT(callbackPtr != BP->rootPtr);
- NRE_ASSERT(callbackPtr->procPtr == NRCallTEBC);
+ NRE_ASSERT(callbackPtr != BP->rootPtr);
+ NRE_ASSERT(callbackPtr->procPtr == NRCallTEBC);
- TOP_CB(interp) = callbackPtr->nextPtr;
- TCLNR_FREE(interp, callbackPtr);
+ TOP_CB(interp) = callbackPtr->nextPtr;
+ TCLNR_FREE(interp, callbackPtr);
- NR_DATA_BURY();
- switch (type) {
- case TCL_NR_BC_TYPE:
- if (param) {
- codePtr = param;
- goto nonRecursiveCallStart;
- } else {
- OBP = BP;
- goto resumeCoroutine;
- }
- break;
- case TCL_NR_TAILCALL_TYPE:
- /*
- * A request to perform a tailcall: just drop this
- * bytecode. */
+ NR_DATA_BURY();
+ switch (type) {
+ case TCL_NR_BC_TYPE:
+ if (param) {
+ codePtr = param;
+ goto nonRecursiveCallStart;
+ } else {
+ OBP = BP;
+ goto resumeCoroutine;
+ }
+ break;
+ case TCL_NR_TAILCALL_TYPE:
+ /*
+ * A request to perform a tailcall: just drop this
+ * bytecode.
+ */
#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, " Tailcall request received\n");
- }
+ if (traceInstructions) {
+ fprintf(stdout, " Tailcall request received\n");
+ }
#endif /* TCL_COMPILE_DEBUG */
- iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
-
- if (catchTop != initCatchTop) {
- TclClearTailcall(interp, param);
- iPtr->varFramePtr->tailcallPtr = NULL;
- TRESULT = TCL_ERROR;
- Tcl_SetResult(interp,
- "tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL",
- "ILLEGAL", NULL);
- pc--;
- goto checkForCatch;
- }
- iPtr->varFramePtr->tailcallPtr = param;
- TclSpliceTailcall(interp, param);
- goto abnormalReturn;
- case TCL_NR_YIELD_TYPE: { /* [yield] */
- CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
-
- if (!corPtr) {
- Tcl_SetResult(interp,
- "yield can only be called in a coroutine",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
- "ILLEGAL_YIELD", NULL);
- TRESULT = TCL_ERROR;
- pc--;
- goto checkForCatch;
- }
-
- NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
- NRE_ASSERT(corPtr->stackLevel != NULL);
- NRE_ASSERT(BP == corPtr->eePtr->bottomPtr);
- if (corPtr->stackLevel != &TAUX) {
- Tcl_SetResult(interp, "cannot yield: C stack busy",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
- "CANT_YIELD", NULL);
- TRESULT = TCL_ERROR;
- pc--;
- goto checkForCatch;
- }
-
- /*
- * Mark suspended, save our state and return
- */
-
- corPtr->stackLevel = NULL;
- iPtr->execEnvPtr = corPtr->callerEEPtr;
- OBP = *corPtr->callerBPPtr;
- goto returnToCaller;
+ iPtr->cmdFramePtr = bcFramePtr->nextPtr;
+ TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+
+ if (catchTop != initCatchTop) {
+ TclClearTailcall(interp, param);
+ iPtr->varFramePtr->tailcallPtr = NULL;
+ TRESULT = TCL_ERROR;
+ Tcl_SetResult(interp,
+ "tailcall called from within a catch environment",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
+ NULL);
+ pc--;
+ goto checkForCatch;
}
- default:
- Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
+ iPtr->varFramePtr->tailcallPtr = param;
+ TclSpliceTailcall(interp, param);
+ goto abnormalReturn;
+ case TCL_NR_YIELD_TYPE: { /* [yield] */
+ CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+ if (!corPtr) {
+ Tcl_SetResult(interp,
+ "yield can only be called in a coroutine",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
+ "ILLEGAL_YIELD", NULL);
+ TRESULT = TCL_ERROR;
+ pc--;
+ goto checkForCatch;
}
- }
- }
- pc += pcAdjustment;
+ NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr);
+ NRE_ASSERT(corPtr->stackLevel != NULL);
+ NRE_ASSERT(BP == corPtr->eePtr->bottomPtr);
+ if (corPtr->stackLevel != &TAUX) {
+ Tcl_SetResult(interp, "cannot yield: C stack busy",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE",
+ "CANT_YIELD", NULL);
+ TRESULT = TCL_ERROR;
+ pc--;
+ goto checkForCatch;
+ }
- nonRecursiveCallReturn:
+ /*
+ * Mark suspended, save our state and return
+ */
- if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
- iPtr->flags |= ERR_ALREADY_LOGGED;
- codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
+ corPtr->stackLevel = NULL;
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ OBP = *corPtr->callerBPPtr;
+ goto returnToCaller;
+ }
+ default:
+ Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
+ }
}
- NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
- iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+ }
- /*
- * If the CallFrame is marked as tailcalling, keep tailcalling
- */
+ pc += pcAdjustment;
- if (iPtr->varFramePtr->tailcallPtr) {
- if (catchTop != initCatchTop) {
- TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
- iPtr->varFramePtr->tailcallPtr = NULL;
- TRESULT = TCL_ERROR;
- Tcl_SetResult(interp,
- "tailcall called from within a catch environment",
- TCL_STATIC);
- Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL",
- NULL);
- pc--;
- goto checkForCatch;
- }
- goto abnormalReturn;
- }
+ nonRecursiveCallReturn:
+ if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
+ }
+ NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
+ iPtr->cmdFramePtr = bcFramePtr->nextPtr;
+ TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+
+ /*
+ * If the CallFrame is marked as tailcalling, keep tailcalling
+ */
- if (iPtr->execEnvPtr->rewind) {
+ if (iPtr->varFramePtr->tailcallPtr) {
+ if (catchTop != initCatchTop) {
+ TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ iPtr->varFramePtr->tailcallPtr = NULL;
TRESULT = TCL_ERROR;
- goto abnormalReturn;
+ Tcl_SetResult(interp,
+ "tailcall called from within a catch environment",
+ TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ pc--;
+ goto checkForCatch;
}
+ goto abnormalReturn;
+ }
- if (TRESULT == TCL_OK) {
- Tcl_Obj *objPtr;
+ if (iPtr->execEnvPtr->rewind) {
+ TRESULT = TCL_ERROR;
+ goto abnormalReturn;
+ }
+
+ if (TRESULT == TCL_OK) {
+ Tcl_Obj *objPtr;
#ifndef TCL_COMPILE_DEBUG
- if (*pc == INST_POP) {
- NEXT_INST_V(1, cleanup, 0);
- }
+ if (*pc == INST_POP) {
+ NEXT_INST_V(1, cleanup, 0);
+ }
#endif
- /*
- * Push the call's object result and continue execution with
- * the next instruction.
- */
+ /*
+ * Push the call's object result and continue execution with the
+ * next instruction.
+ */
- TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
- objc, cmdNameBuf), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
+ objc, cmdNameBuf), Tcl_GetObjResult(interp));
- objResultPtr = 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 avoid any side effects caused by the resetting of
- * errorInfo and errorCode [Bug 804681], which are not needed
- * here. We chose instead to manipulate the interp's object
- * result directly.
- *
- * Note that the result object is now in objResultPtr, it
- * keeps the refCount it had in its role of
- * iPtr->objResultPtr.
- */
+ /*
+ * Reset the interp's result to avoid possible duplications of
+ * large objects [Bug 781585]. We do not call Tcl_ResetResult to
+ * avoid any side effects caused by the resetting of errorInfo and
+ * errorCode [Bug 804681], which are not needed here. We chose
+ * instead to manipulate the interp's object result directly.
+ *
+ * Note that the result object is now in objResultPtr, it keeps
+ * the refCount it had in its role of iPtr->objResultPtr.
+ */
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_V(0, cleanup, -1);
- } else {
- pc--;
- goto processExceptionReturn;
- }
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+ iPtr->objResultPtr = objPtr;
+ NEXT_INST_V(0, cleanup, -1);
+ } else {
+ pc--;
+ goto processExceptionReturn;
}
#if TCL_SUPPORT_84_BYTECODE
@@ -2992,7 +2984,7 @@ TclExecuteByteCode(
*/
int opnd, numArgs;
- Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr, *tmpPtr1, *tmpPtr2;
opnd = TclGetUInt1AtPtr(pc+1);
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
@@ -3011,12 +3003,11 @@ TclExecuteByteCode(
if (numArgs == 0) {
PUSH_OBJECT(objPtr);
} else if (numArgs == 1) {
- Tcl_Obj *tmpPtr1 = POP_OBJECT();
+ tmpPtr1 = POP_OBJECT();
PUSH_OBJECT(objPtr);
PUSH_OBJECT(tmpPtr1);
Tcl_DecrRefCount(tmpPtr1);
} else {
- Tcl_Obj *tmpPtr1, *tmpPtr2;
tmpPtr2 = POP_OBJECT();
tmpPtr1 = POP_OBJECT();
PUSH_OBJECT(objPtr);
@@ -3077,7 +3068,7 @@ TclExecuteByteCode(
}
/*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
@@ -3086,9 +3077,8 @@ TclExecuteByteCode(
*/
{
int opnd, pcAdjustment;
- Tcl_Obj *part1Ptr, *part2Ptr;
+ Tcl_Obj *objPtr, *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
- Tcl_Obj *objPtr;
case INST_LOAD_SCALAR1:
instLoadScalar1:
@@ -3235,11 +3225,7 @@ TclExecuteByteCode(
/*
* End of INST_LOAD instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_STORE and related instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
@@ -3249,9 +3235,8 @@ TclExecuteByteCode(
{
int opnd, pcAdjustment, storeFlags;
- Tcl_Obj *part1Ptr, *part2Ptr;
+ Tcl_Obj *part1Ptr, *part2Ptr, *objPtr, *valuePtr;
Var *varPtr, *arrayPtr;
- Tcl_Obj *objPtr, *valuePtr;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -3500,11 +3485,7 @@ TclExecuteByteCode(
/*
* End of INST_STORE and related instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended! The different
@@ -3515,13 +3496,12 @@ TclExecuteByteCode(
/*TODO: Consider more untangling here; merge with LOAD and STORE ? */
{
- Tcl_Obj *objPtr, *incrPtr;
+ Tcl_Obj *objPtr, *incrPtr, *part1Ptr, *part2Ptr;
int opnd, pcAdjustment;
#ifndef NO_WIDE_TYPE
Tcl_WideInt w;
#endif
long i;
- Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
case INST_INCR_SCALAR1:
@@ -3646,34 +3626,32 @@ TclExecuteByteCode(
goto doneIncr;
}
#ifndef NO_WIDE_TYPE
- {
- w = (Tcl_WideInt)augend;
+ w = (Tcl_WideInt)augend;
- TRACE(("%u %ld => ", opnd, i));
- if (Tcl_IsShared(objPtr)) {
- objPtr->refCount--; /* We know it's shared. */
- objResultPtr = Tcl_NewWideIntObj(w+i);
- Tcl_IncrRefCount(objResultPtr);
- varPtr->value.objPtr = objResultPtr;
- } else {
- objResultPtr = objPtr;
+ TRACE(("%u %ld => ", opnd, i));
+ if (Tcl_IsShared(objPtr)) {
+ objPtr->refCount--; /* We know it's shared. */
+ objResultPtr = Tcl_NewWideIntObj(w+i);
+ Tcl_IncrRefCount(objResultPtr);
+ varPtr->value.objPtr = objResultPtr;
+ } else {
+ objResultPtr = objPtr;
- /*
- * We know the sum value is outside the long
- * range; use macro form that doesn't range test
- * again.
- */
+ /*
+ * We know the sum value is outside the long range;
+ * use macro form that doesn't range test again.
+ */
- TclSetWideIntObj(objPtr, w+i);
- }
- goto doneIncr;
+ TclSetWideIntObj(objPtr, w+i);
}
+ goto doneIncr;
#endif
} /* end if (type == TCL_NUMBER_LONG) */
#ifndef NO_WIDE_TYPE
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt sum;
- w = *((const Tcl_WideInt *)ptr);
+
+ w = *((const Tcl_WideInt *) ptr);
sum = w + i;
/*
@@ -3785,20 +3763,17 @@ TclExecuteByteCode(
/*
* End of INST_INCR instructions.
- * ---------------------------------------------------------
- */
-
- /*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_EXIST instructions.
*/
+
{
Tcl_Obj *part1Ptr, *part2Ptr;
Var *varPtr, *arrayPtr;
+ int opnd;
- case INST_EXIST_SCALAR: {
- int opnd = TclGetUInt4AtPtr(pc+1);
-
+ case INST_EXIST_SCALAR:
+ opnd = TclGetUInt4AtPtr(pc+1);
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -3822,11 +3797,9 @@ TclExecuteByteCode(
objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
- }
-
- case INST_EXIST_ARRAY: {
- int opnd = TclGetUInt4AtPtr(pc+1);
+ case INST_EXIST_ARRAY:
+ opnd = TclGetUInt4AtPtr(pc+1);
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
while (TclIsVarLink(arrayPtr)) {
@@ -3857,7 +3830,6 @@ TclExecuteByteCode(
objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 1, 1);
- }
case INST_EXIST_ARRAY_STK:
cleanup = 2;
@@ -3894,82 +3866,201 @@ TclExecuteByteCode(
/*
* End of INST_EXIST instructions.
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
+ * Start of INST_UNSET instructions.
*/
- case INST_UPVAR: {
- int opnd;
- Var *varPtr, *otherPtr;
+ {
+ Tcl_Obj *part1Ptr, *part2Ptr;
+ Var *varPtr, *arrayPtr;
+ int opnd, flags, localResult;
- TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+ case INST_UNSET_SCALAR:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ opnd = TclGetUInt4AtPtr(pc+2);
+ varPtr = LOCAL(opnd);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd));
+ if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
+ /*
+ * No errors, no traces, no searches: just make the variable cease
+ * to exist.
+ */
- {
- CallFrame *framePtr, *savedFramePtr;
+ if (!TclIsVarUndefined(varPtr)) {
+ Tcl_DecrRefCount(varPtr->value.objPtr);
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ goto slowUnsetScalar;
+ }
+ varPtr->value.objPtr = NULL;
+ NEXT_INST_F(6, 0, 0);
+ }
+ slowUnsetScalar:
+ DECACHE_STACK_INFO();
+ localResult = TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags,
+ opnd);
+ CACHE_STACK_INFO();
+ if (localResult != TCL_OK && flags) {
+ goto errorInUnset;
+ }
+ NEXT_INST_F(6, 0, 0);
- TRESULT = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);
- if (TRESULT != -1) {
+ case INST_UNSET_ARRAY:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ opnd = TclGetUInt4AtPtr(pc+2);
+ part2Ptr = OBJ_AT_TOS;
+ arrayPtr = LOCAL(opnd);
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%s %u \"%.30s\"\n", (flags?"normal":"noerr"), opnd, O2S(part2Ptr)));
+ if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
+ varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
+ if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
/*
- * Locate the other variable.
+ * No nasty traces and element exists, so we can proceed to
+ * unset it. Might still not exist though...
*/
- savedFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = framePtr;
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- iPtr->varFramePtr = savedFramePtr;
- if (otherPtr) {
- TRESULT = TCL_OK;
- goto doLinkVars;
+ if (!TclIsVarUndefined(varPtr)) {
+ Tcl_DecrRefCount(varPtr->value.objPtr);
+ } else if (flags & TCL_LEAVE_ERR_MSG) {
+ goto slowUnsetArray;
}
+ varPtr->value.objPtr = NULL;
+ NEXT_INST_F(6, 1, 0);
}
- TRESULT = TCL_ERROR;
- goto checkForCatch;
}
+ slowUnsetArray:
+ DECACHE_STACK_INFO();
+ varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset",
+ 0, 0, arrayPtr, opnd);
+ if (!varPtr && (flags & TCL_LEAVE_ERR_MSG)) {
+ CACHE_STACK_INFO();
+ goto errorInUnset;
+ }
+ if (varPtr) {
+ localResult = TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL,
+ part2Ptr, flags, opnd);
+ } else {
+ localResult = TCL_OK;
+ }
+ CACHE_STACK_INFO();
+ if (localResult != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) {
+ goto errorInUnset;
+ }
+ NEXT_INST_F(6, 1, 0);
- case INST_VARIABLE:
- TRACE(("variable "));
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- if (otherPtr) {
+ case INST_UNSET_ARRAY_STK:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ cleanup = 2;
+ part2Ptr = OBJ_AT_TOS; /* element name */
+ part1Ptr = OBJ_UNDER_TOS; /* array name */
+ TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"),
+ O2S(part1Ptr), O2S(part2Ptr)));
+ goto doUnsetStk;
+
+ case INST_UNSET_STK:
+ flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0;
+ cleanup = 1;
+ part2Ptr = NULL;
+ part1Ptr = OBJ_AT_TOS; /* variable name */
+ TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr)));
+
+ doUnsetStk:
+ DECACHE_STACK_INFO();
+ localResult = TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags);
+ CACHE_STACK_INFO();
+ if (localResult != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) {
+ goto errorInUnset;
+ }
+ NEXT_INST_V(2, cleanup, 0);
+
+ errorInUnset:
+ TRESULT = TCL_ERROR;
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto checkForCatch;
+ }
+
+ /*
+ * End of INST_UNSET instructions.
+ * -----------------------------------------------------------------
+ * Start of variable linking instructions.
+ */
+
+ {
+ int opnd;
+ Var *varPtr, *otherPtr;
+
+ case INST_UPVAR: {
+ CallFrame *framePtr, *savedFramePtr;
+
+ TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+
+ TRESULT = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);
+ if (TRESULT == -1) {
/*
- * Do the [variable] magic.
+ * Locate the other variable.
*/
- TclSetVarNamespaceVar(otherPtr);
- TRESULT = TCL_OK;
- goto doLinkVars;
+ savedFramePtr = iPtr->varFramePtr;
+ iPtr->varFramePtr = framePtr;
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1,
+ /*createPart2*/ 1, &varPtr);
+ iPtr->varFramePtr = savedFramePtr;
+ if (otherPtr) {
+ TRESULT = TCL_OK;
+ goto doLinkVars;
+ }
}
TRESULT = TCL_ERROR;
goto checkForCatch;
+ }
- case INST_NSUPVAR:
- TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
+ case INST_NSUPVAR: {
+ Tcl_Namespace *nsPtr, *savedNsPtr;
- {
- Tcl_Namespace *nsPtr, *savedNsPtr;
-
- TRESULT = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);
- if (TRESULT == TCL_OK) {
- /*
- * Locate the other variable.
- */
+ TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
+ TRESULT = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);
+ if (TRESULT == TCL_OK) {
+ /*
+ * Locate the other variable.
+ */
- savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
- otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
- iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
- if (otherPtr) {
- goto doLinkVars;
- }
+ savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+ iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
+ if (otherPtr) {
+ goto doLinkVars;
}
+ }
+ TRESULT = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ case INST_VARIABLE:
+ TRACE(("variable "));
+ otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ if (!otherPtr) {
TRESULT = TCL_ERROR;
goto checkForCatch;
}
+ /*
+ * Do the [variable] magic.
+ */
+
+ TclSetVarNamespaceVar(otherPtr);
+ TRESULT = TCL_OK;
+
doLinkVars:
/*
@@ -4020,6 +4111,11 @@ TclExecuteByteCode(
NEXT_INST_F(5, 1, 0);
}
+ /*
+ * End of variable linking instructions.
+ * -----------------------------------------------------------------
+ */
+
case INST_JUMP1: {
int opnd = TclGetInt1AtPtr(pc+1);
@@ -4165,7 +4261,7 @@ TclExecuteByteCode(
}
/*
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
@@ -4587,7 +4683,8 @@ TclExecuteByteCode(
/*
* End of INST_LIST and related instructions.
- * ---------------------------------------------------------
+ * -----------------------------------------------------------------
+ * Start of string-related instructions.
*/
case INST_STR_EQ:
@@ -4791,6 +4888,7 @@ TclExecuteByteCode(
/*
* Get char length to calulate what 'end' means.
*/
+
length = Tcl_GetCharLength(valuePtr);
TRESULT = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index);
if (TRESULT != TCL_OK) {
@@ -4865,12 +4963,29 @@ TclExecuteByteCode(
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
- * TODO: consider peephole opt.
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ */
+
+ pc += 2;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
objResultPtr = TCONST(match);
- NEXT_INST_F(2, 2, 1);
+ NEXT_INST_F(0, 2, 1);
}
case INST_REGEXP: {
@@ -4899,14 +5014,37 @@ TclExecuteByteCode(
O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
TRESULT = TCL_ERROR;
goto checkForCatch;
- } else {
- TRACE(("%.20s %.20s => %d\n",
- O2S(valuePtr), O2S(value2Ptr), match));
- objResultPtr = TCONST(match);
- NEXT_INST_F(2, 2, 1);
}
+
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ */
+
+ pc += 2;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
+ objResultPtr = TCONST(match);
+ NEXT_INST_F(0, 2, 1);
}
+ /*
+ * End of string-related instructions.
+ * -----------------------------------------------------------------
+ * Start of numeric operator instructions.
+ */
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
@@ -6933,6 +7071,11 @@ TclExecuteByteCode(
NEXT_INST_F(1, 0, 0);
}
+ /*
+ * End of numeric operator instructions.
+ * -----------------------------------------------------------------
+ */
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
@@ -7185,10 +7328,18 @@ TclExecuteByteCode(
NEXT_INST_F(2*code -1, 1, 0);
}
+ /*
+ * -----------------------------------------------------------------
+ * Start of dictionary-related instructions.
+ */
+
{
- int opnd, opnd2, allocateDict;
- Tcl_Obj *dictPtr, *valuePtr, *val2Ptr;
+ int opnd, opnd2, allocateDict, done, i, length, allocdict;
+ Tcl_Obj *dictPtr, *valuePtr, *val2Ptr, *statePtr, *keyPtr;
+ Tcl_Obj *emptyPtr, **keyPtrPtr;
Var *varPtr;
+ Tcl_DictSearch *searchPtr;
+ DictUpdateInfo *duiPtr;
case INST_DICT_GET:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -7390,26 +7541,24 @@ TclExecuteByteCode(
if (valuePtr == NULL) {
valuePtr = Tcl_NewListObj(1, &OBJ_AT_TOS);
- } else if (Tcl_IsShared(valuePtr)) {
+ break;
+ }
+ if (Tcl_IsShared(valuePtr)) {
valuePtr = Tcl_DuplicateObj(valuePtr);
TRESULT = Tcl_ListObjAppendElement(interp, valuePtr,
OBJ_AT_TOS);
if (TRESULT != TCL_OK) {
TclDecrRefCount(valuePtr);
- if (allocateDict) {
- TclDecrRefCount(dictPtr);
- }
- goto checkForCatch;
}
} else {
TRESULT = Tcl_ListObjAppendElement(interp, valuePtr,
OBJ_AT_TOS);
- if (TRESULT != TCL_OK) {
- if (allocateDict) {
- TclDecrRefCount(dictPtr);
- }
- goto checkForCatch;
+ }
+ if (TRESULT != TCL_OK) {
+ if (allocateDict) {
+ TclDecrRefCount(dictPtr);
}
+ goto checkForCatch;
}
break;
default:
@@ -7449,13 +7598,6 @@ TclExecuteByteCode(
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
- }
-
- {
- int opnd, done;
- Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr;
- Var *varPtr;
- Tcl_DictSearch *searchPtr;
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -7540,13 +7682,6 @@ TclExecuteByteCode(
Tcl_IncrRefCount(emptyPtr);
}
NEXT_INST_F(5, 0, 0);
- }
-
- {
- int opnd, opnd2, i, length, allocdict;
- Tcl_Obj **keyPtrPtr, *dictPtr, *valuePtr;
- DictUpdateInfo *duiPtr;
- Var *varPtr;
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
@@ -7674,6 +7809,11 @@ TclExecuteByteCode(
NEXT_INST_F(9, 1, 0);
}
+ /*
+ * End of dictionary-related instructions.
+ * -----------------------------------------------------------------
+ */
+
default:
Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c1da3d4..97a5e44 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.455 2010/01/29 16:17:20 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.456 2010/01/30 16:33:25 dkf Exp $
*/
#ifndef _TCLINT
@@ -808,6 +808,9 @@ typedef struct VarInHash {
#define TclIsVarDirectWritable(varPtr) \
!((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH))
+#define TclIsVarDirectUnsettable(varPtr) \
+ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_UNSET|VAR_DEAD_HASH))
+
#define TclIsVarDirectModifyable(varPtr) \
( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \
&& (varPtr)->value.objPtr)
@@ -3392,6 +3395,9 @@ MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3569,6 +3575,10 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp,
const int flags, int index);
MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr,
Tcl_Obj *myNamePtr, int myFlags, int index);
+MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const int flags,
+ int index);
MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
/*
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 54699ce..c2aea55 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.184 2009/11/20 00:19:46 dgp Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.185 2010/01/30 16:33:25 dkf Exp $
*/
#include "tclInt.h"
@@ -158,7 +158,7 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
Tcl_Obj *varNamePtr, Tcl_Obj *handleObj);
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, Tcl_Obj *part1Ptr,
- Tcl_Obj *part2Ptr, int flags);
+ Tcl_Obj *part2Ptr, int flags, int index);
static int SetArraySearchObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
@@ -2204,10 +2204,7 @@ TclObjUnsetVar2(
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
- Var *varPtr;
- Interp *iPtr = (Interp *) interp;
- Var *arrayPtr;
- int result;
+ Var *varPtr, *arrayPtr;
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "unset",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
@@ -2215,7 +2212,52 @@ TclObjUnsetVar2(
return TCL_ERROR;
}
- result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
+ return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags,
+ -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrUnsetVar --
+ *
+ * Delete a variable, given the pointers to the variable's (and possibly
+ * containing array's) VAR structure.
+ *
+ * Results:
+ * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
+ * the variable can't be unset. In the event of an error, if the
+ * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
+ * interp's result.
+ *
+ * Side effects:
+ * If varPtr and arrayPtr indicate a local or global variable in interp,
+ * it is deleted. If varPtr is an array reference and part2Ptr is NULL,
+ * then the whole array is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPtrUnsetVar(
+ Tcl_Interp *interp, /* Command interpreter in which varName is to
+ * be looked up. */
+ register Var *varPtr, /* The variable to be unset. */
+ Var *arrayPtr, /* NULL for scalar variables, pointer to the
+ * containing array otherwise. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ const int flags, /* OR-ed combination of any of
+ * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_LEAVE_ERR_MSG. */
+ int index) /* Index into the local variable table of the
+ * variable, or -1. Only used when part1Ptr is
+ * NULL. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
/*
* Keep the variable alive until we're done with it. We used to
@@ -2228,7 +2270,7 @@ TclObjUnsetVar2(
VarHashRefCount(varPtr)++;
}
- UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags);
+ UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index);
/*
* It's an error to unset an undefined variable.
@@ -2237,7 +2279,7 @@ TclObjUnsetVar2(
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
- ((arrayPtr == NULL) ? noSuchVar : noSuchElement), -1);
+ ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index);
Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL);
}
}
@@ -2294,7 +2336,8 @@ UnsetVarStruct(
Interp *iPtr,
Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr,
- int flags)
+ int flags,
+ int index)
{
Var dummyVar;
int traced = TclIsVarTraced(varPtr)
@@ -2364,7 +2407,7 @@ UnsetVarStruct(
TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS,
- /* leaveErrMsg */ 0, -1);
+ /* leaveErrMsg */ 0, index);
/*
* The traces that we just called may have triggered a change in
@@ -4418,7 +4461,7 @@ TclDeleteNamespaceVars(
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
- NULL, flags);
+ NULL, flags, -1);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
@@ -4506,7 +4549,8 @@ TclDeleteVars(
*/
VarHashInvalidateEntry(varPtr);
- UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags);
+ UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags,
+ -1);
}
VarHashDeleteTable(tablePtr);
}
@@ -4548,7 +4592,7 @@ TclDeleteCompiledLocalVars(
namePtrPtr = &localName(framePtr, 0);
for (i=0 ; i<numLocals ; i++, namePtrPtr++, varPtr++) {
UnsetVarStruct(varPtr, NULL, iPtr, *namePtrPtr, NULL,
- TCL_TRACE_UNSETS);
+ TCL_TRACE_UNSETS, i);
}
framePtr->numCompiledLocals = 0;
}
generated by cgit v0.12 at 2024-11-05 07:15:46 (GMT)