Tcl Source Code

static void		DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr);
static void		FreeArithSeriesInternalRep (Tcl_Obj *listPtr);
static int		SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		UpdateStringOfArithSeries (Tcl_Obj *arithSeriesObj);
static Tcl_Obj *ArithSeriesObjStep(Tcl_Obj *arithSeriesPtr);
static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr);
static void		ArithSeriesGetElements(Tcl_Obj *, Tcl_Obj **, size_t, size_t);


/*
 * The structure below defines the arithmetic series Tcl object type by
 * means of procedures that can be invoked by generic object code.
 *
 * The arithmetic series object is a special case of Tcl list representing
 * an interval of an arithmetic series in constant space.

const TclObjTypeWithAbstractList tclArithSeriesType = {
    {"arithseries",			/* name */
    FreeArithSeriesInternalRep,		/* freeIntRepProc */
    DupArithSeriesInternalRep,		/* dupIntRepProc */
    UpdateStringOfArithSeries,		/* updateStringProc */
    SetArithSeriesFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    ArithSeriesObjLength,
    ArithSeriesGetElements
    )}
};

/*
 *----------------------------------------------------------------------
 *
 * ArithSeriesLen --

 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
ArithSeriesGetElements(
    Tcl_Obj *arithSeriesPtr,
    Tcl_Obj **elemPtr,
    size_t start,
    size_t length)
{
    size_t i, objc;

    if (start + length < start) {
	Tcl_Panic("%s: length overflow", "ArithSeriesGetElements");
    }
    objc = ArithSeriesObjLength(arithSeriesPtr);
    while (length > 0 && start + length > objc) {
	elemPtr[--length] = NULL;
    }
    for (i = 0; i < length; i++) {
	elemPtr[i] = TclArithSeriesObjIndex(NULL, arithSeriesPtr, start + i);
    }
}

Tcl_Obj **
TclArithSeriesGetElements(
    Tcl_Interp *interp,		/* Used to report errors if not NULL. */
    Tcl_Obj *objPtr,		/* ArithSeries object for which an element
				 * array is to be returned. */
    Tcl_Size *objcPtr)		/* Where to store the count of objects
				 * referenced by objv. */


{
    Tcl_Obj **objv = NULL;
    if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) {
	ArithSeries *arithSeriesRepPtr;

	int i, objc;

	ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr);
	objc = arithSeriesRepPtr->len;
	if (objc > 0) {
	    if (arithSeriesRepPtr->elements) {
		/* If this exists, it has already been populated */
		objv = arithSeriesRepPtr->elements;
	    } else {
		/* Construct the elements array */
		objv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * objc);
		if (objv == NULL) {
		    if (interp) {
			Tcl_SetObjResult(
			    interp,
			    Tcl_NewStringObj("max length of a Tcl list exceeded", TCL_INDEX_NONE));
			Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
		    }
		    return NULL;
		}
		arithSeriesRepPtr->elements = objv;
		for (i = 0; i < objc; i++) {
		    objv[i] = TclArithSeriesObjIndex(interp, objPtr, i);
		    if (objv[i] == NULL) {
			return NULL;
		    }
		    Tcl_IncrRefCount(objv[i]);
		}
	    }


	}

	*objcPtr = objc;
    } else {
	if (interp != NULL) {
	    Tcl_SetObjResult(
		interp,
		Tcl_ObjPrintf("value is not an arithseries"));
	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL);
	}

    }
    return objv;
}

