summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/vwait.n71
-rw-r--r--generic/tclEvent.c433
-rw-r--r--generic/tclInt.decls383
-rw-r--r--generic/tclIntDecls.h9
-rw-r--r--generic/tclListObj.c21
-rw-r--r--generic/tclProc.c53
-rw-r--r--generic/tclStubInit.c2
-rw-r--r--tests/event.test7
8 files changed, 554 insertions, 425 deletions
diff --git a/doc/vwait.n b/doc/vwait.n
index f64d39c..5f240d6 100644
--- a/doc/vwait.n
+++ b/doc/vwait.n
@@ -12,6 +12,8 @@
vwait \- Process events until a variable is written
.SH SYNOPSIS
\fBvwait\fR \fIvarName\fR
+.PP
+\fBvwait\fR ?\Ioptions\fR? ?\fIvarName ...\fR?
.BE
.SH DESCRIPTION
.PP
@@ -24,8 +26,75 @@ command will return as soon as the event handler that modified
a variable name with respect to the global namespace, but can refer to any
namespace's variables if the fully-qualified name is given.
.PP
+In the second more complex command form \fIoptions\fR allow for finer
+control of the wait operation and to deal with multiple event sources.
+\fIOptions\fR can be made up of
+.TP
+\fB\-\-\fR
+.
+Marks the end of options. All following arguments are handled as
+variable names.
+.TP
+\fB\-all\fR
+.
+All conditions for the wait operation must be met to complete the
+wait operation. Otherwise (the default) the first event completes
+the wait.
+.TP
+\fB\-extended\fR
+.
+An extended result in list form is returned, see below for explanation.
+.TP
+\fB\-nofileevents\fR
+.
+File events are not handled in the wait operation.
+.TP
+\fB\-noidleevents\fR
+.
+Idle handlers are not invoked during the wait operation.
+.TP
+\fB\-notimerevents\fR
+.
+Timer handlers are not serviced during the wait operation.
+.TP
+\fB\-nowindowevents\fR
+.
+Events of the windowing system are not handled during the wait operation.
+.TP
+\fB\-readable\fR \fIchannel\fR
+.
+\fIChannel\fR must name a Tcl channel open for reading. If \fIchannel\fR
+is or becomes readable the wait operation completes.
+.TP
+\fB\-timeout\fR milliseconds\fR
+.
+The wait operation is constrained to \fImilliseconds\fR.
+.TP
+\fB\-variable\fR \fIvarName\fR
+.
+\fIVarName\fR must be the name of a global variable. Writing or
+unsetting this variable completes the wait operation.
+.TP
+\fB\-writable\fR \fIchannel\fR
+.
+\fIChannel\fR must name a Tcl channel open for writing. If \fIchannel\fR
+is or becomes writable the wait operation completes.
+.PP
+The result returned by \fBvwait\fR is for the simple form an empty
+string. If the \fI\-timeout\fR option is specified, the result is the
+number of milliseconds remaining when the wait condition has been
+met, or -1 if the wait operation timed out.
+.PP
+If the \fI\-extended\fR option is specified, the result is made up
+of a Tcl list with an even number of elements. Odd elements
+take the values \fBreadable\fR, \fBtimeleft\fR, \fBvariable\fR,
+and \fBwritable\fR. Even elements are the corresponding variable
+and channel names or the remaining number of milliseconds.
+The list is ordered by the occurrences of the event(s) with the
+exception of \fBtimeleft\fR which always comes last.
+.PP
In some cases the \fBvwait\fR command may not return immediately
-after \fIvarName\fR is set. This happens if the event handler
+after \fIvarName\fR et.al. is set. This happens if the event handler
that sets \fIvarName\fR does not complete immediately. For example,
if an event handler sets \fIvarName\fR and then itself calls
\fBvwait\fR to wait for a different variable, then it may not return
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index c8fe92e..183ac82 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -50,6 +50,19 @@ typedef struct {
} ErrAssocData;
/*
+ * For each "vwait" event source a structure of the following type
+ * is used:
+ */
+
+typedef struct {
+ int *donePtr; /* Pointer to flag to signal or NULL. */
+ int sequence; /* Order of occurrence. */
+ int mask; /* 0, or TCL_READABLE/TCL_WRITABLE. */
+ Tcl_Obj *sourceObj; /* Name of the event source, either a
+ * variable name or channel name. */
+} VwaitItem;
+
+/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
@@ -116,6 +129,9 @@ static Tcl_ThreadCreateType NewThreadProc(void *clientData);
static void BgErrorDeleteProc(void *clientData,
Tcl_Interp *interp);
static void HandleBgErrors(void *clientData);
+static void VwaitChannelReadProc(void *clientData, int mask);
+static void VwaitChannelWriteProc(void *clientData, int mask);
+static void VwaitTimeoutProc(void *clientData);
static char * VwaitVarProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
@@ -1487,73 +1503,430 @@ Tcl_VwaitObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int done, foundEvent;
- const char *nameString;
+ int i, done = 0, timedOut = 0, foundEvent, any = 1, timeout = 0;
+ int numItems = 0, extended = 0, result, mode, mask = TCL_ALL_EVENTS;
+ Tcl_InterpState saved = NULL;
+ Tcl_TimerToken timer = NULL;
+ Tcl_Time before, after;
+ Tcl_Channel chan;
+ Tcl_WideInt diff = -1;
+ VwaitItem localItems[32], *vwaitItems = localItems;
+ static const char *const options[] = {
+ "-all", "-extended", "-nofileevents", "-noidleevents",
+ "-notimerevents", "-nowindowevents", "-readable",
+ "-timeout", "-variable", "-writable", "--", NULL
+ };
+ enum options {
+ OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS,
+ OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE,
+ OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST
+ } index;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name");
- return TCL_ERROR;
+ if ((objc == 2) && (strcmp(Tcl_GetString(objv[1]), "--") != 0)) {
+ /*
+ * Legacy "vwait" syntax, skip option handling.
+ */
+ i = 1;
+ goto endOfOptionLoop;
}
- nameString = Tcl_GetString(objv[1]);
- if (Tcl_TraceVar2(interp, nameString, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, &done) != TCL_OK) {
- return TCL_ERROR;
- };
- done = 0;
+
+ if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) {
+ vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1));
+ }
+
+ for (i = 1; i < objc; i++) {
+ const char *name;
+
+ name = TclGetString(objv[i]);
+ if (name[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ switch (index) {
+ case OPT_ALL:
+ any = 0;
+ break;
+ case OPT_EXTD:
+ extended = 1;
+ break;
+ case OPT_NO_FEVTS:
+ mask &= ~TCL_FILE_EVENTS;
+ break;
+ case OPT_NO_IEVTS:
+ mask &= ~TCL_IDLE_EVENTS;
+ break;
+ case OPT_NO_TEVTS:
+ mask &= ~TCL_TIMER_EVENTS;
+ break;
+ case OPT_NO_WEVTS:
+ mask &= ~TCL_WINDOW_EVENTS;
+ break;
+ case OPT_TIMEOUT:
+ if (++i >= objc) {
+ needArg:
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "argument required for \"%s\"", options[index]));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i], &timeout) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (timeout < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "timeout must be positive", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NEGTIME", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ break;
+ case OPT_LAST:
+ i++;
+ goto endOfOptionLoop;
+ case OPT_VARIABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[numItems]);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ case OPT_READABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!(mode & TCL_READABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't open for reading",
+ TclGetString(objv[i])));
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_CreateChannelHandler(chan, TCL_READABLE,
+ VwaitChannelReadProc, &vwaitItems[numItems]);
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = TCL_READABLE;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ case OPT_WRITABLE:
+ if (++i >= objc) {
+ goto needArg;
+ }
+ if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (!(mode & TCL_WRITABLE)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "channel \"%s\" wasn't open for writing",
+ TclGetString(objv[i])));
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_CreateChannelHandler(chan, TCL_WRITABLE,
+ VwaitChannelWriteProc, &vwaitItems[numItems]);
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = TCL_WRITABLE;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ break;
+ }
+ }
+
+ endOfOptionLoop:
+ if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS |
+ TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't wait: would block forever", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if ((timeout > 0) && ((mask & TCL_TIMER_EVENTS) == 0)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "timer events disabled with timeout specified", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_TIME", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ for (result = TCL_OK; i < objc; i++) {
+ result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[numItems]);
+ if (result != TCL_OK) {
+ break;
+ }
+ vwaitItems[numItems].donePtr = &done;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = objv[i];
+ numItems++;
+ }
+ if (result != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ if (!(mask & TCL_FILE_EVENTS)) {
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].mask) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "file events disabled with channel(s) specified", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_FILE_EVENT", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ if (timeout > 0) {
+ vwaitItems[numItems].donePtr = &timedOut;
+ vwaitItems[numItems].sequence = -1;
+ vwaitItems[numItems].mask = 0;
+ vwaitItems[numItems].sourceObj = NULL;
+ timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc,
+ &vwaitItems[numItems]);
+ Tcl_GetTime(&before);
+ } else {
+ timeout = 0;
+ }
+
+ if ((numItems == 0) && (timeout == 0)) {
+ /*
+ * "vwait" is equivalent to "update",
+ * "vwait -nofileevents -notimerevents -nowindowevents"
+ * is equivalent to "update idletasks"
+ */
+ any = 1;
+ mask |= TCL_DONT_WAIT;
+ }
+
foundEvent = 1;
- while (!done && foundEvent) {
- foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ while (!timedOut && foundEvent &&
+ ((!any && (done < numItems)) || (any && !done))) {
+ foundEvent = Tcl_DoOneEvent(mask);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "EVENT", "LIMIT", NULL);
break;
}
+ if ((numItems == 0) && (timeout == 0)) {
+ /*
+ * Behavior like "update": clear interpreter's result because
+ * event handlers could have executed commands.
+ */
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ goto done;
+ }
}
- Tcl_UntraceVar2(interp, nameString, NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- VwaitVarProc, &done);
if (!foundEvent) {
Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't wait for variable \"%s\": would wait forever",
- nameString));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj((numItems == 0) ?
+ "can't wait: would wait forever" :
+ "can't wait for variable(s)/channel(s): would wait forever",
+ -1));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
- if (!done) {
+
+ if (!done && !timedOut) {
/*
* The interpreter's result was already set to the right error message
* prior to exiting the loop above.
*/
+ result = TCL_ERROR;
+ goto done;
+ }
- return TCL_ERROR;
+ result = TCL_OK;
+ if (timeout <= 0) {
+ /*
+ * Clear out the interpreter's result, since it may have been set
+ * by event handlers.
+ */
+ Tcl_ResetResult(interp);
+ goto done;
}
/*
- * Clear out the interpreter's result, since it may have been set by event
- * handlers.
+ * When timeout was specified, report milliseconds left or -1 on timeout.
*/
+ if (timedOut) {
+ diff = -1;
+ } else {
+ Tcl_GetTime(&after);
+ diff = after.sec * 1000 + after.usec / 1000;
+ diff -= before.sec * 1000 + before.usec / 1000;
+ diff = timeout - diff;
+ if (diff < 0) {
+ diff = 0;
+ }
+ }
- Tcl_ResetResult(interp);
- return TCL_OK;
+ done:
+ if ((timeout > 0) && (timer != NULL)) {
+ Tcl_DeleteTimerHandler(timer);
+ }
+ if (result != TCL_OK) {
+ saved = Tcl_SaveInterpState(interp, result);
+ }
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].mask & TCL_READABLE) {
+ if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+ &chan, &mode, 0) == TCL_OK) {
+ Tcl_DeleteChannelHandler(chan, VwaitChannelReadProc,
+ &vwaitItems[i]);
+ }
+ } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+ if (TclGetChannelFromObj(interp, vwaitItems[i].sourceObj,
+ &chan, &mode, 0) == TCL_OK) {
+ Tcl_DeleteChannelHandler(chan, VwaitChannelWriteProc,
+ &vwaitItems[i]);
+ }
+ } else {
+ Tcl_UntraceVar2(interp, TclGetString(vwaitItems[i].sourceObj),
+ NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, &vwaitItems[i]);
+ }
+ }
+
+ if (result == TCL_OK) {
+ if (extended) {
+ int k;
+ Tcl_Obj *listObj, *keyObj;
+
+ TclNewObj(listObj);
+ for (k = 0; k < done; k++) {
+ for (i = 0; i < numItems; i++) {
+ if (vwaitItems[i].sequence != k) {
+ continue;
+ }
+ if (vwaitItems[i].mask & TCL_READABLE) {
+ TclNewLiteralStringObj(keyObj, "readable");
+ } else if (vwaitItems[i].mask & TCL_WRITABLE) {
+ TclNewLiteralStringObj(keyObj, "writable");
+ } else {
+ TclNewLiteralStringObj(keyObj, "variable");
+ }
+ Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+ Tcl_ListObjAppendElement(NULL, listObj,
+ vwaitItems[i].sourceObj);
+ }
+ }
+ if (timeout > 0) {
+ TclNewLiteralStringObj(keyObj, "timeleft");
+ Tcl_ListObjAppendElement(NULL, listObj, keyObj);
+ Tcl_ListObjAppendElement(NULL, listObj,
+ Tcl_NewWideIntObj(diff));
+ }
+ Tcl_SetObjResult(interp, listObj);
+ } else if (timeout > 0) {
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(diff));
+ }
+ } else {
+ result = Tcl_RestoreInterpState(interp, saved);
+ }
+ if (vwaitItems != localItems) {
+ ckfree(vwaitItems);
+ }
+ return result;
+}
+
+static void
+VwaitChannelReadProc(
+ void *clientData, /* Pointer to vwait info record. */
+ int mask) /* Event mask, must be TCL_READABLE. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (!(mask & TCL_READABLE)) {
+ return;
+ }
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
+}
+
+static void
+VwaitChannelWriteProc(
+ void *clientData, /* Pointer to vwait info record. */
+ int mask) /* Event mask, must be TCL_WRITABLE. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (!(mask & TCL_WRITABLE)) {
+ return;
+ }
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
+}
+
+static void
+VwaitTimeoutProc(
+ void *clientData) /* Pointer to vwait info record. */
+{
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
+
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->donePtr[0] = 1;
+ itemPtr->donePtr = NULL;
+ }
}
static char *
VwaitVarProc(
- void *clientData, /* Pointer to integer to set to 1. */
+ void *clientData, /* Pointer to vwait info record. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
TCL_UNUSED(int) /*flags*/) /* Information about what happened. */
{
- int *donePtr = (int *)clientData;
+ VwaitItem *itemPtr = (VwaitItem *) clientData;
- *donePtr = 1;
+ if (itemPtr->donePtr != NULL) {
+ itemPtr->sequence = itemPtr->donePtr[0];
+ itemPtr->donePtr[0] += 1;
+ itemPtr->donePtr = NULL;
+ }
Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 8d9ef6c..d16a74c 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -24,23 +24,9 @@ scspec EXTERN
# Use at your own risk. Note that the position of functions should not
# be changed between versions to avoid gratuitous incompatibilities.
-# Replaced by Tcl_FSAccess in 8.4:
-#declare 0 {
-# int TclAccess(const char *path, int mode)
-#}
-#declare 1 {
-# int TclAccessDeleteProc(TclAccessProc_ *proc)
-#}
-#declare 2 {
-# int TclAccessInsertProc(TclAccessProc_ *proc)
-#}
declare 3 {
void TclAllocateFreeObjects(void)
}
-# Replaced by TclpChdir in 8.1:
-# declare 4 {
-# int TclChdir(Tcl_Interp *interp, char *dirName)
-# }
declare 5 {
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
@@ -74,37 +60,12 @@ declare 11 {
declare 12 {
void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr)
}
-# Removed in 8.5:
-#declare 13 {
-# int TclDoGlob(Tcl_Interp *interp, char *separators,
-# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
-#}
declare 14 {
int TclDumpMemoryInfo(void *clientData, int flags)
}
-# Removed in 8.1:
-# declare 15 {
-# void TclExpandParseValue(ParseValue *pvPtr, int needed)
-# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-# Removed in 8.4:
-#declare 17 {
-# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
-#}
-#declare 18 {
-# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 19 {
-# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 20 {
-# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 21 {
-# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
-#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
@@ -120,27 +81,9 @@ declare 24 {
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
-# Removed in 8.1:
-# declare 26 {
-# char *TclGetCwd(Tcl_Interp *interp)
-# }
-# Removed in 8.5:
-#declare 27 {
-# int TclGetDate(char *p, unsigned long now, long zone,
-# unsigned long *timePtr)
-#}
declare 28 {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
-# Removed in 8.4b2:
-#declare 29 {
-# Tcl_Obj *TclGetElementOfIndexedArray(Tcl_Interp *interp,
-# int localIndex, Tcl_Obj *elemPtr, int flags)
-#}
-# Replaced by char *TclGetEnv(const char *name, Tcl_DString *valuePtr) in 8.1:
-# declare 30 {
-# char *TclGetEnv(const char *name)
-# }
declare 31 {
const char *TclGetExtension(const char *name)
}
@@ -148,23 +91,10 @@ declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
-# Removed in 8.5:
-#declare 33 {
-# Tcl_CmdProc *TclGetInterpProc(void)
-#}
declare 34 {deprecated {Use Tcl_GetIntForIndex}} {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
-# Removed in 8.4b2:
-#declare 35 {
-# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
-# int flags)
-#}
-# Removed in 8.6a2:
-#declare 36 {
-# int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr)
-#}
declare 37 {
int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
}
@@ -186,11 +116,9 @@ declare 41 {
declare 42 {
const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
-# Removed in 8.5a2:
-#declare 43 {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
-# int flags)
-#}
+declare 43 {
+ Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void)
+}
declare 44 {
int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
}
@@ -200,20 +128,6 @@ declare 45 {
declare 46 {
int TclInExit(void)
}
-# Removed in 8.4b2:
-#declare 47 {
-# Tcl_Obj *TclIncrElementOfIndexedArray(Tcl_Interp *interp,
-# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
-#}
-# Removed in 8.4b2:
-#declare 48 {
-# Tcl_Obj *TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
-# long incrAmount)
-#}
-#declare 49 {
-# Tcl_Obj *TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
-# Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
-#}
declare 50 {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
@@ -221,11 +135,6 @@ declare 50 {
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
-# Removed in 8.5a2:
-#declare 52 {
-# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
-# int flags)
-#}
declare 53 {
int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp,
int argc, const char **argv)
@@ -237,26 +146,11 @@ declare 54 {
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
-# Replaced with TclpLoadFile in 8.1:
-# declare 56 {
-# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
-# char *sym2, Tcl_LibraryInitProc **proc1Ptr,
-# Tcl_LibraryInitProc **proc2Ptr)
-# }
-# Signature changed to take a length in 8.1:
-# declare 57 {
-# int TclLooksLikeInt(char *p)
-# }
declare 58 {
Var *TclLookupVar(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, const char *msg, int createPart1, int createPart2,
Var **arrayPtrPtr)
}
-# Replaced by Tcl_FSMatchInDirectory in 8.4
-#declare 59 {
-# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
-# Tcl_DString *dirPtr, char *pattern, char *tail)
-#}
declare 60 {
int TclNeedSpace(const char *start, const char *end)
}
@@ -274,37 +168,9 @@ declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
-# Removed in 8.5a2:
-#declare 65 {
-# int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
-# Tcl_Obj *const objv[], int flags)
-#}
-#declare 66 {
-# int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc)
-#}
-#declare 67 {
-# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
-#}
-# Replaced by Tcl_FSAccess in 8.4:
-#declare 68 {
-# int TclpAccess(const char *path, int mode)
-#}
declare 69 {
void *TclpAlloc(unsigned int size)
}
-#declare 70 {
-# int TclpCopyFile(const char *source, const char *dest)
-#}
-#declare 71 {
-# int TclpCopyDirectory(const char *source, const char *dest,
-# Tcl_DString *errorPtr)
-#}
-#declare 72 {
-# int TclpCreateDirectory(const char *path)
-#}
-#declare 73 {
-# int TclpDeleteFile(const char *path)
-#}
declare 74 {
void TclpFree(void *ptr)
}
@@ -317,45 +183,9 @@ declare 76 {
declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
-# Removed in 8.6:
-#declare 78 {
-# int TclpGetTimeZone(unsigned long time)
-#}
-# Replaced by Tcl_FSListVolumes in 8.4:
-#declare 79 {
-# int TclpListVolumes(Tcl_Interp *interp)
-#}
-# Replaced by Tcl_FSOpenFileChannel in 8.4:
-#declare 80 {
-# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
-# char *modeString, int permissions)
-#}
declare 81 {
void *TclpRealloc(void *ptr, unsigned int size)
}
-#declare 82 {
-# int TclpRemoveDirectory(const char *path, int recursive,
-# Tcl_DString *errorPtr)
-#}
-#declare 83 {
-# int TclpRenameFile(const char *source, const char *dest)
-#}
-# Removed in 8.1:
-# declare 84 {
-# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr,
-# ParseValue *pvPtr)
-# }
-# declare 85 {
-# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags,
-# char **termPtr, ParseValue *pvPtr)
-# }
-# declare 86 {
-# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
-# int flags, char **termPtr, ParseValue *pvPtr)
-# }
-# declare 87 {
-# void TclPlatformInit(Tcl_Interp *interp)
-# }
declare 88 {deprecated {}} {
char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags)
@@ -364,10 +194,6 @@ declare 89 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
-# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
-# declare 90 {
-# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
-# }
declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
@@ -379,15 +205,6 @@ declare 92 {
declare 93 {
void TclProcDeleteProc(void *clientData)
}
-# Removed in 8.5:
-#declare 94 {
-# int TclProcInterpProc(void *clientData, Tcl_Interp *interp,
-# int argc, const char **argv)
-#}
-# Replaced by Tcl_FSStat in 8.4:
-#declare 95 {
-# int TclpStat(const char *path, Tcl_StatBuf *buf)
-#}
declare 96 {
int TclRenameCommand(Tcl_Interp *interp, const char *oldName,
const char *newName)
@@ -398,16 +215,6 @@ declare 97 {
declare 98 {
int TclServiceIdle(void)
}
-# Removed in 8.4b2:
-#declare 99 {
-# Tcl_Obj *TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
-# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
-#}
-# Removed in 8.4b2:
-#declare 100 {
-# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
-# Tcl_Obj *objPtr, int flags)
-#}
declare 101 {
const char *TclSetPreInitScript(const char *string)
}
@@ -421,16 +228,6 @@ declare 103 {
declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
-# Replaced by Tcl_FSStat in 8.4:
-#declare 105 {
-# int TclStat(const char *path, Tcl_StatBuf *buf)
-#}
-#declare 106 {
-# int TclStatDeleteProc(TclStatProc_ *proc)
-#}
-#declare 107 {
-# int TclStatInsertProc(TclStatProc_ *proc)
-#}
declare 108 {
void TclTeardownNamespace(Namespace *nsPtr)
}
@@ -440,10 +237,6 @@ declare 109 {
declare 110 {
int TclSockMinimumBuffers(void *sock, int size)
}
-# Removed in 8.1:
-# declare 110 {
-# char *TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
-# }
# Procedures used in conjunction with Tcl namespaces. They are
# defined here instead of in tcl.decls since they are not stable yet.
@@ -534,31 +327,9 @@ declare 132 {
declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
-# Removed in 8.5
-#declare 134 {
-# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
-# const struct tm *t, int useGMT)
-#}
-#declare 135 {
-# int TclpCheckStackSpace(void)
-#}
-
-# Added in 8.1:
-
-#declare 137 {
-# int TclpChdir(const char *dirName)
-#}
declare 138 {
const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
-#declare 139 {
-# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
-# char *sym2, Tcl_LibraryInitProc **proc1Ptr,
-# Tcl_LibraryInitProc **proc2Ptr, void **clientDataPtr)
-#}
-#declare 140 {
-# int TclLooksLikeInt(const char *bytes, int length)
-#}
# This is used by TclX, but should otherwise be considered private
declare 141 {
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
@@ -590,9 +361,6 @@ declare 148 {
declare 149 {
void TclHandleRelease(TclHandle handle)
}
-
-# Added for Tcl 8.2
-
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
@@ -606,17 +374,6 @@ declare 152 {
declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
-
-# moved to tclTest.c (static) in 8.3.2/8.4a2
-#declare 154 {
-# int TclTestChannelCmd(void *clientData,
-# Tcl_Interp *interp, int argc, char **argv)
-#}
-#declare 155 {
-# int TclTestChannelEventCmd(void *clientData,
-# Tcl_Interp *interp, int argc, char **argv)
-#}
-
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
@@ -630,13 +387,7 @@ declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
const char *TclGetStartupScriptFileName(void)
}
-#declare 160 {
-# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
-# Tcl_DString *dirPtr, char *pattern, char *tail,
-# GlobTypeData *types)
-#}
-# new in 8.3.2/8.4a2
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
@@ -696,23 +447,10 @@ declare 171 {
declare 172 {
int TclInThreadExit(void)
}
-
-# added for 8.4.2
-
declare 173 {
int TclUniCharMatch(const Tcl_UniChar *string, int strLen,
const Tcl_UniChar *pattern, int ptnLen, int flags)
}
-
-# added for 8.4.3
-
-#declare 174 {
-# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
-# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
-#}
-
-# Factoring out of trace code
-
declare 175 {
int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr,
const char *part1, const char *part2, int flags, int leaveErrMsg)
@@ -730,17 +468,6 @@ declare 178 {
declare 179 {
Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
-
-# REMOVED
-# Allocate lists without copying arrays
-# declare 180 {
-# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
-# }
-#declare 181 {
-# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
-# const char *file, int line)
-#}
-
declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
@@ -750,66 +477,10 @@ declare 183 {deprecated {}} {
# For the new "Thread Storage" subsystem.
-### REMOVED on grounds it should never have been exposed. All these
-### functions are now either static in tclThreadStorage.c or
-### MODULE_SCOPE.
-# declare 184 {
-# void TclThreadStorageLockInit(void)
-# }
-# declare 185 {
-# void TclThreadStorageLock(void)
-# }
-# declare 186 {
-# void TclThreadStorageUnlock(void)
-# }
-# declare 187 {
-# void TclThreadStoragePrint(FILE *outFile, int flags)
-# }
-# declare 188 {
-# Tcl_HashTable *TclThreadStorageGetHashTable(Tcl_ThreadId id)
-# }
-# declare 189 {
-# Tcl_HashTable *TclThreadStorageInit(Tcl_ThreadId id, void *reserved)
-# }
-# declare 190 {
-# void TclThreadStorageDataKeyInit(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 191 {
-# void *TclThreadStorageDataKeyGet(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 192 {
-# void TclThreadStorageDataKeySet(Tcl_ThreadDataKey *keyPtr, void *data)
-# }
-# declare 193 {
-# void TclFinalizeThreadStorageThread(Tcl_ThreadId id)
-# }
-# declare 194 {
-# void TclFinalizeThreadStorage(void)
-# }
-# declare 195 {
-# void TclFinalizeThreadStorageData(Tcl_ThreadDataKey *keyPtr)
-# }
-# declare 196 {
-# void TclFinalizeThreadStorageDataKey(Tcl_ThreadDataKey *keyPtr)
-# }
-
-#
-# Added in tcl8.5a5 for compiler/executor experimentation.
-# Disabled in Tcl 8.5.1; experiments terminated. :/
-#
-#declare 197 {
-# int TclCompEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
-# const CmdFrame *invoker, int word)
-#}
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
}
-
-#declare 199 {
-# int TclMatchIsTrivial(const char *pattern)
-#}
-
# 200-208 exported for use by the test suite [Bug 1054748]
declare 200 {
int TclpObjRemoveDirectory(Tcl_Obj *pathPtr, int recursive,
@@ -878,8 +549,6 @@ declare 218 {
declare 224 {
TclPlatformType *TclGetPlatform(void)
}
-
-#
declare 225 {
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
@@ -891,12 +560,6 @@ declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
-# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
-# core and NRE-enabled
-# declare 228 {
-# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
-# int skip, ProcErrorProc *errorProc)
-# }
declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
const char *myName, int myFlags, int index)
@@ -1025,7 +688,6 @@ declare 256 {
int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags)
}
-
declare 257 {
void TclStaticLibrary(Tcl_Interp *interp, const char *prefix,
Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc)
@@ -1074,14 +736,9 @@ declare 3 win {
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 5 win {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
-# Removed in 8.1:
-# declare 5 win {
-# HINSTANCE TclWinLoadLibrary(char *name)
-# }
declare 6 win {
unsigned short TclWinNToHS(unsigned short ns)
}
@@ -1095,14 +752,9 @@ declare 8 win {
declare 9 win {
int TclWinGetPlatformId(void)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(TclDIR *dir)
}
-# Removed in 8.3.1 (for Win32s only):
-#declare 10 win {
-# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
-#}
# Pipe channel functions
@@ -1124,18 +776,9 @@ declare 15 win {
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
-# new for 8.4.20+/8.5.12+ Cygwin only
declare 16 win {
int TclpIsAtty(int fd)
}
-# Signature changed in 8.1:
-# declare 16 win {
-# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
-# }
-# declare 17 win {
-# char *TclpGetTZName(void)
-# }
-# new for 8.5.12+ Cygwin only
declare 17 win {
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
@@ -1152,38 +795,18 @@ declare 20 win {
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
-# removed permanently for 8.4
-#declare 21 win {
-# void TclpAsyncMark(Tcl_AsyncHandler async)
-#}
-
-# Added in 8.1:
declare 22 win {
TclFile TclpCreateTempFile(const char *contents)
}
-# Removed in 8.6:
-#declare 23 win {
-# char *TclpGetTZName(int isdst)
-#}
declare 24 win {
char *TclWinNoBackslash(char *path)
}
-# replaced by generic TclGetPlatform
-#declare 25 win {
-# TclPlatformType *TclWinGetPlatform(void)
-#}
declare 26 win {
void TclWinSetInterfaces(int wide)
}
-
-# Added in Tcl 8.3.3 / 8.4
-
declare 27 win {
void TclWinFlushDirtyChannels(void)
}
-
-# Added in 8.4.2
-
declare 28 win {
void TclWinResetInterfaces(void)
}
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 588a1fa..ec9023f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -155,7 +155,8 @@ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command);
/* 42 */
EXTERN const char * TclpGetUserHome(const char *name,
Tcl_DString *bufferPtr);
-/* Slot 43 is reserved */
+/* 43 */
+EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void);
/* 44 */
EXTERN int TclGuessPackageName(const char *fileName,
Tcl_DString *bufPtr);
@@ -711,7 +712,7 @@ typedef struct TclIntStubs {
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
- void (*reserved43)(void);
+ Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */
int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
@@ -1012,7 +1013,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
#define TclpGetUserHome \
(tclIntStubsPtr->tclpGetUserHome) /* 42 */
-/* Slot 43 is reserved */
+#define TclGetObjInterpProc2 \
+ (tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */
#define TclGuessPackageName \
(tclIntStubsPtr->tclGuessPackageName) /* 44 */
#define TclHideUnsafeCommands \
@@ -1420,6 +1422,7 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TclSetPreInitScript
#undef TclObjInterpProc
#define TclObjInterpProc TclGetObjInterpProc()
+#define TclObjInterpProc2 TclGetObjInterpProc2()
#ifndef TCL_NO_DEPRECATED
# define TclSetPreInitScript Tcl_SetPreInitScript
# define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0)
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 89c15b3..5034174 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -2630,6 +2630,27 @@ TclLindexFlat(
{
ListSizeT i;
+ /* Handle ArithSeries as special case */
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ ListSizeT index, listLen = TclArithSeriesObjLength(listObj);
+ Tcl_Obj *elemObj = NULL;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
+ &index) == TCL_OK) {
+ }
+ if (i==0) {
+ TclArithSeriesObjIndex(listObj, index, &elemObj);
+ Tcl_IncrRefCount(elemObj);
+ } else if (index > 0) {
+ Tcl_DecrRefCount(elemObj);
+ TclNewObj(elemObj);
+ Tcl_IncrRefCount(elemObj);
+ break;
+ }
+ }
+ return elemObj;
+ }
+
Tcl_IncrRefCount(listObj);
for (i=0 ; i<indexCount && listObj ; i++) {
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 059e751..f826a14 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1682,6 +1682,43 @@ TclNRInterpProc(
}
return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
}
+
+static int
+NRInterpProc2(
+ ClientData clientData, /* Record describing procedure to be
+ * interpreted. */
+ Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ size_t objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ int result = TclPushProcCallFrame(clientData, interp, objc, objv,
+ /*isLambda*/ 0);
+
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError);
+}
+
+static int
+ObjInterpProc2(
+ ClientData clientData, /* Record describing procedure to be
+ * interpreted. */
+ Tcl_Interp *interp,/* Interpreter in which procedure was
+ * invoked. */
+ size_t objc, /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *const objv[]) /* Argument value objects. */
+{
+ /*
+ * Not used much in the core; external interface for iTcl
+ */
+
+ return Tcl_NRCallObjProc2(interp, NRInterpProc2, clientData, objc, objv);
+}
+
/*
*----------------------------------------------------------------------
@@ -2273,12 +2310,12 @@ TclUpdateReturnInfo(
/*
*----------------------------------------------------------------------
*
- * TclGetObjInterpProc --
+ * TclGetObjInterpProc/TclGetObjInterpProc2 --
*
- * Returns a pointer to the TclObjInterpProc function; this is different
- * from the value obtained from the TclObjInterpProc reference on systems
- * like Windows where import and export versions of a function exported
- * by a DLL exist.
+ * Returns a pointer to the TclObjInterpProc/ObjInterpProc2 functions;
+ * this is different from the value obtained from the TclObjInterpProc
+ * reference on systems like Windows where import and export versions
+ * of a function exported by a DLL exist.
*
* Results:
* Returns the internal address of the TclObjInterpProc function.
@@ -2294,6 +2331,12 @@ TclGetObjInterpProc(void)
{
return TclObjInterpProc;
}
+
+Tcl_ObjCmdProc2 *
+TclGetObjInterpProc2(void)
+{
+ return ObjInterpProc2;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ae00b04..2abd2fb 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -903,7 +903,7 @@ static const TclIntStubs tclIntStubs = {
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
- 0, /* 43 */
+ TclGetObjInterpProc2, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
diff --git a/tests/event.test b/tests/event.test
index 3f9735a..16cbc24 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -509,12 +509,9 @@ test event-10.1 {Tcl_Exit procedure} {stdio} {
[lindex $::errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}
-test event-11.1 {Tcl_VwaitCmd procedure} -returnCodes error -body {
+test event-11.1 {Tcl_VwaitCmd procedure} -body {
vwait
-} -result {wrong # args: should be "vwait name"}
-test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
- vwait a b
-} -result {wrong # args: should be "vwait name"}
+} -result {}
test event-11.3 {Tcl_VwaitCmd procedure} -setup {
catch {unset x}
} -body {
generated by cgit v0.12 at 2025-12-25 14:43:45 (GMT)