ADDED doc/lseq.n Index: doc/lseq.n ================================================================== --- /dev/null +++ doc/lseq.n @@ -0,0 +1,81 @@ +'\" +'\" Copyright (c) 2022 Eric Taylor. All rights reserved. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH lseq n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lseq \- Build a numeric sequence returned as a list +.SH SYNOPSIS +\fBlseq \fIStart \fR?(\fB..\fR|\fBto\fR)? \fIEnd\fR ??\fBby\fR? \fIStep\fR? + +\fBlseq \fIStart \fBcount\fR \fICount\fR ??\fBby\fR? \fIStep\fR? + +\fBlseq \fICount\fR ?\fBby \fIStep\fR? +.BE +.SH DESCRIPTION +.PP +The \fBlseq\fR command creates a sequence of numeric values using the given +parameters \fIStart\fR, \fIEnd\fR, and \fIStep\fR. The \fIoperation\fR +argument ".." or "to" defines an inclusive range. The "count" option is used +to define a count of the number of elements in the list. The short form with a +single count value will create a range from 0 to count-1. + +The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR, +can also be a valid expression. the lseq command will evaluate the expression +and use the numeric result, or error as with any invalid argument value. + +.SH EXAMPLES +.CS +.\" + + lseq 3 + \(-> 0 1 2 + + lseq 3 0 + \(-> 3 2 1 0 + + lseq 10 .. 1 by -2 + \(-> 10 8 6 4 2 + + set l [lseq 0 -5] + \(-> 0 -1 -2 -3 -4 -5 + + foreach i [lseq [llength $l]] { + puts l($i)=[lindex $l $i] + } + \(-> l(0)=0 + l(1)=-1 + l(2)=-2 + l(3)=-3 + l(4)=-4 + l(5)=-5 + + foreach i [lseq [llength $l]-1 0] { + puts l($i)=[lindex $l $i] + } + \(-> l(5)=-5 + l(4)=-4 + l(3)=-3 + l(2)=-2 + l(1)=-1 + l(0)=0 + + set sqrs [lmap i [lseq 1 10] {expr $i*$i}] + \(-> 1 4 9 16 25 36 49 64 81 100 +.\" +.CE +.SH "SEE ALSO" +foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), +lreverse(n), lsearch(n), lset(n), lsort(n) +.SH KEYWORDS +element, index, list +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: ADDED generic/tclArithSeries.c Index: generic/tclArithSeries.c ================================================================== --- /dev/null +++ generic/tclArithSeries.c @@ -0,0 +1,952 @@ +/* + * tclArithSeries.c -- + * + * This file contains the ArithSeries concrete abstract list + * implementation. It implements the inner workings of the lseq command. + * + * Copyright © 2022 Brian S. Griffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" +#include "tclArithSeries.h" +#include + +/* -------------------------- ArithSeries object ---------------------------- */ + + +#define ArithSeriesRepPtr(arithSeriesObjPtr) \ + (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) + +#define ArithSeriesIndexM(arithSeriesRepPtr, index) \ + ((arithSeriesRepPtr)->isDouble ? \ + (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \ + : \ + ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step))) + +#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \ + do { \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \ + (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr); +static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); + +/* + * The structure below defines the arithmetic series Tcl object type by + * means of procedures that can be invoked by generic object code. + * + * The arithmetic series object is a special case of Tcl list representing + * an interval of an arithmetic series in constant space. + * + * The arithmetic series is internally represented with three integers, + * *start*, *end*, and *step*, Where the length is calculated with + * the following algorithm: + * + * if RANGE == 0 THEN + * ERROR + * if RANGE > 0 + * LEN is (((END-START)-1)/STEP) + 1 + * else if RANGE < 0 + * LEN is (((END-START)-1)/STEP) - 1 + * + * And where the equivalent's list I-th element is calculated + * as: + * + * LIST[i] = START+(STEP*i) + * + * Zero elements ranges, like in the case of START=10 END=10 STEP=1 + * are valid and will be equivalent to the empty list. + */ + +const Tcl_ObjType tclArithSeriesType = { + "arithseries", /* name */ + FreeArithSeriesInternalRep, /* freeIntRepProc */ + DupArithSeriesInternalRep, /* dupIntRepProc */ + UpdateStringOfArithSeries, /* updateStringProc */ + SetArithSeriesFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * ArithSeriesLen -- + * + * Compute the length of the equivalent list where + * every element is generated starting from *start*, + * and adding *step* to generate every successive element + * that's < *end* for positive steps, or > *end* for negative + * steps. + * + * Results: + * + * The length of the list generated by the given range, + * that may be zero. + * The function returns -1 if the list is of length infinite. + * + * Side effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +static Tcl_WideInt +ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) +{ + Tcl_WideInt len; + + if (step == 0) return 0; + len = (step ? (1 + (((end-start))/step)) : 0); + return (len < 0) ? -1 : len; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesInt -- + * + * Creates a new ArithSeries object. The returned object has + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +{ + Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); + Tcl_Obj *arithSeriesPtr; + ArithSeries *arithSeriesRepPtr; + + TclNewObj(arithSeriesPtr); + + if (length <= 0) { + return arithSeriesPtr; + } + + arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); + arithSeriesRepPtr->isDouble = 0; + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesPtr->typePtr = &tclArithSeriesType; + if (length > 0) + Tcl_InvalidateStringRep(arithSeriesPtr); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesDbl -- + * + * Creates a new ArithSeries object with doubles. The returned object has + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) +{ + Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); + Tcl_Obj *arithSeriesPtr; + ArithSeriesDbl *arithSeriesRepPtr; + + TclNewObj(arithSeriesPtr); + + if (length <= 0) { + return arithSeriesPtr; + } + + arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); + arithSeriesRepPtr->isDouble = 1; + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesPtr->typePtr = &tclArithSeriesType; + if (length > 0) + Tcl_InvalidateStringRep(arithSeriesPtr); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * assignNumber -- + * + * Create the appropriate Tcl_Obj value for the given numeric values. + * Used locally only for decoding [lseq] numeric arguments. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer. + * No assignment on error. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +static void +assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) +{ + union { + double d; + Tcl_WideInt i; + } *number; + int tcl_number_type; + + if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) { + return; + } + if (useDoubles) { + if (tcl_number_type == TCL_NUMBER_DOUBLE) { + *dblNumberPtr = number->d; + } else { + *dblNumberPtr = (double)number->i; + } + } else { + if (tcl_number_type == TCL_NUMBER_INT) { + *intNumberPtr = number->i; + } else { + *intNumberPtr = (Tcl_WideInt)number->d; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesObj -- + * + * Creates a new ArithSeries object. Some arguments may be NULL and will + * be computed based on the other given arguments. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created ArithSeries object. + * An empty Tcl_Obj if the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj) +{ + double dstart, dend, dstep; + Tcl_WideInt start, end, step, len; + + if (startObj) { + assignNumber(useDoubles, &start, &dstart, startObj); + } else { + start = 0; + dstart = start; + } + if (stepObj) { + assignNumber(useDoubles, &step, &dstep, stepObj); + if (useDoubles) { + step = dstep; + } else { + dstep = step; + } + if (dstep == 0) { + return Tcl_NewObj(); + } + } + if (endObj) { + assignNumber(useDoubles, &end, &dend, endObj); + } + if (lenObj) { + Tcl_GetWideIntFromObj(NULL, lenObj, &len); + } + + if (startObj && endObj) { + if (!stepObj) { + if (useDoubles) { + dstep = (dstart < dend) ? 1.0 : -1.0; + step = dstep; + } else { + step = (start < end) ? 1 : -1; + dstep = step; + } + } + assert(dstep!=0); + if (!lenObj) { + if (useDoubles) { + len = (dend - dstart + dstep)/dstep; + } else { + len = (end - start + step)/step; + } + } + } + + if (!endObj) { + if (useDoubles) { + dend = dstart + (dstep * (len-1)); + end = dend; + } else { + end = start + (step * (len-1)); + dend = end; + } + } + + if (useDoubles) { + return TclNewArithSeriesDbl(dstart, dend, dstep, len); + } else { + return TclNewArithSeriesInt(start, end, step, len); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjStep -- + * + * Return a Tcl_Obj with the step value from the give ArithSeries Obj. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +/* + * TclArithSeriesObjStep -- + */ +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj) +{ + ArithSeries *arithSeriesRepPtr; + + if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + if (arithSeriesRepPtr->isDouble) { + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + } else { + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjIndex -- + * + * Returns the element with the specified index in the list + * represented by the specified Arithmetic Sequence object. + * If the index is out of range, TCL_ERROR is returned, + * otherwise TCL_OK is returned and the integer value of the + * element is stored in *element. + * + * Results: + * + * TCL_OK on success, TCL_ERROR on index out of range. + * + * Side Effects: + * + * On success, the integer pointed by *element is modified. + * + *---------------------------------------------------------------------- + */ + +int +TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj) +{ + ArithSeries *arithSeriesRepPtr; + + if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + if (index < 0 || index >= arithSeriesRepPtr->len) { + return TCL_ERROR; + } + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } else { + *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjLength + * + * Returns the length of the arithmetic series. + * + * Results: + * + * The length of the series as Tcl_WideInt. + * + * Side Effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*) + arithSeriesPtr->internalRep.twoPtrValue.ptr1; + return arithSeriesRepPtr->len; +} + +/* + *---------------------------------------------------------------------- + * + * FreeArithSeriesInternalRep -- + * + * Deallocate the storage associated with an arithseries object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Frees arithSeriesPtr's ArithSeries* internal representation and + * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. + * + *---------------------------------------------------------------------- + */ + +static void +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + Tcl_Obj**elmts = arithSeriesRepPtr->elements; + for(i=0; ilen; i++) { + if (elmts[i]) { + Tcl_DecrRefCount(elmts[i]); + } + } + ckfree((char *) arithSeriesRepPtr->elements); + } + ckfree((char *) arithSeriesRepPtr); + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupArithSeriesInternalRep -- + * + * Initialize the internal representation of a arithseries Tcl_Obj to a + * copy of the internal representation of an existing arithseries object. + * + * Results: + * None. + * + * Side effects: + * We set "copyPtr"s internal rep to a pointer to a + * newly allocated ArithSeries structure. + *---------------------------------------------------------------------- + */ + +static void +DupArithSeriesInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +{ + ArithSeries *srcArithSeriesRepPtr = + (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *copyArithSeriesRepPtr; + + /* + * Allocate a new ArithSeries structure. */ + + copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries)); + *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; + copyArithSeriesRepPtr->elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + copyPtr->typePtr = &tclArithSeriesType; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfArithSeries -- + * + * Update the string representation for an arithseries object. + * Note: This procedure does not invalidate an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the list-to-string conversion. This string will be empty if the + * list has no elements. The list internal representation + * should not be NULL and we assume it is not NULL. + * + * Notes: + * At the cost of overallocation it's possible to estimate + * the length of the string representation and make this procedure + * much faster. Because the programmer shouldn't expect the + * string conversion of a big arithmetic sequence to be fast + * this version takes more care of space than time. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + char *elem, *p; + Tcl_Obj *elemObj; + Tcl_WideInt i; + Tcl_WideInt length = 0; + int slen; + + /* + * Pass 1: estimate space. + */ + for (i = 0; i < arithSeriesRepPtr->len; i++) { + TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elem = TclGetStringFromObj(elemObj, &slen); + Tcl_DecrRefCount(elemObj); + slen += 1; /* + 1 is for the space or the nul-term */ + length += slen; + } + + /* + * Pass 2: generate the string repr. + */ + + p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); + for (i = 0; i < arithSeriesRepPtr->len; i++) { + TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elem = TclGetStringFromObj(elemObj, &slen); + strcpy(p, elem); + p[slen] = ' '; + p += slen+1; + Tcl_DecrRefCount(elemObj); + } + if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; + arithSeriesPtr->length = length-1; +} + +/* + *---------------------------------------------------------------------- + * + * SetArithSeriesFromAny -- + * + * The Arithmetic Series object is just an way to optimize + * Lists space complexity, so no one should try to convert + * a string to an Arithmetic Series object. + * + * This function is here just to populate the Type structure. + * + * Results: + * + * The result is always TCL_ERROR. But see Side Effects. + * + * Side effects: + * + * Tcl Panic if called. + * + *---------------------------------------------------------------------- + */ + +static int +SetArithSeriesFromAny( + TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ + TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */ +{ + Tcl_Panic("SetArithSeriesFromAny: should never be called"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjCopy -- + * + * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. + * + * Results: + * + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a + * refCount of zero. If *arithSeriesPtr does not hold an arithSeries, + * NULL is returned, and if interp is non-NULL, an error message is + * recorded there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjCopy( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *arithSeriesPtr) /* List object for which an element array is + * to be returned. */ +{ + Tcl_Obj *copyPtr; + ArithSeries *arithSeriesRepPtr; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + if (NULL == arithSeriesRepPtr) { + if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) { + /* We know this is going to panic, but it's the message we want */ + return NULL; + } + } + + TclNewObj(copyPtr); + TclInvalidateStringRep(copyPtr); + DupArithSeriesInternalRep(arithSeriesPtr, copyPtr); + return copyPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjRange -- + * + * Makes a slice of an ArithSeries value. + * *arithSeriesPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced series. + * This may be a new object or the same object if not shared. + * + * Side effects: + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjRange( + Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + ArithSeries *arithSeriesRepPtr; + Tcl_Obj *startObj, *endObj, *stepObj; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (fromIdx > toIdx) { + Tcl_Obj *obj; + TclNewObj(obj); + return obj; + } + + TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); + Tcl_IncrRefCount(startObj); + TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); + Tcl_IncrRefCount(endObj); + TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + Tcl_IncrRefCount(stepObj); + + if (Tcl_IsShared(arithSeriesPtr) || + ((arithSeriesPtr->refCount > 1))) { + Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble, + startObj, endObj, stepObj, NULL); + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + return newSlicePtr; + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below causes any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(arithSeriesPtr); + + if (arithSeriesRepPtr->isDouble) { + ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesPtr; + double start, end, step; + Tcl_GetDoubleFromObj(NULL, startObj, &start); + Tcl_GetDoubleFromObj(NULL, endObj, &end); + Tcl_GetDoubleFromObj(NULL, stepObj, &step); + arithSeriesDblRepPtr->start = start; + arithSeriesDblRepPtr->end = end; + arithSeriesDblRepPtr->step = step; + arithSeriesDblRepPtr->len = (end-start+step)/step; + arithSeriesDblRepPtr->elements = NULL; + + } else { + Tcl_WideInt start, end, step; + Tcl_GetWideIntFromObj(NULL, startObj, &start); + Tcl_GetWideIntFromObj(NULL, endObj, &end); + Tcl_GetWideIntFromObj(NULL, stepObj, &step); + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = (end-start+step)/step; + arithSeriesRepPtr->elements = NULL; + } + + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesGetElements -- + * + * This function returns an (objc,objv) array of the elements in a list + * object. + * + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to an Abstract List object and the object can not be converted + * to one, TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclArithSeriesGetElements( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *objPtr, /* AbstractList object for which an element + * array is to be returned. */ + int *objcPtr, /* Where to store the count of objects + * referenced by objv. */ + Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of + * pointers to the list's objects. */ +{ + if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + ArithSeries *arithSeriesRepPtr; + Tcl_Obj **objv; + int i, objc; + + ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); + objc = arithSeriesRepPtr->len; + if (objc > 0) { + if (arithSeriesRepPtr->elements) { + /* If this exists, it has already been populated */ + objv = arithSeriesRepPtr->elements; + } else { + /* Construct the elements array */ + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); + if (objv == NULL) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + arithSeriesRepPtr->elements = objv; + for (i = 0; i < objc; i++) { + if (TclArithSeriesObjIndex(objPtr, i, &objv[i]) != TCL_OK) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("indexing error", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + Tcl_IncrRefCount(objv[i]); + } + } + } else { + objv = NULL; + } + *objvPtr = objv; + *objcPtr = objc; + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an arithseries")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjReverse -- + * + * Reverse the order of the ArithSeries value. + * *arithSeriesPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the reordered series. + * This may be a new object or the same object if not shared. + * + * Side effects: + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjReverse( + Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ +{ + ArithSeries *arithSeriesRepPtr; + Tcl_Obj *startObj, *endObj, *stepObj; + Tcl_Obj *resultObj; + Tcl_WideInt start, end, step, len; + double dstart, dend, dstep; + int isDouble; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + + isDouble = arithSeriesRepPtr->isDouble; + len = arithSeriesRepPtr->len; + + TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + + if (isDouble) { + Tcl_GetDoubleFromObj(NULL, startObj, &dstart); + Tcl_GetDoubleFromObj(NULL, endObj, &dend); + Tcl_GetDoubleFromObj(NULL, stepObj, &dstep); + dstep = -dstep; + TclSetDoubleObj(stepObj, dstep); + } else { + Tcl_GetWideIntFromObj(NULL, startObj, &start); + Tcl_GetWideIntFromObj(NULL, endObj, &end); + Tcl_GetWideIntFromObj(NULL, stepObj, &step); + step = -step; + TclSetIntObj(stepObj, step); + } + + if (Tcl_IsShared(arithSeriesPtr) || + ((arithSeriesPtr->refCount > 1))) { + Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); + resultObj = TclNewArithSeriesObj(isDouble, + startObj, endObj, stepObj, lenObj); + Tcl_DecrRefCount(lenObj); + } else { + + /* + * In-place is possible. + */ + + TclInvalidateStringRep(arithSeriesPtr); + + if (isDouble) { + ArithSeriesDbl *arithSeriesDblRepPtr = + (ArithSeriesDbl*)arithSeriesRepPtr; + arithSeriesDblRepPtr->start = dstart; + arithSeriesDblRepPtr->end = dend; + arithSeriesDblRepPtr->step = dstep; + } else { + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + } + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + for (i=0; ielements[i]); + } + ckfree((char*)arithSeriesRepPtr->elements); + } + arithSeriesRepPtr->elements = NULL; + + resultObj = arithSeriesPtr; + } + + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + + return resultObj; +} ADDED generic/tclArithSeries.h Index: generic/tclArithSeries.h ================================================================== --- /dev/null +++ generic/tclArithSeries.h @@ -0,0 +1,54 @@ +/* + * tclArithSeries.h -- + * + * This file contains the ArithSeries concrete abstract list + * implementation. It implements the inner workings of the lseq command. + * + * Copyright © 2022 Brian S. Griffin. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +/* + * The structure used for the ArithSeries internal representation. + * Note that the len can in theory be always computed by start,end,step + * but it's faster to cache it inside the internal representation. + */ +typedef struct ArithSeries { + Tcl_WideInt start; + Tcl_WideInt end; + Tcl_WideInt step; + Tcl_WideInt len; + Tcl_Obj **elements; + int isDouble; +} ArithSeries; +typedef struct ArithSeriesDbl { + double start; + double end; + double step; + Tcl_WideInt len; + Tcl_Obj **elements; + int isDouble; +} ArithSeriesDbl; + + +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj); +MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, + Tcl_WideInt index, Tcl_Obj **elementObj); +MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, + int fromIdx, int toIdx); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step, + Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, + double step, Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, + Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -320,10 +320,11 @@ {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, Index: generic/tclCmdAH.c ================================================================== --- generic/tclCmdAH.c +++ generic/tclCmdAH.c @@ -13,10 +13,11 @@ #include "tclInt.h" #ifdef _WIN32 # include "tclWinInt.h" #endif +#include "tclArithSeries.h" /* * The state structure used by [foreach]. Note that the actual structure has * all its working arrays appended afterwards so they can be allocated and * freed in a single step. @@ -2801,36 +2802,51 @@ /* * Break up the value lists and variable lists into elements. */ for (i=0 ; ivCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); if (statePtr->vCopyList[i] == NULL) { result = TCL_ERROR; goto done; } TclListObjGetElementsM(NULL, statePtr->vCopyList[i], - &statePtr->varcList[i], &statePtr->varvList[i]); + &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s varlist is empty", - (statePtr->resultList != NULL ? "lmap" : "foreach"))); + "%s varlist is empty", + (statePtr->resultList != NULL ? "lmap" : "foreach"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", - (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), - "NEEDVARS", NULL); + (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), + "NEEDVARS", NULL); result = TCL_ERROR; goto done; } - statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); - if (statePtr->aCopyList[i] == NULL) { - result = TCL_ERROR; - goto done; - } - TclListObjGetElementsM(NULL, statePtr->aCopyList[i], + /* Values */ + if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { + /* Special case for Arith Series */ + statePtr->vCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (statePtr->vCopyList[i] == NULL) { + result = TCL_ERROR; + goto done; + } + /* Don't compute values here, wait until the last momement */ + statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->vCopyList[i]); + } else { + /* List values */ + statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { + result = TCL_ERROR; + goto done; + } + TclListObjGetElementsM(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); - + } + /* account for variable <> value mismatch */ j = statePtr->argcList[i] / statePtr->varcList[i]; if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; } if (j > statePtr->maxj) { @@ -2948,15 +2964,25 @@ { int i, v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { + int isarithseries = TclHasInternalRep(statePtr->vCopyList[i],&tclArithSeriesType); for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; - if (k < statePtr->argcList[i]) { - valuePtr = statePtr->argvList[i][k]; + if (isarithseries) { + if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &valuePtr) != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + TclGetString(statePtr->varvList[i][v]))); + return TCL_ERROR; + } + } else { + valuePtr = statePtr->argvList[i][k]; + } } else { TclNewObj(valuePtr); /* Empty string */ } varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v], Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -17,10 +17,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclRegexp.h" +#include "tclArithSeries.h" +#include #include /* * During execution of the "lsort" command, structures of the following type * are used to arrange the objects being sorted into a collection of linked @@ -92,10 +94,27 @@ #define SORTMODE_REAL 2 #define SORTMODE_COMMAND 3 #define SORTMODE_DICTIONARY 4 #define SORTMODE_ASCII_NC 8 +/* + * Definitions for [lseq] command + */ +static const char *const seq_operations[] = { + "..", "to", "count", "by", NULL +}; +typedef enum Sequence_Operators { + LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY +} SequenceOperators; +static const char *const seq_step_keywords[] = {"by", NULL}; +typedef enum Step_Operators { + STEP_BY = 4 +} SequenceByMode; +typedef enum Sequence_Decoded { + NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg +} SequenceDecoded; + /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); @@ -2180,11 +2199,11 @@ TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int length, listLen; + int length, listLen, isArithSeries = 0; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; @@ -2193,22 +2212,35 @@ /* * Make sure the list argument is a list object and get its length and a * pointer to its array of element pointers. */ - if (TclListObjGetElementsM(interp, objv[1], &listLen, + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + isArithSeries = 1; + listLen = TclArithSeriesObjLength(objv[1]); + } else { + if (TclListObjGetElementsM(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; + } } if (listLen == 0) { /* No elements to join; default empty result is correct. */ return TCL_OK; } if (listLen == 1) { /* One element; return it */ - Tcl_SetObjResult(interp, elemPtrs[0]); + if (isArithSeries) { + Tcl_Obj *valueObj; + if (TclArithSeriesObjIndex(objv[1], 0, &valueObj) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, valueObj); + } else { + Tcl_SetObjResult(interp, elemPtrs[0]); + } return TCL_OK; } joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); @@ -2218,23 +2250,45 @@ resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { int i; TclNewObj(resObjPtr); - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + if (isArithSeries) { + Tcl_Obj *valueObj; + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + if (TclArithSeriesObjIndex(objv[1], i, &valueObj) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendObjToObj(resObjPtr, valueObj); + Tcl_DecrRefCount(valueObj); + } + } else { + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + } } } Tcl_DecrRefCount(joinObjPtr); if (resObjPtr) { Tcl_SetObjResult(interp, resObjPtr); @@ -2687,11 +2741,15 @@ &last); if (result != TCL_OK) { return result; } - Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + Tcl_SetObjResult(interp, TclArithSeriesObjRange(objv[1], first, last)); + } else { + Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); + } return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3071,10 +3129,21 @@ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } + + /* + * Handle ArithSeries special case - don't shimmer a series into a list + * just to reverse it. + */ + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + Tcl_SetObjResult(interp, TclArithSeriesObjReverse(objv[1])); + return TCL_OK; + } /* end ArithSeries */ + + /* True List */ if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } /* @@ -3971,10 +4040,411 @@ } /* *---------------------------------------------------------------------- * + * SequenceIdentifyArgument -- + * (for [lseq] command) + * + * Given a Tcl_Obj, identify if it is a keyword or a number + * + * Return Value + * 0 - failure, unexpected value + * 1 - value is a number + * 2 - value is an operand keyword + * 3 - value is a by keyword + * + * The decoded value will be assigned to the appropriate + * pointer, if supplied. + */ + +static SequenceDecoded +SequenceIdentifyArgument( + Tcl_Interp *interp, /* for error reporting */ + Tcl_Obj *argPtr, /* Argument to decode */ + Tcl_Obj **numValuePtr, /* Return numeric value */ + int *keywordIndexPtr) /* Return keyword enum */ +{ + int status; + SequenceOperators opmode; + SequenceByMode bymode; + union { + Tcl_WideInt i; + double d; + } nvalue; + + status = TclGetNumberFromObj(NULL, argPtr, (ClientData*)&nvalue, keywordIndexPtr); + if (status == TCL_OK) { + if (numValuePtr) { + *numValuePtr = argPtr; + } + return NumericArg; + } else { + /* Check for an index expression */ + long value; + double dvalue; + Tcl_Obj *exprValueObj; + int keyword; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { + status = Tcl_RestoreInterpState(interp, savedstate); + exprValueObj = argPtr; + } else { + // Determine if expression is double or int + if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) { + keyword = TCL_NUMBER_INT; + exprValueObj = argPtr; + } else { + if (floor(dvalue) == dvalue) { + exprValueObj = Tcl_NewWideIntObj(value); + keyword = TCL_NUMBER_INT; + } else { + exprValueObj = Tcl_NewDoubleObj(dvalue); + keyword = TCL_NUMBER_DOUBLE; + } + } + status = Tcl_RestoreInterpState(interp, savedstate); + if (numValuePtr) { + *numValuePtr = exprValueObj; + } + if (keywordIndexPtr) { + *keywordIndexPtr = keyword ;// type of expression result + } + return NumericArg; + } + } + + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, + "range operation", 0, &opmode); + if (status == TCL_OK) { + if (keywordIndexPtr) { + *keywordIndexPtr = opmode; + } + return RangeKeywordArg; + } + + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, + "step keyword", 0, &bymode); + if (status == TCL_OK) { + if (keywordIndexPtr) { + *keywordIndexPtr = bymode; + } + return ByKeywordArg; + } + return NoneArg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LseqObjCmd -- + * + * This procedure is invoked to process the "lseq" Tcl command. + * See the user documentation for details on what it does. + * + * Enumerated possible argument patterns: + * + * 1: + * lseq n + * 2: + * lseq n n + * 3: + * lseq n n n + * lseq n 'to' n + * lseq n 'count' n + * lseq n 'by' n + * 4: + * lseq n 'to' n n + * lseq n n 'by' n + * lseq n 'count' n n + * 5: + * lseq n 'to' n 'by' n + * lseq n 'count' n 'by' n + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LseqObjCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_Obj *elementCount = NULL; + Tcl_Obj *start = NULL, *end = NULL, *step = NULL; + Tcl_WideInt values[5]; + Tcl_Obj *numValues[5]; + Tcl_Obj *numberObj; + int status, keyword, useDoubles = 0; + Tcl_Obj *arithSeriesPtr; + SequenceOperators opmode; + SequenceDecoded decoded; + int i, arg_key = 0, value_i = 0; + // Default constants + Tcl_Obj *zero = Tcl_NewIntObj(0); + Tcl_Obj *one = Tcl_NewIntObj(1); + + /* + * Create a decoding key by looping through the arguments and identify + * what kind of argument each one is. Encode each argument as a decimal + * digit. + */ + if (objc > 6) { + /* Too many arguments */ + arg_key=0; + } else for (i=1; i=0) { + if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]); + } + + // Free constants + Tcl_DecrRefCount(zero); + Tcl_DecrRefCount(one); + + return status; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LsortObjCmd -- * * This procedure is invoked to process the "lsort" Tcl command. See the * user documentation for details on what it does. * @@ -4236,12 +4706,17 @@ } Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + sortInfo.resultCode = TclArithSeriesGetElements(interp, + listObj, &length, &listObjPtrs); + } else { + sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, &length, &listObjPtrs); + } if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } /* Index: generic/tclExecute.c ================================================================== --- generic/tclExecute.c +++ generic/tclExecute.c @@ -17,10 +17,11 @@ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" +#include "tclArithSeries.h" #include #include /* * Hack to determine whether we may expect IEEE floating point. The hack is @@ -4866,10 +4867,27 @@ case INST_LIST_INDEX: /* lindex with objc == 3 */ value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + + /* special case for ArithSeries */ + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + length = TclArithSeriesObjLength(valuePtr); + if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + goto lindexDone; + } + /* * Extract the desired list element. */ if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) @@ -4887,10 +4905,12 @@ } Tcl_ResetResult(interp); } objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); + + lindexDone: if (!objResultPtr) { TRACE_ERROR(interp); goto gotError; } @@ -4909,10 +4929,32 @@ */ valuePtr = OBJ_AT_TOS; opnd = TclGetInt4AtPtr(pc+1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); + + /* special case for ArithSeries */ + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + length = TclArithSeriesObjLength(valuePtr); + + /* Decode end-offset index values. */ + + index = TclIndexDecode(opnd, length); + + /* Compute value @ index */ + if (index >= 0 && index < length) { + if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + } else { + TclNewObj(objResultPtr); + } + pcAdjustment = 5; + goto lindexFastPath2; + } /* * Get the contents of the list, making sure that it really is a list * in the process. */ @@ -4931,10 +4973,12 @@ if (index >= 0 && index < objc) { objResultPtr = objv[index]; } else { TclNewObj(objResultPtr); } + + lindexFastPath2: TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */ @@ -5107,11 +5151,15 @@ fromIdx = TCL_INDEX_START; } fromIdx = TclIndexDecode(fromIdx, objc - 1); - objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + objResultPtr = TclArithSeriesObjRange(valuePtr, fromIdx, toIdx); + } else { + objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); + } TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: @@ -5127,11 +5175,11 @@ } match = 0; if (length > 0) { int i = 0; Tcl_Obj *o; - + int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); /* * An empty list doesn't match anything. */ do { @@ -5143,10 +5191,13 @@ s2len = 0; } if (s1len == s2len) { match = (memcmp(s1, s2, s1len) == 0); } + if (isArithSeries) { + TclDecrRefCount(o); + } i++; } while (i < length && match == 0); } if (*pc == INST_LIST_NOT_IN) { Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -2920,10 +2920,11 @@ MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; +MODULE_SCOPE const Tcl_ObjType tclArithSeriesType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclUniCharStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; @@ -3722,10 +3723,13 @@ MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData, Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LseqObjCmd(void *clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsortObjCmd(void *clientData, Index: generic/tclListObj.c ================================================================== --- generic/tclListObj.c +++ generic/tclListObj.c @@ -7,12 +7,13 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" #include +#include "tclInt.h" +#include "tclArithSeries.h" /* * TODO - memmove is fast. Measure at what size we should prefer memmove * (for unshared objects only) in lieu of range operations. On the other * hand, more cache dirtied? @@ -1660,10 +1661,14 @@ * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { ListRep listRep; + + if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr); + } if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) return TCL_ERROR; ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; @@ -1935,10 +1940,14 @@ ListSizeT index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { Tcl_Obj **elemObjs; ListSizeT numElems; + + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + return TclArithSeriesObjIndex(listObj, index, objPtrPtr); + } /* * TODO * Unlike the original list code, this does not optimize for lindex'ing * an empty string when the internal rep is not already a list. On the @@ -1966,11 +1975,11 @@ * This function returns the number of elements in a list object. If the * object is not already a list object, an attempt will be made to * convert it to one. * * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set + * The return value is normally TCL_OK; in this case *lenPtr will be set * to the integer count of list elements. If listPtr does not refer to a * list object and the object can not be converted to one, TCL_ERROR is * returned and an error message will be left in the interpreter's result * if interp is not NULL. * @@ -1986,10 +1995,15 @@ Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object whose #elements to return. */ ListSizeT *lenPtr) /* The resulting int is stored here. */ { ListRep listRep; + + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + *lenPtr = TclArithSeriesObjLength(listObj); + return TCL_OK; + } /* * TODO * Unlike the original list code, this does not optimize for lindex'ing * an empty string when the internal rep is not already a list. On the @@ -2613,10 +2627,31 @@ ListSizeT indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { ListSizeT i; + + /* Handle ArithSeries as special case */ + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + ListSizeT index, listLen = TclArithSeriesObjLength(listObj); + Tcl_Obj *elemObj = NULL; + for (i=0 ; i 0) { + Tcl_DecrRefCount(elemObj); + TclNewObj(elemObj); + Tcl_IncrRefCount(elemObj); + break; + } + } + return elemObj; + } Tcl_IncrRefCount(listObj); for (i=0 ; i 0 ? size : 1, NULL, &listRep) + != TCL_OK) { + return TCL_ERROR; + } + + LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ + LIST_ASSERT(listRep.storePtr->firstUsed == 0); + LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0); + + listRep.storePtr->numUsed = size; + elemPtrs = listRep.storePtr->slots; + for (j = 0; j < size; j++) { + if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) { + return TCL_ERROR; + } + Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */ + } + } else { ListSizeT estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); /* @@ -3430,10 +3493,11 @@ if (flagPtr != localFlags) { ckfree(flagPtr); } } + /* *------------------------------------------------------------------------ * * TclListTestObj -- ADDED tests/lseq.test Index: tests/lseq.test ================================================================== --- /dev/null +++ tests/lseq.test @@ -0,0 +1,482 @@ +# Commands covered: lseq +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright © 2003 Simon Geard. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +testConstraint arithSeriesDouble 1 +testConstraint arithSeriesShimmer 1 +testConstraint arithSeriesShimmerOk 0 + +## Arg errors +test lseq-1.1 {error cases} -body { + lseq +} \ + -returnCodes 1 \ + -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + + +test lseq-1.2 {step magnitude} { + lseq 10 .. 1 by -2 ;# or this could be an error - or not +} {10 8 6 4 2} + +test lseq-1.3 {synergy between int and double} { + set rl [lseq 25. to 5. by -5] + set il [lseq 25 to 5 by -5] + lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } +} {1 1 1 1 1} + +test lseq-1.4 {integer decreasing} { + lseq 10 .. 1 +} {10 9 8 7 6 5 4 3 2 1} + +test lseq-1.5 {integer increasing} { + lseq 1 .. 10 +} {1 2 3 4 5 6 7 8 9 10} + +test lseq-1.6 {integer decreasing with step} { + lseq 10 .. 1 by -2 +} {10 8 6 4 2} + +test lseq-1.7 {real increasing lseq} arithSeriesDouble { + 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} + +test lseq-1.8 {real increasing lseq with step} arithSeriesDouble { + lseq 5.0 to 25. by 5 +} {5.0 10.0 15.0 20.0 25.0} + +test lseq-1.9 {real decreasing with step} arithSeriesDouble { + lseq 25. to 5. by -5 +} {25.0 20.0 15.0 10.0 5.0} + +# note, 10 cannot be in such a list, but allowed +test lseq-1.10 {integer lseq with step} { + lseq 1 to 10 by 2 +} {1 3 5 7 9} + +test lseq-1.11 {error case: increasing wrong step direction} { + lseq 1 to 10 by -2 +} {} + +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} + +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.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.17 {too many arguments} -body { + lseq 12 to 24 by 2 with feeling +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.18 {too many arguments extra valid keyword} -body { + lseq 12 to 24 by 2 count +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.19 {too many arguments extra numeric value} -body { + lseq 12 to 24 by 2 7 +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.20 {bug: wrong length computed} { + lseq 1 to 10 -1 +} {} + +test lseq-1.21 {n n by n} { + lseq 66 84 by 3 +} {66 69 72 75 78 81 84} + +test lseq-1.22 {n n by -n} { + lseq 84 66 by -3 +} {84 81 78 75 72 69 66} + +# +# Short-hand use cases +# +test lseq-2.2 {step magnitude} { + lseq 10 1 2 ;# this is an empty case since step has wrong sign +} {} + +test lseq-2.3 {step wrong sign} arithSeriesDouble { + lseq 25. 5. 5 ;# ditto - empty list +} {} + +test lseq-2.4 {integer decreasing} { + lseq 10 1 +} {10 9 8 7 6 5 4 3 2 1} + +test lseq-2.5 {integer increasing} { + lseq 1 10 +} {1 2 3 4 5 6 7 8 9 10} + +test lseq-2.6 {integer decreasing with step} { + lseq 10 1 by -2 +} {10 8 6 4 2} + +test lseq-2.7 {real increasing lseq} arithSeriesDouble { + lseq 5.0 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} + + +test lseq-2.8 {real increasing lseq with step} arithSeriesDouble { + lseq 5.0 25. 5 +} {5.0 10.0 15.0 20.0 25.0} + + +test lseq-2.9 {real decreasing with step} arithSeriesDouble { + lseq 25. 5. -5 +} {25.0 20.0 15.0 10.0 5.0} + +test lseq-2.10 {integer lseq with step} { + lseq 1 10 2 +} {1 3 5 7 9} + +test lseq-2.11 {error case: increasing wrong step direction} { + lseq 1 10 -2 +} {} + +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} + +test lseq-2.13 {count only operation} { + lseq 5 +} {0 1 2 3 4} + +test lseq-2.14 {count with step} { + lseq 5 count 5 2 +} {5 7 9 11 13} + +test lseq-2.15 {count with decreasing step} { + lseq 5 count 5 -2 +} {5 3 1 -1 -3} + +test lseq-2.16 {large numbers} { + lseq 1e6 2e6 1e5 +} {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 +} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} + +# Covered: {10 1 2 } {1 10 2} {1 10 -2} {1 1 1} {1 1 1} {-5 17 3} +# Missing: {- - +} {- - -} {- + -} {+ - -} {- - +} {+ + -} +test lseq-2.18 {signs} { + list [lseq -10 -1 2] \ + [lseq -10 -1 -1] \ + [lseq -10 1 -3] \ + [lseq 10 -1 -4] \ + [lseq -10 -1 3] \ + [lseq 10 1 -5] + +} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}} + +test lseq-3.1 {experiement} { + set ans {} + foreach factor [lseq 2.0 10.0] { + set start 1 + set end 10 + for {set step 1} {$step < 1e8} {} { + set l [lseq $start to $end by $step] + if {[llength $l] != 10} { + lappend ans $factor $step [llength $l] $l + } + set step [expr {$step * $factor}] + set end [expr {$end * $factor}] + } + } + if {$ans eq {}} { + set ans OK + } + set ans +} {OK} + +test lseq-3.2 {error case} -body { + lseq foo +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} + +test lseq-3.3 {error case} -body { + lseq 10 foo +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} + +test lseq-3.4 {error case} -body { + lseq 25 or 6 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} + +test lseq-3.5 {simple count and step arguments} { + set s [lseq 25 by 6] + list $s length=[llength $s] +} {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25} + +test lseq-3.6 {error case} -body { + lseq 1 7 or 3 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} + +test lseq-3.7 {lmap lseq} { + lmap x [lseq 5] { expr {$x * $x} } +} {0 1 4 9 16} + +test lseq-3.8 {lrange lseq} { + set r [lrange [lseq 1 100] 10 20] + lindex [tcl::unsupported::representation $r] 3 +} {arithseries} + +test lseq-3.9 {lassign lseq} arithSeriesShimmer { + set r [lseq 15] + set r2 [lassign $r a b] + list [lindex [tcl::unsupported::representation $r] 3] $a $b \ + [lindex [tcl::unsupported::representation $r2] 3] +} {arithseries 0 1 arithseries} + +test lseq-3.10 {lsearch lseq must shimmer?} arithSeriesShimmer { + set r [lseq 15 0] + set a [lsearch $r 9] + list [lindex [tcl::unsupported::representation $r] 3] $a +} {arithseries 6} + +test lseq-3.11 {lreverse lseq} { + set r [lseq 15 0] + set a [lreverse $r] + join [list \ + [lindex [tcl::unsupported::representation $r] 3] \ + $r \ + [lindex [tcl::unsupported::representation $a] 3] \ + $a] \n +} {arithseries +15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 +arithseries +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} + +test lseq-3.12 {in operator} { + set r [lseq 9] + set i [expr {7 in $r}] + set j [expr {10 ni $r}] + set k [expr {-1 in $r}] + set l [expr {4 ni $r}] + list $i $j $k $l [lindex [tcl::unsupported::representation $r] 3] +} {1 1 0 0 arithseries} + +test lseq-3.13 {lmap lseq shimmer} arithSeriesShimmer { + set r [lseq 15] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set m [lmap i $r { expr {$i * 7} }] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + set rep-m [lindex [tcl::unsupported::representation $m] 3] + list $r ${rep-before} ${rep-after} ${rep-m} $m +} {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}} + +test lseq-3.14 {array for shimmer} arithSeriesShimmerOk { + array set testarray {a Test for This great Function} + set vars [lseq 2] + set vars-rep [lindex [tcl::unsupported::representation $vars] 3] + array for $vars testarray { + lappend keys $0 + lappend vals $1 + } + # Since hash order is not guaranteed, have to validate content ignoring order + set valk [lmap k $keys {expr {$k in {a for great}}}] + set valv [lmap v $vals {expr {$v in {Test This Function}}}] + set vars-after [lindex [tcl::unsupported::representation $vars] 3] + list ${vars-rep} $valk $valv ${vars-after} +} {arithseries {1 1 1} {1 1 1} arithseries} + +test lseq-3.15 {join for shimmer} arithSeriesShimmer { + set r [lseq 3] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set str [join $r :] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $str ${rep-after} +} {arithseries 0:1:2 arithseries} + +test lseq-3.16 {error case} -body { + lseq 16 to +} -returnCodes 1 -result {missing "to" value.} + +test lseq-3.17 {error case} -body { + lseq 17 to 13 by +} -returnCodes 1 -result {missing "by" value.} + +test lseq-3.18 {error case} -body { + lseq 18 count +} -returnCodes 1 -result {missing "count" value.} + +test lseq-3.19 {edge case} -body { + lseq 1 count 5 by 0 +} -result {} +# 1 1 1 1 1 + +# My thought is that this is likely a user error, since they can always use lrepeat for this. + +test lseq-3.20 {edge case} -body { + lseq 1 to 1 by 0 +} -result {} + +# hmmm, I guess this is right, in a way, so... + +test lseq-3.21 {edge case} { + lseq 1 to 1 by 1 +} {1} + +test lseq-3.22 {edge case} { + lseq 1 1 1 +} {1} + +test lseq-3.23 {edge case} { + llength [lseq 1 1 1] +} {1} + +test lseq-3.24 {edge case} { + llength [lseq 1 to 1 1] +} {1} + +test lseq-3.25 {edge case} { + llength [lseq 1 to 1 by 1] +} {1} + +test lseq-3.26 {lsort shimmer} arithSeriesShimmer { + set r [lseq 15 0] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set lexical_sort [lsort $r] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $lexical_sort ${rep-after} +} {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries} + +test lseq-3.27 {lreplace shimmer} arithSeriesShimmer { + set r [lseq 15 0] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set lexical_sort [lreplace $r 3 5 A B C] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $lexical_sort ${rep-after} +} {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} + +test lseq-3.28 {lreverse bug in ArithSeries} {} { + set r [lseq -5 17 3] + set rr [lreverse $r] + list $r $rr [string equal $r [lreverse $rr]] +} {{-5 -2 1 4 7 10 13 16} {16 13 10 7 4 1 -2 -5} 1} + +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 +} {7 8 9 10 11 12 13 14 15 16 17 18} + +test lseq-4.2 {start expressions} { + set base [clock seconds] + set tl [lseq $base-60 $base 10] + 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: ADDED tests/range.test Index: tests/range.test ================================================================== --- /dev/null +++ tests/range.test Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -297,12 +297,12 @@ 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 tclAlloc.o \ - tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ - tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ + tclArithSeries.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 \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ tclEncoding.o tclEnsemble.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ @@ -391,18 +391,20 @@ $(GENERIC_DIR)/tclOOInt.h \ $(GENERIC_DIR)/tclOOIntDecls.h \ $(GENERIC_DIR)/tclPatch.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclPort.h \ - $(GENERIC_DIR)/tclRegexp.h + $(GENERIC_DIR)/tclRegexp.h \ + $(GENERIC_DIR)/tclArithSeries.h GENERIC_SRCS = \ $(GENERIC_DIR)/regcomp.c \ $(GENERIC_DIR)/regexec.c \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ $(GENERIC_DIR)/tclAlloc.c \ + $(GENERIC_DIR)/tclArithSeries.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ $(GENERIC_DIR)/tclCkalloc.c \ @@ -1247,10 +1249,13 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c $(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c + +tclArithSeries.o: $(GENERIC_DIR)/tclArithSeries.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclArithSeries.c tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c tclAsync.o: $(GENERIC_DIR)/tclAsync.c Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -276,10 +276,11 @@ regcomp.$(OBJEXT) \ regexec.$(OBJEXT) \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ + tclArithSeries.$(OBJEXT) \ tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ tclCkalloc.$(OBJEXT) \ Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -236,10 +236,11 @@ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ $(TMP_DIR)\regfree.obj \ $(TMP_DIR)\tclAlloc.obj \ + $(TMP_DIR)\tclArithSeries.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ $(TMP_DIR)\tclCkalloc.obj \