/*
 *----------------------------------------------------------------------
 *
 * TclArithSeriesObjReverse --
 *

			    Tcl_Obj *arithSeriesPtr);
MODULE_SCOPE  Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *,
			    Tcl_WideInt index);
MODULE_SCOPE Tcl_Obj *	TclArithSeriesObjRange(Tcl_Interp *interp,
			    Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx);
MODULE_SCOPE Tcl_Obj *	TclArithSeriesObjReverse(Tcl_Interp *interp,
			    Tcl_Obj *arithSeriesPtr);
MODULE_SCOPE Tcl_Obj **TclArithSeriesGetElements(Tcl_Interp *interp,
			    Tcl_Obj *objPtr, Tcl_Size *objcPtr);
MODULE_SCOPE int 	TclNewArithSeriesObj(Tcl_Interp *interp,
			    Tcl_Obj **arithSeriesObj, int useDoubles,
			    Tcl_Obj *startObj, Tcl_Obj *endObj,
			    Tcl_Obj *stepObj, Tcl_Obj *lenObj);

/*
 * Local Variables:

	    goto done;
	}
	Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
	sortInfo.compareCmdPtr = newCommandPtr;
    }

    if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) {
	listObjPtrs = TclArithSeriesGetElements(interp, listObj, &length);
	sortInfo.resultCode = listObjPtrs ? TCL_OK : TCL_ERROR;
    } else {
	sortInfo.resultCode = TclListObjGetElementsM(interp, listObj,
	    &length, &listObjPtrs);
    }
    if (sortInfo.resultCode != TCL_OK || length <= 0) {
	goto done;
    }

#define TCL_TRACE_ENTER_EXEC	1
#define TCL_TRACE_LEAVE_EXEC	2

typedef struct {  /* For internal core use only */
    Tcl_ObjType objType;
    struct {
	size_t (*lengthProc)(Tcl_Obj *obj);
	void (*getElementsProc)(Tcl_Obj *obj, Tcl_Obj **elements, size_t start, size_t length);
    } abstractList;
} TclObjTypeWithAbstractList;
#define TCL_OBJTYPE_V0_1(lengthProc, getElementsProc) (sizeof(TclObjTypeWithAbstractList)) \
	}, {lengthProc, getElementsProc /* For internal core use only */
#define ABSTRACTLIST_PROC(objPtr, proc) (((objPtr)->typePtr \
	&& ((objPtr)->typePtr->version > offsetof(TclObjTypeWithAbstractList, abstractList.proc))) ? \
	((const TclObjTypeWithAbstractList *)(objPtr)->typePtr)->abstractList.proc : NULL)

MODULE_SCOPE size_t TclLengthOne(Tcl_Obj *);
MODULE_SCOPE void TclGetSingleElements(Tcl_Obj *, Tcl_Obj **, size_t, size_t);

/*
 * The structure below defines an entry in the assocData hash table which is
 * associated with an interpreter. The entry contains a pointer to a function
 * to call when the interpreter is deleted, and a pointer to a user-defined
 * piece of data.
 */

static void	ListRepValidate(const ListRep *repPtr, const char *file,
		    int lineNum);
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);
static size_t ListLength(Tcl_Obj *listPtr);
static void ListGetElements(Tcl_Obj *, Tcl_Obj **, size_t, size_t);

/*
 * 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 ListRep defined in tcl.h.
 */

const TclObjTypeWithAbstractList tclListType = {
    {"list",			/* name */
    FreeListInternalRep,	/* freeIntRepProc */
    DupListInternalRep,		/* dupIntRepProc */
    UpdateStringOfList,		/* updateStringProc */
    SetListFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    ListLength,
    ListGetElements
    )}
};

/* Macros to manipulate the List internal rep */
#define ListRepIncrRefs(repPtr_)            \
    do {                                    \
	(repPtr_)->storePtr->refCount++;    \

				 * referenced by objv. */
    Tcl_Obj ***objvPtr)		/* Where to store the pointer to an array of
				 * pointers to the list's objects. */
{
    ListRep listRep;

    if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) {
	Tcl_Obj **objv = TclArithSeriesGetElements(interp, objPtr, objcPtr);
	if (!objv) {
	    return TCL_ERROR;
	}
	*objvPtr = objv;
	return TCL_OK;
    }
    if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK)
	return TCL_ERROR;
    ListRepElements(&listRep, *objcPtr, *objvPtr);
    return TCL_OK;
}

