summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c131
-rw-r--r--generic/tclInt.h1
-rw-r--r--generic/tclInterp.c56
-rw-r--r--generic/tclNamesp.c2
-rw-r--r--generic/tclOOMethod.c2
-rw-r--r--generic/tclStubLibTbl.c58
6 files changed, 127 insertions, 123 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c1032f9..d35af46 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -147,7 +147,8 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static int TEOV_RunEnterTraces(Tcl_Interp *interp,
Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
- Tcl_Obj *const objv[], Namespace *lookupNsPtr);
+ Tcl_Obj *const objv[], Namespace *lookupNsPtr,
+ int weLookUp);
static Tcl_NRPostProc RewindCoroutineCallback;
static Tcl_NRPostProc TailcallCleanup;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
@@ -160,6 +161,7 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces;
static Tcl_NRPostProc Dispatch;
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+static Tcl_NRPostProc NRPostInvoke;
MODULE_SCOPE const TclStubs tclStubs;
@@ -4097,6 +4099,7 @@ TclNREvalObjv(
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Command **cmdPtrPtr;
NRE_callback *callbackPtr;
+ int weLookUp = (cmdPtr == NULL);
iPtr->lookupNsPtr = NULL;
@@ -4126,10 +4129,6 @@ TclNREvalObjv(
return result;
}
- if (cmdPtr) {
- goto commandFound;
- }
-
/*
* Push records for task to be done on return, in INVERSE order. First, if
* needed, the exception handlers (as they should happen last).
@@ -4139,6 +4138,10 @@ TclNREvalObjv(
TEOV_PushExceptionHandlers(interp, objc, objv, flags);
}
+ if (!weLookUp) {
+ goto commandFound;
+ }
+
/*
* Configure evaluation context to match the requested flags.
*/
@@ -4187,12 +4190,16 @@ TclNREvalObjv(
result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame(
flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
- objc, objv), objc, objv, lookupNsPtr);
+ objc, objv), objc, objv, lookupNsPtr, weLookUp);
if (result != TCL_OK) {
return result;
}
- if (!cmdPtr) {
- return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
+ if (cmdPtr == NULL) {
+ if (weLookUp) {
+ return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
+ }
+ /* Is this right??? */
+ return TCL_OK;
}
}
@@ -4595,7 +4602,8 @@ TEOV_RunEnterTraces(
Tcl_Obj *commandPtr,
int objc,
Tcl_Obj *const objv[],
- Namespace *lookupNsPtr)
+ Namespace *lookupNsPtr,
+ int weLookUp)
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
@@ -4603,7 +4611,7 @@ TEOV_RunEnterTraces(
int cmdEpoch = cmdPtr->cmdEpoch;
int newEpoch;
const char *command;
- int length;
+ int length, deleted;
Tcl_IncrRefCount(commandPtr);
command = Tcl_GetStringFromObj(commandPtr, &length);
@@ -4625,16 +4633,32 @@ TEOV_RunEnterTraces(
cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv);
}
newEpoch = cmdPtr->cmdEpoch;
+ deleted = cmdPtr->flags & CMD_IS_DELETED;
TclCleanupCommandMacro(cmdPtr);
- /*
- * If the traces modified/deleted the command or any existing traces, they
- * will update the command's epoch. We need to lookup again, but do not
- * run enter traces on the newly found cmdPtr.
- */
-
if (cmdEpoch != newEpoch) {
- cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
+
+ /*
+ * The traces did something to the traced command. How should
+ * we respond?
+ *
+ * If we got the trace command by looking up a command name, we
+ * should just look it up again.
+ */
+ if (weLookUp) {
+ cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
+ } else {
+
+ /*
+ * If we did not look up a command name, we got the cmdPtr
+ * from a caller. If that cmdPtr has been deleted, we need
+ * to avoid a crash. Otherwise, press on. We don't have
+ * any foundation to claim a better answer.
+ */
+ if (deleted) {
+ cmdPtr = NULL;
+ }
+ }
*cmdPtrPtr = cmdPtr;
}
@@ -6462,30 +6486,32 @@ TclObjInvoke(
* TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
* or TCL_INVOKE_NO_TRACEBACK. */
{
- register Interp *iPtr = (Interp *) interp;
- Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
- const char *cmdName; /* Name of the command from objv[0]. */
- Tcl_HashEntry *hPtr = NULL;
- Command *cmdPtr;
- int result;
-
if (interp == NULL) {
return TCL_ERROR;
}
-
if ((objc < 1) || (objv == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal argument vector", -1));
return TCL_ERROR;
}
-
if ((flags & TCL_INVOKE_HIDDEN) == 0) {
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
+ return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
+}
- if (TclInterpReady(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
+int
+TclNRInvoke(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ register Interp *iPtr = (Interp *) interp;
+ Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
+ const char *cmdName; /* Name of the command from objv[0]. */
+ Tcl_HashEntry *hPtr = NULL;
+ Command *cmdPtr;
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
@@ -6501,36 +6527,22 @@ TclObjInvoke(
}
cmdPtr = Tcl_GetHashValue(hPtr);
- /*
- * Invoke the command function.
- */
-
- iPtr->cmdCount++;
- if (cmdPtr->objProc != NULL) {
- result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
- } else {
- result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
- cmdPtr->objClientData, objc, objv);
- }
-
- /*
- * If an error occurred, record information about what was being executed
- * when the error occurred.
- */
-
- if ((result == TCL_ERROR)
- && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
- && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
- int length;
- Tcl_Obj *command = Tcl_NewListObj(objc, objv);
- const char *cmdString;
+ /* Avoid the exception-handling brain damage when numLevels == 0 . */
+ iPtr->numLevels++;
+ Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
+
+ /* TODO: how to get re-resolution right */
+ return TclNREvalObjv(interp, objc, objv, 0, cmdPtr);
+}
- Tcl_IncrRefCount(command);
- cmdString = Tcl_GetStringFromObj(command, &length);
- Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
- Tcl_DecrRefCount(command);
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
- }
+static int
+NRPostInvoke(
+ ClientData clientData[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *)interp;
+ iPtr->numLevels--;
return result;
}
@@ -8106,7 +8118,8 @@ Tcl_NRCmdSwap(
Tcl_Obj *const objv[],
int flags)
{
- return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd);
+ return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
+ (Command *) cmd);
}
/*****************************************************************************
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6056119..e0e694f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2725,6 +2725,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 1a4297b..0da5d47 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -279,6 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData);
static void RunLimitHandlers(LimitHandler *handlerPtr,
Tcl_Interp *interp);
static void TimeLimitCallback(ClientData clientData);
+
+/* NRE enabling */
+static Tcl_NRPostProc NRPostInvokeHidden;
+static Tcl_ObjCmdProc NRInterpCmd;
+static Tcl_ObjCmdProc NRSlaveCmd;
+
/*
*----------------------------------------------------------------------
@@ -481,7 +487,8 @@ TclInterpInit(
slavePtr->interpCmd = NULL;
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
- Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
+ Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
+ NULL, NULL);
Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
return TCL_OK;
@@ -590,6 +597,16 @@ Tcl_InterpObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
+}
+
+static int
+NRInterpCmd(
+ ClientData clientData, /* Unused. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
Tcl_Interp *slaveInterp;
int index;
static const char *const options[] = {
@@ -2372,8 +2389,8 @@ SlaveCreate(
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
- SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc);
+ slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
+ SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
@@ -2462,6 +2479,16 @@ SlaveObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
+}
+
+static int
+NRSlaveCmd(
+ ClientData clientData, /* Slave interpreter. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
Tcl_Interp *slaveInterp = clientData;
int index;
static const char *const options[] = {
@@ -3052,7 +3079,11 @@ SlaveInvokeHidden(
Tcl_AllowExceptions(slaveInterp);
if (namespaceName == NULL) {
- result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
+ NRE_callback *rootPtr = TOP_CB(slaveInterp);
+
+ Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp,
+ rootPtr, NULL, NULL);
+ return TclNRInvoke(NULL, slaveInterp, objc, objv);
} else {
Namespace *nsPtr, *dummy1, *dummy2;
const char *tail;
@@ -3071,6 +3102,23 @@ SlaveInvokeHidden(
Tcl_Release(slaveInterp);
return result;
}
+
+static int
+NRPostInvokeHidden(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0];
+ NRE_callback *rootPtr = (NRE_callback *)data[1];
+
+ if (interp != slaveInterp) {
+ result = TclNRRunCallbacks(slaveInterp, result, rootPtr);
+ Tcl_TransferResult(slaveInterp, result, interp);
+ }
+ Tcl_Release(slaveInterp);
+ return result;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index aed623a..bdd5386 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1942,7 +1942,7 @@ InvokeImportedNRCmd(
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
- return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
+ return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
static int
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index f9f980a..81293c7 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1421,7 +1421,7 @@ InvokeForwardMethod(
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
((Interp *)interp)->lookupNsPtr
= (Namespace *) contextPtr->oPtr->namespacePtr;
- return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, NULL);
+ return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}
static int
diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c
deleted file mode 100644
index 0391502..0000000
--- a/generic/tclStubLibTbl.c
+++ /dev/null
@@ -1,58 +0,0 @@
-/*
- * tclStubLibTbl.c --
- *
- * Stub object that will be statically linked into extensions that want
- * to access Tcl.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * Copyright (c) 1998 Paul Duffin.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInitStubTable --
- *
- * Initialize the stub table, using the structure pointed at
- * by the "version" argument.
- *
- * Results:
- * Outputs the value of the "version" argument.
- *
- * Side effects:
- * Sets the stub table pointers.
- *
- *----------------------------------------------------------------------
- */
-MODULE_SCOPE const char *
-TclInitStubTable(
- const char *version) /* points to the version field of a
- TclStubInfoType structure variable. */
-{
- tclStubsPtr = ((const TclStubInfoType *) version)->stubs;
-
- if (tclStubsPtr->hooks) {
- tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
- tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
- tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
- } else {
- tclPlatStubsPtr = NULL;
- tclIntStubsPtr = NULL;
- tclIntPlatStubsPtr = NULL;
- }
-
- return version;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
generated by cgit v0.12 at 2024-11-11 10:33:25 (GMT)