summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c453
1 files changed, 21 insertions, 432 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 13b15e8..a9f8276 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,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.40 2001/11/20 21:17:38 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.41 2001/11/20 22:47:58 msofer Exp $
*/
#include "tclInt.h"
@@ -32,9 +32,6 @@ static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr,
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
-static void RecordTracebackInfo _ANSI_ARGS_((
- Tcl_Interp *interp, Tcl_Obj *objPtr,
- int numSrcBytes));
extern TclStubs tclStubs;
@@ -3700,16 +3697,10 @@ Tcl_EvalObjEx(interp, objPtr, flags)
* TCL_EVAL_DIRECT. */
{
register Interp *iPtr = (Interp *) interp;
- int evalFlags; /* Interp->evalFlags value when the
- * procedure was called. */
- register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
- int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
- * at all were executed. */
int numSrcBytes;
int result;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
- Namespace *namespacePtr;
Tcl_IncrRefCount(objPtr);
@@ -3740,174 +3731,38 @@ Tcl_EvalObjEx(interp, objPtr, flags)
p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, p, numSrcBytes, flags);
}
- Tcl_DecrRefCount(objPtr);
- return result;
- }
-
- /*
- * Check that the interpreter is ready to eval the bytecode.
- */
-
- if (TclInterpReady(interp) == TCL_ERROR) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = NULL;
- }
-
- /*
- * Get the ByteCode from the object. If it exists, make sure it hasn't
- * been invalidated by, e.g., someone redefining a command with a
- * compile procedure (this might make the compiled code wrong). If
- * necessary, convert the object to be a ByteCode object and compile it.
- * Also, if the code was compiled in/for a different interpreter,
- * or for a different namespace, or for the same namespace but
- * with different name resolution rules, we recompile it.
- *
- * Precompiled objects, however, are immutable and therefore
- * they are not recompiled, even if the epoch has changed.
- *
- * To be pedantically correct, we should also check that the
- * originating procPtr is the same as the current context procPtr
- * (assuming one exists at all - none for global level). This
- * code is #def'ed out because [info body] was changed to never
- * return a bytecode type object, which should obviate us from
- * the extra checks here.
- */
-
- if (iPtr->varFramePtr != NULL) {
- namespacePtr = iPtr->varFramePtr->nsPtr;
} else {
- namespacePtr = iPtr->globalNsPtr;
- }
+ /*
+ * Let the compiler/engine subsystem do the evaluation.
+ */
- if (objPtr->typePtr == &tclByteCodeType) {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
-
- if (((Interp *) *codePtr->interpHandle != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)
-#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
- || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
- iPtr->varFramePtr->procPtr == codePtr->procPtr))
-#endif
- || (codePtr->nsPtr != namespacePtr)
- || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if ((Interp *) *codePtr->interpHandle != iPtr) {
- panic("Tcl_EvalObj: compiled script jumped interps");
- }
- codePtr->compileEpoch = iPtr->compileEpoch;
- } else {
- tclByteCodeType.freeIntRepProc(objPtr);
- }
- }
- }
- if (objPtr->typePtr != &tclByteCodeType) {
- iPtr->errorLine = 1;
- result = tclByteCodeType.setFromAnyProc(interp, objPtr);
- if (result != TCL_OK) {
- goto done;
- }
- } else {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if (((Interp *) *codePtr->interpHandle != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)) {
- (*tclByteCodeType.freeIntRepProc)(objPtr);
- iPtr->errorLine = 1;
- result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
- if (result != TCL_OK) {
- iPtr->numLevels--;
- return result;
- }
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
}
- }
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- /*
- * Extract then reset the compilation flags in the interpreter.
- * Resetting the flags must be done after any compilation.
- */
-
- evalFlags = iPtr->evalFlags;
- iPtr->evalFlags = 0;
-
- /*
- * Execute the commands. If the code was compiled from an empty string,
- * don't bother executing the code.
- */
+ result = TclCompEvalObj(interp, objPtr, /* engineCall */ 0);
- numSrcBytes = codePtr->numSrcBytes;
- iPtr->numLevels++;
- if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
/*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
+ * If we are again at the top level, process any unusual
+ * return code returned by the evaluated code.
*/
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- }
- } else {
- result = TCL_OK;
- }
-
- /*
- * If no commands at all were executed, check for asynchronous
- * handlers so that they at least get one change to execute.
- * This is needed to handle event loops written in Tcl with
- * empty bodies.
- */
-
- if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
- result = Tcl_AsyncInvoke(interp, result);
- }
-
- /*
- * Update the interpreter's evaluation level count. If we are again at
- * the top level, process any unusual return code returned by the
- * evaluated code.
- */
-
- if (iPtr->numLevels == 1) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
- }
- if ((result != TCL_OK) && (result != TCL_ERROR)
- && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
- ProcessUnexpectedResult(interp, result);
- result = TCL_ERROR;
+ if (iPtr->numLevels == 0) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
+ }
+ if ((result != TCL_OK) && (result != TCL_ERROR)
+ && ((iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
+ ProcessUnexpectedResult(interp, result);
+ result = TCL_ERROR;
+ }
}
+ iPtr->evalFlags = 0;
+ iPtr->varFramePtr = savedVarFramePtr;
}
- /*
- * If an error occurred, record information about what was being
- * executed when the error occurred.
- */
-
- if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- RecordTracebackInfo(interp, objPtr, numSrcBytes);
- }
-
- /*
- * Set the interpreter's termOffset member to the offset of the
- * character just after the last one executed. We approximate the offset
- * of the last character executed by using the number of characters
- * compiled.
- */
-
- iPtr->termOffset = numSrcBytes;
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
- iPtr->numLevels--;
-
- done:
TclDecrRefCount(objPtr);
- iPtr->varFramePtr = savedVarFramePtr;
return result;
}
@@ -3953,61 +3808,6 @@ ProcessUnexpectedResult(interp, returnCode)
}
/*
- *----------------------------------------------------------------------
- *
- * RecordTracebackInfo --
- *
- * Procedure called by Tcl_EvalObj to record information about what was
- * being executed when the error occurred.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Appends information about the script being evaluated to the
- * interpreter's "errorInfo" variable.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RecordTracebackInfo(interp, objPtr, numSrcBytes)
- Tcl_Interp *interp; /* The interpreter in which the error
- * occurred. */
- Tcl_Obj *objPtr; /* Points to object containing script whose
- * evaluation resulted in an error. */
- int numSrcBytes; /* Number of bytes compiled in script. */
-{
- Interp *iPtr = (Interp *) interp;
- char buf[200];
- char *ellipsis, *bytes;
- int length;
-
- /*
- * Decide how much of the command to print in the error message
- * (up to a certain number of bytes).
- */
-
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- length = TclMin(numSrcBytes, length);
-
- ellipsis = "";
- if (length > 150) {
- length = 150;
- ellipsis = " ...";
- }
-
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- length, bytes, ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- length, bytes, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
-}
-
-/*
*---------------------------------------------------------------------------
*
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
@@ -4711,217 +4511,6 @@ Tcl_ExprString(interp, string)
}
/*
- *--------------------------------------------------------------
- *
- * Tcl_ExprObj --
- *
- * Evaluate an expression in a Tcl_Obj.
- *
- * Results:
- * A standard Tcl object result. If the result is other than TCL_OK,
- * then the interpreter's result contains an error message. If the
- * result is TCL_OK, then a pointer to the expression's result value
- * object is stored in resultPtrPtr. In that case, the object's ref
- * count is incremented to reflect the reference returned to the
- * caller; the caller is then responsible for the resulting object
- * and must, for example, decrement the ref count when it is finished
- * with the object.
- *
- * Side effects:
- * Any side effects caused by subcommands in the expression, if any.
- * The interpreter result is not modified unless there is an error.
- *
- *--------------------------------------------------------------
- */
-
-int
-Tcl_ExprObj(interp, objPtr, resultPtrPtr)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- register Tcl_Obj *objPtr; /* Points to Tcl object containing
- * expression to evaluate. */
- Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
- * result is stored if no errors occur. */
-{
- Interp *iPtr = (Interp *) interp;
- CompileEnv compEnv; /* Compilation environment structure
- * allocated in frame. */
- LiteralTable *localTablePtr = &(compEnv.localLitTable);
- register ByteCode *codePtr = NULL;
- /* Tcl Internal type of bytecode.
- * Initialized to avoid compiler warning. */
- AuxData *auxDataPtr;
- LiteralEntry *entryPtr;
- Tcl_Obj *saveObjPtr;
- char *string;
- int length, i, result;
-
- /*
- * First handle some common expressions specially.
- */
-
- string = Tcl_GetStringFromObj(objPtr, &length);
- if (length == 1) {
- if (*string == '0') {
- *resultPtrPtr = Tcl_NewLongObj(0);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- } else if (*string == '1') {
- *resultPtrPtr = Tcl_NewLongObj(1);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- }
- } else if ((length == 2) && (*string == '!')) {
- if (*(string+1) == '0') {
- *resultPtrPtr = Tcl_NewLongObj(1);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- } else if (*(string+1) == '1') {
- *resultPtrPtr = Tcl_NewLongObj(0);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- }
- }
-
- /*
- * Get the ByteCode from the object. If it exists, make sure it hasn't
- * been invalidated by, e.g., someone redefining a command with a
- * compile procedure (this might make the compiled code wrong). If
- * necessary, convert the object to be a ByteCode object and compile it.
- * Also, if the code was compiled in/for a different interpreter, we
- * recompile it.
- *
- * Precompiled expressions, however, are immutable and therefore
- * they are not recompiled, even if the epoch has changed.
- *
- */
-
- if (objPtr->typePtr == &tclByteCodeType) {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if (((Interp *) *codePtr->interpHandle != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)) {
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if ((Interp *) *codePtr->interpHandle != iPtr) {
- panic("Tcl_ExprObj: compiled expression jumped interps");
- }
- codePtr->compileEpoch = iPtr->compileEpoch;
- } else {
- (*tclByteCodeType.freeIntRepProc)(objPtr);
- objPtr->typePtr = (Tcl_ObjType *) NULL;
- }
- }
- }
- if (objPtr->typePtr != &tclByteCodeType) {
- TclInitCompileEnv(interp, &compEnv, string, length);
- result = TclCompileExpr(interp, string, length, &compEnv);
-
- /*
- * Free the compilation environment's literal table bucket array if
- * it was dynamically allocated.
- */
-
- if (localTablePtr->buckets != localTablePtr->staticBuckets) {
- ckfree((char *) localTablePtr->buckets);
- }
-
- if (result != TCL_OK) {
- /*
- * Compilation errors. Free storage allocated for compilation.
- */
-
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyLocalLiteralTable(&compEnv);
-#endif /*TCL_COMPILE_DEBUG*/
- entryPtr = compEnv.literalArrayPtr;
- for (i = 0; i < compEnv.literalArrayNext; i++) {
- TclReleaseLiteral(interp, entryPtr->objPtr);
- entryPtr++;
- }
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyGlobalLiteralTable(iPtr);
-#endif /*TCL_COMPILE_DEBUG*/
-
- auxDataPtr = compEnv.auxDataArrayPtr;
- for (i = 0; i < compEnv.auxDataArrayNext; i++) {
- if (auxDataPtr->type->freeProc != NULL) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
- }
- auxDataPtr++;
- }
- TclFreeCompileEnv(&compEnv);
- return result;
- }
-
- /*
- * Successful compilation. If the expression yielded no
- * instructions, push an zero object as the expression's result.
- */
-
- if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
- &compEnv);
- }
-
- /*
- * Add a "done" instruction as the last instruction and change the
- * object into a ByteCode object. Ownership of the literal objects
- * and aux data items is given to the ByteCode object.
- */
-
- compEnv.numSrcBytes = iPtr->termOffset;
- TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- TclFreeCompileEnv(&compEnv);
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
-#ifdef TCL_COMPILE_DEBUG
- if (tclTraceCompile == 2) {
- TclPrintByteCodeObj(interp, objPtr);
- }
-#endif /* TCL_COMPILE_DEBUG */
- }
-
- /*
- * Execute the expression after first saving the interpreter's result.
- */
-
- saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
- Tcl_ResetResult(interp);
-
- /*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
- */
-
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
- }
-
- /*
- * If the expression evaluated successfully, store a pointer to its
- * value object in resultPtrPtr then restore the old interpreter result.
- * We increment the object's ref count to reflect the reference that we
- * are returning to the caller. We also decrement the ref count of the
- * interpreter's result object after calling Tcl_SetResult since we
- * next store into that field directly.
- */
-
- if (result == TCL_OK) {
- *resultPtrPtr = iPtr->objResultPtr;
- Tcl_IncrRefCount(iPtr->objResultPtr);
-
- Tcl_SetObjResult(interp, saveObjPtr);
- }
- Tcl_DecrRefCount(saveObjPtr);
- return result;
-}
-
-/*
*----------------------------------------------------------------------
*
* Tcl_CreateTrace --