Tcl Source Code

static int		DictValuesCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const *objv);
static int		DictWithCmd(ClientData dummy, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const *objv);
static void		DupDictInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		FreeDictInternalRep(Tcl_Obj *dictPtr);
static void		InvalidateDictChain(Tcl_Obj *dictObj);
static void		InvalidateListRep(Tcl_Obj *dictObj);
static void		InvalidateOtherReps(Tcl_Obj *dictObj);
static int		SetDictFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		UpdateStringOfDict(Tcl_Obj *dictPtr);
static Tcl_HashEntry *	AllocChainEntry(Tcl_HashTable *tablePtr,void *keyPtr);
static inline void	InitChainTable(struct Dict *dict);
static inline void	DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry *CreateChainEntry(struct Dict *dict,
			    Tcl_Obj *keyPtr, int *newPtr);

 */

static void
FreeDictInternalRep(
    Tcl_Obj *dictPtr)
{
    Dict *dict = DICT(dictPtr);
    InvalidateListRep(dictPtr);

    dict->refcount--;
    if (dict->refcount <= 0) {
	DeleteDict(dict);
    }
    dictPtr->typePtr = NULL;
}

    Dict *dict = DICT(dictPtr);
    ChainEntry *cPtr;
    Tcl_Obj *keyPtr, *valuePtr;
    int i, length, bytesNeeded = 0;
    const char *elem;
    char *dst;
    const int maxFlags = UINT_MAX / sizeof(int);
    void *tmp;
    int numElems;

    if (dictPtr->internalRep.twoPtrValue.ptr2 != NULL) {
	tmp = dictPtr->internalRep.twoPtrValue.ptr1;
	dictPtr->internalRep.twoPtrValue.ptr1 = dictPtr->internalRep.twoPtrValue.ptr2;
	dictPtr->typePtr = &tclListType ;
	if (TclGetString(dictPtr) == NULL) {
	    Tcl_Panic("Could not update dict string from internal list");
	}
	dictPtr->internalRep.twoPtrValue.ptr2 = dictPtr->internalRep.twoPtrValue.ptr1;
	dictPtr->internalRep.twoPtrValue.ptr1 = tmp;
	dictPtr->typePtr = &tclDictType;
	return;
    }

    /*
     * This field is the most useful one in the whole hash structure, and it
     * is not exposed by any API function...
     */

    numElems = dict->table.numEntries * 2;

    /* Handle empty list case first, simplifies what follows */
    if (numElems == 0) {
	dictPtr->bytes = tclEmptyStringRep;
	dictPtr->length = 0;
	return;
    }

static int
SetDictFromAny(
    Tcl_Interp *interp,
    Tcl_Obj *objPtr)
{
    Tcl_HashEntry *hPtr;
    int isNew, needlist = 0;
    Dict *dict = ckalloc(sizeof(Dict));

    InitChainTable(dict);

    /*
     * Since lists and dictionaries have very closely-related string
     * representations (i.e. the same parsing code) we can safely special-case

	}

	for (i=0 ; i<objc ; i+=2) {

	    /* Store key and value in the hash table we're building. */
	    hPtr = CreateChainEntry(dict, objv[i], &isNew);
	    if (!isNew) {

		needlist = 1;





		continue;



	    }
	    Tcl_SetHashValue(hPtr, objv[i+1]);
	    Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
	}
    } else {
	int length;
	const char *nextElem = TclGetStringFromObj(objPtr, &length);

    /*
     * 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.
     */


    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    if (needlist) {
	/* squirrel the list intrep away for use by SetListFromAny  */
	objPtr->internalRep.twoPtrValue.ptr2 = objPtr->internalRep.twoPtrValue.ptr1;
    } else {
	TclFreeIntRep(objPtr);
	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
    }
    DICT(objPtr) = dict;
    objPtr->typePtr = &tclDictType;
    return TCL_OK;

  missingValue:
    if (interp != NULL) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"missing value to go with key", -1));

static void
InvalidateDictChain(
    Tcl_Obj *dictObj)
{
    Dict *dict = DICT(dictObj);

    do {
	InvalidateOtherReps(dictObj);
	dict->epoch++;
	dictObj = dict->chain;
	if (dictObj == NULL) {
	    break;
	}
	dict->chain = NULL;
	dict = DICT(dictObj);
    } while (dict != NULL);
}

static void InvalidateListRep(
    Tcl_Obj *dictObj
) {
    void *tmp;

    if (dictObj->internalRep.twoPtrValue.ptr2 != NULL) {
	tmp = dictObj->internalRep.twoPtrValue.ptr1;
	dictObj->internalRep.twoPtrValue.ptr1 = dictObj->internalRep.twoPtrValue.ptr2;
	TclFreeListInternalRep(dictObj);
	dictObj->internalRep.twoPtrValue.ptr1 = tmp;
	dictObj->internalRep.twoPtrValue.ptr2 = NULL;
    }
}

