/* * tclListObj.c -- * * This file contains functions that implement the Tcl list object type. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #define LIST(listObj) ((List *)(listObj)->internalRep.twoPtrValue.ptr1) /* * Prototypes for functions defined later in this file: */ 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 FreeListInternalRep(Tcl_Obj *listPtr); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); 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. */ 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 -- * * 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 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 * resulting list now refers to them. * *---------------------------------------------------------------------- */ static List * NewListIntRep( int objc, Tcl_Obj *const objv[], int p) { List *listRepPtr; if (objc <= 0) { 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. See [Bug 219196] for a discussion. */ if ((size_t)objc > LIST_MAX) { if (p) { Tcl_Panic("max length of a Tcl list (%d elements) exceeded", LIST_MAX); } return NULL; } 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; } listRepPtr->canonicalFlag = 0; listRepPtr->refCount = 0; listRepPtr->maxElemCount = objc; 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]); } } else { listRepPtr->elemCount = 0; } return listRepPtr; } /* *---------------------------------------------------------------------- * * 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 * 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. * * When TCL_MEM_DEBUG is defined, this function just returns the result * of calling the debugging version Tcl_DbNewListObj. * * 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. * * Side effects: * The ref counts of the elements in objv are incremented since the * resulting list now refers to them. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef 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. */ { return Tcl_DbNewListObj(objc, objv, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewListObj( int objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { List *listRepPtr; Tcl_Obj *listPtr; TclNewObj(listPtr); if (objc <= 0) { return listPtr; } /* * Create the internal rep. */ listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ TclInvalidateStringRep(listPtr); ListSetIntRep(listPtr, listRepPtr); return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * 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. * * When TCL_MEM_DEBUG is not defined, this function just returns the * result of calling Tcl_NewListObj. * * 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. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG 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 * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { Tcl_Obj *listPtr; List *listRepPtr; TclDbNewObj(listPtr, file, line); if (objc <= 0) { return listPtr; } /* * Create the internal rep. */ listRepPtr = NewListIntRep(objc, objv, 1); /* * Now create the object. */ TclInvalidateStringRep(listPtr); ListSetIntRep(listPtr, listRepPtr); return listPtr; } #else /* if not TCL_MEM_DEBUG */ 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 * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { return Tcl_NewListObj(objc, objv); } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * 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. */ 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. */ TclFreeIntRep(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. */ if (objc > 0) { listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; } } /* *---------------------------------------------------------------------- * * 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 * object. * * Results: * The return value is normally TCL_OK; in this case *objcPtr is set to * the count of list elements and *objvPtr is set to a pointer to an * array of (*objcPtr) pointers to each list element. If listPtr does not * refer to 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. * * Side effects: * The possible conversion of the object referenced by listPtr * to a list object. * *---------------------------------------------------------------------- */ int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr, /* List object for which an element array is * to be returned. */ int *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result; if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * * 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 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 * since the list now refers to them. listPtr and elemListPtr are * converted, if necessary, to list objects. Also, appending the new * elements may cause listObj's array of element pointers to grow. * listPtr's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr, /* List object to append elements to. */ Tcl_Obj *elemListPtr) /* List obj with elements to append. */ { int objc; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } /* * Pull the elements to append from elemListPtr. */ if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) { return TCL_ERROR; } /* * Insert the new elements starting after the lists's last element. * Delete zero existing elements. */ return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * * This function is a special purpose version of Tcl_ListObjAppendList: * it appends a single object referenced by objPtr 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. * * Results: * The return value is normally TCL_OK; in this case objPtr is added to * the end of listPtr's 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 ref count of objPtr is incremented since the list now refers to * it. listPtr will be converted, if necessary, to a list object. Also, * appending the new element may cause listObj's array of element * pointers to grow. listPtr's old string representation, if any, is * invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjAppendElement( 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. */ { register List *listRepPtr, *newPtr = NULL; int numElems, numRequired, needGrow, isShared, attempt; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } if (listPtr->typePtr != &tclListType) { int result; if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = ListRepPtr(listPtr); 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 (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; /* * Either we have a shared intrep and we must copy to write, or we * need to grow and realloc attempts failed. Attempt intrep copy. */ 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; } 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. */ *(&listRepPtr->elements + listRepPtr->elemCount) = objPtr; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; /* * Invalidate any old string representation since the list's internal * representation has changed. */ TclInvalidateStringRep(listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * * 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. * * 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. * * 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. */ register Tcl_Obj *listPtr, /* List object to index into. */ register int index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result; if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { *objPtrPtr = (&listRepPtr->elements)[index]; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * * This function returns the number of elements in a list object. If the * object is not already a list object, an attempt will be made to * convert it to one. * * Results: * The return value is normally TCL_OK; in this case *intPtr will be set * 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. * * Side effects: * The possible conversion of the argument object to a list object. * *---------------------------------------------------------------------- */ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ register Tcl_Obj *listPtr, /* List object whose #elements to return. */ register int *intPtr) /* The resulting int is stored here. */ { register List *listRepPtr; if (listPtr->typePtr != &tclListType) { int result; if (listPtr->bytes == tclEmptyStringRep) { *intPtr = 0; return TCL_OK; } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * * This function replaces zero or more elements of the list referenced by * listPtr with the objects from an (objc,objv) array. The objc elements * of the array referenced by objv replace the count elements in listPtr * starting at first. * * If the argument first is zero or negative, it refers to the first * element. If first is greater than or equal to the number of elements * in the list, then no elements are deleted; the new elements are * appended to the list. Count gives the number of elements to replace. * If count is zero or negative then no elements are deleted; the new * elements are simply inserted before first. * * The argument objv refers to an array of objc pointers to the new * elements to be added to listPtr in place of those that were deleted. * If objv is NULL, no new elements are added. If listPtr is not a list * object, an attempt will be made to convert it to one. * * 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. * * 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. listPtr is converted, if necessary, * to a list object. listPtr'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. */ { List *listRepPtr; register Tcl_Obj **elemPtrs; int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared; if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { if (listPtr->bytes == tclEmptyStringRep) { if (!objc) { return TCL_OK; } Tcl_SetListObj(listPtr, objc, NULL); } else { int result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { return result; } } } /* * 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; } if (first >= numElems) { first = numElems; /* So we'll insert after last element. */ } if (count < 0) { count = 0; } 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; } if (objc > LIST_MAX - (numElems - count)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); 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]); } if (needGrow && !isShared) { /* Try to use realloc */ List *newPtr = NULL; int 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; listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; } } if (!needGrow && !isShared) { int shift; /* * Can use the current List struct. First "delete" count elements * starting at first. */ for (j = first; j < first + count; j++) { Tcl_Obj *victimPtr = elemPtrs[j]; TclDecrRefCount(victimPtr); } /* * Shift the elements after the last one removed to their new * locations. */ start = first + count; numAfterLast = numElems - start; shift = objc - count; /* numNewElems - numDeleted */ if ((numAfterLast > 0) && (shift != 0)) { Tcl_Obj **src = elemPtrs + start; memmove(src+shift, src, (size_t) 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. */ List *oldListRepPtr = listRepPtr; Tcl_Obj **oldPtrs = elemPtrs; int newMax; if (needGrow){ newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; } 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 = listRepPtr; listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; if (isShared) { /* * The old struct will remain in place; need new refCounts for the * new List struct references. Copy over only the surviving * elements. */ 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]); } oldListRepPtr->refCount--; } else { /* * The old struct will be removed; use its inherited refCounts. */ if (first > 0) { memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *)); } /* * "Delete" count elements starting at first. */ for (j = first; j < first + count; j++) { Tcl_Obj *victimPtr = oldPtrs[j]; TclDecrRefCount(victimPtr); } /* * Copy the elements after the last one removed, shifted to their * new locations. */ start = first + count; numAfterLast = numElems - start; if (numAfterLast > 0) { memcpy(elemPtrs + first + objc, oldPtrs + start, (size_t) numAfterLast * sizeof(Tcl_Obj *)); } ckfree(oldListRepPtr); } } /* * Insert the new elements into elemPtrs before "first". */ for (i=0,j=first ; ielemCount = numRequired; /* * Invalidate and free any old string representation since it no longer * reflects the list's internal representation. */ 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 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 there was an * error. The returned object includes one reference count for the * pointer returned. * * Side effects: * None. * * 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'. */ { 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. * We have to be careful about the order of the checks to avoid repeated * shimmering; see TIP #22 and #23 for details. */ if (indexArgPtr->typePtr != &tclListType && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } 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. */ return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices); /* * Let TclLsetFlat handle the actual lset'ting. */ retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); Tcl_DecrRefCount(indexListCopy); return retValuePtr; } /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * * 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. * * 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.) * * 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. * *---------------------------------------------------------------------- */ 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'. */ { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. */ if (indexCount == 0) { Tcl_IncrRefCount(valuePtr); return valuePtr; } /* * 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. */ 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 = subListPtr; chainPtr = NULL; result = TCL_OK; /* * Loop through all the index arguments, and for each one dive into the * appropriate sublist. */ do { int elemCount; Tcl_Obj *parentList, **elemPtrs; /* * Check for the possible error conditions... */ if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ result = TCL_ERROR; break; } /* * WARNING: the macro TclGetIntForIndexM is not safe for * post-increments, avoid '*indexArray++' here. */ 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; } 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; } /* * 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. */ if (--indexCount) { parentList = subListPtr; if (index == elemCount) { subListPtr = Tcl_NewObj(); } else { subListPtr = elemPtrs[index]; } if (Tcl_IsShared(subListPtr)) { subListPtr = Tcl_DuplicateObj(subListPtr); } /* * 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); } /* * 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. */ parentList->internalRep.twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } 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. */ while (chainPtr) { Tcl_Obj *objPtr = chainPtr; if (result == TCL_OK) { /* * We're going to store valuePtr, so spoil string reps of all * containing lists. */ TclInvalidateStringRep(objPtr); } /* * Clear away our intrep surgery mess. */ chainPtr = objPtr->internalRep.twoPtrValue.ptr2; objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { /* * Error return; message is already in interp. Clean up any excess * memory. */ if (retValuePtr != listPtr) { Tcl_DecrRefCount(retValuePtr); } return NULL; } /* * 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). */ len = -1; TclListObjLength(NULL, subListPtr, &len); if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); } TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * * Set a single element of a list to a specified value * * Results: * The return value is normally TCL_OK. If listPtr 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 listPtr, TCL_ERROR is returned and an error * message is left in the interpreter result. * * Side effects: * Tcl_Panic if listPtr 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 valuePtr, and increments the * ref count of the replacement object. * * It is the caller's responsibility to invalidate the string * representation of the 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 * stored. */ int index, /* Index of element to store. */ Tcl_Obj *valuePtr) /* 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. */ /* * Ensure that the listPtr parameter designates an unshared list. */ if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } if (listPtr->typePtr != &tclListType) { 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); if (result != TCL_OK) { return result; } } listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; /* * Ensure that the index is in bounds. */ if (index<0 || index>=elemCount) { 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; } /* * If the internal rep is shared, replace it with an unshared copy. */ 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--; listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; } elemPtrs = &listRepPtr->elements; /* * Add a reference to the new list element. */ Tcl_IncrRefCount(valuePtr); /* * Remove a reference from the old list element. */ Tcl_DecrRefCount(elemPtrs[index]); /* * Stash the new object in the list. */ elemPtrs[index] = valuePtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * * Deallocate the storage associated with a list object's internal * representation. * * Results: * None. * * Side effects: * Frees listPtr's List* internal representation and sets listPtr's * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all * element objects, which may free them. * *---------------------------------------------------------------------- */ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { List *listRepPtr = ListRepPtr(listPtr); 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); } listPtr->typePtr = NULL; } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * * Results: * None. * * 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. */ { List *listRepPtr = ListRepPtr(srcPtr); ListSetIntRep(copyPtr, listRepPtr); } /* *---------------------------------------------------------------------- * * SetListFromAny -- * * Attempt to generate a list internal form for the Tcl object "objPtr". * * 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. */ { Tcl_Obj *listPtr; List *listRepPtr; Tcl_Obj **elemPtrs; /* * Dictionaries are a special case; they may have stored a previous list * representation */ listPtr = TclObjLookupTyped(objPtr, &tclListType); if (listPtr != NULL) { Tcl_IncrRefCount(listPtr); TclFreeIntRep(objPtr); DupListInternalRep(listPtr, objPtr); Tcl_DecrRefCount(listPtr); objPtr->typePtr = &tclListType; /* To Do: Maybe keep the dict intrep around in case this object is * used as a dict again */ return TCL_OK; } if (objPtr->typePtr == &tclDictType) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; /* * 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. */ Tcl_DictObjSize(NULL, objPtr, &size); listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); if (!listRepPtr) { return TCL_ERROR; } listRepPtr->elemCount = 2 * size; /* * Populate the list representation. */ 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); } } 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; /* * Each iteration, parse and store a list element. */ 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. */ } listRepPtr->elemCount = elemPtrs - &listRepPtr->elements; } /* * 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. */ TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * * 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. * * Results: * None. * * Side effects: * The object's string is set to a valid string that results from the * list-to-string conversion. This string will be empty if the list has * no elements. The list internal representation should not be NULL and * we assume it is not NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; const char *elem; char *dst; Tcl_Obj **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]. */ 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. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { /* * We know numElems <= LIST_MAX, so this is safe. */ 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->length = bytesNeeded - 1; listPtr->bytes = ckalloc(bytesNeeded); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { 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(flagPtr); } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */