summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h89
-rw-r--r--generic/tclAbstractList.c747
-rw-r--r--generic/tclAbstractList.h56
-rwxr-xr-xgeneric/tclArithSeries.c629
-rw-r--r--generic/tclArithSeries.h56
-rw-r--r--generic/tclBasic.c16
-rw-r--r--generic/tclBinary.c4
-rw-r--r--generic/tclClock.c2
-rw-r--r--generic/tclCmdAH.c27
-rw-r--r--generic/tclCmdIL.c353
-rw-r--r--generic/tclCmdMZ.c12
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclDictObj.c177
-rw-r--r--generic/tclEnsemble.c8
-rw-r--r--generic/tclEvent.c2
-rw-r--r--generic/tclExecute.c94
-rw-r--r--generic/tclIOGT.c2
-rw-r--r--generic/tclIORChan.c4
-rwxr-xr-x[-rw-r--r--]generic/tclIOUtil.c6
-rw-r--r--generic/tclInt.h92
-rw-r--r--generic/tclLink.c2
-rw-r--r--generic/tclListObj.c193
-rw-r--r--generic/tclObj.c127
-rw-r--r--generic/tclScan.c2
-rw-r--r--generic/tclStrToD.c12
-rw-r--r--generic/tclTest.c5
-rw-r--r--generic/tclTestABSList.c939
-rw-r--r--generic/tclTestObj.c5
-rw-r--r--generic/tclUtil.c24
-rw-r--r--generic/tclVar.c10
30 files changed, 2861 insertions, 836 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index b43fcec..3db2dd8 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -608,6 +608,28 @@ typedef void *(Tcl_InitNotifierProc) (void);
typedef void (Tcl_FinalizeNotifierProc) (void *clientData);
typedef void (Tcl_MainLoopProc) (void);
+/* Abstract List functions */
+typedef Tcl_Size (Tcl_ObjTypeLengthProc) (struct Tcl_Obj *listPtr);
+typedef int (Tcl_ObjTypeIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
+ Tcl_Size index, struct Tcl_Obj** elemObj);
+typedef int (Tcl_ObjTypeSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
+ Tcl_Size fromIdx, Tcl_Size toIdx,
+ struct Tcl_Obj **newObjPtr);
+typedef int (Tcl_ObjTypeReverseProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
+ struct Tcl_Obj **newObjPtr);
+typedef int (Tcl_ObjTypeGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
+ Tcl_Size *objcptr, struct Tcl_Obj ***objvptr);
+typedef struct Tcl_Obj* (Tcl_ObjTypeSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr,
+ Tcl_Size indexCount,
+ struct Tcl_Obj *const indexArray[],
+ struct Tcl_Obj *valueObj);
+typedef int (Tcl_ObjTypeReplaceProc) (Tcl_Interp *interp, struct Tcl_Obj *listObj,
+ Tcl_Size first, Tcl_Size numToDelete,
+ Tcl_Size numToInsert,
+ struct Tcl_Obj *const insertObjs[]);
+typedef int (Tcl_ObjTypeGetDblProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr,
+ double *doublePtr);
+
#ifndef TCL_NO_DEPRECATED
# define Tcl_PackageInitProc Tcl_LibraryInitProc
# define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc
@@ -637,11 +659,32 @@ typedef struct Tcl_ObjType {
* to this type. Frees the internal rep of the
* old type. Returns TCL_ERROR on failure. */
size_t version;
+
+ /* List emulation functions - ObjType Version 1 */
+ Tcl_ObjTypeLengthProc *lengthProc; /* Return the [llength] of the
+ ** AbstractList */
+ Tcl_ObjTypeIndexProc *indexProc; /* Return a value (Tcl_Obj) for
+ ** [lindex $al $index] */
+ Tcl_ObjTypeSliceProc *sliceProc; /* Return an AbstractList for
+ ** [lrange $al $start $end] */
+ Tcl_ObjTypeReverseProc *reverseProc; /* Return an AbstractList for
+ ** [lreverse $al] */
+ Tcl_ObjTypeGetElements *getElementsProc; /* Return an objv[] of all elements in
+ ** the list */
+ Tcl_ObjTypeSetElement *setElementProc; /* Replace the element at the indicie
+ ** with the given valueObj. */
+ Tcl_ObjTypeReplaceProc *replaceProc; /* Replace subset with subset */
+ Tcl_ObjTypeGetDblProc *getDoubleProc; /* GetDouble from internal rep */
} Tcl_ObjType;
-#define TCL_OBJTYPE_V0 0 /* Pre-Tcl 9. Set to 0 so compiler will auto-init
- * when existing code that does not init this
- * field is compiled with Tcl9 headers */
-#define TCL_OBJTYPE_CURRENT TCL_OBJTYPE_V0
+
+#define TCL_OBJTYPE_V0 0,0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */
+#define TCL_OBJTYPE_V1(a) 1,a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */
+
+#define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) 2, \
+ a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */
+
+#define TCL_OBJTYPE_CURRENT 2
+
/*
* The following structure stores an internal representation (internalrep) for
@@ -694,7 +737,6 @@ typedef struct Tcl_Obj {
Tcl_ObjInternalRep internalRep; /* The internal representation: */
} Tcl_Obj;
-
/*
*----------------------------------------------------------------------------
* The following definitions support Tcl's namespace facility. Note: the first
@@ -2427,6 +2469,25 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
+/*
+ * Free the Obj by effectively doing:
+ *
+ * Tcl_IncrRefCount(objPtr);
+ * Tcl_DecrRefCount(objPtr);
+ *
+ * This will free the obj if there are no references to the obj.
+ */
+# define Tcl_BumpObj(objPtr) \
+ TclBumpObj(objPtr, __FILE__, __LINE__)
+
+static inline void TclBumpObj(Tcl_Obj* objPtr, const char* fn, int line)
+{
+ if (objPtr) {
+ if ((objPtr)->refCount == 0) {
+ Tcl_DbDecrRefCount(objPtr, fn, line);
+ }
+ }
+}
#else
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
@@ -2446,6 +2507,24 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv);
# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
+
+/*
+ * Declare that obj will no longer be used or referenced.
+ * This will release the obj if there is no referece count,
+ * otherwise let it be.
+ */
+# define Tcl_BumpObj(objPtr) \
+ TclBumpObj(objPtr);
+
+static inline void TclBumpObj(Tcl_Obj* objPtr)
+{
+ if (objPtr) {
+ if ((objPtr)->refCount == 0) {
+ Tcl_DecrRefCount(objPtr);
+ }
+ }
+}
+
#endif
/*
diff --git a/generic/tclAbstractList.c b/generic/tclAbstractList.c
new file mode 100644
index 0000000..7c053da
--- /dev/null
+++ b/generic/tclAbstractList.c
@@ -0,0 +1,747 @@
+/*
+ * tclAbstractList.h --
+ *
+ * The AbstractList Obj Type -- a psuedo List
+ *
+ * Copyright © 2022 by Brian Griffin. All rights reserved.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tcl.h"
+#include "tclAbstractList.h"
+
+
+/* -------------------------- AbstractList object ---------------------------- */
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void DupAbstractListInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeAbstractListInternalRep (Tcl_Obj *listPtr);
+static int SetAbstractListFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfAbstractList (Tcl_Obj *listPtr);
+
+/*
+ * The structure below defines the AbstractList Tcl object type by means of
+ * procedures that can be invoked by generic object code.
+ *
+ * The abstract list object is a special case of Tcl list represented by a set
+ * of functions.
+ *
+ */
+
+const Tcl_ObjType tclAbstractListType = {
+ "abstractlist", /* name */
+ FreeAbstractListInternalRep, /* freeIntRepProc */
+ DupAbstractListInternalRep, /* dupIntRepProc */
+ UpdateStringOfAbstractList, /* updateStringProc */
+ SetAbstractListFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListLen --
+ *
+ * Compute the length of the equivalent list
+ *
+ * Results:
+ *
+ * The length of the list generated by the given range,
+ * that may be zero.
+ *
+ * Side effects:
+ *
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_WideInt
+Tcl_AbstractListObjLength(Tcl_Obj *abstractListObjPtr)
+{
+ return AbstractListObjLength(abstractListObjPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjNew()
+ *
+ * Creates a new AbstractList object. The returned object has
+ * refcount = 0.
+ *
+ * Results:
+ *
+ * A Tcl_Obj pointer to the created AbstractList object.
+ * A NULL pointer of the range is invalid.
+ *
+ * Side Effects:
+ *
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_AbstractListObjNew(Tcl_Interp *interp, const Tcl_AbstractListType* vTablePtr)
+{
+ Tcl_Obj *objPtr;
+ Tcl_ObjInternalRep itr;
+ (void)interp;
+ TclNewObj(objPtr);
+ Tcl_StoreInternalRep(objPtr, &tclAbstractListType, &itr);
+ Tcl_AbstractListSetType(objPtr, (void*)vTablePtr); /* dispatch table for concrete type */
+ Tcl_AbstractListSetConcreteRep(objPtr, NULL);
+ Tcl_InvalidateStringRep(objPtr);
+ return objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjIndex --
+ *
+ * Returns the element with the specified index in the list
+ * represented by the specified Abstract List 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:
+ *
+ * Element Tcl_Obj is returned on succes, NULL on index out of range.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AbstractListObjIndex(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *abstractListObjPtr, /* List obj */
+ Tcl_Size index, /* index to element of interest */
+ Tcl_Obj **elemObjPtr) /* Return value */
+{
+ Tcl_AbstractListType *typePtr;
+
+ 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) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("Tcl_AbstractListObjIndex called without and AbstractList Obj.", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ return TCL_ERROR;
+ }
+ }
+ return typePtr->indexProc(interp, abstractListObjPtr, index, elemObjPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeAbstractListInternalRep --
+ *
+ * Deallocate the storage associated with an abstract list object's
+ * internal representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees abstractListPtr's AbstractList* internal representation and
+ * sets listPtr's internalRep.twoPtrValue.ptr2 to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+FreeAbstractListInternalRep(Tcl_Obj *abstractListObjPtr)
+{
+ Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(abstractListObjPtr);
+
+ if (TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_FREEREP)) {
+ /* call the free callback for the concrete rep */
+ typePtr->freeRepProc(abstractListObjPtr);
+ }
+ abstractListObjPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ abstractListObjPtr->internalRep.twoPtrValue.ptr1 = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupAbstractListInternalRep --
+ *
+ * Initialize the internal representation of a AbstractList Tcl_Obj to a
+ * copy of the internal representation of an existing abstractlist object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * We set "copyPtr"s internal rep to a pointer to a
+ * newly allocated AbstractList structure.
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupAbstractListInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set.
+ * Internal rep must be clear, it is stomped */
+{
+ Tcl_AbstractListType *typePtr;
+ typePtr = Tcl_AbstractListGetType(srcPtr);
+ Tcl_AbstractListSetType(copyPtr, typePtr);
+ Tcl_AbstractListSetConcreteRep(copyPtr, NULL);
+
+ /* Now do concrete type dup. It is responsible for calling
+ Tcl_AbstractListSetConcreteRep to initialize ptr2 */
+
+ if (typePtr->dupRepProc) {
+ typePtr->dupRepProc(srcPtr, copyPtr);
+ } else {
+ /* TODO - or set it to NULL instead? */
+ Tcl_AbstractListSetConcreteRep
+ (copyPtr, Tcl_AbstractListGetConcreteRep(srcPtr));
+ }
+
+ copyPtr->typePtr = &tclAbstractListType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfAbstractList --
+ *
+ * Update the string representation for an abstractlist 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
+ * listlike-to-string conversion. This string will be empty if the
+ * AbstractList is empty.
+ *
+ * Notes:
+ * This simple approach is costly in that it forces a string rep for each
+ * element, which is then tossed. Improving the performance here may
+ * require implementing a custom size-calculation function for each
+ * subtype of AbstractList.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfAbstractList(Tcl_Obj *abstractListObjPtr)
+{
+# define LOCAL_SIZE 64
+ char localFlags[LOCAL_SIZE], *flagPtr = NULL;
+ Tcl_AbstractListType *typePtr;
+ char *p;
+ int bytesNeeded = 0;
+ int llen, i;
+
+ /*
+ * TODO - this function essentially adapts the UpdateStringOfList function
+ * for native lists. Both functions allocate temporary storage for
+ * localFlags. I'm not sure if that is the best strategy for performance
+ * as well as memory for large list sizes. Revisit to see if growing
+ * the allocation on the fly would be better. Essentially combine the
+ * TclScanElement and TclConvertElement into one loop, growing the
+ * destination allocation if necessary.
+ */
+
+ typePtr = Tcl_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;
+ }
+
+ /*
+ * TODO - do we need a AbstractList method to mark the list as canonical?
+ * Or perhaps are abstract lists always canonical?
+ * Mark the list as being canonical; although it will now have a string
+ * rep, it is one we derived through proper "canonical" quoting and so
+ * it's known to be free from nasties relating to [concat] and [eval].
+ * listRepPtr->canonicalFlag = 1;
+ */
+
+
+ /*
+ * Handle empty list case first, so rest of the routine is simpler.
+ */
+ llen = typePtr->lengthProc(abstractListObjPtr);
+ if (llen <= 0) {
+ Tcl_InitStringRep(abstractListObjPtr, NULL, 0);
+ return;
+ }
+
+ /*
+ * Pass 1: estimate space.
+ */
+ if (llen <= LOCAL_SIZE) {
+ flagPtr = localFlags;
+ } else {
+ /* We know numElems <= LIST_MAX, so this is safe. */
+ flagPtr = (char *) Tcl_Alloc(llen);
+ }
+ for (bytesNeeded = 0, i = 0; i < llen; i++) {
+ Tcl_Obj *elemObj;
+ const char *elemStr;
+ int elemLen;
+ flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
+ typePtr->indexProc(NULL, abstractListObjPtr, i, &elemObj);
+ Tcl_IncrRefCount(elemObj);
+ elemStr = TclGetStringFromObj(elemObj, &elemLen);
+ /* Note TclScanElement updates flagPtr[i] */
+ bytesNeeded += TclScanElement(elemStr, elemLen, flagPtr+i);
+ if (bytesNeeded < 0) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ Tcl_DecrRefCount(elemObj);
+ }
+ if (bytesNeeded > INT_MAX - llen + 1) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ bytesNeeded += llen; /* Separating spaces and terminating nul */
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+ abstractListObjPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
+ p = abstractListObjPtr->bytes;
+ for (i = 0; i < llen; i++) {
+ Tcl_Obj *elemObj;
+ const char *elemStr;
+ int elemLen;
+ flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
+ typePtr->indexProc(NULL, abstractListObjPtr, i, &elemObj);
+ Tcl_IncrRefCount(elemObj);
+ elemStr = TclGetStringFromObj(elemObj, &elemLen);
+ p += TclConvertElement(elemStr, elemLen, p, flagPtr[i]);
+ *p++ = ' ';
+ Tcl_DecrRefCount(elemObj);
+ }
+ p[-1] = '\0'; /* Overwrite last space added */
+
+ /* Length of generated string */
+ abstractListObjPtr->length = p - 1 - abstractListObjPtr->bytes;
+
+ if (flagPtr != localFlags) {
+ Tcl_Free(flagPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetAbstractListFromAny --
+ *
+ * The AbstractList object is just a way to optimize
+ * Lists space complexity, so no one should try to convert
+ * a string to an AbstractList 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
+SetAbstractListFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ (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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjCopy --
+ *
+ * Makes a "pure AbstractList" copy of an AbstractList 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
+ * abstractList value as *abstractListPtr does. The returned Tcl_Obj has a
+ * refCount of zero. If *abstractListPtr does not hold an AbstractList,
+ * NULL is returned, and if interp is non-NULL, an error message is
+ * recorded there.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_AbstractListObjCopy(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *abstractListObjPtr) /* List object for which an element array is
+ * to be returned. */
+{
+ Tcl_Obj *copyPtr;
+
+ 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;
+ }
+ }
+
+ TclNewObj(copyPtr);
+ TclInvalidateStringRep(copyPtr);
+ DupAbstractListInternalRep(abstractListObjPtr, copyPtr);
+ return copyPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjRange --
+ *
+ * Makes a slice of an AbstractList value.
+ * *abstractListObjPtr must be known to be a valid AbstractList.
+ *
+ * Results:
+ * Returns a pointer to the sliced array.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ *
+ * ?The possible conversion of the object referenced by
+ * abstractListObjPtr to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AbstractListObjRange(
+ Tcl_Interp *interp, /* For error messages. */
+ Tcl_Obj *abstractListObjPtr, /* List object to take a range from. */
+ Tcl_Size fromIdx, /* Index of first element to include. */
+ Tcl_Size toIdx, /* Index of last element to include. */
+ Tcl_Obj **newObjPtr) /* return value */
+{
+ Tcl_AbstractListType *typePtr;
+ if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("Not an AbstractList.", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ 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(interp, abstractListObjPtr, fromIdx, toIdx, newObjPtr);
+ } else {
+ /* TODO ?shimmer avoided? */
+ Tcl_Obj *newObj = TclListObjCopy(NULL, abstractListObjPtr);
+ *newObjPtr = (newObj ? TclListObjRange(newObj, (Tcl_Size)fromIdx, (Tcl_Size)toIdx) : NULL);
+ return (newObj ? TCL_OK : TCL_ERROR);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjReverse --
+ *
+ * Reverses the order of an AbstractList value.
+ * *abstractListObjPtr must be known to be a valid AbstractList.
+ *
+ * Results:
+ * Returns a pointer to the reversed array.
+ * This may be a new object or the same object if not shared.
+ *
+ * Side effects:
+ *
+ * ?The possible conversion of the object referenced by
+ * abstractListObjPtr to a list object.?
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AbstractListObjReverse(
+ Tcl_Interp *interp, /* for reporting errors. */
+ Tcl_Obj *abstractListObjPtr, /* List object to take a range from. */
+ Tcl_Obj **newObjPtr) /* New AbstractListObj */
+{
+ Tcl_AbstractListType *typePtr;
+
+ if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("Not an AbstractList.", -1));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (!TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_REVERSE)) {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("lreverse not supported!", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREVERSE", NULL);
+ }
+ return TCL_ERROR;
+ }
+ typePtr = Tcl_AbstractListGetType(abstractListObjPtr);
+ return typePtr->reverseProc(interp, abstractListObjPtr, newObjPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjGetElements --
+ *
+ * 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
+Tcl_AbstractListObjGetElements(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *objPtr, /* AbstractList object for which an element
+ * array is to be returned. */
+ Tcl_Size *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,&tclAbstractListType)) {
+ Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr);
+
+ if (TclAbstractListHasProc(objPtr, TCL_ABSL_GETELEMENTS)) {
+ int status = typePtr->getElementsProc(interp, objPtr, objcPtr, objvPtr);
+ 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(
+ interp,
+ Tcl_ObjPrintf("value is not an abstract list"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ * Returns pointer to the concrete type or NULL if not AbstractList or
+ * not abstract list of the same type as concrete type
+ */
+Tcl_AbstractListType *
+Tcl_AbstractListGetType(
+ Tcl_Obj *objPtr) /* Object of type AbstractList */
+{
+ if (objPtr->typePtr != &tclAbstractListType) {
+ return NULL;
+ }
+ return (Tcl_AbstractListType *) objPtr->internalRep.twoPtrValue.ptr2;
+}
+
+/* Returns the storage used by the concrete abstract list type */
+void* Tcl_AbstractListGetConcreteRep(
+ Tcl_Obj *objPtr) /* Object of type AbstractList */
+{
+ /* Public function, must check for NULL */
+ if (objPtr == NULL || objPtr->typePtr != &tclAbstractListType) {
+ return NULL;
+ }
+ return objPtr->internalRep.twoPtrValue.ptr1;
+}
+
+/* Replace or add the element in the list @indicies with the given new value
+ */
+Tcl_Obj *
+Tcl_AbstractListSetElement(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ Tcl_Size indexCount,
+ Tcl_Obj *const indexArray[],
+ Tcl_Obj *valueObj)
+{
+ Tcl_Obj *returnObj = NULL;
+
+ if (TclHasInternalRep(objPtr,&tclAbstractListType)) {
+ Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr);
+ if (TclAbstractListHasProc(objPtr, TCL_ABSL_SETELEMENT)) {
+ returnObj = typePtr->setElementProc(interp, objPtr, indexCount, indexArray, valueObj);
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("SetElement not supported!", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ returnObj = NULL;
+ }
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an abstract list"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ returnObj = NULL;
+ }
+ return returnObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AbstractListObjReplace --
+ *
+ * This function mimics the Tcl_ListObjReplace operation, iff the
+ * concrete abstract list type supports the Replace operation, and if
+ * not, it will return with an error.
+ *
+ * This function replaces zero or more elements of the abstract list
+ * referenced by listObj with the objects from an (objc,objv) array. The
+ * objc elements of the array referenced by objv replace the count
+ * elements in listPtr starting at first.
+ *
+ * If the argument first is zero or negative, it refers to the first
+ * element. If first is greater than or equal to the number of elements
+ * in the list, then no elements are deleted; the new elements are
+ * appended to the list. Count gives the number of elements to replace.
+ * If count is zero or negative then no elements are deleted; the new
+ * elements are simply inserted before first.
+ *
+ * The argument objv refers to an array of objc pointers to the new
+ * elements to be added to listPtr in place of those that were deleted.
+ * If objv is NULL, no new elements are added.
+ *
+ * Results:
+ * The return value is normally TCL_OK. If listPtr does not support the
+ * Replace opration then TCL_ERROR is returned and an error message will
+ * be left in the interpreter's result if interp is not NULL.
+ *
+ * Side effects:
+ * The ref counts of the objc elements in objv maybe incremented iff the
+ * concrete type retains a reference to the element(s), otherwise there
+ * will be no change to the ref counts. Similarly, the ref counts for
+ * replaced objects are decremented. listObj's old string representation,
+ * if any, is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+int Tcl_AbstractListObjReplace(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* List object whose elements to replace. */
+ Tcl_Size first, /* Index of first element to replace. */
+ Tcl_Size numToDelete, /* Number of elements to replace. */
+ Tcl_Size numToInsert, /* Number of objects to insert. */
+ Tcl_Obj *const insertObjs[]) /* Tcl objects to insert */
+{
+ int status;
+ if (TclHasInternalRep(objPtr,&tclAbstractListType)) {
+ Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr);
+ if (TclAbstractListHasProc(objPtr, TCL_ABSL_REPLACE)) {
+ status = typePtr->replaceProc(interp, objPtr, first, numToDelete, numToInsert, insertObjs);
+ } else {
+ if (interp) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("Replace not supported!", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ status = TCL_ERROR;
+ }
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf("value is not an abstract list"));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
+ }
+ status = TCL_ERROR;
+ }
+ return status;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclAbstractList.h b/generic/tclAbstractList.h
new file mode 100644
index 0000000..1c19f9c
--- /dev/null
+++ b/generic/tclAbstractList.h
@@ -0,0 +1,56 @@
+/*
+ * tclAbstractList.h --
+ *
+ * The AbstractList Obj Type -- a psuedo List
+ *
+ * Copyright © 2022 by Brian Griffin. All rights reserved.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef _TCLABSTRACTLIST
+#define _TCLABSTRACTLIST
+
+#include "tclInt.h"
+
+static inline const char*
+Tcl_AbstractListTypeName(
+ Tcl_Obj *objPtr) /* Should be of type AbstractList */
+{
+ Tcl_AbstractListType *typePtr;
+ typePtr = Tcl_AbstractListGetType(objPtr);
+ if (typePtr && typePtr->typeName) {
+ return typePtr->typeName;
+ } else {
+ return "abstractlist";
+ }
+}
+
+Tcl_Obj * Tcl_AbstractListObjNew(Tcl_Interp *interp, const Tcl_AbstractListType *vTablePtr);
+Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr);
+int Tcl_AbstractListObjIndex(Tcl_Interp *interp, Tcl_Obj *abstractListPtr,
+ Tcl_Size index, Tcl_Obj **elemObj);
+int Tcl_AbstractListObjRange(Tcl_Interp *interp, Tcl_Obj *abstractListPtr,
+ Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr);
+int Tcl_AbstractListObjReverse(Tcl_Interp *interp, Tcl_Obj *abstractListPtr,
+ Tcl_Obj **newObjPtr);
+int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *objcPtr,
+ Tcl_Obj ***objvPtr);
+Tcl_Obj * Tcl_AbstractListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
+void * Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr);
+Tcl_Obj * Tcl_AbstractListSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ Tcl_Size indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valueObj);
+int Tcl_AbstractListObjReplace(Tcl_Interp *interp, Tcl_Obj *listObj,
+ Tcl_Size first, Tcl_Size numToDelete, Tcl_Size numToInsert,
+ Tcl_Obj *const insertObjs[]);
+
+#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c
index fcc5343..8304d7f 100755
--- a/generic/tclArithSeries.c
+++ b/generic/tclArithSeries.c
@@ -10,13 +10,94 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include "tcl.h"
#include "tclInt.h"
-#include "tclArithSeries.h"
#include <assert.h>
#include <math.h>
+/*
+ * 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.
+ */
+
+/*
+ * 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 {
+ Tcl_Size len;
+ Tcl_Obj **elements;
+ int isDouble;
+ Tcl_WideInt start;
+ Tcl_WideInt end;
+ Tcl_WideInt step;
+} ArithSeries;
+typedef struct {
+ Tcl_Size len;
+ Tcl_Obj **elements;
+ int isDouble;
+ double start;
+ double end;
+ double step;
+ int precision;
+} ArithSeriesDbl;
+
/* -------------------------- ArithSeries object ---------------------------- */
+static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *), Tcl_Obj *arithSeriesObj,
+ Tcl_Size index, Tcl_Obj **elemObj);
+
+static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj);
+static int TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj,
+ Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr);
+static int TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr);
+static int TclArithSeriesGetElements(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr);
+static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr);
+static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr);
+static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+
+static const Tcl_ObjType arithSeriesType = {
+ "arithseries", /* name */
+ FreeArithSeriesInternalRep, /* freeIntRepProc */
+ DupArithSeriesInternalRep, /* dupIntRepProc */
+ UpdateStringOfArithSeries, /* updateStringProc */
+ SetArithSeriesFromAny, /* setFromAnyProc */
+ TCL_OBJTYPE_V2(
+ ArithSeriesObjLength,
+ TclArithSeriesObjIndex,
+ TclArithSeriesObjRange,
+ TclArithSeriesObjReverse,
+ TclArithSeriesGetElements,
+ NULL, // SetElement
+ NULL, // Replace
+ NULL) // GetDouble
+};
+
/*
* Helper functions
*
@@ -68,7 +149,7 @@ static inline ArithSeries*
ArithSeriesGetInternalRep(Tcl_Obj *objPtr)
{
const Tcl_ObjInternalRep *irPtr;
- irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType.objType);
+ irPtr = TclFetchInternalRep((objPtr), &arithSeriesType);
return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL;
}
@@ -93,54 +174,7 @@ maxPrecision(double start, double end, double step)
return dp;
}
-/*
- * 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 *arithSeriesObj);
-static Tcl_Obj* ArithSeriesObjStep(Tcl_Obj *arithSeriesPtr);
-static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
-
-/*
- * 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 TclObjTypeWithAbstractList tclArithSeriesType = {
- {"arithseries", /* name */
- FreeArithSeriesInternalRep, /* freeIntRepProc */
- DupArithSeriesInternalRep, /* dupIntRepProc */
- UpdateStringOfArithSeries, /* updateStringProc */
- SetArithSeriesFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- ArithSeriesObjLength
- )}
-};
+static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj);
/*
*----------------------------------------------------------------------
@@ -189,6 +223,86 @@ ArithSeriesLenDbl(double start, double end, double step)
return (len < 0) ? -1 : len;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ /*
+ * Allocate a new ArithSeries structure. */
+
+ if (srcArithSeriesRepPtr->isDouble) {
+ ArithSeriesDbl *srcArithSeriesDblRepPtr =
+ (ArithSeriesDbl *)srcArithSeriesRepPtr;
+ ArithSeriesDbl *copyArithSeriesDblRepPtr =
+ (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl));
+ *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr;
+ copyArithSeriesDblRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr;
+ } else {
+ ArithSeries *copyArithSeriesRepPtr =
+ (ArithSeries *) Tcl_Alloc(sizeof(ArithSeries));
+ *copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
+ copyArithSeriesRepPtr->elements = NULL;
+ copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
+ }
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ copyPtr->typePtr = &arithSeriesType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArithSeriesInternalRep --
+ *
+ * Free any allocated memory in the ArithSeries Rep
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */
+{
+ ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
+
+ if (arithSeriesRepPtr) {
+ if (arithSeriesRepPtr->elements) {
+ Tcl_WideInt i, len = arithSeriesRepPtr->len;
+ for (i=0; i<len; i++) {
+ Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]);
+ }
+ Tcl_Free((char*)arithSeriesRepPtr->elements);
+ arithSeriesRepPtr->elements = NULL;
+ }
+ Tcl_Free((char*)arithSeriesRepPtr);
+ }
+}
+
+
/*
*----------------------------------------------------------------------
*
@@ -233,7 +347,7 @@ NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_Wide
arithSeriesRepPtr->elements = NULL;
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
- arithSeriesObj->typePtr = &tclArithSeriesType.objType;
+ arithSeriesObj->typePtr = &arithSeriesType;
if (length > 0)
Tcl_InvalidateStringRep(arithSeriesObj);
@@ -288,7 +402,7 @@ NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len)
arithSeriesRepPtr->precision = maxPrecision(start,end,step);
arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr;
arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL;
- arithSeriesObj->typePtr = &tclArithSeriesType.objType;
+ arithSeriesObj->typePtr = &arithSeriesType;
if (length > 0) {
Tcl_InvalidateStringRep(arithSeriesObj);
@@ -456,53 +570,17 @@ TclNewArithSeriesObj(
/*
*----------------------------------------------------------------------
*
- * ArithSeriesObjStep --
- *
- * 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.
- *----------------------------------------------------------------------
- */
-Tcl_Obj *
-ArithSeriesObjStep(
- Tcl_Obj *arithSeriesObj)
-{
- ArithSeries *arithSeriesRepPtr;
- Tcl_Obj *stepObj;
-
- if (arithSeriesObj->typePtr != &tclArithSeriesType.objType) {
- Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj.");
- }
- arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
- if (arithSeriesRepPtr->isDouble) {
- TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
- } else {
- TclNewIntObj(stepObj, arithSeriesRepPtr->step);
- }
- return stepObj;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
* 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, NULL is returned.
+ * 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:
*
- * The element on success, NULL on index out of range.
+ * TCL_OK on success, TCL_ERROR on index out of range.
*
* Side Effects:
*
@@ -511,27 +589,27 @@ ArithSeriesObjStep(
*----------------------------------------------------------------------
*/
-Tcl_Obj *
+int
TclArithSeriesObjIndex(
- TCL_UNUSED(Tcl_Interp *),
- Tcl_Obj *arithSeriesObj,
- Tcl_WideInt index)
+ TCL_UNUSED(Tcl_Interp *),/* Used for error reporting if not NULL. */
+ Tcl_Obj *arithSeriesObj, /* List obj */
+ Tcl_Size index, /* index to element of interest */
+ Tcl_Obj **elemObj) /* Return value */
{
- ArithSeries *arithSeriesRepPtr;
+ ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
- if (arithSeriesObj->typePtr != &tclArithSeriesType.objType) {
- Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj.");
- }
- arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
- if (index < 0 || (Tcl_Size)index >= arithSeriesRepPtr->len) {
- return Tcl_NewObj();
- }
- /* List[i] = Start + (Step * index) */
- if (arithSeriesRepPtr->isDouble) {
- return Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index));
+ if (index < 0 || arithSeriesRepPtr->len <= index) {
+ *elemObj = Tcl_NewObj();
} else {
- return Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index));
+ /* List[i] = Start + (Step * index) */
+ if (arithSeriesRepPtr->isDouble) {
+ *elemObj = Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index));
+ } else {
+ *elemObj = Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index));
+ }
}
+
+ return TCL_OK;
}
/*
@@ -557,174 +635,40 @@ Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj)
arithSeriesObj->internalRep.twoPtrValue.ptr1;
return arithSeriesRepPtr->len;
}
-
+
/*
*----------------------------------------------------------------------
*
- * FreeArithSeriesInternalRep --
+ * TclArithSeriesObjStep --
*
- * Deallocate the storage associated with an arithseries object's
- * internal representation.
+ * Return a Tcl_Obj with the step value from the give ArithSeries Obj.
+ * refcount = 0.
*
* Results:
- * None.
- *
- * Side effects:
- * Frees arithSeriesObj's ArithSeries* internal representation and
- * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL.
*
- *----------------------------------------------------------------------
- */
-
-static void
-FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObj)
-{
- ArithSeries *arithSeriesRepPtr =
- (ArithSeries *) arithSeriesObj->internalRep.twoPtrValue.ptr1;
- if (arithSeriesRepPtr->elements) {
- Tcl_Size i;
- Tcl_Obj**elmts = arithSeriesRepPtr->elements;
- for(i=0; i<arithSeriesRepPtr->len; i++) {
- if (elmts[i]) {
- Tcl_DecrRefCount(elmts[i]);
- }
- }
- Tcl_Free((char *) arithSeriesRepPtr->elements);
- }
- Tcl_Free((char *) arithSeriesRepPtr);
- arithSeriesObj->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.
+ * A Tcl_Obj pointer to the created ArithSeries object.
+ * A NULL pointer of the range is invalid.
*
- * Results:
- * None.
+ * Side Effects:
*
- * Side effects:
- * We set "copyPtr"s internal rep to a pointer to a
- * newly allocated ArithSeries structure.
+ * None.
*----------------------------------------------------------------------
*/
-static void
-DupArithSeriesInternalRep(
- Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+int
+TclArithSeriesObjStep(
+ Tcl_Obj *arithSeriesObj,
+ Tcl_Obj **stepObj)
{
- ArithSeries *srcArithSeriesRepPtr =
- (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1;
- /*
- * Allocate a new ArithSeries structure. */
-
- if (srcArithSeriesRepPtr->isDouble) {
- ArithSeriesDbl *srcArithSeriesDblRepPtr =
- (ArithSeriesDbl *)srcArithSeriesRepPtr;
- ArithSeriesDbl *copyArithSeriesDblRepPtr =
- (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl));
- *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr;
- copyArithSeriesDblRepPtr->elements = NULL;
- copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr;
+ ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
+ if (arithSeriesRepPtr->isDouble) {
+ *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step);
} else {
- ArithSeries *copyArithSeriesRepPtr =
- (ArithSeries *) Tcl_Alloc(sizeof(ArithSeries));
- *copyArithSeriesRepPtr = *srcArithSeriesRepPtr;
- copyArithSeriesRepPtr->elements = NULL;
- copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr;
+ *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step);
}
- copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- copyPtr->typePtr = &tclArithSeriesType.objType;
+ return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * 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 *arithSeriesObj)
-{
- ArithSeries *arithSeriesRepPtr =
- (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1;
- char *elem, *p;
- Tcl_Obj *elemObj;
- Tcl_Size i;
- Tcl_Size length = 0;
- Tcl_Size slen;
-
- /*
- * Pass 1: estimate space.
- */
- if (!arithSeriesRepPtr->isDouble) {
- for (i = 0; i < arithSeriesRepPtr->len; i++) {
- double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
- slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1;
- length += slen;
- }
- } else {
- for (i = 0; i < arithSeriesRepPtr->len; i++) {
- double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
- char tmp[TCL_DOUBLE_SPACE+2];
- tmp[0] = 0;
- Tcl_PrintDouble(NULL,d,tmp);
- if ((length + strlen(tmp)) > TCL_SIZE_MAX) {
- break; // overflow
- }
- length += strlen(tmp);
- }
- }
- length += arithSeriesRepPtr->len; // Space for each separator
-
- /*
- * Pass 2: generate the string repr.
- */
-
- p = Tcl_InitStringRep(arithSeriesObj, NULL, length);
- if (p == NULL) {
- Tcl_Panic("Unable to allocate string size %" TCL_Z_MODIFIER "u", length);
- }
- for (i = 0; i < arithSeriesRepPtr->len; i++) {
- elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i);
- elem = Tcl_GetStringFromObj(elemObj, &slen);
- if (((p - arithSeriesObj->bytes)+slen) > length) {
- break;
- }
- strncpy(p, elem, slen);
- p[slen] = ' ';
- p += slen+1;
- Tcl_DecrRefCount(elemObj);
- }
- if (length > 0) arithSeriesObj->bytes[length-1] = '\0';
- arithSeriesObj->length = length-1;
-}
/*
*----------------------------------------------------------------------
@@ -776,28 +720,33 @@ SetArithSeriesFromAny(
*----------------------------------------------------------------------
*/
-Tcl_Obj *
+int
TclArithSeriesObjRange(
Tcl_Interp *interp, /* For error message(s) */
Tcl_Obj *arithSeriesObj, /* List object to take a range from. */
Tcl_Size fromIdx, /* Index of first element to include. */
- Tcl_Size toIdx) /* Index of last element to include. */
+ Tcl_Size toIdx, /* Index of last element to include. */
+ Tcl_Obj **newObjPtr) /* return value */
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
+ (void)interp; /* silence compiler */
+
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = 0;
}
+ if (toIdx >= arithSeriesRepPtr->len) {
+ toIdx = arithSeriesRepPtr->len-1;
+ }
+
if (fromIdx > toIdx ||
- (toIdx > arithSeriesRepPtr->len-1 &&
- fromIdx > arithSeriesRepPtr->len-1)) {
- Tcl_Obj *obj;
- TclNewObj(obj);
- return obj;
+ fromIdx >= arithSeriesRepPtr->len) {
+ TclNewObj(*newObjPtr);
+ return TCL_OK;
}
if (fromIdx < 0) {
@@ -810,31 +759,22 @@ TclArithSeriesObjRange(
toIdx = arithSeriesRepPtr->len-1;
}
- startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx);
- if (startObj == NULL) {
- return NULL;
- }
+ TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj);
Tcl_IncrRefCount(startObj);
- endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx);
- if (endObj == NULL) {
- return NULL;
- }
+ TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj);
Tcl_IncrRefCount(endObj);
- stepObj = ArithSeriesObjStep(arithSeriesObj);
+ TclArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (Tcl_IsShared(arithSeriesObj) ||
((arithSeriesObj->refCount > 1))) {
- Tcl_Obj *newSlicePtr;
- if (TclNewArithSeriesObj(interp, &newSlicePtr,
- arithSeriesRepPtr->isDouble, startObj, endObj,
- stepObj, NULL) != TCL_OK) {
- newSlicePtr = NULL;
- }
+ int status = TclNewArithSeriesObj(NULL, newObjPtr,
+ arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL);
+
Tcl_DecrRefCount(startObj);
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
- return newSlicePtr;
+ return status;
}
/*
@@ -878,7 +818,8 @@ TclArithSeriesObjRange(
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
- return arithSeriesObj;
+ *newObjPtr = arithSeriesObj;
+ return TCL_OK;
}
/*
@@ -920,12 +861,13 @@ TclArithSeriesGetElements(
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
- if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) {
+ if (TclHasInternalRep(objPtr,&arithSeriesType)) {
ArithSeries *arithSeriesRepPtr;
Tcl_Obj **objv;
int i, objc;
arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr);
+
objc = arithSeriesRepPtr->len;
if (objc > 0) {
if (arithSeriesRepPtr->elements) {
@@ -945,8 +887,8 @@ TclArithSeriesGetElements(
}
arithSeriesRepPtr->elements = objv;
for (i = 0; i < objc; i++) {
- objv[i] = TclArithSeriesObjIndex(interp, objPtr, i);
- if (objv[i] == NULL) {
+ int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]);
+ if (status) {
return TCL_ERROR;
}
Tcl_IncrRefCount(objv[i]);
@@ -974,24 +916,23 @@ TclArithSeriesGetElements(
*
* TclArithSeriesObjReverse --
*
- * Reverse the order of the ArithSeries value.
- * *arithSeriesObj must be known to be a valid list.
+ * Reverse the order of the ArithSeries value. The arithSeriesObj is
+ * assumed to be a valid ArithSeries. The new Obj has the Start and End
+ * values appropriately swapped and the Step value sign is changed.
*
* Results:
- * Returns a pointer to the reordered series.
- * This may be a new object or the same object if not shared.
+ * The result will be an ArithSeries in the reverse order.
*
* Side effects:
- * ?The possible conversion of the object referenced by listPtr?
- * ?to a list object.?
+ * The ogiginal obj will be modified and returned if it is not Shared.
*
*----------------------------------------------------------------------
*/
-
-Tcl_Obj *
+int
TclArithSeriesObjReverse(
Tcl_Interp *interp, /* For error message(s) */
- Tcl_Obj *arithSeriesObj) /* List object to reverse. */
+ Tcl_Obj *arithSeriesObj, /* List object to reverse. */
+ Tcl_Obj **newObjPtr)
{
ArithSeries *arithSeriesRepPtr;
Tcl_Obj *startObj, *endObj, *stepObj;
@@ -1000,16 +941,22 @@ TclArithSeriesObjReverse(
double dstart, dend, dstep;
int isDouble;
+ (void)interp;
+
+ if (newObjPtr == NULL) {
+ return TCL_ERROR;
+ }
+
arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj);
isDouble = arithSeriesRepPtr->isDouble;
len = arithSeriesRepPtr->len;
- startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1));
+ TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1), &startObj);
Tcl_IncrRefCount(startObj);
- endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0);
+ TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj);
Tcl_IncrRefCount(endObj);
- stepObj = ArithSeriesObjStep(arithSeriesObj);
+ TclArithSeriesObjStep(arithSeriesObj, &stepObj);
Tcl_IncrRefCount(stepObj);
if (isDouble) {
@@ -1030,8 +977,8 @@ TclArithSeriesObjReverse(
((arithSeriesObj->refCount > 1))) {
Tcl_Obj *lenObj;
TclNewIntObj(lenObj, len);
- if (TclNewArithSeriesObj(interp, &resultObj,
- isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) {
+ if (TclNewArithSeriesObj(NULL, &resultObj, isDouble,
+ startObj, endObj, stepObj, lenObj) != TCL_OK) {
resultObj = NULL;
}
Tcl_DecrRefCount(lenObj);
@@ -1070,7 +1017,87 @@ TclArithSeriesObjReverse(
Tcl_DecrRefCount(endObj);
Tcl_DecrRefCount(stepObj);
- return resultObj;
+ *newObjPtr = resultObj;
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 *arithSeriesObjPtr)
+{
+ ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
+ char *p;
+ Tcl_Obj *eleObj;
+ Tcl_Size i, bytlen = 0;
+
+ /*
+ * Pass 1: estimate space.
+ */
+ if (!arithSeriesRepPtr->isDouble) {
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
+ size_t slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1;
+ bytlen += slen;
+ }
+ } else {
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
+ char tmp[TCL_DOUBLE_SPACE+2];
+ tmp[0] = 0;
+ Tcl_PrintDouble(NULL,d,tmp);
+ if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) {
+ break; // overflow
+ }
+ bytlen += strlen(tmp);
+ }
+ }
+ bytlen += arithSeriesRepPtr->len; // Space for each separator
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+
+ p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
+ for (i = 0; i < arithSeriesRepPtr->len; i++) {
+ if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) {
+ Tcl_Size slen;
+ char *str = Tcl_GetStringFromObj(eleObj, &slen);
+ strcpy(p, str);
+ p[slen] = ' ';
+ p += slen+1;
+ Tcl_DecrRefCount(eleObj);
+ } // else TODO: report error here?
+ }
+ if (bytlen > 0) arithSeriesObjPtr->bytes[bytlen-1] = '\0';
+ arithSeriesObjPtr->length = bytlen-1;
}
/*
diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h
deleted file mode 100644
index 8002239..0000000
--- a/generic/tclArithSeries.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/*
- * 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 {
- Tcl_WideInt len;
- Tcl_Obj **elements;
- int isDouble;
- Tcl_WideInt start;
- Tcl_WideInt end;
- Tcl_WideInt step;
-} ArithSeries;
-typedef struct {
- Tcl_WideInt len;
- Tcl_Obj **elements;
- int isDouble;
- double start;
- double end;
- double step;
- int precision;
-} ArithSeriesDbl;
-
-
-MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *,
- Tcl_WideInt index);
-MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp,
- Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx);
-MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp,
- Tcl_Obj *arithSeriesPtr);
-MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp,
- Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr);
-MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp,
- Tcl_Obj **arithSeriesObj, int useDoubles,
- Tcl_Obj *startObj, Tcl_Obj *endObj,
- Tcl_Obj *stepObj, Tcl_Obj *lenObj);
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 91c8d7a..b412cd3 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -6152,7 +6152,7 @@ TclNREvalObjEx(
*/
Tcl_IncrRefCount(objPtr);
- listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType.objType);
+ listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType);
if (!listPtr) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
@@ -7050,7 +7050,7 @@ ExprCeilFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
@@ -7090,7 +7090,7 @@ ExprFloorFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
@@ -7236,7 +7236,7 @@ ExprSqrtFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
Tcl_SetObjResult(interp, objv[1]);
@@ -7290,7 +7290,7 @@ ExprUnaryFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d = irPtr->doubleValue;
@@ -7354,7 +7354,7 @@ ExprBinaryFunc(
code = Tcl_GetDoubleFromObj(interp, objv[1], &d1);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d1 = irPtr->doubleValue;
@@ -7369,7 +7369,7 @@ ExprBinaryFunc(
code = Tcl_GetDoubleFromObj(interp, objv[2], &d2);
#ifdef ACCEPT_NAN
if (code != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType);
if (irPtr) {
d2 = irPtr->doubleValue;
@@ -7530,7 +7530,7 @@ ExprDoubleFunc(
}
if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) {
#ifdef ACCEPT_NAN
- if (TclHasInternalRep(objv[1], &tclDoubleType.objType)) {
+ if (TclHasInternalRep(objv[1], &tclDoubleType)) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 81ea3f3..c97ee2e 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -2001,7 +2001,7 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
if (irPtr == NULL) {
return TCL_ERROR;
}
@@ -2021,7 +2021,7 @@ FormatNumber(
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
- const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType.objType);
+ const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType);
if (irPtr == NULL) {
return TCL_ERROR;
diff --git a/generic/tclClock.c b/generic/tclClock.c
index a54e36b..bef10c2 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -433,7 +433,7 @@ ClockGetdatefieldsObjCmd(
* that it isn't.
*/
- if (TclHasInternalRep(objv[1], &tclBignumType.objType)) {
+ if (TclHasInternalRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index bc8bf30..a12c65b 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -17,7 +17,6 @@
#ifdef _WIN32
# include "tclWinInt.h"
#endif
-#include "tclArithSeries.h"
/*
* The state structure used by [foreach]. Note that the actual structure has
@@ -2789,7 +2788,7 @@ EachloopCmd(
/* List */
/* Variables */
statePtr->vCopyList[i] = TclDuplicatePureObj(
- interp, objv[1+i*2], &tclListType.objType);
+ interp, objv[1+i*2], &tclListType);
if (!statePtr->vCopyList[i]) {
result = TCL_ERROR;
goto done;
@@ -2814,19 +2813,18 @@ EachloopCmd(
&statePtr->varcList[i], &statePtr->varvList[i]);
/* Values */
- if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType.objType)) {
- /* Special case for Arith Series */
+ if (TclObjTypeHasProc(objv[2+i*2],indexProc)) {
+ /* Special case for AbstractList */
statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]);
if (statePtr->aCopyList[i] == NULL) {
result = TCL_ERROR;
goto done;
}
/* Don't compute values here, wait until the last moment */
- statePtr->argcList[i] = ABSTRACTLIST_PROC(statePtr->aCopyList[i], lengthProc)(statePtr->aCopyList[i]);
+ statePtr->argcList[i] = TclObjTypeHasProc(statePtr->aCopyList[i], lengthProc)(statePtr->aCopyList[i]);
} else {
- /* List values */
statePtr->aCopyList[i] = TclDuplicatePureObj(
- interp, objv[2+i*2], &tclListType.objType);
+ interp, objv[2+i*2], &tclListType);
if (!statePtr->aCopyList[i]) {
result = TCL_ERROR;
goto done;
@@ -2964,17 +2962,18 @@ ForeachAssignments(
Tcl_Obj *valuePtr, *varValuePtr;
for (i=0 ; i<statePtr->numLists ; i++) {
- int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType.objType);
+ int isAbstractList =
+ TclObjTypeHasProc(statePtr->aCopyList[i],indexProc) != NULL;
+
for (v=0 ; v<statePtr->varcList[i] ; v++) {
k = statePtr->index[i]++;
if (k < statePtr->argcList[i]) {
- if (isarithseries) {
- valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k);
- if (valuePtr == NULL) {
+ if (isAbstractList) {
+ if (Tcl_ObjTypeIndex(interp, statePtr->aCopyList[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])));
+ "\n (setting %s loop variable \"%s\")",
+ (statePtr->resultList != NULL ? "lmap" : "foreach"),
+ TclGetString(statePtr->varvList[i][v])));
return TCL_ERROR;
}
} else {
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 4836b9e..b2f4502 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -19,7 +19,6 @@
#include "tclInt.h"
#include "tclRegexp.h"
-#include "tclArithSeries.h"
#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
@@ -2203,7 +2202,7 @@ Tcl_JoinObjCmd(
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Size length, listLen;
- int isArithSeries = 0;
+ int isAbstractList = 0;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
@@ -2216,14 +2215,17 @@ Tcl_JoinObjCmd(
* pointer to its array of element pointers.
*/
- if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) {
- isArithSeries = 1;
- listLen = ABSTRACTLIST_PROC(objv[1], lengthProc)(objv[1]);
- } else {
- if (TclListObjGetElementsM(interp, objv[1], &listLen,
- &elemPtrs) != TCL_OK) {
+ if (TclObjTypeHasProc(objv[1], getElementsProc)) {
+ listLen = TclObjTypeHasProc(objv[1], lengthProc)(objv[1]);
+ isAbstractList = (listLen ? 1 : 0);
+ if (listLen > 1 &&
+ Tcl_ObjTypeGetElements(interp, objv[1], &listLen, &elemPtrs)
+ != TCL_OK) {
return TCL_ERROR;
}
+ } else if (TclListObjGetElementsM(interp, objv[1], &listLen,
+ &elemPtrs) != TCL_OK) {
+ return TCL_ERROR;
}
if (listLen == 0) {
@@ -2232,14 +2234,15 @@ Tcl_JoinObjCmd(
}
if (listLen == 1) {
/* One element; return it */
- if (isArithSeries) {
- Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0);
- if (valueObj == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, valueObj);
- } else {
+ if (!isAbstractList) {
Tcl_SetObjResult(interp, elemPtrs[0]);
+ } else {
+ Tcl_Obj *elemObj;
+ if (Tcl_ObjTypeIndex(interp, objv[1], 0, &elemObj)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, elemObj);
}
return TCL_OK;
}
@@ -2254,42 +2257,19 @@ Tcl_JoinObjCmd(
Tcl_Size i;
TclNewObj(resObjPtr);
- 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);
- }
- valueObj = TclArithSeriesObjIndex(interp, objv[1], i);
- if (valueObj == NULL) {
- return TCL_ERROR;
- }
- Tcl_AppendObjToObj(resObjPtr, valueObj);
- Tcl_DecrRefCount(valueObj);
- }
- } else {
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
- /*
- * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
- * to shimmer joinObjPtr. If it did, then the case where
- * objv[1] and objv[2] are the same value would not be safe.
- * Accessing elemPtrs would crash.
- */
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
- Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
- }
- Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
}
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
}
Tcl_DecrRefCount(joinObjPtr);
@@ -2335,7 +2315,7 @@ Tcl_LassignObjCmd(
return TCL_ERROR;
}
- listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType.objType);
+ listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType);
if (!listCopyPtr) {
return TCL_ERROR;
}
@@ -2505,7 +2485,7 @@ Tcl_LinsertObjCmd(
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
- listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
+ listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
@@ -2705,7 +2685,7 @@ Tcl_LpopObjCmd(
if (objc == 2) {
if (Tcl_IsShared(listPtr)) {
- listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
+ listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
@@ -2788,11 +2768,11 @@ Tcl_LrangeObjCmd(
return result;
}
- if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) {
- Tcl_Obj *rangeObj;
- rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last);
- if (rangeObj) {
- Tcl_SetObjResult(interp, rangeObj);
+ if (TclObjTypeHasProc(objv[1], sliceProc)) {
+ Tcl_Obj *resultObj;
+ int status = Tcl_ObjTypeSlice(interp, objv[1], first, last, &resultObj);
+ if (status == TCL_OK) {
+ Tcl_SetObjResult(interp, resultObj);
} else {
return TCL_ERROR;
}
@@ -2892,7 +2872,7 @@ Tcl_LremoveObjCmd(
*/
if (Tcl_IsShared(listObj)) {
- listObj = TclDuplicatePureObj(interp, listObj, &tclListType.objType);
+ listObj = TclDuplicatePureObj(interp, listObj, &tclListType);
if (!listObj) {
status = TCL_ERROR;
goto done;
@@ -3147,7 +3127,7 @@ Tcl_LreplaceObjCmd(
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
- listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
+ listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
@@ -3208,20 +3188,18 @@ Tcl_LreverseObjCmd(
}
/*
- * Handle ArithSeries special case - don't shimmer a series into a list
- * just to reverse it.
+ * Handle AbstractList special case - do not shimmer into a list, if it
+ * supports a private Reverse function, just to reverse it.
*/
- if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) {
- Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]);
- if (resObj) {
- Tcl_SetObjResult(interp, resObj);
+ if (TclObjTypeHasProc(objv[1], reverseProc)) {
+ Tcl_Obj *resultObj;
+
+ if (Tcl_ObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) {
+ Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
- } else {
- return TCL_ERROR;
}
- } /* end ArithSeries */
+ } /* end Abstract List */
- /* True List */
if (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) {
return TCL_ERROR;
}
@@ -3314,7 +3292,7 @@ Tcl_LsearchObjCmd(
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
- Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
+ Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL;
SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
@@ -3759,9 +3737,14 @@ Tcl_LsearchObjCmd(
lower = start - groupSize;
upper = listc;
+ itemPtr = NULL;
while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
i -= i % groupSize;
+
+ Tcl_BumpObj(itemPtr);
+ itemPtr = NULL;
+
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
@@ -3860,6 +3843,9 @@ Tcl_LsearchObjCmd(
}
for (i = start; i < listc; i += groupSize) {
match = 0;
+ Tcl_BumpObj(itemPtr);
+ itemPtr = NULL;
+
if (sortInfo.indexc != 0) {
itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
@@ -3986,6 +3972,9 @@ Tcl_LsearchObjCmd(
}
}
+ Tcl_BumpObj(itemPtr);
+ itemPtr = NULL;
+
/*
* Return everything or a single value.
*/
@@ -4045,91 +4034,6 @@ Tcl_LsearchObjCmd(
/*
*----------------------------------------------------------------------
*
- * Tcl_LsetObjCmd --
- *
- * This procedure is invoked to process the "lset" Tcl command. See the
- * user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_LsetObjCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument values. */
-{
- Tcl_Obj *listPtr; /* Pointer to the list being altered. */
- Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
-
- /*
- * Check parameter count.
- */
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "listVar ?index? ?index ...? value");
- return TCL_ERROR;
- }
-
- /*
- * Look up the list variable's value.
- */
-
- listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
- if (listPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Substitute the value in the value. Return either the value or else an
- * unshared copy of it.
- */
-
- if (objc == 4) {
- finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);
- } else {
- finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2,
- objv[objc-1]);
- }
-
- /*
- * If substitution has failed, bail out.
- */
-
- if (finalValuePtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Finally, update the variable so that traces fire.
- */
-
- listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr,
- TCL_LEAVE_ERR_MSG);
- Tcl_DecrRefCount(finalValuePtr);
- if (listPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Return the new value of the variable as the interpreter result.
- */
-
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* SequenceIdentifyArgument --
* (for [lseq] command)
*
@@ -4267,7 +4171,7 @@ Tcl_LseqObjCmd(
Tcl_WideInt values[5];
Tcl_Obj *numValues[5];
Tcl_Obj *numberObj;
- int status, keyword, useDoubles = 0;
+ int status = TCL_ERROR, keyword, useDoubles = 0;
Tcl_Obj *arithSeriesPtr;
SequenceOperators opmode;
SequenceDecoded decoded;
@@ -4337,11 +4241,10 @@ Tcl_LseqObjCmd(
case 0:
Tcl_WrongNumArgs(interp, 1, objv,
"n ??op? n ??by? n??");
- status = TCL_ERROR;
goto done;
break;
-/* range n */
+/* lseq n */
case 1:
start = zero;
elementCount = numValues[0];
@@ -4349,22 +4252,22 @@ Tcl_LseqObjCmd(
step = one;
break;
-/* range n n */
+/* lseq n n */
case 11:
start = numValues[0];
end = numValues[1];
break;
-/* range n n n */
+/* lseq n n n */
case 111:
start = numValues[0];
end = numValues[1];
step = numValues[2];
break;
-/* range n 'to' n */
-/* range n 'count' n */
-/* range n 'by' n */
+/* lseq n 'to' n */
+/* lseq n 'count' n */
+/* lseq n 'by' n */
case 121:
opmode = (SequenceOperators)values[1];
switch (opmode) {
@@ -4384,13 +4287,12 @@ Tcl_LseqObjCmd(
step = one;
break;
default:
- status = TCL_ERROR;
goto done;
}
break;
-/* range n 'to' n n */
-/* range n 'count' n n */
+/* lseq n 'to' n n */
+/* lseq n 'count' n n */
case 1211:
opmode = (SequenceOperators)values[1];
switch (opmode) {
@@ -4407,17 +4309,15 @@ Tcl_LseqObjCmd(
break;
case LSEQ_BY:
/* Error case */
- status = TCL_ERROR;
goto done;
break;
default:
- status = TCL_ERROR;
goto done;
break;
}
break;
-/* range n n 'by' n */
+/* lseq n n 'by' n */
case 1121:
start = numValues[0];
end = numValues[1];
@@ -4430,14 +4330,13 @@ Tcl_LseqObjCmd(
case LSEQ_TO:
case LSEQ_COUNT:
default:
- status = TCL_ERROR;
goto done;
break;
}
break;
-/* range n 'to' n 'by' n */
-/* range n 'count' n 'by' n */
+/* lseq n 'to' n 'by' n */
+/* lseq n 'count' n 'by' n */
case 12121:
start = numValues[0];
opmode = (SequenceOperators)values[3];
@@ -4446,7 +4345,6 @@ Tcl_LseqObjCmd(
step = numValues[4];
break;
default:
- status = TCL_ERROR;
goto done;
break;
}
@@ -4462,7 +4360,6 @@ Tcl_LseqObjCmd(
elementCount = numValues[2];
break;
default:
- status = TCL_ERROR;
goto done;
break;
}
@@ -4476,7 +4373,6 @@ Tcl_LseqObjCmd(
case 1212:
opmode = (SequenceOperators)values[3]; goto KeywordError; break;
KeywordError:
- status = TCL_ERROR;
switch (opmode) {
case LSEQ_DOTS:
case LSEQ_TO:
@@ -4492,14 +4388,12 @@ Tcl_LseqObjCmd(
"missing \"by\" value."));
break;
}
- status = TCL_ERROR;
goto done;
break;
/* All other argument errors */
default:
Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??");
- status = TCL_ERROR;
goto done;
break;
}
@@ -4530,6 +4424,99 @@ Tcl_LseqObjCmd(
/*
*----------------------------------------------------------------------
*
+ * Tcl_LsetObjCmd --
+ *
+ * This procedure is invoked to process the "lset" Tcl command. See the
+ * user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LsetObjCmd(
+ TCL_UNUSED(ClientData),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument values. */
+{
+ Tcl_Obj *listPtr; /* Pointer to the list being altered. */
+ Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
+
+ /*
+ * Check parameter count.
+ */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "listVar ?index? ?index ...? value");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Look up the list variable's value.
+ */
+
+ listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Substitute the value in the value. Return either the value or else an
+ * unshared copy of it.
+ */
+
+ if (objc == 4) {
+ finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]);
+ } else {
+ if (TclObjTypeHasProc(listPtr, setElementProc)) {
+ finalValuePtr = Tcl_ObjTypeSetElement(interp, listPtr,
+ objc-3, objv+2, objv[objc-1]);
+ if (finalValuePtr) {
+ Tcl_IncrRefCount(finalValuePtr);
+ }
+ } else {
+ finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2,
+ objv[objc-1]);
+ }
+ }
+
+ /*
+ * If substitution has failed, bail out.
+ */
+
+ if (finalValuePtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Finally, update the variable so that traces fire.
+ */
+
+ listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr,
+ TCL_LEAVE_ERR_MSG);
+ Tcl_DecrRefCount(finalValuePtr);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the new value of the variable as the interpreter result.
+ */
+
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command. See the
@@ -4771,7 +4758,7 @@ Tcl_LsortObjCmd(
* 1675116]
*/
- listObj = TclDuplicatePureObj(interp ,listObj, &tclListType.objType);
+ listObj = TclDuplicatePureObj(interp ,listObj, &tclListType);
if (listObj == NULL) {
sortInfo.resultCode = TCL_ERROR;
goto done;
@@ -4796,9 +4783,9 @@ Tcl_LsortObjCmd(
sortInfo.compareCmdPtr = newCommandPtr;
}
- if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {
- sortInfo.resultCode = TclArithSeriesGetElements(interp,
- listObj, &length, &listObjPtrs);
+ if (TclObjTypeHasProc(objv[1], getElementsProc)) {
+ sortInfo.resultCode =
+ Tcl_ObjTypeGetElements(interp, listObj, &length, &listObjPtrs);
} else {
sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
&length, &listObjPtrs);
@@ -5127,7 +5114,7 @@ Tcl_LeditObjCmd(
}
if (Tcl_IsShared(listPtr)) {
- listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType);
+ listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType);
if (!listPtr) {
return TCL_ERROR;
}
@@ -5547,7 +5534,7 @@ SelectObjFromSublist(
for (i=0 ; i<infoPtr->indexc ; i++) {
Tcl_Size listLen;
int index;
- Tcl_Obj *currentObj;
+ Tcl_Obj *currentObj, *lastObj=NULL;
if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
@@ -5578,6 +5565,8 @@ SelectObjFromSublist(
return NULL;
}
objPtr = currentObj;
+ Tcl_BumpObj(lastObj);
+ lastObj = currentObj;
}
return objPtr;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 77d8373..e6bda99 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1612,7 +1612,7 @@ StringIsCmd(
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if (!TclHasInternalRep(objPtr, &tclBooleanType.objType)
+ if (!TclHasInternalRep(objPtr, &tclBooleanType)
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
@@ -1681,9 +1681,9 @@ StringIsCmd(
chcomp = Tcl_UniCharIsDigit;
break;
case STR_IS_DOUBLE: {
- if (TclHasInternalRep(objPtr, &tclDoubleType.objType) ||
- TclHasInternalRep(objPtr, &tclIntType.objType) ||
- TclHasInternalRep(objPtr, &tclBignumType.objType)) {
+ if (TclHasInternalRep(objPtr, &tclDoubleType) ||
+ TclHasInternalRep(objPtr, &tclIntType) ||
+ TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
@@ -1712,8 +1712,8 @@ StringIsCmd(
break;
case STR_IS_INT:
case STR_IS_ENTIER:
- if (TclHasInternalRep(objPtr, &tclIntType.objType) ||
- TclHasInternalRep(objPtr, &tclBignumType.objType)) {
+ if (TclHasInternalRep(objPtr, &tclIntType) ||
+ TclHasInternalRep(objPtr, &tclBignumType)) {
break;
}
string1 = Tcl_GetStringFromObj(objPtr, &length1);
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 69b69b2..ae365c3 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2111,7 +2111,7 @@ ParseLexeme(
* Example: Inf + luence + () becomes a valid function call.
* [Bug 3401704]
*/
- if (TclHasInternalRep(literal, &tclDoubleType.objType)) {
+ if (TclHasInternalRep(literal, &tclDoubleType)) {
const char *p = start;
while (p < end) {
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 18a9a97..5da29ed 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -61,6 +61,8 @@ static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
+static Tcl_ObjTypeLengthProc DictAsListLength;
+static Tcl_ObjTypeIndexProc DictAsListIndex;
/*
* Table of dict subcommand names and implementations.
@@ -143,11 +145,22 @@ typedef struct Dict {
const Tcl_ObjType tclDictType = {
"dict",
- FreeDictInternalRep, /* freeIntRepProc */
- DupDictInternalRep, /* dupIntRepProc */
- UpdateStringOfDict, /* updateStringProc */
- SetDictFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0
+ FreeDictInternalRep, /* freeIntRepProc */
+ DupDictInternalRep, /* dupIntRepProc */
+ UpdateStringOfDict, /* updateStringProc */
+ SetDictFromAny, /* setFromAnyProc */
+ TCL_OBJTYPE_V2( /* Extended type for AbstractLists */
+ DictAsListLength, /* return "list" length of dict value w/o
+ * shimmering */
+ DictAsListIndex, /* return key or value at "list" index
+ * location. (keysare at even indicies,
+ * values at odd indicies) */
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL)
};
#define DictSetInternalRep(objPtr, dictRepPtr) \
@@ -603,7 +616,7 @@ SetDictFromAny(
* the conversion from lists to dictionaries.
*/
- if (TclHasInternalRep(objPtr, &tclListType.objType)) {
+ if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size objc, i;
Tcl_Obj **objv;
@@ -3789,6 +3802,158 @@ TclInitDictCmd(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * DictAsListLength --
+ *
+ * Compute the length of a list as if the dict value were converted to a
+ * list.
+ *
+ * Note: the list length may not match the dict size * 2. This occurs when
+ * there are duplicate keys in the original string representation.
+ *
+ * Side Effects --
+ *
+ * The intent is to have no side effects.
+ */
+
+static Tcl_Size
+DictAsListLength(
+ Tcl_Obj *objPtr)
+{
+ Tcl_Size estCount, length, llen;
+ const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_Obj *elemPtr;
+
+ /*
+ * Allocate enough space to hold a (Tcl_Obj *) for each
+ * (possible) list element.
+ */
+
+ estCount = TclMaxListLength(nextElem, length, &limit);
+ estCount += (estCount == 0); /* Smallest list struct holds 1
+ * element. */
+ elemPtr = Tcl_NewObj();
+
+ llen = 0;
+
+ while (nextElem < limit) {
+ const char *elemStart;
+ char *check;
+ Tcl_Size elemSize;
+ int literal;
+
+ if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem,
+ &elemStart, &nextElem, &elemSize, &literal)) {
+ Tcl_DecrRefCount(elemPtr);
+ return 0;
+ }
+ if (elemStart == limit) {
+ break;
+ }
+
+ TclInvalidateStringRep(elemPtr);
+ check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL,
+ elemSize);
+ if (elemSize && check == NULL) {
+ Tcl_DecrRefCount(elemPtr);
+ return 0;
+ }
+ if (!literal) {
+ Tcl_InitStringRep(elemPtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, check));
+ }
+ llen++;
+ }
+ Tcl_DecrRefCount(elemPtr);
+ return llen;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictAsListIndex --
+ *
+ * Return the key or value at the given "list" index, i.e., as if the string
+ * value where treated as a list. The intent is to support this list
+ * operation w/o causing the Obj value to shimmer into a List.
+ *
+ * Side Effects --
+ *
+ * The intent is to have no side effects.
+ *
+ */
+
+static int
+DictAsListIndex(
+ Tcl_Interp *interp,
+ struct Tcl_Obj *objPtr,
+ Tcl_Size index,
+ Tcl_Obj** elemObjPtr)
+{
+ Tcl_Size /*estCount,*/ length, llen;
+ const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_Obj *elemPtr;
+
+ /*
+ * Compute limit of the list string
+ */
+
+ TclMaxListLength(nextElem, length, &limit);
+ elemPtr = Tcl_NewObj();
+
+ llen = 0;
+
+ /*
+ * parse out each element until reaching the "index"th element.
+ * Sure this is slow, but shimmering is slower.
+ */
+ while (nextElem < limit) {
+ const char *elemStart;
+ char *check;
+ Tcl_Size elemSize;
+ int literal;
+
+ if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem,
+ &elemStart, &nextElem, &elemSize, &literal)) {
+ Tcl_DecrRefCount(elemPtr);
+ return 0;
+ }
+ if (elemStart == limit) {
+ break;
+ }
+
+ TclInvalidateStringRep(elemPtr);
+ check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL,
+ elemSize);
+ if (elemSize && check == NULL) {
+ Tcl_DecrRefCount(elemPtr);
+ if (interp) {
+ // Need error message here
+ }
+ return TCL_ERROR;
+ }
+ if (!literal) {
+ Tcl_InitStringRep(elemPtr, NULL,
+ TclCopyAndCollapse(elemSize, elemStart, check));
+ }
+ if (llen == index) {
+ *elemObjPtr = elemPtr;
+ return TCL_OK;
+ }
+ llen++;
+ }
+
+ /*
+ * Index is beyond end of list - return empty
+ */
+ Tcl_InitStringRep(elemPtr, NULL, 0);
+ *elemObjPtr = elemPtr;
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 7c4c5f4..c238141 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -607,7 +607,7 @@ TclNamespaceEnsembleCmd(
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = TclDuplicatePureObj(
- interp, listObj, &tclListType.objType);
+ interp, listObj, &tclListType);
if (!newList) {
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
@@ -624,7 +624,7 @@ TclNamespaceEnsembleCmd(
&newCmd);
if (patchedDict == NULL) {
patchedDict = TclDuplicatePureObj(
- interp, objv[1], &tclListType.objType);
+ interp, objv[1], &tclListType);
if (!patchedDict) {
goto freeMapAndError;
}
@@ -1926,7 +1926,7 @@ NsEnsembleImplementationCmdNR(
if (objc == 2) {
copyPtr = TclDuplicatePureObj(
- interp, prefixObj, &tclListType.objType);
+ interp, prefixObj, &tclListType);
if (!copyPtr) {
return TCL_ERROR;
}
@@ -2330,7 +2330,7 @@ EnsembleUnknownCallback(
*/
unknownCmd = TclDuplicatePureObj(
- interp, ensemblePtr->unknownHandler, &tclListType.objType);
+ interp, ensemblePtr->unknownHandler, &tclListType);
if (!unknownCmd) {
return TCL_ERROR;
}
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index caa4567..88a568a 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -233,7 +233,7 @@ HandleBgErrors(
*/
Tcl_Obj *copyObj = TclDuplicatePureObj(
- interp, assocPtr->cmdPrefix, &tclListType.objType);
+ interp, assocPtr->cmdPrefix, &tclListType);
if (!copyObj) {
return;
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e9494d9..a13d9d9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -19,7 +19,6 @@
#include "tclCompile.h"
#include "tclOOInt.h"
#include "tclTomMath.h"
-#include "tclArithSeries.h"
#include <math.h>
#include <assert.h>
@@ -451,11 +450,11 @@ VarHashCreateVar(
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- ((TclHasInternalRep((objPtr), &tclIntType.objType)) \
+ ((TclHasInternalRep((objPtr), &tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (void *) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
- TclHasInternalRep((objPtr), &tclDoubleType.objType) \
+ TclHasInternalRep((objPtr), &tclDoubleType) \
? (((isnan((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
@@ -674,7 +673,8 @@ static const Tcl_ObjType exprCodeType = {
static const Tcl_ObjType dictIteratorType = {
"dictIterator",
ReleaseDictIterator,
- NULL, NULL, NULL, TCL_OBJTYPE_V0
+ NULL, NULL, NULL,
+ TCL_OBJTYPE_V0
};
/*
@@ -3375,7 +3375,7 @@ TEBCresume(
}
if (Tcl_IsShared(objResultPtr)) {
Tcl_Obj *newValue = TclDuplicatePureObj(
- interp, objResultPtr, &tclListType.objType);
+ interp, objResultPtr, &tclListType);
if (!newValue) {
TRACE_ERROR(interp);
goto gotError;
@@ -3439,7 +3439,7 @@ TEBCresume(
} else {
if (Tcl_IsShared(objResultPtr)) {
valueToAssign = TclDuplicatePureObj(
- interp, objResultPtr, &tclListType.objType);
+ interp, objResultPtr, &tclListType);
if (!valueToAssign) {
goto errorInLappendListPtr;
}
@@ -4668,17 +4668,15 @@ TEBCresume(
valuePtr = OBJ_UNDER_TOS;
TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
-
- /* special case for ArithSeries */
- if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) {
- length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr);
+ /* special case for AbstractList */
+ if (TclObjTypeHasProc(valuePtr,indexProc)) {
+ length = TclObjTypeHasProc(valuePtr, lengthProc)(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
}
- objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
- if (objResultPtr == NULL) {
+ if (Tcl_ObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
@@ -4696,7 +4694,7 @@ TEBCresume(
Tcl_Obj *indexListPtr = value2Ptr;
if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK)
&& (
- !TclHasInternalRep(value2Ptr, &tclListType.objType)
+ !TclHasInternalRep(value2Ptr, &tclListType)
||
((Tcl_ListObjLength(interp,value2Ptr,&value2Length),
value2Length == 1
@@ -4754,34 +4752,30 @@ TEBCresume(
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd));
- /* special case for ArithSeries */
- if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) {
- length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr);
+ /*
+ * Get the contents of the list, making sure that it really is a list
+ * in the process.
+ */
- /* Decode end-offset index values. */
+ /* special case for AbstractList */
+ if (TclObjTypeHasProc(valuePtr,indexProc)) {
+ length = TclObjTypeHasProc(valuePtr, lengthProc)(valuePtr);
+ /* Decode end-offset index values. */
index = TclIndexDecode(opnd, length-1);
/* Compute value @ index */
- if (index >= 0 && index < length) {
- objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index);
- if (objResultPtr == NULL) {
- CACHE_STACK_INFO();
- TRACE_ERROR(interp);
- goto gotError;
- }
- } else {
- TclNewObj(objResultPtr);
+ if (Tcl_ObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
}
+
pcAdjustment = 5;
goto lindexFastPath2;
}
- /*
- * Get the contents of the list, making sure that it really is a list
- * in the process.
- */
-
+ /* List case */
if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -4854,8 +4848,15 @@ TEBCresume(
* Compute the new variable value.
*/
- objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
+ if (TclObjTypeHasProc(valuePtr, setElementProc)) {
+
+ objResultPtr = Tcl_ObjTypeSetElement(interp,
+ valuePtr, numIndices,
+ &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
+ } else {
+ objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
+ }
if (!objResultPtr) {
TRACE_ERROR(interp);
goto gotError;
@@ -4976,8 +4977,10 @@ TEBCresume(
fromIdx = TclIndexDecode(fromIdx, objc - 1);
- if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) {
- objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx);
+ if (TclObjTypeHasProc(valuePtr, sliceProc)) {
+ if (Tcl_ObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) {
+ objResultPtr = NULL;
+ }
} else {
objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx);
}
@@ -5004,14 +5007,18 @@ TEBCresume(
if (length > 0) {
Tcl_Size i = 0;
Tcl_Obj *o;
- int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType.objType);
+ int isAbstractList = TclObjTypeHasProc(value2Ptr,indexProc) != NULL;
+
/*
* An empty list doesn't match anything.
*/
do {
- if (isArithSeries) {
- o = TclArithSeriesObjIndex(NULL, value2Ptr, i);
+ if (isAbstractList) {
+ if (Tcl_ObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) {
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
} else {
Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
}
@@ -5024,9 +5031,10 @@ TEBCresume(
if (s1len == s2len) {
match = (memcmp(s1, s2, s1len) == 0);
}
- if (isArithSeries) {
- TclDecrRefCount(o);
- }
+
+ /* Could be an ephemeral abstract obj */
+ TclBumpObj(o);
+
i++;
} while (i < length && match == 0);
}
@@ -6368,7 +6376,7 @@ TEBCresume(
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
- if (TclHasInternalRep(valuePtr, &tclBooleanType.objType)) {
+ if (TclHasInternalRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
@@ -6436,7 +6444,7 @@ TEBCresume(
}
if (Tcl_IsShared(listPtr)) {
objPtr = TclDuplicatePureObj(
- interp, listPtr, &tclListType.objType);
+ interp, listPtr, &tclListType);
if (!objPtr) {
goto gotError;
}
@@ -8398,7 +8406,7 @@ ExecuteExtendedBinaryMathOp(
overflowExpon:
if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK)
- || (value2Ptr->typePtr != &tclIntType.objType)
+ || (value2Ptr->typePtr != &tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 3206a4f..215c6c7 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -380,7 +380,7 @@ ExecuteCallback(
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclDuplicatePureObj(
- interp, dataPtr->command, &tclListType.objType);
+ interp, dataPtr->command, &tclListType);
if (!command) {
return TCL_ERROR;
}
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index c7cbfe5..a657021 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -2261,7 +2261,7 @@ NewReflectedChannel(
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
- rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType.objType);
+ rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType);
if (!rcPtr->cmd) {
return NULL;
}
@@ -2401,7 +2401,7 @@ InvokeTclMethod(
* before the channel id.
*/
- cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType.objType);
+ cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType);
if (!cmd) {
return TCL_ERROR;
}
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index cec6ad3..57c9fe7 100644..100755
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1687,7 +1687,7 @@ Tcl_FSEvalFileEx(
use the utf-8 encoding. */
{
Tcl_Size length;
- int result = TCL_ERROR;
+ int result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
@@ -1802,7 +1802,7 @@ Tcl_FSEvalFileEx(
const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
unsigned limit = 150;
- int overflow = (length > limit);
+ int overflow = ((unsigned)length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
@@ -1954,7 +1954,7 @@ EvalFileCallback(
Tcl_Size length;
const char *pathString = Tcl_GetStringFromObj(pathPtr, &length);
- const unsigned int limit = 150;
+ const unsigned limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 47e514f..15b5029 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1086,20 +1086,40 @@ typedef struct ActiveInterpTrace {
#define TCL_TRACE_ENTER_EXEC 1
#define TCL_TRACE_LEAVE_EXEC 2
-typedef struct { /* For internal core use only */
- Tcl_ObjType objType;
- struct {
- Tcl_Size (*lengthProc)(Tcl_Obj *obj);
- } abstractList;
-} TclObjTypeWithAbstractList;
-#define TCL_OBJTYPE_V0_1(lengthProc) (sizeof(TclObjTypeWithAbstractList)) \
- }, {lengthProc /* For internal core use only */
-#define ABSTRACTLIST_PROC(objPtr, proc) (((objPtr)->typePtr \
- && ((objPtr)->typePtr->version > offsetof(TclObjTypeWithAbstractList, abstractList.proc))) ? \
- ((const TclObjTypeWithAbstractList *)(objPtr)->typePtr)->abstractList.proc : NULL)
+#define TclObjTypeHasProc(objPtr, proc) \
+ (((objPtr)->typePtr \
+ && (objPtr)->typePtr->version == TCL_OBJTYPE_CURRENT) ? \
+ ((objPtr)->typePtr)->proc : NULL)
+
MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *);
+
+/*
+ * Abstract List
+ *
+ * This structure provides the functions used in List operations to emulate a
+ * List for AbstractList types.
+ */
+
+
+#define Tcl_ObjTypeLength(objPtr) (objPtr)->typePtr->lengthProc(objPtr)
+#define Tcl_ObjTypeIndex(interp, objPtr, index, elemObjPtr) \
+ (objPtr)->typePtr->indexProc((interp),(objPtr),(index),(elemObjPtr))
+#define Tcl_ObjTypeSlice(interp, objPtr, fromIdx, toIdx, newObjPtr) \
+ (objPtr)->typePtr->sliceProc((interp),(objPtr),(fromIdx),(toIdx),(newObjPtr))
+#define Tcl_ObjTypeReverse(interp, objPtr, newObjPtr) \
+ (objPtr)->typePtr->reverseProc((interp),(objPtr),(newObjPtr))
+#define Tcl_ObjTypeGetElements(interp, objPtr, objCPtr, objVPtr) \
+ (objPtr)->typePtr->getElementsProc((interp),(objPtr),(objCPtr),(objVPtr))
+#define Tcl_ObjTypeSetElement(interp, objPtr, indexCount, indexArray, valueObj) \
+ (objPtr)->typePtr->setElementProc((interp), (objPtr), (indexCount), (indexArray), (valueObj))
+#define Tcl_ObjTypeReplace(interp, objPtr, first, numToDelete, numToInsert, insertObjs) \
+ (objPtr)->typePtr->replaceProc((interp), (objPtr), (first), (numToDelete), (numToInsert), (insertObjs))
+#define Tcl_ObjTypeGetDouble(interp, objPtr, doublePtr) \
+ (objPtr)->typePtr->getDoubleProc((interp), (objPtr), (doublePtr))
+
+
/*
* The structure below defines an entry in the assocData hash table which is
* associated with an interpreter. The entry contains a pointer to a function
@@ -2613,7 +2633,7 @@ typedef struct ListRep {
* converted to a list.
*/
#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \
- (((listObj_)->typePtr == &tclListType.objType) \
+ (((listObj_)->typePtr == &tclListType) \
? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
TCL_OK) \
: Tcl_ListObjGetElements( \
@@ -2625,12 +2645,12 @@ typedef struct ListRep {
* Tcl_Obj cannot be converted to a list.
*/
#define TclListObjLengthM(interp_, listObj_, lenPtr_) \
- (((listObj_)->typePtr == &tclListType.objType) \
+ (((listObj_)->typePtr == &tclListType) \
? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
: Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
#define TclListObjIsCanonical(listObj_) \
- (((listObj_)->typePtr == &tclListType.objType) ? ListObjIsCanonical((listObj_)) : 0)
+ (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
@@ -2650,27 +2670,27 @@ typedef struct ListRep {
#if TCL_MAJOR_VERSION > 8
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
- (((objPtr)->typePtr == &tclIntType.objType \
- || (objPtr)->typePtr == &tclBooleanType.objType) \
+ (((objPtr)->typePtr == &tclIntType \
+ || (objPtr)->typePtr == &tclBooleanType) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#else
#define TclGetBooleanFromObj(interp, objPtr, intPtr) \
- (((objPtr)->typePtr == &tclIntType.objType) \
+ (((objPtr)->typePtr == &tclIntType) \
? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
- : ((objPtr)->typePtr == &tclBooleanType.objType) \
+ : ((objPtr)->typePtr == &tclBooleanType) \
? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr)))
#endif
#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
- (((objPtr)->typePtr == &tclIntType.objType) \
+ (((objPtr)->typePtr == &tclIntType) \
? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
#else
#define TclGetLongFromObj(interp, objPtr, longPtr) \
- (((objPtr)->typePtr == &tclIntType.objType \
+ (((objPtr)->typePtr == &tclIntType \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \
? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
@@ -2678,13 +2698,13 @@ typedef struct ListRep {
#endif
#define TclGetIntFromObj(interp, objPtr, intPtr) \
- (((objPtr)->typePtr == &tclIntType.objType \
+ (((objPtr)->typePtr == &tclIntType \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
- ((((objPtr)->typePtr == &tclIntType.objType) && ((objPtr)->internalRep.wideValue >= 0) \
+ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
&& ((objPtr)->internalRep.wideValue <= endValue)) \
? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
@@ -2698,7 +2718,7 @@ typedef struct ListRep {
*/
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
- (((objPtr)->typePtr == &tclIntType.objType) \
+ (((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = \
((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
@@ -2973,13 +2993,12 @@ MODULE_SCOPE void *tclTimeClientData;
* Variables denoting the Tcl object types defined in the core.
*/
-MODULE_SCOPE const TclObjTypeWithAbstractList tclBignumType;
-MODULE_SCOPE const TclObjTypeWithAbstractList tclBooleanType;
+MODULE_SCOPE const Tcl_ObjType tclBignumType;
+MODULE_SCOPE const Tcl_ObjType tclBooleanType;
MODULE_SCOPE const Tcl_ObjType tclByteCodeType;
-MODULE_SCOPE const TclObjTypeWithAbstractList tclDoubleType;
-MODULE_SCOPE const TclObjTypeWithAbstractList tclIntType;
-MODULE_SCOPE const TclObjTypeWithAbstractList tclListType;
-MODULE_SCOPE const TclObjTypeWithAbstractList tclArithSeriesType;
+MODULE_SCOPE const Tcl_ObjType tclDoubleType;
+MODULE_SCOPE const Tcl_ObjType tclIntType;
+MODULE_SCOPE const Tcl_ObjType tclListType;
MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
@@ -3359,6 +3378,9 @@ MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf);
MODULE_SCOPE Tcl_Obj * TclpTempFileName(void);
MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp,
Tcl_Obj* pathPtr);
+MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesPtr,
+ int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj,
+ Tcl_Obj *stepObj, Tcl_Obj *lenObj);
MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep,
Tcl_Size len);
MODULE_SCOPE void TclpAlertNotifier(void *clientData);
@@ -4886,7 +4908,7 @@ MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init;
MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init;
MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init;
MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
-
+MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init;
/*
@@ -4918,7 +4940,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
Tcl_ObjInternalRep ir; \
ir.wideValue = (Tcl_WideInt) i; \
TclInvalidateStringRep(objPtr); \
- Tcl_StoreInternalRep(objPtr, &tclIntType.objType, &ir); \
+ Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \
} while (0)
#define TclSetDoubleObj(objPtr, d) \
@@ -4926,7 +4948,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
Tcl_ObjInternalRep ir; \
ir.doubleValue = (double) d; \
TclInvalidateStringRep(objPtr); \
- Tcl_StoreInternalRep(objPtr, &tclDoubleType.objType, &ir); \
+ Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \
} while (0)
/*
@@ -4951,7 +4973,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclIntType.objType; \
+ (objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
@@ -4970,7 +4992,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
TclSetBignumInternalRep((objPtr), &bignumValue_); \
} else { \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \
- (objPtr)->typePtr = &tclIntType.objType; \
+ (objPtr)->typePtr = &tclIntType; \
} \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
@@ -4985,7 +5007,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.doubleValue = (double)(d); \
- (objPtr)->typePtr = &tclDoubleType.objType; \
+ (objPtr)->typePtr = &tclDoubleType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
diff --git a/generic/tclLink.c b/generic/tclLink.c
index 7474769..b136709 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -547,7 +547,7 @@ GetDouble(
return 0;
} else {
#ifdef ACCEPT_NAN
- Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType.objType);
+ Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType);
if (irPtr != NULL) {
*dblPtr = irPtr->doubleValue;
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 6288ffb..63b895c 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -12,7 +12,6 @@
#include <assert.h>
#include "tclInt.h"
#include "tclTomMath.h"
-#include "tclArithSeries.h"
/*
* TODO - memmove is fast. Measure at what size we should prefer memmove
@@ -69,7 +68,7 @@
/* Checks for when caller should have already converted to internal list type */
#define LIST_ASSERT_TYPE(listObj_) \
- LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType.objType))
+ LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType))
/*
* If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the
@@ -151,15 +150,21 @@ static Tcl_Size ListLength(Tcl_Obj *listPtr);
* The internal representation of a list object is ListRep defined in tcl.h.
*/
-const TclObjTypeWithAbstractList tclListType = {
- {"list", /* name */
+const Tcl_ObjType tclListType = {
+ "list", /* name */
FreeListInternalRep, /* freeIntRepProc */
DupListInternalRep, /* dupIntRepProc */
UpdateStringOfList, /* updateStringProc */
SetListFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- ListLength
- )}
+ TCL_OBJTYPE_V2(
+ ListLength,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL)
};
/* Macros to manipulate the List internal rep */
@@ -205,7 +210,7 @@ const TclObjTypeWithAbstractList tclListType = {
do { \
(objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
(objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
- (objPtr_)->typePtr = &tclListType.objType; \
+ (objPtr_)->typePtr = &tclListType; \
} while (0)
#define ListObjOverwriteRep(objPtr_, repPtr_) \
@@ -1251,7 +1256,7 @@ TclListObjGetRep(
* to be returned. */
ListRep *repPtr) /* Location to store descriptor */
{
- if (!TclHasInternalRep(listObj, &tclListType.objType)) {
+ if (!TclHasInternalRep(listObj, &tclListType)) {
int result;
result = SetListFromAny(interp, listObj);
if (result != TCL_OK) {
@@ -1622,12 +1627,19 @@ Tcl_ListObjGetElements(
{
ListRep listRep;
- if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) {
- return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr);
+ if (TclObjTypeHasProc(objPtr, getElementsProc) &&
+ objPtr->typePtr->getElementsProc(interp, objPtr, objcPtr, objvPtr) == TCL_OK) {
+ return TCL_OK;
+ } else if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) {
+ int length;
+ (void) Tcl_GetStringFromObj(objPtr, &length);
+ if (length == 0) {
+ *objcPtr = 0;
+ *objvPtr = NULL;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
}
-
- if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
- return TCL_ERROR;
ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
@@ -1907,6 +1919,7 @@ Tcl_ListObjIndex(
{
Tcl_Obj **elemObjs;
Tcl_Size numElems;
+ int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0;
/* Empty string => empty list. Avoid unnecessary shimmering */
if (listObj->bytes == &tclEmptyString) {
@@ -1914,6 +1927,10 @@ Tcl_ListObjIndex(
return TCL_OK;
}
+ if (hasAbstractList) {
+ return Tcl_ObjTypeIndex(interp, listObj, index, objPtrPtr);
+ }
+
if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
!= TCL_OK) {
return TCL_ERROR;
@@ -1964,7 +1981,7 @@ Tcl_ListObjLength(
return TCL_OK;
}
- Tcl_Size (*lengthProc)(Tcl_Obj *obj) = ABSTRACTLIST_PROC(listObj, lengthProc);
+ Tcl_Size (*lengthProc)(Tcl_Obj *obj) = TclObjTypeHasProc(listObj, lengthProc);
if (lengthProc) {
*lenPtr = lengthProc(listObj);
return TCL_OK;
@@ -2048,6 +2065,11 @@ Tcl_ListObjReplace(
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
+ if (TclObjTypeHasProc(listObj, replaceProc)) {
+ return Tcl_ObjTypeReplace(interp, listObj, first,
+ numToDelete, numToInsert, insertObjs);
+ }
+
if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
return TCL_ERROR; /* Cannot be converted to a list */
@@ -2527,7 +2549,7 @@ TclLindexList(
* shimmering; if internal rep is already a list do not shimmer it.
* see TIP#22 and TIP#33 for the details.
*/
- if (!TclHasInternalRep(argObj, &tclListType.objType)
+ if (!TclHasInternalRep(argObj, &tclListType)
&& TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1, &index)
== TCL_OK) {
/*
@@ -2548,7 +2570,7 @@ TclLindexList(
* does not.
*/
- indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType.objType);
+ indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType);
if (!indexListCopy) {
/*
* The argument is neither an index nor a well-formed list.
@@ -2609,9 +2631,9 @@ TclLindexFlat(
int status;
Tcl_Size i;
- /* Handle ArithSeries as special case */
- if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {
- Tcl_Size listLen = ABSTRACTLIST_PROC(listObj, lengthProc)(listObj);
+ /* Handle AbstractList as special case */
+ if (TclObjTypeHasProc(listObj,indexProc)) {
+ Tcl_Size listLen = TclObjTypeHasProc(listObj,lengthProc)(listObj);
Tcl_Size index;
Tcl_Obj *elemObj = NULL;
for (i=0 ; i<indexCount && listObj ; i++) {
@@ -2619,12 +2641,14 @@ TclLindexFlat(
&index) == TCL_OK) {
}
if (i==0) {
- elemObj = TclArithSeriesObjIndex(NULL, listObj, index);
+ if (Tcl_ObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) {
+ return NULL;
+ }
} else if (index > 0) {
- /* ArithSeries cannot be a list of lists */
+ // TODO: support nested lists
+ Tcl_Obj *e2Obj = TclLindexFlat(interp, elemObj, 1, &indexArray[i]);
Tcl_DecrRefCount(elemObj);
- TclNewObj(elemObj);
- break;
+ elemObj = e2Obj;
}
}
Tcl_IncrRefCount(elemObj);
@@ -2668,7 +2692,7 @@ TclLindexFlat(
* Must set the internal rep again because it may have been
* changed by TclGetIntForIndexM. See test lindex-8.4.
*/
- if (!TclHasInternalRep(listObj, &tclListType.objType)) {
+ if (!TclHasInternalRep(listObj, &tclListType)) {
status = SetListFromAny(interp, listObj);
if (status != TCL_OK) {
/* The list is not a list at all => error. */
@@ -2740,39 +2764,55 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- if (!TclHasInternalRep(indexArgObj, &tclListType.objType)
- && TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
- == TCL_OK) {
- /* indexArgPtr designates a single index. */
- /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
- return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- }
+ if (!TclHasInternalRep(indexArgObj, &tclListType) &&
+ TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index)
+ == TCL_OK) {
- indexListCopy = TclDuplicatePureObj(
- interp, indexArgObj, &tclListType.objType);
- if (!indexListCopy) {
- /*
- * indexArgPtr designates something that is neither an index nor a
- * well formed list. Report the error via TclLsetFlat.
- */
- return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- }
- if (TCL_OK != TclListObjGetElementsM(
- interp, indexListCopy, &indexCount, &indices)) {
- Tcl_DecrRefCount(indexListCopy);
- /*
- * indexArgPtr designates something that is neither an index nor a
- * well formed list. Report the error via TclLsetFlat.
- */
- return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
- }
+ if (TclObjTypeHasProc(listObj, setElementProc)) {
+ indices = &indexArgObj;
+ retValueObj =
+ Tcl_ObjTypeSetElement(interp, listObj, 1, indices, valueObj);
+ if (retValueObj) Tcl_IncrRefCount(retValueObj);
+ } else {
- /*
- * Let TclLsetFlat perform the actual lset operation.
- */
+ /* indexArgPtr designates a single index. */
+ /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */
+ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
+ }
- retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
- Tcl_DecrRefCount(indexListCopy);
+ } else {
+
+ indexListCopy = TclDuplicatePureObj(
+ interp, indexArgObj, &tclListType);
+ if (!indexListCopy) {
+ /*
+ * indexArgPtr designates something that is neither an index nor a
+ * well formed list. Report the error via TclLsetFlat.
+ */
+ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
+ } else {
+ if (TCL_OK != TclListObjGetElementsM(
+ interp, indexListCopy, &indexCount, &indices)) {
+ Tcl_DecrRefCount(indexListCopy);
+ /*
+ * indexArgPtr designates something that is neither an index nor a
+ * well formed list. Report the error via TclLsetFlat.
+ */
+ retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
+ } else {
+
+ /*
+ * Let TclLsetFlat perform the actual lset operation.
+ */
+
+ retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
+ if (indexListCopy) {
+ Tcl_DecrRefCount(indexListCopy);
+ }
+ }
+ }
+ }
+ assert (retValueObj==NULL || retValueObj->typePtr || retValueObj->bytes);
return retValueObj;
}
@@ -2847,7 +2887,7 @@ TclLsetFlat(
*/
subListObj = Tcl_IsShared(listObj)
- ? TclDuplicatePureObj(interp, listObj, &tclListType.objType) : listObj;
+ ? TclDuplicatePureObj(interp, listObj, &tclListType) : listObj;
if (!subListObj) {
return NULL;
}
@@ -2934,7 +2974,7 @@ TclLsetFlat(
}
if (Tcl_IsShared(subListObj)) {
subListObj = TclDuplicatePureObj(
- interp, subListObj, &tclListType.objType);
+ interp, subListObj, &tclListType);
if (!subListObj) {
return NULL;
}
@@ -2958,7 +2998,7 @@ TclLsetFlat(
if (Tcl_IsShared(subListObj)) {
Tcl_Obj * newSubListObj;
newSubListObj = TclDuplicatePureObj(
- interp, subListObj, &tclListType.objType);
+ interp, subListObj, &tclListType);
if (copied) {
Tcl_DecrRefCount(subListObj);
}
@@ -3289,35 +3329,32 @@ SetListFromAny(
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
- } else if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) {
- /*
- * Convertion from Arithmetic Series is a special case
- * because it can be done an order of magnitude faster
- * and may occur frequently.
- */
- Tcl_Size j, size = ABSTRACTLIST_PROC(objPtr, lengthProc)(objPtr);
+ } else if (TclObjTypeHasProc(objPtr,indexProc)) {
+ Tcl_Size elemCount, i;
- /* TODO - leave space in front and/or back? */
- if (ListRepInitAttempt(
- interp, size > 0 ? size : 1, NULL, &listRep)
- != TCL_OK) {
+ elemCount = TclObjTypeHasProc(objPtr,lengthProc)(objPtr);
+
+ if (ListRepInitAttempt(interp, elemCount, 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++) {
- elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j);
- if (elemPtrs[j] == NULL) {
- return TCL_ERROR;
- }
- Tcl_IncrRefCount(elemPtrs[j]);
+
+ /* Each iteration, store a list element */
+ for (i = 0; i < elemCount; i++) {
+ if (Tcl_ObjTypeIndex(interp, objPtr, i, elemPtrs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
+ LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount);
+
+ listRep.storePtr->numUsed = elemCount;
+
} else {
Tcl_Size estCount, length;
const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length);
@@ -3399,7 +3436,7 @@ fail:
TclFreeInternalRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
- objPtr->typePtr = &tclListType.objType;
+ objPtr->typePtr = &tclListType;
return TCL_OK;
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5c18f5e..9ad45df 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -228,45 +228,37 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
-const TclObjTypeWithAbstractList tclBooleanType= {
- {"boolean", /* name */
+const Tcl_ObjType tclBooleanType= {
+ "boolean", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- TclSetBooleanFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- TclLengthOne
- )}
+ TclSetBooleanFromAny, /* setFromAnyProc */
+ TCL_OBJTYPE_V1(TclLengthOne)
};
-const TclObjTypeWithAbstractList tclDoubleType= {
- {"double", /* name */
+const Tcl_ObjType tclDoubleType= {
+ "double", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- TclLengthOne
- )}
+ TCL_OBJTYPE_V1(TclLengthOne)
};
-const TclObjTypeWithAbstractList tclIntType = {
- {"int", /* name */
+const Tcl_ObjType tclIntType = {
+ "int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- TclLengthOne
- )}
+ TCL_OBJTYPE_V1(TclLengthOne)
};
-const TclObjTypeWithAbstractList tclBignumType = {
- {"bignum", /* name */
+const Tcl_ObjType tclBignumType = {
+ "bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- TclLengthOne
- )}
+ TCL_OBJTYPE_V1(TclLengthOne)
};
/*
@@ -388,15 +380,24 @@ TclInitObjSubsystem(void)
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&tableMutex);
- Tcl_RegisterObjType(&tclDoubleType.objType);
+ Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclStringType);
- Tcl_RegisterObjType(&tclListType.objType);
+ Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
+ /* For backward compatibility only ... */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ Tcl_RegisterObjType(&tclIntType);
+#if !defined(TCL_WIDE_INT_IS_LONG)
+ Tcl_RegisterObjType(&oldIntType);
+#endif
+ Tcl_RegisterObjType(&oldBooleanType);
+#endif
+
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
@@ -1615,6 +1616,8 @@ int SetDuplicatePureObj(
{
char *bytes = objPtr->bytes;
int status = TCL_OK;
+ const Tcl_ObjType *useTypePtr =
+ objPtr->typePtr ? objPtr->typePtr : typePtr;
TclInvalidateStringRep(dupPtr);
assert(dupPtr->typePtr == NULL);
@@ -1626,13 +1629,13 @@ int SetDuplicatePureObj(
dupPtr->typePtr = objPtr->typePtr;
}
- if (typePtr != NULL && dupPtr->typePtr != typePtr) {
+ if (typePtr != NULL && dupPtr->typePtr != useTypePtr) {
if (bytes) {
dupPtr->bytes = bytes;
dupPtr->length = objPtr->length;
}
/* borrow bytes from original object */
- status = Tcl_ConvertToType(interp, dupPtr, typePtr);
+ status = Tcl_ConvertToType(interp, dupPtr, useTypePtr);
if (bytes) {
dupPtr->bytes = NULL;
dupPtr->length = 0;
@@ -1655,7 +1658,7 @@ int SetDuplicatePureObj(
if (bytes && (dupPtr->typePtr == NULL
|| dupPtr->typePtr->updateStringProc == NULL
- || typePtr == &tclStringType
+ || useTypePtr == &tclStringType
)
) {
if (!TclAttemptInitStringRep(dupPtr, bytes, objPtr->length)) {
@@ -2145,11 +2148,11 @@ Tcl_GetBoolFromObj(
return TCL_ERROR;
}
do {
- if (objPtr->typePtr == &tclIntType.objType || objPtr->typePtr == &tclBooleanType.objType) {
+ if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) {
result = (objPtr->internalRep.wideValue != 0);
goto boolEnd;
}
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
/*
* Caution: Don't be tempted to check directly for the "double"
* Tcl_ObjType and then compare the internalrep to 0.0. This isn't
@@ -2166,7 +2169,7 @@ Tcl_GetBoolFromObj(
result = (d != 0.0);
goto boolEnd;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
result = 1;
boolEnd:
if (charPtr != NULL) {
@@ -2234,18 +2237,18 @@ TclSetBooleanFromAny(
*/
if (objPtr->bytes == NULL) {
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
goto badBoolean;
}
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
}
@@ -2376,13 +2379,13 @@ ParseBoolean(
goodBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
- objPtr->typePtr = &tclBooleanType.objType;
+ objPtr->typePtr = &tclBooleanType;
return TCL_OK;
numericBoolean:
TclFreeInternalRep(objPtr);
objPtr->internalRep.wideValue = newBool;
- objPtr->typePtr = &tclIntType.objType;
+ objPtr->typePtr = &tclIntType;
return TCL_OK;
}
@@ -2474,7 +2477,7 @@ Tcl_DbNewDoubleObj(
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
- objPtr->typePtr = &tclDoubleType.objType;
+ objPtr->typePtr = &tclDoubleType;
return objPtr;
}
@@ -2547,7 +2550,11 @@ Tcl_GetDoubleFromObj(
double *dblPtr) /* Place to store resulting double. */
{
do {
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ Tcl_ObjTypeGetDblProc *dblProc = TclObjTypeHasProc(objPtr, getDoubleProc);
+ if (dblProc) {
+ return dblProc(interp, objPtr, dblPtr);
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
if (isnan(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -2560,11 +2567,11 @@ Tcl_GetDoubleFromObj(
*dblPtr = (double) objPtr->internalRep.doubleValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
mp_int big;
TclUnpackBignum(objPtr, big);
@@ -2778,12 +2785,12 @@ Tcl_GetLongFromObj(
{
do {
#ifdef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
*longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
#else
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
/*
* We return any integer in the range LONG_MIN to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
@@ -2802,7 +2809,7 @@ Tcl_GetLongFromObj(
goto tooLarge;
}
#endif
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
@@ -2811,7 +2818,7 @@ Tcl_GetLongFromObj(
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
@@ -3039,11 +3046,11 @@ Tcl_GetWideIntFromObj(
/* Place to store resulting long. */
{
do {
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
@@ -3052,7 +3059,7 @@ Tcl_GetWideIntFromObj(
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
@@ -3124,7 +3131,7 @@ Tcl_GetWideUIntFromObj(
/* Place to store resulting long. */
{
do {
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
if (objPtr->internalRep.wideValue < 0) {
wideUIntOutOfRange:
if (interp != NULL) {
@@ -3138,10 +3145,10 @@ Tcl_GetWideUIntFromObj(
*wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
goto wideUIntOutOfRange;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
/*
* Must check for those bignum values that can fit in a
* Tcl_WideUInt, even when auto-narrowing is enabled.
@@ -3208,11 +3215,11 @@ TclGetWideBitsFromObj(
Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
{
do {
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
@@ -3221,7 +3228,7 @@ TclGetWideBitsFromObj(
}
return TCL_ERROR;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
mp_int big;
mp_err err;
@@ -3325,7 +3332,7 @@ DupBignum(
mp_int bignumVal;
mp_int bignumCopy;
- copyPtr->typePtr = &tclBignumType.objType;
+ copyPtr->typePtr = &tclBignumType;
TclUnpackBignum(srcPtr, bignumVal);
if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) {
Tcl_Panic("initialization failure in DupBignum");
@@ -3495,7 +3502,7 @@ GetBignumFromObj(
mp_int *bignumValue) /* Returned bignum value. */
{
do {
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
@@ -3520,14 +3527,14 @@ GetBignumFromObj(
}
return TCL_OK;
}
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
if (mp_init_i64(bignumValue,
objPtr->internalRep.wideValue) != MP_OKAY) {
return TCL_ERROR;
}
return TCL_OK;
}
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
@@ -3687,7 +3694,7 @@ TclSetBignumInternalRep(
void *big)
{
mp_int *bignumValue = (mp_int *)big;
- objPtr->typePtr = &tclBignumType.objType;
+ objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
/*
@@ -3730,7 +3737,7 @@ Tcl_GetNumberFromObj(
int *typePtr)
{
do {
- if (objPtr->typePtr == &tclDoubleType.objType) {
+ if (objPtr->typePtr == &tclDoubleType) {
if (isnan(objPtr->internalRep.doubleValue)) {
*typePtr = TCL_NUMBER_NAN;
} else {
@@ -3739,12 +3746,12 @@ Tcl_GetNumberFromObj(
*clientDataPtr = &objPtr->internalRep.doubleValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclIntType.objType) {
+ if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
- if (objPtr->typePtr == &tclBignumType.objType) {
+ if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
sizeof(mp_int));
@@ -4705,7 +4712,7 @@ Tcl_RepresentationCmd(
objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
- if (objv[1]->typePtr == &tclDoubleType.objType) {
+ if (objv[1]->typePtr == &tclDoubleType) {
Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
objv[1]->internalRep.doubleValue);
} else {
diff --git a/generic/tclScan.c b/generic/tclScan.c
index bc2df17..42838ac 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -1046,7 +1046,7 @@ Tcl_ScanObjCmd(
if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) {
#ifdef ACCEPT_NAN
const Tcl_ObjInternalRep *irPtr
- = TclFetchInternalRep(objPtr, &tclDoubleType.objType);
+ = TclFetchInternalRep(objPtr, &tclDoubleType);
if (irPtr) {
dvalue = irPtr->doubleValue;
} else
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 5a173af..03a7ab7 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -555,7 +555,7 @@ TclParseNumber(
/* A dict can never be a (single) number */
return TCL_ERROR;
}
- if (TclHasInternalRep(objPtr, &tclListType.objType)) {
+ if (TclHasInternalRep(objPtr, &tclListType)) {
Tcl_Size length;
/* A list can only be a (single) number if its length == 1 */
TclListObjLengthM(NULL, objPtr, &length);
@@ -1378,7 +1378,7 @@ TclParseNumber(
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
- objPtr->typePtr = &tclIntType.objType;
+ objPtr->typePtr = &tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-octalSignificandWide);
@@ -1414,7 +1414,7 @@ TclParseNumber(
significandWide);
significandOverflow = 1;
} else {
- objPtr->typePtr = &tclIntType.objType;
+ objPtr->typePtr = &tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
(Tcl_WideInt)(-significandWide);
@@ -1446,7 +1446,7 @@ TclParseNumber(
* k = numTrailZeros+exponent-numDigitsAfterDp.
*/
- objPtr->typePtr = &tclDoubleType.objType;
+ objPtr->typePtr = &tclDoubleType;
if (exponentSignum) {
/*
* At this point exponent>=0, so the following calculation
@@ -1497,14 +1497,14 @@ TclParseNumber(
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
- objPtr->typePtr = &tclDoubleType.objType;
+ objPtr->typePtr = &tclDoubleType;
break;
#ifdef IEEE_FLOATING_POINT
case sNAN:
case sNANFINISH:
objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide);
- objPtr->typePtr = &tclDoubleType.objType;
+ objPtr->typePtr = &tclDoubleType;
break;
#endif
case INITIAL:
diff --git a/generic/tclTest.c b/generic/tclTest.c
index f0dd5bc..4bfd810 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -741,6 +741,10 @@ Tcltest_Init(
}
#endif
+ if (Tcl_ABSListTest_Init(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
/*
* Check for special options used in ../tests/main.test
*/
@@ -8802,4 +8806,3 @@ vamoose:
* indent-tabs-mode: nil
* End:
*/
-
diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c
new file mode 100644
index 0000000..ec45932
--- /dev/null
+++ b/generic/tclTestABSList.c
@@ -0,0 +1,939 @@
+// Tcl Abstract List test command: "lstring"
+
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
+#include <string.h>
+#include <limits.h>
+#include "tclInt.h"
+
+/*
+ * Forward references
+ */
+
+Tcl_Obj *myNewLStringObj(Tcl_WideInt start,
+ Tcl_WideInt length);
+static void freeRep(Tcl_Obj* alObj);
+static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp,
+ Tcl_Obj *listPtr,
+ Tcl_Size numIndcies,
+ Tcl_Obj *const indicies[],
+ Tcl_Obj *valueObj);
+static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr);
+static int my_LStringObjIndex(Tcl_Interp *interp,
+ Tcl_Obj *lstringObj,
+ Tcl_Size index,
+ Tcl_Obj **charObjPtr);
+static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj,
+ Tcl_Size fromIdx, Tcl_Size toIdx,
+ Tcl_Obj **newObjPtr);
+static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj,
+ Tcl_Obj **newObjPtr);
+static int my_LStringReplace(Tcl_Interp *interp,
+ Tcl_Obj *listObj,
+ Tcl_Size first,
+ Tcl_Size numToDelete,
+ Tcl_Size numToInsert,
+ Tcl_Obj *const insertObjs[]);
+static int my_LStringGetElements(Tcl_Interp *interp,
+ Tcl_Obj *listPtr,
+ Tcl_Size *objcptr,
+ Tcl_Obj ***objvptr);
+static void UpdateStringOfLString(Tcl_Obj *objPtr);
+
+/*
+ * Internal Representation of an lstring type value
+ */
+
+typedef struct LString {
+ char *string; // NULL terminated utf-8 string
+ Tcl_Size strlen; // num bytes in string
+ Tcl_Size allocated; // num bytes allocated
+ Tcl_Obj**elements; // elements array, allocated when GetElements is
+ // called
+} LString;
+
+/*
+ * AbstractList definition of an lstring type
+ */
+static const Tcl_ObjType lstringTypes[11] = {
+ {/*0*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*1*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ NULL, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*2*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ NULL, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*3*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ NULL, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*4*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ NULL, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*5*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ NULL, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*6*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ NULL, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*7*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ NULL, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*8*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*9*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ },
+ {/*10*/
+ "lstring",
+ freeRep,
+ DupLStringRep,
+ UpdateStringOfLString,
+ NULL,
+ TCL_OBJTYPE_V2(
+ my_LStringObjLength, /* Length */
+ my_LStringObjIndex, /* Index */
+ my_LStringObjRange, /* Slice */
+ my_LStringObjReverse, /* Reverse */
+ my_LStringGetElements, /* GetElements */
+ my_LStringObjSetElem, /* SetElement */
+ my_LStringReplace, /* Replace */
+ NULL) /* getDouble */
+ }
+};
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringObjIndex --
+ *
+ * Implements the AbstractList Index function for the lstring type. The
+ * Index function returns the value at the index position given. Caller
+ * is resposible for freeing the Obj.
+ *
+ * Results:
+ * TCL_OK on success. Returns a new Obj, with a 0 refcount in the
+ * supplied charObjPtr location. Call has ownership of the Obj.
+ *
+ * Side effects:
+ * Obj allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+my_LStringObjIndex(
+ Tcl_Interp *interp,
+ Tcl_Obj *lstringObj,
+ Tcl_Size index,
+ Tcl_Obj **charObjPtr)
+{
+ LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
+
+ (void)interp;
+
+ if (index < lstringRepPtr->strlen) {
+ char cchar[2];
+ cchar[0] = lstringRepPtr->string[index];
+ cchar[1] = 0;
+ *charObjPtr = Tcl_NewStringObj(cchar,1);
+ } else {
+ *charObjPtr = Tcl_NewObj();
+ }
+
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringObjLength --
+ *
+ * Implements the AbstractList Length function for the lstring type.
+ * The Length function returns the number of elements in the list.
+ *
+ * Results:
+ * WideInt number of elements in the list.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Size
+my_LStringObjLength(Tcl_Obj *lstringObjPtr)
+{
+ LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1;
+ return lstringRepPtr->strlen;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupLStringRep --
+ *
+ * Replicates the internal representation of the src value, and storing
+ * it in the copy
+ *
+ * Results:
+ * void
+ *
+ * Side effects:
+ * Modifies the rep of the copyObj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)
+{
+ LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1;
+ LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString));
+
+ memcpy(copyLString, srcLString, sizeof(LString));
+ copyLString->string = (char*)Tcl_Alloc(srcLString->allocated);
+ strcpy(copyLString->string, srcLString->string);
+ copyLString->elements = NULL;
+ Tcl_ObjInternalRep itr;
+ itr.twoPtrValue.ptr1 = copyLString;
+ itr.twoPtrValue.ptr2 = NULL;
+ Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr);
+
+ return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringObjSetElem --
+ *
+ * Replace the element value at the given (nested) index with the
+ * valueObj provided. If the lstring obj is shared, a new list is
+ * created conntaining the modifed element.
+ *
+ * Results:
+ * The modifed lstring is returned, either new or original. If the
+ * index is invalid, NULL is returned, and an error is added to the
+ * interp, if provided.
+ *
+ * Side effects:
+ * A new obj may be created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj*
+my_LStringObjSetElem(
+ Tcl_Interp *interp,
+ Tcl_Obj *lstringObj,
+ Tcl_Size numIndicies,
+ Tcl_Obj *const indicies[],
+ Tcl_Obj *valueObj)
+{
+ LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
+ Tcl_Size index;
+ const char *newvalue;
+ int status;
+ Tcl_Obj *returnObj;
+
+ if (numIndicies > 1) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("Multiple indicies not supported by lstring."));
+ return NULL;
+ }
+
+ status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index);
+ if (status != TCL_OK) {
+ return NULL;
+ }
+
+ returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj;
+ lstringRepPtr = (LString*)returnObj->internalRep.twoPtrValue.ptr1;
+
+ if (index >= lstringRepPtr->strlen) {
+ index = lstringRepPtr->strlen;
+ lstringRepPtr->strlen++;
+ lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1);
+ }
+
+ newvalue = Tcl_GetString(valueObj);
+ lstringRepPtr->string[index] = newvalue[0];
+
+ Tcl_InvalidateStringRep(returnObj);
+
+ return returnObj;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringObjRange --
+ *
+ * Creates a new Obj with a slice of the src listPtr.
+ *
+ * Results:
+ * A new Obj is assigned to newObjPtr. Returns TCL_OK
+ *
+ * Side effects:
+ * A new Obj is created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int my_LStringObjRange(
+ Tcl_Interp *interp,
+ Tcl_Obj *lstringObj,
+ Tcl_Size fromIdx,
+ Tcl_Size toIdx,
+ Tcl_Obj **newObjPtr)
+{
+ Tcl_Obj *rangeObj;
+ LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
+ LString *rangeRep;
+ Tcl_WideInt len = toIdx - fromIdx + 1;
+
+ if (lstringRepPtr->strlen < fromIdx ||
+ lstringRepPtr->strlen < toIdx) {
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("Range out of bounds "));
+ return TCL_ERROR;
+ }
+
+ if (len <= 0) {
+ // Return empty value;
+ *newObjPtr = Tcl_NewObj();
+ } else {
+ rangeRep = (LString*)Tcl_Alloc(sizeof(LString));
+ rangeRep->allocated = len+1;
+ rangeRep->strlen = len;
+ rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated);
+ strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len);
+ rangeRep->string[len] = 0;
+ rangeRep->elements = NULL;
+ rangeObj = Tcl_NewObj();
+ Tcl_ObjInternalRep itr;
+ itr.twoPtrValue.ptr1 = rangeRep;
+ itr.twoPtrValue.ptr2 = NULL;
+ Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr);
+ if (rangeRep->strlen > 0) {
+ Tcl_InvalidateStringRep(rangeObj);
+ } else {
+ Tcl_InitStringRep(rangeObj, NULL, 0);
+ }
+ *newObjPtr = rangeObj;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringObjReverse --
+ *
+ * Creates a new Obj with the the order of the elements in the lstring
+ * value reversed, where first is last and last is first, etc.
+ *
+ * Results:
+ * A new Obj is assigned to newObjPtr. Returns TCL_OK
+ *
+ * Side effects:
+ * A new Obj is created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr)
+{
+ LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj *revObj;
+ LString *revRep = (LString*)Tcl_Alloc(sizeof(LString));
+ Tcl_ObjInternalRep itr;
+ Tcl_Size len;
+ char *srcp, *dstp, *endp;
+ (void)interp;
+ len = srcRep->strlen;
+ revRep->strlen = len;
+ revRep->allocated = len+1;
+ revRep->string = (char*)Tcl_Alloc(revRep->allocated);
+ revRep->elements = NULL;
+ srcp = srcRep->string;
+ endp = &srcRep->string[len];
+ dstp = &revRep->string[len];
+ *dstp-- = 0;
+ while (srcp < endp) {
+ *dstp-- = *srcp++;
+ }
+ revObj = Tcl_NewObj();
+ itr.twoPtrValue.ptr1 = revRep;
+ itr.twoPtrValue.ptr2 = NULL;
+ Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr);
+ if (revRep->strlen > 0) {
+ Tcl_InvalidateStringRep(revObj);
+ } else {
+ Tcl_InitStringRep(revObj, NULL, 0);
+ }
+ *newObjPtr = revObj;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringReplace --
+ *
+ * Delete and/or Insert elements in the list, starting at index first.
+ * See more details in the comments below. This should not be called with
+ * a Shared Obj.
+ *
+ * Results:
+ * The value of the listObj is modified.
+ *
+ * Side effects:
+ * The string rep is invalidated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+my_LStringReplace(
+ Tcl_Interp *interp,
+ Tcl_Obj *listObj,
+ Tcl_Size first,
+ Tcl_Size numToDelete,
+ Tcl_Size numToInsert,
+ Tcl_Obj *const insertObjs[])
+{
+ LString *lstringRep = (LString*)listObj->internalRep.twoPtrValue.ptr1;
+ Tcl_Size newLen;
+ Tcl_Size x, ix, kx;
+ char *newStr;
+ char *oldStr = lstringRep->string;
+ (void)interp;
+
+ newLen = lstringRep->strlen - numToDelete + numToInsert;
+
+ if (newLen >= lstringRep->allocated) {
+ lstringRep->allocated = newLen+1;
+ newStr = (char*)Tcl_Alloc(lstringRep->allocated);
+ newStr[newLen] = 0;
+ } else {
+ newStr = oldStr;
+ }
+
+ /* Tcl_ListObjReplace replaces zero or more elements of the list
+ * referenced by listPtr with the objc values in the array referenced by
+ * objv.
+ *
+ * If listPtr does not point to a list value, Tcl_ListObjReplace
+ * will attempt to convert it to one; if the conversion fails, it returns
+ * TCL_ERROR and leaves an error message in the interpreter's result value
+ * if interp is not NULL. Otherwise, it returns TCL_OK after replacing the
+ * values.
+ *
+ * * If objv is NULL, no new elements are added.
+ *
+ * * If the argument first is zero or negative, it refers to the first
+ * element.
+ *
+ * * If first is greater than or equal to the number of elements in the
+ * list, then no elements are deleted; the new elements are appended
+ * to the list. count gives the number of elements to replace.
+ *
+ * * If count is zero or negative then no elements are deleted; the new
+ * elements are simply inserted before the one designated by first.
+ * Tcl_ListObjReplace invalidates listPtr's old string representation.
+ *
+ * * The reference counts of any elements inserted from objv are
+ * incremented since the resulting list now refers to them. Similarly,
+ * the reference counts for any replaced values are decremented.
+ */
+
+ // copy 0 to first-1
+ if (newStr != oldStr) {
+ strncpy(newStr, oldStr, first);
+ }
+
+ // move front elements to keep
+ for(x=0, kx=0; x<newLen && kx<first; kx++, x++) {
+ newStr[x] = oldStr[kx];
+ }
+ // Insert new elements into new string
+ for(x=first, ix=0; ix<numToInsert; x++, ix++) {
+ char const *svalue = Tcl_GetString(insertObjs[ix]);
+ newStr[x] = svalue[0];
+ }
+ // Move remaining elements
+ if ((first+numToDelete) < newLen) {
+ for(/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) {
+ newStr[x] = oldStr[kx];
+ }
+ }
+
+ // Terminate new string.
+ newStr[newLen] = 0;
+
+
+ if (oldStr != newStr) {
+ Tcl_Free(oldStr);
+ }
+ lstringRep->string = newStr;
+ lstringRep->strlen = newLen;
+
+ /* Changes made to value, string rep no longer valid */
+ Tcl_InvalidateStringRep(listObj);
+
+ return TCL_OK;
+}
+
+static const Tcl_ObjType *
+my_SetAbstractProc(int ptype)
+{
+ const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */
+ if (4 <= ptype && ptype <= 11) {
+ /* Table has no entries for the slots upto setfromany */
+ typePtr = &lstringTypes[(ptype-3)];
+ }
+ return typePtr;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_NewLStringObj --
+ *
+ * Creates a new lstring Obj using the string value of objv[0]
+ *
+ * Results:
+ * results
+ *
+ * Side effects:
+ * side effects
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+my_NewLStringObj(
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const objv[])
+{
+ LString *lstringRepPtr;
+ Tcl_ObjInternalRep itr;
+ size_t repSize;
+ Tcl_Obj *lstringPtr;
+ const char *string;
+ static const char* procTypeNames[] = {
+ "FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY",
+ "LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS",
+ "SETELEMENT", "REPLACE", NULL
+ };
+ int i = 0;
+ int ptype;
+ const Tcl_ObjType *lstringTypePtr = &lstringTypes[10];
+
+ repSize = sizeof(LString);
+ lstringRepPtr = (LString*)Tcl_Alloc(repSize);
+
+ while (i<objc) {
+ const char *s = Tcl_GetString(objv[i]);
+ if (strcmp(s, "-not")==0) {
+ i++;
+ if (Tcl_GetIndexFromObj(interp, objv[i], procTypeNames, "proctype", 0, &ptype)==TCL_OK) {
+ lstringTypePtr = my_SetAbstractProc(ptype);
+ }
+ } else if (strcmp(s, "--") == 0) {
+ // End of options
+ i++;
+ break;
+ } else {
+ break;
+ }
+ i++;
+ }
+ if (i != objc-1) {
+ Tcl_WrongNumArgs(interp, 0, objv, "lstring string");
+ return NULL;
+ }
+ string = Tcl_GetString(objv[i]);
+
+ lstringRepPtr->strlen = strlen(string);
+ lstringRepPtr->allocated = lstringRepPtr->strlen + 1;
+ lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated);
+ strcpy(lstringRepPtr->string, string);
+ lstringRepPtr->elements = NULL;
+ lstringPtr = Tcl_NewObj();
+ itr.twoPtrValue.ptr1 = lstringRepPtr;
+ itr.twoPtrValue.ptr2 = NULL;
+ Tcl_StoreInternalRep(lstringPtr, lstringTypePtr, &itr);
+ if (lstringRepPtr->strlen > 0) {
+ Tcl_InvalidateStringRep(lstringPtr);
+ } else {
+ Tcl_InitStringRep(lstringPtr, NULL, 0);
+ }
+
+ return lstringPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * freeRep --
+ *
+ * Free the value storage of the lstring Obj.
+ *
+ * Results:
+ * void
+ *
+ * Side effects:
+ * Memory free'd.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+freeRep(Tcl_Obj* lstringObj)
+{
+ LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
+ if (lstringRepPtr->string) {
+ Tcl_Free(lstringRepPtr->string);
+ }
+ if (lstringRepPtr->elements) {
+ Tcl_Obj **objptr = lstringRepPtr->elements;
+ while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) {
+ Tcl_DecrRefCount(*objptr++);
+ }
+ Tcl_Free((char*)lstringRepPtr->elements);
+ lstringRepPtr->elements = NULL;
+ }
+ Tcl_Free((char*)lstringRepPtr);
+ lstringObj->internalRep.twoPtrValue.ptr1 = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * my_LStringGetElements --
+ *
+ * Get the elements of the list in an array.
+ *
+ * Results:
+ * objc, objv return values
+ *
+ * Side effects:
+ * A Tcl_Obj is stored for every element of the abstract list
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int my_LStringGetElements(Tcl_Interp *interp,
+ Tcl_Obj *lstringObj,
+ Tcl_Size *objcptr,
+ Tcl_Obj ***objvptr)
+{
+ LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj **objPtr;
+ char *cptr = lstringRepPtr->string;
+ (void)interp;
+ if (lstringRepPtr->strlen == 0) {
+ *objcptr = 0;
+ *objvptr = NULL;
+ return TCL_OK;
+ }
+ if (lstringRepPtr->elements == NULL) {
+ lstringRepPtr->elements = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * lstringRepPtr->strlen);
+ objPtr=lstringRepPtr->elements;
+ while (objPtr<&lstringRepPtr->elements[lstringRepPtr->strlen]) {
+ *objPtr = Tcl_NewStringObj(cptr++,1);
+ Tcl_IncrRefCount(*objPtr++);
+ }
+ }
+ *objvptr = lstringRepPtr->elements;
+ *objcptr = lstringRepPtr->strlen;
+ return TCL_OK;
+}
+
+/*
+** UpdateStringRep
+*/
+
+static void
+UpdateStringOfLString(Tcl_Obj *objPtr)
+{
+# define LOCAL_SIZE 64
+ int localFlags[LOCAL_SIZE], *flagPtr = NULL;
+ Tcl_ObjType const *typePtr = objPtr->typePtr;
+ char *p;
+ int bytesNeeded = 0;
+ int llen, i;
+
+
+ /*
+ * Handle empty list case first, so rest of the routine is simpler.
+ */
+ llen = typePtr->lengthProc(objPtr);
+ if (llen <= 0) {
+ Tcl_InitStringRep(objPtr, NULL, 0);
+ return;
+ }
+
+ /*
+ * Pass 1: estimate space.
+ */
+ if (llen <= LOCAL_SIZE) {
+ flagPtr = localFlags;
+ } else {
+ /* We know numElems <= LIST_MAX, so this is safe. */
+ flagPtr = (int *) Tcl_Alloc(llen*sizeof(int));
+ }
+ for (bytesNeeded = 0, i = 0; i < llen; i++) {
+ Tcl_Obj *elemObj;
+ const char *elemStr;
+ int elemLen;
+ flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
+ typePtr->indexProc(NULL, objPtr, i, &elemObj);
+ Tcl_IncrRefCount(elemObj);
+ elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
+ /* Note TclScanElement updates flagPtr[i] */
+ bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]);
+ if (bytesNeeded < 0) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ Tcl_DecrRefCount(elemObj);
+ }
+ if (bytesNeeded > INT_MAX - llen + 1) {
+ Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
+ }
+ bytesNeeded += llen; /* Separating spaces and terminating nul */
+
+ /*
+ * Pass 2: generate the string repr.
+ */
+ objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded);
+ p = objPtr->bytes;
+ for (i = 0; i < llen; i++) {
+ Tcl_Obj *elemObj;
+ const char *elemStr;
+ int elemLen;
+ flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
+ typePtr->indexProc(NULL, objPtr, i, &elemObj);
+ Tcl_IncrRefCount(elemObj);
+ elemStr = Tcl_GetStringFromObj(elemObj, &elemLen);
+ p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]);
+ *p++ = ' ';
+ Tcl_DecrRefCount(elemObj);
+ }
+ p[-1] = '\0'; /* Overwrite last space added */
+
+ /* Length of generated string */
+ objPtr->length = p - 1 - objPtr->bytes;
+
+ if (flagPtr != localFlags) {
+ Tcl_Free(flagPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * lLStringObjCmd --
+ *
+ * Script level command that creats an lstring Obj value.
+ *
+ * Results:
+ * Returns and lstring Obj value in the interp results.
+ *
+ * Side effects:
+ * Interp results modified.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+lLStringObjCmd(
+ void *clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj * const objv[])
+{
+ Tcl_Obj *lstringObj;
+
+ (void)clientData;
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "string");
+ return TCL_ERROR;
+ }
+
+ lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]);
+
+ if (lstringObj) {
+ Tcl_SetObjResult(interp, lstringObj);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Lstring_Init --
+ *
+ * DL load init function. Defines the "lstring" command.
+ *
+ * Results:
+ * "lstring" command added to the interp.
+ *
+ * Side effects:
+ * A new command is defined.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int Tcl_ABSListTest_Init(Tcl_Interp *interp) {
+ if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL);
+ Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0");
+ return TCL_OK;
+}
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 6ad45e9..5271a54 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -974,12 +974,13 @@ TestlistobjCmd(
!= TCL_OK) {
return TCL_ERROR;
}
- if (objP->refCount <= 0) {
+ if (objP->refCount < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "Tcl_ListObjIndex returned object with ref count <= 0",
+ "Tcl_ListObjIndex returned object with ref count < 0",
TCL_INDEX_NONE));
/* Keep looping since we are also looping for leaks */
}
+ Tcl_BumpObj(objP);
}
break;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index cf6dc75..218b80f 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -123,17 +123,15 @@ static int FindElement(Tcl_Interp *interp, const char *string,
* is unregistered, so has no need of a setFromAnyProc either.
*/
-static const TclObjTypeWithAbstractList endOffsetType = {
- {"end-offset", /* name */
+static const Tcl_ObjType endOffsetType = {
+ "end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL, /* setFromAnyProc */
- TCL_OBJTYPE_V0_1(
- TclLengthOne
- )}
+ TCL_OBJTYPE_V1(TclLengthOne)
};
-
+
Tcl_Size
TclLengthOne(
TCL_UNUSED(Tcl_Obj *))
@@ -1975,7 +1973,8 @@ Tcl_ConcatObj(
Tcl_Size length;
objPtr = objv[i];
- if (TclListObjIsCanonical(objPtr)) {
+ if (TclListObjIsCanonical(objPtr) ||
+ TclObjTypeHasProc(objPtr,indexProc)) {
continue;
}
(void)Tcl_GetStringFromObj(objPtr, &length);
@@ -1987,7 +1986,8 @@ Tcl_ConcatObj(
resPtr = NULL;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- if (!TclListObjIsCanonical(objPtr)) {
+ if (!TclListObjIsCanonical(objPtr) &&
+ !TclObjTypeHasProc(objPtr,indexProc)) {
continue;
}
if (resPtr) {
@@ -2005,7 +2005,7 @@ Tcl_ConcatObj(
}
} else {
resPtr = TclDuplicatePureObj(
- NULL, objPtr, &tclListType.objType);
+ NULL, objPtr, &tclListType);
if (!resPtr) {
return NULL;
}
@@ -3497,7 +3497,7 @@ GetEndOffsetFromObj(
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
void *cd;
- while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType.objType)) == NULL) {
+ while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjInternalRep ir;
Tcl_Size length;
const char *bytes = Tcl_GetStringFromObj(objPtr, &length);
@@ -3683,7 +3683,7 @@ GetEndOffsetFromObj(
parseOK:
/* Success. Store the new internal rep. */
ir.wideValue = offset;
- Tcl_StoreInternalRep(objPtr, &endOffsetType.objType, &ir);
+ Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir);
}
offset = irPtr->wideValue;
@@ -3835,7 +3835,7 @@ TclIndexEncode(
*/
const Tcl_ObjInternalRep *irPtr =
- TclFetchInternalRep(objPtr, &endOffsetType.objType);
+ TclFetchInternalRep(objPtr, &endOffsetType);
if (irPtr && irPtr->wideValue >= 0) {
/*
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 32ee631..dcb4db4 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -245,7 +245,8 @@ static Tcl_DupInternalRepProc DupParsedVarName;
static const Tcl_ObjType localVarNameType = {
"localVarName",
- FreeLocalVarName, DupLocalVarName, NULL, NULL, TCL_OBJTYPE_V0
+ FreeLocalVarName, DupLocalVarName, NULL, NULL,
+ TCL_OBJTYPE_V0
};
#define LocalSetInternalRep(objPtr, index, namePtr) \
@@ -268,7 +269,8 @@ static const Tcl_ObjType localVarNameType = {
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
- FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0
+ FreeParsedVarName, DupParsedVarName, NULL, NULL,
+ TCL_OBJTYPE_V0
};
#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \
@@ -3097,7 +3099,7 @@ ArrayForNRCmd(
* loop) don't vanish.
*/
- varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType.objType);
+ varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType);
if (!varListObj) {
return TCL_ERROR;
}
@@ -4074,7 +4076,7 @@ ArraySetCmd(
*/
copyListObj =
- TclDuplicatePureObj(interp, arrayElemObj, &tclListType.objType);
+ TclDuplicatePureObj(interp, arrayElemObj, &tclListType);
if (!copyListObj) {
return TCL_ERROR;
}
generated by cgit v0.12 at 2024-11-16 09:54:17 (GMT)