static void InvalidateOtherReps(
    Tcl_Obj * dictObj
) {
    TclInvalidateStringRep(dictObj);
    InvalidateListRep(dictObj);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DictObjPut --
 *
 *	Add a key,value pair to a dictionary, or update the value for a key if
 *	that key already has a mapping in the dictionary.

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    if (dictPtr->bytes != NULL) {
	InvalidateOtherReps(dictPtr);
    }
    dict = DICT(dictPtr);
    hPtr = CreateChainEntry(dict, keyPtr, &isNew);
    Tcl_IncrRefCount(valuePtr);
    if (!isNew) {
	Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr);

	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return TCL_ERROR;
    }

    dict = DICT(dictPtr);
    if (DeleteChainEntry(dict, keyPtr)) {
	if (dictPtr->bytes != NULL) {
	    InvalidateOtherReps(dictPtr);
	}
	dict->epoch++;
    }
    return TCL_OK;
}

/*

    int line)
{
#ifdef TCL_MEM_DEBUG
    Tcl_Obj *dictPtr;
    Dict *dict;

    TclDbNewObj(dictPtr, file, line);
    InvalidateOtherReps(dictPtr);
    dict = ckalloc(sizeof(Dict));
    InitChainTable(dict);
    dict->epoch = 0;
    dict->chain = NULL;
    dict->refcount = 1;
    DICT(dictPtr) = dict;
    dictPtr->internalRep.twoPtrValue.ptr2 = NULL;

	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_IsShared(dictPtr)) {
	dictPtr = Tcl_DuplicateObj(dictPtr);
    }
    if (dictPtr->bytes != NULL) {
	InvalidateOtherReps(dictPtr);
    }
    for (i=2 ; i<objc ; i+=2) {
	Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]);
    }
    Tcl_SetObjResult(interp, dictPtr);
    return TCL_OK;
}

    if (dictPtr->typePtr != &tclDictType
	    && SetDictFromAny(interp, dictPtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (Tcl_IsShared(dictPtr)) {
	dictPtr = Tcl_DuplicateObj(dictPtr);
    }

    InvalidateOtherReps(dictPtr);

    for (i=2 ; i<objc ; i++) {
	Tcl_DictObjRemove(NULL, dictPtr, objv[i]);
    }
    Tcl_SetObjResult(interp, dictPtr);
    return TCL_OK;
}


	    Tcl_IncrRefCount(incrPtr);
	    code = TclIncrObj(interp, valuePtr, incrPtr);
	    TclDecrRefCount(incrPtr);
	}
    }
    if (code == TCL_OK) {
	InvalidateOtherReps(dictPtr);
	valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
		dictPtr, TCL_LEAVE_ERR_MSG);
	if (valuePtr == NULL) {
	    code = TCL_ERROR;
	} else {
	    Tcl_SetObjResult(interp, valuePtr);
	}

	    }
	}
    }

    if (allocatedValue) {
	Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
    } else if (dictPtr->bytes != NULL) {
	InvalidateOtherReps(dictPtr);
    }

    resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
	    TCL_LEAVE_ERR_MSG);
    if (resultPtr == NULL) {
	return TCL_ERROR;
    }

#define TclIsVarDirectWritable2(varPtr, arrayPtr) \
    (TclIsVarDirectWritable(varPtr) &&\
	(!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_WRITE)))

#define TclIsVarDirectModifyable2(varPtr, arrayPtr) \
    (TclIsVarDirectModifyable(varPtr) &&\
	(!(arrayPtr) || !((arrayPtr)->flags & (VAR_TRACED_READ|VAR_TRACED_WRITE))))


/*
 *----------------------------------------------------------------
 * Data structures related to procedures. These are used primarily in
 * tclProc.c, tclCompile.c, and tclExecute.c.
 *----------------------------------------------------------------
 */

#define TclListObjLength(interp, listPtr, lenPtr) \
    (((listPtr)->typePtr == &tclListType) \
	    ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\
	    : Tcl_ListObjLength((interp), (listPtr), (lenPtr)))

#define TclListObjIsCanonical(listPtr) \
    (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0)


/*
 * Modes for collecting (or not) in the implementations of TclNRForeachCmd,
 * TclNRLmapCmd and their compilations.
 */

#define TCL_EACH_KEEP_NONE  0	/* Discard iteration result like [foreach] */

			    Tcl_Obj *listPtr, Tcl_Obj *argPtr);
