Attachment "range6.patch" to
ticket [1052584fff]
added by
antirez
2004-10-26 05:00:13.
? tests/range.test.tcl
Index: generic/tcl.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tcl.decls,v
retrieving revision 1.104
diff -u -r1.104 tcl.decls
--- generic/tcl.decls 13 May 2004 12:59:20 -0000 1.104
+++ generic/tcl.decls 25 Oct 2004 21:52:17 -0000
@@ -1909,6 +1909,17 @@
declare 534 generic {
int Tcl_LimitGetGranularity(Tcl_Interp *interp, int type)
}
+declare 535 generic {
+ Tcl_Obj * Tcl_NewArithSeriesObj(Tcl_WideInt start,
+ Tcl_WideInt end, Tcl_WideInt step)
+}
+declare 536 generic {
+ int Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, int index,
+ Tcl_WideInt *element)
+}
+declare 537 generic {
+ int Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr)
+}
##############################################################################
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.133
diff -u -r1.133 tclBasic.c
--- generic/tclBasic.c 24 Oct 2004 22:25:12 -0000 1.133
+++ generic/tclBasic.c 25 Oct 2004 21:52:25 -0000
@@ -94,6 +94,7 @@
{"namespace", Tcl_NamespaceObjCmd, (CompileProc *) NULL, 1},
{"package", Tcl_PackageObjCmd, (CompileProc *) NULL, 1},
{"proc", Tcl_ProcObjCmd, (CompileProc *) NULL, 1},
+ {"range", Tcl_RangeObjCmd, (CompileProc *) NULL, 1},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, 1},
{"regsub", Tcl_RegsubObjCmd, (CompileProc *) NULL, 1},
{"rename", Tcl_RenameObjCmd, (CompileProc *) NULL, 1},
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.56
diff -u -r1.56 tclCmdAH.c
--- generic/tclCmdAH.c 21 Oct 2004 15:19:46 -0000 1.56
+++ generic/tclCmdAH.c 25 Oct 2004 21:52:28 -0000
@@ -1767,10 +1767,14 @@
goto done;
}
- result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
- &argcList[i], &argvList[i]);
- if (result != TCL_OK) {
- goto done;
+ if (argObjv[2+i*2]->typePtr != &tclArithSeriesType) {
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
+ &argcList[i], &argvList[i]);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ } else {
+ argcList[i] = Tcl_ArithSeriesObjLength(argObjv[2+i*2]);
}
j = argcList[i] / varcList[i];
@@ -1804,10 +1808,14 @@
if (result != TCL_OK) {
Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
}
- result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
- &argcList[i], &argvList[i]);
- if (result != TCL_OK) {
- Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
+ if (argObjv[2+i*2]->typePtr != &tclArithSeriesType) {
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
+ &argcList[i], &argvList[i]);
+ if (result != TCL_OK) {
+ Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
+ }
+ } else {
+ argcList[i] = Tcl_ArithSeriesObjLength(argObjv[2+i*2]);
}
for (v = 0; v < varcList[i]; v++) {
@@ -1816,7 +1824,20 @@
int isEmptyObj = 0;
if (k < argcList[i]) {
- valuePtr = argvList[i][k];
+ if (argObjv[2+i*2]->typePtr != &tclArithSeriesType) {
+ valuePtr = argvList[i][k];
+ } else {
+ ArithSeries *arithSeriesRepPtr =
+ argObjv[2+i*2]->internalRep.twoPtrValue.ptr1;
+
+ if (arithSeriesRepPtr->flags & TCL_ARITHSERIES_IS_WIDE)
+ valuePtr = Tcl_NewWideIntObj(
+ arithSeriesRepPtr->start.w +
+ (k*arithSeriesRepPtr->step.w));
+ else
+ valuePtr = Tcl_NewIntObj(arithSeriesRepPtr->start.i+
+ (k*arithSeriesRepPtr->step.i));
+ }
} else {
valuePtr = Tcl_NewObj(); /* empty string */
isEmptyObj = 1;
Index: generic/tclCmdIL.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdIL.c,v
retrieving revision 1.67
diff -u -r1.67 tclCmdIL.c
--- generic/tclCmdIL.c 25 Oct 2004 01:06:49 -0000 1.67
+++ generic/tclCmdIL.c 25 Oct 2004 21:52:35 -0000
@@ -2344,6 +2344,35 @@
if (argPtr->typePtr != &tclListType
&& TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) {
+
+ /* If the list is an arithmetic series return the
+ * computed element. */
+ if (listPtr->typePtr == &tclArithSeriesType) {
+ Tcl_Obj *valPtr;
+ int asLen;
+ Tcl_WideInt wideVal;
+
+ /* Parse the index */
+ asLen = Tcl_ArithSeriesObjLength(listPtr);
+ result = TclGetIntForIndex(interp, argPtr,
+ /*endValue*/ asLen-1, &index);
+ if (result != TCL_OK) return NULL;
+
+ /* Return the computed wideInt object */
+ if (Tcl_ArithSeriesObjIndex(listPtr, index, &wideVal) == TCL_OK)
+ {
+ if (wideVal > INT_MAX || wideVal < INT_MIN)
+ valPtr = Tcl_NewWideIntObj(wideVal);
+ else
+ valPtr = Tcl_NewIntObj((int)wideVal);
+ } else {
+ /* Index out of range case */
+ valPtr = Tcl_NewObj();
+ }
+ Tcl_IncrRefCount(valPtr);
+ return valPtr;
+ }
+
/*
* argPtr designates a single index.
*/
@@ -2728,9 +2757,13 @@
return TCL_ERROR;
}
- result = Tcl_ListObjLength(interp, objv[1], &listLen);
- if (result != TCL_OK) {
- return result;
+ if (objv[1]->typePtr == &tclArithSeriesType) {
+ listLen = Tcl_ArithSeriesObjLength(objv[1]);
+ } else {
+ result = Tcl_ListObjLength(interp, objv[1], &listLen);
+ if (result != TCL_OK) {
+ return result;
+ }
}
/*
@@ -3647,6 +3680,83 @@
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RangeObjCmd --
+ *
+ * This procedure returns a list where every element is
+ * part of an arithmetic sequence starting with the number START,
+ * incrementing the next elements of STEP, and including
+ * all the elements < END (or > END for negative steps).
+ * The command returns a specialized object able to represent
+ * this lists in constant space (the Arithmetic Sequence object type).
+ * See Tcl_ListObj.c for more information on this object.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RangeObjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument values. */
+{
+ Tcl_WideInt start = 0, end, step = 1;
+ Tcl_Obj *arithSeriesPtr;
+
+ /* Check parameter count */
+
+ if (objc < 2 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?start? end ?step?");
+ return TCL_ERROR;
+ }
+
+ /* Get the start, end, step parameters from arguments */
+ if (objc == 2) {
+ if (Tcl_GetWideIntFromObj(interp, objv[1], &end) != TCL_OK)
+ return TCL_ERROR;
+ } else if (objc >= 3) {
+ if (Tcl_GetWideIntFromObj(interp, objv[1], &start) != TCL_OK ||
+ Tcl_GetWideIntFromObj(interp, objv[2], &end) != TCL_OK)
+ return TCL_ERROR;
+ if (objc == 4 &&
+ Tcl_GetWideIntFromObj(interp, objv[3], &step) != TCL_OK)
+ return TCL_ERROR;
+ }
+
+ /* Create the arithmetic series object, checking if the
+ * parameters are invalid. */
+
+ arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step);
+ if (arithSeriesPtr == NULL) {
+ Tcl_AppendResult(interp,
+ "Invalid (infinite?) arithmetic sequence specified", NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_IncrRefCount(arithSeriesPtr); /* we may use DecrRefCount to free it */
+ if (Tcl_ArithSeriesObjLength(arithSeriesPtr) > INT_MAX/sizeof(Tcl_Obj *)) {
+ Tcl_DecrRefCount(arithSeriesPtr);
+ Tcl_AppendResult(interp, "overflow of maximum list length", NULL);
+ return TCL_ERROR;
+ }
+
+ /* Return the new object. */
+
+ Tcl_SetObjResult(interp, arithSeriesPtr);
+ Tcl_DecrRefCount(arithSeriesPtr);
+ return TCL_OK;
+}
+
/*
*----------------------------------------------------------------------
*
Index: generic/tclDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclDecls.h,v
retrieving revision 1.105
diff -u -r1.105 tclDecls.h
--- generic/tclDecls.h 7 Jun 2004 16:48:44 -0000 1.105
+++ generic/tclDecls.h 25 Oct 2004 21:52:48 -0000
@@ -3314,6 +3314,25 @@
EXTERN int Tcl_LimitGetGranularity _ANSI_ARGS_((
Tcl_Interp * interp, int type));
#endif
+#ifndef Tcl_NewArithSeriesObj_TCL_DECLARED
+#define Tcl_NewArithSeriesObj_TCL_DECLARED
+/* 535 */
+EXTERN Tcl_Obj * Tcl_NewArithSeriesObj _ANSI_ARGS_((Tcl_WideInt start,
+ Tcl_WideInt end, Tcl_WideInt step));
+#endif
+#ifndef Tcl_ArithSeriesObjIndex_TCL_DECLARED
+#define Tcl_ArithSeriesObjIndex_TCL_DECLARED
+/* 536 */
+EXTERN int Tcl_ArithSeriesObjIndex _ANSI_ARGS_((
+ Tcl_Obj * arithSeriesPtr, int index,
+ Tcl_WideInt * element));
+#endif
+#ifndef Tcl_ArithSeriesObjLength_TCL_DECLARED
+#define Tcl_ArithSeriesObjLength_TCL_DECLARED
+/* 537 */
+EXTERN int Tcl_ArithSeriesObjLength _ANSI_ARGS_((
+ Tcl_Obj * arithSeriesPtr));
+#endif
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -3890,6 +3909,9 @@
int (*tcl_LimitGetCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 532 */
void (*tcl_LimitGetTime) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Time * timeLimitPtr)); /* 533 */
int (*tcl_LimitGetGranularity) _ANSI_ARGS_((Tcl_Interp * interp, int type)); /* 534 */
+ Tcl_Obj * (*tcl_NewArithSeriesObj) _ANSI_ARGS_((Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)); /* 535 */
+ int (*tcl_ArithSeriesObjIndex) _ANSI_ARGS_((Tcl_Obj * arithSeriesPtr, int index, Tcl_WideInt * element)); /* 536 */
+ int (*tcl_ArithSeriesObjLength) _ANSI_ARGS_((Tcl_Obj * arithSeriesPtr)); /* 537 */
} TclStubs;
#ifdef __cplusplus
@@ -6070,6 +6092,18 @@
#define Tcl_LimitGetGranularity \
(tclStubsPtr->tcl_LimitGetGranularity) /* 534 */
#endif
+#ifndef Tcl_NewArithSeriesObj
+#define Tcl_NewArithSeriesObj \
+ (tclStubsPtr->tcl_NewArithSeriesObj) /* 535 */
+#endif
+#ifndef Tcl_ArithSeriesObjIndex
+#define Tcl_ArithSeriesObjIndex \
+ (tclStubsPtr->tcl_ArithSeriesObjIndex) /* 536 */
+#endif
+#ifndef Tcl_ArithSeriesObjLength
+#define Tcl_ArithSeriesObjLength \
+ (tclStubsPtr->tcl_ArithSeriesObjLength) /* 537 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
Index: generic/tclExecute.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclExecute.c,v
retrieving revision 1.161
diff -u -r1.161 tclExecute.c
--- generic/tclExecute.c 25 Oct 2004 01:06:49 -0000 1.161
+++ generic/tclExecute.c 25 Oct 2004 21:52:58 -0000
@@ -2600,13 +2600,17 @@
valuePtr = *tosPtr;
- result = Tcl_ListObjLength(interp, valuePtr, &length);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
+ if (valuePtr->typePtr == &tclArithSeriesType) {
+ objResultPtr = Tcl_NewIntObj(Tcl_ArithSeriesObjLength(valuePtr));
+ } else {
+ result = Tcl_ListObjLength(interp, valuePtr, &length);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
+ objResultPtr = Tcl_NewIntObj(length);
}
- objResultPtr = Tcl_NewIntObj(length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
}
@@ -2649,6 +2653,7 @@
int listc, idx, opnd;
Tcl_Obj **listv;
Tcl_Obj *valuePtr;
+ ArithSeries *arithSeriesRepPtr = NULL;
/*
* Pop the list and get the index
@@ -2658,13 +2663,20 @@
/*
* Get the contents of the list, making sure that it
- * really is a list in the process.
+ * really is a list in the process. Special case for arithmetic
+ * series.
*/
- result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
+ if (valuePtr->typePtr == &tclArithSeriesType) {
+ arithSeriesRepPtr = (ArithSeries*)
+ valuePtr->internalRep.twoPtrValue.ptr1;
+ listc = arithSeriesRepPtr->len;
+ } else {
+ result = Tcl_ListObjGetElements(interp, valuePtr, &listc, &listv);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
+ Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
}
/*
@@ -4552,6 +4564,7 @@
int numLists;
Tcl_Obj *listPtr,*valuePtr, *value2Ptr;
List *listRepPtr;
+ ArithSeries *arithSeriesRepPtr;
Var *iterVarPtr, *listVarPtr;
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
@@ -4586,7 +4599,12 @@
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
- result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ if (listPtr->typePtr == &tclArithSeriesType) {
+ listLen = Tcl_ArithSeriesObjLength(listPtr);
+ result = TCL_OK; /* Tcl_ArithSeriesLength can't fail */
+ } else {
+ result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ }
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
@@ -4602,7 +4620,7 @@
* If some var in some var list still has a remaining list
* element iterate one more time. Assign to var the next
* element from its value list. We already checked above
- * that each list temp holds a valid list object.
+ * that each list temp holds a valid list or range object.
*/
if (continueLoop) {
@@ -4614,24 +4632,55 @@
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
- listLen = listRepPtr->elemCount;
+ arithSeriesRepPtr = (ArithSeries *) listRepPtr;
+ if (listPtr->typePtr == &tclListType) {
+ listLen = listRepPtr->elemCount;
+ } else {
+ listLen = arithSeriesRepPtr->len;
+ }
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
int setEmptyStr = 0;
- if (valIndex >= listLen) {
- setEmptyStr = 1;
- TclNewObj(valuePtr);
- } else {
- valuePtr = listRepPtr->elements[valIndex];
- }
-
+
varIndex = varListPtr->varIndexes[j];
varPtr = &(compiledLocals[varIndex]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
+ if (valIndex >= listLen) {
+ setEmptyStr = 1;
+ TclNewObj(valuePtr);
+ } else {
+ if(listPtr->typePtr == &tclListType) {
+ valuePtr = listRepPtr->elements[valIndex];
+ } else {
+ /*
+ * It is a rangeType Tcl_Obj!
+ *
+ * If the variable can be accessed inline and
+ * its value is unshared we modify it in
+ * place; otherwise we create a new Tcl_Obj.
+ */
+
+ valuePtr = varPtr->value.objPtr;
+ if (!TclIsVarDirectWritable(varPtr) || !valuePtr || Tcl_IsShared(valuePtr)) {
+ TclNewObj(valuePtr);
+ }
+
+ if (arithSeriesRepPtr->flags & TCL_ARITHSERIES_IS_WIDE) {
+ Tcl_SetWideIntObj(valuePtr,
+ arithSeriesRepPtr->start.w +
+ (valIndex*arithSeriesRepPtr->step.w));
+ } else {
+ Tcl_SetIntObj(valuePtr,
+ arithSeriesRepPtr->start.i +
+ (valIndex*arithSeriesRepPtr->step.i));
+ }
+ }
+ }
+
if (TclIsVarDirectWritable(varPtr)) {
value2Ptr = varPtr->value.objPtr;
if (valuePtr != value2Ptr) {
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.187
diff -u -r1.187 tclInt.h
--- generic/tclInt.h 25 Oct 2004 01:06:51 -0000 1.187
+++ generic/tclInt.h 25 Oct 2004 21:53:04 -0000
@@ -1569,6 +1569,29 @@
} List;
/*
+ * 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.
+ */
+#define TCL_ARITHSERIES_IS_WIDE 1
+typedef struct ArithSeries {
+ union {
+ int i;
+ Tcl_WideInt w;
+ } start;
+ union {
+ int i;
+ Tcl_WideInt w;
+ } end;
+ union {
+ int i;
+ Tcl_WideInt w;
+ } step;
+ int len;
+ int flags;
+} ArithSeries;
+
+/*
*----------------------------------------------------------------
* Data structures related to the filesystem internals
*----------------------------------------------------------------
@@ -1674,6 +1697,7 @@
extern Tcl_ObjType tclEndOffsetType;
extern Tcl_ObjType tclIntType;
extern Tcl_ObjType tclListType;
+extern Tcl_ObjType tclArithSeriesType;
extern Tcl_ObjType tclDictType;
extern Tcl_ObjType tclProcBodyType;
extern Tcl_ObjType tclStringType;
@@ -2094,6 +2118,8 @@
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_RangeObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData,
Index: generic/tclListObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclListObj.c,v
retrieving revision 1.19
diff -u -r1.19 tclListObj.c
--- generic/tclListObj.c 29 Sep 2004 22:17:30 -0000 1.19
+++ generic/tclListObj.c 25 Oct 2004 21:53:07 -0000
@@ -1566,6 +1566,39 @@
List *listRepPtr;
/*
+ * Convertion from Arithmetic Series is a special case
+ * because it can be done an order of magnitude faster
+ * and may occur frequently.
+ */
+ if (objPtr->typePtr == &tclArithSeriesType) {
+ Tcl_WideInt wideLen = Tcl_ArithSeriesObjLength(objPtr), j;
+ ArithSeries *arithSeriesRepPtr = (ArithSeries*)
+ objPtr->internalRep.twoPtrValue.ptr1;
+
+ elemPtrs = (Tcl_Obj**) ckalloc(sizeof(Tcl_Obj*)*wideLen);
+ for (j = 0; j < wideLen; j++) {
+ if (arithSeriesRepPtr->flags & TCL_ARITHSERIES_IS_WIDE)
+ elemPtrs[j] = Tcl_NewWideIntObj(
+ arithSeriesRepPtr->start.w +
+ (j*arithSeriesRepPtr->step.w));
+ else
+ elemPtrs[j] = Tcl_NewIntObj(
+ arithSeriesRepPtr->start.i +
+ (j*arithSeriesRepPtr->step.i));
+ }
+ listRepPtr = (List *) ckalloc(sizeof(List));
+ listRepPtr->maxElemCount = wideLen;
+ listRepPtr->elemCount = wideLen;
+ listRepPtr->elements = elemPtrs;
+
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclListType;
+ return TCL_OK;
+ }
+
+ /*
* Get the string representation. Make it up-to-date if necessary.
*/
@@ -1733,3 +1766,395 @@
}
listPtr->length = dst - listPtr->bytes;
}
+
+/* -------------------------- ArithSeries object ---------------------------- */
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void DupArithSeriesInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static void FreeArithSeriesInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
+static int SetArithSeriesFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static void UpdateStringOfArithSeries _ANSI_ARGS_((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 STEP is 0: ERROR
+ * else if START is the same as END: OUTPUT 0
+ * else if STEP is POSITIVE and START > END: ERROR
+ * else if STEP is NEGATIVE and END > START: ERROR
+ * else OUTPUT 1+((ABS(END-START)-1)/ABS(STEP))
+ *
+ * And where the I-th element of the range is:
+ *
+ * ELEMENTS[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_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 infiite.
+ *
+ * Side effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
+{
+ Tcl_WideInt len;
+
+ if (step == 0) return -1;
+ if (start == end) return 0;
+ else if (step > 0 && start > end) return -1;
+ else if (step < 0 && end > start) return -1;
+ len = end-start;
+ if (len < 0) len = -len; /* abs(len) */
+ if (step < 0) step = -step; /* abs(step) */
+ len = 1 + ((len-1)/step);
+ /* We can truncate safely to INT_MAX, the range command
+ * will always return an error for a such long range
+ * because Tcl lists can't be so long. */
+ if (len > INT_MAX) len = INT_MAX;
+ return (int)((len < 0) ? -1 : len);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
+{
+ int len = ArithSeriesLen(start, end, step);
+ Tcl_Obj *arithSeriesPtr;
+ ArithSeries *arithSeriesRepPtr;
+
+ if (len == -1) return NULL; /* Invalid range error */
+ TclNewObj(arithSeriesPtr);
+
+ arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries));
+ arithSeriesRepPtr->flags = 0;
+ if (start > INT_MAX ||
+ start < INT_MIN ||
+ end > INT_MAX ||
+ end < INT_MIN)
+ {
+ arithSeriesRepPtr->flags = TCL_ARITHSERIES_IS_WIDE;
+ arithSeriesRepPtr->start.w = start;
+ arithSeriesRepPtr->end.w = end;
+ arithSeriesRepPtr->step.w = step;
+ } else {
+ arithSeriesRepPtr->start.i = start;
+ arithSeriesRepPtr->end.i = end;
+ arithSeriesRepPtr->step.i = step;
+ }
+ arithSeriesRepPtr->len = len;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arithSeriesRepPtr;
+ arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ arithSeriesPtr->typePtr = &tclArithSeriesType;
+ if (len > 0)
+ Tcl_InvalidateStringRep(arithSeriesPtr);
+
+ return arithSeriesPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, int index, Tcl_WideInt *element)
+{
+ ArithSeries *arithSeriesRepPtr;
+
+ if (arithSeriesPtr->typePtr != &tclArithSeriesType) {
+ Tcl_Panic("Tcl_ArithSeriesObjIndex called with a not ArithSeries Obj.");
+ }
+ arithSeriesRepPtr = (ArithSeries*)
+ arithSeriesPtr->internalRep.twoPtrValue.ptr1;
+ if (index < 0 || index >= arithSeriesRepPtr->len)
+ return TCL_ERROR;
+ /* List[i] = Start + (Step * i) */
+ if (arithSeriesRepPtr->flags & TCL_ARITHSERIES_IS_WIDE)
+ *element = arithSeriesRepPtr->start.w+(index*arithSeriesRepPtr->step.w);
+ else
+ *element = arithSeriesRepPtr->start.i+(index*arithSeriesRepPtr->step.i);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ArithSeriesObjLength
+ *
+ * Returns the length of the arithmentic series.
+ *
+ * Results:
+ *
+ * The length of the series.
+ *
+ * Side Effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int Tcl_ArithSeriesObjLength(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;
+ 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(srcPtr, copyPtr)
+ 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->start = srcArithSeriesRepPtr->start;
+ copyArithSeriesRepPtr->end = srcArithSeriesRepPtr->end;
+ copyArithSeriesRepPtr->step = srcArithSeriesRepPtr->step;
+ copyArithSeriesRepPtr->len = srcArithSeriesRepPtr->len;
+ copyArithSeriesRepPtr->flags = srcArithSeriesRepPtr->flags;
+
+ copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 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 buffer[TCL_INTEGER_SPACE+2], *p;
+ int i, length = 0, slen;
+ Tcl_WideInt ele;
+
+ /*
+ * Empty range case
+ */
+ if (arithSeriesRepPtr->len == 0) {
+ arithSeriesPtr->bytes = tclEmptyStringRep;
+ arithSeriesPtr->length = 1;
+ }
+
+ /*
+ * Pass 1: estimate space.
+ */
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ if (arithSeriesRepPtr->flags & TCL_ARITHSERIES_IS_WIDE)
+ ele = arithSeriesRepPtr->start.w + (i*arithSeriesRepPtr->step.w);
+ else
+ ele = arithSeriesRepPtr->start.i + (i*arithSeriesRepPtr->step.i);
+ /*
+ * Note that sprintf will generate a compiler warning under
+ * Mingw claiming %I64 is an unknown format specifier.
+ * Just ignore this warning. We can't use %L as the format
+ * specifier since that gets printed as a 32 bit value.
+ */
+ sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele);
+ slen = strlen(buffer) + 1; /* + 1 is for the space or the nul-term */
+ length += slen;
+ }
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = arithSeriesPtr->bytes = ckalloc(length);
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ if (arithSeriesRepPtr->flags & TCL_ARITHSERIES_IS_WIDE)
+ ele = arithSeriesRepPtr->start.w + (i*arithSeriesRepPtr->step.w);
+ else
+ ele = arithSeriesRepPtr->start.i + (i*arithSeriesRepPtr->step.i);
+ sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele);
+ slen = strlen(buffer);
+ strcpy(p, buffer);
+ p[slen] = ' ';
+ p += slen+1;
+ }
+ 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(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ Tcl_Panic("SetArithSeriesFromAny: should never be called");
+ return TCL_ERROR;
+}
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.105
diff -u -r1.105 tclStubInit.c
--- generic/tclStubInit.c 14 Oct 2004 15:06:03 -0000 1.105
+++ generic/tclStubInit.c 25 Oct 2004 21:53:09 -0000
@@ -932,6 +932,9 @@
Tcl_LimitGetCommands, /* 532 */
Tcl_LimitGetTime, /* 533 */
Tcl_LimitGetGranularity, /* 534 */
+ Tcl_NewArithSeriesObj, /* 535 */
+ Tcl_ArithSeriesObjIndex, /* 536 */
+ Tcl_ArithSeriesObjLength, /* 537 */
};
/* !END!: Do not edit above this line. */