From f9e3b4dd740c0d808fef53f9eba4b44e67734c34 Mon Sep 17 00:00:00 2001
From: griffin <briang42@easystreet.net>
Date: Fri, 19 Aug 2022 18:08:39 +0000
Subject: Reimplement AbstrctList type structure to simplify. fix various bugs.
---
doc/lseq.n | 104 +++++++++++++++
generic/tcl.decls | 5 +-
generic/tcl.h | 126 +++++++++---------
generic/tclAbstractList.c | 315 +++++++++++++++-----------------------------
generic/tclAbstractList.h | 30 ++---
generic/tclCmdIL.c | 327 ++++++++++++++++++++++++++++++++--------------
generic/tclDecls.h | 10 +-
generic/tclExecute.c | 32 +++--
generic/tclInt.h | 29 ++--
generic/tclStubInit.c | 1 -
tests/lseq.test | 72 ++++++----
11 files changed, 589 insertions(+), 462 deletions(-)
create mode 100644 doc/lseq.n
diff --git a/doc/lseq.n b/doc/lseq.n
new file mode 100644
index 0000000..e6ba7a6
--- /dev/null
+++ b/doc/lseq.n
@@ -0,0 +1,104 @@
+'\"
+'\" 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 the range. The "count" option is used
+to define a count of the number of elements in the list. A short form use of
+the command, with a
+single count value, will create a range from 0 to count-1.
+
+The \fBlseq\fR command can produce both increasing and decreasing sequences. When
+both Start and End are provided without a Step value, then if Start <= End,
+the sequence will be increasing and if Start > End it will be decreasing. If a
+Step vale is included, it's sign should agree with the direction of the
+sequence (descending -> negative and ascending -> positive), otherwise an
+empty list is returned. For example:
+
+.CS \"
+ % lseq 1 to 5 ;# increasing
+ 1 2 3 4 5
+
+ % lseq 5 to 1 ;# decreasing
+ 5 4 3 2 1
+
+ % lseq 6 to 1 by 2 ;# decreasing, step wrong sign, empty list
+
+ % lseq 1 to 5 by 0 ;# all step sizes of 0 produce an empty list
+
+.\"
+.CE
+
+The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR,
+may also be a valid expression. The expression will be evaluate and the
+numeric result be used. An expression that does not evaluate to a number will
+produce an invalid argument error.
+
+.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:
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 459923c..671c89c 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2514,10 +2514,7 @@ declare 677 {
Tcl_Obj *Tcl_AbstractListObjReverse(Tcl_Obj *abstractListPtr)
}
declare 678 {
- Tcl_Obj *Tcl_NewAbstractListObj(Tcl_Interp *interp, const char* typeName, size_t requiredSize)
-}
-declare 679 {
- int Tcl_AbstractListSetProc(Tcl_Obj *objPtr, Tcl_AbstractListProcType ptype, void *proc)
+ Tcl_Obj *Tcl_NewAbstractListObj(Tcl_Interp *interp, const Tcl_AbstractListType* vTablePtr)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
diff --git a/generic/tcl.h b/generic/tcl.h
index 8c72ed0..a6894f4 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -725,15 +725,21 @@ typedef void (Tcl_MainLoopProc) (void);
/* Abstract List functions */
typedef struct Tcl_Obj* (Tcl_ALNewObjProc) (int objc, struct Tcl_Obj *objv[]);
-typedef void (Tcl_ALDupRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *copyPtr);
+typedef void (Tcl_ALDupRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *copyPtr);
typedef Tcl_WideInt (Tcl_ALLengthProc) (struct Tcl_Obj *listPtr);
typedef struct Tcl_Obj* (Tcl_ALIndexProc) (struct Tcl_Obj *listPtr, Tcl_WideInt index);
-typedef struct Tcl_Obj* (Tcl_ALSliceProc) (struct Tcl_Obj *listPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx);
+typedef struct Tcl_Obj* (Tcl_ALSliceProc) (struct Tcl_Obj *listPtr, Tcl_WideInt fromIdx,
+ Tcl_WideInt toIdx);
typedef struct Tcl_Obj* (Tcl_ALReverseProc) (struct Tcl_Obj *listPtr);
+typedef int (Tcl_ALGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
+ int *objcptr, struct Tcl_Obj ***objvptr);
+typedef void (Tcl_ALFreeConcreteRep) (struct Tcl_Obj *listPtr);
+typedef void (Tcl_ALToStringRep) (struct Tcl_Obj *listPtr);
typedef enum {
TCL_ABSL_NEW, TCL_ABSL_DUPREP, TCL_ABSL_LENGTH, TCL_ABSL_INDEX,
- TCL_ABSL_SLICE, TCL_ABSL_REVERSE
+ TCL_ABSL_SLICE, TCL_ABSL_REVERSE, TCL_ABSL_GETELEMENTS, TCL_ABSL_FREEREP,
+ TCL_ABSL_TOSTRING
} Tcl_AbstractListProcType;
typedef struct Tcl_AbstractListVersion_ *Tcl_AbstractListVersion;
@@ -830,80 +836,72 @@ typedef struct Tcl_Obj {
#define TCL_ABSTRACTLIST_VERSION_1 ((Tcl_AbstractListVersion) 0x1)
-typedef struct AbstractList {
+/* Virtual function dispatch a la Tcl_ObjType but for AbstractList */
+typedef struct Tcl_AbstractListType {
Tcl_AbstractListVersion version;/* Structure version */
-
- size_t repSize; /* value size */
const char *typeName; /* Custom value reference */
- Tcl_Obj **elements; /* Used only by Tcl_AbstractListGetElements */
-
+
/* List emulation functions */
- Tcl_ALNewObjProc *newObjProc; /* How to create a new Tcl_Obj of this
- custom type */
- Tcl_ALDupRepProc *dupRepProc; /* How to duplicate a internal rep of this
- custom type */
- Tcl_ALLengthProc *lengthProc; /* Return the [llength] of the
- AbstractList */
- Tcl_ALIndexProc *indexProc; /* Return a value (Tcl_Obj) for
- [lindex $al $index] */
- Tcl_ALSliceProc *sliceProc; /* Return an AbstractList for
- [lrange $al $start $end] */
- Tcl_ALReverseProc *reverseProc; /* Return an AbstractList for
- [lreverse $al] */
- /* Must Be Last -- Don't Move! */
- void* abstractValue;
-
-} AbstractList;
-
-static inline AbstractList* Tcl_AbstractListRepPtr(Tcl_Obj *abstractListObjPtr)
+ Tcl_ALNewObjProc *newObjProc; /* How to create a new Tcl_Obj of this
+ ** custom type */
+ Tcl_ALDupRepProc *dupRepProc; /* How to duplicate a internal rep of this
+ ** custom type */
+ Tcl_ALLengthProc *lengthProc; /* Return the [llength] of the
+ ** AbstractList */
+ Tcl_ALIndexProc *indexProc; /* Return a value (Tcl_Obj) for
+ ** [lindex $al $index] */
+ Tcl_ALSliceProc *sliceProc; /* Return an AbstractList for
+ ** [lrange $al $start $end] */
+ Tcl_ALReverseProc *reverseProc; /* Return an AbstractList for
+ ** [lreverse $al] */
+ Tcl_ALGetElements *getElementsProc; /* Return an objv[] of all elements in
+ ** the list */
+ Tcl_ALFreeConcreteRep *freeRepProc; /* Free ConcreteRep internals if
+ necessary */
+ Tcl_ALToStringRep *toStringProc; /* Optimized "to-string" conversion
+ * for updating the string rep */
+
+} Tcl_AbstractListType;
+
+extern const Tcl_ObjType tclAbstractListType;
+
+/*
+ * Returns pointer to the concrete type or NULL if not AbstractList or
+ * not abstract list of the same type as concrete type
+ */
+static inline Tcl_AbstractListType *Tcl_AbstractListGetType(
+ Tcl_Obj *objPtr)
{
- return (AbstractList *) ((abstractListObjPtr)->internalRep.twoPtrValue.ptr1);
+ if (objPtr->typePtr != &tclAbstractListType) {
+ return NULL;
+ }
+ return (Tcl_AbstractListType *) objPtr->internalRep.twoPtrValue.ptr1;
}
-static inline void* Tcl_AbstractListGetTypeRep(
+/* Returns the storage used by the concrete abstract list type */
+static inline void* Tcl_AbstractListGetConcreteRep(
Tcl_Obj *objPtr) /* Object of type AbstractList */
-{
- const Tcl_ObjInternalRep *irPtr;
- irPtr = objPtr ? &((objPtr)->internalRep) : NULL;
- return irPtr ? (void *)(irPtr->twoPtrValue.ptr2) : NULL;
-}
-
-/* Enforce type checking on supplied function pointers while isolating
- * internal struct details */
-
-EXTERN int Tcl_AbstractListSetProc(Tcl_Obj *objPtr, Tcl_AbstractListProcType ptype, void *proc);
-
-static inline int Tcl_SetAbstractListNewProc(Tcl_Obj *objPtr, Tcl_ALNewObjProc *proc)
-{
- return Tcl_AbstractListSetProc(objPtr, TCL_ABSL_NEW, proc);
-}
-
-static inline int Tcl_SetAbstractListLengthProc(Tcl_Obj *objPtr, Tcl_ALLengthProc *proc)
-{
- return Tcl_AbstractListSetProc(objPtr, TCL_ABSL_LENGTH, proc);
-}
-
-static inline int Tcl_SetAbstractListSliceProc(Tcl_Obj *objPtr, Tcl_ALSliceProc *proc)
-{
- return Tcl_AbstractListSetProc(objPtr, TCL_ABSL_SLICE, proc);
-}
-
-static inline int Tcl_SetAbstractListIndexProc(Tcl_Obj *objPtr, Tcl_ALIndexProc *proc)
-{
- return Tcl_AbstractListSetProc(objPtr, TCL_ABSL_INDEX, proc);
-}
-
-static inline int Tcl_SetAbstractListReverseProc(Tcl_Obj *objPtr, Tcl_ALReverseProc *proc)
{
- return Tcl_AbstractListSetProc(objPtr, TCL_ABSL_REVERSE, proc);
+ /* Public function, must check for NULL */
+ if (objPtr == NULL || objPtr->typePtr != &tclAbstractListType) {
+ return NULL;
+ }
+ return objPtr->internalRep.twoPtrValue.ptr2;
}
-static inline int Tcl_SetAbstractListDupRepProc(Tcl_Obj *objPtr, Tcl_ALDupRepProc *proc)
+/*
+ * Sets the storage used by the concrete abstract list type
+ * Caller has to ensure type is AbstractList. Existing rep will be
+ * overwritten so caller has to free previous rep if necessary.
+ */
+static inline void Tcl_AbstractListSetConcreteRep(
+ Tcl_Obj *objPtr, /* Object of type AbstractList */
+ void *repPtr) /* New representation */
{
- return Tcl_AbstractListSetProc(objPtr, TCL_ABSL_DUPREP, proc);
+ /* assert(objPtr->typePtr == &tclAbstractListType); */
+ objPtr->internalRep.twoPtrValue.ptr2 = repPtr;
}
-
/*
*----------------------------------------------------------------------------
* The following structure contains the state needed by Tcl_SaveResult. No-one
diff --git a/generic/tclAbstractList.c b/generic/tclAbstractList.c
index f7e997f..bbffc2d 100644
--- a/generic/tclAbstractList.c
+++ b/generic/tclAbstractList.c
@@ -1,7 +1,7 @@
/*
* tclAbstractList.h --
*
- * The AbstractList Obj Type -- a psuedo List
+ * The AbstractList Obj Type -- a psuedo List
*
* Copyright © 2022 by Brian Griffin. All rights reserved.
*
@@ -29,7 +29,7 @@ static void UpdateStringOfAbstractList (Tcl_Obj *listPtr);
*
* The abstract list object is a special case of Tcl list represented by a set
* of functions.
- *
+ *
*/
const Tcl_ObjType tclAbstractListType = {
@@ -84,33 +84,18 @@ Tcl_AbstractListObjLength(Tcl_Obj *abstractListObjPtr)
*/
Tcl_Obj*
-Tcl_NewAbstractListObj(Tcl_Interp *interp, const char* typeName, size_t requiredSize)
+Tcl_NewAbstractListObj(Tcl_Interp *interp, const Tcl_AbstractListType* vTablePtr)
{
Tcl_Obj *objPtr;
- size_t repSize;
- AbstractList *abstractListRepPtr;
Tcl_ObjInternalRep itr;
(void)interp;
TclNewObj(objPtr);
- repSize = sizeof(AbstractList) + requiredSize;
- abstractListRepPtr = (AbstractList*)ckalloc(repSize);
- abstractListRepPtr->version = TCL_ABSTRACTLIST_VERSION_1;
- abstractListRepPtr->repSize = repSize;
- abstractListRepPtr->typeName = typeName;;
- abstractListRepPtr->elements = NULL;
- abstractListRepPtr->newObjProc = NULL;
- abstractListRepPtr->dupRepProc = NULL;
- abstractListRepPtr->lengthProc = NULL;
- abstractListRepPtr->indexProc = NULL;
- abstractListRepPtr->sliceProc = NULL;
- abstractListRepPtr->reverseProc = NULL;
- itr.twoPtrValue.ptr1 = abstractListRepPtr;
- itr.twoPtrValue.ptr2 = (((char*)abstractListRepPtr) + offsetof(AbstractList,abstractValue));
+ itr.twoPtrValue.ptr1 = (void*)vTablePtr; /* dispatch table for concrete type */
+ itr.twoPtrValue.ptr2 = NULL;
Tcl_StoreInternalRep(objPtr, &tclAbstractListType, &itr);
Tcl_InvalidateStringRep(objPtr);
return objPtr;
}
-
/*
*----------------------------------------------------------------------
@@ -133,14 +118,22 @@ Tcl_NewAbstractListObj(Tcl_Interp *interp, const char* typeName, size_t required
Tcl_Obj*
Tcl_AbstractListObjIndex(Tcl_Obj *abstractListObjPtr, Tcl_WideInt index)
{
- AbstractList *abstractListRepPtr;
+ Tcl_AbstractListType *typePtr;
Tcl_Obj *elementObjPtr;
- if (abstractListObjPtr->typePtr != &tclAbstractListType) {
- Tcl_Panic("Tcl_AbstractListObjIndex called without and AbstractList Obj.");
+
+ typePtr = Tcl_AbstractListGetType(abstractListObjPtr);
+ /*
+ * The general assumption is that the obj is assumed first to be a List,
+ * and only ends up here because it has been determinded to be an
+ * AbstractList. If that's not the case, then a mistake has been made. To
+ * attempt to try a List call (e.g. shimmer) could potentially loop(?)
+ * So: if called from List code, then something has gone wrong; if called
+ * from user code, then user has made a mistake.
+ */
+ if (typePtr == NULL) {
+ Tcl_Panic("Tcl_AbstractListObjIndex called without and AbstractList Obj.");
}
- abstractListRepPtr = (AbstractList*)
- abstractListObjPtr->internalRep.twoPtrValue.ptr1;
- elementObjPtr = abstractListRepPtr->indexProc(abstractListObjPtr, index);
+ elementObjPtr = typePtr->indexProc(abstractListObjPtr, index);
return elementObjPtr;
}
@@ -166,18 +159,12 @@ Tcl_AbstractListObjIndex(Tcl_Obj *abstractListObjPtr, Tcl_WideInt index)
void
FreeAbstractListInternalRep(Tcl_Obj *abstractListObjPtr)
{
- AbstractList *abstractListRepPtr =
- (AbstractList *) abstractListObjPtr->internalRep.twoPtrValue.ptr1;
- if (abstractListRepPtr->elements) {
- Tcl_WideInt i, llen = abstractListRepPtr->lengthProc(abstractListObjPtr);
- for(i=0; i<llen; i++) {
- if (abstractListRepPtr->elements[i]) {
- Tcl_DecrRefCount(abstractListRepPtr->elements[i]);
- }
- }
- ckfree((char*)abstractListRepPtr->elements);
+ Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(abstractListObjPtr);
+
+ if (TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_FREEREP)) {
+ /* call the free callback for the concrete rep */
+ typePtr->freeRepProc(abstractListObjPtr);
}
- ckfree((char *) abstractListRepPtr);
abstractListObjPtr->internalRep.twoPtrValue.ptr1 = NULL;
abstractListObjPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
@@ -202,31 +189,28 @@ FreeAbstractListInternalRep(Tcl_Obj *abstractListObjPtr)
static void
DupAbstractListInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+ Tcl_Obj *copyPtr; /* Object with internal rep to set.
+ * Internal rep must be clear, it is stomped */
{
- AbstractList *srcAbstractListRepPtr = Tcl_AbstractListRepPtr(srcPtr);
- AbstractList *copyAbstractListRepPtr;
- size_t repSize;
- /*
- * Allocate a new ArithSeries structure.
- */
+ Tcl_AbstractListType *typePtr;
+ typePtr = AbstractListGetType(srcPtr);
+ copyPtr->internalRep.twoPtrValue.ptr1 = typePtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- repSize = srcAbstractListRepPtr->repSize; // example: sizeof(AbstractList) + sizeof(ArithSeries)
- copyAbstractListRepPtr = (AbstractList*) ckalloc(repSize);
- *copyAbstractListRepPtr = *srcAbstractListRepPtr;
- copyPtr->internalRep.twoPtrValue.ptr1 = copyAbstractListRepPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = (((char*)copyAbstractListRepPtr) + offsetof(AbstractList,abstractValue));
- copyAbstractListRepPtr->typeName = srcAbstractListRepPtr->typeName;
- copyPtr->typePtr = &tclAbstractListType;
-
- copyAbstractListRepPtr->elements = NULL; /* Let new object repopulate it's elements on demand. */
+ /* Now do concrete type dup. It is responsible for calling
+ Tcl_AbstractListSetConcreteRep to initialize ptr2 */
- if (srcAbstractListRepPtr->dupRepProc) {
- srcAbstractListRepPtr->dupRepProc(srcPtr, copyPtr);
+ if (typePtr->dupRepProc) {
+ typePtr->dupRepProc(srcPtr, copyPtr);
+ } else {
+ /* TODO - or set it to NULL instead? */
+ copyPtr->internalRep.twoPtrValue.ptr2 =
+ srcPtr->internalRep.twoPtrValue.ptr2;
}
+ copyPtr->typePtr = &tclAbstractListType;
}
-
+
/*
*----------------------------------------------------------------------
*
@@ -253,28 +237,36 @@ DupAbstractListInternalRep(srcPtr, copyPtr)
*----------------------------------------------------------------------
*/
-/* works for arithseries, not for arbitary element values */
-#if 0 // begin depricated
static void
UpdateStringOfAbstractList(Tcl_Obj *abstractListObjPtr)
{
- AbstractList *abstractListRepPtr =
- (AbstractList*) abstractListObjPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_AbstractListType *typePtr;
char *p, *str;
Tcl_Obj *eleObj;
Tcl_WideInt length = 0;
int llen, slen, i;
+ typePtr = AbstractListGetType(abstractListObjPtr);
+
+ /*
+ * If concrete type has a better way to generate the string,
+ * let it do it.
+ */
+ if (TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_TOSTRING)) {
+ typePtr->toStringProc(abstractListObjPtr);
+ return;
+ }
+
/*
* Pass 1: estimate space.
*/
- llen = abstractListRepPtr->lengthProc(abstractListObjPtr);
+ llen = typePtr->lengthProc(abstractListObjPtr);
if (llen <= 0) {
Tcl_InitStringRep(abstractListObjPtr, NULL, 0);
return;
}
for (i = 0; i < llen; i++) {
- eleObj = abstractListRepPtr->indexProc(abstractListObjPtr, i);
+ eleObj = typePtr->indexProc(abstractListObjPtr, i);
Tcl_GetStringFromObj(eleObj, &slen);
length += slen + 1; /* one more for the space char */
Tcl_DecrRefCount(eleObj);
@@ -286,7 +278,7 @@ UpdateStringOfAbstractList(Tcl_Obj *abstractListObjPtr)
p = Tcl_InitStringRep(abstractListObjPtr, NULL, length);
for (i = 0; i < llen; i++) {
- eleObj = abstractListRepPtr->indexProc(abstractListObjPtr, i);
+ eleObj = typePtr->indexProc(abstractListObjPtr, i);
str = Tcl_GetStringFromObj(eleObj, &slen);
strcpy(p, str);
p[slen] = ' ';
@@ -296,75 +288,6 @@ UpdateStringOfAbstractList(Tcl_Obj *abstractListObjPtr)
if (length > 0) abstractListObjPtr->bytes[length-1] = '\0';
abstractListObjPtr->length = length-1;
}
-#endif // end depricated
-
-static void
-UpdateStringOfAbstractList(
- Tcl_Obj *abstractListObjPtr) /* AbstractList object with string rep to update. */
-{
-# define LOCAL_SIZE 64
- char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- ListSizeT numElems, i, length, bytesNeeded = 0;
- const char *elem, *start;
- Tcl_Obj *elemObj;
- char *dst;
- AbstractList* abstractListRepPtr = AbstractListGetInternalRep(abstractListObjPtr);
-
- numElems = abstractListRepPtr->lengthProc(abstractListObjPtr);
- /* Handle empty list case first, so rest of the routine is simpler. */
-
- if (numElems == 0) {
- Tcl_InitStringRep(abstractListObjPtr, NULL, 0);
- return;
- }
-
- /* Pass 1: estimate space, gather flags. */
-
- if (numElems <= LOCAL_SIZE) {
- flagPtr = localFlags;
- } else {
- /* We know numElems <= LIST_MAX, so this is safe. */
- flagPtr = (char *)ckalloc(numElems);
- }
- for (i = 0; i < numElems; i++) {
- flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
- elemObj = abstractListRepPtr->indexProc(abstractListObjPtr, i);
- elem = TclGetStringFromObj(elemObj, &length);
- bytesNeeded += TclScanElement(elem, length, flagPtr+i);
- if (bytesNeeded < 0) {
- /* TODO - what is the max #define for Tcl9? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
- Tcl_DecrRefCount(elemObj);
- }
- /* TODO - what is the max #define for Tcl9? */
- if (bytesNeeded > INT_MAX - numElems + 1) {
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
- bytesNeeded += numElems - 1;
-
- /*
- * Pass 2: copy into string rep buffer.
- */
-
- start = dst = Tcl_InitStringRep(abstractListObjPtr, NULL, bytesNeeded);
- TclOOM(dst, bytesNeeded);
- for (i = 0; i < numElems; i++) {
- flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
- elemObj = abstractListRepPtr->indexProc(abstractListObjPtr, i);
- elem = TclGetStringFromObj(elemObj, &length);
- dst += TclConvertElement(elem, length, dst, flagPtr[i]);
- *dst++ = ' ';
- Tcl_DecrRefCount(elemObj);
- }
-
- /* Set the string length to what was actually written, the safe choice */
- (void) Tcl_InitStringRep(abstractListObjPtr, NULL, dst - 1 - start);
-
- if (flagPtr != localFlags) {
- ckfree(flagPtr);
- }
-}
/*
*----------------------------------------------------------------------
@@ -395,6 +318,10 @@ SetAbstractListFromAny(interp, objPtr)
{
(void)interp;
(void)objPtr;
+ /* TODO - at some future point, should just shimmer to a traditional
+ * Tcl list (but only when those are implemented under the AbstractList)
+ * interface.
+ */
Tcl_Panic("SetAbstractListFromAny: should never be called");
return TCL_ERROR;
}
@@ -429,10 +356,8 @@ TclAbstractListObjCopy(
* to be returned. */
{
Tcl_Obj *copyPtr;
- AbstractList *abstractListRepPtr;
- abstractListRepPtr = AbstractListGetInternalRep(abstractListObjPtr);
- if (NULL == abstractListRepPtr) {
+ if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) {
if (SetAbstractListFromAny(interp, abstractListObjPtr) != TCL_OK) {
/* We know this is going to panic, but it's the message we want */
return NULL;
@@ -471,9 +396,25 @@ Tcl_AbstractListObjRange(
Tcl_WideInt fromIdx, /* Index of first element to include. */
Tcl_WideInt toIdx) /* Index of last element to include. */
{
- AbstractList *abstractListRepPtr =
- AbstractListGetInternalRep(abstractListObjPtr);
- return abstractListRepPtr->sliceProc(abstractListObjPtr, fromIdx, toIdx);
+ Tcl_AbstractListType *typePtr;
+ if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) {
+ if (SetAbstractListFromAny(NULL, abstractListObjPtr) != TCL_OK) {
+ /* We know this is going to panic, but it's the message we want */
+ return NULL;
+ }
+ }
+ typePtr = Tcl_AbstractListGetType(abstractListObjPtr);
+ /*
+ * sliceProc can be NULL, then revert to List. Note: [lrange]
+ * command also checks for NULL sliceProc, and won't call AbstractList
+ */
+ if (typePtr->sliceProc) {
+ return typePtr->sliceProc(abstractListObjPtr, fromIdx, toIdx);
+ } else {
+ /* TODO ?shimmer avoided? */
+ Tcl_Obj *newObj = TclListObjCopy(NULL, abstractListObjPtr);
+ return newObj ? TclListObjRange(newObj, (ListSizeT)fromIdx, (ListSizeT)toIdx) : NULL;
+ }
}
/*
@@ -500,9 +441,16 @@ Tcl_Obj *
Tcl_AbstractListObjReverse(
Tcl_Obj *abstractListObjPtr) /* List object to take a range from. */
{
- AbstractList *abstractListRepPtr =
- AbstractListGetInternalRep(abstractListObjPtr);
- return abstractListRepPtr->reverseProc(abstractListObjPtr);
+ Tcl_AbstractListType *typePtr;
+ if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType) ||
+ !TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_REVERSE)) {
+ if (SetAbstractListFromAny(NULL, abstractListObjPtr) != TCL_OK) {
+ /* We know this is going to panic, but it's the message we want */
+ return NULL;
+ }
+ }
+ typePtr = Tcl_AbstractListGetType(abstractListObjPtr);
+ return typePtr->reverseProc(abstractListObjPtr);
}
@@ -547,38 +495,21 @@ Tcl_AbstractListObjGetElements(
{
if (TclHasInternalRep(objPtr,&tclAbstractListType)) {
- AbstractList *abstractListRepPtr =
- AbstractListGetInternalRep(objPtr);
- Tcl_Obj **objv;
- int i, objc = abstractListRepPtr->lengthProc(objPtr);
-
- if (objc > 0) {
- if (abstractListRepPtr->elements) {
- /* If this exists, it has already been populated */
- objv = abstractListRepPtr->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;
- }
- abstractListRepPtr->elements = objv;
- for (i = 0; i < objc; i++) {
- objv[i] = abstractListRepPtr->indexProc(objPtr, i);
- Tcl_IncrRefCount(objv[i]);
- }
- }
- } else {
- objv = NULL;
- }
- *objvPtr = objv;
- *objcPtr = objc;
+ Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr);
+
+ if (TclAbstractListHasProc(objPtr, TCL_ABSL_GETELEMENTS)) {
+ int status = typePtr->getElementsProc(interp, objPtr, objcPtr, objvPtr);
+ /* TODO -- Add error message here, or propagate interp down */
+ return status;
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("GetElements not supported!", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ }
+ return TCL_ERROR;
} else {
if (interp != NULL) {
Tcl_SetObjResult(
@@ -591,44 +522,6 @@ Tcl_AbstractListObjGetElements(
return TCL_OK;
}
-int
-Tcl_AbstractListSetProc(
- Tcl_Obj *objPtr,
- Tcl_AbstractListProcType ptype,
- void *proc)
-{
- AbstractList* al_internalRep = AbstractListGetInternalRep(objPtr);
-
- if (al_internalRep == NULL) {
- return TCL_ERROR;
- }
-
- switch (ptype) {
- case TCL_ABSL_NEW:
- al_internalRep->newObjProc = (Tcl_ALNewObjProc *)proc;
- break;
- case TCL_ABSL_DUPREP:
- al_internalRep->dupRepProc = (Tcl_ALDupRepProc *)proc;
- break;
- case TCL_ABSL_LENGTH:
- al_internalRep->lengthProc = (Tcl_ALLengthProc *)proc;
- break;
- case TCL_ABSL_INDEX:
- al_internalRep->indexProc = (Tcl_ALIndexProc *)proc;
- break;
- case TCL_ABSL_SLICE:
- al_internalRep->sliceProc = (Tcl_ALSliceProc *)proc;
- break;
- case TCL_ABSL_REVERSE:
- al_internalRep->reverseProc = (Tcl_ALReverseProc *)proc;
- break;
- default:
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-
/*
* Local Variables:
* mode: c
diff --git a/generic/tclAbstractList.h b/generic/tclAbstractList.h
index dc45709..80ae269 100644
--- a/generic/tclAbstractList.h
+++ b/generic/tclAbstractList.h
@@ -1,7 +1,7 @@
/*
* tclAbstractList.h --
*
- * The AbstractList Obj Type -- a psuedo List
+ * The AbstractList Obj Type -- a psuedo List
*
* Copyright © 2022 by Brian Griffin. All rights reserved.
*
@@ -14,31 +14,21 @@
#include "tclInt.h"
-static inline AbstractList* AbstractListGetInternalRep(
- Tcl_Obj *objPtr) /* Object of type AbstractList */
-{
- const Tcl_ObjInternalRep *irPtr;
- irPtr = TclFetchInternalRep((objPtr), &tclAbstractListType);
- return irPtr ? (AbstractList *)(irPtr->twoPtrValue.ptr1) : NULL;
-}
-
-
static inline const char*
Tcl_AbstractListTypeName(
Tcl_Obj *objPtr) /* Should be of type AbstractList */
{
- AbstractList *abstractListRepPtr =
- AbstractListGetInternalRep(objPtr);
- return (abstractListRepPtr->typeName
- ? abstractListRepPtr->typeName
- : (objPtr->typePtr
- ? objPtr->typePtr->name
- : "pure string"));
+ Tcl_AbstractListType *typePtr;
+ typePtr = Tcl_AbstractListGetType(objPtr);
+ if (typePtr && typePtr->typeName) {
+ return typePtr->typeName;
+ } else {
+ return "abstractlist";
+ }
}
-
-Tcl_Obj* Tcl_NewAbstractListObj(Tcl_Interp *interp, const char* typeName, size_t requiredSize);
-int Tcl_AbstractListCheckedSetProc(Tcl_Obj *objPtr, Tcl_AbstractListProcType ptype, void** procPtr);
+Tcl_Obj *Tcl_NewAbstractListObj(Tcl_Interp *interp, const Tcl_AbstractListType *);
+int Tcl_AbstractListCheckedSetProc(Tcl_Obj *objPtr, Tcl_AbstractListProcType ptype, void **procPtr);
Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr);
Tcl_Obj* Tcl_AbstractListObjIndex(Tcl_Obj *abstractListPtr, Tcl_WideInt index);
Tcl_Obj* Tcl_AbstractListObjRange(Tcl_Obj *abstractListPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx);
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index dd2b6cf..91a22ec 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -187,12 +187,13 @@ typedef enum Sequence_Decoded {
* but it's faster to cache it inside the internal representation.
*/
typedef struct ArithSeries {
- const char *name;
- Tcl_WideInt start;
- Tcl_WideInt end;
- Tcl_WideInt step;
- Tcl_WideInt len;
-
+ Tcl_WideInt start; /* first (left most) value */
+ Tcl_WideInt end; /* last (right most or greater) value */
+ Tcl_WideInt step; /* increment value */
+ Tcl_WideInt len; /* total number of elements in list (has priority
+ ** over "end") */
+ Tcl_Obj **elements; /* List elements array, only used when absolutely
+ ** necessary. */
} ArithSeries;
@@ -3915,8 +3916,8 @@ Tcl_LsearchObjCmd(
}
Tcl_SetObjResult(interp, itemPtr);
} else {
- Tcl_Obj *elObj;
- TclNewIndexObj(elObj, index);
+ Tcl_Obj *elObj;
+ TclNewIndexObj(elObj, index);
Tcl_SetObjResult(interp, elObj);
}
} else if (index < 0) {
@@ -3984,14 +3985,13 @@ Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
Tcl_Obj*Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index);
Tcl_Obj *TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx);
Tcl_Obj *TclArithSeriesObjReverse(Tcl_Obj *arithSeriesObjPtr);
+int TclArithSeriesGetElements(Tcl_Interp *interp, Tcl_Obj *arithSeriesObjPtr,
+ int *objcPtr, Tcl_Obj ***objvPtr);
+static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
-#define ArithSeriesRepPtr(arithSeriesObjPtr) \
- (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr2)
-
-#define ArithSeriesIndexM(arithSeriesRepPtr, index) \
- (arithSeriesRepPtr)->start+((index)*arithSeriesRepPtr->step)
+#define ArithSeriesIndexM(arithSeriesPtr, index) \
+ (arithSeriesPtr)->start+((index) * (arithSeriesPtr)->step)
-
/*
*----------------------------------------------------------------------
*
@@ -4028,10 +4028,11 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
/*
*----------------------------------------------------------------------
*
- * DupAbstractListInternalRep --
+ * DupArithSeriesRep --
*
- * Initialize the internal representation of a AbstractList Tcl_Obj to a
- * copy of the internal representation of an existing arithseries object.
+ * Initialize the internal representation of a ArithSeries abstract list
+ * Tcl_Obj to a copy of the internal representation of an existing
+ * arithseries object.
*
* Results:
* None.
@@ -4045,17 +4046,59 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step)
static void
DupArithSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
{
- ArithSeries *srcArithSeries = (ArithSeries*)Tcl_AbstractListGetTypeRep(srcPtr);
- ArithSeries *copyArithSeries = (ArithSeries*)Tcl_AbstractListGetTypeRep(copyPtr);
+ ArithSeries *srcArithSeries = (ArithSeries*)Tcl_AbstractListGetConcreteRep(srcPtr);
+ ArithSeries *copyArithSeries = (ArithSeries *)ckalloc(sizeof(ArithSeries));
- copyArithSeries->name = "arithseries";
- copyArithSeries->start = srcArithSeries->start;
- copyArithSeries->end = srcArithSeries->end;
- copyArithSeries->step = srcArithSeries->step;
- copyArithSeries->len = srcArithSeries->len;
+ *copyArithSeries = *srcArithSeries;
+ /* Note: we do not have to be worry about existing internal rep because
+ copyPtr is supposed to be freshly initialized */
+ Tcl_AbstractListSetConcreteRep(copyPtr, copyArithSeries);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesRep --
+ *
+ * Free any allocated memory in the ArithSeries Rep
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+static void FreeArithSeriesRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */
+{
+ ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+ if (arithSeriesPtr) {
+ if (arithSeriesPtr->elements) {
+ ckfree((char*)arithSeriesPtr->elements);
+ arithSeriesPtr->elements = NULL;
+ }
+ ckfree((char*)arithSeriesPtr);
+ }
}
+
+
+static Tcl_AbstractListType arithSeriesType = {
+ TCL_ABSTRACTLIST_VERSION_1,
+ "arithseries",
+ Tcl_NewArithSeriesObj,
+ DupArithSeriesRep,
+ Tcl_ArithSeriesObjLength,
+ Tcl_ArithSeriesObjIndex,
+ TclArithSeriesObjRange,
+ TclArithSeriesObjReverse,
+ TclArithSeriesGetElements,
+ FreeArithSeriesRep,
+ UpdateStringOfArithSeries
+};
+
/*
*----------------------------------------------------------------------
*
@@ -4079,30 +4122,30 @@ Tcl_Obj *
TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len)
{
Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step));
- Tcl_Obj *arithSeriesPtr;
- ArithSeries *arithSeriesRepPtr;
- static const char *arithSeriesName = "arithseries";
- if (length == -1) return NULL; /* Invalid range error */
-
- arithSeriesPtr = Tcl_NewAbstractListObj(NULL, arithSeriesName, sizeof (ArithSeries));
- arithSeriesRepPtr = (ArithSeries*)Tcl_AbstractListGetTypeRep(arithSeriesPtr);
- arithSeriesRepPtr->start = start;
- arithSeriesRepPtr->end = end;
- arithSeriesRepPtr->step = step;
- arithSeriesRepPtr->len = length;
- Tcl_SetAbstractListNewProc( arithSeriesPtr, Tcl_NewArithSeriesObj );
- Tcl_SetAbstractListLengthProc( arithSeriesPtr, Tcl_ArithSeriesObjLength );
- Tcl_SetAbstractListIndexProc( arithSeriesPtr, Tcl_ArithSeriesObjIndex );
- Tcl_SetAbstractListSliceProc( arithSeriesPtr, TclArithSeriesObjRange );
- Tcl_SetAbstractListReverseProc( arithSeriesPtr, TclArithSeriesObjReverse );
- Tcl_SetAbstractListDupRepProc( arithSeriesPtr, DupArithSeriesRep );
-
- if (length > 0) {
- Tcl_InvalidateStringRep(arithSeriesPtr);
- } else {
- Tcl_InitStringRep(arithSeriesPtr, NULL, 0);
+ ArithSeries *arithSeriesPtr;
+ Tcl_Obj *arithSeriesObj;
+
+ if (length <= 0) {
+ TclNewObj(arithSeriesObj);
+ return arithSeriesObj;
}
- return arithSeriesPtr;
+
+ /* Allocate internal representation */
+ arithSeriesPtr = (ArithSeries*)ckalloc(sizeof(ArithSeries));
+ arithSeriesPtr->start = start;
+ arithSeriesPtr->end = end;
+ arithSeriesPtr->step = step;
+ arithSeriesPtr->len = length;
+ arithSeriesPtr->elements = NULL;
+
+ /* Store the internal rep in a new AbstrictList Tcl_Obj */
+ arithSeriesObj = Tcl_NewAbstractListObj(NULL, &arithSeriesType);
+ Tcl_AbstractListSetConcreteRep(arithSeriesObj,arithSeriesPtr);
+
+ if (length == 0) {
+ Tcl_InitStringRep(arithSeriesObj, NULL, 0);
+ }
+ return arithSeriesObj;
}
Tcl_Obj *
@@ -4145,18 +4188,18 @@ Tcl_NewArithSeriesObj(int objc, Tcl_Obj *objv[])
Tcl_Obj*
Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesObjPtr, Tcl_WideInt index)
{
- ArithSeries *arithSeriesRepPtr;
+ ArithSeries *arithSeriesPtr;
Tcl_WideInt element;
- if (arithSeriesObjPtr->typePtr != &tclAbstractListType) {
- Tcl_Panic("Tcl_ArithSeriesObjIndex called with a not ArithSeries Obj.");
- }
- arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObjPtr);
- if (index < 0 || index >= arithSeriesRepPtr->len)
+ assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
+
+ arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+
+ if (index < 0 || index >= arithSeriesPtr->len)
return NULL;
/* List[i] = Start + (Step * i) */
- element = ArithSeriesIndexM(arithSeriesRepPtr, index);
+ element = ArithSeriesIndexM(arithSeriesPtr, index);
return Tcl_NewWideIntObj(element);
}
@@ -4180,8 +4223,10 @@ Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesObjPtr, Tcl_WideInt index)
*/
Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesObjPtr)
{
- ArithSeries *arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObjPtr);
- return arithSeriesRepPtr->len;
+ assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
+
+ ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+ return arithSeriesPtr->len;
}
/*
@@ -4209,12 +4254,12 @@ TclArithSeriesObjRange(
Tcl_WideInt fromIdx, /* Index of first element to include. */
Tcl_WideInt toIdx) /* Index of last element to include. */
{
- ArithSeries *arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObjPtr);
- Tcl_WideInt start = -1, end = -1, step, len;
- Tcl_Obj *fromObj, *toObj;
+ ArithSeries *arithSeriesPtr;
+ Tcl_WideInt start = -1, end = -1, step, len;
- arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObjPtr);
+ assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
+ arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
if (fromIdx < 0) {
fromIdx = 0;
@@ -4225,18 +4270,11 @@ TclArithSeriesObjRange(
return obj;
}
- fromObj = Tcl_ArithSeriesObjIndex(arithSeriesObjPtr, fromIdx);
- if (fromObj == NULL) return NULL;
- toObj = Tcl_ArithSeriesObjIndex(arithSeriesObjPtr, toIdx);
- if (toObj == NULL) return NULL;
- Tcl_GetWideIntFromObj(NULL, fromObj, &start);
- Tcl_DecrRefCount(fromObj);
- Tcl_GetWideIntFromObj(NULL, toObj, &end);
- Tcl_DecrRefCount(toObj);
- step = arithSeriesRepPtr->step;
+ start = ArithSeriesIndexM(arithSeriesPtr, fromIdx);
+ end = ArithSeriesIndexM(arithSeriesPtr, toIdx);
+ step = arithSeriesPtr->step;
len = ArithSeriesLen(start, end, step);
-
if (Tcl_IsShared(arithSeriesObjPtr) ||
((arithSeriesObjPtr->refCount > 1))) {
return TclNewArithSeriesObj(start, end, step, len);
@@ -4253,10 +4291,10 @@ TclArithSeriesObjRange(
TclInvalidateStringRep(arithSeriesObjPtr);
- arithSeriesRepPtr->start = start;
- arithSeriesRepPtr->end = end;
- arithSeriesRepPtr->step = step;
- arithSeriesRepPtr->len = len;
+ arithSeriesPtr->start = start;
+ arithSeriesPtr->end = end;
+ arithSeriesPtr->step = step;
+ arithSeriesPtr->len = len;
return arithSeriesObjPtr;
}
@@ -4269,13 +4307,16 @@ Tcl_Obj *
TclArithSeriesObjReverse(
Tcl_Obj *arithSeriesObjPtr) /* List object to take a range from. */
{
- ArithSeries *arithSeriesPtr = ArithSeriesRepPtr(arithSeriesObjPtr);
+ ArithSeries *arithSeriesPtr;
Tcl_Obj *resultObjPtr;
Tcl_WideInt rstart, rend, rstep, len;
+ assert(Tcl_AbstractListGetType(arithSeriesObjPtr) == &arithSeriesType);
+ arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+
len = arithSeriesPtr->len;
rend = ArithSeriesIndexM(arithSeriesPtr, 0);
- rstart = ArithSeriesIndexM(arithSeriesPtr, len-1);
+ rstart = ArithSeriesIndexM(arithSeriesPtr, (len-1));
rstep = -arithSeriesPtr->step;
if (Tcl_IsShared(arithSeriesObjPtr)) {
@@ -4289,7 +4330,113 @@ TclArithSeriesObjReverse(
}
return resultObjPtr;
}
+/*
+** Handle ArithSeries GetElements call
+*/
+
+int
+TclArithSeriesGetElements(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *arithSeriesObjPtr, /* ArithSeries object for which an element
+ * array is to be returned. */
+ int *objcPtr, /* Where to store the count of objects
+ * referenced by objv. */
+ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
+ * pointers to the list's objects. */
+{
+
+ if (TclHasInternalRep(arithSeriesObjPtr,&tclAbstractListType)) {
+ ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr);
+ Tcl_AbstractListType *typePtr;
+ Tcl_Obj **objv;
+ int i, objc;
+
+ typePtr = Tcl_AbstractListGetType(arithSeriesObjPtr);
+
+ objc = Tcl_ArithSeriesObjLength(arithSeriesObjPtr);
+
+ if (objvPtr == NULL) {
+ if (objcPtr) {
+ *objcPtr = objc;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+ }
+
+ if (objc && objvPtr && arithSeriesPtr->elements) {
+ objv = arithSeriesPtr->elements;
+ } else if (objc > 0) {
+ objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc);
+ if (objv == NULL) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ for (i = 0; i < objc; i++) {
+ objv[i] = typePtr->indexProc(arithSeriesObjPtr, i);
+ }
+ } else {
+ objv = NULL;
+ }
+ arithSeriesPtr->elements = objv;
+ *objvPtr = objv;
+ *objcPtr = objc;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an abstract list"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+static void
+UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr)
+{
+ char *p, *str;
+ Tcl_Obj *eleObj;
+ Tcl_WideInt length = 0;
+ int llen, slen, i;
+
+ /*
+ * Pass 1: estimate space.
+ */
+ llen = Tcl_ArithSeriesObjLength(arithSeriesObjPtr);
+ if (llen <= 0) {
+ Tcl_InitStringRep(arithSeriesObjPtr, NULL, 0);
+ return;
+ }
+ for (i = 0; i < llen; i++) {
+ eleObj = Tcl_ArithSeriesObjIndex(arithSeriesObjPtr, i);
+ Tcl_GetStringFromObj(eleObj, &slen);
+ length += slen + 1; /* one more for the space char */
+ Tcl_DecrRefCount(eleObj);
+ }
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, length);
+ for (i = 0; i < llen; i++) {
+ eleObj = Tcl_ArithSeriesObjIndex(arithSeriesObjPtr, i);
+ str = Tcl_GetStringFromObj(eleObj, &slen);
+ strcpy(p, str);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(eleObj);
+ }
+ if (length > 0) arithSeriesObjPtr->bytes[length-1] = '\0';
+ arithSeriesObjPtr->length = length-1;
+}
/*
*----------------------------------------------------------------------
@@ -4488,11 +4635,7 @@ Tcl_LseqObjCmd(
start = values[0];
end = values[1];
step = (start <= end) ? 1 : -1;
- if (start <= end) {
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- } else {
- elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list
- }
+ elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
if (elementCount < 0) elementCount = 0;
break;
@@ -4501,11 +4644,7 @@ Tcl_LseqObjCmd(
start = values[0];
end = values[1];
step = values[2];
- if (start <= end) {
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- } else {
- elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list
- }
+ elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
if (elementCount < 0) elementCount = 0;
break;
@@ -4527,7 +4666,6 @@ Tcl_LseqObjCmd(
elementCount = values[0];
step = values[2];
end = start + (step * elementCount);
- elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list
break;
case LSEQ_COUNT:
start = values[0];
@@ -4551,6 +4689,7 @@ Tcl_LseqObjCmd(
start = values[0];
end = values[2];
step = values[3];
+ elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
break;
case LSEQ_COUNT:
start = values[0];
@@ -4592,11 +4731,7 @@ Tcl_LseqObjCmd(
goto done;
break;
}
- if (start <= end) {
- elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
- } else {
- elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list
- }
+ elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
break;
/* lseq n 'to' n 'by' n */
@@ -4619,13 +4754,7 @@ Tcl_LseqObjCmd(
case LSEQ_TO:
start = values[0];
end = values[2];
- if ((step == 0) || // 0 step --> empty list
- (start < end && step < 0) || // step sign mismatch with end-start
- (start > end && step > 0)) { // --> empty list
- elementCount = 0;
- } else {
- elementCount = (end-start+step)/step;
- }
+ elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list
break;
case LSEQ_COUNT:
start = values[0];
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 3cc257c..03e397d 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -1987,10 +1987,7 @@ EXTERN Tcl_Obj * Tcl_AbstractListObjRange(Tcl_Obj *abstractListPtr,
EXTERN Tcl_Obj * Tcl_AbstractListObjReverse(Tcl_Obj *abstractListPtr);
/* 678 */
EXTERN Tcl_Obj * Tcl_NewAbstractListObj(Tcl_Interp *interp,
- const char*typeName, size_t requiredSize);
-/* 679 */
-EXTERN int Tcl_AbstractListSetProc(Tcl_Obj *objPtr,
- Tcl_AbstractListProcType ptype, void *proc);
+ const Tcl_AbstractListType*vTablePtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2704,8 +2701,7 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_AbstractListObjIndex) (Tcl_Obj *abstractListPtr, Tcl_WideInt index); /* 675 */
Tcl_Obj * (*tcl_AbstractListObjRange) (Tcl_Obj *abstractListPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx); /* 676 */
Tcl_Obj * (*tcl_AbstractListObjReverse) (Tcl_Obj *abstractListPtr); /* 677 */
- Tcl_Obj * (*tcl_NewAbstractListObj) (Tcl_Interp *interp, const char*typeName, size_t requiredSize); /* 678 */
- int (*tcl_AbstractListSetProc) (Tcl_Obj *objPtr, Tcl_AbstractListProcType ptype, void *proc); /* 679 */
+ Tcl_Obj * (*tcl_NewAbstractListObj) (Tcl_Interp *interp, const Tcl_AbstractListType*vTablePtr); /* 678 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -4094,8 +4090,6 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_AbstractListObjReverse) /* 677 */
#define Tcl_NewAbstractListObj \
(tclStubsPtr->tcl_NewAbstractListObj) /* 678 */
-#define Tcl_AbstractListSetProc \
- (tclStubsPtr->tcl_AbstractListSetProc) /* 679 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2e72d86..7a0456b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4863,15 +4863,15 @@ TEBCresume(
/* special case for AbstractList */
if (TclHasInternalRep(valuePtr,&tclAbstractListType)) {
- AbstractList *abstractListRepPtr =
- (AbstractList*) valuePtr->internalRep.twoPtrValue.ptr1;
- length = abstractListRepPtr->lengthProc(valuePtr);
+ Tcl_AbstractListType *typePtr;
+ typePtr = Tcl_AbstractListGetType(valuePtr);
+ length = typePtr->lengthProc(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
- objResultPtr = abstractListRepPtr->indexProc(valuePtr, index);
+ objResultPtr = typePtr->indexProc(valuePtr, index);
goto lindexDone;
}
@@ -4896,7 +4896,7 @@ TEBCresume(
}
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
-
+
lindexDone:
if (!objResultPtr) {
TRACE_ERROR(interp);
@@ -4928,9 +4928,9 @@ TEBCresume(
/* special case for AbstractList */
if (TclHasInternalRep(valuePtr,&tclAbstractListType)) {
- AbstractList* abstractListRepPtr =
- (AbstractList *) valuePtr->internalRep.twoPtrValue.ptr1;
- length = abstractListRepPtr->lengthProc(valuePtr);
+ Tcl_AbstractListType *typePtr;
+ typePtr = Tcl_AbstractListGetType(valuePtr);
+ length = typePtr->lengthProc(valuePtr);
/* Decode end-offset index values. */
@@ -4938,7 +4938,7 @@ TEBCresume(
/* Compute value @ index */
if (index >= 0 && index < length) {
- objResultPtr = abstractListRepPtr->indexProc(valuePtr, index);
+ objResultPtr = typePtr->indexProc(valuePtr, index);
} else {
TclNewObj(objResultPtr);
}
@@ -4963,9 +4963,9 @@ TEBCresume(
} else {
TclNewObj(objResultPtr);
}
-
+
lindexFastPath2:
-
+
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
@@ -5142,13 +5142,11 @@ TEBCresume(
fromIdx = TclIndexDecode(fromIdx, objc - 1);
{
- AbstractList* abstractListRepPtr =
- TclHasInternalRep(valuePtr,&tclAbstractListType)
- ? (AbstractList*)valuePtr->internalRep.twoPtrValue.ptr1
- : NULL;
+ Tcl_AbstractListType *typePtr;
+ typePtr = Tcl_AbstractListGetType(valuePtr);
- if (abstractListRepPtr && TclAbstractListHasProc(valuePtr, TCL_ABSL_SLICE)) {
- objResultPtr = abstractListRepPtr->sliceProc(valuePtr, fromIdx, toIdx);
+ if (typePtr && TclAbstractListHasProc(valuePtr, TCL_ABSL_SLICE)) {
+ objResultPtr = typePtr->sliceProc(valuePtr, fromIdx, toIdx);
} else {
objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx);
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index bb79e28..38927dc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2632,31 +2632,40 @@ typedef struct ListRep {
(((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
+#define AbstractListGetType(abstractListObjPtr) \
+ (Tcl_AbstractListType *) ((abstractListObjPtr)->internalRep.twoPtrValue.ptr1)
+
static inline Tcl_WideInt
AbstractListObjLength(Tcl_Obj* abstractListObjPtr)
{
- AbstractList *oaRepPtr =
- (AbstractList *)abstractListObjPtr->internalRep.twoPtrValue.ptr1;
- return oaRepPtr->lengthProc(abstractListObjPtr);
+ Tcl_AbstractListType *typePtr =
+ (Tcl_AbstractListType *) abstractListObjPtr->internalRep.twoPtrValue.ptr1;
+ return typePtr->lengthProc(abstractListObjPtr);
}
static inline int
TclAbstractListHasProc(Tcl_Obj* abstractListObjPtr, Tcl_AbstractListProcType ptype)
{
- AbstractList* repPtr = Tcl_AbstractListRepPtr(abstractListObjPtr);
+ Tcl_AbstractListType *typePtr = AbstractListGetType(abstractListObjPtr);
switch (ptype) {
case TCL_ABSL_NEW:
- return (repPtr->newObjProc != NULL);
+ return (typePtr->newObjProc != NULL);
case TCL_ABSL_DUPREP:
- return (repPtr->dupRepProc != NULL);
+ return (typePtr->dupRepProc != NULL);
case TCL_ABSL_LENGTH:
- return (repPtr->lengthProc != NULL);
+ return (typePtr->lengthProc != NULL);
case TCL_ABSL_INDEX:
- return (repPtr->indexProc != NULL);
+ return (typePtr->indexProc != NULL);
case TCL_ABSL_SLICE:
- return (repPtr->sliceProc != NULL);
+ return (typePtr->sliceProc != NULL);
case TCL_ABSL_REVERSE:
- return (repPtr->reverseProc != NULL);
+ return (typePtr->reverseProc != NULL);
+ case TCL_ABSL_GETELEMENTS:
+ return (typePtr->getElementsProc != NULL);
+ case TCL_ABSL_FREEREP:
+ return (typePtr->freeRepProc != NULL);
+ case TCL_ABSL_TOSTRING:
+ return (typePtr->toStringProc != NULL);
}
return 0;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index e5312b2..5c66f7e 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -2041,7 +2041,6 @@ const TclStubs tclStubs = {
Tcl_AbstractListObjRange, /* 676 */
Tcl_AbstractListObjReverse, /* 677 */
Tcl_NewAbstractListObj, /* 678 */
- Tcl_AbstractListSetProc, /* 679 */
};
/* !END!: Do not edit above this line. */
diff --git a/tests/lseq.test b/tests/lseq.test
index 082111b..0919813 100644
--- a/tests/lseq.test
+++ b/tests/lseq.test
@@ -73,33 +73,21 @@ 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.13 {count operation} -body {
+ lseq 5 count 5
+} -result {5 6 7 8 9}
-test lseq-1.14 {count with step} {
- -body {
- lseq 5 count 5 by 2
- }
- -result {5 7 9 11 13}
-}
+test lseq-1.14 {count with step} -body {
+ lseq 5 count 5 by 2
+} -result {5 7 9 11 13}
-test lseq-1.15 {count with decreasing step} {
- -body {
- lseq 5 count 5 by -2
- }
- -result {5 3 1 -1 -3}
-}
+test lseq-1.15 {count with decreasing step} -body {
+ lseq 5 count 5 by -2
+} -result {5 3 1 -1 -3}
-test lseq-1.16 {large numbers} {
- -body {
- lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
- }
- -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
-}
+test lseq-1.16 {large numbers} -body {
+ lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}]
+} -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000}
test lseq-1.17 {too many arguments} -body {
lseq 12 to 24 by 2 with feeling
@@ -113,6 +101,18 @@ 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
#
@@ -182,6 +182,17 @@ 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 {}
@@ -216,8 +227,9 @@ test lseq-3.4 {error case} -body {
} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by}
test lseq-3.5 {simple count and step arguments} {
- lseq 25 by 6
-} {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 150}
+ 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
@@ -335,7 +347,7 @@ test lseq-3.22 {edge case} {
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}
@@ -366,6 +378,10 @@ test lseq-3.28 {lreverse bug in ArithSeries} {} {
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-4.1 {end expressions} {
set start 7
lseq $start $start+11
@@ -377,11 +393,11 @@ test lseq-4.2 {start expressions} {
lmap t $tl {expr {$t - $base + 60}}
} {0 10 20 30 40 50 60}
-
# cleanup
::tcltest::cleanupTests
return
+#
# Local Variables:
# mode: tcl
# End:
--
cgit v0.12