MODULE_SCOPE Tcl_Obj *	TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[]);
/* TIP #280 */
MODULE_SCOPE void	TclListLines(Tcl_Obj *listObj, int line, int n,
			    int *lines, Tcl_Obj *const *elems);
MODULE_SCOPE Tcl_Obj *	TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr);
MODULE_SCOPE void	TclFreeListInternalRep(Tcl_Obj *listPtr);
MODULE_SCOPE Tcl_Obj *	TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    Tcl_Obj *indexPtr, Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Obj *	TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr,
			    int indexCount, Tcl_Obj *const indexArray[],
			    Tcl_Obj *valuePtr);
MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name,
			    const EnsembleImplMap map[]);

 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tclInt.h"

#define LIST(listObj)    ((List *)(listObj)->internalRep.twoPtrValue.ptr1)
/*
 * Prototypes for functions defined later in this file:
 */

static List *		AttemptNewList(Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static List *		NewListIntRep(int objc, Tcl_Obj *const objv[], int p);
static void		DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);

static int		SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		UpdateStringOfList(Tcl_Obj *listPtr);

/*
 * The structure below defines the list Tcl object type by means of functions
 * that can be invoked by generic object code.
 *
 * The internal representation of a list object is a two-pointer
 * representation. The first pointer designates a List structure that contains
 * an array of pointers to the element objects, together with integers that
 * represent the current element count and the allocated size of the array.
 * The second pointer is normally NULL; during execution of functions in this
 * file that operate on nested sublists, it is occasionally used as working
 * storage to avoid an auxiliary stack.
 */

const Tcl_ObjType tclListType = {
    "list",			/* name */
    TclFreeListInternalRep,	/* freeIntRepProc */
    DupListInternalRep,		/* dupIntRepProc */
    UpdateStringOfList,		/* updateStringProc */
    SetListFromAny		/* setFromAnyProc */
};

#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreeListInternalRep --
 *
 *	Deallocate the storage associated with a list object's internal
 *	representation.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees listPtr's List* internal representation and sets listPtr's
 *	internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all
 *	element objects, which may free them.
 *
 *----------------------------------------------------------------------
 */

void
TclFreeListInternalRep(
    Tcl_Obj *listPtr)		/* List object with internal rep to free. */
{
    List *listRepPtr = ListRepPtr(listPtr);

    if (listRepPtr->refCount-- <= 1) {
	Tcl_Obj **elemPtrs = &listRepPtr->elements;
	int i, numElems = listRepPtr->elemCount;

{
    List *listRepPtr;
    Tcl_Obj **elemPtrs;

    /*
     * Dictionaries are a special case; they have a string representation such
     * that *all* valid dictionaries are valid lists. Hence we can convert
     * more directly.
     

     */

    if (objPtr->typePtr == &tclDictType) {
	Tcl_Obj *keyPtr, *valuePtr;
	Tcl_DictSearch search;
	int done, size;

	/*
	 * Create the new list representation. Note that we do not need to do
	 * anything with the string representation as the transformation (and
	 * the reverse back to a dictionary) are both order-preserving. Also
	 * note that since we know we've got a valid dictionary (by
	 * representation) we also know that fetching the size of the
	 * dictionary or iterating over it will not fail.
	 */

	if (objPtr->internalRep.twoPtrValue.ptr2 != NULL) {
	    /* A usable list representation exists.  */
	    listRepPtr = objPtr->internalRep.twoPtrValue.ptr2;
	    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
	    /* To Do: Maybe keep the dict intrep around in case this object is
	     * used as a dict again */
	} else {
	    Tcl_DictObjSize(NULL, objPtr, &size);
	    listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL);
	    if (!listRepPtr) {
		return TCL_ERROR;
	    }
	    listRepPtr->elemCount = 2 * size;

	    /*
	     * Populate the list representation.
	     */

	    elemPtrs = &listRepPtr->elements;
	    Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done);
	    while (!done) {
		*elemPtrs++ = keyPtr;
		*elemPtrs++ = valuePtr;
		Tcl_IncrRefCount(keyPtr);
		Tcl_IncrRefCount(valuePtr);
		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
	    }
	}
    } else {
	int estCount, length;
	const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);

	/*
	 * Allocate enough space to hold a (Tcl_Obj *) for each

test-tcl: ${TCLTEST_EXE}
	$(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS)

gdb-test: ${TCLTEST_EXE}
	@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
	@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
	@echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run
	@echo "$(GDBSCRIPT)" >> gdb.run
	$(GDB) ./${TCLTEST_EXE} --command=gdb.run
	rm gdb.run

# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
	$(SHELL_ENV) ./${TCLTEST_EXE}