/*

    Tcl_Obj *listPtr)
{
	ListRep listRep;
	ListObjGetRep(listPtr, &listRep);

    return ListRepLength(&listRep);
}

static void ListGetElements(
    Tcl_Obj *listPtr,
    Tcl_Obj **elemPtr,
    size_t start,
    size_t length)
{
    ListRep listRep;
    size_t i, objc;
    Tcl_Obj **objv;

    if (start + length < start) {
	Tcl_Panic("%s: length overflow", "ListGetElements");
    }
    ListObjGetRep(listPtr, &listRep);
    ListRepElements(&listRep, objc, objv);
    while (length > 0 && start + length > objc) {
	elemPtr[--length] = NULL;
    }
    objv += start;
    for (i = 0; i < length; i++) {
	elemPtr[i] =  objv[i];
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListObjReplace --
 *
 *	This function replaces zero or more elements of the list referenced by

const TclObjTypeWithAbstractList tclBooleanType= {
    {"boolean",			/* name */
    NULL,			/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    NULL,			/* updateStringProc */
    TclSetBooleanFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne,
    TclGetSingleElements
    )}
};
const TclObjTypeWithAbstractList tclDoubleType= {
    {"double",			/* name */
    NULL,			/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    UpdateStringOfDouble,	/* updateStringProc */
    SetDoubleFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne,
    TclGetSingleElements
    )}
};
const TclObjTypeWithAbstractList tclIntType = {
    {"int",			/* name */
    NULL,			/* freeIntRepProc */
    NULL,			/* dupIntRepProc */
    UpdateStringOfInt,		/* updateStringProc */
    SetIntFromAny,		/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne,
    TclGetSingleElements
    )}
};
const TclObjTypeWithAbstractList tclBignumType = {
    {"bignum",			/* name */
    FreeBignum,			/* freeIntRepProc */
    DupBignum,			/* dupIntRepProc */
    UpdateStringOfBignum,	/* updateStringProc */
    NULL,			/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne,
    TclGetSingleElements
    )}
};

/*
 * The structure below defines the Tcl obj hash key type.
 */

static const TclObjTypeWithAbstractList endOffsetType = {
    {"end-offset",			/* name */
    NULL,				/* freeIntRepProc */
    NULL,				/* dupIntRepProc */
    NULL,				/* updateStringProc */
    NULL,				/* setFromAnyProc */
    TCL_OBJTYPE_V0_1(
    TclLengthOne,
    TclGetSingleElements
    )}
};

size_t
TclLengthOne(
    TCL_UNUSED(Tcl_Obj *))
{
    return 1;
}

void
TclGetSingleElements(
    Tcl_Obj *endOffsetPtr,
    Tcl_Obj **elemPtr,
    size_t start,
    size_t length)
{
    if (start + length < start) {
	Tcl_Panic("%s: length overflow", "ListGetElements");
    }
    if (length > 0 && start == 0) {
	size_t len;
	const char *str = Tcl_GetStringFromObj(endOffsetPtr, &len);
	if (len == 0 || (!isspace(UCHAR(*str)) && !isspace(UCHAR(str[len-1])))) {
	    /* If the endOffset doesn't start or end with space, we can use the obj itself. */
	    *elemPtr++ = endOffsetPtr;
	} else {
	    /* otherwise, strip the spaces */
	    Tcl_Obj *obj;

	    while (len > 0 && isspace(UCHAR(str[len-1]))) {
		len--;
	    }
	    while (len > 0 && isspace(UCHAR(*str))) {
		str++; len--;
	    }
	    TclNewStringObj(obj, str, len);
	    *elemPtr++ = obj;
	    start++, length--;
	}
    }
    memset(elemPtr, 0, length * sizeof(Tcl_Obj *));
}

/*
 *	*	STRING REPRESENTATION OF LISTS	*	*	*
 *
 * The next several routines implement the conversions of strings to and from
 * Tcl lists. To understand their operation, the rules of parsing and
 * generating the string representation of lists must be known.  Here we
 * describe them in one place.