summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclExecute.c350
1 files changed, 180 insertions, 170 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f12fb4d..a7212ef 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.475 2010/03/26 09:43:51 nijtmans Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.476 2010/04/19 15:43:36 dkf Exp $
*/
#include "tclInt.h"
@@ -2667,54 +2667,65 @@ TclExecuteByteCode(
int objc, pcAdjustment;
Tcl_Obj **objv;
- instEvalStk:
- case INST_EVAL_STK: {
- /*
- * Moved here to support transforming the eval of objects to a
- * simple command invocation (for canonical lists) or a
- * non-recursive TEBC call (compiled scripts).
- */
+ instEvalStk:
+ case INST_EVAL_STK:
+ /*
+ * Moved here to support transforming the eval of objects to a simple
+ * command invocation (for canonical lists) or a non-recursive TEBC
+ * call (compiled scripts).
+ */
- ByteCode *newCodePtr;
+ objPtr = OBJ_AT_TOS;
+ cleanup = 1;
+ pcAdjustment = 1;
- objPtr = OBJ_AT_TOS;
- cleanup = 1;
- pcAdjustment = 1;
+ if (objPtr->typePtr == &tclListType) {
+ List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *copyPtr;
- if (objPtr->typePtr == &tclListType) { /* is a list... */
- List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
- Tcl_Obj *copyPtr;
+ /*
+ * Test if the list is "pure" or "canonical", since in that case
+ * we can know for sure that there are no syntactic nasties and
+ * treat the list's elements as literal words without need for
+ * further substitution. "Pure" lists are those that have no
+ * string representation at all; they're known OK because we know
+ * the algorithm for generating the string representation never
+ * produces hazards. "Canonical" lists are where we know that the
+ * string representation was produced from the internal
+ * representation of the list.
+ */
- if (objPtr->bytes == NULL || /* ...without a string rep */
- listRepPtr->canonicalFlag) {/* ...or that is canonical
- * */
- if (Tcl_IsShared(objPtr)) {
- copyPtr = TclListObjCopy(interp, objPtr);
- Tcl_IncrRefCount(copyPtr);
- OBJ_AT_TOS = copyPtr;
- listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
- Tcl_DecrRefCount(objPtr);
- }
- objc = listRepPtr->elemCount;
- objv = &listRepPtr->elements;
+ if (objPtr->bytes == NULL || listRepPtr->canonicalFlag) {
+ if (Tcl_IsShared(objPtr)) {
+ copyPtr = TclListObjCopy(interp, objPtr);
+ Tcl_IncrRefCount(copyPtr);
+ OBJ_AT_TOS = copyPtr;
+ listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_DecrRefCount(objPtr);
+ }
+ objc = listRepPtr->elemCount;
+ objv = &listRepPtr->elements;
- /*
- * Fix for [Bug 2102930]
- */
+ /*
+ * Fix for [Bug 2102930]
+ */
- iPtr->numLevels++;
- Tcl_NRAddCallback(interp, NRCommand, NULL,NULL,NULL,NULL);
- goto doInvocationFromEval;
- }
+ iPtr->numLevels++;
+ Tcl_NRAddCallback(interp, NRCommand, NULL,NULL,NULL,NULL);
+ goto doInvocationFromEval;
}
+ }
- /*
- * Run the bytecode in this same TEBC instance!
- *
- * TIP #280: The invoking context is left NULL for a dynamically
- * constructed command. We cannot match its lines to the outer
- * context.
- */
+ /*
+ * Run the bytecode in this same TEBC instance!
+ *
+ * TIP #280: The invoking context is left NULL for a dynamically
+ * constructed command. We cannot match its lines to the outer
+ * context.
+ */
+
+ {
+ ByteCode *newCodePtr;
DECACHE_STACK_INFO();
newCodePtr = TclCompileObj(interp, objPtr, NULL, 0);
@@ -2727,13 +2738,10 @@ TclExecuteByteCode(
}
case INST_INVOKE_EXPANDED:
- {
- CLANG_ASSERT(auxObjList);
- objc = CURR_DEPTH
- - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1;
- POP_TAUX_OBJ();
- }
-
+ CLANG_ASSERT(auxObjList);
+ objc = CURR_DEPTH
+ - (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1;
+ POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
goto doInvocation;
@@ -2808,101 +2816,102 @@ TclExecuteByteCode(
CACHE_STACK_INFO();
if (TOP_CB(interp) != BP->rootPtr) {
+ TEOV_callback *callbackPtr;
+ int type;
+ ClientData param;
+
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];
+ callbackPtr = TOP_CB(interp);
+ type = PTR2INT(callbackPtr->data[0]);
+ 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;
+ }
+ 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;
- }
+ 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;
- }
+ 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
- */
+ /*
+ * Mark suspended, save our state and return
+ */
- corPtr->stackLevel = NULL;
- iPtr->execEnvPtr = corPtr->callerEEPtr;
- OBP = *corPtr->callerBPPtr;
- goto returnToCaller;
- }
- default:
- Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
- }
+ corPtr->stackLevel = NULL;
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ OBP = *corPtr->callerBPPtr;
+ goto returnToCaller;
+ }
+ default:
+ Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!");
}
}
@@ -2922,18 +2931,19 @@ TclExecuteByteCode(
*/
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;
+ if (catchTop == initCatchTop) {
+ goto abnormalReturn;
}
- goto abnormalReturn;
+
+ 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;
}
if (iPtr->execEnvPtr->rewind) {
@@ -2941,41 +2951,41 @@ TclExecuteByteCode(
goto abnormalReturn;
}
- if (TRESULT == TCL_OK) {
+ if (TRESULT != TCL_OK) {
+ pc--;
+ goto processExceptionReturn;
+ }
+
#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);
#if TCL_SUPPORT_84_BYTECODE
case INST_CALL_BUILTIN_FUNC1: {
generated by cgit v0.12 at 2024-11-23 03:47:45 (GMT)