diff options
Diffstat (limited to 'generic/tclListObj.c')
| -rw-r--r-- | generic/tclListObj.c | 1372 |
1 files changed, 841 insertions, 531 deletions
diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 1bc0344..bd2dbc4 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclListObj.c,v 1.31 2005/12/13 22:43:18 kennykb Exp $ */ #include "tclInt.h" @@ -19,7 +17,9 @@ * Prototypes for functions defined later in this file: */ -static List * NewListIntRep(int objc, Tcl_Obj *CONST objv[]); +static List * AttemptNewList(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static List * NewListIntRep(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); @@ -38,30 +38,33 @@ static void UpdateStringOfList(Tcl_Obj *listPtr); * storage to avoid an auxiliary stack. */ -Tcl_ObjType tclListType = { +const Tcl_ObjType tclListType = { "list", /* name */ FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny /* setFromAnyProc */ }; + +#ifndef TCL_MIN_ELEMENT_GROWTH +#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) +#endif /* *---------------------------------------------------------------------- * * NewListIntRep -- * - * If objc>0 and objv!=NULL, this function creates a list internal rep - * with objc elements given in the array objv. - * If objc>0 and objv==NULL it creates the list internal rep of a list - * with 0 elements, where enough space has been preallocated to store - * objc elements. - * If objc<=0, it returns NULL. + * Creates a list internal rep with space for objc elements. 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. Flag value "p" indicates + * how to behave on failure. * * Results: - * A new List struct is returned. If objc<=0 or if the allocation fails - * for lack of memory, NULL is returned. The list returned has refCount - * 0. + * A new List struct with refCount 0 is returned. If some failure + * prevents this then if p=0, NULL is returned and otherwise the + * routine panics. * * Side effects: * The ref counts of the elements in objv are incremented since the @@ -73,30 +76,36 @@ Tcl_ObjType tclListType = { static List * NewListIntRep( int objc, - Tcl_Obj *CONST objv[]) + Tcl_Obj *const objv[], + int p) { - Tcl_Obj **elemPtrs; List *listRepPtr; - int i; if (objc <= 0) { - return NULL; + Tcl_Panic("NewListIntRep: expects postive element count"); } /* * 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. + * requires API changes to fix. See [Bug 219196] for a discussion. */ - if (objc > INT_MAX/sizeof(Tcl_Obj *)) { + if ((size_t)objc > LIST_MAX) { + if (p) { + Tcl_Panic("max length of a Tcl list (%d elements) exceeded", + LIST_MAX); + } return NULL; } - listRepPtr = (List *) attemptckalloc(sizeof(List) + - ((objc-1) * sizeof(Tcl_Obj *))); + listRepPtr = attemptckalloc(LIST_SIZE(objc)); if (listRepPtr == NULL) { + if (p) { + Tcl_Panic("list creation failed: unable to alloc %u bytes", + LIST_SIZE(objc)); + } return NULL; } @@ -105,6 +114,9 @@ NewListIntRep( listRepPtr->maxElemCount = objc; if (objv) { + Tcl_Obj **elemPtrs; + int i; + listRepPtr->elemCount = objc; elemPtrs = &listRepPtr->elements; for (i = 0; i < objc; i++) { @@ -120,6 +132,51 @@ NewListIntRep( /* *---------------------------------------------------------------------- * + * AttemptNewList -- + * + * Creates a list internal rep with space for objc elements. 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. + * + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then NULL is returned, and an error message is left + * in the interp result, unless interp is NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +static List * +AttemptNewList( + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + List *listRepPtr = NewListIntRep(objc, objv, 0); + + if (interp != NULL && listRepPtr == NULL) { + if (objc > LIST_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", + LIST_MAX)); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "list creation failed: unable to alloc %u bytes", + LIST_SIZE(objc))); + } + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return listRepPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewListObj -- * * This function is normally called when not debugging: i.e., when @@ -149,7 +206,7 @@ NewListIntRep( Tcl_Obj * Tcl_NewListObj( int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ + Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { return Tcl_DbNewListObj(objc, objv, "unknown", 0); } @@ -159,7 +216,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_NewListObj( int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ + Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; Tcl_Obj *listPtr; @@ -174,21 +231,14 @@ Tcl_NewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to create the list\n"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ - Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; - + TclInvalidateStringRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); return listPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -227,8 +277,8 @@ Tcl_NewListObj( Tcl_Obj * Tcl_DbNewListObj( int 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 + 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. */ @@ -246,20 +296,14 @@ Tcl_DbNewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to create the list\n"); - } + listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ - Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; - listRepPtr->refCount++; + TclInvalidateStringRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); return listPtr; } @@ -269,8 +313,8 @@ Tcl_DbNewListObj( Tcl_Obj * Tcl_DbNewListObj( int 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 + 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. */ @@ -305,12 +349,12 @@ void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ int objc, /* Count of objects referenced by objv. */ - Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ + Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; if (Tcl_IsShared(objPtr)) { - Tcl_Panic("Tcl_SetListObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetListObj"); } /* @@ -318,8 +362,7 @@ Tcl_SetListObj( */ TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; - Tcl_InvalidateStringRep(objPtr); + TclInvalidateStringRep(objPtr); /* * Set the object's type to "list" and initialize the internal rep. @@ -328,14 +371,8 @@ Tcl_SetListObj( */ if (objc > 0) { - listRepPtr = NewListIntRep(objc, objv); - if (!listRepPtr) { - Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj"); - } - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; - listRepPtr->refCount++; + listRepPtr = NewListIntRep(objc, objv, 1); + ListSetIntRep(objPtr, listRepPtr); } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; @@ -345,6 +382,47 @@ Tcl_SetListObj( /* *---------------------------------------------------------------------- * + * TclListObjCopy -- + * + * 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. + * + * 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. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjCopy( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listPtr) /* List object for which an element array is + * to be returned. */ +{ + Tcl_Obj *copyPtr; + + if (listPtr->typePtr != &tclListType) { + if (SetListFromAny(interp, listPtr) != TCL_OK) { + return NULL; + } + } + + TclNewObj(copyPtr); + TclInvalidateStringRep(copyPtr); + DupListInternalRep(listPtr, copyPtr); + return copyPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list @@ -385,21 +463,19 @@ Tcl_ListObjGetElements( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -410,16 +486,13 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the objects in the list referenced by - * elemListPtr to the list object referenced by listPtr. If listPtr is - * not already a list object, an attempt will be made to convert it to - * one. + * This function appends the elements in the list value referenced by + * elemListPtr to the list value referenced by listPtr. * * Results: * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list objects and they can not be converted to one, TCL_ERROR - * is returned and an error message is left in the interpreter's result - * if interp is not NULL. + * refer to list values, TCL_ERROR is returned and an error message is + * left in the interpreter's result if interp is not NULL. * * Side effects: * The reference counts of the elements in elemListPtr are incremented @@ -437,29 +510,27 @@ Tcl_ListObjAppendList( register Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { - int listLen, objc, result; + int objc; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { - Tcl_Panic("Tcl_ListObjAppendList called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } - result = Tcl_ListObjLength(interp, listPtr, &listLen); - if (result != TCL_OK) { - return result; - } + /* + * Pull the elements to append from elemListPtr. + */ - result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv); - if (result != TCL_OK) { - return result; + if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { + return TCL_ERROR; } /* - * Insert objc new elements starting after the lists's last element. + * Insert the new elements starting after the lists's last element. * Delete zero existing elements. */ - return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv); + return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); } /* @@ -495,77 +566,129 @@ Tcl_ListObjAppendElement( Tcl_Obj *listPtr, /* List object to append objPtr to. */ Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ { - register List *listRepPtr; - register Tcl_Obj **elemPtrs; - int numElems, numRequired, newMax, newSize, i; + register List *listRepPtr, *newPtr = NULL; + int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { - Tcl_Panic("Tcl_ListObjAppendElement called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; + needGrow = (numRequired > listRepPtr->maxElemCount); + isShared = (listRepPtr->refCount > 1); - /* - * If there is no room in the current array of element pointers, allocate - * a new, larger array and copy the pointers to it. If the List struct is - * shared, allocate a new one. - */ + 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 (numRequired > listRepPtr->maxElemCount){ - newMax = (2 * numRequired); - newSize = sizeof(List)+((newMax-1)*sizeof(Tcl_Obj*)); - } else { - newMax = listRepPtr->maxElemCount; - newSize = 0; + if (needGrow && !isShared) { + /* + * Need to grow + unshared intrep => try to realloc + */ + + attempt = 2 * numRequired; + if (attempt <= LIST_MAX) { + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; + if (attempt > LIST_MAX) { + attempt = LIST_MAX; + } + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr == NULL) { + attempt = numRequired; + newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt)); + } + if (newPtr) { + listRepPtr = newPtr; + listRepPtr->maxElemCount = attempt; + needGrow = 0; + } } + if (isShared || needGrow) { + Tcl_Obj **dst, **src = &listRepPtr->elements; - if (listRepPtr->refCount > 1) { - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldElems; + /* + * Either we have a shared intrep and we must copy to write, or we + * need to grow and realloc attempts failed. Attempt intrep copy. + */ - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + 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); } - oldElems = &oldListRepPtr->elements; - elemPtrs = &listRepPtr->elements; - for (i=0; i<numElems; i++) { - elemPtrs[i] = oldElems[i]; - Tcl_IncrRefCount(elemPtrs[i]); + if (newPtr == NULL) { + attempt = numRequired; + newPtr = AttemptNewList(interp, attempt, NULL); } - listRepPtr->elemCount = numElems; - listRepPtr->refCount++; - oldListRepPtr->refCount--; - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - } else if (newSize) { - listRepPtr = (List *) ckrealloc((char *)listRepPtr, (size_t)newSize); - listRepPtr->maxElemCount = newMax; - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + if (newPtr == NULL) { + /* + * All growth attempts failed; throw the error. + */ + + return TCL_ERROR; + } + + dst = &newPtr->elements; + newPtr->refCount++; + newPtr->canonicalFlag = listRepPtr->canonicalFlag; + newPtr->elemCount = listRepPtr->elemCount; + + if (isShared) { + /* + * The original intrep must remain undisturbed. Copy into the new + * one and bump refcounts + */ + while (numElems--) { + *dst = *src++; + Tcl_IncrRefCount(*dst++); + } + listRepPtr->refCount--; + } else { + /* + * Old intrep to be freed, re-use refCounts. + */ + + memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *)); + ckfree(listRepPtr); + } + listRepPtr = newPtr; } + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; /* * Add objPtr to the end of listPtr's array of element pointers. Increment * the ref count for the (now shared) objPtr. */ - elemPtrs = &listRepPtr->elements; - elemPtrs[numElems] = objPtr; + *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; @@ -574,7 +697,7 @@ Tcl_ListObjAppendElement( * representation has changed. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -614,21 +737,19 @@ Tcl_ListObjIndex( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -669,21 +790,19 @@ Tcl_ListObjLength( register List *listRepPtr; if (listPtr->typePtr != &tclListType) { - int result, length; + int result; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (!length) { + if (listPtr->bytes == tclEmptyStringRep) { *intPtr = 0; return TCL_OK; } - result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -733,65 +852,78 @@ Tcl_ListObjReplace( 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 + Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to * insert. */ { List *listRepPtr; register Tcl_Obj **elemPtrs; - Tcl_Obj *victimPtr; - int numElems, numRequired, numAfterLast; - int start, shift, newMax, i, j, result; - int isShared; + int numElems, numRequired, numAfterLast, start, i, j, isShared; if (Tcl_IsShared(listPtr)) { - Tcl_Panic("Tcl_ListObjReplace called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { - int length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (!length) { - if (objc) { - Tcl_SetListObj(listPtr, objc, NULL); - } else { + if (listPtr->bytes == tclEmptyStringRep) { + if (!objc) { return TCL_OK; } + Tcl_SetListObj(listPtr, objc, NULL); } else { - result = SetListFromAny(interp, listPtr); + int result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { return result; } } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + /* + * 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. + */ + + listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; if (first < 0) { - first = 0; + first = 0; } if (first >= numElems) { first = numElems; /* So we'll insert after last element. */ } if (count < 0) { count = 0; - } else if (numElems < first+count) { + } else if (numElems < first+count || first+count < 0) { + /* + * The 'first+count < 0' condition here guards agains integer + * overflow in determining 'first+count'. + */ + count = numElems - first; } isShared = (listRepPtr->refCount > 1); - numRequired = (numElems - count + objc); + numRequired = numElems - count + objc; + + for (i = 0; i < objc; i++) { + Tcl_IncrRefCount(objv[i]); + } + + if ((numRequired <= listRepPtr->maxElemCount) && !isShared) { + int shift; - if ((numRequired <= listRepPtr->maxElemCount) - && !isShared) { /* * Can use the current List struct. First "delete" count elements * starting at first. */ for (j = first; j < first + count; j++) { - victimPtr = elemPtrs[j]; + Tcl_Obj *victimPtr = elemPtrs[j]; + TclDecrRefCount(victimPtr); } @@ -800,37 +932,55 @@ Tcl_ListObjReplace( * locations. */ - start = (first + count); - numAfterLast = (numElems - start); - shift = (objc - count); /* numNewElems - numDeleted */ + start = first + count; + numAfterLast = numElems - start; + shift = objc - count; /* numNewElems - numDeleted */ if ((numAfterLast > 0) && (shift != 0)) { - Tcl_Obj **src, **dst; + Tcl_Obj **src = elemPtrs + start; - src = elemPtrs + start; dst = src + shift; - memmove((VOID*) dst, (VOID*) src, - (size_t) (numAfterLast * sizeof(Tcl_Obj*))); + memmove(src+shift, src, (size_t) numAfterLast * sizeof(Tcl_Obj*)); } } else { /* - * Cannot use the current List struct - it is shared, too small, or + * Cannot use the current List struct; it is shared, too small, or * both. Allocate a new struct and insert elements into it. */ List *oldListRepPtr = listRepPtr; Tcl_Obj **oldPtrs = elemPtrs; + int newMax; if (numRequired > listRepPtr->maxElemCount){ - newMax = (2 * numRequired); + newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; } - listRepPtr = NewListIntRep(newMax, NULL); - if (!listRepPtr) { - Tcl_Panic("Not enough memory to allocate list"); + 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; + } + } } - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -846,7 +996,7 @@ Tcl_ListObjReplace( elemPtrs[i] = oldPtrs[i]; Tcl_IncrRefCount(elemPtrs[i]); } - for (i= first + count, j = first + objc; + for (i = first + count, j = first + objc; j < numRequired; i++, j++) { elemPtrs[j] = oldPtrs[i]; Tcl_IncrRefCount(elemPtrs[j]); @@ -859,8 +1009,7 @@ Tcl_ListObjReplace( */ if (first > 0) { - memcpy((VOID *) elemPtrs, (VOID *) oldPtrs, - (size_t) (first * sizeof(Tcl_Obj *))); + memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *)); } /* @@ -868,7 +1017,8 @@ Tcl_ListObjReplace( */ for (j = first; j < first + count; j++) { - victimPtr = oldPtrs[j]; + Tcl_Obj *victimPtr = oldPtrs[j]; + TclDecrRefCount(victimPtr); } @@ -877,15 +1027,14 @@ Tcl_ListObjReplace( * new locations. */ - start = (first + count); - numAfterLast = (numElems - start); + start = first + count; + numAfterLast = numElems - start; if (numAfterLast > 0) { - memcpy((VOID *) &(elemPtrs[first + objc]), - (VOID *) &(oldPtrs[start]), - (size_t) (numAfterLast * sizeof(Tcl_Obj *))); + memcpy(elemPtrs + first + objc, oldPtrs + start, + (size_t) numAfterLast * sizeof(Tcl_Obj *)); } - ckfree((char *) oldListRepPtr); + ckfree(oldListRepPtr); } } @@ -895,7 +1044,6 @@ Tcl_ListObjReplace( for (i=0,j=first ; i<objc ; i++,j++) { elemPtrs[j] = objv[i]; - Tcl_IncrRefCount(objv[i]); } /* @@ -909,68 +1057,229 @@ Tcl_ListObjReplace( * reflects the list's internal representation. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * + * TclLindexList -- + * + * This procedure handles the 'lindex' command when objc==3. + * + * 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. + * + * Side effects: + * None. + * + * 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 intreps 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. */ +{ + + int index; /* Index into the list. */ + Tcl_Obj *indexListCopy; + + /* + * 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. + */ + + if (argPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { + /* + * argPtr designates a single index. + */ + + return TclLindexFlat(interp, listPtr, 1, &argPtr); + } + + /* + * Here we make a private copy of the index list argument to avoid any + * shimmering issues that might invalidate the indices array below while + * we are still using it. This is probably unnecessary. It does not appear + * that any damaging shimmering is possible, and no test has been devised + * to show any error when this private copy is not made. But it's cheap, + * and it offers some future-proofing insurance in case the TclLindexFlat + * implementation changes in some unexpected way, or some new form of + * trace or callback permits things to happen that the current + * implementation does not. + */ + + indexListCopy = TclListObjCopy(NULL, argPtr); + if (indexListCopy == NULL) { + /* + * argPtr designates something that is neither an index nor a + * well-formed list. Report the error via TclLindexFlat. + */ + + return TclLindexFlat(interp, listPtr, 1, &argPtr); + } + + if (indexListCopy->typePtr == &tclListType) { + List *listRepPtr = ListRepPtr(indexListCopy); + + listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, + &listRepPtr->elements); + } else { + int indexCount = -1; /* Size of the array of list indices. */ + Tcl_Obj **indices = NULL; + /* Array of list indices. */ + + Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices); + listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); + } + Tcl_DecrRefCount(indexListCopy); + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLindexFlat -- + * + * This procedure is the core of the 'lindex' command, with all index + * arguments presented as a flat list. + * + * 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. + * + * 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 *const indexArray[])/* Array of pointers to Tcl objects that + * represent the indices in the list. */ +{ + int i; + + Tcl_IncrRefCount(listPtr); + + for (i=0 ; i<indexCount && listPtr ; i++) { + int index, listLen = 0; + Tcl_Obj **elemPtrs = NULL, *sublistCopy; + + /* + * Here we make a private copy of the current sublist, so we avoid any + * shimmering issues that might invalidate the elemPtr array below + * while we are still using it. See test lindex-8.4. + */ + + sublistCopy = TclListObjCopy(interp, listPtr); + Tcl_DecrRefCount(listPtr); + listPtr = NULL; + + if (sublistCopy == NULL) { + /* + * The sublist is not a list at all => error. + */ + + break; + } + TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs); + + if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, + &index) == TCL_OK) { + if (index<0 || index>=listLen) { + /* + * Index is out of range. Break out of loop with empty result. + * First check remaining indices for validity + */ + + while (++i < indexCount) { + if (TclGetIntForIndexM(interp, indexArray[i], -1, &index) + != TCL_OK) { + Tcl_DecrRefCount(sublistCopy); + return NULL; + } + } + listPtr = Tcl_NewObj(); + } else { + /* + * Extract the pointer to the appropriate element. + */ + + listPtr = elemPtrs[index]; + } + Tcl_IncrRefCount(listPtr); + } + Tcl_DecrRefCount(sublistCopy); + } + + return listPtr; +} + +/* + *---------------------------------------------------------------------- + * * TclLsetList -- * * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * * Results: - * Returns the new value of the list variable, or NULL if an error - * occurs. + * 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. * * Side effects: - * Surgery is performed on the list value to produce the result. - * - * 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. + * None. * - * 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_LsetFlat and related functions maintain a linked list of Tcl_Obj's - * whose string representations must be spoilt by threading via 'ptr2' of - * the two-pointer internal representation. On entry to Tcl_LsetList, the - * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any - * Tcl_Obj that has been modified is set to NULL. + * 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 intreps 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' */ + 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'. */ { - int indexCount; /* Number of indices in the index list */ - Tcl_Obj **indices; /* 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 */ - int i; - List *indexListRepPtr; + int 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 *indexListCopy; /* * Determine whether the index arg designates a list or a single index. @@ -979,15 +1288,17 @@ TclLsetList( */ if (indexArgPtr->typePtr != &tclListType - && TclGetIntForIndex(NULL, indexArgPtr, 0, &index) == TCL_OK) { + && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); - } else if (Tcl_ListObjGetElements(NULL, indexArgPtr, &indexCount, - &indices) != TCL_OK) { + } + + indexListCopy = TclListObjCopy(NULL, indexArgPtr); + if (indexListCopy == NULL) { /* * indexArgPtr designates something that is neither an index nor a * well formed list. Report the error via TclLsetFlat. @@ -995,21 +1306,7 @@ TclLsetList( return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } - - /* - * At this point, we know that argPtr designates a well formed list, and - * the 'else if' above has parsed it into indexCount and indices. - * Increase the reference count of the internal rep of indexArgPtr, in - * order to insure the validity of pointers even if indexArgPtr shimmers - * to another type. - */ - - if (indexCount) { - indexListRepPtr = (List *) indexArgPtr->internalRep.twoPtrValue.ptr1; - indexListRepPtr->refCount++; - } else { - indexListRepPtr = NULL; /* avoid compiler warning*/ - } + TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices); /* * Let TclLsetFlat handle the actual lset'ting. @@ -1017,19 +1314,7 @@ TclLsetList( retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); - /* - * If we are the only users of indexListRepPtr, we free it before - * returning. - */ - - if (indexCount) { - if (--indexListRepPtr->refCount <= 0) { - for (i=0; i<indexCount; i++) { - Tcl_DecrRefCount(indices[i]); - } - ckfree((char *) indexListRepPtr); - } - } + Tcl_DecrRefCount(indexListCopy); return retValuePtr; } @@ -1038,16 +1323,14 @@ TclLsetList( * * TclLsetFlat -- * - * Core of the 'lset' command when objc>=5. Objv[2], ... , objv[objc-2] - * contain scalar indices. + * Core engine of the 'lset' command. * * Results: * Returns the new value of the list variable, or NULL if an error - * occurs. + * occurred. The returned object includes one reference count for the + * pointer returned. * * Side effects: - * Surgery is performed on the list value to produce the result. - * * 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 @@ -1068,9 +1351,10 @@ TclLsetList( * caller is expected to store the returned value back in the variable * and decrement its reference count. (INST_STORE_* does exactly this.) * - * Tcl_LsetList and related functions maintain a linked list of Tcl_Obj's - * whose string representations must be spoilt by threading via 'ptr2' of - * the two-pointer internal representation. On entry to Tcl_LsetList, the + * Surgery is performed on the unshared list value to produce the result. + * TclLsetFlat maintains a linked list of Tcl_Obj's 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. * @@ -1079,29 +1363,19 @@ TclLsetList( 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 *CONST indexArray[], - /* Index args */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' */ + Tcl_Interp *interp, /* Tcl interpreter. */ + Tcl_Obj *listPtr, /* Pointer to the list being modified. */ + int indexCount, /* Number of index args. */ + Tcl_Obj *const indexArray[], + /* Index args. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ { - int duplicated; /* Flag == 1 if the obj has been duplicated, 0 - * otherwise */ - Tcl_Obj *retValuePtr; /* Pointer to the list to be returned */ - int elemCount; /* Length of one sublist being changed */ - Tcl_Obj **elemPtrs; /* Pointers to the elements of a sublist */ - Tcl_Obj *subListPtr; /* Pointer to the current sublist */ - int index; /* Index of the element to replace in the - * current sublist */ - Tcl_Obj *chainPtr; /* Pointer to the enclosing list of the - * current sublist. */ - int result; /* Status return from library calls */ - int i; + int index, result, len; + Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; /* - * If there are no indices, then simply return the new value, counting the - * returned pointer as a reference. + * If there are no indices, simply return the new value. (Without + * indices, [lset] is a synonym for [set]. */ if (indexCount == 0) { @@ -1110,163 +1384,184 @@ TclLsetFlat( } /* - * If the list is shared, make a private copy. Duplicate the intrep to - * insure that it is modifyable [Bug 1333036]. A plain Tcl_DuplicateObj - * will just increase the intrep's refCount without upping the sublists' - * refCount, so that their true shared status cannot be determined from - * their refCount. + * 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 + * 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 + * all elements to be unchanged. */ - if (Tcl_IsShared(listPtr)) { - duplicated = 1; - if (listPtr->typePtr == &tclListType) { - result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, - &elemPtrs); - listPtr = Tcl_NewListObj(elemCount, elemPtrs); - } else { - listPtr = Tcl_DuplicateObj(listPtr); - } - Tcl_IncrRefCount(listPtr); - } else { - duplicated = 0; - } + subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; /* * Anchor the linked list of Tcl_Obj's whose string reps must be * invalidated if the operation succeeds. */ - retValuePtr = listPtr; + retValuePtr = subListPtr; chainPtr = NULL; + result = TCL_OK; /* - * Handle each index arg by diving into the appropriate sublist. + * Loop through all the index arguments, and for each one dive into the + * appropriate sublist. */ - for (i=0 ; ; i++) { - /* - * Take the sublist apart. - */ - - result = Tcl_ListObjGetElements(interp, listPtr, &elemCount, - &elemPtrs); - if (result != TCL_OK) { - break; - } - if (elemCount == 0) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); - result = TCL_ERROR; - break; - } - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + do { + int elemCount; + Tcl_Obj *parentList, **elemPtrs; /* - * Determine the index of the requested element. + * Check for the possible error conditions... */ - result = TclGetIntForIndex(interp, indexArray[i], elemCount-1, &index); - if (result != TCL_OK) { + if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) + != TCL_OK) { + /* ...the sublist we're indexing into isn't a list at all. */ + result = TCL_ERROR; break; } /* - * Check that the index is in range. + * WARNING: the macro TclGetIntForIndexM is not safe for + * post-increments, avoid '*indexArray++' here. */ - if (index<0 || index>=elemCount) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); + if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) + != TCL_OK) { + /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; + indexArray++; break; } - - /* - * Break the loop after extracting the innermost sublist - */ - - if (i >= indexCount-1) { - result = TCL_OK; + indexArray++; + + if (index < 0 || index > elemCount) { + /* ...the index points outside the sublist. */ + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", + "BADINDEX", NULL); + } + result = TCL_ERROR; break; } /* - * Extract the appropriate sublist, and make sure that it is unshared. - * If it is a list, duplicate the intrep to avoid [Bug 1333036], as - * per the previous comment. + * 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. */ - subListPtr = elemPtrs[index]; - if (Tcl_IsShared(subListPtr)) { - if (subListPtr->typePtr == &tclListType) { - result = Tcl_ListObjGetElements(interp, subListPtr, &elemCount, - &elemPtrs); - subListPtr = Tcl_NewListObj(elemCount, elemPtrs); + if (--indexCount) { + parentList = subListPtr; + if (index == elemCount) { + subListPtr = Tcl_NewObj(); } else { + subListPtr = elemPtrs[index]; + } + if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); } - result = TclListObjSetElement(interp, listPtr, index, subListPtr); - if (result != TCL_OK) { - /* - * We actually shouldn't be able to get here. If we do, it - * would result in leaking subListPtr, but everything's been - * validated already; the error exit from TclListObjSetElement - * should never happen. - */ - break; + /* + * 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 intrep with other + * Tcl_Obj's. Dealing with the shared intrep case can cause + * subListPtr to become shared again, so detect that case and make + * and store another copy. + */ + + if (index == elemCount) { + Tcl_ListObjAppendElement(NULL, parentList, subListPtr); + } else { + TclListObjSetElement(NULL, parentList, index, subListPtr); + } + if (Tcl_IsShared(subListPtr)) { + subListPtr = Tcl_DuplicateObj(subListPtr); + TclListObjSetElement(NULL, parentList, index, subListPtr); } - } - /* - * Chain the current sublist onto the linked list of Tcl_Obj's whose - * string reps must be spoilt. - */ + /* + * 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 intrep surgery) so we can spoil + * them at that time. + */ - chainPtr = listPtr; - listPtr = subListPtr; - } + parentList->internalRep.twoPtrValue.ptr2 = chainPtr; + chainPtr = parentList; + } + } while (indexCount > 0); /* - * Store the result in the list element. + * 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. */ - if (result == TCL_OK) { - result = TclListObjSetElement(interp, listPtr, index, valuePtr); - } + while (chainPtr) { + Tcl_Obj *objPtr = chainPtr; - if (result == TCL_OK) { - listPtr->internalRep.twoPtrValue.ptr2 = (void *) chainPtr; + if (result == TCL_OK) { + /* + * We're going to store valuePtr, so spoil string reps of all + * containing lists. + */ + + TclInvalidateStringRep(objPtr); + } /* - * Spoil all the string reps. + * Clear away our intrep surgery mess. */ - while (listPtr != NULL) { - subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2; - Tcl_InvalidateStringRep(listPtr); - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr = subListPtr; - } + chainPtr = objPtr->internalRep.twoPtrValue.ptr2; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + } + if (result != TCL_OK) { /* - * Return the new list if everything worked. + * Error return; message is already in interp. Clean up any excess + * memory. */ - if (!duplicated) { - Tcl_IncrRefCount(retValuePtr); + if (retValuePtr != listPtr) { + Tcl_DecrRefCount(retValuePtr); } - return retValuePtr; + return NULL; } /* - * Clean up the one dangling reference otherwise. + * Store valuePtr 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). */ - if (duplicated) { - Tcl_DecrRefCount(retValuePtr); + len = -1; + TclListObjLength(NULL, subListPtr, &len); + if (index == len) { + Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); + } else { + TclListObjSetElement(NULL, subListPtr, index, valuePtr); } - return NULL; + TclInvalidateStringRep(subListPtr); + Tcl_IncrRefCount(retValuePtr); + return retValuePtr; } /* @@ -1301,34 +1596,35 @@ TclLsetFlat( int TclListObjSetElement( Tcl_Interp *interp, /* Tcl interpreter; used for error reporting - * if not NULL */ + * if not NULL. */ Tcl_Obj *listPtr, /* List object in which element should be - * stored */ - int index, /* Index of element to store */ + * stored. */ + int index, /* Index of element to store. */ Tcl_Obj *valuePtr) /* Tcl object to store in the designated list - * element */ + * element. */ { - int result; /* Return value from this function. */ 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. */ - int i; /* * Ensure that the listPtr parameter designates an unshared list. */ if (Tcl_IsShared(listPtr)) { - Tcl_Panic("Tcl_ListObjSetElement called with shared object"); + Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } if (listPtr->typePtr != &tclListType) { - int length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (!length) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("list index out of range", -1)); + int result; + + if (listPtr->bytes == tclEmptyStringRep) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", + "BADINDEX", NULL); + } return TCL_ERROR; } result = SetListFromAny(interp, listPtr); @@ -1337,9 +1633,8 @@ TclListObjSetElement( } } - listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; - elemPtrs = &listRepPtr->elements; /* * Ensure that the index is in bounds. @@ -1349,8 +1644,10 @@ TclListObjSetElement( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); - return TCL_ERROR; + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX", + NULL); } + return TCL_ERROR; } /* @@ -1358,21 +1655,30 @@ TclListObjSetElement( */ if (listRepPtr->refCount > 1) { - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldElemPtrs = elemPtrs; + Tcl_Obj **dst, **src = &listRepPtr->elements; + List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); - listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL); - listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; - elemPtrs = &listRepPtr->elements; - for (i=0; i < elemCount; i++) { - elemPtrs[i] = oldElemPtrs[i]; - Tcl_IncrRefCount(elemPtrs[i]); + if (newPtr == NULL) { + newPtr = AttemptNewList(interp, elemCount, NULL); + if (newPtr == NULL) { + return TCL_ERROR; + } } - listRepPtr->refCount++; - listRepPtr->elemCount = elemCount; - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - oldListRepPtr->refCount--; + newPtr->refCount++; + newPtr->elemCount = elemCount; + newPtr->canonicalFlag = listRepPtr->canonicalFlag; + + dst = &newPtr->elements; + while (elemCount--) { + *dst = *src++; + Tcl_IncrRefCount(*dst++); + } + + listRepPtr->refCount--; + + listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; } + elemPtrs = &listRepPtr->elements; /* * Add a reference to the new list element. @@ -1418,22 +1724,19 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj **elemPtrs = &listRepPtr->elements; - register Tcl_Obj *objPtr; - int numElems = listRepPtr->elemCount; - int i; + List *listRepPtr = ListRepPtr(listPtr); if (--listRepPtr->refCount <= 0) { + Tcl_Obj **elemPtrs = &listRepPtr->elements; + int i, numElems = listRepPtr->elemCount; + for (i = 0; i < numElems; i++) { - objPtr = elemPtrs[i]; - Tcl_DecrRefCount(objPtr); + Tcl_DecrRefCount(elemPtrs[i]); } - ckfree((char *) listRepPtr); + ckfree(listRepPtr); } - listPtr->internalRep.twoPtrValue.ptr1 = NULL; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = NULL; } /* @@ -1458,12 +1761,9 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; + List *listRepPtr = ListRepPtr(srcPtr); - listRepPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclListType; + ListSetIntRep(copyPtr, listRepPtr); } /* @@ -1490,105 +1790,113 @@ SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - char *string, *s; - CONST char *elemStart, *nextElem; - int lenRemain, length, estCount, elemSize, hasBrace, i, j, result; - char *limit; /* Points just after string's last byte. */ - register CONST char *p; - register Tcl_Obj **elemPtrs; - register Tcl_Obj *elemPtr; List *listRepPtr; + Tcl_Obj **elemPtrs; /* - * Get the string representation. Make it up-to-date if necessary. + * Dictionaries are a special case; they have a string representation such + * that *all* valid dictionaries are valid lists. Hence we can convert + * more directly. Only do this when there's no existing string rep; if + * there is, it is the string rep that's authoritative (because it could + * describe duplicate keys). */ - string = Tcl_GetStringFromObj(objPtr, &length); + if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { + Tcl_Obj *keyPtr, *valuePtr; + Tcl_DictSearch search; + int done, size; - /* - * Parse the string into separate string objects, and create a List - * structure that points to the element string objects. We use a modified - * version of Tcl_SplitList's implementation to avoid one malloc and a - * string copy for each list element. First, estimate the number of - * elements by counting the number of space characters in the list. - */ + /* + * Create the new list representation. Note that we do not need to do + * anything with the string representation as the transformation (and + * the reverse back to a dictionary) are both order-preserving. Also + * note that since we know we've got a valid dictionary (by + * representation) we also know that fetching the size of the + * dictionary or iterating over it will not fail. + */ - limit = (string + length); - estCount = 1; - for (p = string; p < limit; p++) { - if (isspace(UCHAR(*p))) { /* INTL: ISO space. */ - estCount++; + Tcl_DictObjSize(NULL, objPtr, &size); + listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); + if (!listRepPtr) { + return TCL_ERROR; } - } - - /* - * Allocate a new List structure with enough room for "estCount" elements. - * Each element is a pointer to a Tcl_Obj with the appropriate string rep. - * The initial "estCount" elements are set using the corresponding "argv" - * strings. - */ + listRepPtr->elemCount = 2 * size; - listRepPtr = NewListIntRep(estCount, NULL); - if (!listRepPtr) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Not enough memory to allocate the list internal rep", -1)); - return TCL_ERROR; - } - elemPtrs = &listRepPtr->elements; + /* + * Populate the list representation. + */ - for (p=string, lenRemain=length, i=0; - lenRemain > 0; - p = nextElem, lenRemain = (limit - nextElem), i++) { - result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem, - &elemSize, &hasBrace); - if (result != TCL_OK) { - for (j = 0; j < i; j++) { - elemPtr = elemPtrs[j]; - Tcl_DecrRefCount(elemPtr); - } - ckfree((char *) listRepPtr); - return result; - } - if (elemStart >= limit) { - break; + elemPtrs = &listRepPtr->elements; + Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); + while (!done) { + *elemPtrs++ = keyPtr; + *elemPtrs++ = valuePtr; + Tcl_IncrRefCount(keyPtr); + Tcl_IncrRefCount(valuePtr); + Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } - if (i > estCount) { - Tcl_Panic("SetListFromAny: bad size estimate for list"); + } else { + int estCount, length; + const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); + + /* + * Allocate enough space to hold a (Tcl_Obj *) for each + * (possible) list element. + */ + + estCount = TclMaxListLength(nextElem, length, &limit); + estCount += (estCount == 0); /* Smallest list struct holds 1 + * element. */ + listRepPtr = AttemptNewList(interp, estCount, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; } + elemPtrs = &listRepPtr->elements; /* - * Allocate a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". + * Each iteration, parse and store a list element. */ - s = ckalloc((unsigned) elemSize + 1); - if (hasBrace) { - memcpy((void *) s, (void *) elemStart, (size_t) elemSize); - s[elemSize] = 0; - } else { - elemSize = TclCopyAndCollapse(elemSize, elemStart, s); + while (nextElem < limit) { + const char *elemStart; + int elemSize, literal; + + if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, + &elemStart, &nextElem, &elemSize, &literal)) { + while (--elemPtrs >= &listRepPtr->elements) { + Tcl_DecrRefCount(*elemPtrs); + } + ckfree((char *) listRepPtr); + return TCL_ERROR; + } + if (elemStart == limit) { + break; + } + + /* TODO: replace panic with error on alloc failure? */ + if (literal) { + TclNewStringObj(*elemPtrs, elemStart, elemSize); + } else { + TclNewObj(*elemPtrs); + (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); + (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, + (*elemPtrs)->bytes); + } + + Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - TclNewObj(elemPtr); - elemPtr->bytes = s; - elemPtr->length = elemSize; - elemPtrs[i] = elemPtr; - Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ + listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } - listRepPtr->elemCount = i; - /* * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - listRepPtr->refCount++; TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; + ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1618,19 +1926,32 @@ UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { # define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr; - List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; - register int i; - char *elem, *dst; - int length; + int i, length, bytesNeeded = 0; + const char *elem; + char *dst; Tcl_Obj **elemPtrs; /* - * Convert each element of the list to string form and then convert it to - * proper list element form, adding it to the result buffer. + * Mark the list as being canonical; although it will now have a string + * rep, it is one we derived through proper "canonical" quoting and so + * it's known to be free from nasties relating to [concat] and [eval]. + */ + + listRepPtr->canonicalFlag = 1; + + /* + * Handle empty list case first, so rest of the routine is simpler. */ + if (numElems == 0) { + listPtr->bytes = tclEmptyStringRep; + listPtr->length = 0; + return; + } + /* * Pass 1: estimate space, gather flags. */ @@ -1638,55 +1959,44 @@ UpdateStringOfList( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); - } - listPtr->length = 1; - elemPtrs = &listRepPtr->elements; - for (i = 0; i < numElems; i++) { - elem = Tcl_GetStringFromObj(elemPtrs[i], &length); - listPtr->length += Tcl_ScanCountedElement(elem, length, - &flagPtr[i]) + 1; - /* - * Check for continued sanity. [Bug 1267380] + * We know numElems <= LIST_MAX, so this is safe. */ - if (listPtr->length < 1) { - Tcl_Panic("string representation size exceeds sane bounds"); + flagPtr = ckalloc(numElems * sizeof(int)); + } + elemPtrs = &listRepPtr->elements; + for (i = 0; i < numElems; i++) { + flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); + elem = TclGetStringFromObj(elemPtrs[i], &length); + bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + bytesNeeded += numElems; /* * Pass 2: copy into string rep buffer. */ - listPtr->bytes = ckalloc((unsigned) listPtr->length); + listPtr->length = bytesNeeded - 1; + listPtr->bytes = ckalloc(bytesNeeded); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { - elem = Tcl_GetStringFromObj(elemPtrs[i], &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, - flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); - *dst = ' '; - dst++; + flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); + elem = TclGetStringFromObj(elemPtrs[i], &length); + dst += TclConvertElement(elem, length, dst, flagPtr[i]); + *dst++ = ' '; } + listPtr->bytes[listPtr->length] = '\0'; + if (flagPtr != localFlags) { - ckfree((char *) flagPtr); - } - if (dst == listPtr->bytes) { - *dst = 0; - } else { - dst--; - *dst = 0; + ckfree(flagPtr); } - listPtr->length = dst - listPtr->bytes; - - /* - * Mark the list as being canonical; although it has a string rep, it is - * one we derived through proper "canonical" quoting and so it's known to - * be free from nasties relating to [concat] and [eval]. - */ - - listRepPtr->canonicalFlag = 1; } /* |