summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorgriffin <briang42@easystreet.net>2022-08-28 00:10:13 (GMT)
committergriffin <briang42@easystreet.net>2022-08-28 00:10:13 (GMT)
commit31c68fa4e741269ba96b1411eca08a67001079f2 (patch)
treeec21eaf79c1107e1491b3bc407adff6be31311b1
parentf9e3b4dd740c0d808fef53f9eba4b44e67734c34 (diff)
downloadtcl-31c68fa4e741269ba96b1411eca08a67001079f2.zip
tcl-31c68fa4e741269ba96b1411eca08a67001079f2.tar.gz
tcl-31c68fa4e741269ba96b1411eca08a67001079f2.tar.bz2
Move all ArithSeries code to it's own file. Sync other changes wil TIP-629.
-rw-r--r--doc/AbstractListObj.356
-rw-r--r--generic/tclAbstractList.c10
-rw-r--r--generic/tclAbstractList.h9
-rw-r--r--generic/tclArithSeries.c854
-rw-r--r--generic/tclArithSeries.h76
-rw-r--r--generic/tclCmdIL.c838
-rw-r--r--generic/tclInt.h2
-rw-r--r--tests/lseq.test113
-rw-r--r--unix/Makefile.in7
9 files changed, 1235 insertions, 730 deletions
diff --git a/doc/AbstractListObj.3 b/doc/AbstractListObj.3
index ccd04fc..b8cf4da 100644
--- a/doc/AbstractListObj.3
+++ b/doc/AbstractListObj.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-.TH Tcl_AbstractListObj 3 8.7 Tcl "Tcl Library Procedures"
+.TH Tcl_AbstractListType 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
@@ -15,7 +15,13 @@ Tcl_AbstractListObjRange, Tcl_AbstractListObjReverse, Tcl_AbstractListSetProc \-
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
-\fBTcl_NewAbstractListObj\fR(\fIinterp, typeName, requiredSize\fR)
+\fBTcl_NewAbstractListObj\fR(\fIinterp, abstractListType\fR)
+Tcl_AbstractListType *
+\fBTcl_AbstractListGetType\fR(\fIobjPtr\fR)
+void
+\fBTcl_AbstractListSetConcreteRep\fR(\fIobjPtr, repPtr\fR)
+void *
+\fBTcl_AbstractListGetConcreteRep\fR(\fIobjPtr\fR)
Tcl_WideInt
\fBTcl_AbstractListObjLength\fR(\fIobjPtr\fR)
Tcl_Obj *
@@ -24,20 +30,6 @@ Tcl_Obj *
\fBTcl_AbstractListObjRange\fR(\fIobjPtr, fromIdx, toIdx\fR)
Tcl_Obj *
\fBTcl_AbstractListObjReverse(\fIobjPtr\fR)
-void*
-\fBTcl_AbstractListGetTypeRep\fR(\fIobjPtr\fR)
-int
-\fBTcl_SetAbstractListNewProc\fR(\fITcl_Obj *objPtr, Tcl_ALNewObjProc *proc\fR)
-int
-\fBTcl_SetAbstractListLengthProc\fR(\fITcl_Obj *objPtr, Tcl_ALLengthProc *proc\fR)
-int
-\fBTcl_SetAbstractListSliceProc\fR(\fITcl_Obj *objPtr, Tcl_ALSliceProc *proc\fR)
-int
-\fBTcl_SetAbstractListIndexProc\fR(\fITcl_Obj *objPtr, Tcl_ALIndexProc *proc\fR)
-int
-\fBTcl_SetAbstractListReverseProc\fR(\fITcl_Obj *objPtr, Tcl_ALReverseProc *proc\fR)
-int
-\fBTcl_SetAbstractListDupRepProc\fR(\fITcl_Obj *objPtr, Tcl_ALDupRepProc *proc\fR)
Tcl_Obj*
(Tcl_ALNewObjProc) (int objc, Tcl_Obj *objv[])
void
@@ -56,18 +48,13 @@ Tcl_Obj*
If an error occurs while converting a value to be a list value,
an error message is left in the interpreter's result value
unless \fIinterp\fR is NULL.
-.AP "const char" *typeName in
-The type name of this custom abstract list type. This name will
-appear in type related error messages, or reported by the
-[tcl::unsupported::representation] command.
-.AP size_t requiredSize in
-The amount of space required to store whatever information is needed
-to represent the value for this type. For example, if a custom type
-uses a C struct to store the value details, then the required size
-would be \fBsizeof\fR(\fImyCustomStructType\fR). The
-\fBTcl_NewAbstractListObj\fR call will provide the extra storage
-needed for the struct. Use the
-\fBTcl_AbstractListGetTypeRep\fR(\fIobjPtr\fR) function to obtain the
+.AP Tcl_AbstractListType *abstractListType in
+This structure defines the behavior for the \fBAbstractList\fR for a
+given concrete \fBAbstractList\fR type. The struct provides the name
+plus a number of functions that implement the various List operations
+on the AbstractType value. \fBTcl_NewAbstractListObj\fR call will
+provide the extra storage needed for the struct. Use the
+\fBTcl_AbstractListGetConcreteRep\fR(\fIobjPtr\fR) function to obtain the
address of this storeage.
.AP Tcl_Obj *objPtr in/out
A Tcl_Obj of type AbstractList. Use to read or modify the type or value content an AbstractList type.
@@ -115,17 +102,12 @@ on the index using an arithmetic expression: "value = start + (step *
index)".
.PP
\fBTcl_NewAbstractListObj\fR is used to create an object with a custom
-List representation. The \fIrequiredSize\fR argument is needed to add the
-callers storage space for this new value type. For example,
-the example above needs to store 4 values: start, end, step, and
-length, therefore, the size needed is the sizeof() a struct containing
-those 4 values. The \fBTcl_AbstractListGetTypeRep\fR call is then
-used to obtain the address for this space.
+List representation. TODO: describe vtable type
.PP
.CS
typedef struct ArithSeries {int start, int end, int step, int length} ArithSeries;
\fBTcl_Obj\fR *objPtr = \fBTcl_NewAbstractListObj\fR(interp, "arithseries", sizeof(arithSeries));
-ArithSeries *repPtr = \fBTcl_AbstractListGetTypeRep\fR(objPtr);
+ArithSeries *repPtr = \fBTcl_AbstractListGetConcreteRep\fR(objPtr);
repPtr->start = 0;
repPtr->end = 10;
repPtr->step = 1;
@@ -163,10 +145,10 @@ ArithSeriesObjIndex(Tcl_Obj *arithSeriesObjPtr, Tcl_WideInt index)
if (index < 0 || index >= arithSeriesRepPtr->length)
return NULL;
-
+
/* List[i] = Start + (Step * i) */
element = (arithSeriesRepPtr->start + (index) * arithSeriesRepPtr->step);
-
+
return Tcl_NewWideIntObj(element);
}
diff --git a/generic/tclAbstractList.c b/generic/tclAbstractList.c
index bbffc2d..eb33157 100644
--- a/generic/tclAbstractList.c
+++ b/generic/tclAbstractList.c
@@ -69,12 +69,12 @@ Tcl_AbstractListObjLength(Tcl_Obj *abstractListObjPtr)
*
* Tcl_NewAbstractListObj()
*
- * Creates a new ArithSeries object. The returned object has
+ * Creates a new AbstractList object. The returned object has
* refcount = 0.
*
* Results:
*
- * A Tcl_Obj pointer to the created ArithSeries object.
+ * A Tcl_Obj pointer to the created AbstractList object.
* A NULL pointer of the range is invalid.
*
* Side Effects:
@@ -175,7 +175,7 @@ FreeAbstractListInternalRep(Tcl_Obj *abstractListObjPtr)
* DupAbstractListInternalRep --
*
* Initialize the internal representation of a AbstractList Tcl_Obj to a
- * copy of the internal representation of an existing arithseries object.
+ * copy of the internal representation of an existing abstractlist object.
*
* Results:
* None.
@@ -294,9 +294,9 @@ UpdateStringOfAbstractList(Tcl_Obj *abstractListObjPtr)
*
* SetAbstractListFromAny --
*
- * The Arithmetic Series object is just an way to optimize
+ * The AbstractList object is just a way to optimize
* Lists space complexity, so no one should try to convert
- * a string to an Arithmetic Series object.
+ * a string to an AbstractList object.
*
* This function is here just to populate the Type structure.
*
diff --git a/generic/tclAbstractList.h b/generic/tclAbstractList.h
index 80ae269..015f6c6 100644
--- a/generic/tclAbstractList.h
+++ b/generic/tclAbstractList.h
@@ -27,12 +27,11 @@ Tcl_AbstractListTypeName(
}
}
-Tcl_Obj *Tcl_NewAbstractListObj(Tcl_Interp *interp, const Tcl_AbstractListType *);
-int Tcl_AbstractListCheckedSetProc(Tcl_Obj *objPtr, Tcl_AbstractListProcType ptype, void **procPtr);
+Tcl_Obj * Tcl_NewAbstractListObj(Tcl_Interp *interp, const Tcl_AbstractListType *);
Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr);
-Tcl_Obj* Tcl_AbstractListObjIndex(Tcl_Obj *abstractListPtr, Tcl_WideInt index);
-Tcl_Obj* Tcl_AbstractListObjRange(Tcl_Obj *abstractListPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx);
-Tcl_Obj* Tcl_AbstractListObjReverse(Tcl_Obj *abstractListPtr);
+Tcl_Obj * Tcl_AbstractListObjIndex(Tcl_Obj *abstractListPtr, Tcl_WideInt index);
+Tcl_Obj * Tcl_AbstractListObjRange(Tcl_Obj *abstractListPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx);
+Tcl_Obj * Tcl_AbstractListObjReverse(Tcl_Obj *abstractListPtr);
int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr);
#endif
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
new file mode 100644
index 0000000..19dd949
--- /dev/null
+++ b/generic/tclArithSeries.c
@@ -0,0 +1,854 @@
+/*
+ * 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 <assert.h>
+#include "tcl.h"
+#include "tclInt.h"
+#include "tclArithSeries.h"
+
+
+/*
+ * The structure below defines the arithmetic series Tcl Obj Type by means of
+ * procedures that can be invoked by generic object code.
+ *
+ * The arithmetic series object is a Tcl_AbstractList 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 list's 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.
+ */
+
+static void DupArithSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeArithSeriesRep(Tcl_Obj *arithSeriesObjPtr);
+static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
+
+static Tcl_AbstractListType arithSeriesType = {
+ TCL_ABSTRACTLIST_VERSION_1,
+ "arithseries",
+ Tcl_NewArithSeriesObj,
+ DupArithSeriesRep,
+ TclArithSeriesObjLength,
+ TclArithSeriesObjIndex,
+ TclArithSeriesObjRange,
+ TclArithSeriesObjReverse,
+ TclArithSeriesGetElements,
+ FreeArithSeriesRep,
+ UpdateStringOfArithSeries
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 infiite.
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupArithSeriesRep --
+ *
+ * Initialize the internal representation of a ArithSeries abstract list
+ * 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 AbstractList structure.
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupArithSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
+{
+ ArithSeries *srcArithSeries = (ArithSeries*)Tcl_AbstractListGetConcreteRep(srcPtr);
+ ArithSeries *copyArithSeries = (ArithSeries *)ckalloc(sizeof(ArithSeries));
+
+ *copyArithSeries = *srcArithSeries;
+
+ /* Note: we do not have to be worry about existing internal rep because
+ copyPtr is supposed to be freshly initialized */
+ Tcl_AbstractListSetConcreteRep(copyPtr, copyArithSeries);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesRep --
+ *
+ * Free any allocated memory in the ArithSeries Rep
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+FreeArithSeriesRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */
+{
+ ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+ if (arithSeriesPtr) {
+ if (arithSeriesPtr->elements) {
+ Tcl_WideInt i, len = arithSeriesPtr->len;
+ for (i=0; i<len; i++) {
+ Tcl_DecrRefCount(arithSeriesPtr->elements[i]);
+ }
+ ckfree((char*)arithSeriesPtr->elements);
+ arithSeriesPtr->elements = NULL;
+ }
+ ckfree((char*)arithSeriesPtr);
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *arithSeriesObj;
+ ArithSeries *arithSeriesRepPtr;
+
+ if (length <= 0) {
+ TclNewObj(arithSeriesObj);
+ return arithSeriesObj;
+ }
+
+ arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries));
+ arithSeriesRepPtr->isDouble = 0;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+
+ arithSeriesObj = Tcl_NewAbstractListObj(NULL, &arithSeriesType);
+ Tcl_AbstractListSetConcreteRep(arithSeriesObj, arithSeriesRepPtr);
+
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *arithSeriesObj;
+ ArithSeriesDbl *arithSeriesRepPtr;
+
+ if (length <= 0) {
+ TclNewObj(arithSeriesObj);
+ return arithSeriesObj;
+ }
+
+ arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl));
+ arithSeriesRepPtr->isDouble = 1;
+ arithSeriesRepPtr->start = start;
+ arithSeriesRepPtr->end = end;
+ arithSeriesRepPtr->step = step;
+ arithSeriesRepPtr->len = length;
+ arithSeriesRepPtr->elements = NULL;
+
+ arithSeriesObj = Tcl_NewAbstractListObj(NULL, &arithSeriesType);
+ Tcl_AbstractListSetConcreteRep(arithSeriesObj, arithSeriesRepPtr);
+
+ if (length > 0)
+ Tcl_InvalidateStringRep(arithSeriesObj);
+
+ return arithSeriesObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * assignNumber --
+ *
+ * Create the approprite 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, /* Promote values to double when true,
+ * int otherwise */
+ Tcl_Obj *startObj, /* First value in list */
+ Tcl_Obj *endObj, /* Upper bound value of list */
+ Tcl_Obj *stepObj, /* Increment amount */
+ Tcl_Obj *lenObj) /* Number of elements */
+{
+ 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);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjLength
+ *
+ * Returns the length of the arithmentic series.
+ *
+ * Results:
+ *
+ * The length of the series as Tcl_WideInt.
+ *
+ * Side Effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj)
+{
+ ArithSeries *arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesObj);
+ return arithSeriesRepPtr->len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclArithSeriesObjIndex --
+ *
+ * Returns the element with the specified index in the list
+ * represented by the specified Arithmentic 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 succes, TCL_ERROR on index out of range.
+ *
+ * Side Effects:
+ *
+ * On success, the integer pointed by *element is modified.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index)
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *elemObj;
+
+ if (arithSeriesPtr->typePtr != &tclAbstractListType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr);
+ if (index < 0 || index >= arithSeriesRepPtr->len) {
+ return NULL;
+ }
+ /* List[i] = Start + (Step * index) */
+ if (arithSeriesRepPtr->isDouble) {
+ elemObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ } else {
+ elemObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index));
+ }
+ return elemObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 --
+ */
+Tcl_Obj *
+TclArithSeriesObjStep(
+ Tcl_Obj *arithSeriesPtr)
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *stepObj;
+
+ if (arithSeriesPtr->typePtr != &tclAbstractListType) {
+ Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr);
+ if (arithSeriesRepPtr->isDouble) {
+ stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
+ } else {
+ stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step);
+ }
+ return stepObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NewArithSeriesObj --
+ *
+ * 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 *
+Tcl_NewArithSeriesObj(int objc, Tcl_Obj *objv[])
+{
+ if (objc != 4) return NULL;
+ // TODO: Define this use model!
+ return TclNewArithSeriesObj(0, objv[0]/*start*/, objv[1]/*end*/,
+ objv[2]/*step*/, objv[3]/*len*/);
+}
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ArithSeriesObjLength
+ *
+ * Returns the length of the arithmentic series.
+ *
+ * Results:
+ *
+ * The length of the series as Tcl_WideInt.
+ *
+ * Side Effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesObjPtr)
+{
+ assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
+
+ ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+ return arithSeriesPtr->len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+ Tcl_WideInt fromIdx, /* Index of first element to include. */
+ Tcl_WideInt toIdx) /* Index of last element to include. */
+{
+ ArithSeries *arithSeriesRepPtr;
+ Tcl_Obj *startObj, *endObj, *stepObj;
+
+ arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr);
+
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+ if (fromIdx > toIdx) {
+ Tcl_Obj *obj;
+ TclNewObj(obj);
+ return obj;
+ }
+
+ startObj = TclArithSeriesObjIndex(arithSeriesPtr, fromIdx);
+ Tcl_IncrRefCount(startObj);
+ endObj = TclArithSeriesObjIndex(arithSeriesPtr, toIdx);
+ Tcl_IncrRefCount(endObj);
+ stepObj = TclArithSeriesObjStep(arithSeriesPtr);
+ 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 cause 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;
+}
+
+/*
+ * Handle ArithSeries special case - don't shimmer a series into a list
+ * just to reverse it.
+ */
+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;
+
+ arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr);
+
+ isDouble = arithSeriesRepPtr->isDouble;
+ len = arithSeriesRepPtr->len;
+
+ startObj = TclArithSeriesObjIndex(arithSeriesPtr, (len-1));
+ endObj = TclArithSeriesObjIndex(arithSeriesPtr, 0);
+ stepObj = TclArithSeriesObjStep(arithSeriesPtr);
+
+ 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);
+ }
+
+ Tcl_IncrRefCount(startObj);
+ Tcl_IncrRefCount(endObj);
+ Tcl_IncrRefCount(stepObj);
+
+ 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;
+}
+/*
+** Handle ArithSeries GetElements call
+*/
+
+int
+TclArithSeriesGetElements(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *arithSeriesObjPtr, /* ArithSeries 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(arithSeriesObjPtr,&tclAbstractListType)) {
+ ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+ Tcl_AbstractListType *typePtr;
+ Tcl_Obj **objv;
+ int i, objc;
+
+ typePtr = Tcl_AbstractListGetType(arithSeriesObjPtr);
+
+ objc = Tcl_ArithSeriesObjLength(arithSeriesObjPtr);
+
+ if (objvPtr == NULL) {
+ if (objcPtr) {
+ *objcPtr = objc;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+ }
+
+ if (objc && objvPtr && arithSeriesPtr->elements) {
+ objv = arithSeriesPtr->elements;
+ } else if (objc > 0) {
+ 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;
+ }
+ for (i = 0; i < objc; i++) {
+ objv[i] = typePtr->indexProc(arithSeriesObjPtr, i);
+ Tcl_IncrRefCount(objv[i]);
+ }
+ } else {
+ objv = NULL;
+ }
+ arithSeriesPtr->elements = objv;
+ *objvPtr = objv;
+ *objcPtr = objc;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an abstract list"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+static void
+UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr)
+{
+ char *p, *str;
+ Tcl_Obj *eleObj;
+ Tcl_WideInt length = 0;
+ int llen, slen, i;
+
+
+ /*
+ * Pass 1: estimate space.
+ */
+ llen = Tcl_ArithSeriesObjLength(arithSeriesObjPtr);
+ if (llen <= 0) {
+ Tcl_InitStringRep(arithSeriesObjPtr, NULL, 0);
+ return;
+ }
+ for (i = 0; i < llen; i++) {
+ eleObj = TclArithSeriesObjIndex(arithSeriesObjPtr, i);
+ Tcl_GetStringFromObj(eleObj, &slen);
+ length += slen + 1; /* one more for the space char */
+ Tcl_DecrRefCount(eleObj);
+ }
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, length);
+ for (i = 0; i < llen; i++) {
+ eleObj = TclArithSeriesObjIndex(arithSeriesObjPtr, i);
+ str = Tcl_GetStringFromObj(eleObj, &slen);
+ strcpy(p, str);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(eleObj);
+ }
+ if (length > 0) arithSeriesObjPtr->bytes[length-1] = '\0';
+ arithSeriesObjPtr->length = length-1;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
new file mode 100644
index 0000000..d48bbbb
--- /dev/null
+++ b/generic/tclArithSeries.h
@@ -0,0 +1,76 @@
+/*
+ * 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 AirthSeries 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;
+
+#define ArithSeriesIndexM(arithSeriesRepPtr, index) \
+ ((arithSeriesRepPtr)->isDouble ? \
+ (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \
+ : \
+ ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step)))
+
+#define ArithSeriesStepM(arithSeriesRepPtr) \
+ ((arithSeriesRepPtr)->isDouble ? \
+ ((ArithSeriesDbl*)(arithSeriesRepPtr))->step \
+ : \
+ (arithSeriesRepPtr)->step)
+
+
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp,
+ Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr,
+ Tcl_WideInt index);
+MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj);
+MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr,
+ Tcl_WideInt fromIdx, Tcl_WideInt 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);
+
+MODULE_SCOPE Tcl_Obj * Tcl_NewArithSeriesObj(int objc, Tcl_Obj *objv[]);
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 91a22ec..5e910b8 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -17,9 +17,11 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <math.h>
#include "tclInt.h"
#include "tclRegexp.h"
#include "tclAbstractList.h"
+#include "tclArithSeries.h"
#include <assert.h>
/*
@@ -178,26 +180,9 @@ typedef enum Step_Operators {
STEP_BY = 4
} SequenceByMode;
typedef enum Sequence_Decoded {
- NoneArg, NumericArg, LseqKeywordArg, ByKeywordArg
+ NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg
} SequenceDecoded;
-/*
- * The structure used for the AirthSeries internal representation.
- * Note that the len can, in theory, always be computed by start,end,step
- * but it's faster to cache it inside the internal representation.
- */
-typedef struct ArithSeries {
- Tcl_WideInt start; /* first (left most) value */
- Tcl_WideInt end; /* last (right most or greater) value */
- Tcl_WideInt step; /* increment value */
- Tcl_WideInt len; /* total number of elements in list (has priority
- ** over "end") */
- Tcl_Obj **elements; /* List elements array, only used when absolutely
- ** necessary. */
-} ArithSeries;
-
-
-
/*
*----------------------------------------------------------------------
@@ -3952,496 +3937,13 @@ Tcl_LsearchObjCmd(
}
return result;
}
-
-/*
- * The structure below defines the arithmetic series Tcl Obj Type by means of
- * procedures that can be invoked by generic object code.
- *
- * The arithmetic series object is a Tcl_AbstractList 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 list's 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.
- */
-
-Tcl_Obj *Tcl_NewArithSeriesObj(int objc, Tcl_Obj *objv[]);
-Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
-Tcl_Obj*Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index);
-Tcl_Obj *TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx);
-Tcl_Obj *TclArithSeriesObjReverse(Tcl_Obj *arithSeriesObjPtr);
-int TclArithSeriesGetElements(Tcl_Interp *interp, Tcl_Obj *arithSeriesObjPtr,
- int *objcPtr, Tcl_Obj ***objvPtr);
-static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
-
-#define ArithSeriesIndexM(arithSeriesPtr, index) \
- (arithSeriesPtr)->start+((index) * (arithSeriesPtr)->step)
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 infiite.
- *
- * 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupArithSeriesRep --
- *
- * Initialize the internal representation of a ArithSeries abstract list
- * 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 AbstractList structure.
- *----------------------------------------------------------------------
- */
-
-static void
-DupArithSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
-{
- ArithSeries *srcArithSeries = (ArithSeries*)Tcl_AbstractListGetConcreteRep(srcPtr);
- ArithSeries *copyArithSeries = (ArithSeries *)ckalloc(sizeof(ArithSeries));
-
- *copyArithSeries = *srcArithSeries;
-
- /* Note: we do not have to be worry about existing internal rep because
- copyPtr is supposed to be freshly initialized */
- Tcl_AbstractListSetConcreteRep(copyPtr, copyArithSeries);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeArithSeriesRep --
- *
- * Free any allocated memory in the ArithSeries Rep
- *
- * Results:
- * None.
- *
- * Side effects:
- *
- *----------------------------------------------------------------------
- */
-static void FreeArithSeriesRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */
-{
- ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
- if (arithSeriesPtr) {
- if (arithSeriesPtr->elements) {
- ckfree((char*)arithSeriesPtr->elements);
- arithSeriesPtr->elements = NULL;
- }
- ckfree((char*)arithSeriesPtr);
- }
-}
-
-
-
-static Tcl_AbstractListType arithSeriesType = {
- TCL_ABSTRACTLIST_VERSION_1,
- "arithseries",
- Tcl_NewArithSeriesObj,
- DupArithSeriesRep,
- Tcl_ArithSeriesObjLength,
- Tcl_ArithSeriesObjIndex,
- TclArithSeriesObjRange,
- TclArithSeriesObjReverse,
- TclArithSeriesGetElements,
- FreeArithSeriesRep,
- UpdateStringOfArithSeries
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * TclNewArithSeriesObj --
- *
- * 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 *
-TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len)
-{
- Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step));
- ArithSeries *arithSeriesPtr;
- Tcl_Obj *arithSeriesObj;
-
- if (length <= 0) {
- TclNewObj(arithSeriesObj);
- return arithSeriesObj;
- }
-
- /* Allocate internal representation */
- arithSeriesPtr = (ArithSeries*)ckalloc(sizeof(ArithSeries));
- arithSeriesPtr->start = start;
- arithSeriesPtr->end = end;
- arithSeriesPtr->step = step;
- arithSeriesPtr->len = length;
- arithSeriesPtr->elements = NULL;
-
- /* Store the internal rep in a new AbstrictList Tcl_Obj */
- arithSeriesObj = Tcl_NewAbstractListObj(NULL, &arithSeriesType);
- Tcl_AbstractListSetConcreteRep(arithSeriesObj,arithSeriesPtr);
-
- if (length == 0) {
- Tcl_InitStringRep(arithSeriesObj, NULL, 0);
- }
- return arithSeriesObj;
-}
-
-Tcl_Obj *
-Tcl_NewArithSeriesObj(int objc, Tcl_Obj *objv[])
-{
- Tcl_WideInt start, end, step, len;
-
- if (objc != 4) return NULL;
- if (Tcl_GetWideIntFromObj(NULL, objv[0], &start) != TCL_OK) return NULL;
- if (Tcl_GetWideIntFromObj(NULL, objv[1], &end) != TCL_OK) return NULL;
- if (Tcl_GetWideIntFromObj(NULL, objv[2], &step) != TCL_OK) return NULL;
- if (Tcl_GetWideIntFromObj(NULL, objv[3], &len) != TCL_OK) return NULL;
-
- return TclNewArithSeriesObj(start, end, step, len);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ArithSeriesObjIndex --
- *
- * Returns the element with the specified index in the list
- * represented by the specified Arithmentic 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 succes, TCL_ERROR on index out of range.
- *
- * Side Effects:
- *
- * On success, the integer pointed by *element is modified.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj*
-Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesObjPtr, Tcl_WideInt index)
-{
- ArithSeries *arithSeriesPtr;
- Tcl_WideInt element;
-
- assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
-
- arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
-
- if (index < 0 || index >= arithSeriesPtr->len)
- return NULL;
-
- /* List[i] = Start + (Step * i) */
- element = ArithSeriesIndexM(arithSeriesPtr, index);
-
- return Tcl_NewWideIntObj(element);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ArithSeriesObjLength
- *
- * Returns the length of the arithmentic series.
- *
- * Results:
- *
- * The length of the series as Tcl_WideInt.
- *
- * Side Effects:
- *
- * None.
- *
- *----------------------------------------------------------------------
- */
-Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesObjPtr)
-{
- assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
-
- ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
- return arithSeriesPtr->len;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 *arithSeriesObjPtr, /* List object to take a range from. */
- Tcl_WideInt fromIdx, /* Index of first element to include. */
- Tcl_WideInt toIdx) /* Index of last element to include. */
-{
-
- ArithSeries *arithSeriesPtr;
- Tcl_WideInt start = -1, end = -1, step, len;
-
- assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
- arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
-
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (fromIdx > toIdx) {
- Tcl_Obj *obj;
- TclNewObj(obj);
- return obj;
- }
-
- start = ArithSeriesIndexM(arithSeriesPtr, fromIdx);
- end = ArithSeriesIndexM(arithSeriesPtr, toIdx);
- step = arithSeriesPtr->step;
- len = ArithSeriesLen(start, end, step);
-
- if (Tcl_IsShared(arithSeriesObjPtr) ||
- ((arithSeriesObjPtr->refCount > 1))) {
- return TclNewArithSeriesObj(start, end, step, len);
- }
-
- /*
- * In-place is possible.
- */
-
- /*
- * Even if nothing below cause any changes, we still want the
- * string-canonizing effect of [lrange 0 end].
- */
-
- TclInvalidateStringRep(arithSeriesObjPtr);
-
- arithSeriesPtr->start = start;
- arithSeriesPtr->end = end;
- arithSeriesPtr->step = step;
- arithSeriesPtr->len = len;
-
- return arithSeriesObjPtr;
-}
-
-/*
- * Handle ArithSeries special case - don't shimmer a series into a list
- * just to reverse it.
- */
-Tcl_Obj *
-TclArithSeriesObjReverse(
- Tcl_Obj *arithSeriesObjPtr) /* List object to take a range from. */
-{
- ArithSeries *arithSeriesPtr;
- Tcl_Obj *resultObjPtr;
- Tcl_WideInt rstart, rend, rstep, len;
-
- assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
- arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
-
- len = arithSeriesPtr->len;
- rend = ArithSeriesIndexM(arithSeriesPtr, 0);
- rstart = ArithSeriesIndexM(arithSeriesPtr, (len-1));
- rstep = -arithSeriesPtr->step;
-
- if (Tcl_IsShared(arithSeriesObjPtr)) {
- resultObjPtr = TclNewArithSeriesObj(rstart, rend, rstep, len);
- } else {
- arithSeriesPtr->start = rstart;
- arithSeriesPtr->end = rend;
- arithSeriesPtr->step = rstep;
- TclInvalidateStringRep(arithSeriesObjPtr);
- resultObjPtr = arithSeriesObjPtr;
- }
- return resultObjPtr;
-}
-/*
-** Handle ArithSeries GetElements call
-*/
-
-int
-TclArithSeriesGetElements(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *arithSeriesObjPtr, /* ArithSeries 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(arithSeriesObjPtr,&tclAbstractListType)) {
- ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
- Tcl_AbstractListType *typePtr;
- Tcl_Obj **objv;
- int i, objc;
-
- typePtr = Tcl_AbstractListGetType(arithSeriesObjPtr);
-
- objc = Tcl_ArithSeriesObjLength(arithSeriesObjPtr);
-
- if (objvPtr == NULL) {
- if (objcPtr) {
- *objcPtr = objc;
- return TCL_OK;
- }
- return TCL_ERROR;
- }
-
- if (objc && objvPtr && arithSeriesPtr->elements) {
- objv = arithSeriesPtr->elements;
- } else if (objc > 0) {
- 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;
- }
- for (i = 0; i < objc; i++) {
- objv[i] = typePtr->indexProc(arithSeriesObjPtr, i);
- }
- } else {
- objv = NULL;
- }
- arithSeriesPtr->elements = objv;
- *objvPtr = objv;
- *objcPtr = objc;
- } else {
- if (interp != NULL) {
- Tcl_SetObjResult(
- interp,
- Tcl_ObjPrintf("value is not an abstract list"));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
- }
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-static void
-UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr)
-{
- char *p, *str;
- Tcl_Obj *eleObj;
- Tcl_WideInt length = 0;
- int llen, slen, i;
-
-
- /*
- * Pass 1: estimate space.
- */
- llen = Tcl_ArithSeriesObjLength(arithSeriesObjPtr);
- if (llen <= 0) {
- Tcl_InitStringRep(arithSeriesObjPtr, NULL, 0);
- return;
- }
- for (i = 0; i < llen; i++) {
- eleObj = Tcl_ArithSeriesObjIndex(arithSeriesObjPtr, i);
- Tcl_GetStringFromObj(eleObj, &slen);
- length += slen + 1; /* one more for the space char */
- Tcl_DecrRefCount(eleObj);
- }
-
- /*
- * Pass 2: generate the string repr.
- */
-
- p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, length);
- for (i = 0; i < llen; i++) {
- eleObj = Tcl_ArithSeriesObjIndex(arithSeriesObjPtr, i);
- str = Tcl_GetStringFromObj(eleObj, &slen);
- strcpy(p, str);
- p[slen] = ' ';
- p += slen+1;
- Tcl_DecrRefCount(eleObj);
- }
- if (length > 0) arithSeriesObjPtr->bytes[length-1] = '\0';
- arithSeriesObjPtr->length = length-1;
-}
/*
*----------------------------------------------------------------------
*
* SequenceIdentifyArgument --
+ * (for [lseq] command)
*
* Given a Tcl_Obj, identify if it is a keyword or a number
*
@@ -4459,43 +3961,66 @@ static SequenceDecoded
SequenceIdentifyArgument(
Tcl_Interp *interp, /* for error reporting */
Tcl_Obj *argPtr, /* Argument to decode */
- Tcl_WideInt *intValuePtr, /* Return numeric value */
+ Tcl_Obj **numValuePtr, /* Return numeric value */
int *keywordIndexPtr) /* Return keyword enum */
{
int status;
- Tcl_WideInt number;
SequenceOperators opmode;
SequenceByMode bymode;
+ union {
+ Tcl_WideInt i;
+ double d;
+ } nvalue;
- status = Tcl_GetWideIntFromObj(NULL, argPtr, &number);
- if (status != TCL_OK) {
+ 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 (intValuePtr) {
- *intValuePtr = value;
+ if (numValuePtr) {
+ *numValuePtr = exprValueObj;
+ }
+ if (keywordIndexPtr) {
+ *keywordIndexPtr = keyword ;// type of expression result
}
return NumericArg;
}
- } else {
- if (intValuePtr) {
- *intValuePtr = number;
- }
- return NumericArg;
}
status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations,
- "lseq operation", 0, &opmode);
+ "range operation", 0, &opmode);
if (status == TCL_OK) {
if (keywordIndexPtr) {
*keywordIndexPtr = opmode;
}
- return LseqKeywordArg;
+ return RangeKeywordArg;
}
status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords,
@@ -4514,8 +4039,8 @@ SequenceIdentifyArgument(
*
* Tcl_LseqObjCmd --
*
- * This procedure is invoked to process the "lseq" Tcl command. See
- * the user documentation for details on what it does.
+ * This procedure is invoked to process the "lseq" Tcl command.
+ * See the user documentation for details on what it does.
*
* Enumerated possible argument patterns:
*
@@ -4552,14 +4077,19 @@ Tcl_LseqObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- Tcl_WideInt elementCount = -1;
- Tcl_WideInt start = 0, end = 0, step = 0, number = 0;
+ Tcl_Obj *elementCount = NULL;
+ Tcl_Obj *start = NULL, *end = NULL, *step = NULL;
Tcl_WideInt values[5];
- int status, keyword;
+ 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
@@ -4571,7 +4101,8 @@ Tcl_LseqObjCmd(
arg_key=0;
} else for (i=1; i<objc; i++) {
arg_key = (arg_key * 10);
- decoded = SequenceIdentifyArgument(interp, objv[i], &number, &keyword);
+ numValues[value_i] = NULL;
+ decoded = SequenceIdentifyArgument(interp, objv[i], &numberObj, &keyword);
switch (decoded) {
case NoneArg:
@@ -4585,12 +4116,15 @@ Tcl_LseqObjCmd(
case NumericArg:
arg_key += NumericArg;
- values[value_i] = number;
+ 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 LseqKeywordArg:
- arg_key += LseqKeywordArg;
+ case RangeKeywordArg:
+ arg_key += RangeKeywordArg;
values[value_i] = keyword;
value_i++;
break;
@@ -4624,171 +4158,138 @@ Tcl_LseqObjCmd(
/* lseq n */
case 1:
- start = 0;
- elementCount = (values[0] <= 0 ? 0 : values[0]);
- end = values[0]-1;
- step = 1;
- break;
+ start = zero;
+ elementCount = numValues[0];
+ end = NULL;
+ step = one;
+ break;
/* lseq n n */
case 11:
- start = values[0];
- end = values[1];
- step = (start <= end) ? 1 : -1;
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- if (elementCount < 0) elementCount = 0;
- break;
+ start = numValues[0];
+ end = numValues[1];
+ break;
/* lseq n n n */
case 111:
- start = values[0];
- end = values[1];
- step = values[2];
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- if (elementCount < 0) elementCount = 0;
- break;
+ start = numValues[0];
+ end = numValues[1];
+ step = numValues[2];
+ break;
/* lseq n 'to' n */
/* lseq n 'count' n */
/* lseq n 'by' n */
case 121:
- opmode = (SequenceOperators)values[1];
- switch (opmode) {
- case LSEQ_DOTS:
- case LSEQ_TO:
- start = values[0];
- end = values[2];
- step = (start <= end) ? 1 : -1;
- elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list
- break;
- case LSEQ_BY:
- start = 0;
- elementCount = values[0];
- step = values[2];
- end = start + (step * elementCount);
- break;
- case LSEQ_COUNT:
- start = values[0];
- elementCount = (values[2] >= 0 ? values[2] : 0);
- step = 1;
- end = start + (step * elementCount);
- 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_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;
/* lseq n 'to' n n */
/* lseq n 'count' n n */
case 1211:
- opmode = (SequenceOperators)values[1];
- switch (opmode) {
- case LSEQ_DOTS:
- case LSEQ_TO:
- start = values[0];
- end = values[2];
- step = values[3];
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- break;
- case LSEQ_COUNT:
- start = values[0];
- elementCount = (values[2] >= 0 ? values[2] : 0);
- step = values[3];
- if (step != 0) {
- end = start + (step * elementCount);
- } else {
- end = start;
- elementCount = 0; /* empty list when step 0 */
- }
- break;
- case LSEQ_BY:
- /* Error case */
- status = TCL_ERROR;
- goto done;
- break;
- default:
- status = TCL_ERROR;
- goto done;
- break;
- }
- break;
+ 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;
/* lseq n n 'by' n */
case 1121:
- start = values[0];
- end = values[1];
- opmode = (SequenceOperators)values[2];
- switch (opmode) {
- case LSEQ_BY:
- step = values[3];
- break;
- case LSEQ_DOTS:
- case LSEQ_TO:
- case LSEQ_COUNT:
- default:
- status = TCL_ERROR;
- goto done;
- break;
- }
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- break;
+ 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;
/* lseq n 'to' n 'by' n */
/* lseq n 'count' n 'by' n */
case 12121:
- start = values[0];
- opmode = (SequenceOperators)values[3];
- switch (opmode) {
- case LSEQ_BY:
- step = values[4];
- break;
- default:
- status = TCL_ERROR;
- goto done;
- break;
- }
- opmode = (SequenceOperators)values[1];
- switch (opmode) {
- case LSEQ_DOTS:
- case LSEQ_TO:
- start = values[0];
- end = values[2];
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- break;
- case LSEQ_COUNT:
- start = values[0];
- elementCount = (values[2] >= 0 ? values[2] : 0);
- if (step != 0) {
- end = start + (step * elementCount);
- } else {
- end = start;
- elementCount = 0; /* empty list when step is 0 */
- }
- break;
- default:
- status = TCL_ERROR;
- goto done;
- break;
- }
- break;
+ 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)(int)values[1];
- status = TCL_ERROR;
- goto KeywordError;
- break;
+ opmode = (SequenceOperators)values[1]; goto KeywordError; break;
case 112:
- opmode = (SequenceOperators)(int)values[2];
- status = TCL_ERROR;
- goto KeywordError;
- break;
+ opmode = (SequenceOperators)values[2]; goto KeywordError; break;
case 1212:
- opmode = (SequenceOperators)(int)values[3];
- status = TCL_ERROR;
- goto KeywordError;
- break;
+ opmode = (SequenceOperators)values[3]; goto KeywordError; break;
KeywordError:
status = TCL_ERROR;
switch (opmode) {
@@ -4813,7 +4314,6 @@ Tcl_LseqObjCmd(
/* All other argument errors */
default:
Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
- status = TCL_ERROR;
goto done;
break;
}
@@ -4821,11 +4321,21 @@ Tcl_LseqObjCmd(
/*
* Success! Now lets create the series object.
*/
- arithSeriesPtr = TclNewArithSeriesObj(start, end, step, elementCount);
+ 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;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 38927dc..89e74a2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3094,7 +3094,7 @@ struct Tcl_LoadHandle_ {
*/
MODULE_SCOPE Tcl_Obj * TclAbstractListObjCopy(Tcl_Interp *interp,
- Tcl_Obj *arithSeriesPtr);
+ Tcl_Obj *abstractListObjPtr);
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, int len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
diff --git a/tests/lseq.test b/tests/lseq.test
index 0919813..4c837ba 100644
--- a/tests/lseq.test
+++ b/tests/lseq.test
@@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-testConstraint arithSeriesDouble 0
+testConstraint arithSeriesDouble 1
testConstraint arithSeriesShimmer 1
testConstraint arithSeriesShimmerOk 0
@@ -71,23 +71,35 @@ test lseq-1.11 {error case: increasing wrong step direction} {
test lseq-1.12 {decreasing lseq with step} arithSeriesDouble {
lseq 25. to -25. by -5
-} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0}
+} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0}
-test lseq-1.13 {count operation} -body {
- lseq 5 count 5
-} -result {5 6 7 8 9}
+test lseq-1.13 {count operation} {
+ -body {
+ lseq 5 count 5
+ }
+ -result {5 6 7 8 9}
+}
-test lseq-1.14 {count with step} -body {
- lseq 5 count 5 by 2
-} -result {5 7 9 11 13}
+test lseq-1.14 {count with step} {
+ -body {
+ lseq 5 count 5 by 2
+ }
+ -result {5 7 9 11 13}
+}
-test lseq-1.15 {count with decreasing step} -body {
- lseq 5 count 5 by -2
-} -result {5 3 1 -1 -3}
+test lseq-1.15 {count with decreasing step} {
+ -body {
+ lseq 5 count 5 by -2
+ }
+ -result {5 3 1 -1 -3}
+}
-test lseq-1.16 {large numbers} -body {
- lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
-} -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
+test lseq-1.16 {large numbers} {
+ -body {
+ lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
+ }
+ -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
+}
test lseq-1.17 {too many arguments} -body {
lseq 12 to 24 by 2 with feeling
@@ -160,7 +172,7 @@ test lseq-2.11 {error case: increasing wrong step direction} {
test lseq-2.12 {decreasing lseq with step} arithSeriesDouble {
lseq 25. -25. -5
-} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0}
+} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0}
test lseq-2.13 {count only operation} {
lseq 5
@@ -176,7 +188,7 @@ test lseq-2.15 {count with decreasing step} {
test lseq-2.16 {large numbers} {
lseq 1e6 2e6 1e5
-} {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
+} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0}
test lseq-2.17 {large numbers} arithSeriesDouble {
lseq 1e6 2e6 1e5
@@ -382,6 +394,23 @@ test lseq-3.29 {edge case: negative count} {
lseq -15
} {}
+test lseq-3.30 {lreverse with double values} arithSeriesDouble {
+ set r [lseq 3.5 18.5 1.5]
+ set a [lreverse $r]
+ join [list \
+ [lindex [tcl::unsupported::representation $r] 3] \
+ $r \
+ [lindex [tcl::unsupported::representation $a] 3] \
+ $a] \n
+} {arithseries
+3.5 5.0 6.5 8.0 9.5 11.0 12.5 14.0 15.5 17.0 18.5
+arithseries
+18.5 17.0 15.5 14.0 12.5 11.0 9.5 8.0 6.5 5.0 3.5}
+
+test lseq-3.31 {lreverse inplace with doubles} arithSeriesDouble {
+ lreverse [lseq 1.1 29.9 0.3]
+} {29.9 29.599999999999998 29.299999999999997 29.0 28.7 28.4 28.099999999999998 27.799999999999997 27.5 27.2 26.9 26.599999999999998 26.299999999999997 26.0 25.7 25.4 25.099999999999998 24.799999999999997 24.5 24.2 23.9 23.599999999999998 23.299999999999997 23.0 22.7 22.4 22.099999999999998 21.799999999999997 21.5 21.2 20.9 20.6 20.299999999999997 20.0 19.7 19.4 19.1 18.799999999999997 18.5 18.2 17.9 17.6 17.299999999999997 17.0 16.7 16.4 16.1 15.799999999999999 15.5 15.2 14.899999999999999 14.6 14.299999999999999 14.0 13.7 13.399999999999999 13.099999999999998 12.8 12.5 12.2 11.899999999999999 11.599999999999998 11.3 11.0 10.7 10.399999999999999 10.099999999999998 9.8 9.5 9.2 8.899999999999999 8.599999999999998 8.3 8.0 7.699999999999999 7.399999999999999 7.099999999999998 6.800000000000001 6.5 6.199999999999999 5.899999999999999 5.599999999999998 5.300000000000001 5.0 4.699999999999999 4.399999999999999 4.099999999999998 3.8000000000000007 3.5 3.1999999999999993 2.8999999999999986 2.599999999999998 2.3000000000000007 2.0 1.6999999999999993 1.3999999999999986 1.1000000000000014}
+
test lseq-4.1 {end expressions} {
set start 7
lseq $start $start+11
@@ -393,11 +422,61 @@ test lseq-4.2 {start expressions} {
lmap t $tl {expr {$t - $base + 60}}
} {0 10 20 30 40 50 60}
+## lseq 1 to 10 by -2
+## # -> lseq: invalid step = -2 with a = 1 and b = 10
+
+test lseq-4.3 {TIP examples} {
+ set examples {# Examples from TIP-629
+ # --- Begin ---
+ lseq 10 .. 1
+ # -> 10 9 8 7 6 5 4 3 2 1
+ lseq 1 .. 10
+ # -> 1 2 3 4 5 6 7 8 9 10
+ lseq 10 .. 1 by 2
+ # ->
+ lseq 10 .. 1 by -2
+ # -> 10 8 6 4 2
+ lseq 5.0 to 15.
+ # -> 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0
+ lseq 5.0 to 25. by 5
+ # -> 5.0 10.0 15.0 20.0 25.0
+ lseq 25. to 5. by 5
+ # ->
+ lseq 25. to 5. by -5
+ # -> 25.0 20.0 15.0 10.0 5.0
+ lseq 1 to 10 by 2
+ # -> 1 3 5 7 9
+ lseq 25. to -25. by -5
+ # -> 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0
+ lseq 5 5
+ # -> 5
+ lseq 5 5 2
+ # -> 5
+ lseq 5 5 -2
+ # -> 5
+ }
+
+ foreach {cmd expect} [split $examples \n] {
+ if {[string trim $cmd] ne ""} {
+ set cmd [string trimleft $cmd]
+ if {[string match {\#*} $cmd]} continue
+ set status [catch $cmd ans]
+ lappend res $ans
+ if {[regexp {\# -> (.*)$} $expect -> expected]} {
+ if {$expected ne $ans} {
+ lappend res [list Mismatch: $cmd -> $ans ne $expected]
+ }
+ }
+ }
+ }
+ set res
+} {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5}
+
+
# cleanup
::tcltest::cleanupTests
return
-#
# Local Variables:
# mode: tcl
# End:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 5118787..dc9ba2b 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -299,7 +299,7 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o
GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o \
- tclAbstractList.o tclAlloc.o \
+ tclAbstractList.o tclArithSeries.o tclAlloc.o \
tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \
tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \
tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \
@@ -382,6 +382,7 @@ TCL_DECLS = \
GENERIC_HDRS = \
$(GENERIC_DIR)/tcl.h \
$(GENERIC_DIR)/tclAbstractList.h \
+ $(GENERIC_DIR)/tclArithSeries.h \
$(GENERIC_DIR)/tclDecls.h \
$(GENERIC_DIR)/tclInt.h \
$(GENERIC_DIR)/tclIntDecls.h \
@@ -403,6 +404,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/regfree.c \
$(GENERIC_DIR)/regerror.c \
$(GENERIC_DIR)/tclAbstractList.c \
+ $(GENERIC_DIR)/tclArithSeries.c \
$(GENERIC_DIR)/tclAlloc.c \
$(GENERIC_DIR)/tclAssembly.c \
$(GENERIC_DIR)/tclAsync.c \
@@ -1250,6 +1252,9 @@ regerror.o: $(REGHDRS) $(GENERIC_DIR)/regerrs.h $(GENERIC_DIR)/regerror.c
tclAbstractList.o: $(GENERIC_DIR)/tclAbstractList.c $(COMPILEHDR)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAbstractList.c
+tclArithSeries.o: $(GENERIC_DIR)/tclArithSeries.c $(COMPILEHDR)
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclArithSeries.c
+
tclAppInit.o: $(UNIX_DIR)/tclAppInit.c
$(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c