summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rwxr-xr-xgeneric/tclArithSeries.c952
-rw-r--r--generic/tclArithSeries.h54
-rw-r--r--generic/tclBasic.c1
-rw-r--r--generic/tclCmdAH.c54
-rw-r--r--generic/tclCmdIL.c507
-rw-r--r--generic/tclExecute.c55
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclListObj.c68
8 files changed, 1661 insertions, 34 deletions
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
new file mode 100755
index 0000000..93177a7
--- /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*) ckalloc(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*) ckalloc(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]);
+ }
+ }
+ ckfree((char *) arithSeriesRepPtr->elements);
+ }
+ ckfree((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*) ckalloc(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. */
+ int *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 **)ckalloc(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]);
+ }
+ ckfree((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..f855c22
--- /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, int *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 b806c33..83111b1 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -322,6 +322,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 06919a2..092bbd1 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
@@ -2803,32 +2804,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++;
@@ -2950,11 +2966,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 cdc302c..9430eb5 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -19,6 +19,8 @@
#include "tclInt.h"
#include "tclRegexp.h"
+#include "tclArithSeries.h"
+#include <math.h>
#include <assert.h>
/*
@@ -95,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:
*/
@@ -2182,7 +2201,7 @@ Tcl_JoinObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int length, listLen;
+ int length, listLen, isArithSeries = 0;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
@@ -2195,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) {
@@ -2206,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;
}
@@ -2220,19 +2252,41 @@ Tcl_JoinObjCmd(
int i;
TclNewObj(resObjPtr);
- 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);
@@ -2689,7 +2743,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;
}
@@ -3073,6 +3131,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;
}
@@ -3973,6 +4042,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
@@ -4238,8 +4708,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/tclExecute.c b/generic/tclExecute.c
index 8aa3bb2..f8d5493 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>
@@ -4868,6 +4869,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.
*/
@@ -4889,6 +4907,8 @@ TEBCresume(
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
+
+ lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
@@ -4912,6 +4932,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 >= 0 && 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.
@@ -4934,6 +4976,8 @@ TEBCresume(
TclNewObj(objResultPtr);
}
+ lindexFastPath2:
+
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
@@ -5109,7 +5153,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);
@@ -5129,7 +5177,7 @@ TEBCresume(
if (length > 0) {
int i = 0;
Tcl_Obj *o;
-
+ int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType);
/*
* An empty list doesn't match anything.
*/
@@ -5145,6 +5193,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/tclInt.h b/generic/tclInt.h
index 09f22d3..0959741 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2922,6 +2922,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;
@@ -3725,6 +3726,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/tclListObj.c b/generic/tclListObj.c
index 7a702e0..5034174 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
@@ -1663,6 +1664,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);
@@ -1938,6 +1943,10 @@ Tcl_ListObjIndex(
Tcl_Obj **elemObjs;
ListSizeT numElems;
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ return TclArithSeriesObjIndex(listObj, index, objPtrPtr);
+ }
+
/*
* TODO
* Unlike the original list code, this does not optimize for lindex'ing
@@ -1968,7 +1977,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
@@ -1989,6 +1998,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
@@ -2616,6 +2630,27 @@ TclLindexFlat(
{
ListSizeT i;
+ /* Handle ArithSeries as special case */
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ ListSizeT index, listLen = TclArithSeriesObjLength(listObj);
+ Tcl_Obj *elemObj = NULL;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
+ &index) == TCL_OK) {
+ }
+ if (i==0) {
+ TclArithSeriesObjIndex(listObj, index, &elemObj);
+ Tcl_IncrRefCount(elemObj);
+ } else if (index > 0) {
+ Tcl_DecrRefCount(elemObj);
+ TclNewObj(elemObj);
+ Tcl_IncrRefCount(elemObj);
+ break;
+ }
+ }
+ return elemObj;
+ }
+
Tcl_IncrRefCount(listObj);
for (i=0 ; i<indexCount && listObj ; i++) {
@@ -3243,6 +3278,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 {
ListSizeT estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
@@ -3432,6 +3495,7 @@ UpdateStringOfList(
ckfree(flagPtr);
}
}
+
/*
*------------------------------------------------------------------------
generated by cgit v0.12 at 2025-02-21 13:46:53 (GMT)