summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls16
-rwxr-xr-xgeneric/tclArithSeries.c952
-rw-r--r--generic/tclArithSeries.h54
-rw-r--r--generic/tclBasic.c1
-rw-r--r--generic/tclCmdAH.c109
-rw-r--r--generic/tclCmdIL.c507
-rw-r--r--generic/tclCmdMZ.c8
-rw-r--r--generic/tclDecls.h30
-rw-r--r--generic/tclEvent.c433
-rw-r--r--generic/tclExecute.c55
-rw-r--r--generic/tclIO.c52
-rw-r--r--generic/tclIO.h2
-rw-r--r--generic/tclInt.decls130
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclIntDecls.h9
-rw-r--r--generic/tclInterp.c6
-rw-r--r--generic/tclListObj.c68
-rw-r--r--generic/tclProc.c63
-rw-r--r--generic/tclStringObj.c4
-rw-r--r--generic/tclStubInit.c7
-rw-r--r--generic/tclTest.c48
-rw-r--r--generic/tclTomMath.decls10
22 files changed, 2457 insertions, 112 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 15025f7..6f24f38 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -702,9 +702,10 @@ declare 187 {
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode)
}
-declare 190 {
- int Tcl_MakeSafe(Tcl_Interp *interp)
-}
+# Removed in 9.0
+#declare 190 {
+# int Tcl_MakeSafe(Tcl_Interp *interp)
+#}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket)
}
@@ -2560,6 +2561,8 @@ declare 673 {
int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index)
}
+# slot 674 and 675 are reserved for TIP #618
+
declare 676 {
Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp,
const char *cmdName,
@@ -2582,6 +2585,13 @@ declare 679 {
void *clientData, size_t objc, Tcl_Obj *const objv[])
}
+# slot 680 and 681 are reserved for TIP #638
+
+# TIP #220.
+declare 682 {
+ int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode)
+}
+
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
new file mode 100755
index 0000000..97a0a64
--- /dev/null
+++ b/generic/tclArithSeries.c
@@ -0,0 +1,952 @@
+/*
+ * tclArithSeries.c --
+ *
+ * This file contains the ArithSeries concrete abstract list
+ * implementation. It implements the inner workings of the lseq command.
+ *
+ * Copyright © 2022 Brian S. Griffin.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclArithSeries.h"
+#include <assert.h>
+
+/* -------------------------- ArithSeries object ---------------------------- */
+
+
+#define ArithSeriesRepPtr(arithSeriesObjPtr) \
+ (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1)
+
+#define ArithSeriesIndexM(arithSeriesRepPtr, index) \
+ ((arithSeriesRepPtr)->isDouble ? \
+ (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \
+ : \
+ ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step)))
+
+#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \
+ do { \
+ const Tcl_ObjInternalRep *irPtr; \
+ irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \
+ (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \
+ } while (0)
+
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr);
+static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfArithSeries (Tcl_Obj *listPtr);
+
+/*
+ * The structure below defines the arithmetic series Tcl object type by
+ * means of procedures that can be invoked by generic object code.
+ *
+ * The arithmetic series object is a special case of Tcl list representing
+ * an interval of an arithmetic series in constant space.
+ *
+ * The arithmetic series is internally represented with three integers,
+ * *start*, *end*, and *step*, Where the length is calculated with
+ * the following algorithm:
+ *
+ * if RANGE == 0 THEN
+ * ERROR
+ * if RANGE > 0
+ * LEN is (((END-START)-1)/STEP) + 1
+ * else if RANGE < 0
+ * LEN is (((END-START)-1)/STEP) - 1
+ *
+ * And where the equivalent's list I-th element is calculated
+ * as:
+ *
+ * LIST[i] = START+(STEP*i)
+ *
+ * Zero elements ranges, like in the case of START=10 END=10 STEP=1
+ * are valid and will be equivalent to the empty list.
+ */
+
+const Tcl_ObjType tclArithSeriesType = {
+ "arithseries", /* name */
+ FreeArithSeriesInternalRep, /* freeIntRepProc */
+ DupArithSeriesInternalRep, /* dupIntRepProc */
+ UpdateStringOfArithSeries, /* updateStringProc */
+ SetArithSeriesFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ArithSeriesLen --
+ *
+ * Compute the length of the equivalent list where
+ * every element is generated starting from *start*,
+ * and adding *step* to generate every successive element
+ * that's < *end* for positive steps, or > *end* for negative
+ * steps.
+ *
+ * Results:
+ *
+ * The length of the list generated by the given range,
+ * that may be zero.
+ * The function returns -1 if the list is of length infinite.
+ *
+ * Side effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static Tcl_WideInt
+ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
+{
+ Tcl_WideInt len;
+
+ if (step == 0) return 0;
+ len = (step ? (1 + (((end-start))/step)) : 0);
+ return (len < 0) ? -1 : len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewArithSeriesInt --
+ *
+ * Creates a new ArithSeries object. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len)
+{
+ Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step));
+ Tcl_Obj *arithSeriesPtr;
+ ArithSeries *arithSeriesRepPtr;
+
+ TclNewObj(arithSeriesPtr);
+
+ if (length <= 0) {
+ return arithSeriesPtr;
+ }
+
+ arithSeriesRepPtr = (ArithSeries*) Tcl_Alloc(sizeof (ArithSeries));
+ arithSeriesRepPtr->isDouble = 0;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesPtr->typePtr = &tclArithSeriesType;
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesPtr);
+
+ return arithSeriesPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewArithSeriesDbl --
+ *
+ * Creates a new ArithSeries object with doubles. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len)
+{
+ Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step));
+ Tcl_Obj *arithSeriesPtr;
+ ArithSeriesDbl *arithSeriesRepPtr;
+
+ TclNewObj(arithSeriesPtr);
+
+ if (length <= 0) {
+ return arithSeriesPtr;
+ }
+
+ arithSeriesRepPtr = (ArithSeriesDbl*) Tcl_Alloc(sizeof (ArithSeriesDbl));
+ arithSeriesRepPtr->isDouble = 1;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesPtr->typePtr = &tclArithSeriesType;
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesPtr);
+
+ return arithSeriesPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * assignNumber --
+ *
+ * Create the appropriate Tcl_Obj value for the given numeric values.
+ * Used locally only for decoding [lseq] numeric arguments.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer.
+ * No assignment on error.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+static void
+assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj)
+{
+ union {
+ double d;
+ Tcl_WideInt i;
+ } *number;
+ int tcl_number_type;
+
+ if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) {
+ return;
+ }
+ if (useDoubles) {
+ if (tcl_number_type == TCL_NUMBER_DOUBLE) {
+ *dblNumberPtr = number->d;
+ } else {
+ *dblNumberPtr = (double)number->i;
+ }
+ } else {
+ if (tcl_number_type == TCL_NUMBER_INT) {
+ *intNumberPtr = number->i;
+ } else {
+ *intNumberPtr = (Tcl_WideInt)number->d;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNewArithSeriesObj --
+ *
+ * Creates a new ArithSeries object. Some arguments may be NULL and will
+ * be computed based on the other given arguments.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * An empty Tcl_Obj if the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj)
+{
+ double dstart, dend, dstep;
+ Tcl_WideInt start, end, step, len;
+
+ if (startObj) {
+ assignNumber(useDoubles, &start, &dstart, startObj);
+ } else {
+ start = 0;
+ dstart = start;
+ }
+ if (stepObj) {
+ assignNumber(useDoubles, &step, &dstep, stepObj);
+ if (useDoubles) {
+ step = dstep;
+ } else {
+ dstep = step;
+ }
+ if (dstep == 0) {
+ return Tcl_NewObj();
+ }
+ }
+ if (endObj) {
+ assignNumber(useDoubles, &end, &dend, endObj);
+ }
+ if (lenObj) {
+ Tcl_GetWideIntFromObj(NULL, lenObj, &len);
+ }
+
+ if (startObj && endObj) {
+ if (!stepObj) {
+ if (useDoubles) {
+ dstep = (dstart < dend) ? 1.0 : -1.0;
+ step = dstep;
+ } else {
+ step = (start < end) ? 1 : -1;
+ dstep = step;
+ }
+ }
+ assert(dstep!=0);
+ if (!lenObj) {
+ if (useDoubles) {
+ len = (dend - dstart + dstep)/dstep;
+ } else {
+ len = (end - start + step)/step;
+ }
+ }
+ }
+
+ if (!endObj) {
+ if (useDoubles) {
+ dend = dstart + (dstep * (len-1));
+ end = dend;
+ } else {
+ end = start + (step * (len-1));
+ dend = end;
+ }
+ }
+
+ if (useDoubles) {
+ return TclNewArithSeriesDbl(dstart, dend, dstep, len);
+ } else {
+ return TclNewArithSeriesInt(start, end, step, len);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjStep --
+ *
+ * Return a Tcl_Obj with the step value from the give ArithSeries Obj.
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+/*
+ * TclArithSeriesObjStep --
+ */
+int
+TclArithSeriesObjStep(
+ Tcl_Obj *arithSeriesPtr,
+ Tcl_Obj **stepObj)
+{
+ ArithSeries *arithSeriesRepPtr;
+
+ if (arithSeriesPtr->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr);
+ if (arithSeriesRepPtr->isDouble) {
+ *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
+ } else {
+ *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step);
+ }
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjIndex --
+ *
+ * Returns the element with the specified index in the list
+ * represented by the specified Arithmetic Sequence object.
+ * If the index is out of range, TCL_ERROR is returned,
+ * otherwise TCL_OK is returned and the integer value of the
+ * element is stored in *element.
+ *
+ * Results:
+ *
+ * TCL_OK on success, TCL_ERROR on index out of range.
+ *
+ * Side Effects:
+ *
+ * On success, the integer pointed by *element is modified.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj)
+{
+ ArithSeries *arithSeriesRepPtr;
+
+ if (arithSeriesPtr->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr);
+ if (index < 0 || index >= arithSeriesRepPtr->len) {
+ return TCL_ERROR;
+ }
+ /* List[i] = Start + (Step * index) */
+ if (arithSeriesRepPtr->isDouble) {
+ *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ } else {
+ *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjLength
+ *
+ * Returns the length of the arithmetic series.
+ *
+ * Results:
+ *
+ * The length of the series as Tcl_WideInt.
+ *
+ * Side Effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr)
+{
+ ArithSeries *arithSeriesRepPtr = (ArithSeries*)
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1;
+ return arithSeriesRepPtr->len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesInternalRep --
+ *
+ * Deallocate the storage associated with an arithseries object's
+ * internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees arithSeriesPtr's ArithSeries* internal representation and
+ * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1;
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i;
+ Tcl_Obj**elmts = arithSeriesRepPtr->elements;
+ for(i=0; i<arithSeriesRepPtr->len; i++) {
+ if (elmts[i]) {
+ Tcl_DecrRefCount(elmts[i]);
+ }
+ }
+ Tcl_Free((char *) arithSeriesRepPtr->elements);
+ }
+ Tcl_Free((char *) arithSeriesRepPtr);
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupArithSeriesInternalRep --
+ *
+ * Initialize the internal representation of a arithseries Tcl_Obj to a
+ * copy of the internal representation of an existing arithseries object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * We set "copyPtr"s internal rep to a pointer to a
+ * newly allocated ArithSeries structure.
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupArithSeriesInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ ArithSeries *srcArithSeriesRepPtr =
+ (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1;
+ ArithSeries *copyArithSeriesRepPtr;
+
+ /*
+ * Allocate a new ArithSeries structure. */
+
+ copyArithSeriesRepPtr = (ArithSeries*) Tcl_Alloc(sizeof(ArithSeries));
+ *copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
+ copyArithSeriesRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ copyPtr->typePtr = &tclArithSeriesType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfArithSeries --
+ *
+ * Update the string representation for an arithseries object.
+ * Note: This procedure does not invalidate an existing old string rep
+ * so storage will be lost if this has not already been done.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to a valid string that results from
+ * the list-to-string conversion. This string will be empty if the
+ * list has no elements. The list internal representation
+ * should not be NULL and we assume it is not NULL.
+ *
+ * Notes:
+ * At the cost of overallocation it's possible to estimate
+ * the length of the string representation and make this procedure
+ * much faster. Because the programmer shouldn't expect the
+ * string conversion of a big arithmetic sequence to be fast
+ * this version takes more care of space than time.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr)
+{
+ ArithSeries *arithSeriesRepPtr =
+ (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1;
+ char *elem, *p;
+ Tcl_Obj *elemObj;
+ Tcl_WideInt i;
+ Tcl_WideInt length = 0;
+ int slen;
+
+ /*
+ * Pass 1: estimate space.
+ */
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj);
+ elem = TclGetStringFromObj(elemObj, &slen);
+ Tcl_DecrRefCount(elemObj);
+ slen += 1; /* + 1 is for the space or the nul-term */
+ length += slen;
+ }
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesPtr, NULL, length);
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj);
+ elem = TclGetStringFromObj(elemObj, &slen);
+ strcpy(p, elem);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(elemObj);
+ }
+ if (length > 0) arithSeriesPtr->bytes[length-1] = '\0';
+ arithSeriesPtr->length = length-1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetArithSeriesFromAny --
+ *
+ * The Arithmetic Series object is just an way to optimize
+ * Lists space complexity, so no one should try to convert
+ * a string to an Arithmetic Series object.
+ *
+ * This function is here just to populate the Type structure.
+ *
+ * Results:
+ *
+ * The result is always TCL_ERROR. But see Side Effects.
+ *
+ * Side effects:
+ *
+ * Tcl Panic if called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetArithSeriesFromAny(
+ TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */
+ TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */
+{
+ Tcl_Panic("SetArithSeriesFromAny: should never be called");
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjCopy --
+ *
+ * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C
+ * level a counterpart of the [lrange $list 0 end] command, while using
+ * internals details to be as efficient as possible.
+ *
+ * Results:
+ *
+ * Normally returns a pointer to a new Tcl_Obj, that contains the same
+ * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a
+ * refCount of zero. If *arithSeriesPtr does not hold an arithSeries,
+ * NULL is returned, and if interp is non-NULL, an error message is
+ * recorded there.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjCopy(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *arithSeriesPtr) /* List object for which an element array is
+ * to be returned. */
+{
+ Tcl_Obj *copyPtr;
+ ArithSeries *arithSeriesRepPtr;
+
+ ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr);
+ if (NULL == arithSeriesRepPtr) {
+ if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) {
+ /* We know this is going to panic, but it's the message we want */
+ return NULL;
+ }
+ }
+
+ TclNewObj(copyPtr);
+ TclInvalidateStringRep(copyPtr);
+ DupArithSeriesInternalRep(arithSeriesPtr, copyPtr);
+ return copyPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjRange --
+ *
+ * Makes a slice of an ArithSeries value.
+ * *arithSeriesPtr must be known to be a valid list.
+ *
+ * Results:
+ * Returns a pointer to the sliced series.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ * ?The possible conversion of the object referenced by listPtr?
+ * ?to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjRange(
+ Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */
+ int fromIdx, /* Index of first element to include. */
+ int toIdx) /* Index of last element to include. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+
+ ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr);
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (fromIdx > toIdx) {
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+
+ TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj);
+ Tcl_IncrRefCount(startObj);
+ TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj);
+ Tcl_IncrRefCount(endObj);
+ TclArithSeriesObjStep(arithSeriesPtr, &stepObj);
+ Tcl_IncrRefCount(stepObj);
+
+ if (Tcl_IsShared(arithSeriesPtr) ||
+ ((arithSeriesPtr->refCount > 1))) {
+ Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble,
+ startObj, endObj, stepObj, NULL);
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+ return newSlicePtr;
+ }
+
+ /*
+ * In-place is possible.
+ */
+
+ /*
+ * Even if nothing below causes any changes, we still want the
+ * string-canonizing effect of [lrange 0 end].
+ */
+
+ TclInvalidateStringRep(arithSeriesPtr);
+
+ if (arithSeriesRepPtr->isDouble) {
+ ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesPtr;
+ double start, end, step;
+ Tcl_GetDoubleFromObj(NULL, startObj, &start);
+ Tcl_GetDoubleFromObj(NULL, endObj, &end);
+ Tcl_GetDoubleFromObj(NULL, stepObj, &step);
+ arithSeriesDblRepPtr->start = start;
+ arithSeriesDblRepPtr->end = end;
+ arithSeriesDblRepPtr->step = step;
+ arithSeriesDblRepPtr->len = (end-start+step)/step;
+ arithSeriesDblRepPtr->elements = NULL;
+
+ } else {
+ Tcl_WideInt start, end, step;
+ Tcl_GetWideIntFromObj(NULL, startObj, &start);
+ Tcl_GetWideIntFromObj(NULL, endObj, &end);
+ Tcl_GetWideIntFromObj(NULL, stepObj, &step);
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = (end-start+step)/step;
+ arithSeriesRepPtr->elements = NULL;
+ }
+
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+
+ return arithSeriesPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesGetElements --
+ *
+ * This function returns an (objc,objv) array of the elements in a list
+ * object.
+ *
+ * Results:
+ * The return value is normally TCL_OK; in this case *objcPtr is set to
+ * the count of list elements and *objvPtr is set to a pointer to an
+ * array of (*objcPtr) pointers to each list element. If listPtr does not
+ * refer to an Abstract List object and the object can not be converted
+ * to one, TCL_ERROR is returned and an error message will be left in the
+ * interpreter's result if interp is not NULL.
+ *
+ * The objects referenced by the returned array should be treated as
+ * readonly and their ref counts are _not_ incremented; the caller must
+ * do that if it holds on to a reference. Furthermore, the pointer and
+ * length returned by this function may change as soon as any function is
+ * called on the list object; be careful about retaining the pointer in a
+ * local data structure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclArithSeriesGetElements(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *objPtr, /* AbstractList object for which an element
+ * array is to be returned. */
+ size_t *objcPtr, /* Where to store the count of objects
+ * referenced by objv. */
+ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
+ * pointers to the list's objects. */
+{
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj **objv;
+ int i, objc;
+
+ ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr);
+ objc = arithSeriesRepPtr->len;
+ if (objc > 0) {
+ if (arithSeriesRepPtr->elements) {
+ /* If this exists, it has already been populated */
+ objv = arithSeriesRepPtr->elements;
+ } else {
+ /* Construct the elements array */
+ objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc);
+ if (objv == NULL) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ arithSeriesRepPtr->elements = objv;
+ for (i = 0; i < objc; i++) {
+ if (TclArithSeriesObjIndex(objPtr, i, &objv[i]) != TCL_OK) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("indexing error", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(objv[i]);
+ }
+ }
+ } else {
+ objv = NULL;
+ }
+ *objvPtr = objv;
+ *objcPtr = objc;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an arithseries"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjReverse --
+ *
+ * Reverse the order of the ArithSeries value.
+ * *arithSeriesPtr must be known to be a valid list.
+ *
+ * Results:
+ * Returns a pointer to the reordered series.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ * ?The possible conversion of the object referenced by listPtr?
+ * ?to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjReverse(
+ Tcl_Obj *arithSeriesPtr) /* List object to reverse. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+ Tcl_Obj *resultObj;
+ Tcl_WideInt start, end, step, len;
+ double dstart, dend, dstep;
+ int isDouble;
+
+ ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr);
+
+ isDouble = arithSeriesRepPtr->isDouble;
+ len = arithSeriesRepPtr->len;
+
+ TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj);
+ TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj);
+ TclArithSeriesObjStep(arithSeriesPtr, &stepObj);
+
+ if (isDouble) {
+ Tcl_GetDoubleFromObj(NULL, startObj, &dstart);
+ Tcl_GetDoubleFromObj(NULL, endObj, &dend);
+ Tcl_GetDoubleFromObj(NULL, stepObj, &dstep);
+ dstep = -dstep;
+ TclSetDoubleObj(stepObj, dstep);
+ } else {
+ Tcl_GetWideIntFromObj(NULL, startObj, &start);
+ Tcl_GetWideIntFromObj(NULL, endObj, &end);
+ Tcl_GetWideIntFromObj(NULL, stepObj, &step);
+ step = -step;
+ TclSetIntObj(stepObj, step);
+ }
+
+ if (Tcl_IsShared(arithSeriesPtr) ||
+ ((arithSeriesPtr->refCount > 1))) {
+ Tcl_Obj *lenObj = Tcl_NewWideIntObj(len);
+ resultObj = TclNewArithSeriesObj(isDouble,
+ startObj, endObj, stepObj, lenObj);
+ Tcl_DecrRefCount(lenObj);
+ } else {
+
+ /*
+ * In-place is possible.
+ */
+
+ TclInvalidateStringRep(arithSeriesPtr);
+
+ if (isDouble) {
+ ArithSeriesDbl *arithSeriesDblRepPtr =
+ (ArithSeriesDbl*)arithSeriesRepPtr;
+ arithSeriesDblRepPtr->start = dstart;
+ arithSeriesDblRepPtr->end = dend;
+ arithSeriesDblRepPtr->step = dstep;
+ } else {
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ }
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i;
+ for (i=0; i<len; i++) {
+ Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
+ }
+ Tcl_Free((char*)arithSeriesRepPtr->elements);
+ }
+ arithSeriesRepPtr->elements = NULL;
+
+ resultObj = arithSeriesPtr;
+ }
+
+ Tcl_DecrRefCount(startObj);
+ Tcl_DecrRefCount(endObj);
+ Tcl_DecrRefCount(stepObj);
+
+ return resultObj;
+}
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
new file mode 100644
index 0000000..c4bfbfe
--- /dev/null
+++ b/generic/tclArithSeries.h
@@ -0,0 +1,54 @@
+/*
+ * tclArithSeries.h --
+ *
+ * This file contains the ArithSeries concrete abstract list
+ * implementation. It implements the inner workings of the lseq command.
+ *
+ * Copyright © 2022 Brian S. Griffin.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+/*
+ * The structure used for the ArithSeries internal representation.
+ * Note that the len can in theory be always computed by start,end,step
+ * but it's faster to cache it inside the internal representation.
+ */
+typedef struct ArithSeries {
+ Tcl_WideInt start;
+ Tcl_WideInt end;
+ Tcl_WideInt step;
+ Tcl_WideInt len;
+ Tcl_Obj **elements;
+ int isDouble;
+} ArithSeries;
+typedef struct ArithSeriesDbl {
+ double start;
+ double end;
+ double step;
+ Tcl_WideInt len;
+ Tcl_Obj **elements;
+ int isDouble;
+} ArithSeriesDbl;
+
+
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr,
+ Tcl_Obj **stepObj);
+MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr,
+ Tcl_WideInt index, Tcl_Obj **elementObj);
+MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr,
+ int fromIdx, int toIdx);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, size_t *objcPtr, Tcl_Obj ***objvPtr);
+MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start,
+ Tcl_WideInt end, Tcl_WideInt step,
+ Tcl_WideInt len);
+MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end,
+ double step, Tcl_WideInt len);
+MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj,
+ Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj);
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index bac9b9a..787c52d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -309,6 +309,7 @@ static const CmdInfo builtInCmds[] = {
{"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
{"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
{"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index bf7a9cd..6a45a0b 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -15,6 +15,7 @@
#ifdef _WIN32
# include "tclWinInt.h"
#endif
+#include "tclArithSeries.h"
/*
* The state structure used by [foreach]. Note that the actual structure has
@@ -1265,14 +1266,18 @@ FileAttrLinkStatCmd(
{
Tcl_StatBuf buf;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- return StoreStatData(interp, objv[2], &buf);
+ if (objc == 2) {
+ return StoreStatData(interp, NULL, &buf);
+ } else {
+ return StoreStatData(interp, objv[2], &buf);
+ }
}
/*
@@ -1301,14 +1306,18 @@ FileAttrStatCmd(
{
Tcl_StatBuf buf;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "name varName");
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- return StoreStatData(interp, objv[2], &buf);
+ if (objc == 2) {
+ return StoreStatData(interp, NULL, &buf);
+ } else {
+ return StoreStatData(interp, objv[2], &buf);
+ }
}
/*
@@ -2208,7 +2217,7 @@ GetStatBuf(
*
* This is a utility procedure that breaks out the fields of a "stat"
* structure and stores them in textual form into the elements of an
- * associative array.
+ * associative array (if given) or returns a dictionary.
*
* Results:
* Returns a standard Tcl return value. If an error occurs then a message
@@ -2228,9 +2237,40 @@ StoreStatData(
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
- Tcl_Obj *field, *value;
+ Tcl_Obj *field, *value, *result;
unsigned short mode;
+ if (varName == NULL) {
+ result = Tcl_NewObj();
+ Tcl_IncrRefCount(result);
+#define DOBJPUT(key, objValue) \
+ Tcl_DictObjPut(NULL, result, \
+ Tcl_NewStringObj((key), -1), \
+ (objValue));
+ DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev));
+ DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
+ DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink));
+ DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid));
+ DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid));
+ DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
+#endif
+ DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
+ DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
+ DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
+ mode = (unsigned short) statPtr->st_mode;
+ DOBJPUT("mode", Tcl_NewWideIntObj(mode));
+ DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
+#undef DOBJPUT
+ Tcl_SetObjResult(interp, result);
+ Tcl_DecrRefCount(result);
+ return TCL_OK;
+ }
+
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*
@@ -2657,32 +2697,47 @@ EachloopCmd(
*/
for (i=0 ; i<numLists ; i++) {
+ /* List */
+ /* Variables */
statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]);
if (statePtr->vCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
TclListObjGetElementsM(NULL, statePtr->vCopyList[i],
- &statePtr->varcList[i], &statePtr->varvList[i]);
+ &statePtr->varcList[i], &statePtr->varvList[i]);
if (statePtr->varcList[i] < 1) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%s varlist is empty",
- (statePtr->resultList != NULL ? "lmap" : "foreach")));
+ "%s varlist is empty",
+ (statePtr->resultList != NULL ? "lmap" : "foreach")));
Tcl_SetErrorCode(interp, "TCL", "OPERATION",
- (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
- "NEEDVARS", NULL);
+ (statePtr->resultList != NULL ? "LMAP" : "FOREACH"),
+ "NEEDVARS", NULL);
result = TCL_ERROR;
goto done;
}
- statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
- if (statePtr->aCopyList[i] == NULL) {
- result = TCL_ERROR;
- goto done;
- }
- TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
+ /* Values */
+ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) {
+ /* Special case for Arith Series */
+ statePtr->vCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]);
+ if (statePtr->vCopyList[i] == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ /* Don't compute values here, wait until the last momement */
+ statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->vCopyList[i]);
+ } else {
+ /* List values */
+ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]);
+ if (statePtr->aCopyList[i] == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ TclListObjGetElementsM(NULL, statePtr->aCopyList[i],
&statePtr->argcList[i], &statePtr->argvList[i]);
-
+ }
+ /* account for variable <> value mismatch */
j = statePtr->argcList[i] / statePtr->varcList[i];
if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) {
j++;
@@ -2805,11 +2860,21 @@ ForeachAssignments(
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
+ int isarithseries = TclHasInternalRep(statePtr->vCopyList[i],&tclArithSeriesType);
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
-
if (k < statePtr->argcList[i]) {
- valuePtr = statePtr->argvList[i][k];
+ if (isarithseries) {
+ if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &valuePtr) != TCL_OK) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (setting %s loop variable \"%s\")",
+ (statePtr->resultList != NULL ? "lmap" : "foreach"),
+ TclGetString(statePtr->varvList[i][v])));
+ return TCL_ERROR;
+ }
+ } else {
+ valuePtr = statePtr->argvList[i][k];
+ }
} else {
TclNewObj(valuePtr); /* Empty string */
}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 031168f..64eb37c 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -19,6 +19,9 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include "tclArithSeries.h"
+#include <math.h>
+#include <assert.h>
/*
* During execution of the "lsort" command, structures of the following type
@@ -94,6 +97,23 @@ typedef struct {
#define SORTMODE_ASCII_NC 8
/*
+ * Definitions for [lseq] command
+ */
+static const char *const seq_operations[] = {
+ "..", "to", "count", "by", NULL
+};
+typedef enum Sequence_Operators {
+ LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY
+} SequenceOperators;
+static const char *const seq_step_keywords[] = {"by", NULL};
+typedef enum Step_Operators {
+ STEP_BY = 4
+} SequenceByMode;
+typedef enum Sequence_Decoded {
+ NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg
+} SequenceDecoded;
+
+/*
* Forward declarations for procedures defined in this file:
*/
@@ -2181,6 +2201,7 @@ Tcl_JoinObjCmd(
Tcl_Obj *const objv[]) /* The argument objects. */
{
size_t length, listLen;
+ int isArithSeries = 0;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
@@ -2193,9 +2214,14 @@ Tcl_JoinObjCmd(
* pointer to its array of element pointers.
*/
- if (TclListObjGetElementsM(interp, objv[1], &listLen,
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ isArithSeries = 1;
+ listLen = TclArithSeriesObjLength(objv[1]);
+ } else {
+ if (TclListObjGetElementsM(interp, objv[1], &listLen,
&elemPtrs) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_ERROR;
+ }
}
if (listLen == 0) {
@@ -2204,7 +2230,15 @@ Tcl_JoinObjCmd(
}
if (listLen == 1) {
/* One element; return it */
- Tcl_SetObjResult(interp, elemPtrs[0]);
+ if (isArithSeries) {
+ Tcl_Obj *valueObj;
+ if (TclArithSeriesObjIndex(objv[1], 0, &valueObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, valueObj);
+ } else {
+ Tcl_SetObjResult(interp, elemPtrs[0]);
+ }
return TCL_OK;
}
@@ -2218,19 +2252,41 @@ Tcl_JoinObjCmd(
size_t i;
resObjPtr = Tcl_NewObj();
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
+ if (isArithSeries) {
+ Tcl_Obj *valueObj;
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
+
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
+
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ if (TclArithSeriesObjIndex(objv[1], i, &valueObj) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_AppendObjToObj(resObjPtr, valueObj);
+ Tcl_DecrRefCount(valueObj);
+ }
+ } else {
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
- /*
- * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
- * to shimmer joinObjPtr. If it did, then the case where
- * objv[1] and objv[2] are the same value would not be safe.
- * Accessing elemPtrs would crash.
- */
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
- Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
- Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
}
Tcl_DecrRefCount(joinObjPtr);
@@ -2691,7 +2747,11 @@ Tcl_LrangeObjCmd(
return result;
}
- Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ Tcl_SetObjResult(interp, TclArithSeriesObjRange(objv[1], first, last));
+ } else {
+ Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last));
+ }
return TCL_OK;
}
@@ -3075,6 +3135,17 @@ Tcl_LreverseObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
}
+
+ /*
+ * Handle ArithSeries special case - don't shimmer a series into a list
+ * just to reverse it.
+ */
+ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) {
+ Tcl_SetObjResult(interp, TclArithSeriesObjReverse(objv[1]));
+ return TCL_OK;
+ } /* end ArithSeries */
+
+ /* True List */
if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) {
return TCL_ERROR;
}
@@ -3979,6 +4050,407 @@ Tcl_LsetObjCmd(
/*
*----------------------------------------------------------------------
*
+ * SequenceIdentifyArgument --
+ * (for [lseq] command)
+ *
+ * Given a Tcl_Obj, identify if it is a keyword or a number
+ *
+ * Return Value
+ * 0 - failure, unexpected value
+ * 1 - value is a number
+ * 2 - value is an operand keyword
+ * 3 - value is a by keyword
+ *
+ * The decoded value will be assigned to the appropriate
+ * pointer, if supplied.
+ */
+
+static SequenceDecoded
+SequenceIdentifyArgument(
+ Tcl_Interp *interp, /* for error reporting */
+ Tcl_Obj *argPtr, /* Argument to decode */
+ Tcl_Obj **numValuePtr, /* Return numeric value */
+ int *keywordIndexPtr) /* Return keyword enum */
+{
+ int status;
+ SequenceOperators opmode;
+ SequenceByMode bymode;
+ union {
+ Tcl_WideInt i;
+ double d;
+ } nvalue;
+
+ status = TclGetNumberFromObj(NULL, argPtr, (ClientData*)&nvalue, keywordIndexPtr);
+ if (status == TCL_OK) {
+ if (numValuePtr) {
+ *numValuePtr = argPtr;
+ }
+ return NumericArg;
+ } else {
+ /* Check for an index expression */
+ long value;
+ double dvalue;
+ Tcl_Obj *exprValueObj;
+ int keyword;
+ Tcl_InterpState savedstate;
+ savedstate = Tcl_SaveInterpState(interp, status);
+ if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) {
+ status = Tcl_RestoreInterpState(interp, savedstate);
+ exprValueObj = argPtr;
+ } else {
+ // Determine if expression is double or int
+ if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) {
+ keyword = TCL_NUMBER_INT;
+ exprValueObj = argPtr;
+ } else {
+ if (floor(dvalue) == dvalue) {
+ exprValueObj = Tcl_NewWideIntObj(value);
+ keyword = TCL_NUMBER_INT;
+ } else {
+ exprValueObj = Tcl_NewDoubleObj(dvalue);
+ keyword = TCL_NUMBER_DOUBLE;
+ }
+ }
+ status = Tcl_RestoreInterpState(interp, savedstate);
+ if (numValuePtr) {
+ *numValuePtr = exprValueObj;
+ }
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = keyword ;// type of expression result
+ }
+ return NumericArg;
+ }
+ }
+
+ status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
+ "range operation", 0, &opmode);
+ if (status == TCL_OK) {
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = opmode;
+ }
+ return RangeKeywordArg;
+ }
+
+ status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords,
+ "step keyword", 0, &bymode);
+ if (status == TCL_OK) {
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = bymode;
+ }
+ return ByKeywordArg;
+ }
+ return NoneArg;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LseqObjCmd --
+ *
+ * This procedure is invoked to process the "lseq" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Enumerated possible argument patterns:
+ *
+ * 1:
+ * lseq n
+ * 2:
+ * lseq n n
+ * 3:
+ * lseq n n n
+ * lseq n 'to' n
+ * lseq n 'count' n
+ * lseq n 'by' n
+ * 4:
+ * lseq n 'to' n n
+ * lseq n n 'by' n
+ * lseq n 'count' n n
+ * 5:
+ * lseq n 'to' n 'by' n
+ * lseq n 'count' n 'by' n
+ *
+ * Results:
+ * A standard Tcl object result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LseqObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_Obj *elementCount = NULL;
+ Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
+ Tcl_WideInt values[5];
+ Tcl_Obj *numValues[5];
+ Tcl_Obj *numberObj;
+ int status, keyword, useDoubles = 0;
+ Tcl_Obj *arithSeriesPtr;
+ SequenceOperators opmode;
+ SequenceDecoded decoded;
+ int i, arg_key = 0, value_i = 0;
+ // Default constants
+ Tcl_Obj *zero = Tcl_NewIntObj(0);
+ Tcl_Obj *one = Tcl_NewIntObj(1);
+
+ /*
+ * Create a decoding key by looping through the arguments and identify
+ * what kind of argument each one is. Encode each argument as a decimal
+ * digit.
+ */
+ if (objc > 6) {
+ /* Too many arguments */
+ arg_key=0;
+ } else for (i=1; i<objc; i++) {
+ arg_key = (arg_key * 10);
+ numValues[value_i] = NULL;
+ decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword);
+ switch (decoded) {
+
+ case NoneArg:
+ /*
+ * Unrecognizable argument
+ * Reproduce operation error message
+ */
+ status = Tcl_GetIndexFromObj(interp, objv[i], seq_operations,
+ "operation", 0, &opmode);
+ goto done;
+
+ case NumericArg:
+ arg_key += NumericArg;
+ numValues[value_i] = numberObj;
+ Tcl_IncrRefCount(numValues[value_i]);
+ values[value_i] = keyword; // This is the TCL_NUMBER_* value
+ useDoubles = useDoubles ? useDoubles : keyword == TCL_NUMBER_DOUBLE;
+ value_i++;
+ break;
+
+ case RangeKeywordArg:
+ arg_key += RangeKeywordArg;
+ values[value_i] = keyword;
+ value_i++;
+ break;
+
+ case ByKeywordArg:
+ arg_key += ByKeywordArg;
+ values[value_i] = keyword;
+ value_i++;
+ break;
+
+ default:
+ arg_key += 9; // Error state
+ value_i++;
+ break;
+ }
+ }
+
+ /*
+ * The key encoding defines a valid set of arguments, or indicates an
+ * error condition; process the values accordningly.
+ */
+ switch (arg_key) {
+
+/* No argument */
+ case 0:
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "n ??op? n ??by? n??");
+ status = TCL_ERROR;
+ goto done;
+ break;
+
+/* range n */
+ case 1:
+ start = zero;
+ elementCount = numValues[0];
+ end = NULL;
+ step = one;
+ break;
+
+/* range n n */
+ case 11:
+ start = numValues[0];
+ end = numValues[1];
+ break;
+
+/* range n n n */
+ case 111:
+ start = numValues[0];
+ end = numValues[1];
+ step = numValues[2];
+ break;
+
+/* range n 'to' n */
+/* range n 'count' n */
+/* range n 'by' n */
+ case 121:
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ break;
+ case LSEQ_BY:
+ start = zero;
+ elementCount = numValues[0];
+ step = numValues[2];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ step = one;
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ }
+ break;
+
+/* range n 'to' n n */
+/* range n 'count' n n */
+ case 1211:
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ step = numValues[3];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ step = numValues[3];
+ break;
+ case LSEQ_BY:
+ /* Error case */
+ status = TCL_ERROR;
+ goto done;
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* range n n 'by' n */
+ case 1121:
+ start = numValues[0];
+ end = numValues[1];
+ opmode = (SequenceOperators)values[2];
+ switch (opmode) {
+ case LSEQ_BY:
+ step = numValues[3];
+ break;
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ case LSEQ_COUNT:
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* range n 'to' n 'by' n */
+/* range n 'count' n 'by' n */
+ case 12121:
+ start = numValues[0];
+ opmode = (SequenceOperators)values[3];
+ switch (opmode) {
+ case LSEQ_BY:
+ step = numValues[4];
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ opmode = (SequenceOperators)values[1];
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ start = numValues[0];
+ end = numValues[2];
+ break;
+ case LSEQ_COUNT:
+ start = numValues[0];
+ elementCount = numValues[2];
+ break;
+ default:
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+ break;
+
+/* Error cases: incomplete arguments */
+ case 12:
+ opmode = (SequenceOperators)values[1]; goto KeywordError; break;
+ case 112:
+ opmode = (SequenceOperators)values[2]; goto KeywordError; break;
+ case 1212:
+ opmode = (SequenceOperators)values[3]; goto KeywordError; break;
+ KeywordError:
+ status = TCL_ERROR;
+ switch (opmode) {
+ case LSEQ_DOTS:
+ case LSEQ_TO:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"to\" value."));
+ break;
+ case LSEQ_COUNT:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"count\" value."));
+ break;
+ case LSEQ_BY:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "missing \"by\" value."));
+ break;
+ }
+ status = TCL_ERROR;
+ goto done;
+ break;
+
+/* All other argument errors */
+ default:
+ Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
+ status = TCL_ERROR;
+ goto done;
+ break;
+ }
+
+ /*
+ * Success! Now lets create the series object.
+ */
+ arithSeriesPtr = TclNewArithSeriesObj(useDoubles, start, end, step, elementCount);
+
+ Tcl_SetObjResult(interp, arithSeriesPtr);
+ status = TCL_OK;
+
+ done:
+ // Free number arguments.
+ while (--value_i>=0) {
+ if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]);
+ }
+
+ // Free constants
+ Tcl_DecrRefCount(zero);
+ Tcl_DecrRefCount(one);
+
+ return status;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
@@ -4247,8 +4719,13 @@ Tcl_LsortObjCmd(
sortInfo.compareCmdPtr = newCommandPtr;
}
- sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ sortInfo.resultCode = TclArithSeriesGetElements(interp,
+ listObj, &length, &listObjPtrs);
+ } else {
+ sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
&length, &listObjPtrs);
+ }
if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 885df49..8a08f53 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3760,8 +3760,12 @@ TclNRSwitchObjCmd(
if (matchVarObj != NULL) {
Tcl_Obj *substringObj;
- substringObj = Tcl_GetRange(stringObj,
- info.matches[j].start, info.matches[j].end-1);
+ if (info.matches[j].end + 1 > 1) {
+ substringObj = Tcl_GetRange(stringObj,
+ info.matches[j].start, info.matches[j].end-1);
+ } else {
+ TclNewObj(substringObj);
+ }
/*
* Never fails; the object is always clean at this point.
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index cc8c683..b4ba4d9 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -531,8 +531,7 @@ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName,
/* Slot 188 is reserved */
/* 189 */
EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode);
-/* 190 */
-EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
+/* Slot 190 is reserved */
/* 191 */
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket);
/* 192 */
@@ -1834,6 +1833,11 @@ EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp,
EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp,
Tcl_ObjCmdProc2 *objProc2, void *clientData,
size_t objc, Tcl_Obj *const objv[]);
+/* Slot 680 is reserved */
+/* Slot 681 is reserved */
+/* 682 */
+EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp,
+ Tcl_Channel chan, int mode);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2035,7 +2039,7 @@ typedef struct TclStubs {
int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */
void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */
- int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
+ void (*reserved190)(void);
Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */
char * (*tcl_Merge) (Tcl_Size argc, const char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
@@ -2525,6 +2529,9 @@ typedef struct TclStubs {
Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */
Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */
int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */
+ void (*reserved680)(void);
+ void (*reserved681)(void);
+ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -2896,8 +2903,7 @@ extern const TclStubs *tclStubsPtr;
/* Slot 188 is reserved */
#define Tcl_MakeFileChannel \
(tclStubsPtr->tcl_MakeFileChannel) /* 189 */
-#define Tcl_MakeSafe \
- (tclStubsPtr->tcl_MakeSafe) /* 190 */
+/* Slot 190 is reserved */
#define Tcl_MakeTcpClientChannel \
(tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */
#define Tcl_Merge \
@@ -3836,6 +3842,10 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_NRCreateCommand2) /* 678 */
#define Tcl_NRCallObjProc2 \
(tclStubsPtr->tcl_NRCallObjProc2) /* 679 */
+/* Slot 680 is reserved */
+/* Slot 681 is reserved */
+#define Tcl_RemoveChannelMode \
+ (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
#endif /* defined(USE_TCL_STUBS) */
@@ -3888,20 +3898,28 @@ extern const TclStubs *tclStubsPtr;
#define Tcl_GlobalEval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL)
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
+inline TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void Tcl_SaveResult_(void) {}
#define Tcl_SaveResult(interp, statePtr) \
do { \
+ Tcl_SaveResult_(); \
*(statePtr) = Tcl_GetObjResult(interp); \
Tcl_IncrRefCount(*(statePtr)); \
Tcl_SetObjResult(interp, Tcl_NewObj()); \
} while(0)
+inline TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void Tcl_RestoreResult_(void) {}
#define Tcl_RestoreResult(interp, statePtr) \
do { \
+ Tcl_RestoreResult_(); \
Tcl_ResetResult(interp); \
Tcl_SetObjResult(interp, *(statePtr)); \
Tcl_DecrRefCount(*(statePtr)); \
} while(0)
+inline TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_(void) {}
#define Tcl_DiscardResult(statePtr) \
- Tcl_DecrRefCount(*(statePtr))
+ do { \
+ Tcl_DiscardResult_(); \
+ Tcl_DecrRefCount(*(statePtr)); \
+ } while(0)
#define Tcl_SetResult(interp, result, freeProc) \
do { \
const char *__result = result; \
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 6445ca3..6d7d968 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);
@@ -1477,73 +1493,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 = TclGetString(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 *) Tcl_Alloc(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) {
+ Tcl_Free(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/tclExecute.c b/generic/tclExecute.c
index 6db2faf..c0af4bd 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -19,6 +19,7 @@
#include "tclCompile.h"
#include "tclOOInt.h"
#include "tclTomMath.h"
+#include "tclArithSeries.h"
#include <math.h>
#include <assert.h>
@@ -4658,6 +4659,23 @@ TEBCresume(
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
+
+ /* special case for ArithSeries */
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ length = TclArithSeriesObjLength(valuePtr);
+ if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ goto lindexDone;
+ }
+
/*
* Extract the desired list element.
*/
@@ -4679,6 +4697,8 @@ TEBCresume(
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
+
+ lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
@@ -4702,6 +4722,28 @@ TEBCresume(
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
+ /* special case for ArithSeries */
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ length = TclArithSeriesObjLength(valuePtr);
+
+ /* Decode end-offset index values. */
+
+ index = TclIndexDecode(opnd, length);
+
+ /* Compute value @ index */
+ if (index < length) {
+ if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ } else {
+ TclNewObj(objResultPtr);
+ }
+ pcAdjustment = 5;
+ goto lindexFastPath2;
+ }
+
/*
* Get the contents of the list, making sure that it really is a list
* in the process.
@@ -4724,6 +4766,8 @@ TEBCresume(
TclNewObj(objResultPtr);
}
+ lindexFastPath2:
+
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
@@ -4899,7 +4943,11 @@ TEBCresume(
fromIdx = TclIndexDecode(fromIdx, objc - 1);
- objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
+ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) {
+ objResultPtr = TclArithSeriesObjRange(valuePtr, fromIdx, toIdx);
+ } else {
+ objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
+ }
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
@@ -4919,7 +4967,7 @@ TEBCresume(
if (length > 0) {
size_t i = 0;
Tcl_Obj *o;
-
+ int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType);
/*
* An empty list doesn't match anything.
*/
@@ -4935,6 +4983,9 @@ TEBCresume(
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
+ if (isArithSeries) {
+ TclDecrRefCount(o);
+ }
i++;
} while (i < length && match == 0);
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index aeed4cd..3549317 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -1655,6 +1655,7 @@ Tcl_CreateChannel(
}
statePtr->channelName = tmp;
statePtr->flags = mask;
+ statePtr->maxPerms = mask; /* Save max privileges for close callback */
/*
* Set the channel to system default encoding.
@@ -2140,8 +2141,11 @@ Tcl_UnstackChannel(
/*
* Close and free the channel driver state.
+ * TIP #220: This is done with maximum privileges (as created).
*/
+ statePtr->flags &= ~(TCL_READABLE|TCL_WRITABLE);
+ statePtr->flags |= statePtr->maxPerms;
result = ChanClose(chanPtr, interp);
ChannelFree(chanPtr);
@@ -2421,6 +2425,54 @@ Tcl_GetChannelHandle(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RemoveChannelMode --
+ *
+ * Remove either read or write privileges from the channel.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * May change the access mode of the channel.
+ * May leave an error message in the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RemoveChannelMode(
+ Tcl_Interp* interp, /* The interp for an error message. Allowed to be NULL. */
+ Tcl_Channel chan, /* The channel which is modified. */
+ int mode) /* The access mode to drop from the channel */
+{
+ const char* emsg;
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of actual channel. */
+
+ if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) {
+ emsg = "Illegal mode value.";
+ goto error;
+ }
+ if (0 == (statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & ~mode)) {
+ emsg = "Bad mode, would make channel inacessible";
+ goto error;
+ }
+
+ statePtr->flags &= ~mode;
+ return TCL_OK;
+
+ error:
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Tcl_RemoveChannelMode error: %s. Channel: \"%s\"",
+ emsg, Tcl_GetChannelName((Tcl_Channel) chan)));
+ }
+ return TCL_ERROR;
+}
+
+/*
*---------------------------------------------------------------------------
*
* AllocChannelBuffer --
diff --git a/generic/tclIO.h b/generic/tclIO.h
index ca6a0ac..e5a3b7b 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -216,6 +216,8 @@ typedef struct ChannelState {
* companion to 'unreportedError'. */
size_t epoch; /* Used to test validity of stored channelname
* lookup results. */
+ int maxPerms; /* TIP #220: Max access privileges
+ * the channel was created with. */
} ChannelState;
/*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 2c6c0f8..1bd462d 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -37,6 +37,11 @@ declare 6 {
declare 7 {
Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst)
}
+# Removed in 9.0:
+#declare 8 {
+# int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
+# Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
+#}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv,
@@ -85,6 +90,14 @@ declare 32 {
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
+# Removed in 9.0:
+#declare 34 {
+# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
+# int endValue, int *indexPtr)
+#}
+#declare 37 {
+# int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName)
+#}
declare 38 {
int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName,
Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr,
@@ -103,12 +116,24 @@ declare 41 {
declare 42 {
const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
+declare 43 {
+ Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void)
+}
+# Removed in 9.0:
+#declare 44 {
+# int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr)
+#}
declare 45 {
int TclHideUnsafeCommands(Tcl_Interp *interp)
}
declare 46 {
int TclInExit(void)
}
+# Removed in 9.0:
+#declare 50 {
+# void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
+# Namespace *nsPtr)
+#}
declare 51 {
int TclInterpInit(Tcl_Interp *interp)
}
@@ -157,9 +182,18 @@ declare 75 {
declare 76 {
unsigned long long TclpGetSeconds(void)
}
+# Removed in 9.0:
+#declare 77 {
+# void TclpGetTime(Tcl_Time *time)
+#}
declare 81 {
void *TclpRealloc(void *ptr, TCL_HASH_TYPE size)
}
+# Removed in 9.0:
+#declare 88 {
+# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp,
+# const char *name1, const char *name2, int flags)
+#}
declare 89 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
@@ -196,6 +230,10 @@ declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
+# Removed in 9.0:
+#declare 104 {
+# int TclSockMinimumBuffersOld(int sock, int size)
+#}
declare 108 {
void TclTeardownNamespace(Namespace *nsPtr)
}
@@ -205,10 +243,6 @@ declare 109 {
declare 110 {
int TclSockMinimumBuffers(void *sock, Tcl_Size 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.
@@ -218,6 +252,30 @@ declare 111 {
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
+# Removed in 9.0:
+#declare 112 {
+# int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# Tcl_Obj *objPtr)
+#}
+#declare 113 {
+# Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
+# void *clientData, Tcl_NamespaceDeleteProc *deleteProc)
+#}
+#declare 114 {
+# void TclDeleteNamespace(Tcl_Namespace *nsPtr)
+#}
+#declare 115 {
+# int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# const char *pattern, int resetListFirst)
+#}
+#declare 116 {
+# Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
+# Tcl_Namespace *contextNsPtr, int flags)
+#}
+#declare 117 {
+# Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
+# Tcl_Namespace *contextNsPtr, int flags)
+#}
declare 118 {
int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
@@ -230,10 +288,33 @@ declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
+# Removed in 9.0:
+#declare 121 {
+# int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# const char *pattern)
+#}
+#declare 122 {
+# Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+#}
+#declare 123 {
+# void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
+# Tcl_Obj *objPtr)
+#}
+#declare 124 {
+# Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
+#}
+#declare 125 {
+# Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
+#}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
+# Removed in 9.0:
+#declare 127 {
+# int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+# const char *pattern, int allowOverwrite)
+#}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
@@ -252,6 +333,10 @@ declare 131 {
declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
+# Removed in 9.0:
+#declare 133 {
+# struct tm *TclpGetDate(const time_t *time, int useGMT)
+#}
declare 138 {
const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
@@ -306,6 +391,14 @@ declare 156 {
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
+# Removed in 9.0:
+#declare 158 {
+# void TclSetStartupScriptFileName(const char *filename)
+#}
+#declare 159 {
+# const char *TclGetStartupScriptFileName(void)
+#}
+
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
@@ -342,6 +435,13 @@ declare 166 {
Tcl_Size index, Tcl_Obj *valuePtr)
}
+# Removed in 9.0:
+#declare 167 {
+# void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
+#}
+#declare 168 {
+# Tcl_Obj *TclGetStartupScriptPath(void)
+#}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, size_t n)
@@ -374,6 +474,22 @@ declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
+# Removed in 9.0:
+#declare 178 {
+# void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+#}
+#declare 179 {
+# Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
+#}
+#declare 182 {
+# struct tm *TclpLocaltime(const time_t *clock)
+#}
+#declare 183 {
+# struct tm *TclpGmtime(const time_t *clock)
+#}
+
+# For the new "Thread Storage" subsystem.
+
declare 198 {
int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
CallFrame **framePtrPtr)
@@ -478,6 +594,10 @@ declare 234 {
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
+# Removed in 9.0:
+#declare 236 {
+# void TclBackgroundException(Tcl_Interp *interp, int code)
+#}
# TIP #285: Script cancellation support.
declare 237 {
@@ -583,7 +703,6 @@ declare 258 {
Tcl_Obj *basenameObj)
}
-
# TIP 625: for unit testing - create list objects with span
declare 260 {
Tcl_Obj *TclListTestObj(int length, int leadingSpace, int endSpace)
@@ -593,7 +712,6 @@ declare 260 {
declare 261 {
void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
}
-
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index dee9f30..3c12081 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2878,6 +2878,7 @@ MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
MODULE_SCOPE const Tcl_ObjType tclDoubleType;
MODULE_SCOPE const Tcl_ObjType tclIntType;
MODULE_SCOPE const Tcl_ObjType tclListType;
+MODULE_SCOPE const Tcl_ObjType tclArithSeriesType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
@@ -3230,6 +3231,7 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
const EnsembleImplMap map[]);
+MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp);
MODULE_SCOPE int TclMaxListLength(const char *bytes, Tcl_Size numBytes,
const char **endPtr);
MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc,
@@ -3636,6 +3638,9 @@ MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData,
MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_LseqObjCmd(void *clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 9332b5e..b84b996 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -130,7 +130,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);
/* Slot 44 is reserved */
/* 45 */
EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp);
@@ -631,7 +632,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 */
void (*reserved44)(void);
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
@@ -929,7 +930,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
#define TclpGetUserHome \
(tclIntStubsPtr->tclpGetUserHome) /* 42 */
-/* Slot 43 is reserved */
+#define TclGetObjInterpProc2 \
+ (tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */
/* Slot 44 is reserved */
#define TclHideUnsafeCommands \
(tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
@@ -1291,6 +1293,7 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TclObjInterpProc
#define TclObjInterpProc TclGetObjInterpProc()
+#define TclObjInterpProc2 TclGetObjInterpProc2()
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 589b0da..98e63db 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -2481,7 +2481,7 @@ ChildCreate(
((Interp *) parentInterp)->maxNestingDepth;
if (safe) {
- if (Tcl_MakeSafe(childInterp) == TCL_ERROR) {
+ if (TclMakeSafe(childInterp) == TCL_ERROR) {
goto error;
}
} else {
@@ -3264,7 +3264,7 @@ Tcl_IsSafe(
/*
*----------------------------------------------------------------------
*
- * Tcl_MakeSafe --
+ * TclMakeSafe --
*
* Makes its argument interpreter contain only functionality that is
* defined to be part of Safe Tcl. Unsafe commands are hidden, the env
@@ -3281,7 +3281,7 @@ Tcl_IsSafe(
*/
int
-Tcl_MakeSafe(
+TclMakeSafe(
Tcl_Interp *interp) /* Interpreter to be made safe. */
{
Tcl_Channel chan; /* Channel to remove from safe interpreter. */
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 163f831..0ded8df 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -9,8 +9,9 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#include "tclInt.h"
#include <assert.h>
+#include "tclInt.h"
+#include "tclArithSeries.h"
/*
* TODO - memmove is fast. Measure at what size we should prefer memmove
@@ -1658,6 +1659,10 @@ Tcl_ListObjGetElements(
{
ListRep listRep;
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr);
+ }
+
if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
return TCL_ERROR;
ListRepElements(&listRep, *objcPtr, *objvPtr);
@@ -1933,6 +1938,10 @@ Tcl_ListObjIndex(
Tcl_Obj **elemObjs;
Tcl_Size numElems;
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ return TclArithSeriesObjIndex(listObj, index, objPtrPtr);
+ }
+
/*
* TODO
* Unlike the original list code, this does not optimize for lindex'ing
@@ -1963,7 +1972,7 @@ Tcl_ListObjIndex(
* convert it to one.
*
* Results:
- * The return value is normally TCL_OK; in this case *intPtr will be set
+ * The return value is normally TCL_OK; in this case *lenPtr will be set
* to the integer count of list elements. If listPtr does not refer to a
* list object and the object can not be converted to one, TCL_ERROR is
* returned and an error message will be left in the interpreter's result
@@ -1984,6 +1993,11 @@ Tcl_ListObjLength(
{
ListRep listRep;
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ *lenPtr = TclArithSeriesObjLength(listObj);
+ return TCL_OK;
+ }
+
/*
* TODO
* Unlike the original list code, this does not optimize for lindex'ing
@@ -2611,6 +2625,27 @@ TclLindexFlat(
{
Tcl_Size 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++) {
@@ -3238,6 +3273,34 @@ SetListFromAny(
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
+ } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ /*
+ * Convertion from Arithmetic Series is a special case
+ * because it can be done an order of magnitude faster
+ * and may occur frequently.
+ */
+ ListSizeT j, size = TclArithSeriesObjLength(objPtr);
+
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? size : 1, NULL, &listRep)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);
+ LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0);
+
+ listRep.storePtr->numUsed = size;
+ elemPtrs = listRep.storePtr->slots;
+ for (j = 0; j < size; j++) {
+ if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */
+ }
+
} else {
Tcl_Size estCount, length;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
@@ -3424,6 +3487,7 @@ UpdateStringOfList(
Tcl_Free(flagPtr);
}
}
+
/*
*------------------------------------------------------------------------
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 4d421c7..acb520c 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -485,7 +485,7 @@ TclCreateProc(
* in the Proc.
*/
- result = TclListObjGetElementsM(interp , argsPtr ,&numArgs ,&argArray);
+ result = TclListObjGetElementsM(interp, argsPtr, &numArgs, &argArray);
if (result != TCL_OK) {
goto procError;
}
@@ -576,7 +576,7 @@ TclCreateProc(
* (its value was kept the same as pre VarReform to simplify
* tbcload's processing of older byetcodes).
*
- * The only other flag vlaue that is important to retrieve from
+ * The only other flag value that is important to retrieve from
* precompiled procs is VAR_TEMPORARY (also unchanged). It is
* needed later when retrieving the variable names.
*/
@@ -1085,7 +1085,7 @@ ProcWrongNumArgs(
Tcl_IncrRefCount(desiredObjs[0]);
if (localCt > 0) {
- Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
+ Var *defPtr = (Var *)(&framePtr->localCachePtr->varName0 + localCt);
for (i=1 ; i<=numArgs ; i++, defPtr++) {
Tcl_Obj *argObj;
@@ -1595,7 +1595,6 @@ TclPushProcCallFrame(
*----------------------------------------------------------------------
*/
-#undef TclObjInterpProc
int
TclObjInterpProc(
ClientData clientData, /* Record describing procedure to be
@@ -1631,6 +1630,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);
+}
+
/*
*----------------------------------------------------------------------
@@ -2224,15 +2260,16 @@ 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.
+ * Returns the internal address of the TclObjInterpProc/ObjInterpProc2
+ * functions.
*
* Side effects:
* None.
@@ -2245,6 +2282,12 @@ TclGetObjInterpProc(void)
{
return TclObjInterpProc;
}
+
+Tcl_ObjCmdProc2 *
+TclGetObjInterpProc2(void)
+{
+ return ObjInterpProc2;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index c7d7d70..cf23aab 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -731,7 +731,9 @@ Tcl_GetUnicodeFromObj(
*
* Create a Tcl Object that contains the chars between first and last of
* the object indicated by "objPtr". If the object is not already a
- * String object, convert it to one.
+ * String object, convert it to one. If first is TCL_INDEX_NONE, the
+ * returned string start at the beginning of objPtr. If last is
+ * TCL_INDEX_NONE, the returned string ends at the end of objPtr.
*
* Results:
* Returns a new Tcl Object of the String type.
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index a00e835..2928cfa 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -435,7 +435,7 @@ static const TclIntStubs tclIntStubs = {
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
- 0, /* 43 */
+ TclGetObjInterpProc2, /* 43 */
0, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
@@ -986,7 +986,7 @@ const TclStubs tclStubs = {
Tcl_LinkVar, /* 187 */
0, /* 188 */
Tcl_MakeFileChannel, /* 189 */
- Tcl_MakeSafe, /* 190 */
+ 0, /* 190 */
Tcl_MakeTcpClientChannel, /* 191 */
Tcl_Merge, /* 192 */
Tcl_NextHashEntry, /* 193 */
@@ -1476,6 +1476,9 @@ const TclStubs tclStubs = {
Tcl_CreateObjTrace2, /* 677 */
Tcl_NRCreateCommand2, /* 678 */
Tcl_NRCallObjProc2, /* 679 */
+ 0, /* 680 */
+ 0, /* 681 */
+ Tcl_RemoveChannelMode, /* 682 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index ce83500..57037c2 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -170,6 +170,15 @@ typedef struct TestChannel {
static TestChannel *firstDetached;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/*
* Forward declarations for procedures defined later in this file:
*/
@@ -6000,6 +6009,45 @@ TestChannelCmd(
return TCL_OK;
}
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+
+ if (statePtr->maxPerms & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->maxPerms & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE);
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE);
+ }
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", NULL);
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index 9c5ca8b..d9335c5 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -74,7 +74,7 @@ declare 16 {
mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
# Removed in 9.0
-#declare 17 {deprecated {is private function in libtommath}} {
+#declare 17 {
# mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, mp_digit *r)
#}
declare 18 {
@@ -141,7 +141,7 @@ declare 38 {
mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
# Removed in 9.0
-#declare 39 {deprecated {macro calling mp_set_u64}} {
+#declare 39 {
# void TclBN_mp_set(mp_int *a, unsigned int b)
#}
# Removed in 9.0
@@ -180,18 +180,18 @@ declare 49 {
void TclBN_mp_zero(mp_int *a)
}
# Removed in 9.0
-#declare 61 {deprecated {macro calling mp_init_u64}} {
+#declare 61 {
# mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i)
#}
# Removed in 9.0
-#declare 62 {deprecated {macro calling mp_set_u64}} {
+#declare 62 {
# void TclBN_mp_set_ul(mp_int *a, unsigned long i)
#}
declare 63 {
int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
# Removed in 9.0
-#declare 64 {deprecated {macro calling mp_init_i64}} {
+#declare 64 {
# int TclBN_mp_init_l(mp_int *bignum, long initVal)
#}
declare 65 {
generated by cgit v0.12 at 2024-11-16 09:41:11 (GMT)