tclListObj.c

Go to the documentation of this file.
00001 /*
00002  * tclListObj.c --
00003  *
00004  *      This file contains functions that implement the Tcl list object type.
00005  *
00006  * Copyright (c) 1995-1997 Sun Microsystems, Inc.
00007  * Copyright (c) 1998 by Scriptics Corporation.
00008  * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
00009  *
00010  * See the file "license.terms" for information on usage and redistribution of
00011  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00012  *
00013  * RCS: @(#) $Id: tclListObj.c,v 1.49 2007/12/13 15:23:18 dgp Exp $
00014  */
00015 
00016 #include "tclInt.h"
00017 
00018 /*
00019  * Prototypes for functions defined later in this file:
00020  */
00021 
00022 static List *           NewListIntRep(int objc, Tcl_Obj *CONST objv[]);
00023 static void             DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
00024 static void             FreeListInternalRep(Tcl_Obj *listPtr);
00025 static int              SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
00026 static void             UpdateStringOfList(Tcl_Obj *listPtr);
00027 
00028 /*
00029  * The structure below defines the list Tcl object type by means of functions
00030  * that can be invoked by generic object code.
00031  *
00032  * The internal representation of a list object is a two-pointer
00033  * representation. The first pointer designates a List structure that contains
00034  * an array of pointers to the element objects, together with integers that
00035  * represent the current element count and the allocated size of the array.
00036  * The second pointer is normally NULL; during execution of functions in this
00037  * file that operate on nested sublists, it is occasionally used as working
00038  * storage to avoid an auxiliary stack.
00039  */
00040 
00041 Tcl_ObjType tclListType = {
00042     "list",                     /* name */
00043     FreeListInternalRep,        /* freeIntRepProc */
00044     DupListInternalRep,         /* dupIntRepProc */
00045     UpdateStringOfList,         /* updateStringProc */
00046     SetListFromAny              /* setFromAnyProc */
00047 };
00048 
00049 /*
00050  *----------------------------------------------------------------------
00051  *
00052  * NewListIntRep --
00053  *
00054  *      If objc>0 and objv!=NULL, this function creates a list internal rep
00055  *      with objc elements given in the array objv. If objc>0 and objv==NULL
00056  *      it creates the list internal rep of a list with 0 elements, where
00057  *      enough space has been preallocated to store objc elements. If objc<=0,
00058  *      it returns NULL.
00059  *
00060  * Results:
00061  *      A new List struct is returned. If objc<=0 or if the allocation fails
00062  *      for lack of memory, NULL is returned. The list returned has refCount
00063  *      0.
00064  *
00065  * Side effects:
00066  *      The ref counts of the elements in objv are incremented since the
00067  *      resulting list now refers to them.
00068  *
00069  *----------------------------------------------------------------------
00070  */
00071 
00072 static List *
00073 NewListIntRep(
00074     int objc,
00075     Tcl_Obj *CONST objv[])
00076 {
00077     List *listRepPtr;
00078 
00079     if (objc <= 0) {
00080         return NULL;
00081     }
00082 
00083     /*
00084      * First check to see if we'd overflow and try to allocate an object
00085      * larger than our memory allocator allows. Note that this is actually a
00086      * fairly small value when you're on a serious 64-bit machine, but that
00087      * requires API changes to fix. See [Bug 219196] for a discussion.
00088      */
00089 
00090     if ((size_t)objc > INT_MAX/sizeof(Tcl_Obj *)) {
00091         return NULL;
00092     }
00093 
00094     listRepPtr = (List *)
00095             attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)));
00096     if (listRepPtr == NULL) {
00097         return NULL;
00098     }
00099 
00100     listRepPtr->canonicalFlag = 0;
00101     listRepPtr->refCount = 0;
00102     listRepPtr->maxElemCount = objc;
00103 
00104     if (objv) {
00105         Tcl_Obj **elemPtrs;
00106         int i;
00107 
00108         listRepPtr->elemCount = objc;
00109         elemPtrs = &listRepPtr->elements;
00110         for (i = 0;  i < objc;  i++) {
00111             elemPtrs[i] = objv[i];
00112             Tcl_IncrRefCount(elemPtrs[i]);
00113         }
00114     } else {
00115         listRepPtr->elemCount = 0;
00116     }
00117     return listRepPtr;
00118 }
00119 
00120 /*
00121  *----------------------------------------------------------------------
00122  *
00123  * Tcl_NewListObj --
00124  *
00125  *      This function is normally called when not debugging: i.e., when
00126  *      TCL_MEM_DEBUG is not defined. It creates a new list object from an
00127  *      (objc,objv) array: that is, each of the objc elements of the array
00128  *      referenced by objv is inserted as an element into a new Tcl object.
00129  *
00130  *      When TCL_MEM_DEBUG is defined, this function just returns the result
00131  *      of calling the debugging version Tcl_DbNewListObj.
00132  *
00133  * Results:
00134  *      A new list object is returned that is initialized from the object
00135  *      pointers in objv. If objc is less than or equal to zero, an empty
00136  *      object is returned. The new object's string representation is left
00137  *      NULL. The resulting new list object has ref count 0.
00138  *
00139  * Side effects:
00140  *      The ref counts of the elements in objv are incremented since the
00141  *      resulting list now refers to them.
00142  *
00143  *----------------------------------------------------------------------
00144  */
00145 
00146 #ifdef TCL_MEM_DEBUG
00147 #undef Tcl_NewListObj
00148 
00149 Tcl_Obj *
00150 Tcl_NewListObj(
00151     int objc,                   /* Count of objects referenced by objv. */
00152     Tcl_Obj *CONST objv[])      /* An array of pointers to Tcl objects. */
00153 {
00154     return Tcl_DbNewListObj(objc, objv, "unknown", 0);
00155 }
00156 
00157 #else /* if not TCL_MEM_DEBUG */
00158 
00159 Tcl_Obj *
00160 Tcl_NewListObj(
00161     int objc,                   /* Count of objects referenced by objv. */
00162     Tcl_Obj *CONST objv[])      /* An array of pointers to Tcl objects. */
00163 {
00164     List *listRepPtr;
00165     Tcl_Obj *listPtr;
00166 
00167     TclNewObj(listPtr);
00168 
00169     if (objc <= 0) {
00170         return listPtr;
00171     }
00172 
00173     /*
00174      * Create the internal rep.
00175      */
00176 
00177     listRepPtr = NewListIntRep(objc, objv);
00178     if (!listRepPtr) {
00179         Tcl_Panic("Not enough memory to allocate list");
00180     }
00181 
00182     /*
00183      * Now create the object.
00184      */
00185 
00186     Tcl_InvalidateStringRep(listPtr);
00187     listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
00188     listPtr->internalRep.twoPtrValue.ptr2 = NULL;
00189     listPtr->typePtr = &tclListType;
00190     listRepPtr->refCount++;
00191 
00192     return listPtr;
00193 }
00194 #endif /* if TCL_MEM_DEBUG */
00195 
00196 /*
00197  *----------------------------------------------------------------------
00198  *
00199  * Tcl_DbNewListObj --
00200  *
00201  *      This function is normally called when debugging: i.e., when
00202  *      TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
00203  *      as the Tcl_NewListObj function above except that it calls
00204  *      Tcl_DbCkalloc directly with the file name and line number from its
00205  *      caller. This simplifies debugging since then the [memory active]
00206  *      command will report the correct file name and line number when
00207  *      reporting objects that haven't been freed.
00208  *
00209  *      When TCL_MEM_DEBUG is not defined, this function just returns the
00210  *      result of calling Tcl_NewListObj.
00211  *
00212  * Results:
00213  *      A new list object is returned that is initialized from the object
00214  *      pointers in objv. If objc is less than or equal to zero, an empty
00215  *      object is returned. The new object's string representation is left
00216  *      NULL. The new list object has ref count 0.
00217  *
00218  * Side effects:
00219  *      The ref counts of the elements in objv are incremented since the
00220  *      resulting list now refers to them.
00221  *
00222  *----------------------------------------------------------------------
00223  */
00224 
00225 #ifdef TCL_MEM_DEBUG
00226 
00227 Tcl_Obj *
00228 Tcl_DbNewListObj(
00229     int objc,                   /* Count of objects referenced by objv. */
00230     Tcl_Obj *CONST objv[],      /* An array of pointers to Tcl objects. */
00231     CONST char *file,           /* The name of the source file calling this
00232                                  * function; used for debugging. */
00233     int line)                   /* Line number in the source file; used for
00234                                  * debugging. */
00235 {
00236     Tcl_Obj *listPtr;
00237     List *listRepPtr;
00238 
00239     TclDbNewObj(listPtr, file, line);
00240 
00241     if (objc <= 0) {
00242         return listPtr;
00243     }
00244 
00245     /*
00246      * Create the internal rep.
00247      */
00248 
00249     listRepPtr = NewListIntRep(objc, objv);
00250     if (!listRepPtr) {
00251         Tcl_Panic("Not enough memory to allocate list");
00252     }
00253 
00254     /*
00255      * Now create the object.
00256      */
00257 
00258     Tcl_InvalidateStringRep(listPtr);
00259     listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
00260     listPtr->internalRep.twoPtrValue.ptr2 = NULL;
00261     listPtr->typePtr = &tclListType;
00262     listRepPtr->refCount++;
00263 
00264     return listPtr;
00265 }
00266 
00267 #else /* if not TCL_MEM_DEBUG */
00268 
00269 Tcl_Obj *
00270 Tcl_DbNewListObj(
00271     int objc,                   /* Count of objects referenced by objv. */
00272     Tcl_Obj *CONST objv[],      /* An array of pointers to Tcl objects. */
00273     CONST char *file,           /* The name of the source file calling this
00274                                  * function; used for debugging. */
00275     int line)                   /* Line number in the source file; used for
00276                                  * debugging. */
00277 {
00278     return Tcl_NewListObj(objc, objv);
00279 }
00280 #endif /* TCL_MEM_DEBUG */
00281 
00282 /*
00283  *----------------------------------------------------------------------
00284  *
00285  * Tcl_SetListObj --
00286  *
00287  *      Modify an object to be a list containing each of the objc elements of
00288  *      the object array referenced by objv.
00289  *
00290  * Results:
00291  *      None.
00292  *
00293  * Side effects:
00294  *      The object is made a list object and is initialized from the object
00295  *      pointers in objv. If objc is less than or equal to zero, an empty
00296  *      object is returned. The new object's string representation is left
00297  *      NULL. The ref counts of the elements in objv are incremented since the
00298  *      list now refers to them. The object's old string and internal
00299  *      representations are freed and its type is set NULL.
00300  *
00301  *----------------------------------------------------------------------
00302  */
00303 
00304 void
00305 Tcl_SetListObj(
00306     Tcl_Obj *objPtr,            /* Object whose internal rep to init. */
00307     int objc,                   /* Count of objects referenced by objv. */
00308     Tcl_Obj *CONST objv[])      /* An array of pointers to Tcl objects. */
00309 {
00310     List *listRepPtr;
00311 
00312     if (Tcl_IsShared(objPtr)) {
00313         Tcl_Panic("%s called with shared object", "Tcl_SetListObj");
00314     }
00315 
00316     /*
00317      * Free any old string rep and any internal rep for the old type.
00318      */
00319 
00320     TclFreeIntRep(objPtr);
00321     objPtr->typePtr = NULL;
00322     Tcl_InvalidateStringRep(objPtr);
00323 
00324     /*
00325      * Set the object's type to "list" and initialize the internal rep.
00326      * However, if there are no elements to put in the list, just give the
00327      * object an empty string rep and a NULL type.
00328      */
00329 
00330     if (objc > 0) {
00331         listRepPtr = NewListIntRep(objc, objv);
00332         if (!listRepPtr) {
00333             Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj");
00334         }
00335         objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
00336         objPtr->internalRep.twoPtrValue.ptr2 = NULL;
00337         objPtr->typePtr = &tclListType;
00338         listRepPtr->refCount++;
00339     } else {
00340         objPtr->bytes = tclEmptyStringRep;
00341         objPtr->length = 0;
00342     }
00343 }
00344 
00345 /*
00346  *----------------------------------------------------------------------
00347  *
00348  * TclListObjCopy --
00349  *
00350  *      Makes a "pure list" copy of a list value. This provides for the C
00351  *      level a counterpart of the [lrange $list 0 end] command, while using
00352  *      internals details to be as efficient as possible.
00353  *
00354  * Results:
00355  *      Normally returns a pointer to a new Tcl_Obj, that contains the same
00356  *      list value as *listPtr does. The returned Tcl_Obj has a refCount of
00357  *      zero. If *listPtr does not hold a list, NULL is returned, and if
00358  *      interp is non-NULL, an error message is recorded there.
00359  *
00360  * Side effects:
00361  *      None.
00362  *
00363  *----------------------------------------------------------------------
00364  */
00365 
00366 Tcl_Obj *
00367 TclListObjCopy(
00368     Tcl_Interp *interp,         /* Used to report errors if not NULL. */
00369     Tcl_Obj *listPtr)           /* List object for which an element array is
00370                                  * to be returned. */
00371 {
00372     Tcl_Obj *copyPtr;
00373 
00374     if (listPtr->typePtr != &tclListType) {
00375         if (SetListFromAny(interp, listPtr) != TCL_OK) {
00376             return NULL;
00377         }
00378     }
00379 
00380     TclNewObj(copyPtr);
00381     TclInvalidateStringRep(copyPtr);
00382     DupListInternalRep(listPtr, copyPtr);
00383     return copyPtr;
00384 }
00385 
00386 /*
00387  *----------------------------------------------------------------------
00388  *
00389  * Tcl_ListObjGetElements --
00390  *
00391  *      This function returns an (objc,objv) array of the elements in a list
00392  *      object.
00393  *
00394  * Results:
00395  *      The return value is normally TCL_OK; in this case *objcPtr is set to
00396  *      the count of list elements and *objvPtr is set to a pointer to an
00397  *      array of (*objcPtr) pointers to each list element. If listPtr does not
00398  *      refer to a list object and the object can not be converted to one,
00399  *      TCL_ERROR is returned and an error message will be left in the
00400  *      interpreter's result if interp is not NULL.
00401  *
00402  *      The objects referenced by the returned array should be treated as
00403  *      readonly and their ref counts are _not_ incremented; the caller must
00404  *      do that if it holds on to a reference. Furthermore, the pointer and
00405  *      length returned by this function may change as soon as any function is
00406  *      called on the list object; be careful about retaining the pointer in a
00407  *      local data structure.
00408  *
00409  * Side effects:
00410  *      The possible conversion of the object referenced by listPtr
00411  *      to a list object.
00412  *
00413  *----------------------------------------------------------------------
00414  */
00415 
00416 int
00417 Tcl_ListObjGetElements(
00418     Tcl_Interp *interp,         /* Used to report errors if not NULL. */
00419     register Tcl_Obj *listPtr,  /* List object for which an element array is
00420                                  * to be returned. */
00421     int *objcPtr,               /* Where to store the count of objects
00422                                  * referenced by objv. */
00423     Tcl_Obj ***objvPtr)         /* Where to store the pointer to an array of
00424                                  * pointers to the list's objects. */
00425 {
00426     register List *listRepPtr;
00427 
00428     if (listPtr->typePtr != &tclListType) {
00429         int result, length;
00430 
00431         (void) TclGetStringFromObj(listPtr, &length);
00432         if (!length) {
00433             *objcPtr = 0;
00434             *objvPtr = NULL;
00435             return TCL_OK;
00436         }
00437 
00438         result = SetListFromAny(interp, listPtr);
00439         if (result != TCL_OK) {
00440             return result;
00441         }
00442     }
00443     listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
00444     *objcPtr = listRepPtr->elemCount;
00445     *objvPtr = &listRepPtr->elements;
00446     return TCL_OK;
00447 }
00448 
00449 /*
00450  *----------------------------------------------------------------------
00451  *
00452  * Tcl_ListObjAppendList --
00453  *
00454  *      This function appends the objects in the list referenced by
00455  *      elemListPtr to the list object referenced by listPtr. If listPtr is
00456  *      not already a list object, an attempt will be made to convert it to
00457  *      one.
00458  *
00459  * Results:
00460  *      The return value is normally TCL_OK. If listPtr or elemListPtr do not
00461  *      refer to list objects and they can not be converted to one, TCL_ERROR
00462  *      is returned and an error message is left in the interpreter's result
00463  *      if interp is not NULL.
00464  *
00465  * Side effects:
00466  *      The reference counts of the elements in elemListPtr are incremented
00467  *      since the list now refers to them. listPtr and elemListPtr are
00468  *      converted, if necessary, to list objects. Also, appending the new
00469  *      elements may cause listObj's array of element pointers to grow.
00470  *      listPtr's old string representation, if any, is invalidated.
00471  *
00472  *----------------------------------------------------------------------
00473  */
00474 
00475 int
00476 Tcl_ListObjAppendList(
00477     Tcl_Interp *interp,         /* Used to report errors if not NULL. */
00478     register Tcl_Obj *listPtr,  /* List object to append elements to. */
00479     Tcl_Obj *elemListPtr)       /* List obj with elements to append. */
00480 {
00481     int listLen, objc, result;
00482     Tcl_Obj **objv;
00483 
00484     if (Tcl_IsShared(listPtr)) {
00485         Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
00486     }
00487 
00488     result = TclListObjLength(interp, listPtr, &listLen);
00489     if (result != TCL_OK) {
00490         return result;
00491     }
00492 
00493     result = TclListObjGetElements(interp, elemListPtr, &objc, &objv);
00494     if (result != TCL_OK) {
00495         return result;
00496     }
00497 
00498     /*
00499      * Insert objc new elements starting after the lists's last element.
00500      * Delete zero existing elements.
00501      */
00502 
00503     return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv);
00504 }
00505 
00506 /*
00507  *----------------------------------------------------------------------
00508  *
00509  * Tcl_ListObjAppendElement --
00510  *
00511  *      This function is a special purpose version of Tcl_ListObjAppendList:
00512  *      it appends a single object referenced by objPtr to the list object
00513  *      referenced by listPtr. If listPtr is not already a list object, an
00514  *      attempt will be made to convert it to one.
00515  *
00516  * Results:
00517  *      The return value is normally TCL_OK; in this case objPtr is added to
00518  *      the end of listPtr's list. If listPtr does not refer to a list object
00519  *      and the object can not be converted to one, TCL_ERROR is returned and
00520  *      an error message will be left in the interpreter's result if interp is
00521  *      not NULL.
00522  *
00523  * Side effects:
00524  *      The ref count of objPtr is incremented since the list now refers to
00525  *      it. listPtr will be converted, if necessary, to a list object. Also,
00526  *      appending the new element may cause listObj's array of element
00527  *      pointers to grow. listPtr's old string representation, if any, is
00528  *      invalidated.
00529  *
00530  *----------------------------------------------------------------------
00531  */
00532 
00533 int
00534 Tcl_ListObjAppendElement(
00535     Tcl_Interp *interp,         /* Used to report errors if not NULL. */
00536     Tcl_Obj *listPtr,           /* List object to append objPtr to. */
00537     Tcl_Obj *objPtr)            /* Object to append to listPtr's list. */
00538 {
00539     register List *listRepPtr;
00540     register Tcl_Obj **elemPtrs;
00541     int numElems, numRequired, newMax, newSize, i;
00542 
00543     if (Tcl_IsShared(listPtr)) {
00544         Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
00545     }
00546     if (listPtr->typePtr != &tclListType) {
00547         int result, length;
00548 
00549         (void) TclGetStringFromObj(listPtr, &length);
00550         if (!length) {
00551             Tcl_SetListObj(listPtr, 1, &objPtr);
00552             return TCL_OK;
00553         }
00554 
00555         result = SetListFromAny(interp, listPtr);
00556         if (result != TCL_OK) {
00557             return result;
00558         }
00559     }
00560 
00561     listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
00562     numElems = listRepPtr->elemCount;
00563     numRequired = numElems + 1 ;
00564 
00565     /*
00566      * If there is no room in the current array of element pointers, allocate
00567      * a new, larger array and copy the pointers to it. If the List struct is
00568      * shared, allocate a new one.
00569      */
00570 
00571     if (numRequired > listRepPtr->maxElemCount){
00572         newMax = 2 * numRequired;
00573         newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *));
00574     } else {
00575         newMax = listRepPtr->maxElemCount;
00576         newSize = 0;
00577     }
00578 
00579     if (listRepPtr->refCount > 1) {
00580         List *oldListRepPtr = listRepPtr;
00581         Tcl_Obj **oldElems;
00582 
00583         listRepPtr = NewListIntRep(newMax, NULL);
00584         if (!listRepPtr) {
00585             Tcl_Panic("Not enough memory to allocate list");
00586         }
00587         oldElems = &oldListRepPtr->elements;
00588         elemPtrs = &listRepPtr->elements;
00589         for (i=0; i<numElems; i++) {
00590             elemPtrs[i] = oldElems[i];
00591             Tcl_IncrRefCount(elemPtrs[i]);
00592         }
00593         listRepPtr->elemCount = numElems;
00594         listRepPtr->refCount++;
00595         oldListRepPtr->refCount--;
00596         listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
00597     } else if (newSize) {
00598         listRepPtr = (List *) ckrealloc((char *)listRepPtr, (size_t)newSize);
00599         listRepPtr->maxElemCount = newMax;
00600         listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
00601     }
00602 
00603     /*
00604      * Add objPtr to the end of listPtr's array of element pointers. Increment
00605      * the ref count for the (now shared) objPtr.
00606      */
00607 
00608     elemPtrs = &listRepPtr->elements;
00609     elemPtrs[numElems] = objPtr;
00610     Tcl_IncrRefCount(objPtr);
00611     listRepPtr->elemCount++;
00612 
00613     /*
00614      * Invalidate any old string representation since the list's internal
00615      * representation has changed.
00616      */
00617 
00618     Tcl_InvalidateStringRep(listPtr);
00619     return TCL_OK;
00620 }
00621 
00622 /*
00623  *----------------------------------------------------------------------
00624  *
00625  * Tcl_ListObjIndex --
00626  *
00627  *      This function returns a pointer to the index'th object from the list
00628  *      referenced by listPtr. The first element has index 0. If index is
00629  *      negative or greater than or equal to the number of elements in the
00630  *      list, a NULL is returned. If listPtr is not a list object, an attempt
00631  *      will be made to convert it to a list.
00632  *
00633  * Results:
00634  *      The return value is normally TCL_OK; in this case objPtrPtr is set to
00635  *      the Tcl_Obj pointer for the index'th list element or NULL if index is
00636  *      out of range. This object should be treated as readonly and its ref
00637  *      count is _not_ incremented; the caller must do that if it holds on to
00638  *      the reference. If listPtr does not refer to a list and can't be
00639  *      converted to one, TCL_ERROR is returned and an error message is left
00640  *      in the interpreter's result if interp is not NULL.
00641  *
00642  * Side effects:
00643  *      listPtr will be converted, if necessary, to a list object.
00644  *
00645  *----------------------------------------------------------------------
00646  */
00647 
00648 int
00649 Tcl_ListObjIndex(
00650     Tcl_Interp *interp,         /* Used to report errors if not NULL. */
00651     register Tcl_Obj *listPtr,  /* List object to index into. */
00652     register int index,         /* Index of element to return. */
00653     Tcl_Obj **objPtrPtr)        /* The resulting Tcl_Obj* is stored here. */
00654 {
00655     register List *listRepPtr;
00656 
00657     if (listPtr->typePtr != &tclListType) {
00658         int result, length;
00659 
00660         (void) TclGetStringFromObj(listPtr, &length);
00661         if (!length) {
00662             *objPtrPtr = NULL;
00663             return TCL_OK;
00664         }
00665 
00666         result = SetListFromAny(interp, listPtr);
00667         if (result != TCL_OK) {
00668             return result;
00669         }
00670     }
00671 
00672     listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
00673     if ((index < 0) || (index >= listRepPtr->elemCount)) {
00674         *objPtrPtr = NULL;
00675     } else {
00676         *objPtrPtr = (&listRepPtr->elements)[index];
00677     }
00678 
00679     return TCL_OK;
00680 }
00681 
00682 /*
00683  *----------------------------------------------------------------------
00684  *
00685  * Tcl_ListObjLength --
00686  *
00687  *      This function returns the number of elements in a list object. If the
00688  *      object is not already a list object, an attempt will be made to
00689  *      convert it to one.
00690  *
00691  * Results:
00692  *      The return value is normally TCL_OK; in this case *intPtr will be set
00693  *      to the integer count of list elements. If listPtr does not refer to a
00694  *      list object and the object can not be converted to one, TCL_ERROR is
00695  *      returned and an error message will be left in the interpreter's result
00696  *      if interp is not NULL.
00697  *
00698  * Side effects:
00699  *      The possible conversion of the argument object to a list object.
00700  *
00701  *----------------------------------------------------------------------
00702  */
00703 
00704 int
00705 Tcl_ListObjLength(
00706     Tcl_Interp *interp,         /* Used to report errors if not NULL. */
00707     register Tcl_Obj *listPtr,  /* List object whose #elements to return. */
00708     register int *intPtr)       /* The resulting int is stored here. */
00709 {
00710     register List *listRepPtr;
00711 
00712     if (listPtr->typePtr != &tclListType) {
00713         int result, length;
00714 
00715         (void) TclGetStringFromObj(listPtr, &length);
00716         if (!length) {
00717             *intPtr = 0;
00718             return TCL_OK;
00719         }
00720 
00721         result = SetListFromAny(interp, listPtr);
00722         if (result != TCL_OK) {
00723             return result;
00724         }
00725     }
00726 
00727     listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
00728     *intPtr = listRepPtr->elemCount;
00729     return TCL_OK;
00730 }
00731 
00732 /*
00733  *----------------------------------------------------------------------
00734  *
00735  * Tcl_ListObjReplace --
00736  *
00737  *      This function replaces zero or more elements of the list referenced by
00738  *      listPtr with the objects from an (objc,objv) array. The objc elements
00739  *      of the array referenced by objv replace the count elements in listPtr
00740  *      starting at first.
00741  *
00742  *      If the argument first is zero or negative, it refers to the first
00743  *      element. If first is greater than or equal to the number of elements
00744  *      in the list, then no elements are deleted; the new elements are
00745  *      appended to the list. Count gives the number of elements to replace.
00746  *      If count is zero or negative then no elements are deleted; the new
00747  *      elements are simply inserted before first.
00748  *
00749  *      The argument objv refers to an array of objc pointers to the new
00750  *      elements to be added to listPtr in place of those that were deleted.
00751  *      If objv is NULL, no new elements are added. If listPtr is not a list
00752  *      object, an attempt will be made to convert it to one.
00753  *
00754  * Results:
00755  *      The return value is normally TCL_OK. If listPtr does not refer to a
00756  *      list object and can not be converted to one, TCL_ERROR is returned and
00757  *      an error message will be left in the interpreter's result if interp is
00758  *      not NULL.
00759  *
00760  * Side effects:
00761  *      The ref counts of the objc elements in objv are incremented since the
00762  *      resulting list now refers to them. Similarly, the ref counts for
00763  *      replaced objects are decremented. listPtr is converted, if necessary,
00764  *      to a list object. listPtr's old string representation, if any, is
00765  *      freed.
00766  *
00767  *----------------------------------------------------------------------
00768  */
00769 
00770 int
00771 Tcl_ListObjReplace(
00772     Tcl_Interp *interp,         /* Used for error reporting if not NULL. */
00773     Tcl_Obj *listPtr,           /* List object whose elements to replace. */
00774     int first,                  /* Index of first element to replace. */
00775     int count,                  /* Number of elements to replace. */
00776     int objc,                   /* Number of objects to insert. */
00777     Tcl_Obj *CONST objv[])      /* An array of objc pointers to Tcl objects to
00778                                  * insert. */
00779 {
00780     List *listRepPtr;
00781     register Tcl_Obj **elemPtrs;
00782     int numElems, numRequired, numAfterLast, start, i, j, isShared;
00783 
00784     if (Tcl_IsShared(listPtr)) {
00785         Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
00786     }
00787     if (listPtr->typePtr != &tclListType) {
00788         int length;
00789 
00790         (void) TclGetStringFromObj(listPtr, &length);
00791         if (!length) {
00792             if (objc) {
00793                 Tcl_SetListObj(listPtr, objc, NULL);
00794             } else {
00795                 return TCL_OK;
00796             }
00797         } else {
00798             int result = SetListFromAny(interp, listPtr);
00799 
00800             if (result != TCL_OK) {
00801                 return result;
00802             }
00803         }
00804     }
00805 
00806     /*
00807      * Note that when count == 0 and objc == 0, this routine is logically a
00808      * no-op, removing and adding no elements to the list. However, by flowing
00809      * through this routine anyway, we get the important side effect that the
00810      * resulting listPtr is a list in canoncial form. This is important.
00811      * Resist any temptation to optimize this case.
00812      */
00813 
00814     listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
00815     elemPtrs = &listRepPtr->elements;
00816     numElems = listRepPtr->elemCount;
00817 
00818     if (first < 0) {
00819         first = 0;
00820     }
00821     if (first >= numElems) {
00822         first = numElems;       /* So we'll insert after last element. */
00823     }
00824     if (count < 0) {
00825         count = 0;
00826     } else if (numElems < first+count) {
00827         count = numElems - first;
00828     }
00829 
00830     isShared = (listRepPtr->refCount > 1);
00831     numRequired = numElems - count + objc;
00832 
00833     if ((numRequired <= listRepPtr->maxElemCount) && !isShared) {
00834         int shift;
00835 
00836         /*
00837          * Can use the current List struct. First "delete" count elements
00838          * starting at first.
00839          */
00840 
00841         for (j = first;  j < first + count;  j++) {
00842             Tcl_Obj *victimPtr = elemPtrs[j];
00843 
00844             TclDecrRefCount(victimPtr);
00845         }
00846 
00847         /*
00848          * Shift the elements after the last one removed to their new
00849          * locations.
00850          */
00851 
00852         start = first + count;
00853         numAfterLast = numElems - start;
00854         shift = objc - count;   /* numNewElems - numDeleted */
00855         if ((numAfterLast > 0) && (shift != 0)) {
00856             Tcl_Obj **src = elemPtrs + start;
00857 
00858             memmove(src+shift, src, (size_t) numAfterLast * sizeof(Tcl_Obj*));
00859         }
00860     } else {
00861         /*
00862          * Cannot use the current List struct; it is shared, too small, or
00863          * both. Allocate a new struct and insert elements into it.
00864          */
00865 
00866         List *oldListRepPtr = listRepPtr;
00867         Tcl_Obj **oldPtrs = elemPtrs;
00868         int newMax;
00869 
00870         if (numRequired > listRepPtr->maxElemCount){
00871             newMax = 2 * numRequired;
00872         } else {
00873             newMax = listRepPtr->maxElemCount;
00874         }
00875 
00876         listRepPtr = NewListIntRep(newMax, NULL);
00877         if (!listRepPtr) {
00878             Tcl_Panic("Not enough memory to allocate list");
00879         }
00880 
00881         listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
00882         listRepPtr->refCount++;
00883 
00884         elemPtrs = &listRepPtr->elements;
00885 
00886         if (isShared) {
00887             /*
00888              * The old struct will remain in place; need new refCounts for the
00889              * new List struct references. Copy over only the surviving
00890              * elements.
00891              */
00892 
00893             for (i=0; i < first; i++) {
00894                 elemPtrs[i] = oldPtrs[i];
00895                 Tcl_IncrRefCount(elemPtrs[i]);
00896             }
00897             for (i = first + count, j = first + objc;
00898                     j < numRequired; i++, j++) {
00899                 elemPtrs[j] = oldPtrs[i];
00900                 Tcl_IncrRefCount(elemPtrs[j]);
00901             }
00902 
00903             oldListRepPtr->refCount--;
00904         } else {
00905             /*
00906              * The old struct will be removed; use its inherited refCounts.
00907              */
00908 
00909             if (first > 0) {
00910                 memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *));
00911             }
00912 
00913             /*
00914              * "Delete" count elements starting at first.
00915              */
00916 
00917             for (j = first;  j < first + count;  j++) {
00918                 Tcl_Obj *victimPtr = oldPtrs[j];
00919 
00920                 TclDecrRefCount(victimPtr);
00921             }
00922 
00923             /*
00924              * Copy the elements after the last one removed, shifted to their
00925              * new locations.
00926              */
00927 
00928             start = first + count;
00929             numAfterLast = numElems - start;
00930             if (numAfterLast > 0) {
00931                 memcpy(elemPtrs + first + objc, oldPtrs + start,
00932                         (size_t) numAfterLast * sizeof(Tcl_Obj *));
00933             }
00934 
00935             ckfree((char *) oldListRepPtr);
00936         }
00937     }
00938 
00939     /*
00940      * Insert the new elements into elemPtrs before "first". We don't do a
00941      * memcpy here because we must increment the reference counts for the
00942      * added elements, so we must explicitly loop anyway.
00943      */
00944 
00945     for (i=0,j=first ; i<objc ; i++,j++) {
00946         elemPtrs[j] = objv[i];
00947         Tcl_IncrRefCount(objv[i]);
00948     }
00949 
00950     /*
00951      * Update the count of elements.
00952      */
00953 
00954     listRepPtr->elemCount = numRequired;
00955 
00956     /*
00957      * Invalidate and free any old string representation since it no longer
00958      * reflects the list's internal representation.
00959      */
00960 
00961     Tcl_InvalidateStringRep(listPtr);
00962     return TCL_OK;
00963 }
00964 
00965 /*
00966  *----------------------------------------------------------------------
00967  *
00968  * TclLindexList --
00969  *
00970  *      This procedure handles the 'lindex' command when objc==3.
00971  *
00972  * Results:
00973  *      Returns a pointer to the object extracted, or NULL if an error
00974  *      occurred. The returned object already includes one reference count for
00975  *      the pointer returned.
00976  *
00977  * Side effects:
00978  *      None.
00979  *
00980  * Notes:
00981  *      This procedure is implemented entirely as a wrapper around
00982  *      TclLindexFlat. All it does is reconfigure the argument format into the
00983  *      form required by TclLindexFlat, while taking care to manage shimmering
00984  *      in such a way that we tend to keep the most useful intreps and/or
00985  *      avoid the most expensive conversions.
00986  *
00987  *----------------------------------------------------------------------
00988  */
00989 
00990 Tcl_Obj *
00991 TclLindexList(
00992     Tcl_Interp *interp,         /* Tcl interpreter. */
00993     Tcl_Obj *listPtr,           /* List being unpacked. */
00994     Tcl_Obj *argPtr)            /* Index or index list. */
00995 {
00996 
00997     int index;                  /* Index into the list. */
00998     Tcl_Obj **indices;          /* Array of list indices. */
00999     int indexCount;             /* Size of the array of list indices. */
01000     Tcl_Obj *indexListCopy;
01001 
01002     /*
01003      * Determine whether argPtr designates a list or a single index. We have
01004      * to be careful about the order of the checks to avoid repeated
01005      * shimmering; see TIP#22 and TIP#33 for the details.
01006      */
01007 
01008     if (argPtr->typePtr != &tclListType
01009             && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) {
01010         /*
01011          * argPtr designates a single index.
01012          */
01013 
01014         return TclLindexFlat(interp, listPtr, 1, &argPtr);
01015     }
01016 
01017     /*
01018      * Here we make a private copy of the index list argument to avoid any
01019      * shimmering issues that might invalidate the indices array below while
01020      * we are still using it. This is probably unnecessary. It does not appear
01021      * that any damaging shimmering is possible, and no test has been devised
01022      * to show any error when this private copy is not made. But it's cheap,
01023      * and it offers some future-proofing insurance in case the TclLindexFlat
01024      * implementation changes in some unexpected way, or some new form of
01025      * trace or callback permits things to happen that the current
01026      * implementation does not.
01027      */
01028 
01029     indexListCopy = TclListObjCopy(NULL, argPtr);
01030     if (indexListCopy == NULL) {
01031         /*
01032          * argPtr designates something that is neither an index nor a
01033          * well-formed list. Report the error via TclLindexFlat.
01034          */
01035 
01036         return TclLindexFlat(interp, listPtr, 1, &argPtr);
01037     }
01038 
01039     TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
01040     listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
01041     Tcl_DecrRefCount(indexListCopy);
01042     return listPtr;
01043 }
01044 
01045 /*
01046  *----------------------------------------------------------------------
01047  *
01048  * TclLindexFlat --
01049  *
01050  *      This procedure is the core of the 'lindex' command, with all index
01051  *      arguments presented as a flat list.
01052  *
01053  * Results:
01054  *      Returns a pointer to the object extracted, or NULL if an error
01055  *      occurred. The returned object already includes one reference count for
01056  *      the pointer returned.
01057  *
01058  * Side effects:
01059  *      None.
01060  *
01061  * Notes:
01062  *      The reference count of the returned object includes one reference
01063  *      corresponding to the pointer returned. Thus, the calling code will
01064  *      usually do something like:
01065  *              Tcl_SetObjResult(interp, result);
01066  *              Tcl_DecrRefCount(result);
01067  *
01068  *----------------------------------------------------------------------
01069  */
01070 
01071 Tcl_Obj *
01072 TclLindexFlat(
01073     Tcl_Interp *interp,         /* Tcl interpreter. */
01074     Tcl_Obj *listPtr,           /* Tcl object representing the list. */
01075     int indexCount,             /* Count of indices. */
01076     Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
01077                                  * represent the indices in the list. */
01078 {
01079     int i;
01080 
01081     Tcl_IncrRefCount(listPtr);
01082 
01083     for (i=0 ; i<indexCount && listPtr ; i++) {
01084         int index, listLen;
01085         Tcl_Obj **elemPtrs, *sublistCopy;
01086 
01087         /*
01088          * Here we make a private copy of the current sublist, so we avoid any
01089          * shimmering issues that might invalidate the elemPtr array below
01090          * while we are still using it. See test lindex-8.4.
01091          */
01092 
01093         sublistCopy = TclListObjCopy(interp, listPtr);
01094         Tcl_DecrRefCount(listPtr);
01095         listPtr = NULL;
01096 
01097         if (sublistCopy == NULL) {
01098             /*
01099              * The sublist is not a list at all => error.
01100              */
01101 
01102             break;
01103         }
01104         TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
01105 
01106         if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
01107                 &index) == TCL_OK) {
01108             if (index<0 || index>=listLen) {
01109                 /*
01110                  * Index is out of range. Break out of loop with empty result.
01111                  * First check remaining indices for validity
01112                  */
01113 
01114                 while (++i < indexCount) {
01115                     if (TclGetIntForIndexM(interp, indexArray[i], -1, &index)
01116                         != TCL_OK) {
01117                         Tcl_DecrRefCount(sublistCopy);
01118                         return NULL;
01119                     }
01120                 }
01121                 listPtr = Tcl_NewObj();
01122             } else {
01123                 /*
01124                  * Extract the pointer to the appropriate element.
01125                  */
01126 
01127                 listPtr = elemPtrs[index];
01128             }
01129             Tcl_IncrRefCount(listPtr);
01130         }
01131         Tcl_DecrRefCount(sublistCopy);
01132     }
01133 
01134     return listPtr;
01135 }
01136 
01137 /*
01138  *----------------------------------------------------------------------
01139  *
01140  * TclLsetList --
01141  *
01142  *      Core of the 'lset' command when objc == 4. Objv[2] may be either a
01143  *      scalar index or a list of indices.
01144  *
01145  * Results:
01146  *      Returns the new value of the list variable, or NULL if there was an
01147  *      error. The returned object includes one reference count for the
01148  *      pointer returned.
01149  *
01150  * Side effects:
01151  *      None.
01152  *
01153  * Notes:
01154  *      This procedure is implemented entirely as a wrapper around
01155  *      TclLsetFlat. All it does is reconfigure the argument format into the
01156  *      form required by TclLsetFlat, while taking care to manage shimmering
01157  *      in such a way that we tend to keep the most useful intreps and/or
01158  *      avoid the most expensive conversions.
01159  *
01160  *----------------------------------------------------------------------
01161  */
01162 
01163 Tcl_Obj *
01164 TclLsetList(
01165     Tcl_Interp *interp,         /* Tcl interpreter. */
01166     Tcl_Obj *listPtr,           /* Pointer to the list being modified. */
01167     Tcl_Obj *indexArgPtr,       /* Index or index-list arg to 'lset'. */
01168     Tcl_Obj *valuePtr)          /* Value arg to 'lset'. */
01169 {
01170     int indexCount;             /* Number of indices in the index list. */
01171     Tcl_Obj **indices;          /* Vector of indices in the index list. */
01172     Tcl_Obj *retValuePtr;       /* Pointer to the list to be returned. */
01173     int index;                  /* Current index in the list - discarded. */
01174     Tcl_Obj *indexListCopy;
01175 
01176     /*
01177      * Determine whether the index arg designates a list or a single index.
01178      * We have to be careful about the order of the checks to avoid repeated
01179      * shimmering; see TIP #22 and #23 for details.
01180      */
01181 
01182     if (indexArgPtr->typePtr != &tclListType
01183             && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) {
01184         /*
01185          * indexArgPtr designates a single index.
01186          */
01187 
01188         return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
01189 
01190     }
01191 
01192     indexListCopy = TclListObjCopy(NULL, indexArgPtr);
01193     if (indexListCopy == NULL) {
01194         /*
01195          * indexArgPtr designates something that is neither an index nor a
01196          * well formed list. Report the error via TclLsetFlat.
01197          */
01198 
01199         return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
01200     }
01201     TclListObjGetElements(NULL, indexArgPtr, &indexCount, &indices);
01202 
01203     /*
01204      * Let TclLsetFlat handle the actual lset'ting.
01205      */
01206 
01207     retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr);
01208 
01209     Tcl_DecrRefCount(indexListCopy);
01210     return retValuePtr;
01211 }
01212 
01213 /*
01214  *----------------------------------------------------------------------
01215  *
01216  * TclLsetFlat --
01217  *
01218  *      Core engine of the 'lset' command.
01219  *
01220  * Results:
01221  *      Returns the new value of the list variable, or NULL if an error
01222  *      occurred. The returned object includes one reference count for
01223  *      the pointer returned.
01224  *
01225  * Side effects:
01226  *      On entry, the reference count of the variable value does not reflect
01227  *      any references held on the stack. The first action of this function is
01228  *      to determine whether the object is shared, and to duplicate it if it
01229  *      is. The reference count of the duplicate is incremented. At this
01230  *      point, the reference count will be 1 for either case, so that the
01231  *      object will appear to be unshared.
01232  *
01233  *      If an error occurs, and the object has been duplicated, the reference
01234  *      count on the duplicate is decremented so that it is now 0: this
01235  *      dismisses any memory that was allocated by this function.
01236  *
01237  *      If no error occurs, the reference count of the original object is
01238  *      incremented if the object has not been duplicated, and nothing is done
01239  *      to a reference count of the duplicate. Now the reference count of an
01240  *      unduplicated object is 2 (the returned pointer, plus the one stored in
01241  *      the variable). The reference count of a duplicate object is 1,
01242  *      reflecting that the returned pointer is the only active reference. The
01243  *      caller is expected to store the returned value back in the variable
01244  *      and decrement its reference count. (INST_STORE_* does exactly this.)
01245  *
01246  *      Surgery is performed on the unshared list value to produce the result.
01247  *      TclLsetFlat maintains a linked list of Tcl_Obj's whose string
01248  *      representations must be spoilt by threading via 'ptr2' of the
01249  *      two-pointer internal representation. On entry to TclLsetFlat, the
01250  *      values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
01251  *      Tcl_Obj that has been modified is set to NULL.
01252  *
01253  *----------------------------------------------------------------------
01254  */
01255 
01256 Tcl_Obj *
01257 TclLsetFlat(
01258     Tcl_Interp *interp,         /* Tcl interpreter. */
01259     Tcl_Obj *listPtr,           /* Pointer to the list being modified. */
01260     int indexCount,             /* Number of index args. */
01261     Tcl_Obj *const indexArray[],
01262                                 /* Index args. */
01263     Tcl_Obj *valuePtr)          /* Value arg to 'lset'. */
01264 {
01265     int index, result;
01266     Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
01267 
01268     /*
01269      * If there are no indices, simply return the new value.
01270      * (Without indices, [lset] is a synonym for [set].
01271      */
01272 
01273     if (indexCount == 0) {
01274         Tcl_IncrRefCount(valuePtr);
01275         return valuePtr;
01276     }
01277 
01278     /*
01279      * If the list is shared, make a copy we can modify (copy-on-write).
01280      * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few
01281      * reasons: 1) we have not yet confirmed listPtr is actually a list;
01282      * 2) We make a verbatim copy of any existing string rep, and when
01283      * we combine that with the delayed invalidation of string reps of
01284      * modified Tcl_Obj's implemented below, the outcome is that any
01285      * error condition that causes this routine to return NULL, will
01286      * leave the string rep of listPtr and all elements to be unchanged.
01287      */
01288 
01289     subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
01290 
01291     /*
01292      * Anchor the linked list of Tcl_Obj's whose string reps must be
01293      * invalidated if the operation succeeds.
01294      */
01295 
01296     retValuePtr = subListPtr;
01297     chainPtr = NULL;
01298 
01299     /*
01300      * Loop through all the index arguments, and for each one dive
01301      * into the appropriate sublist.
01302      */
01303 
01304     do {
01305         int elemCount;
01306         Tcl_Obj *parentList, **elemPtrs;
01307 
01308         /* Check for the possible error conditions... */
01309         result = TCL_ERROR;
01310         if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
01311                 != TCL_OK) {
01312             /* ...the sublist we're indexing into isn't a list at all. */
01313             break;
01314         }
01315 
01316         /*
01317          * WARNING: the macro TclGetIntForIndexM is not safe for
01318          * post-increments, avoid '*indexArray++' here.
01319          */
01320         
01321         if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
01322                 != TCL_OK)  {
01323             /* ...the index we're trying to use isn't an index at all. */
01324             indexArray++;
01325             break;
01326         }
01327         indexArray++;
01328 
01329         if (index < 0 || index >= elemCount) {
01330             /* ...the index points outside the sublist. */
01331             Tcl_SetObjResult(interp,
01332                     Tcl_NewStringObj("list index out of range", -1));
01333             break;
01334         }
01335 
01336         /*
01337          * No error conditions.  As long as we're not yet on the last
01338          * index, determine the next sublist for the next pass through
01339          * the loop, and take steps to make sure it is an unshared copy,
01340          * as we intend to modify it.
01341          */
01342 
01343         result = TCL_OK;
01344         if (--indexCount) {
01345             parentList = subListPtr;
01346             subListPtr = elemPtrs[index];
01347             if (Tcl_IsShared(subListPtr)) {
01348                 subListPtr = Tcl_DuplicateObj(subListPtr);
01349             }
01350 
01351             /*
01352              * Replace the original elemPtr[index] in parentList with a copy
01353              * we know to be unshared.  This call will also deal with the
01354              * situation where parentList shares its intrep with other
01355              * Tcl_Obj's.  Dealing with the shared intrep case can cause
01356              * subListPtr to become shared again, so detect that case and
01357              * make and store another copy.
01358              */
01359 
01360             TclListObjSetElement(NULL, parentList, index, subListPtr);
01361             if (Tcl_IsShared(subListPtr)) {
01362                 subListPtr = Tcl_DuplicateObj(subListPtr);
01363                 TclListObjSetElement(NULL, parentList, index, subListPtr);
01364             }
01365 
01366             /*
01367              * The TclListObjSetElement() calls do not spoil the string
01368              * rep of parentList, and that's fine for now, since all we've
01369              * done so far is replace a list element with an unshared copy.
01370              * The list value remains the same, so the string rep. is still
01371              * valid, and unchanged, which is good because if this whole
01372              * routine returns NULL, we'd like to leave no change to the
01373              * value of the lset variable.  Later on, when we set valuePtr
01374              * in its proper place, then all containing lists will have
01375              * their values changed, and will need their string reps spoiled.
01376              * We maintain a list of all those Tcl_Obj's (via a little intrep
01377              * surgery) so we can spoil them at that time.
01378              */
01379 
01380             parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr;
01381             chainPtr = parentList;
01382         }
01383     } while (indexCount > 0);
01384 
01385     /*
01386      * Either we've detected and error condition, and exited the loop
01387      * with result == TCL_ERROR, or we've successfully reached the last
01388      * index, and we're ready to store valuePtr.  In either case, we
01389      * need to clean up our string spoiling list of Tcl_Obj's.
01390      */
01391 
01392     while (chainPtr) {
01393         Tcl_Obj *objPtr = chainPtr;
01394 
01395         if (result == TCL_OK) {
01396 
01397             /*
01398              * We're going to store valuePtr, so spoil string reps
01399              * of all containing lists.
01400              */
01401 
01402             Tcl_InvalidateStringRep(objPtr);
01403         }
01404 
01405         /* Clear away our intrep surgery mess */
01406         chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
01407         objPtr->internalRep.twoPtrValue.ptr2 = NULL;
01408     }
01409 
01410     if (result != TCL_OK) {
01411         /* 
01412          * Error return; message is already in interp. Clean up
01413          * any excess memory. 
01414          */
01415         if (retValuePtr != listPtr) {
01416             Tcl_DecrRefCount(retValuePtr);
01417         }
01418         return NULL;
01419     }
01420 
01421     /* Store valuePtr in proper sublist and return */
01422     TclListObjSetElement(NULL, subListPtr, index, valuePtr);
01423     Tcl_InvalidateStringRep(subListPtr);
01424     Tcl_IncrRefCount(retValuePtr);
01425     return retValuePtr;
01426 }
01427 
01428 /*
01429  *----------------------------------------------------------------------
01430  *
01431  * TclListObjSetElement --
01432  *
01433  *      Set a single element of a list to a specified value
01434  *
01435  * Results:
01436  *      The return value is normally TCL_OK. If listPtr does not refer to a
01437  *      list object and cannot be converted to one, TCL_ERROR is returned and
01438  *      an error message will be left in the interpreter result if interp is
01439  *      not NULL. Similarly, if index designates an element outside the range
01440  *      [0..listLength-1], where listLength is the count of elements in the
01441  *      list object designated by listPtr, TCL_ERROR is returned and an error
01442  *      message is left in the interpreter result.
01443  *
01444  * Side effects:
01445  *      Tcl_Panic if listPtr designates a shared object. Otherwise, attempts
01446  *      to convert it to a list with a non-shared internal rep. Decrements the
01447  *      ref count of the object at the specified index within the list,
01448  *      replaces with the object designated by valuePtr, and increments the
01449  *      ref count of the replacement object.
01450  *
01451  *      It is the caller's responsibility to invalidate the string
01452  *      representation of the object.
01453  *
01454  *----------------------------------------------------------------------
01455  */
01456 
01457 int
01458 TclListObjSetElement(
01459     Tcl_Interp *interp,         /* Tcl interpreter; used for error reporting
01460                                  * if not NULL. */
01461     Tcl_Obj *listPtr,           /* List object in which element should be
01462                                  * stored. */
01463     int index,                  /* Index of element to store. */
01464     Tcl_Obj *valuePtr)          /* Tcl object to store in the designated list
01465                                  * element. */
01466 {
01467     List *listRepPtr;           /* Internal representation of the list being
01468                                  * modified. */
01469     Tcl_Obj **elemPtrs;         /* Pointers to elements of the list. */
01470     int elemCount;              /* Number of elements in the list. */
01471 
01472     /*
01473      * Ensure that the listPtr parameter designates an unshared list.
01474      */
01475 
01476     if (Tcl_IsShared(listPtr)) {
01477         Tcl_Panic("%s called with shared object", "TclListObjSetElement");
01478     }
01479     if (listPtr->typePtr != &tclListType) {
01480         int length, result;
01481 
01482         (void) TclGetStringFromObj(listPtr, &length);
01483         if (!length) {
01484             Tcl_SetObjResult(interp,
01485                     Tcl_NewStringObj("list index out of range", -1));
01486             return TCL_ERROR;
01487         }
01488         result = SetListFromAny(interp, listPtr);
01489         if (result != TCL_OK) {
01490             return result;
01491         }
01492     }
01493 
01494     listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
01495     elemCount = listRepPtr->elemCount;
01496     elemPtrs = &listRepPtr->elements;
01497 
01498     /*
01499      * Ensure that the index is in bounds.
01500      */
01501 
01502     if (index<0 || index>=elemCount) {
01503         if (interp != NULL) {
01504             Tcl_SetObjResult(interp,
01505                     Tcl_NewStringObj("list index out of range", -1));
01506         }
01507         return TCL_ERROR;
01508     }
01509 
01510     /*
01511      * If the internal rep is shared, replace it with an unshared copy.
01512      */
01513 
01514     if (listRepPtr->refCount > 1) {
01515         List *oldListRepPtr = listRepPtr;
01516         Tcl_Obj **oldElemPtrs = elemPtrs;
01517         int i;
01518 
01519         listRepPtr = NewListIntRep(listRepPtr->maxElemCount, NULL);
01520         if (listRepPtr == NULL) {
01521             Tcl_Panic("Not enough memory to allocate list");
01522         }
01523         listRepPtr->canonicalFlag = oldListRepPtr->canonicalFlag;
01524         elemPtrs = &listRepPtr->elements;
01525         for (i=0; i < elemCount; i++) {
01526             elemPtrs[i] = oldElemPtrs[i];
01527             Tcl_IncrRefCount(elemPtrs[i]);
01528         }
01529         listRepPtr->refCount++;
01530         listRepPtr->elemCount = elemCount;
01531         listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
01532         oldListRepPtr->refCount--;
01533     }
01534 
01535     /*
01536      * Add a reference to the new list element.
01537      */
01538 
01539     Tcl_IncrRefCount(valuePtr);
01540 
01541     /*
01542      * Remove a reference from the old list element.
01543      */
01544 
01545     Tcl_DecrRefCount(elemPtrs[index]);
01546 
01547     /*
01548      * Stash the new object in the list.
01549      */
01550 
01551     elemPtrs[index] = valuePtr;
01552 
01553     return TCL_OK;
01554 }
01555 
01556 /*
01557  *----------------------------------------------------------------------
01558  *
01559  * FreeListInternalRep --
01560  *
01561  *      Deallocate the storage associated with a list object's internal
01562  *      representation.
01563  *
01564  * Results:
01565  *      None.
01566  *
01567  * Side effects:
01568  *      Frees listPtr's List* internal representation and sets listPtr's
01569  *      internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all
01570  *      element objects, which may free them.
01571  *
01572  *----------------------------------------------------------------------
01573  */
01574 
01575 static void
01576 FreeListInternalRep(
01577     Tcl_Obj *listPtr)           /* List object with internal rep to free. */
01578 {
01579     register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
01580     register Tcl_Obj **elemPtrs = &listRepPtr->elements;
01581     register Tcl_Obj *objPtr;
01582     int numElems = listRepPtr->elemCount;
01583     int i;
01584 
01585     if (--listRepPtr->refCount <= 0) {
01586         for (i = 0;  i < numElems;  i++) {
01587             objPtr = elemPtrs[i];
01588             Tcl_DecrRefCount(objPtr);
01589         }
01590         ckfree((char *) listRepPtr);
01591     }
01592 
01593     listPtr->internalRep.twoPtrValue.ptr1 = NULL;
01594     listPtr->internalRep.twoPtrValue.ptr2 = NULL;
01595 }
01596 
01597 /*
01598  *----------------------------------------------------------------------
01599  *
01600  * DupListInternalRep --
01601  *
01602  *      Initialize the internal representation of a list Tcl_Obj to share the
01603  *      internal representation of an existing list object.
01604  *
01605  * Results:
01606  *      None.
01607  *
01608  * Side effects:
01609  *      The reference count of the List internal rep is incremented.
01610  *
01611  *----------------------------------------------------------------------
01612  */
01613 
01614 static void
01615 DupListInternalRep(
01616     Tcl_Obj *srcPtr,            /* Object with internal rep to copy. */
01617     Tcl_Obj *copyPtr)           /* Object with internal rep to set. */
01618 {
01619     List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;
01620 
01621     listRepPtr->refCount++;
01622     copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
01623     copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
01624     copyPtr->typePtr = &tclListType;
01625 }
01626 
01627 /*
01628  *----------------------------------------------------------------------
01629  *
01630  * SetListFromAny --
01631  *
01632  *      Attempt to generate a list internal form for the Tcl object "objPtr".
01633  *
01634  * Results:
01635  *      The return value is TCL_OK or TCL_ERROR. If an error occurs during
01636  *      conversion, an error message is left in the interpreter's result
01637  *      unless "interp" is NULL.
01638  *
01639  * Side effects:
01640  *      If no error occurs, a list is stored as "objPtr"s internal
01641  *      representation.
01642  *
01643  *----------------------------------------------------------------------
01644  */
01645 
01646 static int
01647 SetListFromAny(
01648     Tcl_Interp *interp,         /* Used for error reporting if not NULL. */
01649     Tcl_Obj *objPtr)            /* The object to convert. */
01650 {
01651     char *string, *s;
01652     const char *elemStart, *nextElem;
01653     int lenRemain, length, estCount, elemSize, hasBrace, i, j, result;
01654     const char *limit;          /* Points just after string's last byte. */
01655     register const char *p;
01656     register Tcl_Obj **elemPtrs;
01657     register Tcl_Obj *elemPtr;
01658     List *listRepPtr;
01659 
01660     /*
01661      * Get the string representation. Make it up-to-date if necessary.
01662      */
01663 
01664     string = TclGetStringFromObj(objPtr, &length);
01665 
01666     /*
01667      * Parse the string into separate string objects, and create a List
01668      * structure that points to the element string objects. We use a modified
01669      * version of Tcl_SplitList's implementation to avoid one malloc and a
01670      * string copy for each list element. First, estimate the number of
01671      * elements by counting the number of space characters in the list.
01672      */
01673 
01674     limit = string + length;
01675     estCount = 1;
01676     for (p = string;  p < limit;  p++) {
01677         if (isspace(UCHAR(*p))) { /* INTL: ISO space. */
01678             estCount++;
01679         }
01680     }
01681 
01682     /*
01683      * Allocate a new List structure with enough room for "estCount" elements.
01684      * Each element is a pointer to a Tcl_Obj with the appropriate string rep.
01685      * The initial "estCount" elements are set using the corresponding "argv"
01686      * strings.
01687      */
01688 
01689     listRepPtr = NewListIntRep(estCount, NULL);
01690     if (!listRepPtr) {
01691         Tcl_SetObjResult(interp, Tcl_NewStringObj(
01692                 "Not enough memory to allocate the list internal rep", -1));
01693         return TCL_ERROR;
01694     }
01695     elemPtrs = &listRepPtr->elements;
01696 
01697     for (p=string, lenRemain=length, i=0;
01698             lenRemain > 0;
01699             p=nextElem, lenRemain=limit-nextElem, i++) {
01700         result = TclFindElement(interp, p, lenRemain, &elemStart, &nextElem,
01701                 &elemSize, &hasBrace);
01702         if (result != TCL_OK) {
01703             for (j = 0;  j < i;  j++) {
01704                 elemPtr = elemPtrs[j];
01705                 Tcl_DecrRefCount(elemPtr);
01706             }
01707             ckfree((char *) listRepPtr);
01708             return result;
01709         }
01710         if (elemStart >= limit) {
01711             break;
01712         }
01713         if (i > estCount) {
01714             Tcl_Panic("SetListFromAny: bad size estimate for list");
01715         }
01716 
01717         /*
01718          * Allocate a Tcl object for the element and initialize it from the
01719          * "elemSize" bytes starting at "elemStart".
01720          */
01721 
01722         s = ckalloc((unsigned) elemSize + 1);
01723         if (hasBrace) {
01724             memcpy(s, elemStart, (size_t) elemSize);
01725             s[elemSize] = 0;
01726         } else {
01727             elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
01728         }
01729 
01730         TclNewObj(elemPtr);
01731         elemPtr->bytes = s;
01732         elemPtr->length = elemSize;
01733         elemPtrs[i] = elemPtr;
01734         Tcl_IncrRefCount(elemPtr);      /* Since list now holds ref to it. */
01735     }
01736 
01737     listRepPtr->elemCount = i;
01738 
01739     /*
01740      * Free the old internalRep before setting the new one. We do this as late
01741      * as possible to allow the conversion code, in particular
01742      * Tcl_GetStringFromObj, to use that old internalRep.
01743      */
01744 
01745     listRepPtr->refCount++;
01746     TclFreeIntRep(objPtr);
01747     objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
01748     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
01749     objPtr->typePtr = &tclListType;
01750     return TCL_OK;
01751 }
01752 
01753 /*
01754  *----------------------------------------------------------------------
01755  *
01756  * UpdateStringOfList --
01757  *
01758  *      Update the string representation for a list object. Note: This
01759  *      function does not invalidate an existing old string rep so storage
01760  *      will be lost if this has not already been done.
01761  *
01762  * Results:
01763  *      None.
01764  *
01765  * Side effects:
01766  *      The object's string is set to a valid string that results from the
01767  *      list-to-string conversion. This string will be empty if the list has
01768  *      no elements. The list internal representation should not be NULL and
01769  *      we assume it is not NULL.
01770  *
01771  *----------------------------------------------------------------------
01772  */
01773 
01774 static void
01775 UpdateStringOfList(
01776     Tcl_Obj *listPtr)           /* List object with string rep to update. */
01777 {
01778 #   define LOCAL_SIZE 20
01779     int localFlags[LOCAL_SIZE], *flagPtr;
01780     List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
01781     int numElems = listRepPtr->elemCount;
01782     register int i;
01783     char *elem, *dst;
01784     int length;
01785     Tcl_Obj **elemPtrs;
01786 
01787     /*
01788      * Convert each element of the list to string form and then convert it to
01789      * proper list element form, adding it to the result buffer.
01790      */
01791 
01792     /*
01793      * Pass 1: estimate space, gather flags.
01794      */
01795 
01796     if (numElems <= LOCAL_SIZE) {
01797         flagPtr = localFlags;
01798     } else {
01799         flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int));
01800     }
01801     listPtr->length = 1;
01802     elemPtrs = &listRepPtr->elements;
01803     for (i = 0; i < numElems; i++) {
01804         elem = TclGetStringFromObj(elemPtrs[i], &length);
01805         listPtr->length += Tcl_ScanCountedElement(elem, length, flagPtr+i)+1;
01806 
01807         /*
01808          * Check for continued sanity. [Bug 1267380]
01809          */
01810 
01811         if (listPtr->length < 1) {
01812             Tcl_Panic("string representation size exceeds sane bounds");
01813         }
01814     }
01815 
01816     /*
01817      * Pass 2: copy into string rep buffer.
01818      */
01819 
01820     listPtr->bytes = ckalloc((unsigned) listPtr->length);
01821     dst = listPtr->bytes;
01822     for (i = 0; i < numElems; i++) {
01823         elem = TclGetStringFromObj(elemPtrs[i], &length);
01824         dst += Tcl_ConvertCountedElement(elem, length, dst,
01825                 flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH));
01826         *dst = ' ';
01827         dst++;
01828     }
01829     if (flagPtr != localFlags) {
01830         ckfree((char *) flagPtr);
01831     }
01832     if (dst == listPtr->bytes) {
01833         *dst = 0;
01834     } else {
01835         dst--;
01836         *dst = 0;
01837     }
01838     listPtr->length = dst - listPtr->bytes;
01839 
01840     /*
01841      * Mark the list as being canonical; although it has a string rep, it is
01842      * one we derived through proper "canonical" quoting and so it's known to
01843      * be free from nasties relating to [concat] and [eval].
01844      */
01845 
01846     listRepPtr->canonicalFlag = 1;
01847 }
01848 
01849 /*
01850  * Local Variables:
01851  * mode: c
01852  * c-basic-offset: 4
01853  * fill-column: 78
01854  * End:
01855  */



Generated on Wed Mar 12 12:18:19 2008 by  doxygen 1.5.1