summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorgriffin <briang42@easystreet.net>2022-08-30 17:56:36 (GMT)
committergriffin <briang42@easystreet.net>2022-08-30 17:56:36 (GMT)
commitd06b33cd9433fa01e505824932e316301348a970 (patch)
treee1c8414aa6f966cf5f061b5de23097d447f0a113 /generic
parent603b76f9107442e86b4f3bfd8c506097ca661fa6 (diff)
parent8c034cf9ce62c27025614676e999df1db4e75686 (diff)
downloadtcl-d06b33cd9433fa01e505824932e316301348a970.zip
tcl-d06b33cd9433fa01e505824932e316301348a970.tar.gz
tcl-d06b33cd9433fa01e505824932e316301348a970.tar.bz2
Sync with core-8-branch listObj changes.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCmdIL.c45
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclInt.decls11
-rw-r--r--generic/tclInt.h236
-rw-r--r--generic/tclIntDecls.h12
-rw-r--r--generic/tclInterp.c14
-rw-r--r--generic/tclListObj.c3769
-rw-r--r--generic/tclStubInit.c2
-rw-r--r--generic/tclTest.c154
9 files changed, 2961 insertions, 1286 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index bcee3ca..fa8d1a5 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -19,8 +19,9 @@
#include "tclInt.h"
#include "tclRegexp.h"
-#include <math.h>
#include "tclArithSeries.h"
+#include <math.h>
+#include <assert.h>
/*
* During execution of the "lsort" command, structures of the following type
@@ -2956,10 +2957,15 @@ Tcl_LrepeatObjCmd(
listPtr = Tcl_NewListObj(totalElems, NULL);
if (totalElems) {
- List *listRepPtr = ListRepPtr(listPtr);
-
- listRepPtr->elemCount = elementCount*objc;
- dataArray = listRepPtr->elements;
+ ListRep listRep;
+ ListObjGetRep(listPtr, &listRep);
+ dataArray = ListRepElementsBase(&listRep);
+ listRep.storePtr->numUsed = totalElems;
+ if (listRep.spanPtr) {
+ /* Future proofing in case Tcl_NewListObj returns a span */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
}
/*
@@ -3150,14 +3156,21 @@ Tcl_LreverseObjCmd(
}
if (Tcl_IsShared(objv[1])
- || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */
+ || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */
Tcl_Obj *resultObj, **dataArray;
- List *listRepPtr;
+ ListRep listRep;
resultObj = Tcl_NewListObj(elemc, NULL);
- listRepPtr = ListRepPtr(resultObj);
- listRepPtr->elemCount = elemc;
- dataArray = listRepPtr->elements;
+
+ /* Modify the internal rep in-place */
+ ListObjGetRep(resultObj, &listRep);
+ listRep.storePtr->numUsed = elemc;
+ dataArray = ListRepElementsBase(&listRep);
+ if (listRep.spanPtr) {
+ /* Future proofing */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
for (i=0,j=elemc-1 ; i<elemc ; i++,j--) {
dataArray[j] = elemv[i];
@@ -4883,12 +4896,12 @@ Tcl_LsortObjCmd(
*/
if (sortInfo.resultCode == TCL_OK) {
- List *listRepPtr;
+ ListRep listRep;
Tcl_Obj **newArray, *objPtr;
resultPtr = Tcl_NewListObj(sortInfo.numElements * groupSize, NULL);
- listRepPtr = ListRepPtr(resultPtr);
- newArray = listRepPtr->elements;
+ ListObjGetRep(resultPtr, &listRep);
+ newArray = ListRepElementsBase(&listRep);
if (group) {
for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) {
idx = elementPtr->payload.index;
@@ -4917,7 +4930,11 @@ Tcl_LsortObjCmd(
Tcl_IncrRefCount(objPtr);
}
}
- listRepPtr->elemCount = i;
+ listRep.storePtr->numUsed = i;
+ if (listRep.spanPtr) {
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
Tcl_SetObjResult(interp, resultPtr);
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 353926c..d56b994 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3517,7 +3517,7 @@ TEBCresume(
varPtr->value.objPtr = objResultPtr = newValue;
Tcl_IncrRefCount(newValue);
}
- if (Tcl_ListObjReplace(interp, objResultPtr, len, 0, objc, objv)
+ if (TclListObjAppendElements(interp, objResultPtr, objc, objv)
!= TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -3575,7 +3575,7 @@ TEBCresume(
} else {
valueToAssign = objResultPtr;
}
- if (Tcl_ListObjReplace(interp, valueToAssign, len, 0,
+ if (TclListObjAppendElements(interp, valueToAssign,
objc, objv) != TCL_OK) {
if (createdNewObj) {
TclDecrRefCount(valueToAssign);
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 5a9f4f0..7828872 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1039,6 +1039,17 @@ declare 258 {
declare 259 {
void TclUnusedStubEntry(void)
}
+
+# TIP 625: for unit testing - create list objects with span
+declare 260 {
+ Tcl_Obj *TclListTestObj(int length, int leadingSpace, int endSpace)
+}
+
+# TIP 625: for unit testing - check list invariants
+declare 261 {
+ void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
+}
+
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 168ecbf..f8820c8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2437,59 +2437,211 @@ typedef enum TclEolTranslation {
#define TCL_INVOKE_NO_TRACEBACK (1<<2)
/*
- * The structure used as the internal representation of Tcl list objects. This
- * struct is grown (reallocated and copied) as necessary to hold all the
- * list's element pointers. The struct might contain more slots than currently
- * used to hold all element pointers. This is done to make append operations
- * faster.
+ * ListSizeT is the type for holding list element counts. It's defined
+ * simplify sharing source between Tcl8 and Tcl9.
*/
+#if TCL_MAJOR_VERSION > 8
-typedef struct List {
- int refCount;
- int maxElemCount; /* Total number of element array slots. */
- int elemCount; /* Current number of list elements. */
- int canonicalFlag; /* Set if the string representation was
- * derived from the list representation. May
- * be ignored if there is no string rep at
- * all.*/
- Tcl_Obj *elements[TCLFLEXARRAY]; /* First list element; the struct is grown to
- * accommodate all elements. */
-} List;
+typedef size_t ListSizeT;
+
+/*
+ * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed
+ * between values of the ListSizeT type so limit the range to signed
+ */
+#define ListSizeT_MAX ((ListSizeT)PTRDIFF_MAX)
-#define LIST_MAX \
- ((int)(((size_t)UINT_MAX - offsetof(List, elements))/sizeof(Tcl_Obj *)))
-#define LIST_SIZE(numElems) \
- (TCL_HASH_TYPE)(offsetof(List, elements) + ((numElems) * sizeof(Tcl_Obj *)))
+#else
+
+typedef int ListSizeT;
+#define ListSizeT_MAX INT_MAX
+
+#endif
/*
- * Macro used to get the elements of a list object.
+ * ListStore --
+ *
+ * A Tcl list's internal representation is defined through three structures.
+ *
+ * A ListStore struct is a structure that includes a variable size array that
+ * serves as storage for a Tcl list. A contiguous sequence of slots in the
+ * array, the "in-use" area, holds valid pointers to Tcl_Obj values that
+ * belong to one or more Tcl lists. The unused slots before and after these
+ * are free slots that may be used to prepend and append without having to
+ * reallocate the struct. The ListStore may be shared amongst multiple lists
+ * and reference counted.
+ *
+ * A ListSpan struct defines a sequence of slots within a ListStore. This sequence
+ * always lies within the "in-use" area of the ListStore. Like ListStore, the
+ * structure may be shared among multiple lists and is reference counted.
+ *
+ * A ListRep struct holds the internal representation of a Tcl list as stored
+ * in a Tcl_Obj. It is composed of a ListStore and a ListSpan that together
+ * define the content of the list. The ListSpan specifies the range of slots
+ * within the ListStore that hold elements for this list. The ListSpan is
+ * optional in which case the list includes all the "in-use" slots of the
+ * ListStore.
+ *
*/
+typedef struct ListStore {
+ ListSizeT firstUsed; /* Index of first slot in use within slots[] */
+ ListSizeT numUsed; /* Number of slots in use (starting firstUsed) */
+ ListSizeT numAllocated; /* Total number of slots[] array slots. */
+ int refCount; /* Number of references to this instance */
+ int flags; /* LISTSTORE_* flags */
+ Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */
+} ListStore;
+
+#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this
+ store have their string representation
+ derived from the list representation */
+
+/* Max number of elements that can be contained in a list */
+#define LIST_MAX \
+ ((ListSizeT)(((size_t)ListSizeT_MAX - offsetof(ListStore, slots)) \
+ / sizeof(Tcl_Obj *)))
+/* Memory size needed for a ListStore to hold numSlots_ elements */
+#define LIST_SIZE(numSlots_) \
+ ((int)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *))))
+
+/*
+ * ListSpan --
+ * See comments above for ListStore
+ */
+typedef struct ListSpan {
+ ListSizeT spanStart; /* Starting index of the span */
+ ListSizeT spanLength; /* Number of elements in the span */
+ int refCount; /* Count of references to this span record */
+} ListSpan;
+#ifndef LIST_SPAN_THRESHOLD /* May be set on build line */
+#define LIST_SPAN_THRESHOLD 101
+#endif
-#define ListRepPtr(listPtr) \
- ((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
+/*
+ * ListRep --
+ * See comments above for ListStore
+ */
+typedef struct ListRep {
+ ListStore *storePtr;/* element array shared amongst different lists */
+ ListSpan *spanPtr; /* If not NULL, the span holds the range of slots
+ within *storePtr that contain this list elements. */
+} ListRep;
-#define ListObjGetElements(listPtr, objc, objv) \
- ((objv) = ListRepPtr(listPtr)->elements, \
- (objc) = ListRepPtr(listPtr)->elemCount)
+/*
+ * Macros used to get access list internal representations.
+ *
+ * Naming conventions:
+ * ListRep* - expect a pointer to a valid ListRep
+ * ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to
+ * be a list (tclListType). Will crash otherwise.
+ * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not
+ * be tclListType. These will convert as needed and return error if
+ * conversion not possible.
+ */
+
+/* Returns the starting slot for this listRep in the contained ListStore */
+#define ListRepStart(listRepPtr_) \
+ ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanStart \
+ : (listRepPtr_)->storePtr->firstUsed)
+
+/* Returns the number of elements in this listRep */
+#define ListRepLength(listRepPtr_) \
+ ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanLength \
+ : (listRepPtr_)->storePtr->numUsed)
+
+/* Returns a pointer to the first slot containing this ListRep elements */
+#define ListRepElementsBase(listRepPtr_) \
+ (&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)])
+
+/* Stores the number of elements and base address of the element array */
+#define ListRepElements(listRepPtr_, objc_, objv_) \
+ (((objv_) = ListRepElementsBase(listRepPtr_)), \
+ ((objc_) = ListRepLength(listRepPtr_)))
+
+/* Returns 1/0 whether the ListRep's ListStore is shared. */
+#define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1)
+
+/* Returns a pointer to the ListStore component */
+#define ListObjStorePtr(listObj_) \
+ ((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1))
+
+/* Returns a pointer to the ListSpan component */
+#define ListObjSpanPtr(listObj_) \
+ ((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2))
+
+/* Returns the ListRep internal representaton in a Tcl_Obj */
+#define ListObjGetRep(listObj_, listRepPtr_) \
+ do { \
+ (listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \
+ (listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \
+ } while (0)
-#define ListObjLength(listPtr, len) \
- ((len) = ListRepPtr(listPtr)->elemCount)
+/* Returns the length of the list */
+#define ListObjLength(listObj_, len_) \
+ ((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \
+ : ListObjStorePtr(listObj_)->numUsed)
-#define ListObjIsCanonical(listPtr) \
- (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag)
+/* Returns the starting slot index of this list's elements in the ListStore */
+#define ListObjStart(listObj_) \
+ (ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \
+ : ListObjStorePtr(listObj_)->firstUsed)
-#define TclListObjGetElementsM(interp, listPtr, objcPtr, objvPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\
- : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)))
+/* Stores the element count and base address of this list's elements */
+#define ListObjGetElements(listObj_, objc_, objv_) \
+ (((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \
+ (ListObjLength(listObj_, (objc_))))
-#define TclListObjLengthM(interp, listPtr, lenPtr) \
- (((listPtr)->typePtr == &tclListType) \
- ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
- : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))
+/*
+ * Returns 1/0 whether the internal representation (not the Tcl_Obj itself)
+ * is shared. Note by intent this only checks for sharing of ListStore,
+ * not spans.
+ */
+#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1)
-#define TclListObjIsCanonical(listPtr) \
- (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)
+/*
+ * Certain commands like concat are optimized if an existing string
+ * representation of a list object is known to be in canonical format (i.e.
+ * generated from the list representation). There are three conditions when
+ * this will be the case:
+ * (1) No string representation exists which means it will obviously have
+ * to be generated from the list representation when needed
+ * (2) The ListStore flags is marked canonical. This is done at the time
+ * the string representation is generated from the list IF the list
+ * representation does not have a span (see comments in UpdateStringOfList).
+ * (3) The list representation does not have a span component. This is
+ * because list Tcl_Obj's with spans are always created from existing lists
+ * and never from strings (see SetListFromAny) and thus their string
+ * representation will always be canonical.
+ */
+#define ListObjIsCanonical(listObj_) \
+ (((listObj_)->bytes == NULL) \
+ || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \
+ || ListObjSpanPtr(listObj_) != NULL)
+
+/*
+ * Converts the Tcl_Obj to a list if it isn't one and stores the element
+ * count and base address of this list's elements in objcPtr_ and objvPtr_.
+ * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be
+ * converted to a list.
+ */
+#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \
+ (((listObj_)->typePtr == &tclListType) \
+ ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \
+ TCL_OK) \
+ : Tcl_ListObjGetElements( \
+ (interp_), (listObj_), (objcPtr_), (objvPtr_)))
+
+/*
+ * Converts the Tcl_Obj to a list if it isn't one and stores the element
+ * count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the
+ * Tcl_Obj cannot be converted to a list.
+ */
+#define TclListObjLengthM(interp_, listObj_, lenPtr_) \
+ (((listObj_)->typePtr == &tclListType) \
+ ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \
+ : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_)))
+
+#define TclListObjIsCanonical(listObj_) \
+ (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0)
/*
* Modes for collecting (or not) in the implementations of TclNRForeachCmd,
@@ -3108,6 +3260,9 @@ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n,
MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx,
int toIdx);
+MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp,
+ Tcl_Obj *toObj, int elemCount,
+ Tcl_Obj *const elemObjv[]);
MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
@@ -5227,6 +5382,7 @@ typedef struct NRE_callback {
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
+
#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
#define Tcl_AttemptAlloc(size) TclpAlloc(size)
#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size))
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 33b6883..5d728a0 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -658,6 +658,12 @@ EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* 259 */
EXTERN void TclUnusedStubEntry(void);
+/* 260 */
+EXTERN Tcl_Obj * TclListTestObj(int length, int leadingSpace,
+ int endSpace);
+/* 261 */
+EXTERN void TclListObjValidate(Tcl_Interp *interp,
+ Tcl_Obj *listObj);
typedef struct TclIntStubs {
int magic;
@@ -923,6 +929,8 @@ typedef struct TclIntStubs {
void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */
Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
void (*tclUnusedStubEntry) (void); /* 259 */
+ Tcl_Obj * (*tclListTestObj) (int length, int leadingSpace, int endSpace); /* 260 */
+ void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
@@ -1370,6 +1378,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */
#define TclUnusedStubEntry \
(tclIntStubsPtr->tclUnusedStubEntry) /* 259 */
+#define TclListTestObj \
+ (tclIntStubsPtr->tclListTestObj) /* 260 */
+#define TclListObjValidate \
+ (tclIntStubsPtr->tclListObjValidate) /* 261 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 4ce2f31..d51b289 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -12,6 +12,7 @@
*/
#include "tclInt.h"
+#include <assert.h>
/*
* A pointer to a string that holds an initialization script that if non-NULL
@@ -1822,7 +1823,7 @@ AliasNRCmd(
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
- List *listRep;
+ ListRep listRep;
int flags = TCL_EVAL_INVOKE;
/*
@@ -1834,10 +1835,15 @@ AliasNRCmd(
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
+ /* TODO - encapsulate this into tclListObj.c */
listPtr = Tcl_NewListObj(cmdc, NULL);
- listRep = ListRepPtr(listPtr);
- listRep->elemCount = cmdc;
- cmdv = listRep->elements;
+ ListObjGetRep(listPtr, &listRep);
+ cmdv = ListRepElementsBase(&listRep);
+ listRep.storePtr->numUsed = cmdc;
+ if (listRep.spanPtr) {
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ }
prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 74b3a29..b18e556 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -3,9 +3,7 @@
*
* This file contains functions that implement the Tcl list object type.
*
- * Copyright © 1995-1997 Sun Microsystems, Inc.
- * Copyright © 1998 Scriptics Corporation.
- * Copyright © 2001 Kevin B. Kenny. All rights reserved.
+ * Copyright © 2022 Ashok P. Nadkarni. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -16,28 +14,140 @@
#include "tclArithSeries.h"
/*
- * Prototypes for functions defined later in this file:
+ * TODO - memmove is fast. Measure at what size we should prefer memmove
+ * (for unshared objects only) in lieu of range operations. On the other
+ * hand, more cache dirtied?
*/
-static List * AttemptNewList(Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
-static List * NewListInternalRep(int objc, Tcl_Obj *const objv[], int p);
-static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
-static void FreeListInternalRep(Tcl_Obj *listPtr);
-static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static void UpdateStringOfList(Tcl_Obj *listPtr);
+/*
+ * Macros for validation and bug checking.
+ */
+
+/*
+ * Control whether asserts are enabled. Always enable in debug builds. In non-debug
+ * builds, can be set with cdebug="-DENABLE_LIST_ASSERTS" on the nmake command line.
+ */
+#ifdef ENABLE_LIST_ASSERTS
+# ifdef NDEBUG
+# undef NDEBUG /* Activate assert() macro */
+# endif
+#else
+# ifndef NDEBUG
+# define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */
+# endif
+#endif
+
+#ifdef ENABLE_LIST_ASSERTS
+
+#define LIST_ASSERT(cond_) assert(cond_) /* TODO - is there a Tcl-specific one? */
+/*
+ * LIST_INDEX_ASSERT is to catch errors with negative indices and counts
+ * being passed AFTER validation. On Tcl9 length types are unsigned hence
+ * the checks against LIST_MAX. On Tcl8 length types are signed hence the
+ * also checks against 0.
+ */
+#define LIST_INDEX_ASSERT(idxarg_) \
+ do { \
+ ListSizeT idx_ = (idxarg_); /* To guard against ++ etc. */ \
+ LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \
+ } while (0)
+/* Ditto for counts except upper limit is different */
+#define LIST_COUNT_ASSERT(countarg_) \
+ do { \
+ ListSizeT count_ = (countarg_); /* To guard against ++ etc. */ \
+ LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \
+ } while (0)
+
+#else
+
+#define LIST_ASSERT(cond_) ((void) 0)
+#define LIST_INDEX_ASSERT(idx_) ((void) 0)
+#define LIST_COUNT_ASSERT(count_) ((void) 0)
+
+#endif
+
+/* Checks for when caller should have already converted to internal list type */
+#define LIST_ASSERT_TYPE(listObj_) \
+ LIST_ASSERT((listObj_)->typePtr == &tclListType);
+
+
+/*
+ * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the
+ * command line), the entire list internal representation is checked for
+ * inconsistencies. This has a non-trivial cost so has to be separately
+ * enabled and not part of assertions checking. However, the test suite does
+ * invoke ListRepValidate directly even without ENABLE_LIST_INVARIANTS.
+ */
+#ifdef ENABLE_LIST_INVARIANTS
+#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_, __FILE__, __LINE__)
+#else
+#define LISTREP_CHECK(listRepPtr_) (void) 0
+#endif
+
+/*
+ * Flags used for controlling behavior of allocation of list
+ * internal representations.
+ *
+ * If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if
+ * list is too large or memory cannot be allocated. Without the flag
+ * a NULL pointer is returned.
+ *
+ * The LISTREP_SPACE_FAVOR_NONE, LISTREP_SPACE_FAVOR_FRONT,
+ * LISTREP_SPACE_FAVOR_BACK, LISTREP_SPACE_ONLY_BACK flags are used to
+ * control additional space when allocating.
+ * - If none of these flags is present, the exact space requested is
+ * allocated, nothing more.
+ * - Otherwise, if only LISTREP_FAVOR_FRONT is present, extra space is
+ * allocated with more towards the front.
+ * - Conversely, if only LISTREP_FAVOR_BACK is present extra space is allocated
+ * with more to the back.
+ * - If both flags are present (LISTREP_SPACE_FAVOR_NONE), the extra space
+ * is equally apportioned.
+ * - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at
+ * the back.
+ */
+#define LISTREP_PANIC_ON_FAIL 0x00000001
+#define LISTREP_SPACE_FAVOR_FRONT 0x00000002
+#define LISTREP_SPACE_FAVOR_BACK 0x00000004
+#define LISTREP_SPACE_ONLY_BACK 0x00000008
+#define LISTREP_SPACE_FAVOR_NONE \
+ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK)
+#define LISTREP_SPACE_FLAGS \
+ (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \
+ | LISTREP_SPACE_ONLY_BACK)
+
+/*
+ * Prototypes for non-inline static functions defined later in this file:
+ */
+static int MemoryAllocationError(Tcl_Interp *, size_t size);
+static int ListLimitExceededError(Tcl_Interp *);
+static ListStore *ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags);
+static int ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *);
+static int ListRepInitAttempt(Tcl_Interp *,
+ ListSizeT objc,
+ Tcl_Obj *const objv[],
+ ListRep *);
+static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags);
+static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr);
+static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr);
+static void ListRepRange(ListRep *srcRepPtr,
+ ListSizeT rangeStart,
+ ListSizeT rangeEnd,
+ int preserveSrcRep,
+ ListRep *rangeRepPtr);
+static ListStore *ListStoreReallocate(ListStore *storePtr, ListSizeT numSlots);
+static void ListRepValidate(const ListRep *repPtr, const char *file,
+ int lineNum);
+static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
+static void FreeListInternalRep(Tcl_Obj *listPtr);
+static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static void UpdateStringOfList(Tcl_Obj *listPtr);
/*
* The structure below defines the list Tcl object type by means of functions
* that can be invoked by generic object code.
*
- * The internal representation of a list object is a two-pointer
- * representation. The first pointer designates a List structure that contains
- * an array of pointers to the element objects, together with integers that
- * represent the current element count and the allocated size of the array.
- * The second pointer is normally NULL; during execution of functions in this
- * file that operate on nested sublists, it is occasionally used as working
- * storage to avoid an auxiliary stack.
+ * The internal representation of a list object is ListRep defined in tcl.h.
*/
const Tcl_ObjType tclListType = {
@@ -49,142 +159,924 @@ const Tcl_ObjType tclListType = {
};
/* Macros to manipulate the List internal rep */
+#define ListRepIncrRefs(repPtr_) \
+ do { \
+ (repPtr_)->storePtr->refCount++; \
+ if ((repPtr_)->spanPtr) \
+ (repPtr_)->spanPtr->refCount++; \
+ } while (0)
+
+/* Returns number of free unused slots at the back of the ListRep's ListStore */
+#define ListRepNumFreeTail(repPtr_) \
+ ((repPtr_)->storePtr->numAllocated \
+ - ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed))
+
+/* Returns number of free unused slots at the front of the ListRep's ListStore */
+#define ListRepNumFreeHead(repPtr_) ((repPtr_)->storePtr->firstUsed)
-#define ListSetInternalRep(objPtr, listRepPtr) \
- do { \
- Tcl_ObjInternalRep ir; \
- ir.twoPtrValue.ptr1 = (listRepPtr); \
- ir.twoPtrValue.ptr2 = NULL; \
- (listRepPtr)->refCount++; \
- Tcl_StoreInternalRep((objPtr), &tclListType, &ir); \
+/* Returns a pointer to the slot corresponding to list index listIdx_ */
+#define ListRepSlotPtr(repPtr_, listIdx_) \
+ (&(repPtr_)->storePtr->slots[ListRepStart(repPtr_) + (listIdx_)])
+
+/*
+ * Macros to replace the internal representation in a Tcl_Obj. There are
+ * subtle differences in each so make sure to use the right one to avoid
+ * memory leaks, access to freed memory and the like.
+ *
+ * ListObjStompRep - assumes the Tcl_Obj internal representation can be
+ * overwritten AND that the passed ListRep already has reference counts that
+ * include the reference from the Tcl_Obj. Basically just copies the pointers
+ * and sets the internal Tcl_Obj type to list
+ *
+ * ListObjOverwriteRep - like ListObjOverwriteRep but additionally
+ * increments reference counts on the passed ListRep. Generally used when
+ * the string representation of the Tcl_Obj is not to be modified.
+ *
+ * ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally
+ * assumes the Tcl_Obj internal rep is valid (and possibly even same as
+ * passed ListRep) and frees it first. Additionally invalidates the string
+ * representation. Generally used when modifying a Tcl_Obj value.
+ */
+#define ListObjStompRep(objPtr_, repPtr_) \
+ do { \
+ (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \
+ (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \
+ (objPtr_)->typePtr = &tclListType; \
} while (0)
-#define ListGetInternalRep(objPtr, listRepPtr) \
- do { \
- const Tcl_ObjInternalRep *irPtr; \
- irPtr = TclFetchInternalRep((objPtr), &tclListType); \
- (listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \
+#define ListObjOverwriteRep(objPtr_, repPtr_) \
+ do { \
+ ListRepIncrRefs(repPtr_); \
+ ListObjStompRep(objPtr_, repPtr_); \
} while (0)
-#define ListResetInternalRep(objPtr, listRepPtr) \
- TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr)
+#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \
+ do { \
+ /* Note order important, don't use ListObjOverwriteRep! */ \
+ ListRepIncrRefs(repPtr_); \
+ TclFreeInternalRep(objPtr_); \
+ TclInvalidateStringRep(objPtr_); \
+ ListObjStompRep(objPtr_, repPtr_); \
+ } while (0)
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListSpanNew --
+ *
+ * Allocates and initializes memory for a new ListSpan. The reference
+ * count on the returned struct is 0.
+ *
+ * Results:
+ * Non-NULL pointer to the allocated ListSpan.
+ *
+ * Side effects:
+ * The function will panic on memory allocation failure.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline ListSpan *
+ListSpanNew(
+ ListSizeT firstSlot, /* Starting slot index of the span */
+ ListSizeT numSlots) /* Number of slots covered by the span */
+{
+ ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr));
+ spanPtr->refCount = 0;
+ spanPtr->spanStart = firstSlot;
+ spanPtr->spanLength = numSlots;
+ return spanPtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListSpanIncrRefs --
+ *
+ * Increments the reference count on the spanPtr
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The obvious.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListSpanIncrRefs(ListSpan *spanPtr)
+{
+ spanPtr->refCount += 1;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListSpanDecrRefs --
+ *
+ * Decrements the reference count on a span, freeing the memory if
+ * it drops to zero or less.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The memory may be freed.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListSpanDecrRefs(ListSpan *spanPtr)
+{
+ if (spanPtr->refCount <= 1) {
+ ckfree(spanPtr);
+ } else {
+ spanPtr->refCount -= 1;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListSpanMerited --
+ *
+ * Creation of a new list may sometimes be done as a span on existing
+ * storage instead of allocating new. The tradeoff is that if the
+ * original list is released, the new span-based list may hold on to
+ * more memory than desired. This function implements heuristics for
+ * deciding which option is better.
+ *
+ * Results:
+ * Returns non-0 if a span-based list is likely to be more optimal
+ * and 0 if not.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline int
+ListSpanMerited(
+ ListSizeT length, /* Length of the proposed span */
+ ListSizeT usedStorageLength, /* Number of slots currently in used */
+ ListSizeT allocatedStorageLength) /* Length of the currently allocation */
+{
+ /*
+ TODO
+ - heuristics thresholds need to be determined
+ - currently, information about the sharing (ref count) of existing
+ storage is not passed. Perhaps it should be. For example if the
+ existing storage has a "large" ref count, then it might make sense
+ to do even a small span.
+ */
-#ifndef TCL_MIN_ELEMENT_GROWTH
-#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
-#endif
+ if (length < LIST_SPAN_THRESHOLD) {
+ return 0;/* No span for small lists */
+ }
+ if (length < (allocatedStorageLength / 2 - allocatedStorageLength / 8)) {
+ return 0; /* No span if less than 3/8 of allocation */
+ }
+ if (length < usedStorageLength / 2) {
+ return 0; /* No span if less than half current storage */
+ }
+
+ return 1;
+}
/*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*
- * NewListInternalRep --
+ * ListStoreUpSize --
*
- * Creates a 'List' structure with space for 'objc' elements. 'objc' must
- * be > 0. If 'objv' is not NULL, The list is initialized with first
- * 'objc' values in that array. Otherwise the list is initialized to have
- * 0 elements, with space to add 'objc' more. Flag value 'p' indicates
- * how to behave on failure.
+ * For reasons of efficiency, extra space is allocated for a ListStore
+ * compared to what was requested. This function calculates how many
+ * slots should actually be allocated for a given request size.
*
- * Value
+ * Results:
+ * Number of slots to allocate.
*
- * A new 'List' structure with refCount 0. If some failure
- * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic'
- * is called if it is not.
+ * Side effects:
+ * None.
*
- * Effect
+ *------------------------------------------------------------------------
+ */
+static inline ListSizeT
+ListStoreUpSize(ListSizeT numSlotsRequested) {
+ /* TODO -how much extra? May be double only for smaller requests? */
+ return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested
+ : LIST_MAX;
+}
+
+/*
+ *------------------------------------------------------------------------
*
- * The refCount of each value in 'objv' is incremented as it is added
- * to the list.
+ * ListRepFreeUnreferenced --
*
- *----------------------------------------------------------------------
+ * Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks
+ * before calling it.
+ *
+ * IMPORTANT: this function must not be called on an internal
+ * representation of a Tcl_Obj that is itself shared.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See comments for ListRepUnsharedFreeUnreferenced.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListRepFreeUnreferenced(const ListRep *repPtr)
+{
+ if (! ListRepIsShared(repPtr) && repPtr->spanPtr) {
+ /* T:listrep-1.5.1 */
+ ListRepUnsharedFreeUnreferenced(repPtr);
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ObjArrayIncrRefs --
+ *
+ * Increments the reference counts for Tcl_Obj's in a subarray.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * As above.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ObjArrayIncrRefs(
+ Tcl_Obj * const *objv, /* Pointer to the array */
+ ListSizeT startIdx, /* Starting index of subarray within objv */
+ ListSizeT count) /* Number of elements in the subarray */
+{
+ Tcl_Obj * const *end;
+ LIST_INDEX_ASSERT(startIdx);
+ LIST_COUNT_ASSERT(count);
+ objv += startIdx;
+ end = objv + count;
+ while (objv < end) {
+ Tcl_IncrRefCount(*objv);
+ ++objv;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ObjArrayDecrRefs --
+ *
+ * Decrements the reference counts for Tcl_Obj's in a subarray.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * As above.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ObjArrayDecrRefs(
+ Tcl_Obj * const *objv, /* Pointer to the array */
+ ListSizeT startIdx, /* Starting index of subarray within objv */
+ ListSizeT count) /* Number of elements in the subarray */
+{
+ Tcl_Obj * const *end;
+ LIST_INDEX_ASSERT(startIdx);
+ LIST_COUNT_ASSERT(count);
+ objv += startIdx;
+ end = objv + count;
+ while (objv < end) {
+ Tcl_DecrRefCount(*objv);
+ ++objv;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ObjArrayCopy --
+ *
+ * Copies an array of Tcl_Obj* pointers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Reference counts on copied Tcl_Obj's are incremented.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ObjArrayCopy(
+ Tcl_Obj **to, /* Destination */
+ ListSizeT count, /* Number of pointers to copy */
+ Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */
+{
+ Tcl_Obj **end;
+ LIST_COUNT_ASSERT(count);
+ end = to + count;
+ /* TODO - would memmove followed by separate IncrRef loop be faster? */
+ while (to < end) {
+ Tcl_IncrRefCount(*from);
+ *to++ = *from++;
+ }
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * MemoryAllocationError --
+ *
+ * Generates a memory allocation failure error.
+ *
+ * Results:
+ * Always TCL_ERROR.
+ *
+ * Side effects:
+ * Error message and code are stored in the interpreter if not NULL.
+ *
+ *------------------------------------------------------------------------
+ */
+static int
+MemoryAllocationError(
+ Tcl_Interp *interp, /* Interpreter for error message. May be NULL */
+ size_t size) /* Size of attempted allocation that failed */
+{
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_ObjPrintf(
+ "list construction failed: unable to alloc %" TCL_LL_MODIFIER
+ "u bytes",
+ (Tcl_WideInt)size));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListLimitExceeded --
+ *
+ * Generates an error for exceeding maximum list size.
+ *
+ * Results:
+ * Always TCL_ERROR.
+ *
+ * Side effects:
+ * Error message and code are stored in the interpreter if not NULL.
+ *
+ *------------------------------------------------------------------------
*/
+static int
+ListLimitExceededError(Tcl_Interp *interp)
+{
+ if (interp != NULL) {
+ Tcl_SetObjResult(
+ interp,
+ Tcl_NewStringObj("max length of a Tcl list exceeded", -1));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedShiftDown --
+ *
+ * Shifts the "in-use" contents in the ListStore for a ListRep down
+ * by the given number of slots. The ListStore must be unshared and
+ * the free space at the front of the storage area must be big enough.
+ * It is the caller's responsibility to check.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The contents of the ListRep's ListStore area are shifted down in the
+ * storage area. The ListRep's ListSpan is updated accordingly.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount)
+{
+ ListStore *storePtr;
-static List *
-NewListInternalRep(
- int objc,
- Tcl_Obj *const objv[],
- int p)
+ LISTREP_CHECK(repPtr);
+ LIST_ASSERT(!ListRepIsShared(repPtr));
+
+ storePtr = repPtr->storePtr;
+
+ LIST_COUNT_ASSERT(shiftCount);
+ LIST_ASSERT(storePtr->firstUsed >= shiftCount);
+
+ memmove(&storePtr->slots[storePtr->firstUsed - shiftCount],
+ &storePtr->slots[storePtr->firstUsed],
+ storePtr->numUsed * sizeof(Tcl_Obj *));
+ storePtr->firstUsed -= shiftCount;
+ if (repPtr->spanPtr) {
+ repPtr->spanPtr->spanStart -= shiftCount;
+ LIST_ASSERT(repPtr->spanPtr->spanLength == storePtr->numUsed);
+ } else {
+ /*
+ * If there was no span, firstUsed must have been 0 (Invariant)
+ * AND shiftCount must have been 0 (<= firstUsed on call)
+ * In other words, this would have been a no-op
+ */
+
+ LIST_ASSERT(storePtr->firstUsed == 0);
+ LIST_ASSERT(shiftCount == 0);
+ }
+
+ LISTREP_CHECK(repPtr);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedShiftUp --
+ *
+ * Shifts the "in-use" contents in the ListStore for a ListRep up
+ * by the given number of slots. The ListStore must be unshared and
+ * the free space at the back of the storage area must be big enough.
+ * It is the caller's responsibility to check.
+ * TODO - this function is not currently used.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The contents of the ListRep's ListStore area are shifted up in the
+ * storage area. The ListRep's ListSpan is updated accordingly.
+ *
+ *------------------------------------------------------------------------
+ */
+static inline void
+ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount)
{
- List *listRepPtr;
+ ListStore *storePtr;
+
+ LISTREP_CHECK(repPtr);
+ LIST_ASSERT(!ListRepIsShared(repPtr));
+ LIST_COUNT_ASSERT(shiftCount);
+
+ storePtr = repPtr->storePtr;
+ LIST_ASSERT((storePtr->firstUsed + storePtr->numUsed + shiftCount)
+ <= storePtr->numAllocated);
+
+ memmove(&storePtr->slots[storePtr->firstUsed + shiftCount],
+ &storePtr->slots[storePtr->firstUsed],
+ storePtr->numUsed * sizeof(Tcl_Obj *));
+ storePtr->firstUsed += shiftCount;
+ if (repPtr->spanPtr) {
+ repPtr->spanPtr->spanStart += shiftCount;
+ } else {
+ /* No span means entire original list is span */
+ /* Should have been zero before shift - Invariant TBD */
+ LIST_ASSERT(storePtr->firstUsed == shiftCount);
+ repPtr->spanPtr = ListSpanNew(shiftCount, storePtr->numUsed);
+ }
- if (objc <= 0) {
- Tcl_Panic("NewListInternalRep: expects postive element count");
+ LISTREP_CHECK(repPtr);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepValidate --
+ *
+ * Checks all invariants for a ListRep and panics on failure.
+ * Note this is independent of NDEBUG, assert etc.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Panics if any invariant is not met.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListRepValidate(const ListRep *repPtr, const char *file, int lineNum)
+{
+ ListStore *storePtr = repPtr->storePtr;
+ const char *condition;
+
+ (void)storePtr; /* To stop gcc from whining about unused vars */
+
+#define INVARIANT(cond_) \
+ do { \
+ if (!(cond_)) { \
+ condition = #cond_; \
+ goto failure; \
+ } \
+ } while (0)
+
+ /* Separate each condition so line number gives exact reason for failure */
+ INVARIANT(storePtr != NULL);
+ INVARIANT(storePtr->numAllocated >= 0);
+ INVARIANT(storePtr->numAllocated <= LIST_MAX);
+ INVARIANT(storePtr->firstUsed >= 0);
+ INVARIANT(storePtr->firstUsed < storePtr->numAllocated);
+ INVARIANT(storePtr->numUsed >= 0);
+ INVARIANT(storePtr->numUsed <= storePtr->numAllocated);
+ INVARIANT(storePtr->firstUsed <= (storePtr->numAllocated - storePtr->numUsed));
+
+ if (! ListRepIsShared(repPtr)) {
+ /*
+ * If this is the only reference and there is no span, then store
+ * occupancy must begin at 0
+ */
+ INVARIANT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0);
}
+ INVARIANT(ListRepStart(repPtr) >= storePtr->firstUsed);
+ INVARIANT(ListRepLength(repPtr) <= storePtr->numUsed);
+ INVARIANT(ListRepStart(repPtr) <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr)));
+
+#undef INVARIANT
+
+ return;
+
+failure:
+ Tcl_Panic("List internal failure in %s line %d. Condition: %s",
+ file,
+ lineNum,
+ condition);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclListObjValidate --
+ *
+ * Wrapper around ListRepValidate. Primarily used from test suite.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Will panic if internal structure is not consistent or if object
+ * cannot be converted to a list object.
+ *
+ *------------------------------------------------------------------------
+ */
+void
+TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
+{
+ ListRep listRep;
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ Tcl_Panic("Object passed to TclListObjValidate cannot be converted to "
+ "a list object.");
+ }
+ ListRepValidate(&listRep, __FILE__, __LINE__);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ListStoreNew --
+ *
+ * Allocates a new ListStore with space for at least objc elements. objc
+ * must be > 0. If objv!=NULL, initializes with the first objc values
+ * in that array. If objv==NULL, initalize 0 elements, with space
+ * to add objc more.
+ *
+ * Normally the function allocates the exact space requested unless
+ * the flags arguments has any LISTREP_SPACE_*
+ * bits set. See the comments for those #defines.
+ *
+ * Results:
+ * On success, a pointer to the allocated ListStore is returned.
+ * On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in
+ * flags; otherwise returns NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented on success
+ * since the returned ListStore references them.
+ *
+ *----------------------------------------------------------------------
+ */
+static ListStore *
+ListStoreNew(
+ ListSizeT objc,
+ Tcl_Obj *const objv[],
+ int flags)
+{
+ ListStore *storePtr;
+ ListSizeT capacity;
+
/*
* First check to see if we'd overflow and try to allocate an object
- * larger than our memory allocator allows. Note that this is actually a
- * fairly small value when you're on a serious 64-bit machine, but that
- * requires API changes to fix. See [Bug 219196] for a discussion.
+ * larger than our memory allocator allows.
*/
-
- if ((size_t)objc > LIST_MAX) {
- if (p) {
- Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
- LIST_MAX);
+ if (objc > LIST_MAX) {
+ if (flags & LISTREP_PANIC_ON_FAIL) {
+ Tcl_Panic("max length of a Tcl list exceeded");
}
return NULL;
}
- listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc));
- if (listRepPtr == NULL) {
- if (p) {
+ if (flags & LISTREP_SPACE_FLAGS) {
+ capacity = ListStoreUpSize(objc);
+ } else {
+ capacity = objc;
+ }
+
+ storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity));
+ if (storePtr == NULL && capacity != objc) {
+ capacity = objc; /* Try allocating exact size */
+ storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity));
+ }
+ if (storePtr == NULL) {
+ if (flags & LISTREP_PANIC_ON_FAIL) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
LIST_SIZE(objc));
}
return NULL;
}
- listRepPtr->canonicalFlag = 0;
- listRepPtr->refCount = 0;
- listRepPtr->maxElemCount = objc;
+ storePtr->refCount = 0;
+ storePtr->flags = 0;
+ storePtr->numAllocated = capacity;
+ if (capacity == objc) {
+ storePtr->firstUsed = 0;
+ } else {
+ ListSizeT extra = capacity - objc;
+ int spaceFlags = flags & LISTREP_SPACE_FLAGS;
+ if (spaceFlags == LISTREP_SPACE_ONLY_BACK) {
+ storePtr->firstUsed = 0;
+ } else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) {
+ /* Leave more space in the front */
+ storePtr->firstUsed =
+ extra - (extra / 4); /* NOT same as 3*extra/4 */
+ } else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) {
+ /* Leave more space in the back */
+ storePtr->firstUsed = extra / 4;
+ } else {
+ /* Apportion equally */
+ storePtr->firstUsed = extra / 2;
+ }
+ }
if (objv) {
- Tcl_Obj **elemPtrs;
- int i;
-
- listRepPtr->elemCount = objc;
- elemPtrs = listRepPtr->elements;
- for (i = 0; i < objc; i++) {
- elemPtrs[i] = objv[i];
- Tcl_IncrRefCount(elemPtrs[i]);
- }
+ storePtr->numUsed = objc;
+ ObjArrayCopy(&storePtr->slots[storePtr->firstUsed], objc, objv);
} else {
- listRepPtr->elemCount = 0;
+ storePtr->numUsed = 0;
}
- return listRepPtr;
+
+ return storePtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListStoreReallocate --
+ *
+ * Reallocates the memory for a ListStore.
+ *
+ * Results:
+ * Pointer to the ListStore which may be the same as storePtr or pointer
+ * to a new block of memory. On reallocation failure, NULL is returned.
+ *
+ *
+ * Side effects:
+ * The memory pointed to by storePtr is freed if it a new block has to
+ * be returned.
+ *
+ *
+ *------------------------------------------------------------------------
+ */
+ListStore *
+ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots)
+{
+ ListSizeT newCapacity;
+ ListStore *newStorePtr;
+
+ newCapacity = ListStoreUpSize(numSlots);
+ newStorePtr =
+ (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(newCapacity));
+ if (newStorePtr == NULL) {
+ newCapacity = numSlots;
+ newStorePtr = (ListStore *)attemptckrealloc(storePtr,
+ LIST_SIZE(newCapacity));
+ if (newStorePtr == NULL)
+ return NULL;
+ }
+ /* Only the capacity has changed, fix it in the header */
+ newStorePtr->numAllocated = newCapacity;
+ return newStorePtr;
}
/*
*----------------------------------------------------------------------
*
- * AttemptNewList --
+ * ListRepInit --
+ *
+ * Initializes a ListRep to hold a list internal representation
+ * with space for objc elements.
*
- * Like NewListInternalRep, but additionally sets an error message on failure.
+ * objc must be > 0. If objv!=NULL, initializes with the first objc
+ * values in that array. If objv==NULL, initalize list internal rep to
+ * have 0 elements, with space to add objc more.
+ *
+ * Normally the function allocates the exact space requested unless
+ * the flags arguments has one of the LISTREP_SPACE_* bits set.
+ * See the comments for those #defines.
+ *
+ * The reference counts of the ListStore and ListSpan (if present)
+ * pointed to by the initialized repPtr are set to zero.
+ * Caller has to manage them as necessary.
+ *
+ * Results:
+ * On success, TCL_OK is returned with *listRepPtr initialized.
+ * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise
+ * returns TCL_ERROR with *listRepPtr fields set to NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
+static int
+ListRepInit(
+ ListSizeT objc,
+ Tcl_Obj *const objv[],
+ int flags,
+ ListRep *repPtr
+ )
+{
+ ListStore *storePtr;
-static List *
-AttemptNewList(
+ storePtr = ListStoreNew(objc, objv, flags);
+ if (storePtr) {
+ repPtr->storePtr = storePtr;
+ if (storePtr->firstUsed == 0) {
+ repPtr->spanPtr = NULL;
+ } else {
+ repPtr->spanPtr =
+ ListSpanNew(storePtr->firstUsed, storePtr->numUsed);
+ }
+ return TCL_OK;
+ }
+ /*
+ * Initialize to keep gcc happy at the call site. Else it complains
+ * about possibly uninitialized use.
+ */
+ repPtr->storePtr = NULL;
+ repPtr->spanPtr = NULL;
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ListRepInitAttempt --
+ *
+ * Creates a list internal rep with space for objc elements. See
+ * ListRepInit for requirements for parameters (in particular objc must
+ * be > 0). This function only adds error messages to the interpreter if
+ * not NULL.
+ *
+ * The reference counts of the ListStore and ListSpan (if present)
+ * pointed to by the initialized repPtr are set to zero.
+ * Caller has to manage them as necessary.
+ *
+ * Results:
+ * On success, TCL_OK is returned with *listRepPtr initialized.
+ * On allocation failure, returnes TCL_ERROR with an error message
+ * in the interpreter if non-NULL.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ListRepInitAttempt(
Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
+ ListSizeT objc,
+ Tcl_Obj *const objv[],
+ ListRep *repPtr)
{
- List *listRepPtr = NewListInternalRep(objc, objv, 0);
+ int result = ListRepInit(objc, objv, 0, repPtr);
- if (interp != NULL && listRepPtr == NULL) {
+ if (result != TCL_OK && interp != NULL) {
if (objc > LIST_MAX) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
+ ListLimitExceededError(interp);
} else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "list creation failed: unable to alloc %u bytes",
- LIST_SIZE(objc)));
+ MemoryAllocationError(interp, LIST_SIZE(objc));
}
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return listRepPtr;
+ return result;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepClone --
+ *
+ * Does a deep clone of an existing ListRep.
+ *
+ * Normally the function allocates the exact space needed unless
+ * the flags arguments has one of the LISTREP_SPACE_* bits set.
+ * See the comments for those #defines.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The toRepPtr location is initialized with the ListStore and ListSpan
+ * (if needed) containing a copy of the list elements in fromRepPtr.
+ * The function will panic if memory cannot be allocated.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags)
+{
+ Tcl_Obj **fromObjs;
+ ListSizeT numFrom;
+
+ ListRepElements(fromRepPtr, numFrom, fromObjs);
+ ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRepUnsharedFreeUnreferenced --
+ *
+ * Frees any Tcl_Obj's from the "in-use" area of the ListStore for a
+ * ListRep that are not actually references from any lists.
+ *
+ * IMPORTANT: this function must not be called on a shared internal
+ * representation or the internal representation of a shared Tcl_Obj.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The firstUsed and numUsed fields of the ListStore are updated to
+ * reflect the new "in-use" extent.
+ *
+ *------------------------------------------------------------------------
+ */
+static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr)
+{
+ ListSizeT count;
+ ListStore *storePtr;
+ ListSpan *spanPtr;
+
+ LIST_ASSERT(!ListRepIsShared(repPtr));
+ LISTREP_CHECK(repPtr);
+
+ storePtr = repPtr->storePtr;
+ spanPtr = repPtr->spanPtr;
+ if (spanPtr == NULL) {
+ LIST_ASSERT(storePtr->firstUsed == 0); /* Invariant TBD */
+ return;
+ }
+
+ /* Collect garbage at front */
+ count = spanPtr->spanStart - storePtr->firstUsed;
+ LIST_COUNT_ASSERT(count);
+ if (count > 0) {
+ /* T:listrep-1.5.1,6.{1:8} */
+ ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count);
+ storePtr->firstUsed = spanPtr->spanStart;
+ LIST_ASSERT(storePtr->numUsed >= count);
+ storePtr->numUsed -= count;
+ }
+
+ /* Collect garbage at back */
+ count = (storePtr->firstUsed + storePtr->numUsed)
+ - (spanPtr->spanStart + spanPtr->spanLength);
+ LIST_COUNT_ASSERT(count);
+ if (count > 0) {
+ /* T:listrep-6.{1:8} */
+ ObjArrayDecrRefs(
+ storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count);
+ LIST_ASSERT(storePtr->numUsed >= count);
+ storePtr->numUsed -= count;
+ }
+
+ LIST_ASSERT(ListRepStart(repPtr) == storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(repPtr) == storePtr->numUsed);
+ LISTREP_CHECK(repPtr);
}
/*
@@ -192,20 +1084,23 @@ AttemptNewList(
*
* Tcl_NewListObj --
*
- * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is
- * defined, 'Tcl_DbNewListObj' is called instead.
- *
- * Value
+ * This function is normally called when not debugging: i.e., when
+ * TCL_MEM_DEBUG is not defined. It creates a new list object from an
+ * (objc,objv) array: that is, each of the objc elements of the array
+ * referenced by objv is inserted as an element into a new Tcl object.
*
- * A new list 'Tcl_Obj' to which is appended values from 'objv', or if
- * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no
- * elements. The string representation of the new 'Tcl_Obj' is set to
- * NULL. The refCount of the list is 0.
+ * When TCL_MEM_DEBUG is defined, this function just returns the result
+ * of calling the debugging version Tcl_DbNewListObj.
*
- * Effect
+ * Results:
+ * A new list object is returned that is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The resulting new list object has ref count 0.
*
- * The refCount of each elements in 'objv' is incremented as it is added
- * to the list.
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -215,7 +1110,7 @@ AttemptNewList(
Tcl_Obj *
Tcl_NewListObj(
- int objc, /* Count of objects referenced by objv. */
+ ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
return Tcl_DbNewListObj(objc, objv, "unknown", 0);
@@ -225,45 +1120,50 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_NewListObj(
- int objc, /* Count of objects referenced by objv. */
+ ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
- List *listRepPtr;
- Tcl_Obj *listPtr;
+ ListRep listRep;
+ Tcl_Obj *listObj;
- TclNewObj(listPtr);
+ TclNewObj(listObj);
if (objc <= 0) {
- return listPtr;
+ return listObj;
}
- /*
- * Create the internal rep.
- */
-
- listRepPtr = NewListInternalRep(objc, objv, 1);
-
- /*
- * Now create the object.
- */
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
- TclInvalidateStringRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
- return listPtr;
+ return listObj;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
- * Tcl_DbNewListObj --
+ * Tcl_DbNewListObj --
+ *
+ * This function is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
+ * as the Tcl_NewListObj function above except that it calls
+ * Tcl_DbCkalloc directly with the file name and line number from its
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
- * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the
- * file name and line number from its caller. This simplifies debugging
- * since the [memory active] command will report the correct file
- * name and line number when reporting objects that haven't been freed.
+ * When TCL_MEM_DEBUG is not defined, this function just returns the
+ * result of calling Tcl_NewListObj.
*
- * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead.
+ * Results:
+ * A new list object is returned that is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The new list object has ref count 0.
+ *
+ * Side effects:
+ * The ref counts of the elements in objv are incremented since the
+ * resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
@@ -272,43 +1172,33 @@ Tcl_NewListObj(
Tcl_Obj *
Tcl_DbNewListObj(
- int objc, /* Count of objects referenced by objv. */
+ ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
- Tcl_Obj *listPtr;
- List *listRepPtr;
+ Tcl_Obj *listObj;
+ ListRep listRep;
- TclDbNewObj(listPtr, file, line);
+ TclDbNewObj(listObj, file, line);
if (objc <= 0) {
- return listPtr;
+ return listObj;
}
- /*
- * Create the internal rep.
- */
-
- listRepPtr = NewListInternalRep(objc, objv, 1);
-
- /*
- * Now create the object.
- */
-
- TclInvalidateStringRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
- return listPtr;
+ return listObj;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
- int objc, /* Count of objects referenced by objv. */
+ ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
@@ -318,45 +1208,152 @@ Tcl_DbNewListObj(
#endif /* TCL_MEM_DEBUG */
/*
+ *------------------------------------------------------------------------
+ *
+ * TclNewListObj2 --
+ *
+ * Create a new Tcl_Obj list comprising of the concatenation of two
+ * Tcl_Obj* arrays.
+ * TODO - currently this function is not used within tclListObj but
+ * need to see if it would be useful in other files that preallocate
+ * lists and then append.
+ *
+ * Results:
+ * Non-NULL pointer to the allocate Tcl_Obj.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclNewListObj2(
+ ListSizeT objc1, /* Count of objects referenced by objv1. */
+ Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */
+ ListSizeT objc2, /* Count of objects referenced by objv2. */
+ Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */
+)
+{
+ Tcl_Obj *listObj;
+ ListStore *storePtr;
+ ListSizeT objc = objc1 + objc2;
+
+ listObj = Tcl_NewListObj(objc, NULL);
+ if (objc == 0) {
+ return listObj; /* An empty object */
+ }
+ LIST_ASSERT_TYPE(listObj);
+
+ storePtr = ListObjStorePtr(listObj);
+
+ LIST_ASSERT(ListObjSpanPtr(listObj) == NULL);
+ LIST_ASSERT(storePtr->firstUsed == 0);
+ LIST_ASSERT(storePtr->numUsed == 0);
+ LIST_ASSERT(storePtr->numAllocated >= objc);
+
+ if (objc1) {
+ ObjArrayCopy(storePtr->slots, objc1, objv1);
+ }
+ if (objc2) {
+ ObjArrayCopy(&storePtr->slots[objc1], objc2, objv2);
+ }
+ storePtr->numUsed = objc;
+ return listObj;
+}
+
+/*
*----------------------------------------------------------------------
*
- * Tcl_SetListObj --
+ * TclListObjGetRep --
*
- * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of
- * creating a new one.
+ * This function returns a copy of the ListRep stored
+ * as the internal representation of an object. The reference
+ * counts of the (ListStore, ListSpan) contained in the representation
+ * are NOT incremented.
*
+ * Results:
+ * The return value is normally TCL_OK; in this case *listRepP
+ * is set to a copy of the descriptor stored as the internal
+ * representation of the Tcl_Obj containing a list. if listPtr does not
+ * refer to a list object and the object can not be converted to one,
+ * TCL_ERROR is returned and an error message will be left in the
+ * interpreter's result if interp is not NULL.
+ *
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object. *repPtr is initialized to the internal rep
+ * if result is TCL_OK, or set to NULL on error.
*----------------------------------------------------------------------
*/
+static int
+TclListObjGetRep(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object for which an element array is
+ * to be returned. */
+ ListRep *repPtr) /* Location to store descriptor */
+{
+ if (!TclHasInternalRep(listObj, &tclListType)) {
+ int result;
+ result = SetListFromAny(interp, listObj);
+ if (result != TCL_OK) {
+ /* Init to keep gcc happy wrt uninitialized fields at call site */
+ repPtr->storePtr = NULL;
+ repPtr->spanPtr = NULL;
+ return result;
+ }
+ }
+ ListObjGetRep(listObj, repPtr);
+ LISTREP_CHECK(repPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetListObj --
+ *
+ * Modify an object to be a list containing each of the objc elements of
+ * the object array referenced by objv.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object is made a list object and is initialized from the object
+ * pointers in objv. If objc is less than or equal to zero, an empty
+ * object is returned. The new object's string representation is left
+ * NULL. The ref counts of the elements in objv are incremented since the
+ * list now refers to them. The object's old string and internal
+ * representations are freed and its type is set NULL.
+ *
+ *----------------------------------------------------------------------
+ */
void
Tcl_SetListObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
- int objc, /* Count of objects referenced by objv. */
+ ListSizeT objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */
{
- List *listRepPtr;
-
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetListObj");
}
/*
- * Free any old string rep and any internal rep for the old type.
- */
-
- TclFreeInternalRep(objPtr);
- TclInvalidateStringRep(objPtr);
-
- /*
* Set the object's type to "list" and initialize the internal rep.
* However, if there are no elements to put in the list, just give the
- * object an empty string rep and a NULL type.
+ * object an empty string rep and a NULL type. NOTE ListRepInit must
+ * not be called with objc == 0!
*/
if (objc > 0) {
- listRepPtr = NewListInternalRep(objc, objv, 1);
- ListSetInternalRep(objPtr, listRepPtr);
+ ListRep listRep;
+ /* TODO - perhaps ask for extra space? */
+ ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep);
+ ListObjReplaceRepAndInvalidate(objPtr, &listRep);
} else {
+ TclFreeInternalRep(objPtr);
+ TclInvalidateStringRep(objPtr);
Tcl_InitStringRep(objPtr, NULL, 0);
}
}
@@ -366,20 +1363,18 @@ Tcl_SetListObj(
*
* TclListObjCopy --
*
- * Creates a new 'Tcl_Obj' which is a pure copy of a list 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.
+ * Makes a "pure list" copy of a list 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.
*
- * Value
- *
- * The address of the new 'Tcl_Obj' which shares its internal
- * representation with 'listPtr', and whose refCount is 0. If 'listPtr'
- * is not actually a list, the value is NULL, and an error message is left
- * in 'interp' if it is not NULL.
- *
- * Effect
+ * Results:
+ * Normally returns a pointer to a new Tcl_Obj, that contains the same
+ * list value as *listPtr does. The returned Tcl_Obj has a refCount of
+ * zero. If *listPtr does not hold a list, NULL is returned, and if
+ * interp is non-NULL, an error message is recorded there.
*
- * 'listPtr' is converted to a list if it isn't one already.
+ * Side effects:
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -387,137 +1382,290 @@ Tcl_SetListObj(
Tcl_Obj *
TclListObjCopy(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr) /* List object for which an element array is
+ Tcl_Obj *listObj) /* List object for which an element array is
* to be returned. */
{
- Tcl_Obj *copyPtr;
- List *listRepPtr;
+ Tcl_Obj *copyObj;
- ListGetInternalRep(listPtr, listRepPtr);
- if (NULL == listRepPtr) {
- if (SetListFromAny(interp, listPtr) != TCL_OK) {
+ if (!TclHasInternalRep(listObj, &tclListType)) {
+ if (SetListFromAny(interp, listObj) != TCL_OK) {
return NULL;
}
}
- TclNewObj(copyPtr);
- TclInvalidateStringRep(copyPtr);
- DupListInternalRep(listPtr, copyPtr);
- return copyPtr;
+ TclNewObj(copyObj);
+ TclInvalidateStringRep(copyObj);
+ DupListInternalRep(listObj, copyObj);
+ return copyObj;
}
/*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*
- * TclListObjRange --
+ * ListRepRange --
*
- * Makes a slice of a list value.
- * *listPtr must be known to be a valid list.
+ * Initializes a ListRep as a range within the passed ListRep.
+ * The range limits are clamped to the list boundaries.
*
* Results:
- * Returns a pointer to the sliced list.
- * This may be a new object or the same object if not shared.
+ * None.
*
* Side effects:
- * The possible conversion of the object referenced by listPtr
- * to a list object.
- *
- *----------------------------------------------------------------------
+ * The ListStore and ListSpan referenced by in the returned ListRep
+ * may or may not be the same as those passed in. For example, the
+ * ListStore may differ because the range is small enough that a new
+ * ListStore is more memory-optimal. The ListSpan may differ because
+ * it is NULL or shared. Regardless, reference counts on the returned
+ * values are not incremented. Generally, ListObjReplaceRepAndInvalidate
+ * may be used to store the new ListRep back into an object or a
+ * ListRepIncrRefs followed by ListRepDecrRefs to free in case of errors.
+ * Any other use should be carefully reconsidered.
+ * TODO WARNING:- this is an awkward interface and easy for caller
+ * to get wrong. Mostly due to refcount combinations. Perhaps passing
+ * in the source listObj instead of source listRep might simplify.
+ *
+ *------------------------------------------------------------------------
*/
-
-Tcl_Obj *
-TclListObjRange(
- Tcl_Obj *listPtr, /* List object to take a range from. */
- int fromIdx, /* Index of first element to include. */
- int toIdx) /* Index of last element to include. */
+static void
+ListRepRange(
+ ListRep *srcRepPtr, /* Contains source of the range */
+ ListSizeT rangeStart, /* Index of first element to include */
+ ListSizeT rangeEnd, /* Index of last element to include */
+ int preserveSrcRep, /* If true, srcRepPtr contents must not be
+ modified (generally because a shared Tcl_Obj
+ references it) */
+ ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */
{
- Tcl_Obj **elemPtrs;
- int listLen, i, newLen;
- List *listRepPtr;
-
- TclListObjGetElementsM(NULL, listPtr, &listLen, &elemPtrs);
-
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (toIdx >= listLen) {
- toIdx = listLen-1;
+ Tcl_Obj **srcElems;
+ ListSizeT numSrcElems = ListRepLength(srcRepPtr);
+ ListSizeT rangeLen;
+ ListSizeT numAfterRangeEnd;
+
+ LISTREP_CHECK(srcRepPtr);
+
+ /* Take the opportunity to garbage collect */
+ /* TODO - we probably do not need the preserveSrcRep here unlike later */
+ if (!preserveSrcRep) {
+ /* T:listrep-1.{4,5,8,9},2.{4:7},3.{15:18},4.{7,8} */
+ ListRepFreeUnreferenced(srcRepPtr);
+ } /* else T:listrep-2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
+
+ if (rangeStart < 0) {
+ rangeStart = 0;
}
- if (fromIdx > toIdx) {
- Tcl_Obj *obj;
- TclNewObj(obj);
- return obj;
+ if (rangeEnd >= numSrcElems) {
+ rangeEnd = numSrcElems - 1;
}
-
- newLen = toIdx - fromIdx + 1;
-
- if (Tcl_IsShared(listPtr) ||
- ((ListRepPtr(listPtr)->refCount > 1))) {
- return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]);
+ if (rangeStart > rangeEnd) {
+ /* Empty list of capacity 1. */
+ ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr);
+ return;
}
- /*
- * In-place is possible.
- */
+ rangeLen = rangeEnd - rangeStart + 1;
/*
- * Even if nothing below cause any changes, we still want the
- * string-canonizing effect of [lrange 0 end].
+ * We can create a range one of four ways:
+ * (0) Range encapsulates entire list
+ * (1) Special case: deleting in-place from end of an unshared object
+ * (2) Use a ListSpan referencing the current ListStore
+ * (3) Creating a new ListStore
+ * (4) Removing all elements outside the range in the current ListStore
+ * Option (4) may only be done if caller has not disallowed it AND
+ * the ListStore is not shared.
+ *
+ * The choice depends on heuristics related to speed and memory.
+ * TODO - heuristics below need to be measured and tuned.
+ *
+ * Note: Even if nothing below cause any changes, we still want the
+ * string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not
+ * be returned as is even if the range encompasses the whole list.
*/
+ if (rangeStart == 0 && rangeEnd == (numSrcElems-1)) {
+ /* Option 0 - entire list. This may be used to canonicalize */
+ /* T:listrep-1.10.1,2.8.1 */
+ *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */
+ } else if (rangeStart == 0 && (!preserveSrcRep)
+ && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) {
+ /* Option 1 - Special case unshared, exclude end elements, no span */
+ LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */
+ ListRepElements(srcRepPtr, numSrcElems, srcElems);
+ numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
+ /* Assert: Because numSrcElems > rangeEnd earlier */
+ LIST_ASSERT(numAfterRangeEnd >= 0);
+ if (numAfterRangeEnd != 0) {
+ /* T:listrep-1.{8,9} */
+ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
+ }
+ /* srcRepPtr->storePtr->firstUsed,numAllocated unchanged */
+ srcRepPtr->storePtr->numUsed = rangeLen;
+ srcRepPtr->storePtr->flags = 0;
+ rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */
+ rangeRepPtr->spanPtr = NULL;
+ } else if (ListSpanMerited(rangeLen,
+ srcRepPtr->storePtr->numUsed,
+ srcRepPtr->storePtr->numAllocated)) {
+ /* Option 2 - because span would be most efficient */
+ ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart;
+ if (!preserveSrcRep && srcRepPtr->spanPtr
+ && srcRepPtr->spanPtr->refCount <= 1) {
+ /* If span is not shared reuse it */
+ /* T:listrep-2.7.3,3.{16,18} */
+ srcRepPtr->spanPtr->spanStart = spanStart;
+ srcRepPtr->spanPtr->spanLength = rangeLen;
+ *rangeRepPtr = *srcRepPtr;
+ } else {
+ /* Span not present or is shared. */
+ /* T:listrep-1.5,2.{5,7},4.{7,8} */
+ rangeRepPtr->storePtr = srcRepPtr->storePtr;
+ rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen);
+ }
+ /*
+ * We have potentially created a new internal representation that
+ * references the same storage as srcRep but not yet incremented its
+ * reference count. So do NOT call freezombies if preserveSrcRep
+ * is mandated.
+ */
+ if (!preserveSrcRep) {
+ /* T:listrep-1.{5.1,5.2,5.4},2.{5,7},3.{16,18},4.{7,8} */
+ ListRepFreeUnreferenced(rangeRepPtr);
+ }
+ } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) {
+ /* Option 3 - span or modification in place not allowed/desired */
+ /* T:listrep-2.{4,6} */
+ ListRepElements(srcRepPtr, numSrcElems, srcElems);
+ /* TODO - allocate extra space? */
+ ListRepInit(rangeLen,
+ &srcElems[rangeStart],
+ LISTREP_PANIC_ON_FAIL,
+ rangeRepPtr);
+ } else {
+ /*
+ * Option 4 - modify in place. Note that because of the invariant
+ * that spanless list stores must start at 0, we have to move
+ * everything to the front.
+ * TODO - perhaps if a span already exists, no need to move to front?
+ * or maybe no need to move all the way to the front?
+ * TODO - if range is small relative to allocation, allocate new?
+ */
- TclInvalidateStringRep(listPtr);
-
- /*
- * Delete elements that should not be included.
- */
+ /* Asserts follow from call to ListRepFreeUnreferenced earlier */
+ LIST_ASSERT(!preserveSrcRep);
+ LIST_ASSERT(!ListRepIsShared(srcRepPtr));
+ LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed);
- for (i = 0; i < fromIdx; i++) {
- TclDecrRefCount(elemPtrs[i]);
- }
- for (i = toIdx + 1; i < listLen; i++) {
- TclDecrRefCount(elemPtrs[i]);
- }
+ ListRepElements(srcRepPtr, numSrcElems, srcElems);
- if (fromIdx > 0) {
- memmove(elemPtrs, &elemPtrs[fromIdx],
- (size_t) newLen * sizeof(Tcl_Obj*));
+ /* Free leading elements outside range */
+ if (rangeStart != 0) {
+ /* T:listrep-1.4,3.15 */
+ ObjArrayDecrRefs(srcElems, 0, rangeStart);
+ }
+ /* Ditto for trailing */
+ numAfterRangeEnd = numSrcElems - (rangeEnd + 1);
+ /* Assert: Because numSrcElems > rangeEnd earlier */
+ LIST_ASSERT(numAfterRangeEnd >= 0);
+ if (numAfterRangeEnd != 0) {
+ /* T:listrep-3.17 */
+ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd);
+ }
+ memmove(&srcRepPtr->storePtr->slots[0],
+ &srcRepPtr->storePtr
+ ->slots[srcRepPtr->storePtr->firstUsed + rangeStart],
+ rangeLen * sizeof(Tcl_Obj *));
+ srcRepPtr->storePtr->firstUsed = 0;
+ srcRepPtr->storePtr->numUsed = rangeLen;
+ srcRepPtr->storePtr->flags = 0;
+ if (srcRepPtr->spanPtr) {
+ /* In case the source has a span, update it for consistency */
+ /* T:listrep-3.{15,17} */
+ srcRepPtr->spanPtr->spanStart = srcRepPtr->storePtr->firstUsed;
+ srcRepPtr->spanPtr->spanLength = srcRepPtr->storePtr->numUsed;
+ }
+ rangeRepPtr->storePtr = srcRepPtr->storePtr;
+ rangeRepPtr->spanPtr = NULL;
}
- listRepPtr = ListRepPtr(listPtr);
- listRepPtr->elemCount = newLen;
+ /* TODO - call freezombies here if !preserveSrcRep? */
- return listPtr;
+ /* Note ref counts intentionally not incremented */
+ LISTREP_CHECK(rangeRepPtr);
+ return;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ListObjGetElements --
- *
- * Retreive the elements in a list 'Tcl_Obj'.
+ * TclListObjRange --
*
- * Value
+ * Makes a slice of a list value.
+ * *listObj must be known to be a valid list.
*
- * TCL_OK
+ * Results:
+ * Returns a pointer to the sliced list.
+ * This may be a new object or the same object if not shared.
+ * Returns NULL if passed listObj was not a list and could not be
+ * converted to one.
*
- * A count of list elements is stored, 'objcPtr', And a pointer to the
- * array of elements in the list is stored in 'objvPtr'.
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object.
*
- * The elements accessible via 'objvPtr' should be treated as readonly
- * and the refCount for each object is _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.
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclListObjRange(
+ Tcl_Obj *listObj, /* List object to take a range from. */
+ ListSizeT rangeStart, /* Index of first element to include. */
+ ListSizeT rangeEnd) /* Index of last element to include. */
+{
+ ListRep listRep;
+ ListRep resultRep;
+
+ int isShared;
+ if (TclListObjGetRep(NULL, listObj, &listRep) != TCL_OK)
+ return NULL;
+
+ isShared = Tcl_IsShared(listObj);
+
+ ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep);
+
+ if (isShared) {
+ /* T:listrep-1.10.1,2.{4.2,4.3,5.2,5.3,6.2,7.2,8.1} */
+ TclNewObj(listObj);
+ } /* T:listrep-1.{4.3,5.1,5.2} */
+ ListObjReplaceRepAndInvalidate(listObj, &resultRep);
+ return listObj;
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * TCL_ERROR
+ * Tcl_ListObjGetElements --
*
- * 'listPtr' is not a valid list. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * This function returns an (objc,objv) array of the elements in a list
+ * object.
*
- * Effect
+ * 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 a list object and the object can not be converted to one,
+ * TCL_ERROR is returned and an error message will be left in the
+ * interpreter's result if interp is not NULL.
+ *
+ * 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.
*
- * 'listPtr' is converted to a list object if it isn't one already.
+ * Side effects:
+ * The possible conversion of the object referenced by listPtr
+ * to a list object.
*
*----------------------------------------------------------------------
*/
@@ -526,36 +1674,22 @@ TclListObjRange(
int
Tcl_ListObjGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object for which an element array is
+ Tcl_Obj *objPtr, /* List object for which an element array is
* to be returned. */
- int *objcPtr, /* Where to store the count of objects
+ ListSizeT *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. */
{
- List *listRepPtr;
+ ListRep listRep;
- ListGetInternalRep(listPtr, listRepPtr);
-
- if (listRepPtr == NULL) {
- int result;
- int length;
- if ( ! TclHasInternalRep(listPtr,&tclArithSeriesType)) {
- (void) Tcl_GetStringFromObj(listPtr, &length);
- if (length == 0) {
- *objcPtr = 0;
- *objvPtr = NULL;
- return TCL_OK;
- }
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- ListGetInternalRep(listPtr, listRepPtr);
+ if (TclHasInternalRep(objPtr,&tclArithSeriesType)) {
+ return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr);
}
- *objcPtr = listRepPtr->elemCount;
- *objvPtr = listRepPtr->elements;
+
+ if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
+ return TCL_ERROR;
+ ListRepElements(&listRep, *objcPtr, *objvPtr);
return TCL_OK;
}
@@ -564,49 +1698,37 @@ Tcl_ListObjGetElements(
*
* Tcl_ListObjAppendList --
*
- * Appends the elements of elemListPtr to those of listPtr.
- *
- * Value
+ * This function appends the elements in the list fromObj
+ * to toObj. toObj must not be shared else the function will panic.
*
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' or 'elemListPtr' are not valid lists. An error
- * message is left in the interpreter's result if 'interp' is not NULL.
- *
- * Effect
+ * Results:
+ * The return value is normally TCL_OK. If fromObj or toObj do not
+ * refer to list values, TCL_ERROR is returned and an error message is
+ * left in the interpreter's result if interp is not NULL.
*
- * The reference count of each element of 'elemListPtr' as it is added to
- * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType'
- * if they are not already. Appending the new elements may cause the
- * array of element pointers in 'listObj' to grow. If any objects are
- * appended to 'listPtr'. Any preexisting string representation of
- * 'listPtr' is invalidated.
+ * Side effects:
+ * The reference counts of the elements in fromObj are incremented
+ * since the list now refers to them. toObj and fromObj are
+ * converted, if necessary, to list objects. Also, appending the new
+ * elements may cause toObj's array of element pointers to grow.
+ * toObj's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjAppendList(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to append elements to. */
- Tcl_Obj *elemListPtr) /* List obj with elements to append. */
+ Tcl_Obj *toObj, /* List object to append elements to. */
+ Tcl_Obj *fromObj) /* List obj with elements to append. */
{
- int objc;
+ ListSizeT objc;
Tcl_Obj **objv;
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsShared(toObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
}
- /*
- * Pull the elements to append from elemListPtr.
- */
-
- if (TCL_OK != TclListObjGetElementsM(interp, elemListPtr, &objc, &objv)) {
+ if (TclListObjGetElementsM(interp, fromObj, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
@@ -615,254 +1737,250 @@ Tcl_ListObjAppendList(
* Delete zero existing elements.
*/
- return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv);
+ return TclListObjAppendElements(interp, toObj, objc, objv);
}
/*
- *----------------------------------------------------------------------
- *
- * Tcl_ListObjAppendElement --
- *
- * Like 'Tcl_ListObjAppendList', but Appends a single value to a list.
- *
- * Value
+ *------------------------------------------------------------------------
*
- * TCL_OK
+ * TclListObjAppendElements --
*
- * 'objPtr' is appended to the elements of 'listPtr'.
+ * Appends multiple elements to a Tcl_Obj list object. If
+ * the passed Tcl_Obj is not a list object, it will be converted to one
+ * and an error raised if the conversion fails.
*
- * TCL_ERROR
+ * The Tcl_Obj must not be shared though the internal representation
+ * may be.
*
- * listPtr does not refer to a list object and the object can not be
- * converted to one. An error message will be left in the
- * interpreter's result if interp is not NULL.
- *
- * Effect
+ * Results:
+ * On success, TCL_OK is returned with the specified elements appended.
+ * On failure, TCL_ERROR is returned with an error message in the
+ * interpreter if not NULL.
*
- * If 'listPtr' is not already of type 'tclListType', it is converted.
- * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'.
- * Appending the new element may cause the the array of element pointers
- * in 'listObj' to grow. Any preexisting string representation of
- * 'listPtr' is invalidated.
+ * Side effects:
+ * None.
*
- *----------------------------------------------------------------------
+ *------------------------------------------------------------------------
*/
-
-int
-Tcl_ListObjAppendElement(
+ int TclListObjAppendElements (
Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to append objPtr to. */
- Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
+ Tcl_Obj *toObj, /* List object to append */
+ ListSizeT elemCount, /* Number of elements in elemObjs[] */
+ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */
{
- List *listRepPtr, *newPtr = NULL;
- int numElems, numRequired;
- int needGrow, isShared, attempt;
+ ListRep listRep;
+ Tcl_Obj **toObjv;
+ ListSizeT toLen;
+ ListSizeT finalLen;
- if (Tcl_IsShared(listPtr)) {
- Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
+ if (Tcl_IsShared(toObj)) {
+ Tcl_Panic("%s called with shared object", "TclListObjAppendElements");
}
- ListGetInternalRep(listPtr, listRepPtr);
- if (listRepPtr == NULL) {
- int result;
- int length;
-
- (void) Tcl_GetStringFromObj(listPtr, &length);
- if (length == 0) {
- Tcl_SetListObj(listPtr, 1, &objPtr);
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- ListGetInternalRep(listPtr, listRepPtr);
- }
-
- numElems = listRepPtr->elemCount;
- numRequired = numElems + 1 ;
- needGrow = (numRequired > listRepPtr->maxElemCount);
- isShared = (listRepPtr->refCount > 1);
-
- if (numRequired > LIST_MAX) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- }
- return TCL_ERROR;
- }
+ if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK)
+ return TCL_ERROR; /* Cannot be converted to a list */
- if (needGrow && !isShared) {
- /*
- * Need to grow + unshared internalrep => try to realloc
- */
+ if (elemCount == 0)
+ return TCL_OK; /* Nothing to do. Note AFTER check for list above */
- attempt = 2 * numRequired;
- if (attempt <= LIST_MAX) {
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
- }
- if (newPtr) {
- listRepPtr = newPtr;
- listRepPtr->maxElemCount = attempt;
- needGrow = 0;
- }
+ ListRepElements(&listRep, toLen, toObjv);
+ if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) {
+ return ListLimitExceededError(interp);
}
- if (isShared || needGrow) {
- Tcl_Obj **dst, **src = listRepPtr->elements;
+ finalLen = toLen + elemCount;
+ if (!ListRepIsShared(&listRep)) {
/*
- * Either we have a shared internalrep and we must copy to write, or we
- * need to grow and realloc attempts failed. Attempt internalrep copy.
+ * Reuse storage if possible. Even if too small, realloc-ing instead
+ * of creating a new ListStore will save us on manipulating Tcl_Obj
+ * reference counts on the elements which is a substantial cost
+ * if the list is not small.
*/
+ ListSizeT numTailFree;
- attempt = 2 * numRequired;
- newPtr = AttemptNewList(NULL, attempt, NULL);
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = AttemptNewList(NULL, attempt, NULL);
- }
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = AttemptNewList(interp, attempt, NULL);
- }
- if (newPtr == NULL) {
- /*
- * All growth attempts failed; throw the error.
- */
-
- return TCL_ERROR;
- }
+ ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */
- dst = newPtr->elements;
- newPtr->refCount++;
- newPtr->canonicalFlag = listRepPtr->canonicalFlag;
- newPtr->elemCount = listRepPtr->elemCount;
+ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed);
+ LIST_ASSERT(toLen == listRep.storePtr->numUsed);
- if (isShared) {
- /*
- * The original internalrep must remain undisturbed. Copy into the new
- * one and bump refcounts
- */
- while (numElems--) {
- *dst = *src++;
- Tcl_IncrRefCount(*dst++);
+ if (finalLen > listRep.storePtr->numAllocated) {
+ /* T:listrep-1.{2,11},3.6 */
+ ListStore *newStorePtr;
+ newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen);
+ if (newStorePtr == NULL) {
+ return MemoryAllocationError(interp, LIST_SIZE(finalLen));
}
- listRepPtr->refCount--;
- } else {
+ LIST_ASSERT(newStorePtr->numAllocated >= finalLen);
+ listRep.storePtr = newStorePtr;
/*
- * Old internalrep to be freed, re-use refCounts.
+ * WARNING: at this point the Tcl_Obj internal rep potentially
+ * points to freed storage if the reallocation returned a
+ * different location. Overwrite it to bring it back in sync.
*/
-
- memcpy(dst, src, numElems * sizeof(Tcl_Obj *));
- ckfree(listRepPtr);
- }
- listRepPtr = newPtr;
+ ListObjStompRep(toObj, &listRep);
+ } /* else T:listrep-3.{4,5} */
+ LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
+ /* Current store big enough */
+ numTailFree = ListRepNumFreeTail(&listRep);
+ LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed)
+ >= elemCount); /* Total free */
+ if (numTailFree < elemCount) {
+ /* Not enough room at back. Move some to front */
+ /* T:listrep-3.5 */
+ ListSizeT shiftCount = elemCount - numTailFree;
+ /* Divide remaining space between front and back */
+ shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2;
+ LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed);
+ if (shiftCount) {
+ /* T:listrep-3.5 */
+ ListRepUnsharedShiftDown(&listRep, shiftCount);
+ }
+ } /* else T:listrep-3.{4,6} */
+ ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep)
+ + ListRepLength(&listRep)],
+ elemCount,
+ elemObjv);
+ listRep.storePtr->numUsed = finalLen;
+ if (listRep.spanPtr) {
+ /* T:listrep-3.{4,5,6} */
+ LIST_ASSERT(listRep.spanPtr->spanStart
+ == listRep.storePtr->firstUsed);
+ listRep.spanPtr->spanLength = finalLen;
+ } /* else T:listrep-3.6.3 */
+ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
+ LIST_ASSERT(ListRepLength(&listRep) == finalLen);
+ LISTREP_CHECK(&listRep);
+
+ ListObjReplaceRepAndInvalidate(toObj, &listRep);
+ return TCL_OK;
}
- ListResetInternalRep(listPtr, listRepPtr);
- listRepPtr->refCount++;
- TclFreeInternalRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
- listRepPtr->refCount--;
-
- /*
- * Add objPtr to the end of listPtr's array of element pointers. Increment
- * the ref count for the (now shared) objPtr.
- */
-
- listRepPtr->elements[listRepPtr->elemCount] = objPtr;
- Tcl_IncrRefCount(objPtr);
- listRepPtr->elemCount++;
/*
- * Invalidate any old string representation since the list's internal
- * representation has changed.
+ * Have to make a new list rep, either shared or no room in old one.
+ * If the old list did not have a span (all elements at front), do
+ * not leave space in the front either, assuming all appends and no
+ * prepends.
*/
+ if (ListRepInit(finalLen,
+ NULL,
+ listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK
+ : LISTREP_SPACE_ONLY_BACK,
+ &listRep)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen);
- TclInvalidateStringRep(listPtr);
+ if (toLen) {
+ /* T:listrep-2.{2,9},4.5 */
+ ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv);
+ }
+ ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv);
+ listRep.storePtr->numUsed = finalLen;
+ if (listRep.spanPtr) {
+ /* T:listrep-4.5 */
+ LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed);
+ listRep.spanPtr->spanLength = finalLen;
+ }
+ LISTREP_CHECK(&listRep);
+ ListObjReplaceRepAndInvalidate(toObj, &listRep);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ListObjIndex --
+ * Tcl_ListObjAppendElement --
*
- * Retrieve a pointer to the element of 'listPtr' at 'index'. The index
- * of the first element is 0.
+ * This function is a special purpose version of Tcl_ListObjAppendList:
+ * it appends a single object referenced by elemObj to the list object
+ * referenced by toObj. If toObj is not already a list object, an
+ * attempt will be made to convert it to one.
*
- * Value
+ * Results:
+ * The return value is normally TCL_OK; in this case elemObj is added to
+ * the end of toObj's list. If toObj does not refer to a list object
+ * and the object can not be converted to one, TCL_ERROR is returned and
+ * an error message will be left in the interpreter's result if interp is
+ * not NULL.
*
- * TCL_OK
+ * Side effects:
+ * The ref count of elemObj is incremented since the list now refers to
+ * it. toObj will be converted, if necessary, to a list object. Also,
+ * appending the new element may cause listObj's array of element
+ * pointers to grow. toObj's old string representation, if any, is
+ * invalidated.
*
- * A pointer to the element at 'index' is stored in 'objPtrPtr'. If
- * 'index' is out of range, NULL is stored in 'objPtrPtr'. This
- * object should be treated as readonly and its 'refCount' is _not_
- * incremented. The caller must do that if it holds on to the
- * reference.
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_ListObjAppendElement(
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *toObj, /* List object to append elemObj to. */
+ Tcl_Obj *elemObj) /* Object to append to toObj's list. */
+{
+ /*
+ * TODO - compare perf with 8.6 to see if worth optimizing single
+ * element case
+ */
+ return TclListObjAppendElements(interp, toObj, 1, &elemObj);
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * TCL_ERROR
+ * Tcl_ListObjIndex --
*
- * 'listPtr' is not a valid list. An an error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * This function returns a pointer to the index'th object from the list
+ * referenced by listPtr. The first element has index 0. If index is
+ * negative or greater than or equal to the number of elements in the
+ * list, a NULL is returned. If listPtr is not a list object, an attempt
+ * will be made to convert it to a list.
*
- * Effect
+ * Results:
+ * The return value is normally TCL_OK; in this case objPtrPtr is set to
+ * the Tcl_Obj pointer for the index'th list element or NULL if index is
+ * out of range. This object should be treated as readonly and its ref
+ * count is _not_ incremented; the caller must do that if it holds on to
+ * the reference. If listPtr does not refer to a list and can't be
+ * converted to one, TCL_ERROR is returned and an error message is left
+ * in the interpreter's result if interp is not NULL.
*
- * If 'listPtr' is not already of type 'tclListType', it is converted.
+ * Side effects:
+ * listPtr will be converted, if necessary, to a list object.
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjIndex(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object to index into. */
- int index, /* Index of element to return. */
- Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object to index into. */
+ ListSizeT index, /* Index of element to return. */
+ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
{
- List *listRepPtr;
+ Tcl_Obj **elemObjs;
+ ListSizeT numElems;
- ListGetInternalRep(listPtr, listRepPtr);
-
- if (listRepPtr == NULL && TclHasInternalRep(listPtr,&tclArithSeriesType)) {
- return TclArithSeriesObjIndex(listPtr, index, objPtrPtr);
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ return TclArithSeriesObjIndex(listObj, index, objPtrPtr);
}
- if (listRepPtr == NULL) {
- int result;
- int length;
-
- (void) Tcl_GetStringFromObj(listPtr, &length);
- if (length == 0) {
- *objPtrPtr = NULL;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- ListGetInternalRep(listPtr, listRepPtr);
+ /*
+ * TODO
+ * Unlike the original list code, this does not optimize for lindex'ing
+ * an empty string when the internal rep is not already a list. On the
+ * other hand, this code will be faster for the case where the object
+ * is currently a dict. Benchmark the two cases.
+ */
+ if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs)
+ != TCL_OK) {
+ return TCL_ERROR;
}
-
- if ((index < 0) || (index >= listRepPtr->elemCount)) {
+ if ((index < 0) || (index >= numElems)) {
*objPtrPtr = NULL;
} else {
- *objPtrPtr = listRepPtr->elements[index];
+ *objPtrPtr = elemObjs[index];
}
return TCL_OK;
@@ -873,20 +1991,19 @@ Tcl_ListObjIndex(
*
* Tcl_ListObjLength --
*
- * Retrieve the number of elements in a list.
- *
- * Value
+ * This function returns the number of elements in a list object. If the
+ * object is not already a list object, an attempt will be made to
+ * convert it to one.
*
- * TCL_OK
- *
- * A count of list elements is stored at the address provided by
- * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is
- * converted.
- *
- * TCL_ERROR
+ * Results:
+ * The return value is normally TCL_OK; in this case *lenPtr will be set
+ * to the integer count of list elements. If listPtr does not refer to a
+ * list object and the object can not be converted to one, TCL_ERROR is
+ * returned and an error message will be left in the interpreter's result
+ * if interp is not NULL.
*
- * 'listPtr' is not a valid list. An error message will be left in
- * the interpreter's result if 'interp' is not NULL.
+ * Side effects:
+ * The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
@@ -894,35 +2011,28 @@ Tcl_ListObjIndex(
#undef Tcl_ListObjLength
int
Tcl_ListObjLength(
- Tcl_Interp *interp, /* Used to report errors if not NULL. */
- Tcl_Obj *listPtr, /* List object whose #elements to return. */
- int *intPtr) /* The resulting length is stored here. */
+ Tcl_Interp *interp, /* Used to report errors if not NULL. */
+ Tcl_Obj *listObj, /* List object whose #elements to return. */
+ ListSizeT *lenPtr) /* The resulting int is stored here. */
{
- List *listRepPtr;
-
- ListGetInternalRep(listPtr, listRepPtr);
- if (listRepPtr == NULL) {
- int result;
- int length;
+ ListRep listRep;
- if (TclHasInternalRep(listPtr,&tclArithSeriesType)) {
- *intPtr = TclArithSeriesObjLength(listPtr);
- return TCL_OK;
- }
-
- (void) Tcl_GetStringFromObj(listPtr, &length);
- if (length == 0) {
- *intPtr = 0;
- return TCL_OK;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- ListGetInternalRep(listPtr, listRepPtr);
+ if (TclHasInternalRep(listObj,&tclArithSeriesType)) {
+ *lenPtr = TclArithSeriesObjLength(listObj);
+ return TCL_OK;
}
- *intPtr = listRepPtr->elemCount;
+ /*
+ * TODO
+ * Unlike the original list code, this does not optimize for lindex'ing
+ * an empty string when the internal rep is not already a list. On the
+ * other hand, this code will be faster for the case where the object
+ * is currently a dict. Benchmark the two cases.
+ */
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *lenPtr = ListRepLength(&listRep);
return TCL_OK;
}
@@ -931,296 +2041,498 @@ Tcl_ListObjLength(
*
* Tcl_ListObjReplace --
*
- * Replace values in a list.
- *
- * If 'first' is zero or TCL_INDEX_NONE, it refers to the first element. If
- * 'first' outside the range of elements in the list, no elements are
- * deleted.
- *
- * If 'count' is zero or TCL_INDEX_NONE no elements are deleted, and any new
- * elements are inserted at the beginning of the list.
- *
- * Value
- *
- * TCL_OK
- *
- * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr'
- * starting at 'first'. If 'objc' 0, no new elements are added.
- *
- * TCL_ERROR
+ * This function replaces zero or more elements of the 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.
*
- * 'listPtr' is not a valid list. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * 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.
*
- * Effect
+ * 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. If listPtr is not a list
+ * object, an attempt will be made to convert it to one.
*
- * If 'listPtr' is not of type 'tclListType', it is converted if possible.
- *
- * The 'refCount' of each element appended to the list is incremented.
- * Similarly, the 'refCount' for each replaced element is decremented.
+ * Results:
+ * The return value is normally TCL_OK. If listPtr does not refer to a
+ * list object and 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.
*
- * If 'listPtr' is modified, any previous string representation is
- * invalidated.
+ * Side effects:
+ * The ref counts of the objc elements in objv are incremented since the
+ * resulting list now refers to them. Similarly, the ref counts for
+ * replaced objects are decremented. listObj is converted, if necessary,
+ * to a list object. listObj's old string representation, if any, is
+ * freed.
*
*----------------------------------------------------------------------
*/
-
int
Tcl_ListObjReplace(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
- Tcl_Obj *listPtr, /* List object whose elements to replace. */
- int first, /* Index of first element to replace. */
- int count, /* Number of elements to replace. */
- int objc, /* Number of objects to insert. */
- Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to
- * insert. */
+ Tcl_Obj *listObj, /* List object whose elements to replace. */
+ ListSizeT first, /* Index of first element to replace. */
+ ListSizeT numToDelete, /* Number of elements to replace. */
+ ListSizeT numToInsert, /* Number of objects to insert. */
+ Tcl_Obj *const insertObjs[])/* Tcl objects to insert */
{
- List *listRepPtr;
- Tcl_Obj **elemPtrs;
- int numElems, numRequired, numAfterLast, start, i, j;
- int needGrow, isShared;
-
- if (Tcl_IsShared(listPtr)) {
+ ListRep listRep;
+ ListSizeT origListLen;
+ int lenChange;
+ int leadSegmentLen;
+ int tailSegmentLen;
+ ListSizeT numFreeSlots;
+ int leadShift;
+ int tailShift;
+ Tcl_Obj **listObjs;
+ int favor;
+
+ if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
- ListGetInternalRep(listPtr, listRepPtr);
- if (listRepPtr == NULL) {
- int length;
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK)
+ return TCL_ERROR; /* Cannot be converted to a list */
- (void) Tcl_GetStringFromObj(listPtr, &length);
- if (length == 0) {
- if (objc == 0) {
- return TCL_OK;
- }
- Tcl_SetListObj(listPtr, objc, NULL);
- } else {
- int result = SetListFromAny(interp, listPtr);
+ /* TODO - will need modification if Tcl9 sticks to unsigned indices */
- if (result != TCL_OK) {
- return result;
- }
- }
- ListGetInternalRep(listPtr, listRepPtr);
+ /* Make limits sane */
+ origListLen = ListRepLength(&listRep);
+ if (first < 0) {
+ first = 0;
+ }
+ if (first > origListLen) {
+ first = origListLen; /* So we'll insert after last element. */
+ }
+ if (numToDelete < 0) {
+ numToDelete = 0;
+ } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */
+ || origListLen < first + numToDelete) {
+ numToDelete = origListLen - first;
+ }
+
+ if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) {
+ return ListLimitExceededError(interp);
+ }
+
+ if ((first+numToDelete) >= origListLen) {
+ /* Operating at back of list. Favor leaving space at back */
+ favor = LISTREP_SPACE_FAVOR_BACK;
+ } else if (first == 0) {
+ /* Operating on front of list. Favor leaving space in front */
+ favor = LISTREP_SPACE_FAVOR_FRONT;
+ } else {
+ /* Operating on middle of list. */
+ favor = LISTREP_SPACE_FAVOR_NONE;
}
/*
- * Note that when count == 0 and objc == 0, this routine is logically a
- * no-op, removing and adding no elements to the list. However, by flowing
- * through this routine anyway, we get the important side effect that the
- * resulting listPtr is a list in canoncial form. This is important.
- * Resist any temptation to optimize this case.
+ * There are a number of special cases to consider from an optimization
+ * point of view.
+ * (1) Pure deletes (numToInsert==0) from the front or back can be treated
+ * as a range op irrespective of whether the ListStore is shared or not
+ * (2) Pure inserts (numToDelete == 0)
+ * (2a) Pure inserts at the back can be treated as appends
+ * (2b) Pure inserts from the *front* can be optimized under certain
+ * conditions by inserting before first ListStore slot in use if there
+ * is room, again irrespective of sharing
+ * (3) If the ListStore is shared OR there is insufficient free space
+ * OR existing allocation is too large compared to new size, create
+ * a new ListStore
+ * (4) Unshared ListStore with sufficient free space. Delete, shift and
+ * insert within the ListStore.
*/
- elemPtrs = listRepPtr->elements;
- numElems = listRepPtr->elemCount;
+ /* Note: do not do TclInvalidateStringRep as yet in case there are errors */
- if (first < 0) {
- first = 0;
- }
- if (first >= numElems) {
- first = numElems; /* So we'll insert after last element. */
+ /* Check Case (1) - Treat pure deletes from front or back as range ops */
+ if (numToInsert == 0) {
+ if (numToDelete == 0) {
+ /*
+ * Should force canonical even for no-op. Remember Tcl_Obj unshared
+ * so OK to invalidate string rep
+ */
+ /* T:listrep-1.10,2.8 */
+ TclInvalidateStringRep(listObj);
+ return TCL_OK;
+ }
+ if (first == 0) {
+ /* Delete from front, so return tail. */
+ /* T:listrep-1.{4,5},2.{4,5},3.{15,16},4.7 */
+ ListRep tailRep;
+ ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep);
+ ListObjReplaceRepAndInvalidate(listObj, &tailRep);
+ return TCL_OK;
+ } else if ((first+numToDelete) >= origListLen) {
+ /* Delete from tail, so return head */
+ /* T:listrep-1.{8,9},2.{6,7},3.{17,18},4.8 */
+ ListRep headRep;
+ ListRepRange(&listRep, 0, first-1, 0, &headRep);
+ ListObjReplaceRepAndInvalidate(listObj, &headRep);
+ return TCL_OK;
+ }
+ /* Deletion from middle. Fall through to general case */
}
- if (count < 0) {
- count = 0;
- } else if (count > LIST_MAX /* Handle integer overflow */
- || numElems < first+count) {
- count = numElems - first;
- }
+ /* Garbage collect before checking the pure insert optimization */
+ ListRepFreeUnreferenced(&listRep);
- if (objc > LIST_MAX - (numElems - count)) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "max length of a Tcl list (%d elements) exceeded",
- LIST_MAX));
+ /*
+ * Check Case (2) - pure inserts under certain conditions:
+ */
+ if (numToDelete == 0) {
+ /* Case (2a) - Append to list. */
+ if (first == origListLen) {
+ /* T:listrep-1.11,2.9,3.{5,6},2.2.1 */
+ return TclListObjAppendElements(
+ interp, listObj, numToInsert, insertObjs);
+ }
+
+ /*
+ * Case (2b) - pure inserts at front under some circumstances
+ * (i) Insertion must be at head of list
+ * (ii) The list's span must be at head of the in-use slots in the store
+ * (iii) There must be unused room at front of the store
+ * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not
+ * affect the other Tcl_Obj's referencing this ListStore.
+ */
+ if (first == 0 && /* (i) */
+ ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */
+ numToInsert <= listRep.storePtr->firstUsed /* (iii) */
+ ) {
+ ListSizeT newLen;
+ LIST_ASSERT(numToInsert); /* Else would have returned above */
+ listRep.storePtr->firstUsed -= numToInsert;
+ ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed],
+ numToInsert,
+ insertObjs);
+ listRep.storePtr->numUsed += numToInsert;
+ newLen = listRep.spanPtr->spanLength + numToInsert;
+ if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
+ /* An unshared span record, re-use it */
+ /* T:listrep-3.1 */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = newLen;
+ } else {
+ /* Need a new span record */
+ if (listRep.storePtr->firstUsed == 0) {
+ listRep.spanPtr = NULL;
+ } else {
+ /* T:listrep-4.3 */
+ listRep.spanPtr =
+ ListSpanNew(listRep.storePtr->firstUsed, newLen);
+ }
+ }
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
+ return TCL_OK;
}
- return TCL_ERROR;
}
- isShared = (listRepPtr->refCount > 1);
- numRequired = numElems - count + objc; /* Known <= LIST_MAX */
- needGrow = numRequired > listRepPtr->maxElemCount;
- for (i = 0; i < objc; i++) {
- Tcl_IncrRefCount(objv[i]);
+ /* Just for readability of the code */
+ lenChange = numToInsert - numToDelete;
+ leadSegmentLen = first;
+ tailSegmentLen = origListLen - (first + numToDelete);
+ numFreeSlots = listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
+
+ /*
+ * Before further processing, if unshared, try and reallocate to avoid
+ * new allocation below. This avoids expensive ref count manipulation
+ * later by not having to go through the ListRepInit and
+ * ListObjReplaceAndInvalidate below.
+ * TODO - we could be smarter about the reallocate. Use of realloc
+ * means all new free space is at the back. Instead, the realloc could
+ * be an explicit alloc and memmove which would let us redistribute
+ * free space.
+ */
+ if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) {
+ /* T:listrep-1.{1,3,14,18,21},3.{3,10,11,14,27,32,41} */
+ ListStore *newStorePtr =
+ ListStoreReallocate(listRep.storePtr, origListLen + lenChange);
+ if (newStorePtr == NULL) {
+ return MemoryAllocationError(interp,
+ LIST_SIZE(origListLen + lenChange));
+ }
+ listRep.storePtr = newStorePtr;
+ numFreeSlots =
+ listRep.storePtr->numAllocated - listRep.storePtr->numUsed;
+ /*
+ * WARNING: at this point the Tcl_Obj internal rep potentially
+ * points to freed storage if the reallocation returned a
+ * different location. Overwrite it to bring it back in sync.
+ */
+ ListObjStompRep(listObj, &listRep);
}
- if (needGrow && !isShared) {
- /* Try to use realloc */
- List *newPtr = NULL;
- int attempt = 2 * numRequired;
- if (attempt <= LIST_MAX) {
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ /*
+ * Case (3) a new ListStore is required
+ * (a) The passed-in ListStore is shared
+ * (b) There is not enough free space in the unshared passed-in ListStore
+ * (c) The new unshared size is much "smaller" (TODO) than the allocated space
+ * TODO - for unshared case ONLY, consider a "move" based implementation
+ */
+ if (ListRepIsShared(&listRep) || /* 3a */
+ numFreeSlots < lenChange || /* 3b */
+ (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */
+ ) {
+ ListRep newRep;
+ Tcl_Obj **toObjs;
+ listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
+ ListRepInit(origListLen + lenChange,
+ NULL,
+ LISTREP_PANIC_ON_FAIL | favor,
+ &newRep);
+ toObjs = ListRepSlotPtr(&newRep, 0);
+ if (leadSegmentLen > 0) {
+ /* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */
+ ObjArrayCopy(toObjs, leadSegmentLen, listObjs);
}
- if (newPtr == NULL) {
- attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
- if (attempt > LIST_MAX) {
- attempt = LIST_MAX;
- }
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ if (numToInsert > 0) {
+ /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */
+ ObjArrayCopy(&toObjs[leadSegmentLen],
+ numToInsert,
+ insertObjs);
}
- if (newPtr == NULL) {
- attempt = numRequired;
- newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ if (tailSegmentLen > 0) {
+ /* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */
+ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert],
+ tailSegmentLen,
+ &listObjs[leadSegmentLen+numToDelete]);
}
- if (newPtr) {
- listRepPtr = newPtr;
- ListResetInternalRep(listPtr, listRepPtr);
- elemPtrs = listRepPtr->elements;
- listRepPtr->maxElemCount = attempt;
- needGrow = numRequired > listRepPtr->maxElemCount;
+ newRep.storePtr->numUsed = origListLen + lenChange;
+ if (newRep.spanPtr) {
+ /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,9:18} */
+ newRep.spanPtr->spanLength = newRep.storePtr->numUsed;
}
+ LISTREP_CHECK(&newRep);
+ ListObjReplaceRepAndInvalidate(listObj, &newRep);
+ return TCL_OK;
}
- if (!needGrow && !isShared) {
- int shift;
- /*
- * Can use the current List struct. First "delete" count elements
- * starting at first.
- */
+ /*
+ * Case (4) - unshared ListStore with sufficient room.
+ * After deleting elements, there will be a corresponding gap. If this
+ * gap does not match number of insertions, either the lead segment,
+ * or the tail segment, or both will have to be moved.
+ * The general strategy is to move the fewest number of elements. If
+ *
+ * TODO - what about appends to unshared ? Is below sufficiently optimal?
+ */
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = elemPtrs[j];
+ /* Following must hold for unshared listreps after ListRepFreeUnreferenced above */
+ LIST_ASSERT(origListLen == listRep.storePtr->numUsed);
+ LIST_ASSERT(origListLen == ListRepLength(&listRep));
+ LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed);
- TclDecrRefCount(victimPtr);
- }
+ LIST_ASSERT((numToDelete + numToInsert) > 0);
- /*
- * Shift the elements after the last one removed to their new
- * locations.
- */
+ /* Base of slot array holding the list elements */
+ listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)];
- start = first + count;
- numAfterLast = numElems - start;
- shift = objc - count; /* numNewElems - numDeleted */
- if ((numAfterLast > 0) && (shift != 0)) {
- Tcl_Obj **src = elemPtrs + start;
+ /*
+ * Free up elements to be deleted. Before that, increment the ref counts
+ * for objects to be inserted in case there is overlap. T:listobj-11.1
+ */
+ if (numToInsert) {
+ /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
+ ObjArrayIncrRefs(insertObjs, 0, numToInsert);
+ }
+ if (numToDelete) {
+ /* T:listrep-1.{6,7,12:21},3.{19:41} */
+ ObjArrayDecrRefs(listObjs, first, numToDelete);
+ }
- memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*));
- }
- } else {
- /*
- * Cannot use the current List struct; it is shared, too small, or
- * both. Allocate a new struct and insert elements into it.
- */
+ /*
+ * TODO - below the moves are optimized but this may result in needing a
+ * span allocation. Perhaps for small lists, it may be more efficient to
+ * just move everything up front and save on allocating a span.
+ */
- List *oldListRepPtr = listRepPtr;
- Tcl_Obj **oldPtrs = elemPtrs;
- int newMax;
+ /*
+ * Calculate shifts if necessary to accomodate insertions.
+ * NOTE: all indices are relative to listObjs which is not necessarily the
+ * start of the ListStore storage area.
+ *
+ * leadShift - how much to shift the lead segment
+ * tailShift - how much to shift the tail segment
+ * insertTarget - index where to insert.
+ */
- if (needGrow) {
- newMax = 2 * numRequired;
+ if (lenChange == 0) {
+ /* T:listrep-1.{12,15,19},3.{23,28,33}. Exact fit */
+ leadShift = 0;
+ tailShift = 0;
+ } else if (lenChange < 0) {
+ /*
+ * More deletions than insertions. The gap after deletions is large
+ * enough for insertions. Move a segment depending on size.
+ */
+ if (leadSegmentLen > tailSegmentLen) {
+ /* Tail segment smaller. Insert after lead, move tail down */
+ /* T:listrep-1.{7,17,20},3.{21,2229,35} */
+ leadShift = 0;
+ tailShift = lenChange;
} else {
- newMax = listRepPtr->maxElemCount;
+ /* Lead segment smaller. Insert before tail, move lead up */
+ /* T:listrep-1.{6,13,16},3.{19,20,24,34} */
+ leadShift = -lenChange;
+ tailShift = 0;
}
+ } else {
+ LIST_ASSERT(lenChange > 0); /* Reminder */
- listRepPtr = AttemptNewList(NULL, newMax, NULL);
- if (listRepPtr == NULL) {
- unsigned int limit = LIST_MAX - numRequired;
- unsigned int extra = numRequired - numElems
- + TCL_MIN_ELEMENT_GROWTH;
- int growth = (int) ((extra > limit) ? limit : extra);
-
- listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
- if (listRepPtr == NULL) {
- listRepPtr = AttemptNewList(interp, numRequired, NULL);
- if (listRepPtr == NULL) {
- for (i = 0; i < objc; i++) {
- /* See bug 3598580 */
-#if TCL_MAJOR_VERSION > 8
- Tcl_DecrRefCount(objv[i]);
-#else
- objv[i]->refCount--;
-#endif
- }
- return TCL_ERROR;
+ /*
+ * We need to make room for the insertions. Again we have multiple
+ * possibilities. We may be able to get by just shifting one segment
+ * or need to shift both. In the former case, favor shifting the
+ * smaller segment.
+ */
+ int leadSpace = ListRepNumFreeHead(&listRep);
+ int tailSpace = ListRepNumFreeTail(&listRep);
+ int finalFreeSpace = leadSpace + tailSpace - lenChange;
+
+ LIST_ASSERT((leadSpace + tailSpace) >= lenChange);
+ if (leadSpace >= lenChange
+ && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) {
+ /* Move only lead to the front to make more room */
+ /* T:listrep-3.25,36,38, */
+ leadShift = -lenChange;
+ tailShift = 0;
+ /*
+ * Redistribute the remaining free space between the front and
+ * back if either there is no tail space left or if the
+ * entire list is the head anyways. This is an important
+ * optimization for further operations like further asymmetric
+ * insertions.
+ */
+ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) {
+ int postShiftLeadSpace = leadSpace - lenChange;
+ if (postShiftLeadSpace > (finalFreeSpace/2)) {
+ ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2);
+ leadShift -= extraShift;
+ tailShift = -extraShift; /* Move tail to the front as well */
}
- }
- }
-
- ListResetInternalRep(listPtr, listRepPtr);
- listRepPtr->refCount++;
-
- elemPtrs = listRepPtr->elements;
-
- if (isShared) {
+ } /* else T:listrep-3.{7,12,25,38} */
+ LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift);
+ } else if (tailSpace >= lenChange) {
+ /* Move only tail segment to the back to make more room. */
+ /* T:listrep-3.{8,10,11,14,26,27,30,32,37,39,41} */
+ leadShift = 0;
+ tailShift = lenChange;
/*
- * The old struct will remain in place; need new refCounts for the
- * new List struct references. Copy over only the surviving
- * elements.
+ * See comments above. This is analogous.
*/
-
- for (i=0; i < first; i++) {
- elemPtrs[i] = oldPtrs[i];
- Tcl_IncrRefCount(elemPtrs[i]);
- }
- for (i = first + count, j = first + objc;
- j < numRequired; i++, j++) {
- elemPtrs[j] = oldPtrs[i];
- Tcl_IncrRefCount(elemPtrs[j]);
+ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) {
+ int postShiftTailSpace = tailSpace - lenChange;
+ if (postShiftTailSpace > (finalFreeSpace/2)) {
+ /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */
+ ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2);
+ tailShift += extraShift;
+ leadShift = extraShift; /* Move head to the back as well */
+ }
}
-
- oldListRepPtr->refCount--;
+ LIST_ASSERT(tailShift <= tailSpace);
} else {
/*
- * The old struct will be removed; use its inherited refCounts.
+ * Both lead and tail need to be shifted to make room.
+ * Divide remaining free space equally between front and back.
*/
-
- if (first > 0) {
- memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *));
- }
+ /* T:listrep-3.{9,13,31,40} */
+ LIST_ASSERT(leadSpace < lenChange);
+ LIST_ASSERT(tailSpace < lenChange);
/*
- * "Delete" count elements starting at first.
+ * leadShift = leadSpace - (finalFreeSpace/2)
+ * Thus leadShift <= leadSpace
+ * Also,
+ * = leadSpace - (leadSpace + tailSpace - lenChange)/2
+ * = leadSpace/2 - tailSpace/2 + lenChange/2
+ * >= 0 because lenChange > tailSpace
*/
-
- for (j = first; j < first + count; j++) {
- Tcl_Obj *victimPtr = oldPtrs[j];
-
- TclDecrRefCount(victimPtr);
+ leadShift = leadSpace - (finalFreeSpace / 2);
+ tailShift = lenChange - leadShift;
+ if (tailShift > tailSpace) {
+ /* Account for integer division errors */
+ leadShift += 1;
+ tailShift -= 1;
}
-
/*
- * Copy the elements after the last one removed, shifted to their
- * new locations.
+ * Following must be true because otherwise one of the previous
+ * if clauses would have been taken.
*/
-
- start = first + count;
- numAfterLast = numElems - start;
- if (numAfterLast > 0) {
- memcpy(elemPtrs + first + objc, oldPtrs + start,
- (size_t) numAfterLast * sizeof(Tcl_Obj *));
- }
-
- ckfree(oldListRepPtr);
+ LIST_ASSERT(leadShift > 0 && leadShift < lenChange);
+ LIST_ASSERT(tailShift > 0 && tailShift < lenChange);
+ leadShift = -leadShift; /* Lead is actually shifted downward */
}
}
- /*
- * Insert the new elements into elemPtrs before "first".
- */
-
- for (i=0,j=first ; i<objc ; i++,j++) {
- elemPtrs[j] = objv[i];
+ /* Careful about order of moves! */
+ if (leadShift > 0) {
+ /* Will happen when we have to make room at bottom */
+ if (tailShift != 0 && tailSegmentLen != 0) {
+ /* T:listrep-1.{1,3,14,18},3.{2,3,26,27} */
+ ListSizeT tailStart = leadSegmentLen + numToDelete;
+ memmove(&listObjs[tailStart + tailShift],
+ &listObjs[tailStart],
+ tailSegmentLen * sizeof(Tcl_Obj *));
+ }
+ if (leadSegmentLen != 0) {
+ /* T:listrep-1.{3,6,16,18,21},3.{19,20,34} */
+ memmove(&listObjs[leadShift],
+ &listObjs[0],
+ leadSegmentLen * sizeof(Tcl_Obj *));
+ }
+ } else {
+ if (leadShift != 0 && leadSegmentLen != 0) {
+ /* T:listrep-3.{7,9,12,13,31,36,38,40} */
+ memmove(&listObjs[leadShift],
+ &listObjs[0],
+ leadSegmentLen * sizeof(Tcl_Obj *));
+ }
+ if (tailShift != 0 && tailSegmentLen != 0) {
+ /* T:listrep-1.{7,17},3.{8:11,13,14,21,22,35,37,39:41} */
+ ListSizeT tailStart = leadSegmentLen + numToDelete;
+ memmove(&listObjs[tailStart + tailShift],
+ &listObjs[tailStart],
+ tailSegmentLen * sizeof(Tcl_Obj *));
+ }
+ }
+ if (numToInsert) {
+ /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */
+ /* T:listrep-1.{1,3,12:21},3.{2,3,7:14,23:41} */
+ memmove(&listObjs[leadSegmentLen + leadShift],
+ insertObjs,
+ numToInsert * sizeof(Tcl_Obj *));
}
- /*
- * Update the count of elements.
- */
-
- listRepPtr->elemCount = numRequired;
-
- /*
- * Invalidate and free any old representations that may not agree
- * with the revised list's internal representation.
- */
+ listRep.storePtr->firstUsed += leadShift;
+ listRep.storePtr->numUsed = origListLen + lenChange;
+ listRep.storePtr->flags = 0;
- listRepPtr->refCount++;
- TclFreeInternalRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
- listRepPtr->refCount--;
+ if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) {
+ /* An unshared span record, re-use it, even if not required */
+ /* T:listrep-3.{2,3,7:14},3.{19:41} */
+ listRep.spanPtr->spanStart = listRep.storePtr->firstUsed;
+ listRep.spanPtr->spanLength = listRep.storePtr->numUsed;
+ } else {
+ /* Need a new span record */
+ if (listRep.storePtr->firstUsed == 0) {
+ /* T:listrep-1.{7,12,15,17,19,20} */
+ listRep.spanPtr = NULL;
+ } else {
+ /* T:listrep-1.{1,3,6.1,13,14,16,18,21} */
+ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed,
+ listRep.storePtr->numUsed);
+ }
+ }
- TclInvalidateStringRep(listPtr);
+ LISTREP_CHECK(&listRep);
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
@@ -1229,48 +2541,49 @@ Tcl_ListObjReplace(
*
* TclLindexList --
*
- * Implements the 'lindex' command when objc==3.
- *
- * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures
- * the argument format into required form while taking care to manage
- * shimmering so as to tend to keep the most useful internalreps
- * and/or avoid the most expensive conversions.
+ * This procedure handles the 'lindex' command when objc==3.
*
- * Value
+ * Results:
+ * Returns a pointer to the object extracted, or NULL if an error
+ * occurred. The returned object already includes one reference count for
+ * the pointer returned.
*
- * A pointer to the specified element, with its 'refCount' incremented, or
- * NULL if an error occurred.
+ * Side effects:
+ * None.
*
- * Notes
+ * Notes:
+ * This procedure is implemented entirely as a wrapper around
+ * TclLindexFlat. All it does is reconfigure the argument format into the
+ * form required by TclLindexFlat, while taking care to manage shimmering
+ * in such a way that we tend to keep the most useful internalreps and/or
+ * avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* List being unpacked. */
- Tcl_Obj *argPtr) /* Index or index list. */
+ Tcl_Obj *listObj, /* List being unpacked. */
+ Tcl_Obj *argObj) /* Index or index list. */
{
-
- int index; /* Index into the list. */
+ ListSizeT index; /* Index into the list. */
Tcl_Obj *indexListCopy;
- List *listRepPtr;
+ Tcl_Obj **indexObjs;
+ ListSizeT numIndexObjs;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
- * shimmering; see TIP#22 and TIP#33 for the details.
+ * shimmering; if internal rep is already a list do not shimmer it.
+ * see TIP#22 and TIP#33 for the details.
*/
-
- ListGetInternalRep(argPtr, listRepPtr);
- if ((listRepPtr == NULL)
- && TclGetIntForIndexM(NULL , argPtr, INT_MAX - 1, &index) == TCL_OK) {
+ if (!TclHasInternalRep(argObj, &tclListType)
+ && TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index)
+ == TCL_OK) {
/*
* argPtr designates a single index.
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
/*
@@ -1285,61 +2598,61 @@ TclLindexList(
* implementation does not.
*/
- indexListCopy = TclListObjCopy(NULL, argPtr);
+ indexListCopy = TclListObjCopy(NULL, argObj);
if (indexListCopy == NULL) {
/*
- * argPtr designates something that is neither an index nor a
- * well-formed list. Report the error via TclLindexFlat.
+ * The argument is neither an index nor a well-formed list.
+ * Report the error via TclLindexFlat.
+ * TODO - This is as original. why not directly return an error?
*/
-
- return TclLindexFlat(interp, listPtr, 1, &argPtr);
+ return TclLindexFlat(interp, listObj, 1, &argObj);
}
- ListGetInternalRep(indexListCopy, listRepPtr);
-
- assert(listRepPtr != NULL);
-
- listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
- listRepPtr->elements);
+ ListObjGetElements(indexListCopy, numIndexObjs, indexObjs);
+ listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs);
Tcl_DecrRefCount(indexListCopy);
- return listPtr;
+ return listObj;
}
/*
*----------------------------------------------------------------------
*
- * TclLindexFlat --
- *
- * The core of the 'lindex' command, with all index
- * arguments presented as a flat list.
+ * TclLindexFlat --
*
- * Value
+ * This procedure is the core of the 'lindex' command, with all index
+ * arguments presented as a flat list.
*
- * A pointer to the object extracted, with its 'refCount' incremented, or
- * NULL if an error occurred. Thus, the calling code will usually do
- * something like:
+ * Results:
+ * Returns a pointer to the object extracted, or NULL if an error
+ * occurred. The returned object already includes one reference count for
+ * the pointer returned.
*
- * Tcl_SetObjResult(interp, result);
- * Tcl_DecrRefCount(result);
+ * Side effects:
+ * None.
*
+ * Notes:
+ * The reference count of the returned object includes one reference
+ * corresponding to the pointer returned. Thus, the calling code will
+ * usually do something like:
+ * Tcl_SetObjResult(interp, result);
+ * Tcl_DecrRefCount(result);
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLindexFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* Tcl object representing the list. */
- int indexCount, /* Count of indices. */
+ Tcl_Obj *listObj, /* Tcl object representing the list. */
+ ListSizeT indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
- int i;
+ ListSizeT i;
- Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(listObj);
- for (i=0 ; i<indexCount && listPtr ; i++) {
- int index, listLen = 0;
+ for (i=0 ; i<indexCount && listObj ; i++) {
+ ListSizeT index, listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
@@ -1348,18 +2661,16 @@ TclLindexFlat(
* while we are still using it. See test lindex-8.4.
*/
- sublistCopy = TclListObjCopy(interp, listPtr);
- Tcl_DecrRefCount(listPtr);
- listPtr = NULL;
+ sublistCopy = TclListObjCopy(interp, listObj);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
if (sublistCopy == NULL) {
- /*
- * The sublist is not a list at all => error.
- */
-
+ /* The sublist is not a list at all => error. */
break;
}
- TclListObjGetElementsM(NULL, sublistCopy, &listLen, &elemPtrs);
+ LIST_ASSERT_TYPE(sublistCopy);
+ ListObjGetElements(sublistCopy, listLen, elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
@@ -1370,26 +2681,24 @@ TclLindexFlat(
*/
while (++i < indexCount) {
- if (TclGetIntForIndexM(interp, indexArray[i], INT_MAX - 1, &index)
+ if (TclGetIntForIndexM(
+ interp, indexArray[i], ListSizeT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
- TclNewObj(listPtr);
+ TclNewObj(listObj);
} else {
- /*
- * Extract the pointer to the appropriate element.
- */
-
- listPtr = elemPtrs[index];
+ /* Extract the pointer to the appropriate element. */
+ listObj = elemPtrs[index];
}
- Tcl_IncrRefCount(listPtr);
+ Tcl_IncrRefCount(listObj);
}
Tcl_DecrRefCount(sublistCopy);
}
- return listPtr;
+ return listObj;
}
/*
@@ -1397,34 +2706,39 @@ TclLindexFlat(
*
* TclLsetList --
*
- * The core of [lset] when objc == 4. Objv[2] may be either a
+ * Core of the 'lset' command when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
* It also handles 'lpop' when given a NULL value.
*
- * Implemented entirely as a wrapper around 'TclLindexFlat', as described
- * for 'TclLindexList'.
+ * Results:
+ * Returns the new value of the list variable, or NULL if there was an
+ * error. The returned object includes one reference count for the
+ * pointer returned.
*
- * Value
+ * Side effects:
+ * None.
*
- * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if
- * there was an error.
+ * Notes:
+ * This procedure is implemented entirely as a wrapper around
+ * TclLsetFlat. All it does is reconfigure the argument format into the
+ * form required by TclLsetFlat, while taking care to manage shimmering
+ * in such a way that we tend to keep the most useful internalreps and/or
+ * avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* Pointer to the list being modified. */
- Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
+ Tcl_Obj *listObj, /* Pointer to the list being modified. */
+ Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */
+ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
- int indexCount = 0; /* Number of indices in the index list. */
+ ListSizeT indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
- Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
- int index; /* Current index in the list - discarded. */
+ Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */
+ ListSizeT index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
- List *listRepPtr;
/*
* Determine whether the index arg designates a list or a single index.
@@ -1432,36 +2746,33 @@ TclLsetList(
* shimmering; see TIP #22 and #23 for details.
*/
- ListGetInternalRep(indexArgPtr, listRepPtr);
- if (listRepPtr == NULL
- && TclGetIntForIndexM(NULL, indexArgPtr, INT_MAX - 1, &index) == TCL_OK) {
- /*
- * indexArgPtr designates a single index.
- */
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
-
+ if (!TclHasInternalRep(indexArgObj, &tclListType)
+ && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_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);
}
- indexListCopy = TclListObjCopy(NULL, indexArgPtr);
+ indexListCopy = TclListObjCopy(NULL, indexArgObj);
if (indexListCopy == NULL) {
/*
* indexArgPtr designates something that is neither an index nor a
* well formed list. Report the error via TclLsetFlat.
*/
-
- return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
+ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj);
}
- TclListObjGetElementsM(NULL, indexArgPtr, &indexCount, &indices);
+ LIST_ASSERT_TYPE(indexListCopy);
+ ListObjGetElements(indexListCopy, indexCount, indices);
/*
* Let TclLsetFlat handle the actual lset'ting.
*/
- retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);
+ retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj);
Tcl_DecrRefCount(indexListCopy);
- return retValuePtr;
+ return retValueObj;
}
/*
@@ -1472,109 +2783,106 @@ TclLsetList(
* Core engine of the 'lset' command.
* It also handles 'lpop' when given a NULL value.
*
- * Value
- *
- * The resulting list
- *
- * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not
- * duplicated, its 'refCount' is incremented. The reference count of
- * an unduplicated object is therefore 2 (one for the returned pointer
- * and one for the variable that holds it). The reference count of a
- * duplicate object is 1, reflecting that result is the only active
- * reference. The caller is expected to store the result in the
- * variable and decrement its reference count. (INST_STORE_* does
- * exactly this.)
- *
- * NULL
- *
- * An error occurred. If 'listPtr' was duplicated, the reference
- * count on the duplicate is decremented so that it is 0, causing any
- * memory allocated by this function to be freed.
- *
- *
- * Effect
- *
- * On entry, the reference count of 'listPtr' does not reflect any
- * references held on the stack. The first action of this function is to
- * determine whether 'listPtr' is shared and to create a duplicate
- * unshared copy if it is. The reference count of the duplicate is
- * incremented. At this point, the reference count is 1 in either case so
- * that the object is considered unshared.
+ * Results:
+ * Returns the new value of the list variable, or NULL if an error
+ * occurred. The returned object includes one reference count for the
+ * pointer returned.
*
- * The unshared list is altered directly to produce the result.
- * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string
- * representations must be spoilt by threading via 'ptr2' of the
- * two-pointer internal representation. On entry to 'TclLsetFlat', the
- * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
- * Tcl_Obj that has been modified is set to NULL.
+ * Side effects:
+ * On entry, the reference count of the variable value does not reflect
+ * any references held on the stack. The first action of this function is
+ * to determine whether the object is shared, and to duplicate it if it
+ * is. The reference count of the duplicate is incremented. At this
+ * point, the reference count will be 1 for either case, so that the
+ * object will appear to be unshared.
+ *
+ * If an error occurs, and the object has been duplicated, the reference
+ * count on the duplicate is decremented so that it is now 0: this
+ * dismisses any memory that was allocated by this function.
+ *
+ * If no error occurs, the reference count of the original object is
+ * incremented if the object has not been duplicated, and nothing is done
+ * to a reference count of the duplicate. Now the reference count of an
+ * unduplicated object is 2 (the returned pointer, plus the one stored in
+ * the variable). The reference count of a duplicate object is 1,
+ * reflecting that the returned pointer is the only active reference. The
+ * caller is expected to store the returned value back in the variable
+ * and decrement its reference count. (INST_STORE_* does exactly this.)
*
*----------------------------------------------------------------------
*/
-
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
- Tcl_Obj *listPtr, /* Pointer to the list being modified. */
- int indexCount, /* Number of index args. */
+ Tcl_Obj *listObj, /* Pointer to the list being modified. */
+ ListSizeT indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
- Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
+ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */
{
- int index, len;
+ ListSizeT index, len;
int result;
- Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
- Tcl_ObjInternalRep *irPtr;
+ Tcl_Obj *subListObj, *retValueObj;
+ Tcl_Obj *pendingInvalidates[10];
+ Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates;
+ ListSizeT numPendingInvalidates = 0;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
- * [lpop] does not use this but protect for NULL valuePtr just in case.
+ * [lpop] does not use this but protect for NULL valueObj just in case.
*/
if (indexCount == 0) {
- if (valuePtr != NULL) {
- Tcl_IncrRefCount(valuePtr);
+ if (valueObj != NULL) {
+ Tcl_IncrRefCount(valueObj);
}
- return valuePtr;
+ return valueObj;
}
/*
* If the list is shared, make a copy we can modify (copy-on-write). We
* use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons:
- * 1) we have not yet confirmed listPtr is actually a list; 2) We make a
+ * 1) we have not yet confirmed listObj is actually a list; 2) We make a
* verbatim copy of any existing string rep, and when we combine that with
* the delayed invalidation of string reps of modified Tcl_Obj's
* implemented below, the outcome is that any error condition that causes
- * this routine to return NULL, will leave the string rep of listPtr and
+ * this routine to return NULL, will leave the string rep of listObj and
* all elements to be unchanged.
*/
- subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
+ subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj;
/*
* Anchor the linked list of Tcl_Obj's whose string reps must be
* invalidated if the operation succeeds.
*/
- retValuePtr = subListPtr;
- chainPtr = NULL;
+ retValueObj = subListObj;
result = TCL_OK;
+ /* Allocate if static array for pending invalidations is too small */
+ if (indexCount
+ > (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) {
+ pendingInvalidatesPtr =
+ (Tcl_Obj **) ckalloc(indexCount * sizeof(*pendingInvalidatesPtr));
+ }
+
/*
* Loop through all the index arguments, and for each one dive into the
* appropriate sublist.
*/
do {
- int elemCount;
+ ListSizeT elemCount;
Tcl_Obj *parentList, **elemPtrs;
/*
* Check for the possible error conditions...
*/
- if (TclListObjGetElementsM(interp, subListPtr, &elemCount, &elemPtrs)
- != TCL_OK) {
+ if (TclListObjGetElementsM(interp, subListObj, &elemCount, &elemPtrs)
+ != TCL_OK) {
/* ...the sublist we're indexing into isn't a list at all. */
result = TCL_ERROR;
break;
@@ -1586,22 +2894,27 @@ TclLsetFlat(
*/
if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
- != TCL_OK) {
+ != TCL_OK) {
/* ...the index we're trying to use isn't an index at all. */
result = TCL_ERROR;
- indexArray++;
+ indexArray++; /* Why bother with this increment? TBD */
break;
}
indexArray++;
if (index < 0 || index > elemCount
- || (valuePtr == NULL && index >= elemCount)) {
+ || (valueObj == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "index \"%s\" out of range", Tcl_GetString(indexArray[-1])));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
- "OUTOFRANGE", NULL);
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("index \"%s\" out of range",
+ Tcl_GetString(indexArray[-1])));
+ Tcl_SetErrorCode(interp,
+ "TCL",
+ "VALUE",
+ "INDEX"
+ "OUTOFRANGE",
+ NULL);
}
result = TCL_ERROR;
break;
@@ -1609,128 +2922,129 @@ TclLsetFlat(
/*
* No error conditions. As long as we're not yet on the last index,
- * determine the next sublist for the next pass through the loop, and
- * take steps to make sure it is an unshared copy, as we intend to
- * modify it.
+ * determine the next sublist for the next pass through the loop,
+ * and take steps to make sure it is an unshared copy, as we intend
+ * to modify it.
*/
if (--indexCount) {
- parentList = subListPtr;
+ parentList = subListObj;
if (index == elemCount) {
- TclNewObj(subListPtr);
+ TclNewObj(subListObj);
} else {
- subListPtr = elemPtrs[index];
+ subListObj = elemPtrs[index];
}
- if (Tcl_IsShared(subListPtr)) {
- subListPtr = Tcl_DuplicateObj(subListPtr);
+ if (Tcl_IsShared(subListObj)) {
+ subListObj = Tcl_DuplicateObj(subListObj);
}
/*
* Replace the original elemPtr[index] in parentList with a copy
* we know to be unshared. This call will also deal with the
* situation where parentList shares its internalrep with other
- * Tcl_Obj's. Dealing with the shared internalrep case can cause
- * subListPtr to become shared again, so detect that case and make
- * and store another copy.
+ * Tcl_Obj's. Dealing with the shared internalrep case can
+ * cause subListObj to become shared again, so detect that case
+ * and make and store another copy.
*/
if (index == elemCount) {
- Tcl_ListObjAppendElement(NULL, parentList, subListPtr);
+ Tcl_ListObjAppendElement(NULL, parentList, subListObj);
} else {
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ TclListObjSetElement(NULL, parentList, index, subListObj);
}
- if (Tcl_IsShared(subListPtr)) {
- subListPtr = Tcl_DuplicateObj(subListPtr);
- TclListObjSetElement(NULL, parentList, index, subListPtr);
+ if (Tcl_IsShared(subListObj)) {
+ subListObj = Tcl_DuplicateObj(subListObj);
+ TclListObjSetElement(NULL, parentList, index, subListObj);
}
/*
- * The TclListObjSetElement() calls do not spoil the string rep of
- * parentList, and that's fine for now, since all we've done so
- * far is replace a list element with an unshared copy. The list
- * value remains the same, so the string rep. is still valid, and
- * unchanged, which is good because if this whole routine returns
- * NULL, we'd like to leave no change to the value of the lset
- * variable. Later on, when we set valuePtr in its proper place,
- * then all containing lists will have their values changed, and
- * will need their string reps spoiled. We maintain a list of all
- * those Tcl_Obj's (via a little internalrep surgery) so we can spoil
- * them at that time.
+ * The TclListObjSetElement() calls do not spoil the string rep
+ * of parentList, and that's fine for now, since all we've done
+ * so far is replace a list element with an unshared copy. The
+ * list value remains the same, so the string rep. is still
+ * valid, and unchanged, which is good because if this whole
+ * routine returns NULL, we'd like to leave no change to the
+ * value of the lset variable. Later on, when we set valueObj
+ * in its proper place, then all containing lists will have
+ * their values changed, and will need their string reps
+ * spoiled. We maintain a list of all those Tcl_Obj's (via a
+ * little internalrep surgery) so we can spoil them at that
+ * time.
*/
- irPtr = TclFetchInternalRep(parentList, &tclListType);
- irPtr->twoPtrValue.ptr2 = chainPtr;
- chainPtr = parentList;
+ pendingInvalidatesPtr[numPendingInvalidates] = parentList;
+ ++numPendingInvalidates;
}
} while (indexCount > 0);
/*
* Either we've detected and error condition, and exited the loop with
* result == TCL_ERROR, or we've successfully reached the last index, and
- * we're ready to store valuePtr. In either case, we need to clean up our
- * string spoiling list of Tcl_Obj's.
+ * we're ready to store valueObj. On success, we need to invalidate
+ * the string representations of intermediate lists whose contained
+ * list element would have changed.
*/
+ if (result == TCL_OK) {
+ while (numPendingInvalidates > 0) {
+ Tcl_Obj *objPtr;
- while (chainPtr) {
- Tcl_Obj *objPtr = chainPtr;
- List *listRepPtr;
+ --numPendingInvalidates;
+ objPtr = pendingInvalidatesPtr[numPendingInvalidates];
- /*
- * Clear away our internalrep surgery mess.
- */
-
- irPtr = TclFetchInternalRep(objPtr, &tclListType);
- listRepPtr = (List *)irPtr->twoPtrValue.ptr1;
- chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
-
- if (result == TCL_OK) {
-
- /*
- * We're going to store valuePtr, so spoil string reps of all
- * containing lists.
- */
-
- listRepPtr->refCount++;
- TclFreeInternalRep(objPtr);
- ListSetInternalRep(objPtr, listRepPtr);
- listRepPtr->refCount--;
-
- TclInvalidateStringRep(objPtr);
- } else {
- irPtr->twoPtrValue.ptr2 = NULL;
+ if (result == TCL_OK) {
+ /*
+ * We're going to store valueObj, so spoil string reps of all
+ * containing lists.
+ * TODO - historically, the storing of the internal rep was done
+ * because the ptr2 field of the internal rep was used to chain
+ * objects whose string rep needed to be invalidated. Now this
+ * is no longer the case, so replacing of the internal rep
+ * should not be needed. The TclInvalidateStringRep should
+ * suffice. Formulate a test case before changing.
+ */
+ ListRep objInternalRep;
+ TclListObjGetRep(NULL, objPtr, &objInternalRep);
+ ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep);
+ }
}
}
+ if (pendingInvalidatesPtr != pendingInvalidates)
+ ckfree(pendingInvalidatesPtr);
+
if (result != TCL_OK) {
/*
* Error return; message is already in interp. Clean up any excess
* memory.
*/
- if (retValuePtr != listPtr) {
- Tcl_DecrRefCount(retValuePtr);
+ if (retValueObj != listObj) {
+ Tcl_DecrRefCount(retValueObj);
}
return NULL;
}
/*
- * Store valuePtr in proper sublist and return. The TCL_INDEX_NONE is
- * to avoid a compiler warning (not a problem because we checked that
- * we have a proper list - or something convertible to one - above).
+ * Store valueObj in proper sublist and return. The -1 is to avoid a
+ * compiler warning (not a problem because we checked that we have a
+ * proper list - or something convertible to one - above).
*/
- len = TCL_INDEX_NONE;
- TclListObjLengthM(NULL, subListPtr, &len);
- if (valuePtr == NULL) {
- Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL);
+ len = -1;
+ TclListObjLengthM(NULL, subListObj, &len);
+ if (valueObj == NULL) {
+ /* T:listrep-1.{4.2,5.4,6.1,7.1,8.3},2.{4,5}.4 */
+ Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL);
} else if (index == len) {
- Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
+ /* T:listrep-1.2.1,2.{2.3,9.3},3.{4,5,6}.3 */
+ Tcl_ListObjAppendElement(NULL, subListObj, valueObj);
} else {
- TclListObjSetElement(NULL, subListPtr, index, valuePtr);
- TclInvalidateStringRep(subListPtr);
+ /* T:listrep-1.{12.1,15.1,19.1},2.{10,13,16}.1 */
+ TclListObjSetElement(NULL, subListObj, index, valueObj);
+ TclInvalidateStringRep(subListObj);
}
- Tcl_IncrRefCount(retValuePtr);
- return retValuePtr;
+ Tcl_IncrRefCount(retValueObj);
+ return retValueObj;
}
/*
@@ -1738,93 +3052,53 @@ TclLsetFlat(
*
* TclListObjSetElement --
*
- * Set a single element of a list to a specified value.
- *
- * It is the caller's responsibility to invalidate the string
- * representation of the 'listPtr'.
- *
- * Value
+ * Set a single element of a list to a specified value
*
- * TCL_OK
- *
- * Success.
- *
- * TCL_ERROR
- *
- * 'listPtr' does not refer to a list object and cannot be converted
- * to one. An error message will be left in the interpreter result if
- * interp is not NULL.
- *
- * TCL_ERROR
- *
- * An index designates an element outside the range [0..listLength-1],
- * where 'listLength' is the count of elements in the list object
- * designated by 'listPtr'. An error message is left in the
- * interpreter result.
- *
- * Effect
- *
- * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If
- * 'listPtr' is not already of type 'tclListType', it is converted and the
- * internal representation is unshared. The 'refCount' of the element at
- * 'index' is decremented and replaced in the list with the 'valuePtr',
- * whose 'refCount' in turn is incremented.
+ * Results:
+ * The return value is normally TCL_OK. If listObj does not refer to a
+ * list object and cannot be converted to one, TCL_ERROR is returned and
+ * an error message will be left in the interpreter result if interp is
+ * not NULL. Similarly, if index designates an element outside the range
+ * [0..listLength-1], where listLength is the count of elements in the
+ * list object designated by listObj, TCL_ERROR is returned and an error
+ * message is left in the interpreter result.
*
+ * Side effects:
+ * Tcl_Panic if listObj designates a shared object. Otherwise, attempts
+ * to convert it to a list with a non-shared internal rep. Decrements the
+ * ref count of the object at the specified index within the list,
+ * replaces with the object designated by valueObj, and increments the
+ * ref count of the replacement object.
*
*----------------------------------------------------------------------
*/
-
int
TclListObjSetElement(
Tcl_Interp *interp, /* Tcl interpreter; used for error reporting
* if not NULL. */
- Tcl_Obj *listPtr, /* List object in which element should be
+ Tcl_Obj *listObj, /* List object in which element should be
* stored. */
- int index, /* Index of element to store. */
- Tcl_Obj *valuePtr) /* Tcl object to store in the designated list
+ ListSizeT index, /* Index of element to store. */
+ Tcl_Obj *valueObj) /* Tcl object to store in the designated list
* element. */
{
- List *listRepPtr; /* Internal representation of the list being
- * modified. */
- Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
- int elemCount; /* Number of elements in the list. */
+ ListRep listRep;
+ Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */
+ ListSizeT elemCount; /* Number of elements in the list. */
- /*
- * Ensure that the listPtr parameter designates an unshared list.
- */
+ /* Ensure that the listObj parameter designates an unshared list. */
- if (Tcl_IsShared(listPtr)) {
+ if (Tcl_IsShared(listObj)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
- ListGetInternalRep(listPtr, listRepPtr);
- if (listRepPtr == NULL) {
- int result;
- int length;
-
- (void) Tcl_GetStringFromObj(listPtr, &length);
- if (length == 0) {
- if (interp != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "index \"%d\" out of range", index));
- Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
- "OUTOFRANGE", NULL);
- }
- return TCL_ERROR;
- }
- result = SetListFromAny(interp, listPtr);
- if (result != TCL_OK) {
- return result;
- }
- ListGetInternalRep(listPtr, listRepPtr);
+ if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) {
+ return TCL_ERROR;
}
- elemCount = listRepPtr->elemCount;
-
- /*
- * Ensure that the index is in bounds.
- */
+ elemCount = ListRepLength(&listRep);
+ /* Ensure that the index is in bounds. */
if (index<0 || index>=elemCount) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -1836,65 +3110,33 @@ TclListObjSetElement(
}
/*
- * If the internal rep is shared, replace it with an unshared copy.
+ * Note - garbage collect this only AFTER checking indices above.
+ * Do not want to modify listrep and then not store it back in listObj.
*/
+ ListRepFreeUnreferenced(&listRep);
- if (listRepPtr->refCount > 1) {
- Tcl_Obj **dst, **src = listRepPtr->elements;
- List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL);
-
- if (newPtr == NULL) {
- newPtr = AttemptNewList(interp, elemCount, NULL);
- if (newPtr == NULL) {
- return TCL_ERROR;
- }
- }
- newPtr->refCount++;
- newPtr->elemCount = elemCount;
- newPtr->canonicalFlag = listRepPtr->canonicalFlag;
-
- dst = newPtr->elements;
- while (elemCount--) {
- *dst = *src++;
- Tcl_IncrRefCount(*dst++);
- }
-
- listRepPtr->refCount--;
+ /* Replace a shared internal rep with an unshared copy */
+ if (listRep.storePtr->refCount > 1) {
+ ListRep newInternalRep;
+ /* T:listrep-2.{10,13,16}.1 */
+ /* TODO - leave extra space? */
+ ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL);
+ listRep = newInternalRep;
+ } /* else T:listrep-1.{12.1,15.1,19.1} */
- listRepPtr = newPtr;
- ListResetInternalRep(listPtr, listRepPtr);
- }
- elemPtrs = listRepPtr->elements;
+ /* Retrieve element array AFTER potential cloning above */
+ ListRepElements(&listRep, elemCount, elemPtrs);
/*
- * Add a reference to the new list element.
+ * Add a reference to the new list element and remove from old before
+ * replacing it. Order is important!
*/
-
- Tcl_IncrRefCount(valuePtr);
-
- /*
- * Remove a reference from the old list element.
- */
-
+ Tcl_IncrRefCount(valueObj);
Tcl_DecrRefCount(elemPtrs[index]);
+ elemPtrs[index] = valueObj;
- /*
- * Stash the new object in the list.
- */
-
- elemPtrs[index] = valuePtr;
-
- /*
- * Invalidate outdated internalreps.
- */
-
- ListGetInternalRep(listPtr, listRepPtr);
- listRepPtr->refCount++;
- TclFreeInternalRep(listPtr);
- ListSetInternalRep(listPtr, listRepPtr);
- listRepPtr->refCount--;
-
- TclInvalidateStringRep(listPtr);
+ /* Internal rep may be cloned so replace */
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
return TCL_OK;
}
@@ -1904,34 +3146,33 @@ TclListObjSetElement(
*
* FreeListInternalRep --
*
- * Deallocate the storage associated with the internal representation of a
- * a list object.
+ * Deallocate the storage associated with a list object's internal
+ * representation.
*
- * Effect
+ * Results:
+ * None.
*
+ * Side effects:
* Frees listPtr's List* internal representation, if no longer shared.
* May decrement the ref counts of element objects, which may free them.
*
*----------------------------------------------------------------------
*/
-
static void
FreeListInternalRep(
- Tcl_Obj *listPtr) /* List object with internal rep to free. */
+ Tcl_Obj *listObj) /* List object with internal rep to free. */
{
- List *listRepPtr;
-
- ListGetInternalRep(listPtr, listRepPtr);
- assert(listRepPtr != NULL);
-
- if (listRepPtr->refCount-- <= 1) {
- Tcl_Obj **elemPtrs = listRepPtr->elements;
- int i, numElems = listRepPtr->elemCount;
-
- for (i = 0; i < numElems; i++) {
- Tcl_DecrRefCount(elemPtrs[i]);
- }
- ckfree(listRepPtr);
+ ListRep listRep;
+
+ ListObjGetRep(listObj, &listRep);
+ if (listRep.storePtr->refCount-- <= 1) {
+ ObjArrayDecrRefs(
+ listRep.storePtr->slots,
+ listRep.storePtr->firstUsed, listRep.storePtr->numUsed);
+ ckfree(listRep.storePtr);
+ }
+ if (listRep.spanPtr) {
+ ListSpanDecrRefs(listRep.spanPtr);
}
}
@@ -1940,26 +3181,25 @@ FreeListInternalRep(
*
* DupListInternalRep --
*
- * Initialize the internal representation of a list 'Tcl_Obj' to share the
+ * Initialize the internal representation of a list Tcl_Obj to share the
* internal representation of an existing list object.
*
- * Effect
+ * Results:
+ * None.
*
- * The 'refCount' of the List internal rep is incremented.
+ * Side effects:
+ * The reference count of the List internal rep is incremented.
*
*----------------------------------------------------------------------
*/
-
static void
DupListInternalRep(
- Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+ Tcl_Obj *srcObj, /* Object with internal rep to copy. */
+ Tcl_Obj *copyObj) /* Object with internal rep to set. */
{
- List *listRepPtr;
-
- ListGetInternalRep(srcPtr, listRepPtr);
- assert(listRepPtr != NULL);
- ListSetInternalRep(copyPtr, listRepPtr);
+ ListRep listRep;
+ ListObjGetRep(srcObj, &listRep);
+ ListObjOverwriteRep(copyObj, &listRep);
}
/*
@@ -1967,31 +3207,26 @@ DupListInternalRep(
*
* SetListFromAny --
*
- * Convert any object to a list.
- *
- * Value
- *
- * TCL_OK
- *
- * Success. The internal representation of 'objPtr' is set, and the type
- * of 'objPtr' is 'tclListType'.
+ * Attempt to generate a list internal form for the Tcl object "objPtr".
*
- * TCL_ERROR
- *
- * An error occured during conversion. An error message is left in the
- * interpreter's result if 'interp' is not NULL.
+ * Results:
+ * The return value is TCL_OK or TCL_ERROR. If an error occurs during
+ * conversion, an error message is left in the interpreter's result
+ * unless "interp" is NULL.
*
+ * Side effects:
+ * If no error occurs, a list is stored as "objPtr"s internal
+ * representation.
*
*----------------------------------------------------------------------
*/
-
static int
SetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
- List *listRepPtr;
Tcl_Obj **elemPtrs;
+ ListRep listRep;
/*
* Dictionaries are a special case; they have a string representation such
@@ -2005,7 +3240,7 @@ SetListFromAny(
Tcl_Obj *keyPtr, *valuePtr;
Tcl_DictSearch search;
int done;
- int size;
+ ListSizeT size;
/*
* Create the new list representation. Note that we do not need to do
@@ -2017,17 +3252,22 @@ SetListFromAny(
*/
Tcl_DictObjSize(NULL, objPtr, &size);
- listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL);
- if (!listRepPtr) {
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? 2 * size : 1, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- listRepPtr->elemCount = 2 * size;
- /*
- * Populate the list representation.
- */
+ 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 = 2 * size;
+
+ /* Populate the list representation. */
- elemPtrs = listRepPtr->elements;
+ elemPtrs = listRep.storePtr->slots;
Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
while (!done) {
*elemPtrs++ = keyPtr;
@@ -2042,22 +3282,30 @@ SetListFromAny(
* because it can be done an order of magnitude faster
* and may occur frequently.
*/
- Tcl_WideInt wideLen = TclArithSeriesObjLength(objPtr), j;
- listRepPtr = AttemptNewList(interp, wideLen, NULL);
- if (listRepPtr == NULL) {
+ ListSizeT j, size = TclArithSeriesObjLength(objPtr);
+
+ /* TODO - leave space in front and/or back? */
+ if (ListRepInitAttempt(
+ interp, size > 0 ? size : 1, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- elemPtrs = listRepPtr->elements;
- for (j = 0; j < wideLen; j++) {
+
+ LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);
+ LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0);
+
+ listRep.storePtr->numUsed = size;
+ elemPtrs = listRep.storePtr->slots;
+ for (j = 0; j < size; j++) {
if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) {
return TCL_ERROR;
}
Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */
}
- listRepPtr->elemCount = wideLen;
} else {
- int estCount, length;
+ ListSizeT estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
@@ -2068,29 +3316,32 @@ SetListFromAny(
estCount = TclMaxListLength(nextElem, length, &limit);
estCount += (estCount == 0); /* Smallest list struct holds 1
* element. */
- listRepPtr = AttemptNewList(interp, estCount, NULL);
- if (listRepPtr == NULL) {
+ /* TODO - allocate additional space? */
+ if (ListRepInitAttempt(interp, estCount, NULL, &listRep)
+ != TCL_OK) {
return TCL_ERROR;
}
- elemPtrs = listRepPtr->elements;
- /*
- * Each iteration, parse and store a list element.
- */
+ LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);
+
+ elemPtrs = listRep.storePtr->slots;
+
+ /* Each iteration, parse and store a list element. */
while (nextElem < limit) {
const char *elemStart;
char *check;
- int elemSize;
+ ListSizeT elemSize;
int literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
- fail:
- while (--elemPtrs >= listRepPtr->elements) {
+fail:
+ while (--elemPtrs >= listRep.storePtr->slots) {
Tcl_DecrRefCount(*elemPtrs);
}
- ckfree(listRepPtr);
+ ckfree(listRep.storePtr);
return TCL_ERROR;
}
if (elemStart == limit) {
@@ -2102,11 +3353,7 @@ SetListFromAny(
check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL,
elemSize);
if (elemSize && check == NULL) {
- if (interp) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "cannot construct list, out of memory", -1));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- }
+ MemoryAllocationError(interp, elemSize);
goto fail;
}
if (!literal) {
@@ -2117,16 +3364,29 @@ SetListFromAny(
Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */
}
- listRepPtr->elemCount = elemPtrs - listRepPtr->elements;
+ listRep.storePtr->numUsed =
+ elemPtrs - listRep.storePtr->slots;
}
+ LISTREP_CHECK(&listRep);
+
/*
* Store the new internalRep. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use the old internalRep.
*/
- ListSetInternalRep(objPtr, listRepPtr);
+ /*
+ * Note old string representation NOT to be invalidated.
+ * So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER
+ * IncrRefs so do not use ListObjOverwriteRep
+ */
+ ListRepIncrRefs(&listRep);
+ TclFreeInternalRep(objPtr);
+ objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr;
+ objPtr->typePtr = &tclListType;
+
return TCL_OK;
}
@@ -2135,69 +3395,71 @@ SetListFromAny(
*
* UpdateStringOfList --
*
- * Update the string representation for a list object.
- *
- * Any previously-exising string representation is not invalidated, so
- * storage is lost if this has not been taken care of.
+ * Update the string representation for a list object. Note: This
+ * function does not invalidate an existing old string rep so storage
+ * will be lost if this has not already been done.
*
- * Effect
+ * Results:
+ * None.
*
- * The string representation of 'listPtr' is set to the resulting string.
- * This string will be empty if the list has no elements. It is assumed
- * that the list internal representation is not NULL.
+ * 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.
*
*----------------------------------------------------------------------
*/
-
static void
UpdateStringOfList(
- Tcl_Obj *listPtr) /* List object with string rep to update. */
+ Tcl_Obj *listObj) /* List object with string rep to update. */
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
- int numElems, i, length, bytesNeeded = 0;
+ ListSizeT numElems, i, length, bytesNeeded = 0;
const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
- List *listRepPtr;
+ ListRep listRep;
- ListGetInternalRep(listPtr, listRepPtr);
+ ListObjGetRep(listObj, &listRep);
+ LISTREP_CHECK(&listRep);
- assert(listRepPtr != NULL);
-
- numElems = listRepPtr->elemCount;
+ ListRepElements(&listRep, numElems, elemPtrs);
/*
* 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].
+ * However, we only do this if this is not a spanned list. Marking the
+ * storage canonical for a spanned list make ALL lists using the storage
+ * canonical which is not right. (Consider a list generated from a
+ * string and then this function called for a spanned list generated
+ * from it). On the other hand, a spanned list is always canonical
+ * (never generated from a string) so it does not have to be explicitly
+ * marked as such. The ListObjIsCanonical macro takes this into account.
+ * See the comments there.
*/
+ if (listRep.spanPtr == NULL) {
+ LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */
+ listRep.storePtr->flags |= LISTSTORE_CANONICAL;
+ }
- listRepPtr->canonicalFlag = 1;
-
- /*
- * Handle empty list case first, so rest of the routine is simpler.
- */
+ /* Handle empty list case first, so rest of the routine is simpler. */
if (numElems == 0) {
- Tcl_InitStringRep(listPtr, NULL, 0);
+ Tcl_InitStringRep(listObj, NULL, 0);
return;
}
- /*
- * Pass 1: estimate space, gather flags.
- */
+ /* Pass 1: estimate space, gather flags. */
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
- /*
- * We know numElems <= LIST_MAX, so this is safe.
- */
-
+ /* We know numElems <= LIST_MAX, so this is safe. */
flagPtr = (char *)ckalloc(numElems);
}
- elemPtrs = listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
@@ -2215,7 +3477,7 @@ UpdateStringOfList(
* Pass 2: copy into string rep buffer.
*/
- start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded);
+ start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
@@ -2225,7 +3487,7 @@ UpdateStringOfList(
}
/* Set the string length to what was actually written, the safe choice */
- (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start);
+ (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
ckfree(flagPtr);
@@ -2234,6 +3496,61 @@ UpdateStringOfList(
/*
+ *------------------------------------------------------------------------
+ *
+ * TclListTestObj --
+ *
+ * Returns a list object with a specific internal rep and content.
+ * Used specifically for testing so span can be controlled explicitly.
+ *
+ * Results:
+ * Pointer to the Tcl_Obj containing the list.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclListTestObj (int length, int leadingSpace, int endSpace)
+{
+ if (length < 0)
+ length = 0;
+ if (leadingSpace < 0)
+ leadingSpace = 0;
+ if (endSpace < 0)
+ endSpace = 0;
+
+ ListRep listRep;
+ ListSizeT capacity;
+ Tcl_Obj *listObj;
+
+ TclNewObj(listObj);
+
+ /* Only a test object so ignoring overflow checks */
+ capacity = length + leadingSpace + endSpace;
+ if (capacity == 0) {
+ return listObj;
+ }
+
+ ListRepInit(capacity, NULL, 0, &listRep);
+
+ ListStore *storePtr = listRep.storePtr;
+ int i;
+ for (i = 0; i < length; ++i) {
+ storePtr->slots[i + leadingSpace] = Tcl_NewIntObj(i);
+ Tcl_IncrRefCount(storePtr->slots[i + leadingSpace]);
+ }
+ storePtr->firstUsed = leadingSpace;
+ storePtr->numUsed = length;
+ if (leadingSpace != 0) {
+ listRep.spanPtr = ListSpanNew(leadingSpace, length);
+ }
+ ListObjReplaceRepAndInvalidate(listObj, &listRep);
+ return listObj;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 4941348..a067668 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -1119,6 +1119,8 @@ static const TclIntStubs tclIntStubs = {
TclStaticLibrary, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
TclUnusedStubEntry, /* 259 */
+ TclListTestObj, /* 260 */
+ TclListObjValidate, /* 261 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 9284969..8d106f9 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -273,6 +273,7 @@ static Tcl_ObjCmdProc TestgetvarfullnameCmd;
static Tcl_CmdProc TestinterpdeleteCmd;
static Tcl_CmdProc TestlinkCmd;
static Tcl_ObjCmdProc TestlinkarrayCmd;
+static Tcl_ObjCmdProc TestlistrepCmd;
static Tcl_ObjCmdProc TestlocaleCmd;
static Tcl_CmdProc TestmainthreadCmd;
static Tcl_CmdProc TestsetmainloopCmd;
@@ -656,6 +657,7 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
@@ -3425,6 +3427,158 @@ TestlinkarrayCmd(
/*
*----------------------------------------------------------------------
*
+ * TestlistrepCmd --
+ *
+ * This function is invoked to generate a list object with a specific
+ * internal representation.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestlistrepCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ /* Subcommands supported by this command */
+ const char* subcommands[] = {
+ "new",
+ "describe",
+ "config",
+ "validate",
+ NULL
+ };
+ enum {
+ LISTREP_NEW,
+ LISTREP_DESCRIBE,
+ LISTREP_CONFIG,
+ LISTREP_VALIDATE
+ } cmdIndex;
+ Tcl_Obj *resultObj = NULL;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(
+ interp, objv[1], subcommands, "command", 0, &cmdIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (cmdIndex) {
+ case LISTREP_NEW:
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?");
+ return TCL_ERROR;
+ } else {
+ int length;
+ int leadSpace = 0;
+ int endSpace = 0;
+ if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 4) {
+ if (Tcl_GetIntFromObj(interp, objv[4], &endSpace)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ resultObj = TclListTestObj(length, leadSpace, endSpace);
+ }
+ break;
+
+ case LISTREP_DESCRIBE:
+#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
+ do { \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewStringObj(#fld_, -1)); \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
+ } while (0)
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **objs;
+ ListSizeT nobjs;
+ ListRep listRep;
+ Tcl_Obj *listRepObjs[4];
+
+ /* Force list representation */
+ if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ListObjGetRep(objv[2], &listRep);
+ listRepObjs[0] = Tcl_NewStringObj("store", -1);
+ listRepObjs[1] = Tcl_NewListObj(12, NULL);
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", -1));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
+ if (listRep.spanPtr) {
+ listRepObjs[2] = Tcl_NewStringObj("span", -1);
+ listRepObjs[3] = Tcl_NewListObj(8, NULL);
+ Tcl_ListObjAppendElement(interp,
+ listRepObjs[3],
+ Tcl_NewStringObj("memoryAddress", -1));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
+ APPEND_FIELD(
+ listRepObjs[3], listRep.spanPtr, spanLength);
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
+ }
+ resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
+ }
+#undef APPEND_FIELD
+ break;
+
+ case LISTREP_CONFIG:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewListObj(2, NULL);
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", -1));
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
+ break;
+
+ case LISTREP_VALIDATE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ TclListObjValidate(interp, objv[2]); /* Panics if invalid */
+ resultObj = Tcl_NewObj();
+ break;
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used