diff options
Diffstat (limited to 'generic/tclListObj.c')
| -rw-r--r-- | generic/tclListObj.c | 2163 |
1 files changed, 1198 insertions, 965 deletions
diff --git a/generic/tclListObj.c b/generic/tclListObj.c index b4af98a..d6ffa95 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1,70 +1,193 @@ -/* +/* * tclListObj.c -- * - * This file contains procedures that implement the Tcl list object - * type. + * 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* - * Prototypes for procedures defined later in this file: + * Prototypes for functions defined later in this file: */ -static void DupListInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FreeListInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); -static int SetListFromAny _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); -static void UpdateStringOfList _ANSI_ARGS_((Tcl_Obj *listPtr)); +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); +static void UpdateStringOfList(Tcl_Obj *listPtr); /* - * The structure below defines the list Tcl object type by means of - * procedures that can be invoked by generic object code. + * 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. + * 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. */ Tcl_ObjType tclListType = { - "list", /* name */ - FreeListInternalRep, /* freeIntRepProc */ - DupListInternalRep, /* dupIntRepProc */ - UpdateStringOfList, /* updateStringProc */ - SetListFromAny /* setFromAnyProc */ + "list", /* name */ + FreeListInternalRep, /* freeIntRepProc */ + DupListInternalRep, /* dupIntRepProc */ + UpdateStringOfList, /* updateStringProc */ + SetListFromAny /* setFromAnyProc */ }; /* *---------------------------------------------------------------------- * + * 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 = (List *) + attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))); + if (listRepPtr == NULL) { + if (p) { + Tcl_Panic("list creation failed: unable to alloc %u bytes", + (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))); + } + 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", + (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))))); + } + } + return listRepPtr; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewListObj -- * - * This procedure is normally called when not debugging: i.e., when + * 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 procedure just returns the - * result of calling the debugging version Tcl_DbNewListObj. + * 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. + * 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 @@ -77,9 +200,9 @@ Tcl_ObjType tclListType = { #undef Tcl_NewListObj Tcl_Obj * -Tcl_NewListObj(objc, objv) - int objc; /* Count of objects referenced by objv. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +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); } @@ -87,36 +210,31 @@ Tcl_NewListObj(objc, objv) #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * -Tcl_NewListObj(objc, objv) - int objc; /* Count of objects referenced by objv. */ - Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +Tcl_NewListObj( + int objc, /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]) /* An array of pointers to Tcl objects. */ { - register Tcl_Obj *listPtr; - register Tcl_Obj **elemPtrs; - register List *listRepPtr; - int i; - + List *listRepPtr; + Tcl_Obj *listPtr; + TclNewObj(listPtr); - - if (objc > 0) { - Tcl_InvalidateStringRep(listPtr); - - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = elemPtrs; - - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; + + 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 */ @@ -126,22 +244,22 @@ Tcl_NewListObj(objc, objv) * * Tcl_DbNewListObj -- * - * This procedure 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 procedure above except that it calls + * 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 + * 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 procedure just returns the + * 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. + * 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 @@ -153,53 +271,49 @@ Tcl_NewListObj(objc, objv) #ifdef TCL_MEM_DEBUG Tcl_Obj * -Tcl_DbNewListObj(objc, objv, file, line) - 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 - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +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. */ { - register Tcl_Obj *listPtr; - register Tcl_Obj **elemPtrs; - register List *listRepPtr; - int i; - + Tcl_Obj *listPtr; + List *listRepPtr; + TclDbNewObj(listPtr, file, line); - - if (objc > 0) { - Tcl_InvalidateStringRep(listPtr); - - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = elemPtrs; - - listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr->typePtr = &tclListType; + + 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(objc, objv, file, line) - 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 - * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ +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); } @@ -210,8 +324,8 @@ Tcl_DbNewListObj(objc, objv, file, line) * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements - * of the object array referenced by objv. + * Modify an object to be a list containing each of the objc elements of + * the object array referenced by objv. * * Results: * None. @@ -219,61 +333,43 @@ Tcl_DbNewListObj(objc, objv, file, line) * 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. + * 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(objPtr, objc, objv) - 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_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. */ { - register Tcl_Obj **elemPtrs; - register List *listRepPtr; - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - int i; + List *listRepPtr; if (Tcl_IsShared(objPtr)) { - panic("Tcl_SetListObj called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_SetListObj"); } - + /* * Free any old string rep and any internal rep for the old type. */ - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } + TclFreeIntRep(objPtr); objPtr->typePtr = NULL; - Tcl_InvalidateStringRep(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. + * 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) { - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (objc * sizeof(Tcl_Obj *))); - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = objc; - listRepPtr->elemCount = objc; - listRepPtr->elements = elemPtrs; - - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; + listRepPtr = NewListIntRep(objc, objv, 1); + ListSetIntRep(objPtr, listRepPtr); } else { objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; @@ -283,25 +379,66 @@ Tcl_SetListObj(objPtr, objc, objv) /* *---------------------------------------------------------------------- * + * 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 procedure returns an (objc,objv) array of the elements in a - * list object. + * 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. + * 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 procedure may change as soon as any - * procedure is called on the list object; be careful about retaining - * the pointer in a local data structure. + * 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 @@ -311,26 +448,33 @@ Tcl_SetListObj(objPtr, objc, objv) */ int -Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) - 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 +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. */ + 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 = SetListFromAny(interp, listPtr); + int result; + + 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; + *objvPtr = &listRepPtr->elements; return TCL_OK; } @@ -339,50 +483,46 @@ Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) * * Tcl_ListObjAppendList -- * - * This procedure appends the objects in the list referenced by + * 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. * * 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. + * 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. * * 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. + * 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(interp, listPtr, elemListPtr) - 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. */ +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. */ { - register List *listRepPtr; int listLen, objc, result; Tcl_Obj **objv; if (Tcl_IsShared(listPtr)) { - panic("Tcl_ListObjAppendList called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } - if (listPtr->typePtr != &tclListType) { - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } + + result = TclListObjLength(interp, listPtr, &listLen); + if (result != TCL_OK) { + return result; } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - listLen = listRepPtr->elemCount; - result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv); + result = TclListObjGetElements(interp, elemListPtr, &objc, &objv); if (result != TCL_OK) { return result; } @@ -391,7 +531,7 @@ Tcl_ListObjAppendList(interp, listPtr, elemListPtr) * Insert objc new elements starting after the lists's last element. * Delete zero existing elements. */ - + return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv); } @@ -400,77 +540,102 @@ Tcl_ListObjAppendList(interp, listPtr, elemListPtr) * * Tcl_ListObjAppendElement -- * - * This procedure 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. + * 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. + * 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. + * 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(interp, listPtr, objPtr) - Tcl_Interp *interp; /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr; /* List object to append objPtr to. */ - Tcl_Obj *objPtr; /* Object to append to listPtr's list. */ +Tcl_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; register Tcl_Obj **elemPtrs; - int numElems, numRequired; - + int numElems, numRequired, newMax, newSize, i; + if (Tcl_IsShared(listPtr)) { - panic("Tcl_ListObjAppendElement called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } if (listPtr->typePtr != &tclListType) { - int result = SetListFromAny(interp, listPtr); + 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 = (List *) listPtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; + listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 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 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 > listRepPtr->maxElemCount) { - int newMax = (2 * numRequired); - Tcl_Obj **newElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); - - memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, - (size_t) (numElems * sizeof(Tcl_Obj *))); + if (numRequired > listRepPtr->maxElemCount){ + newMax = 2 * numRequired; + newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *)); + } else { + newMax = listRepPtr->maxElemCount; + newSize = 0; + } + + if (listRepPtr->refCount > 1) { + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldElems; + listRepPtr = AttemptNewList(interp, newMax, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; + } + oldElems = &oldListRepPtr->elements; + elemPtrs = &listRepPtr->elements; + for (i=0; i<numElems; i++) { + elemPtrs[i] = oldElems[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + 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; - listRepPtr->elements = newElemPtrs; - ckfree((char *) elemPtrs); - elemPtrs = newElemPtrs; + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; } /* - * Add objPtr to the end of listPtr's array of element - * pointers. Increment the ref count for the (now shared) objPtr. + * 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; Tcl_IncrRefCount(objPtr); listRepPtr->elemCount++; @@ -480,7 +645,7 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr) * representation has changed. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -489,20 +654,20 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr) * * Tcl_ListObjIndex -- * - * This procedure 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. + * 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. + * 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. @@ -511,28 +676,34 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr) */ int -Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) - 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. */ +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 = SetListFromAny(interp, listPtr); + int result; + + 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 { - *objPtrPtr = listRepPtr->elements[index]; + *objPtrPtr = (&listRepPtr->elements)[index]; } - + return TCL_OK; } @@ -541,16 +712,16 @@ Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) * * Tcl_ListObjLength -- * - * This procedure returns the number of elements in a list object. If - * the object is not already a list object, an attempt will be made to + * 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. + * 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. @@ -559,21 +730,27 @@ Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) */ int -Tcl_ListObjLength(interp, listPtr, intPtr) - 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. */ +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 = SetListFromAny(interp, listPtr); + int result; + + 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; } @@ -582,456 +759,491 @@ Tcl_ListObjLength(interp, listPtr, intPtr) *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- - * - * This procedure 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. + * + * 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. + * 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. + * 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. + * 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. + * 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(interp, listPtr, first, count, objc, objv) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *listPtr; /* List object whose elements to replace. */ - int first; /* Index of first element to replace. */ - int count; /* Number of elements to replace. */ - int objc; /* Number of objects to insert. */ - Tcl_Obj *CONST objv[]; /* An array of objc pointers to Tcl objects - * to insert. */ +Tcl_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, **newPtrs; - Tcl_Obj *victimPtr; - int numElems, numRequired, numAfterLast; - int start, shift, newMax, i, j, result; - + register Tcl_Obj **elemPtrs; + int numElems, numRequired, numAfterLast, start, i, j, isShared; + if (Tcl_IsShared(listPtr)) { - panic("Tcl_ListObjReplace called with shared object"); + Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } if (listPtr->typePtr != &tclListType) { - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; + if (listPtr->bytes == tclEmptyStringRep) { + if (objc) { + Tcl_SetListObj(listPtr, objc, NULL); + } else { + return TCL_OK; + } + } else { + int result = SetListFromAny(interp, listPtr); + + if (result != TCL_OK) { + return result; + } } } - listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; + + /* + * 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 < 0) { + first = 0; } if (first >= numElems) { - first = numElems; /* so we'll insert after last element */ + 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; } - + + isShared = (listRepPtr->refCount > 1); + numRequired = numElems - count + objc; + for (i = 0; i < objc; i++) { Tcl_IncrRefCount(objv[i]); } - numRequired = (numElems - count + objc); - if (numRequired <= listRepPtr->maxElemCount) { + if ((numRequired <= listRepPtr->maxElemCount) && !isShared) { + int shift; + /* - * Enough room in the current array. First "delete" count - * elements starting at first. + * Can use the current List struct. First "delete" count elements + * starting at first. */ - for (i = 0, j = first; i < count; i++, j++) { - victimPtr = elemPtrs[j]; + 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. + * Shift the elements after the last one removed to their new + * 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 { /* - * Insert the new elements into elemPtrs before "first". + * Cannot use the current List struct; it is shared, too small, or + * both. Allocate a new struct and insert elements into it. */ - for (i = 0, j = first; i < objc; i++, j++) { - elemPtrs[j] = objv[i]; - } + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldPtrs = elemPtrs; + int newMax; - /* - * Update the count of elements. - */ + if (numRequired > listRepPtr->maxElemCount){ + newMax = 2 * numRequired; + } else { + newMax = listRepPtr->maxElemCount; + } - listRepPtr->elemCount = numRequired; - } else { - /* - * Not enough room in the current array. Allocate a larger array and - * insert elements into it. - */ + listRepPtr = AttemptNewList(interp, newMax, 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; + } - newMax = (2 * numRequired); - newPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + listRepPtr->refCount++; - /* - * Copy over the elements before "first". - */ + elemPtrs = &listRepPtr->elements; - if (first > 0) { - memcpy((VOID *) newPtrs, (VOID *) elemPtrs, - (size_t) (first * sizeof(Tcl_Obj *))); - } + if (isShared) { + /* + * The old struct will remain in place; need new refCounts for the + * new List struct references. Copy over only the surviving + * elements. + */ - /* - * "Delete" count elements starting at first. - */ + 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]); + } - for (i = 0, j = first; i < count; i++, j++) { - victimPtr = elemPtrs[j]; - TclDecrRefCount(victimPtr); - } + oldListRepPtr->refCount--; + } else { + /* + * The old struct will be removed; use its inherited refCounts. + */ - /* - * Copy the elements after the last one removed, shifted to - * their new locations. - */ + if (first > 0) { + memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *)); + } - start = (first + count); - numAfterLast = (numElems - start); - if (numAfterLast > 0) { - memcpy((VOID *) &(newPtrs[first + objc]), - (VOID *) &(elemPtrs[start]), - (size_t) (numAfterLast * sizeof(Tcl_Obj *))); - } - - /* - * Insert the new elements before "first" and update the - * count of elements. - */ + /* + * "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 *)); + } - for (i = 0, j = first; i < objc; i++, j++) { - newPtrs[j] = objv[i]; + ckfree((char *) oldListRepPtr); } + } - listRepPtr->elemCount = numRequired; - listRepPtr->maxElemCount = newMax; - listRepPtr->elements = newPtrs; - ckfree((char *) elemPtrs); + /* + * Insert the new elements into elemPtrs before "first". + */ + + for (i=0,j=first ; i<objc ; i++,j++) { + elemPtrs[j] = objv[i]; } - + + /* + * Update the count of elements. + */ + + listRepPtr->elemCount = numRequired; + /* * Invalidate and free any old string representation since it no longer * reflects the list's internal representation. */ - Tcl_InvalidateStringRep(listPtr); + TclInvalidateStringRep(listPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclLsetList -- - * - * Core of the 'lset' command when objc == 4. Objv[2] may be - * either a scalar index or a list of indices. + * TclLindexList -- + * + * This procedure handles the 'lindex' command when objc==3. * * Results: - * Returns the new value of the list variable, or NULL if an - * error occurs. + * 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: - * 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. - * - * 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 procedure. - * - * 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. + * 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* -TclLsetList( interp, listPtr, indexArgPtr, valuePtr ) - 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_Obj * +TclLindexList( + Tcl_Interp *interp, /* Tcl interpreter. */ + Tcl_Obj *listPtr, /* List being unpacked. */ + Tcl_Obj *argPtr) /* Index or index list. */ { - int indexCount; /* Number of indices in the index list */ - Tcl_Obj** indices; /* Vector of indices in the index list*/ - - int duplicated; /* Flag == 1 if the obj has been - * duplicated, 0 otherwise */ - Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */ - int index; /* Current index in the list - discarded */ - int result; /* Status return from library calls */ - Tcl_Obj* subListPtr; /* Pointer to the current sublist */ - int elemCount; /* Count of elements in the current sublist */ - Tcl_Obj** elemPtrs; /* Pointers to elements of current sublist */ - Tcl_Obj* chainPtr; /* Pointer to the enclosing sublist - * of the current sublist */ - int i; + int index; /* Index into the list. */ + Tcl_Obj **indices; /* Array of list indices. */ + int indexCount; /* Size of the array of list indices. */ + 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. + * 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 ( indexArgPtr->typePtr != &tclListType - && TclGetIntForIndex( 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 ) { - + if (argPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* - * indexArgPtr designates something that is neither an index nor a - * well formed list. Report the error via TclLsetFlat. + * argPtr designates a single index. */ - return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr ); - + return TclLindexFlat(interp, listPtr, 1, &argPtr); } /* - * At this point, we know that argPtr designates a well formed list, - * and the 'else if' above has parsed it into indexCount and indices. - * If there are no indices, simply return 'valuePtr', counting the - * returned pointer as a reference. + * 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. */ - if ( indexCount == 0 ) { - Tcl_IncrRefCount( valuePtr ); - return valuePtr; - } - - /* - * Duplicate the list arg if necessary. - */ + 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. + */ - if ( Tcl_IsShared( listPtr ) ) { - duplicated = 1; - listPtr = Tcl_DuplicateObj( listPtr ); - Tcl_IncrRefCount( listPtr ); - } else { - duplicated = 0; + return TclLindexFlat(interp, listPtr, 1, &argPtr); } - /* - * It would be tempting simply to go off to TclLsetFlat to finish the - * processing. Alas, it is also incorrect! The problem is that - * 'indexArgPtr' may designate a sublist of 'listPtr' whose value - * is to be manipulated. The fact that 'listPtr' is itself unshared - * does not guarantee that no sublist is. Therefore, it's necessary - * to replicate all the work here, expanding the index list on each - * trip through the loop. - */ - - /* - * Anchor the linked list of Tcl_Obj's whose string reps must be - * invalidated if the operation succeeds. - */ + TclListObjGetElements(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); + * + *---------------------------------------------------------------------- + */ - retValuePtr = listPtr; - chainPtr = NULL; +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; - /* - * Handle each index arg by diving into the appropriate sublist - */ + Tcl_IncrRefCount(listPtr); - for ( i = 0; ; ++i ) { + for (i=0 ; i<indexCount && listPtr ; i++) { + int index, listLen; + Tcl_Obj **elemPtrs, *sublistCopy; /* - * Take the sublist apart. + * 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. */ - result = Tcl_ListObjGetElements( interp, listPtr, - &elemCount, &elemPtrs ); - if ( result != TCL_OK ) { - break; - } - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; - - /* - * Reconstitute the index array - */ + sublistCopy = TclListObjCopy(interp, listPtr); + Tcl_DecrRefCount(listPtr); + listPtr = NULL; - result = Tcl_ListObjGetElements( interp, indexArgPtr, - &indexCount, &indices ); - if ( result != TCL_OK ) { - /* - * Shouldn't be able to get here, because we already - * parsed the thing successfully once. + if (sublistCopy == NULL) { + /* + * The sublist is not a list at all => error. */ - break; - } - - /* - * Determine the index of the requested element. - */ - - result = TclGetIntForIndex( interp, indices[ i ], - (elemCount - 1), &index ); - if ( result != TCL_OK ) { - break; - } - - /* - * Check that the index is in range. - */ - if ( ( index < 0 ) || ( index >= elemCount ) ) { - Tcl_SetObjResult( interp, - Tcl_NewStringObj( "list index out of range", - -1 ) ); - result = TCL_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 + */ - /* - * Break the loop after extracting the innermost sublist - */ - - if ( i >= indexCount-1 ) { - result = TCL_OK; - break; - } - - /* - * Extract the appropriate sublist, and make sure that it is unshared. - */ - - 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, because - * we've already checked everything that TclListObjSetElement - * checks. If we were to get here, it would result in leaking - * subListPtr. + 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. */ - break; + + listPtr = elemPtrs[index]; } + Tcl_IncrRefCount(listPtr); } + Tcl_DecrRefCount(sublistCopy); + } - /* - * Chain the current sublist onto the linked list of Tcl_Obj's - * whose string reps must be spoilt. - */ - - chainPtr = listPtr; - listPtr = subListPtr; + 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; /* 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. */ + Tcl_Obj *indexListCopy; /* - * Store the new element into the correct slot in the innermost sublist. + * 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 ( result == TCL_OK ) { - result = TclListObjSetElement( interp, listPtr, index, valuePtr ); - } + if (indexArgPtr->typePtr != &tclListType + && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { + /* + * indexArgPtr designates a single index. + */ - if ( result == TCL_OK ) { + return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + } - /* Spoil all the string reps */ - - while ( listPtr != NULL ) { - subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2; - Tcl_InvalidateStringRep( listPtr ); - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr = subListPtr; - } + 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 the new list if everything worked. */ - - if ( !duplicated ) { - Tcl_IncrRefCount( retValuePtr ); - } - return retValuePtr; + return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); } + TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices); - /* Clean up the one dangling reference otherwise */ + /* + * Let TclLsetFlat handle the actual lset'ting. + */ - if ( duplicated ) { - Tcl_DecrRefCount( retValuePtr ); - } - return NULL; + retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); + Tcl_DecrRefCount(indexListCopy); + return retValuePtr; } /* @@ -1039,220 +1251,216 @@ TclLsetList( interp, listPtr, indexArgPtr, valuePtr ) * * 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. + * 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: - * 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. - * - * 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 procedure. - * - * 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_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 values of 'ptr2' are immaterial; on exit, - * the 'ptr2' field of any Tcl_Obj that has been modified is set to - * NULL. + * 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( interp, listPtr, indexCount, indexArray, valuePtr ) - 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_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 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; + 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 ) { - Tcl_IncrRefCount( valuePtr ); + if (indexCount == 0) { + Tcl_IncrRefCount(valuePtr); return valuePtr; } /* - * If the list is shared, make a private copy. + * 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; - 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; /* - * 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. - */ + do { + int elemCount; + Tcl_Obj *parentList, **elemPtrs; - result = Tcl_ListObjGetElements( interp, listPtr, - &elemCount, &elemPtrs ); - if ( result != TCL_OK ) { + /* Check for the possible error conditions... */ + result = TCL_ERROR; + if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs) + != TCL_OK) { + /* ...the sublist we're indexing into isn't a list at all. */ break; } - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; /* - * Determine the index of the requested element. + * WARNING: the macro TclGetIntForIndexM is not safe for + * post-increments, avoid '*indexArray++' here. */ - - result = TclGetIntForIndex( interp, indexArray[ i ], - (elemCount - 1), &index ); - if ( result != TCL_OK ) { - break; - } - /* - * Check that the index is in range. - */ - - if ( ( index < 0 ) || ( index >= elemCount ) ) { - Tcl_SetObjResult( interp, - Tcl_NewStringObj( "list index out of range", - -1 ) ); - result = TCL_ERROR; + if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) + != TCL_OK) { + /* ...the index we're trying to use isn't an index at all. */ + indexArray++; break; } + indexArray++; - /* - * Break the loop after extracting the innermost sublist - */ - - if ( i >= indexCount-1 ) { - result = TCL_OK; + 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)); + } break; } - + /* - * Extract the appropriate sublist, and make sure that it is unshared. + * 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 ) ) { - 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; + result = TCL_OK; + if (--indexCount) { + parentList = subListPtr; + subListPtr = elemPtrs[index]; + if (Tcl_IsShared(subListPtr)) { + subListPtr = Tcl_DuplicateObj(subListPtr); } - } - /* - * Chain the current sublist onto the linked list of Tcl_Obj's - * whose string reps must be spoilt. - */ + /* + * 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. + */ - chainPtr = listPtr; - listPtr = subListPtr; + 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. + */ - /* Store the result in the list element */ + parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr; + chainPtr = parentList; + } + } while (indexCount > 0); - if ( result == TCL_OK ) { - result = TclListObjSetElement( interp, listPtr, index, valuePtr ); - } + /* + * 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 ) { + while (chainPtr) { + Tcl_Obj *objPtr = chainPtr; - listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr; + if (result == TCL_OK) { - /* Spoil all the string reps */ - - while ( listPtr != NULL ) { - subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2; - Tcl_InvalidateStringRep( listPtr ); - listPtr->internalRep.twoPtrValue.ptr2 = NULL; - listPtr = subListPtr; - } + /* + * We're going to store valuePtr, so spoil string reps + * of all containing lists. + */ - /* Return the new list if everything worked. */ - - if ( !duplicated ) { - Tcl_IncrRefCount( retValuePtr ); + TclInvalidateStringRep(objPtr); } - return retValuePtr; - } - /* Clean up the one dangling reference otherwise */ + /* Clear away our intrep surgery mess */ + chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + } - if ( duplicated ) { - Tcl_DecrRefCount( retValuePtr ); + if (result != TCL_OK) { + /* + * Error return; message is already in interp. Clean up + * any excess memory. + */ + if (retValuePtr != listPtr) { + Tcl_DecrRefCount(retValuePtr); + } + return NULL; } - return NULL; + /* Store valuePtr in proper sublist and return */ + TclListObjSetElement(NULL, subListPtr, index, valuePtr); + TclInvalidateStringRep(subListPtr); + Tcl_IncrRefCount(retValuePtr); + return retValuePtr; } /* @@ -1263,86 +1471,125 @@ TclLsetFlat( interp, listPtr, indexCount, indexArray, valuePtr ) * 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. + * 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. * - * Panics if listPtr designates a shared object. Otherwise, attempts - * to convert it to a list. 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. + * It is the caller's responsibility to invalidate the string + * representation of the object. * *---------------------------------------------------------------------- */ int -TclListObjSetElement( interp, listPtr, index, valuePtr ) - 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 */ +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. */ { - 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 */ + 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 */ + /* + * Ensure that the listPtr parameter designates an unshared list. + */ - if ( Tcl_IsShared( listPtr ) ) { - panic( "Tcl_ListObjSetElement called with shared object" ); + if (Tcl_IsShared(listPtr)) { + Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - if ( listPtr->typePtr != &tclListType ) { - result = SetListFromAny( interp, listPtr ); - if ( result != TCL_OK ) { + if (listPtr->typePtr != &tclListType) { + int result; + + if (listPtr->bytes == tclEmptyStringRep) { + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("list index out of range", -1)); + } + return TCL_ERROR; + } + result = SetListFromAny(interp, listPtr); + if (result != TCL_OK) { return result; } } - listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1; - elemPtrs = listRepPtr->elements; + + listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; + elemPtrs = &listRepPtr->elements; + + /* + * 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)); + } + return TCL_ERROR; + } + + /* + * If the internal rep is shared, replace it with an unshared copy. + */ - /* Ensure that the index is in bounds */ + if (listRepPtr->refCount > 1) { + List *oldListRepPtr = listRepPtr; + Tcl_Obj **oldElemPtrs = elemPtrs; + int i; - if ( index < 0 || index >= elemCount ) { - if ( interp != NULL ) { - Tcl_SetObjResult( interp, - Tcl_NewStringObj( "list index out of range", - -1 ) ); + listRepPtr = AttemptNewList(interp, listRepPtr->maxElemCount, NULL); + if (listRepPtr == NULL) { return TCL_ERROR; } + listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag; + elemPtrs = &listRepPtr->elements; + for (i=0; i < elemCount; i++) { + elemPtrs[i] = oldElemPtrs[i]; + Tcl_IncrRefCount(elemPtrs[i]); + } + listRepPtr->refCount++; + listRepPtr->elemCount = elemCount; + listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr; + oldListRepPtr->refCount--; } - /* Add a reference to the new list element */ + /* + * Add a reference to the new list element. + */ - Tcl_IncrRefCount( valuePtr ); + Tcl_IncrRefCount(valuePtr); - /* Remove a reference from the old list element */ + /* + * Remove a reference from the old list element. + */ - Tcl_DecrRefCount( elemPtrs[ index ] ); + Tcl_DecrRefCount(elemPtrs[index]); - /* Stash the new object in the list */ + /* + * Stash the new object in the list. + */ - elemPtrs[ index ] = valuePtr; + elemPtrs[index] = valuePtr; return TCL_OK; - } /* @@ -1358,31 +1605,29 @@ TclListObjSetElement( interp, listPtr, index, valuePtr ) * * 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. + * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all + * element objects, which may free them. * *---------------------------------------------------------------------- */ static void -FreeListInternalRep(listPtr) - Tcl_Obj *listPtr; /* List object with internal rep to free. */ +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; - - for (i = 0; i < numElems; i++) { - objPtr = elemPtrs[i]; - Tcl_DecrRefCount(objPtr); + List *listRepPtr = ListRepPtr(listPtr); + + if (--listRepPtr->refCount <= 0) { + Tcl_Obj **elemPtrs = &listRepPtr->elements; + int i, numElems = listRepPtr->elemCount; + + for (i = 0; i < numElems; i++) { + Tcl_DecrRefCount(elemPtrs[i]); + } + ckfree((char *) listRepPtr); } - ckfree((char *) elemPtrs); - ckfree((char *) listRepPtr); - listPtr->internalRep.twoPtrValue.ptr1 = NULL; - listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = NULL; } /* @@ -1390,57 +1635,26 @@ FreeListInternalRep(listPtr) * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to a - * copy of the internal representation of an existing list object. + * Initialize the internal representation of a list Tcl_Obj to share the + * internal representation of an existing list object. * * Results: * None. * * Side effects: - * "srcPtr"s list internal rep pointer should not be NULL and we assume - * it is not NULL. We set "copyPtr"s internal rep to a pointer to a - * newly allocated List structure that, in turn, points to "srcPtr"s - * element objects. Those element objects are not actually copied but - * are shared between "srcPtr" and "copyPtr". The ref count of each - * element object is incremented. + * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void -DupListInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +DupListInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1; - int numElems = srcListRepPtr->elemCount; - int maxElems = srcListRepPtr->maxElemCount; - register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements; - register Tcl_Obj **copyElemPtrs; - register List *copyListRepPtr; - int i; + List *listRepPtr = ListRepPtr(srcPtr); - /* - * Allocate a new List structure that points to "srcPtr"s element - * objects. Increment the ref counts for those (now shared) element - * objects. - */ - - copyElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) maxElems * sizeof(Tcl_Obj *)); - for (i = 0; i < numElems; i++) { - copyElemPtrs[i] = srcElemPtrs[i]; - Tcl_IncrRefCount(copyElemPtrs[i]); - } - - copyListRepPtr = (List *) ckalloc(sizeof(List)); - copyListRepPtr->maxElemCount = maxElems; - copyListRepPtr->elemCount = numElems; - copyListRepPtr->elements = copyElemPtrs; - - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclListType; + ListSetIntRep(copyPtr, listRepPtr); } /* @@ -1448,8 +1662,7 @@ DupListInternalRep(srcPtr, copyPtr) * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object - * "objPtr". + * 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 @@ -1464,110 +1677,113 @@ DupListInternalRep(srcPtr, copyPtr) */ static int -SetListFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ +SetListFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr) /* The object to convert. */ { - Tcl_ObjType *oldTypePtr = objPtr->typePtr; - 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; } - } + listRepPtr->elemCount = 2 * size; - /* - * 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. - */ + /* + * Populate the list representation. + */ - elemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (estCount * sizeof(Tcl_Obj *))); - 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 *) elemPtrs); - return result; - } - if (elemStart >= limit) { - break; - } - if (i > estCount) { - panic("SetListFromAny: bad size estimate for list"); + 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 a Tcl object for the element and initialize it from the - * "elemSize" bytes starting at "elemStart". + * Allocate enough space to hold a (Tcl_Obj *) for each + * (possible) 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); + 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. */ } - - TclNewObj(elemPtr); - elemPtr->bytes = s; - elemPtr->length = elemSize; - elemPtrs[i] = elemPtr; - Tcl_IncrRefCount(elemPtr); /* since list now holds ref to it */ - } - listRepPtr = (List *) ckalloc(sizeof(List)); - listRepPtr->maxElemCount = estCount; - listRepPtr->elemCount = i; - listRepPtr->elements = elemPtrs; + 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 + * 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. */ - if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { - oldTypePtr->freeIntRepProc(objPtr); - } - - objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclListType; + TclFreeIntRep(objPtr); + ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1576,39 +1792,50 @@ SetListFromAny(interp, objPtr) * * UpdateStringOfList -- * - * Update the string representation for a list object. - * Note: This procedure does not invalidate an existing old string rep - * so storage will be lost if this has not already been done. + * 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. + * 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(listPtr) - Tcl_Obj *listPtr; /* List object with string rep to update. */ +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; + int i, length, bytesNeeded = 0; char *elem, *dst; - int length; + 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. */ @@ -1616,41 +1843,47 @@ UpdateStringOfList(listPtr) if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int)); + /* We know numElems <= LIST_MAX, so this is safe. */ + flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int)); } - listPtr->length = 1; + elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { - elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length); - listPtr->length += Tcl_ScanCountedElement(elem, length, - &flagPtr[i]) + 1; - /* - * Check for continued sanity. [Bug 1267380] - */ - if (listPtr->length < 1) { - Tcl_Panic("string representation size exceeds sane bounds"); + 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((unsigned) bytesNeeded); dst = listPtr->bytes; for (i = 0; i < numElems; i++) { - elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length); - dst += Tcl_ConvertCountedElement(elem, length, dst, flagPtr[i]); - *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; - } - listPtr->length = dst - listPtr->bytes; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |