summaryrefslogtreecommitdiffstats
path: root/generic/tclBasic.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r--generic/tclBasic.c579
1 files changed, 421 insertions, 158 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5ca70d4..645a581 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -86,7 +86,7 @@ typedef struct OldMathFuncData {
Tcl_MathProc *proc; /* Handler function */
int numArgs; /* Number of args expected */
Tcl_ValueType *argTypes; /* Types of the args */
- ClientData clientData; /* Client data for the handler function */
+ void *clientData; /* Client data for the handler function */
} OldMathFuncData;
/*
@@ -105,8 +105,8 @@ typedef struct {
* cancellation. */
char *result; /* The script cancellation result or NULL for
* a default result. */
- int length; /* Length of the above error message. */
- ClientData clientData; /* Not used. */
+ int length; /* Length of the above error message. */
+ void *clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
@@ -149,12 +149,12 @@ static Tcl_ObjCmdProc BadEnsembleSubcommand;
static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr,
const char *oldName, const char *newName,
int flags);
-static int CancelEvalProc(ClientData clientData,
+static int CancelEvalProc(void *clientData,
Tcl_Interp *interp, int code);
static int CheckDoubleResult(Tcl_Interp *interp, double dResult);
-static void DeleteCoroutine(ClientData clientData);
+static void DeleteCoroutine(void *clientData);
static void DeleteInterpProc(Tcl_Interp *interp);
-static void DeleteOpCmdClientData(ClientData clientData);
+static void DeleteOpCmdClientData(void *clientData);
#ifdef USE_DTRACE
static Tcl_ObjCmdProc DTraceObjCmd;
static Tcl_NRPostProc DTraceCmdReturn;
@@ -192,7 +192,7 @@ static Tcl_NRPostProc NRCommand;
#if !defined(TCL_NO_DEPRECATED)
static Tcl_ObjCmdProc OldMathFuncProc;
-static void OldMathFuncDeleteProc(ClientData clientData);
+static void OldMathFuncDeleteProc(void *clientData);
#endif /* !defined(TCL_NO_DEPRECATED) */
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
@@ -233,8 +233,8 @@ MODULE_SCOPE const TclStubs tclStubs;
* after particular kinds of [yield].
*/
-#define CORO_ACTIVATE_YIELD PTR2INT(NULL)
-#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1
+#define CORO_ACTIVATE_YIELD NULL
+#define CORO_ACTIVATE_YIELDM INT2PTR(1)
#define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1)
#define COROUTINE_ARGUMENTS_ARBITRARY (-2)
@@ -607,6 +607,108 @@ TclFinalizeEvaluation(void)
/*
*----------------------------------------------------------------------
*
+ * buildInfoObjCmd --
+ *
+ * Implements tcl::build-info command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+buildInfoObjCmd(
+ void *clientData,
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?option?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ int len;
+ const char *arg = TclGetStringFromObj(objv[1], &len);
+ if (len == 7 && !strcmp(arg, "version")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '.');
+ if (p) {
+ const char *q = strchr(p+1, '.');
+ const char *r = strchr(p+1, '+');
+ p = (q < r) ? q : r;
+ }
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ return TCL_OK;
+ } else if (len == 10 && !strcmp(arg, "patchlevel")) {
+ char buf[80];
+ const char *p = strchr((char *)clientData, '+');
+ if (p) {
+ memcpy(buf, (char *)clientData, p - (char *)clientData);
+ buf[p - (char *)clientData] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ }
+ return TCL_OK;
+ } else if (len == 6 && !strcmp(arg, "commit")) {
+ const char *q, *p = strchr((char *)clientData, '+');
+ if (p) {
+ if ((q = strchr(p, '.'))) {
+ char buf[80];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ }
+ return TCL_OK;
+ } else if (len == 8 && !strcmp(arg, "compiler")) {
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4)
+ || !strncmp(p+1, "icc-", 4) || !strncmp(p+1, "msvc-", 5)) {
+ const char *q = strchr(p+1, '.');
+ if (q) {
+ char buf[16];
+ memcpy(buf, p+1, q - p - 1);
+ buf[q - p - 1] = '\0';
+ Tcl_AppendResult(interp, buf, NULL);
+ } else {
+ Tcl_AppendResult(interp, p+1, NULL);
+ }
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ const char *p = strchr((char *)clientData, '.');
+ while (p) {
+ if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) {
+ Tcl_AppendResult(interp, "1", NULL);
+ return TCL_OK;
+ }
+ p = strchr(p+1, '.');
+ }
+ Tcl_AppendResult(interp, "0", NULL);
+ return TCL_OK;
+ }
+ Tcl_AppendResult(interp, (char *)clientData, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_CreateInterp --
*
* Create a new TCL command interpreter.
@@ -644,8 +746,7 @@ Tcl_CreateInterp(void)
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
-
- Tcl_InitSubsystems();
+ const char *version = Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
@@ -1162,7 +1263,7 @@ Tcl_CreateInterp(void)
#endif /* !TCL_NO_DEPRECATED */
TclpSetVariables(interp);
-#if TCL_THREADS
+#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
@@ -1176,10 +1277,14 @@ Tcl_CreateInterp(void)
/*
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
+ * TIP #599: Extended build information "+<UUID>.<tag1>.<tag2>...."
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs);
+ Tcl_CreateObjCommand(interp, "::tcl::build-info",
+ buildInfoObjCmd, (void *)version, NULL);
+
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
@@ -1209,7 +1314,7 @@ Tcl_CreateInterp(void)
static void
DeleteOpCmdClientData(
- ClientData clientData)
+ void *clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
@@ -1245,11 +1350,11 @@ TclRegisterCommandTypeName(
int isNew;
hPtr = Tcl_CreateHashEntry(&commandTypeTable,
- (void *) implementationProc, &isNew);
+ implementationProc, &isNew);
Tcl_SetHashValue(hPtr, (void *) nameStr);
} else {
hPtr = Tcl_FindHashEntry(&commandTypeTable,
- (void *) implementationProc);
+ implementationProc);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -1374,7 +1479,7 @@ TclHideUnsafeCommands(
static int
BadEnsembleSubcommand(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /* objv */)
@@ -1414,7 +1519,7 @@ Tcl_CallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
@@ -1462,7 +1567,7 @@ Tcl_DontCallWhenDeleted(
Tcl_Interp *interp, /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTablePtr;
@@ -1510,7 +1615,7 @@ Tcl_SetAssocData(
const char *name, /* Name for association. */
Tcl_InterpDeleteProc *proc, /* Proc to call when interpreter is about to
* be deleted. */
- ClientData clientData) /* One-word value to pass to proc. */
+ void *clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
@@ -1592,7 +1697,7 @@ Tcl_DeleteAssocData(
*----------------------------------------------------------------------
*/
-ClientData
+void *
Tcl_GetAssocData(
Tcl_Interp *interp, /* Interpreter associated with. */
const char *name, /* Name of association. */
@@ -1760,7 +1865,7 @@ DeleteInterpProc(
*/
Tcl_MutexLock(&cancelLock);
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
+ hPtr = Tcl_FindHashEntry(&cancelTable, iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
@@ -1826,28 +1931,28 @@ DeleteInterpProc(
ckfree(hTablePtr);
}
- /*
- * Invoke deletion callbacks; note that a callback can create new
- * callbacks, so we iterate.
- */
- while (iPtr->assocData != NULL) {
+ if (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
- iPtr->assocData = NULL;
+ /*
+ * Invoke deletion callbacks; note that a callback can create new
+ * callbacks, so we iterate.
+ */
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
+ Tcl_DeleteHashEntry(hPtr);
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
+ iPtr->assocData = NULL;
}
/*
@@ -1965,7 +2070,7 @@ DeleteInterpProc(
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
- for (i=0; i< eclPtr->nuloc; i++) {
+ for (i=0; i<eclPtr->nuloc; i++) {
ckfree(eclPtr->loc[i].line);
}
@@ -2396,7 +2501,7 @@ Tcl_CreateCommand(
* specified namespace; otherwise it is put in
* the global namespace. */
Tcl_CmdProc *proc, /* Function to associate with cmdName. */
- ClientData clientData, /* Arbitrary value passed to string proc. */
+ void *clientData, /* Arbitrary value passed to string proc. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
@@ -2584,6 +2689,61 @@ Tcl_CreateCommand(
*----------------------------------------------------------------------
*/
+typedef struct {
+ void *clientData; /* Arbitrary value to pass to object function. */
+ Tcl_ObjCmdProc2 *proc;
+ Tcl_ObjCmdProc2 *nreProc;
+ Tcl_CmdDeleteProc *deleteProc;
+} CmdWrapperInfo;
+
+
+static int cmdWrapperProc(void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const *objv)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ return info->proc(info->clientData, interp, objc, objv);
+}
+
+static void cmdWrapperDeleteProc(void *clientData) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+
+ clientData = info->clientData;
+ Tcl_CmdDeleteProc *deleteProc = info->deleteProc;
+ ckfree(info);
+ if (deleteProc != NULL) {
+ deleteProc(clientData);
+ }
+}
+
+Tcl_Command
+Tcl_CreateObjCommand2(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name. */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+)
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->deleteProc = deleteProc;
+ info->clientData = clientData;
+
+ return Tcl_CreateObjCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_CreateObjCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -2594,7 +2754,7 @@ Tcl_CreateObjCommand(
* the global namespace. */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc
/* If not NULL, gives a function to call when
@@ -2644,7 +2804,7 @@ TclCreateObjCommandInNs(
Tcl_Namespace *namesp, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
@@ -2830,7 +2990,7 @@ TclCreateObjCommandInNs(
int
TclInvokeStringCommand(
- ClientData clientData, /* Points to command's Command structure. */
+ void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -2878,7 +3038,7 @@ TclInvokeStringCommand(
int
TclInvokeObjectCommand(
- ClientData clientData, /* Points to command's Command structure. */
+ void *clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
@@ -3217,8 +3377,14 @@ Tcl_SetCommandInfoFromToken(
}
cmdPtr->objClientData = infoPtr->objClientData;
}
- cmdPtr->deleteProc = infoPtr->deleteProc;
- cmdPtr->deleteData = infoPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ info->deleteProc = infoPtr->deleteProc;
+ info->clientData = infoPtr->deleteData;
+ } else {
+ cmdPtr->deleteProc = infoPtr->deleteProc;
+ cmdPtr->deleteData = infoPtr->deleteData;
+ }
return 1;
}
@@ -3295,10 +3461,15 @@ Tcl_GetCommandInfoFromToken(
infoPtr->objClientData = cmdPtr->objClientData;
infoPtr->proc = cmdPtr->proc;
infoPtr->clientData = cmdPtr->clientData;
- infoPtr->deleteProc = cmdPtr->deleteProc;
- infoPtr->deleteData = cmdPtr->deleteData;
+ if (cmdPtr->deleteProc == cmdWrapperDeleteProc) {
+ CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData;
+ infoPtr->deleteProc = info->deleteProc;
+ infoPtr->deleteData = info->clientData;
+ } else {
+ infoPtr->deleteProc = cmdPtr->deleteProc;
+ infoPtr->deleteData = cmdPtr->deleteData;
+ }
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
-
return 1;
}
@@ -3505,15 +3676,14 @@ Tcl_DeleteCommandFromToken(
cmdPtr->flags |= CMD_DYING;
/*
- * Call trace functions for the command being deleted. Then delete its
- * traces.
+ * Call each functions and then delete the trace.
*/
cmdPtr->nsPtr->refCount++;
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
- /* Note that CallCommandTraces() never frees cmdPtr, that's
+ /* CallCommandTraces() does not cmdPtr, that's
* done just before Tcl_DeleteCommandFromToken() returns */
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
@@ -3768,7 +3938,7 @@ CallCommandTraces(
static int
CancelEvalProc(
- ClientData clientData, /* Interp to cancel the script in progress. */
+ void *clientData, /* Interp to cancel the script in progress. */
TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
@@ -3888,7 +4058,7 @@ Tcl_CreateMathFunc(
* argument. */
Tcl_MathProc *proc, /* C function that implements the math
* function. */
- ClientData clientData) /* Additional value to pass to the
+ void *clientData) /* Additional value to pass to the
* function. */
{
Tcl_DString bigName;
@@ -3897,7 +4067,9 @@ Tcl_CreateMathFunc(
data->proc = proc;
data->numArgs = numArgs;
data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
- memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
+ if ((numArgs > 0) && (argTypes != NULL)) {
+ memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
+ }
data->clientData = clientData;
Tcl_DStringInit(&bigName);
@@ -3927,7 +4099,7 @@ Tcl_CreateMathFunc(
static int
OldMathFuncProc(
- ClientData clientData, /* Pointer to OldMathFuncData describing the
+ void *clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
@@ -3960,8 +4132,8 @@ OldMathFuncProc(
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
if (result != TCL_OK) {
- const Tcl_ObjIntRep *irPtr
- = TclFetchIntRep(valuePtr, &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr
+ = TclFetchInternalRep(valuePtr, &tclDoubleType);
if (irPtr) {
d = irPtr->doubleValue;
@@ -4074,7 +4246,7 @@ OldMathFuncProc(
static void
OldMathFuncDeleteProc(
- ClientData clientData)
+ void *clientData)
{
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
@@ -4113,7 +4285,7 @@ Tcl_GetMathFuncInfo(
int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
- ClientData *clientDataPtr)
+ void **clientDataPtr)
{
Tcl_Obj *cmdNameObj;
Command *cmdPtr;
@@ -4276,7 +4448,7 @@ TclInterpReady(
* probably because of an infinite loop somewhere.
*/
- if (((iPtr->numLevels) <= iPtr->maxNestingDepth)) {
+ if ((iPtr->numLevels <= iPtr->maxNestingDepth)) {
return TCL_OK;
}
@@ -4455,7 +4627,7 @@ Tcl_CancelEval(
* script. */
Tcl_Obj *resultObjPtr, /* The script cancellation error message or
* NULL for a default error message. */
- ClientData clientData, /* Passed to CancelEvalProc. */
+ void *clientData, /* Passed to CancelEvalProc. */
int flags) /* Collection of OR-ed bits that control
* the cancellation of the script. Only
* TCL_CANCEL_UNWIND is currently
@@ -4478,7 +4650,7 @@ Tcl_CancelEval(
goto done;
}
- hPtr = Tcl_FindHashEntry(&cancelTable, (char *) interp);
+ hPtr = Tcl_FindHashEntry(&cancelTable, interp);
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
@@ -4614,7 +4786,7 @@ TclNREvalObjv(
static int
EvalObjvCore(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
@@ -4774,12 +4946,12 @@ EvalObjvCore(
static int
Dispatch(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
- ClientData clientData = data[1];
+ void *clientData = data[1];
int objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
@@ -4862,11 +5034,12 @@ TclNRRunCallbacks(
static int
NRCommand(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *listPtr;
iPtr->numLevels--;
@@ -4875,7 +5048,10 @@ NRCommand(
*/
if (data[1] && (data[1] != INT2PTR(1))) {
- TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
+ listPtr = (Tcl_Obj *)data[1];
+ data[1] = NULL;
+
+ TclNRAddCallback(interp, TclNRTailcallEval, listPtr, NULL, NULL, NULL);
}
/* OPT ??
@@ -4931,7 +5107,7 @@ TEOV_PushExceptionHandlers(
*/
TclNRAddCallback(interp, TEOV_Error, INT2PTR(objc),
- (ClientData) objv, NULL, NULL);
+ objv, NULL, NULL);
}
if (iPtr->numLevels == 1) {
@@ -4962,7 +5138,7 @@ TEOV_SwitchVarFrame(
static int
TEOV_RestoreVarFrame(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -4972,7 +5148,7 @@ TEOV_RestoreVarFrame(
static int
TEOV_Exception(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -5001,7 +5177,7 @@ TEOV_Exception(
static int
TEOV_Error(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -5069,7 +5245,7 @@ TEOV_NotFound(
* itself.
*/
- Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
+ TclListObjGetElementsM(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
@@ -5127,7 +5303,7 @@ TEOV_NotFound(
static int
TEOV_NotFoundCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -5164,8 +5340,8 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
- int length, traceCode = TCL_OK;
+ int length, newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ int traceCode = TCL_OK;
const char *command = TclGetStringFromObj(commandPtr, &length);
/*
@@ -5207,7 +5383,7 @@ TEOV_RunEnterTraces(
static int
TEOV_RunLeaveTraces(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -5429,12 +5605,13 @@ TclEvalEx(
Tcl_Obj **objv, **objvSpace;
int *expand, *lines, *lineSpace;
Tcl_Token *tokenPtr;
- int commandLength, bytesLeft, expandRequested, code = TCL_OK;
+ int bytesLeft, expandRequested, code = TCL_OK;
+ int commandLength;
CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
- unsigned int i, objectsUsed = 0;
+ TCL_HASH_TYPE i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
@@ -5626,7 +5803,7 @@ TclEvalEx(
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
int numElements;
- code = TclListObjLength(interp, objv[objectsUsed],
+ code = TclListObjLengthM(interp, objv[objectsUsed],
&numElements);
if (code == TCL_ERROR) {
/*
@@ -5678,7 +5855,7 @@ TclEvalEx(
int numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
- Tcl_ListObjGetElements(NULL, temp, &numElements,
+ TclListObjGetElementsM(NULL, temp, &numElements,
&elements);
objectsUsed += numElements;
while (numElements--) {
@@ -6039,7 +6216,7 @@ TclArgumentRelease(
for (i = 1; i < objc; i++) {
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
+ Tcl_FindHashEntry(iPtr->lineLAPtr, objv[i]);
if (!hPtr) {
continue;
@@ -6091,7 +6268,7 @@ TclArgumentBCEnter(
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
- Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
@@ -6197,7 +6374,7 @@ TclArgumentBCRelease(
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
- Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
+ Tcl_FindHashEntry(iPtr->lineLABCPtr, cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
@@ -6262,7 +6439,7 @@ TclArgumentGet(
* stack. That is nearest.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
@@ -6276,7 +6453,7 @@ TclArgumentGet(
* that stack.
*/
- hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
+ hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
@@ -6319,7 +6496,7 @@ Tcl_Eval(
* previous call to Tcl_CreateInterp). */
const char *script) /* Pointer to TCL command to execute. */
{
- int code = Tcl_EvalEx(interp, script, -1, 0);
+ int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0);
/*
* For backwards compatibility with old C code that predates the object
@@ -6518,7 +6695,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
@@ -6598,7 +6775,7 @@ TclNREvalObjEx(
static int
TEOEx_ByteCodeCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6644,7 +6821,7 @@ TEOEx_ByteCodeCallback(
static int
TEOEx_ListCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -6851,7 +7028,7 @@ Tcl_ExprLongObj(
Tcl_Obj *resultPtr;
int result, type;
double d;
- ClientData internalPtr;
+ void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
@@ -6897,7 +7074,7 @@ Tcl_ExprDoubleObj(
{
Tcl_Obj *resultPtr;
int result, type;
- ClientData internalPtr;
+ void *internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result != TCL_OK) {
@@ -7078,7 +7255,7 @@ TclNRInvoke(
static int
NRPostInvoke(
- TCL_UNUSED(ClientData *),
+ TCL_UNUSED(void **),
Tcl_Interp *interp,
int result)
{
@@ -7168,10 +7345,11 @@ Tcl_AppendObjToErrorInfo(
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
- const char *message = TclGetString(objPtr);
+ int length;
+ const char *message = TclGetStringFromObj(objPtr, &length);
Tcl_IncrRefCount(objPtr);
- Tcl_AddObjErrorInfo(interp, message, objPtr->length);
+ Tcl_AddObjErrorInfo(interp, message, length);
Tcl_DecrRefCount(objPtr);
}
@@ -7280,7 +7458,7 @@ Tcl_AddObjErrorInfo(
}
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
@@ -7289,12 +7467,12 @@ Tcl_AddObjErrorInfo(
*
* Results:
* A standard Tcl return result. An error message or other result may be
- * left in the interp's result.
+ * left in the interp.
*
* Side effects:
* Depends on what was done by the command.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
@@ -7343,6 +7521,7 @@ Tcl_VarEvalVA(
*
*----------------------------------------------------------------------
*/
+
int
Tcl_VarEval(
Tcl_Interp *interp,
@@ -7534,7 +7713,7 @@ ExprCeilFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
@@ -7574,7 +7753,7 @@ ExprFloorFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
@@ -7602,7 +7781,7 @@ ExprIsqrtFunc(
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter list. */
{
- ClientData ptr;
+ void *ptr;
int type;
double d;
Tcl_WideInt w;
@@ -7720,7 +7899,7 @@ ExprSqrtFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
@@ -7731,7 +7910,7 @@ ExprSqrtFunc(
if (code != TCL_OK) {
return TCL_ERROR;
}
- if ((d >= 0.0) && TclIsInfinite(d)
+ if ((d >= 0.0) && isinf(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
mp_int root;
mp_err err;
@@ -7755,7 +7934,7 @@ ExprSqrtFunc(
static int
ExprUnaryFunc(
- ClientData clientData, /* Contains the address of a function that
+ void *clientData, /* Contains the address of a function that
* takes one double argument and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7774,7 +7953,7 @@ ExprUnaryFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d = irPtr->doubleValue;
@@ -7796,12 +7975,12 @@ CheckDoubleResult(
double dResult)
{
#ifndef ACCEPT_NAN
- if (TclIsNaN(dResult)) {
+ if (isnan(dResult)) {
TclExprFloatError(interp, dResult);
return TCL_ERROR;
}
#endif
- if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) {
+ if ((errno == ERANGE) && ((dResult == 0.0) || isinf(dResult))) {
/*
* When ERANGE signals under/overflow, just accept 0.0 or +/-Inf
*/
@@ -7819,7 +7998,7 @@ CheckDoubleResult(
static int
ExprBinaryFunc(
- ClientData clientData, /* Contains the address of a function that
+ void *clientData, /* Contains the address of a function that
* takes two double arguments and returns a
* double result. */
Tcl_Interp *interp, /* The interpreter in which to execute the
@@ -7838,7 +8017,7 @@ ExprBinaryFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d1 = irPtr->doubleValue;
@@ -7853,7 +8032,7 @@ ExprBinaryFunc(
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d2 = irPtr->doubleValue;
@@ -7877,7 +8056,7 @@ ExprAbsFunc(
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
- ClientData ptr;
+ void *ptr;
int type;
mp_int big;
@@ -8014,7 +8193,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (TclHasIntRep(objv[1], &tclDoubleType)) {
+ if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
@@ -8035,7 +8214,7 @@ ExprIntFunc(
{
double d;
int type;
- ClientData ptr;
+ void *ptr;
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
@@ -8114,7 +8293,7 @@ ExprMaxMinFunc(
Tcl_Obj *res;
double d;
int type, i;
- ClientData ptr;
+ void *ptr;
if (objc < 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
@@ -8191,15 +8370,15 @@ ExprRandFunc(
* take into consideration the thread this interp is running in.
*/
- iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
+ iPtr->randSeed = TclpGetClicks() + PTR2UINT(Tcl_GetCurrentThread())*4093U;
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
- iPtr->randSeed &= 0x7FFFFFFF;
- if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
- iPtr->randSeed ^= 123459876;
+ iPtr->randSeed &= 0x7FFFFFFFL;
+ if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFFL)) {
+ iPtr->randSeed ^= 123459876L;
}
}
@@ -8266,7 +8445,7 @@ ExprRoundFunc(
Tcl_Obj *const *objv) /* Parameter vector. */
{
double d;
- ClientData ptr;
+ void *ptr;
int type;
if (objc != 2) {
@@ -8534,7 +8713,7 @@ ExprIsFiniteFunc(
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
- ClientData ptr;
+ void *ptr;
int type, result = 0;
if (objc != 2) {
@@ -8565,7 +8744,7 @@ ExprIsInfinityFunc(
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
- ClientData ptr;
+ void *ptr;
int type, result = 0;
if (objc != 2) {
@@ -8595,7 +8774,7 @@ ExprIsNaNFunc(
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
- ClientData ptr;
+ void *ptr;
int type, result = 1;
if (objc != 2) {
@@ -8625,7 +8804,7 @@ ExprIsNormalFunc(
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
- ClientData ptr;
+ void *ptr;
int type, result = 0;
if (objc != 2) {
@@ -8655,7 +8834,7 @@ ExprIsSubnormalFunc(
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
- ClientData ptr;
+ void *ptr;
int type, result = 0;
if (objc != 2) {
@@ -8685,7 +8864,7 @@ ExprIsUnorderedFunc(
Tcl_Obj *const *objv) /* Actual parameter list */
{
double d;
- ClientData ptr;
+ void *ptr;
int type, result = 0;
if (objc != 3) {
@@ -8727,7 +8906,7 @@ FloatClassifyObjCmd(
{
double d;
Tcl_Obj *objPtr;
- ClientData ptr;
+ void *ptr;
int type;
if (objc != 2) {
@@ -8931,7 +9110,7 @@ TclDTraceInfo(
static int
DTraceCmdReturn(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -8976,7 +9155,7 @@ int
Tcl_NRCallObjProc(
Tcl_Interp *interp,
Tcl_ObjCmdProc *objProc,
- ClientData clientData,
+ void *clientData,
int objc,
Tcl_Obj *const objv[])
{
@@ -8987,6 +9166,37 @@ Tcl_NRCallObjProc(
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
+int wrapperNRObjProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ clientData = info->clientData;
+ Tcl_ObjCmdProc2 *proc = info->proc;
+ ckfree(info);
+ return proc(clientData, interp, objc, objv);
+}
+
+int
+Tcl_NRCallObjProc2(
+ Tcl_Interp *interp,
+ Tcl_ObjCmdProc2 *objProc,
+ void *clientData,
+ size_t objc,
+ Tcl_Obj *const objv[])
+{
+ NRE_callback *rootPtr = TOP_CB(interp);
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->clientData = clientData;
+ info->proc = objProc;
+
+ TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info,
+ INT2PTR(objc), objv);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
+}
+
/*
*----------------------------------------------------------------------
*
@@ -9015,6 +9225,46 @@ Tcl_NRCallObjProc(
*----------------------------------------------------------------------
*/
+static int cmdWrapperNreProc(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)clientData;
+ return info->nreProc(info->clientData, interp, objc, objv);
+}
+
+Tcl_Command
+Tcl_NRCreateCommand2(
+ Tcl_Interp *interp, /* Token for command interpreter (returned by
+ * previous call to Tcl_CreateInterp). */
+ const char *cmdName, /* Name of command. If it contains namespace
+ * qualifiers, the new command is put in the
+ * specified namespace; otherwise it is put in
+ * the global namespace. */
+ Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with
+ * name, provides direct access for direct
+ * calls. */
+ Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with
+ * name, provides NR implementation */
+ void *clientData, /* Arbitrary value to pass to object
+ * function. */
+ Tcl_CmdDeleteProc *deleteProc)
+ /* If not NULL, gives a function to call when
+ * this command is deleted. */
+{
+ CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo));
+ info->proc = proc;
+ info->nreProc = nreProc;
+ info->deleteProc = deleteProc;
+ info->clientData = clientData;
+ return Tcl_NRCreateCommand(interp, cmdName,
+ (proc ? cmdWrapperProc : NULL),
+ (nreProc ? cmdWrapperNreProc : NULL),
+ info, cmdWrapperDeleteProc);
+}
+
Tcl_Command
Tcl_NRCreateCommand(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -9028,7 +9278,7 @@ Tcl_NRCreateCommand(
* calls. */
Tcl_ObjCmdProc *nreProc, /* Object-based function to associate with
* name, provides NR implementation */
- ClientData clientData, /* Arbitrary value to pass to object
+ void *clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
@@ -9049,7 +9299,7 @@ TclNRCreateCommandInNs(
Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc,
- ClientData clientData,
+ void *clientData,
Tcl_CmdDeleteProc *deleteProc)
{
Command *cmdPtr = (Command *)
@@ -9277,7 +9527,7 @@ TclNRTailcallObjCmd(
int
TclNRTailcallEval(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -9287,7 +9537,7 @@ TclNRTailcallEval(
int objc;
Tcl_Obj **objv;
- Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
+ TclListObjGetElementsM(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
if (result == TCL_OK) {
@@ -9316,7 +9566,7 @@ TclNRTailcallEval(
int
TclNRReleaseValues(
- ClientData data[],
+ void *data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
@@ -9337,10 +9587,10 @@ void
Tcl_NRAddCallback(
Tcl_Interp *interp,
Tcl_NRPostProc *postProcPtr,
- ClientData data0,
- ClientData data1,
- ClientData data2,
- ClientData data3)
+ void *data0,
+ void *data1,
+ void *data2,
+ void *data3)
{
if (!(postProcPtr)) {
Tcl_Panic("Adding a callback without an objProc?!");
@@ -9374,7 +9624,7 @@ Tcl_NRAddCallback(
int
TclNRYieldObjCmd(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
@@ -9450,14 +9700,15 @@ TclNRYieldToObjCmd(
iPtr->execEnvPtr = corPtr->callerEEPtr;
TclSetTailcall(interp, listPtr);
+ corPtr->yieldPtr = listPtr;
iPtr->execEnvPtr = corPtr->eePtr;
- return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
+ return TclNRYieldObjCmd(CORO_ACTIVATE_YIELDM, interp, 1, objv);
}
static int
RewindCoroutineCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
@@ -9484,7 +9735,7 @@ RewindCoroutine(
static void
DeleteCoroutine(
- ClientData clientData)
+ void *clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
@@ -9497,7 +9748,7 @@ DeleteCoroutine(
static int
NRCoroutineCallerCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -9543,7 +9794,7 @@ NRCoroutineCallerCallback(
static int
NRCoroutineExitCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
@@ -9608,14 +9859,11 @@ NRCoroutineExitCallback(
int
TclNRCoroutineActivateCallback(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
- int type = PTR2INT(data[1]);
- int numLevels, unused;
- int *stackLevel = &unused;
if (!corPtr->stackLevel) {
/*
@@ -9632,8 +9880,8 @@ TclNRCoroutineActivateCallback(
* the interp's environment to make it suitable to run this coroutine.
*/
- corPtr->stackLevel = stackLevel;
- numLevels = corPtr->auxNumLevels;
+ corPtr->stackLevel = &corPtr;
+ int numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
SAVE_CONTEXT(corPtr->caller);
@@ -9646,7 +9894,23 @@ TclNRCoroutineActivateCallback(
* Coroutine is active: yield
*/
- if (corPtr->stackLevel != stackLevel) {
+ if (corPtr->stackLevel != &corPtr) {
+ NRE_callback *runPtr;
+
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ if (corPtr->yieldPtr) {
+ for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
+ if (runPtr->data[1] == corPtr->yieldPtr) {
+ runPtr->data[1] = NULL;
+ Tcl_DecrRefCount(corPtr->yieldPtr);
+ corPtr->yieldPtr = NULL;
+ break;
+ }
+ }
+ }
+ iPtr->execEnvPtr = corPtr->eePtr;
+
+
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot yield: C stack busy", -1));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD",
@@ -9654,6 +9918,7 @@ TclNRCoroutineActivateCallback(
return TCL_ERROR;
}
+ void *type = data[1];
if (type == CORO_ACTIVATE_YIELD) {
corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
} else if (type == CORO_ACTIVATE_YIELDM) {
@@ -9662,9 +9927,10 @@ TclNRCoroutineActivateCallback(
Tcl_Panic("Yield received an option which is not implemented");
}
+ corPtr->yieldPtr = NULL;
corPtr->stackLevel = NULL;
- numLevels = iPtr->numLevels;
+ int numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
@@ -9687,7 +9953,7 @@ TclNRCoroutineActivateCallback(
static int
TclNREvalList(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
@@ -9699,7 +9965,7 @@ TclNREvalList(
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
- TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
@@ -9811,7 +10077,6 @@ TclNRCoroInjectObjCmd(
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
- ExecEnv *savedEEPtr = iPtr->execEnvPtr;
/*
* Usage more or less like tailcall:
@@ -9840,6 +10105,7 @@ TclNRCoroInjectObjCmd(
* to happen when the coro is resumed.
*/
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, InjectHandler, corPtr,
Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL);
@@ -9856,9 +10122,6 @@ TclNRCoroProbeObjCmd(
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
- ExecEnv *savedEEPtr = iPtr->execEnvPtr;
- int numLevels, unused;
- int *stackLevel = &unused;
/*
* Usage more or less like tailcall:
@@ -9888,6 +10151,7 @@ TclNRCoroProbeObjCmd(
* to happen when the coro is resumed.
*/
+ ExecEnv *savedEEPtr = iPtr->execEnvPtr;
iPtr->execEnvPtr = corPtr->eePtr;
TclNRAddCallback(interp, InjectHandler, corPtr,
Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr);
@@ -9908,8 +10172,8 @@ TclNRCoroProbeObjCmd(
* the interp's environment to make it suitable to run this coroutine.
*/
- corPtr->stackLevel = stackLevel;
- numLevels = corPtr->auxNumLevels;
+ corPtr->stackLevel = &corPtr;
+ int numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = iPtr->numLevels;
/*
@@ -9947,14 +10211,14 @@ TclNRCoroProbeObjCmd(
static int
InjectHandler(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
int nargs = PTR2INT(data[2]);
- ClientData isProbe = data[3];
+ void *isProbe = data[3];
int objc;
Tcl_Obj **objv;
@@ -9987,21 +10251,20 @@ InjectHandler(
TclMarkTailcall(interp);
TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr,
INT2PTR(nargs), isProbe);
- TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ TclListObjGetElementsM(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
}
static int
InjectHandlerPostCall(
- ClientData data[],
+ void *data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
int nargs = PTR2INT(data[2]);
- ClientData isProbe = data[3];
- int numLevels;
+ void *isProbe = data[3];
/*
* Delete the command words for what we just executed.
@@ -10023,7 +10286,7 @@ InjectHandlerPostCall(
}
corPtr->nargs = nargs;
corPtr->stackLevel = NULL;
- numLevels = iPtr->numLevels;
+ int numLevels = iPtr->numLevels;
iPtr->numLevels = corPtr->auxNumLevels;
corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
iPtr->execEnvPtr = corPtr->callerEEPtr;
@@ -10088,7 +10351,7 @@ NRInjectObjCmd(
int
TclNRInterpCoroutine(
- ClientData clientData,
+ void *clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
@@ -10119,7 +10382,7 @@ TclNRInterpCoroutine(
}
break;
default:
- if (corPtr->nargs != objc-1) {
+ if (corPtr->nargs + 1 != objc) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("wrong coro nargs; how did we get here? "
"not implemented!", -1));
generated by cgit v0.12 at 2025-12-10 00:21:51 (GMT)