summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog12
-rw-r--r--generic/tclBasic.c453
-rw-r--r--generic/tclCompile.h14
-rw-r--r--generic/tclExecute.c467
4 files changed, 508 insertions, 438 deletions
diff --git a/ChangeLog b/ChangeLog
index e7ae183..3b75631 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
* generic/tclBasic.c
* generic/tclCompile.h:
+ * generic/tclExecute.c: moving all code relative to bytecodes from
+ tclBasic.c to tclExecute.c - the functions RecordTracebackInfo and
+ Tcl_ExprObj went to tclExecute.c, and new interface function was
+ defined (TclCompEvalObj).
+ The final objective of this sequence of moves is to provide a
+ clean, clear-cut interface between Tcl's core and the
+ compiler/engine subsystem.
+
+2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclBasic.c
+ * generic/tclCompile.h:
* generic/tclExecute.c: factoring out of common code in tclBasic.c
(new function TclInterpReady defined: it resets the interp's
result, then checks that it hasn't been deleted and that the
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 --
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d26bdd9..533f521 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,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.21 2001/11/20 21:17:39 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.22 2001/11/20 22:47:58 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -730,6 +730,16 @@ EXTERN int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc,
int flags));
EXTERN int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));
+
+/*
+ *----------------------------------------------------------------
+ * Procedures exported by the engine to be used by tclBasic.c
+ *----------------------------------------------------------------
+ */
+
+EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int engineCall));
+
/*
*----------------------------------------------------------------
* Procedures shared among Tcl bytecode compilation and execution
@@ -766,8 +776,6 @@ EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr,
EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_((
unsigned char *pc, int catchOnly,
ByteCode* codePtr));
-EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
- ByteCode *codePtr));
EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void));
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 8ca2772..fa05bab 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.41 2001/11/20 21:17:39 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.42 2001/11/20 22:47:58 msofer Exp $
*/
#include "tclInt.h"
@@ -221,6 +221,8 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
* Declarations for local procedures to this file:
*/
+static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
+ ByteCode *codePtr));
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
@@ -258,6 +260,11 @@ static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
+#endif
+static void RecordTracebackInfo _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int numSrcBytes));
+#ifdef TCL_COMPILE_DEBUG
static char * StringForResultCode _ANSI_ARGS_((int result));
static void ValidatePcAndStackTop _ANSI_ARGS_((
ByteCode *codePtr, unsigned char *pc,
@@ -488,6 +495,460 @@ GrowEvaluationStack(eePtr)
}
/*
+ *--------------------------------------------------------------
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompEvalObj --
+ *
+ * This procedure evaluates the script contained in a Tcl_Obj by
+ * first compiling it and then passing it to TclExecuteByteCode.
+ *
+ * Results:
+ * The return value is one of the return codes defined in tcl.h
+ * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
+ * that either contains the result of executing the code or an
+ * error message.
+ *
+ * Side effects:
+ * Almost certainly, depending on the ByteCode's instructions.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompEvalObj(interp, objPtr, engineCall)
+ Tcl_Interp *interp;
+ Tcl_Obj *objPtr;
+ int engineCall; /* Set to 1 if it is an internal
+ * engine call, 0 if called from
+ * Tcl_EvalObjEx */
+{
+ 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;
+ Namespace *namespacePtr;
+
+
+ /*
+ * Check that the interpreter is ready to execute scripts
+ */
+
+ if (TclInterpReady(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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;
+ }
+
+ 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) {
+ return result;;
+ }
+ } 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) {
+ return result;
+ }
+ }
+ }
+ 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.
+ */
+
+ 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.
+ */
+
+ 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);
+ }
+
+ /*
+ * 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--;
+
+ /*
+ * Tcl_EvalObjEx needs the evalFlags for error reporting at
+ * iPtr->numLevels 0 - we pass it here, it will reset them.
+ */
+
+ if (!engineCall) {
+ iPtr->evalFlags = evalFlags;
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+}
+
+/*
*----------------------------------------------------------------------
*
* TclExecuteByteCode --
@@ -507,7 +968,7 @@ GrowEvaluationStack(eePtr)
*----------------------------------------------------------------------
*/
-int
+static int
TclExecuteByteCode(interp, codePtr)
Tcl_Interp *interp; /* Token for command interpreter. */
ByteCode *codePtr; /* The bytecode sequence to interpret. */
@@ -910,7 +1371,7 @@ TclExecuteByteCode(interp, codePtr)
case INST_EVAL_STK:
objPtr = POP_OBJECT();
DECACHE_STACK_INFO();
- result = Tcl_EvalObjEx(interp, objPtr, 0);
+ result = TclCompEvalObj(interp, objPtr, /* engineCall */ 1);
CACHE_STACK_INFO();
if (result == TCL_OK) {
/*