diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 29 | ||||
| -rw-r--r-- | generic/tcl.h | 78 | ||||
| -rw-r--r-- | generic/tclAbstractList.c | 673 | ||||
| -rw-r--r-- | generic/tclAbstractList.h | 55 | ||||
| -rwxr-xr-x | generic/tclArithSeries.c | 851 | ||||
| -rw-r--r-- | generic/tclArithSeries.h | 37 | ||||
| -rw-r--r-- | generic/tclBasic.c | 2 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 28 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 375 | ||||
| -rw-r--r-- | generic/tclDecls.h | 58 | ||||
| -rw-r--r-- | generic/tclExecute.c | 59 | ||||
| -rw-r--r-- | generic/tclInt.h | 43 | ||||
| -rw-r--r-- | generic/tclListObj.c | 96 | ||||
| -rw-r--r-- | generic/tclObj.c | 14 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 9 |
15 files changed, 1628 insertions, 779 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 268fe33..c8d5101 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2547,6 +2547,35 @@ declare 682 { int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode) } +# TIP #636 +declare 683 { + Tcl_Obj *Tcl_AbstractListObjNew(Tcl_Interp *interp, const Tcl_AbstractListType* vTablePtr) +} +declare 684 { + Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr) +} +declare 685 { + int Tcl_AbstractListObjIndex(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, Tcl_WideInt index, Tcl_Obj **elemObjPtr) +} +declare 686 { + int Tcl_AbstractListObjRange(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx, Tcl_Obj **newObjPtr) +} +declare 687 { + int Tcl_AbstractListObjReverse(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, Tcl_Obj **newObjPtr) +} +declare 688 { + int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr) +} +declare 689 { + Tcl_Obj *Tcl_AbstractListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr) +} +declare 690 { + void *Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr) +} +declare 691 { + Tcl_Obj *Tcl_AbstractListSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indicies, Tcl_Obj *valueObj) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index 849278b..203cfa6 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -728,6 +728,34 @@ typedef ClientData (Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData); typedef void (Tcl_MainLoopProc) (void); +/* Abstract List functions */ +typedef struct Tcl_Obj* (Tcl_ALNewObjProc) (int objc, struct Tcl_Obj * const objv[]); +typedef void (Tcl_ALDupRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *copyPtr); +typedef Tcl_WideInt (Tcl_ALLengthProc) (struct Tcl_Obj *listPtr); +typedef int (Tcl_ALIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_WideInt index, struct Tcl_Obj** elemObj); +typedef int (Tcl_ALSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_WideInt fromIdx, Tcl_WideInt toIdx, + struct Tcl_Obj **newObjPtr); +typedef int (Tcl_ALReverseProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + struct Tcl_Obj **newObjPtr); +typedef int (Tcl_ALGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + int *objcptr, struct Tcl_Obj ***objvptr); +typedef void (Tcl_ALFreeConcreteRep) (struct Tcl_Obj *listPtr); +typedef void (Tcl_ALToStringRep) (struct Tcl_Obj *listPtr); +typedef struct Tcl_Obj* (Tcl_ALSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + struct Tcl_Obj *indicies, + struct Tcl_Obj *valueObj); + +typedef enum { + TCL_ABSL_NEW, TCL_ABSL_DUPREP, TCL_ABSL_LENGTH, TCL_ABSL_INDEX, + TCL_ABSL_SLICE, TCL_ABSL_REVERSE, TCL_ABSL_GETELEMENTS, TCL_ABSL_FREEREP, + TCL_ABSL_TOSTRING, TCL_ABSL_SETELEMENT +} Tcl_AbstractListProcType; + +typedef struct Tcl_AbstractListVersion_ *Tcl_AbstractListVersion; + + #ifndef TCL_NO_DEPRECATED # define Tcl_PackageInitProc Tcl_LibraryInitProc # define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc @@ -811,6 +839,56 @@ typedef struct Tcl_Obj { /* + * Abstract List + * + * This structure provides the functions used in List operations to emulate a + * List for AbstractList types. + */ + +#define TCL_ABSTRACTLIST_VERSION_1 ((Tcl_AbstractListVersion) 0x1) + +/* Virtual function dispatch a la Tcl_ObjType but for AbstractList */ +typedef struct Tcl_AbstractListType { + Tcl_AbstractListVersion version;/* Structure version */ + const char *typeName; /* Custom value reference */ + + /* List emulation functions */ + Tcl_ALNewObjProc *newObjProc; /* How to create a new Tcl_Obj of this + ** custom type */ + Tcl_ALDupRepProc *dupRepProc; /* How to duplicate a internal rep of this + ** custom type */ + Tcl_ALLengthProc *lengthProc; /* Return the [llength] of the + ** AbstractList */ + Tcl_ALIndexProc *indexProc; /* Return a value (Tcl_Obj) for + ** [lindex $al $index] */ + Tcl_ALSliceProc *sliceProc; /* Return an AbstractList for + ** [lrange $al $start $end] */ + Tcl_ALReverseProc *reverseProc; /* Return an AbstractList for + ** [lreverse $al] */ + Tcl_ALGetElements *getElementsProc; /* Return an objv[] of all elements in + ** the list */ + Tcl_ALFreeConcreteRep *freeRepProc; /* Free ConcreteRep internals if + ** necessary */ + Tcl_ALToStringRep *toStringProc; /* Optimized "to-string" conversion + ** for updating the string rep */ + Tcl_ALSetElement *setElementProc; /* Replace the element at the indicie + ** with the given valueObj. */ +} Tcl_AbstractListType; + +/* + * Sets the storage used by the concrete abstract list type + * Caller has to ensure type is AbstractList. Existing rep will be + * overwritten so caller has to free previous rep if necessary. + */ +static inline void Tcl_AbstractListSetConcreteRep( + Tcl_Obj *objPtr, /* Object of type AbstractList */ + void *repPtr) /* New representation */ +{ + /* assert(objPtr->typePtr == &tclAbstractListType); */ + objPtr->internalRep.twoPtrValue.ptr2 = repPtr; +} + +/* *---------------------------------------------------------------------------- * The following structure contains the state needed by Tcl_SaveResult. No-one * outside of Tcl should access any of these fields. This structure is diff --git a/generic/tclAbstractList.c b/generic/tclAbstractList.c new file mode 100644 index 0000000..209e9ac --- /dev/null +++ b/generic/tclAbstractList.c @@ -0,0 +1,673 @@ +/* + * tclAbstractList.h -- + * + * The AbstractList Obj Type -- a psuedo List + * + * Copyright © 2022 by Brian Griffin. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tcl.h" +#include "tclAbstractList.h" + + +/* -------------------------- AbstractList object ---------------------------- */ + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupAbstractListInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeAbstractListInternalRep (Tcl_Obj *listPtr); +static int SetAbstractListFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfAbstractList (Tcl_Obj *listPtr); + +/* + * The structure below defines the AbstractList Tcl object type by means of + * procedures that can be invoked by generic object code. + * + * The abstract list object is a special case of Tcl list represented by a set + * of functions. + * + */ + +const Tcl_ObjType tclAbstractListType = { + "abstractlist", /* name */ + FreeAbstractListInternalRep, /* freeIntRepProc */ + DupAbstractListInternalRep, /* dupIntRepProc */ + UpdateStringOfAbstractList, /* updateStringProc */ + SetAbstractListFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListLen -- + * + * Compute the length of the equivalent list + * + * Results: + * + * The length of the list generated by the given range, + * that may be zero. + * + * Side effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_WideInt +Tcl_AbstractListObjLength(Tcl_Obj *abstractListObjPtr) +{ + return AbstractListObjLength(abstractListObjPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjNew() + * + * Creates a new AbstractList object. The returned object has + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created AbstractList object. + * A NULL pointer of the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +Tcl_AbstractListObjNew(Tcl_Interp *interp, const Tcl_AbstractListType* vTablePtr) +{ + Tcl_Obj *objPtr; + Tcl_ObjInternalRep itr; + (void)interp; + TclNewObj(objPtr); + itr.twoPtrValue.ptr1 = (void*)vTablePtr; /* dispatch table for concrete type */ + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(objPtr, &tclAbstractListType, &itr); + Tcl_InvalidateStringRep(objPtr); + return objPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjIndex -- + * + * Returns the element with the specified index in the list + * represented by the specified Abstract List object. + * If the index is out of range, TCL_ERROR is returned, + * otherwise TCL_OK is returned and the integer value of the + * element is stored in *element. + * + * Results: + * + * Element Tcl_Obj is returned on succes, NULL on index out of range. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AbstractListObjIndex( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *abstractListObjPtr, /* List obj */ + Tcl_WideInt index, /* index to element of interest */ + Tcl_Obj **elemObjPtr) /* Return value */ +{ + Tcl_AbstractListType *typePtr; + + typePtr = Tcl_AbstractListGetType(abstractListObjPtr); + /* + * The general assumption is that the obj is assumed first to be a List, + * and only ends up here because it has been determinded to be an + * AbstractList. If that's not the case, then a mistake has been made. To + * attempt to try a List call (e.g. shimmer) could potentially loop(?) + * So: if called from List code, then something has gone wrong; if called + * from user code, then user has made a mistake. + */ + if (typePtr == NULL) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("Tcl_AbstractListObjIndex called without and AbstractList Obj.", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + return TCL_ERROR; + } + } + return typePtr->indexProc(interp, abstractListObjPtr, index, elemObjPtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreeAbstractListInternalRep -- + * + * Deallocate the storage associated with an abstract list object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Frees abstractListPtr's AbstractList* internal representation and + * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. + * + *---------------------------------------------------------------------- + */ + +void +FreeAbstractListInternalRep(Tcl_Obj *abstractListObjPtr) +{ + Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(abstractListObjPtr); + + if (TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_FREEREP)) { + /* call the free callback for the concrete rep */ + typePtr->freeRepProc(abstractListObjPtr); + } + abstractListObjPtr->internalRep.twoPtrValue.ptr1 = NULL; + abstractListObjPtr->internalRep.twoPtrValue.ptr2 = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupAbstractListInternalRep -- + * + * Initialize the internal representation of a AbstractList Tcl_Obj to a + * copy of the internal representation of an existing abstractlist object. + * + * Results: + * None. + * + * Side effects: + * We set "copyPtr"s internal rep to a pointer to a + * newly allocated AbstractList structure. + *---------------------------------------------------------------------- + */ + +static void +DupAbstractListInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. + * Internal rep must be clear, it is stomped */ +{ + Tcl_AbstractListType *typePtr; + typePtr = AbstractListGetType(srcPtr); + copyPtr->internalRep.twoPtrValue.ptr1 = typePtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + + /* Now do concrete type dup. It is responsible for calling + Tcl_AbstractListSetConcreteRep to initialize ptr2 */ + + if (typePtr->dupRepProc) { + typePtr->dupRepProc(srcPtr, copyPtr); + } else { + /* TODO - or set it to NULL instead? */ + copyPtr->internalRep.twoPtrValue.ptr2 = + srcPtr->internalRep.twoPtrValue.ptr2; + } + + copyPtr->typePtr = &tclAbstractListType; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfAbstractList -- + * + * Update the string representation for an abstractlist object. + * Note: This procedure does not invalidate an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from the + * listlike-to-string conversion. This string will be empty if the + * AbstractList is empty. + * + * Notes: + * This simple approach is costly in that it forces a string rep for each + * element, which is then tossed. Improving the performance here may + * require implementing a custom size-calculation function for each + * subtype of AbstractList. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfAbstractList(Tcl_Obj *abstractListObjPtr) +{ +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; + Tcl_AbstractListType *typePtr; + char *p; + int bytesNeeded = 0; + int llen, i; + + /* + * TODO - this function essentially adapts the UpdateStringOfList function + * for native lists. Both functions allocate temporary storage for + * localFlags. I'm not sure if that is the best strategy for performance + * as well as memory for large list sizes. Revisit to see if growing + * the allocation on the fly would be better. Essentially combine the + * TclScanElement and TclConvertElement into one loop, growing the + * destination allocation if necessary. + */ + + typePtr = AbstractListGetType(abstractListObjPtr); + + /* + * If concrete type has a better way to generate the string, + * let it do it. + */ + if (TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_TOSTRING)) { + typePtr->toStringProc(abstractListObjPtr); + return; + } + + /* + * TODO - do we need a AbstractList method to mark the list as canonical? + * Or perhaps are abstract lists always canonical? + * Mark the list as being canonical; although it will now have a string + * rep, it is one we derived through proper "canonical" quoting and so + * it's known to be free from nasties relating to [concat] and [eval]. + * listRepPtr->canonicalFlag = 1; + */ + + + /* + * Handle empty list case first, so rest of the routine is simpler. + */ + llen = typePtr->lengthProc(abstractListObjPtr); + if (llen <= 0) { + Tcl_InitStringRep(abstractListObjPtr, NULL, 0); + return; + } + + /* + * Pass 1: estimate space. + */ + if (llen <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + /* We know numElems <= LIST_MAX, so this is safe. */ + flagPtr = (char *) ckalloc(llen); + } + for (bytesNeeded = 0, i = 0; i < llen; i++) { + Tcl_Obj *elemObj; + const char *elemStr; + int elemLen; + flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); + typePtr->indexProc(NULL, abstractListObjPtr, i, &elemObj); + Tcl_IncrRefCount(elemObj); + elemStr = TclGetStringFromObj(elemObj, &elemLen); + /* Note TclScanElement updates flagPtr[i] */ + bytesNeeded += TclScanElement(elemStr, elemLen, flagPtr+i); + if (bytesNeeded < 0) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + Tcl_DecrRefCount(elemObj); + } + if (bytesNeeded > INT_MAX - llen + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + bytesNeeded += llen; /* Separating spaces and terminating nul */ + + /* + * Pass 2: generate the string repr. + */ + abstractListObjPtr->bytes = (char *) ckalloc(bytesNeeded); + p = abstractListObjPtr->bytes; + for (i = 0; i < llen; i++) { + Tcl_Obj *elemObj; + const char *elemStr; + int elemLen; + flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); + typePtr->indexProc(NULL, abstractListObjPtr, i, &elemObj); + Tcl_IncrRefCount(elemObj); + elemStr = TclGetStringFromObj(elemObj, &elemLen); + p += TclConvertElement(elemStr, elemLen, p, flagPtr[i]); + *p++ = ' '; + Tcl_DecrRefCount(elemObj); + } + p[-1] = '\0'; /* Overwrite last space added */ + + /* Length of generated string */ + abstractListObjPtr->length = p - 1 - abstractListObjPtr->bytes; + + if (flagPtr != localFlags) { + ckfree(flagPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * SetAbstractListFromAny -- + * + * The AbstractList object is just a way to optimize + * Lists space complexity, so no one should try to convert + * a string to an AbstractList object. + * + * This function is here just to populate the Type structure. + * + * Results: + * + * The result is always TCL_ERROR. But see Side Effects. + * + * Side effects: + * + * Tcl Panic if called. + * + *---------------------------------------------------------------------- + */ + +static int +SetAbstractListFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr) /* The object to convert. */ +{ + (void)interp; + (void)objPtr; + /* TODO - at some future point, should just shimmer to a traditional + * Tcl list (but only when those are implemented under the AbstractList) + * interface. + */ + Tcl_Panic("SetAbstractListFromAny: should never be called"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjCopy -- + * + * Makes a "pure AbstractList" copy of an AbstractList value. This + * provides for the C level a counterpart of the [lrange $list 0 end] + * command, while using internals details to be as efficient as possible. + * + * Results: + * + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * abstractList value as *abstractListPtr does. The returned Tcl_Obj has a + * refCount of zero. If *abstractListPtr does not hold an AbstractList, + * NULL is returned, and if interp is non-NULL, an error message is + * recorded there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_AbstractListObjCopy( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *abstractListObjPtr) /* List object for which an element array is + * to be returned. */ +{ + Tcl_Obj *copyPtr; + + if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) { + if (SetAbstractListFromAny(interp, abstractListObjPtr) != TCL_OK) { + /* We know this is going to panic, but it's the message we want */ + return NULL; + } + } + + TclNewObj(copyPtr); + TclInvalidateStringRep(copyPtr); + DupAbstractListInternalRep(abstractListObjPtr, copyPtr); + return copyPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjRange -- + * + * Makes a slice of an AbstractList value. + * *abstractListObjPtr must be known to be a valid AbstractList. + * + * Results: + * Returns a pointer to the sliced array. + * This may be a new object or the same object if not shared. + * + * Side effects: + * + * ?The possible conversion of the object referenced by + * abstractListObjPtr to a list object.? + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AbstractListObjRange( + Tcl_Interp *interp, /* For error messages. */ + Tcl_Obj *abstractListObjPtr, /* List object to take a range from. */ + Tcl_WideInt fromIdx, /* Index of first element to include. */ + Tcl_WideInt toIdx, /* Index of last element to include. */ + Tcl_Obj **newObjPtr) /* return value */ +{ + Tcl_AbstractListType *typePtr; + if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("Not an AbstractList.", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + return TCL_ERROR; + } + typePtr = Tcl_AbstractListGetType(abstractListObjPtr); + /* + * sliceProc can be NULL, then revert to List. Note: [lrange] + * command also checks for NULL sliceProc, and won't call AbstractList + */ + if (typePtr->sliceProc) { + return typePtr->sliceProc(interp, abstractListObjPtr, fromIdx, toIdx, newObjPtr); + } else { + /* TODO ?shimmer avoided? */ + Tcl_Obj *newObj = TclListObjCopy(NULL, abstractListObjPtr); + *newObjPtr = (newObj ? TclListObjRange(newObj, (ListSizeT)fromIdx, (ListSizeT)toIdx) : NULL); + return (newObj ? TCL_OK : TCL_ERROR); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjReverse -- + * + * Reverses the order of an AbstractList value. + * *abstractListObjPtr must be known to be a valid AbstractList. + * + * Results: + * Returns a pointer to the reversed array. + * This may be a new object or the same object if not shared. + * + * Side effects: + * + * ?The possible conversion of the object referenced by + * abstractListObjPtr to a list object.? + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AbstractListObjReverse( + Tcl_Interp *interp, /* for reporting errors. */ + Tcl_Obj *abstractListObjPtr, /* List object to take a range from. */ + Tcl_Obj **newObjPtr) /* New AbstractListObj */ +{ + Tcl_AbstractListType *typePtr; + + if (!TclHasInternalRep(abstractListObjPtr, &tclAbstractListType)) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("Not an AbstractList.", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + return TCL_ERROR; + } + if (!TclAbstractListHasProc(abstractListObjPtr, TCL_ABSL_REVERSE)) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("lreverse not supported!", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREVERSE", NULL); + } + return TCL_ERROR; + } + typePtr = Tcl_AbstractListGetType(abstractListObjPtr); + return typePtr->reverseProc(interp, abstractListObjPtr, newObjPtr); +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjGetElements -- + * + * This function returns an (objc,objv) array of the elements in a list + * object. + * + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to an Abstract List object and the object can not be converted + * to one, TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AbstractListObjGetElements( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *objPtr, /* AbstractList object for which an element + * array is to be returned. */ + int *objcPtr, /* Where to store the count of objects + * referenced by objv. */ + Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of + * pointers to the list's objects. */ +{ + + if (TclHasInternalRep(objPtr,&tclAbstractListType)) { + Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr); + + if (TclAbstractListHasProc(objPtr, TCL_ABSL_GETELEMENTS)) { + int status = typePtr->getElementsProc(interp, objPtr, objcPtr, objvPtr); + return status; + } else { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("GetElements not supported!", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + } + return TCL_ERROR; + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an abstract list")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * Returns pointer to the concrete type or NULL if not AbstractList or + * not abstract list of the same type as concrete type + */ +Tcl_AbstractListType * +Tcl_AbstractListGetType( + Tcl_Obj *objPtr) /* Object of type AbstractList */ +{ + if (objPtr->typePtr != &tclAbstractListType) { + return NULL; + } + return (Tcl_AbstractListType *) objPtr->internalRep.twoPtrValue.ptr1; +} + +/* Returns the storage used by the concrete abstract list type */ +void* Tcl_AbstractListGetConcreteRep( + Tcl_Obj *objPtr) /* Object of type AbstractList */ +{ + /* Public function, must check for NULL */ + if (objPtr == NULL || objPtr->typePtr != &tclAbstractListType) { + return NULL; + } + return objPtr->internalRep.twoPtrValue.ptr2; +} + +/* Replace or add the element in the list @indicies with the given new value + */ +Tcl_Obj * +Tcl_AbstractListSetElement( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj *indicies, + Tcl_Obj *valueObj) +{ + Tcl_Obj *returnObj = NULL; + + if (TclHasInternalRep(objPtr,&tclAbstractListType)) { + Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr); + if (TclAbstractListHasProc(objPtr, TCL_ABSL_SETELEMENT)) { + returnObj = typePtr->setElementProc(interp, objPtr, indicies, valueObj); + } else { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("SetElement not supported!", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + returnObj = NULL; + } + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an abstract list")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + returnObj = NULL; + } + return returnObj; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclAbstractList.h b/generic/tclAbstractList.h new file mode 100644 index 0000000..1c92b42 --- /dev/null +++ b/generic/tclAbstractList.h @@ -0,0 +1,55 @@ +/* + * tclAbstractList.h -- + * + * The AbstractList Obj Type -- a psuedo List + * + * Copyright © 2022 by Brian Griffin. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TCLABSTRACTLIST +#define _TCLABSTRACTLIST + +#include "tclInt.h" + +Tcl_AbstractListType * Tcl_AbstractListGetType(Tcl_Obj *objPtr); + +static inline const char* +Tcl_AbstractListTypeName( + Tcl_Obj *objPtr) /* Should be of type AbstractList */ +{ + Tcl_AbstractListType *typePtr; + typePtr = Tcl_AbstractListGetType(objPtr); + if (typePtr && typePtr->typeName) { + return typePtr->typeName; + } else { + return "abstractlist"; + } +} + +Tcl_Obj * Tcl_AbstractListObjNew(Tcl_Interp *interp, const Tcl_AbstractListType *); +Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr); +int Tcl_AbstractListObjIndex(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, + Tcl_WideInt index, Tcl_Obj **elemObj); +int Tcl_AbstractListObjRange(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, + Tcl_WideInt fromIdx, Tcl_WideInt toIdx, Tcl_Obj **newObjPtr); +int Tcl_AbstractListObjReverse(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, + Tcl_Obj **newObjPtr); +int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, + Tcl_Obj ***objvPtr); +Tcl_Obj * Tcl_AbstractListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +void * Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr); +Tcl_Obj * Tcl_AbstractListSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj *indicies, Tcl_Obj *valueObj); + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index b6f33a8..445088b 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -10,45 +10,18 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <assert.h> +#include "tcl.h" #include "tclInt.h" #include "tclArithSeries.h" -#include <assert.h> - -/* -------------------------- ArithSeries object ---------------------------- */ - - -#define ArithSeriesRepPtr(arithSeriesObjPtr) \ - (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) - -#define ArithSeriesIndexM(arithSeriesRepPtr, index) \ - ((arithSeriesRepPtr)->isDouble ? \ - (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \ - : \ - ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step))) - -#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \ - do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \ - (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - - -/* - * Prototypes for procedures defined later in this file: - */ - -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 *listPtr); + /* - * The structure below defines the arithmetic series Tcl object type by - * means of procedures that can be invoked by generic object code. + * The structure below defines the arithmetic series Tcl Obj 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. + * The arithmetic series object is a Tcl_AbstractList representing an interval + * of an arithmetic series in constant space. * * The arithmetic series is internally represented with three integers, * *start*, *end*, and *step*, Where the length is calculated with @@ -61,7 +34,7 @@ static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); * else if RANGE < 0 * LEN is (((END-START)-1)/STEP) - 1 * - * And where the equivalent's list I-th element is calculated + * And where the list's I-th element is calculated * as: * * LIST[i] = START+(STEP*i) @@ -70,18 +43,50 @@ static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); * are valid and will be equivalent to the empty list. */ -const Tcl_ObjType tclArithSeriesType = { - "arithseries", /* name */ - FreeArithSeriesInternalRep, /* freeIntRepProc */ - DupArithSeriesInternalRep, /* dupIntRepProc */ - UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny /* setFromAnyProc */ +#define ArithSeriesIndexM(arithSeriesRepPtr, index) \ + ((arithSeriesRepPtr)->isDouble ? \ + (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \ + : \ + ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step))) + +static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, Tcl_Obj **stepObj); +static int TclArithSeriesObjIndex(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, + Tcl_WideInt index, Tcl_Obj **elemObj); +static Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj); +static int TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, + Tcl_WideInt fromIdx, Tcl_WideInt toIdx, Tcl_Obj **newObjPtr); +static int TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, Tcl_Obj **newObjPtr); +static int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); +static Tcl_Obj *TclNewArithSeriesInt(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step, + Tcl_WideInt len); +static Tcl_Obj *TclNewArithSeriesDbl(double start, double end, + double step, Tcl_WideInt len); +static void DupArithSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeArithSeriesRep(Tcl_Obj *arithSeriesObjPtr); +static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); +static Tcl_Obj *Tcl_NewArithSeriesObj(int objc, Tcl_Obj * const objv[]); + +static Tcl_AbstractListType arithSeriesType = { + TCL_ABSTRACTLIST_VERSION_1, + "arithseries", + Tcl_NewArithSeriesObj, + DupArithSeriesRep, + TclArithSeriesObjLength, + TclArithSeriesObjIndex, + TclArithSeriesObjRange, + TclArithSeriesObjReverse, + TclArithSeriesGetElements, + FreeArithSeriesRep, + UpdateStringOfArithSeries, + NULL }; /* *---------------------------------------------------------------------- * - * ArithSeriesLen -- + * Arithserieslen -- * * Compute the length of the equivalent list where * every element is generated starting from *start*, @@ -93,7 +98,7 @@ const Tcl_ObjType tclArithSeriesType = { * * The length of the list generated by the given range, * that may be zero. - * The function returns -1 if the list is of length infinite. + * The function returns -1 if the list is of length infiite. * * Side effects: * @@ -106,12 +111,74 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) { Tcl_WideInt len; - if (step == 0) { - return 0; - } - len = 1 + ((end-start)/step); + if (step == 0) return 0; + len = (step ? (1 + (((end-start))/step)) : 0); return (len < 0) ? -1 : len; } + +/* + *---------------------------------------------------------------------- + * + * DupArithSeriesRep -- + * + * Initialize the internal representation of a ArithSeries abstract list + * Tcl_Obj to a copy of the internal representation of an existing + * arithseries object. + * + * Results: + * None. + * + * Side effects: + * We set "copyPtr"s internal rep to a pointer to a + * newly allocated AbstractList structure. + *---------------------------------------------------------------------- + */ + +static void +DupArithSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) +{ + ArithSeries *srcArithSeries = (ArithSeries*)Tcl_AbstractListGetConcreteRep(srcPtr); + ArithSeries *copyArithSeries = (ArithSeries *)ckalloc(sizeof(ArithSeries)); + + *copyArithSeries = *srcArithSeries; + + /* Note: we do not have to be worry about existing internal rep because + copyPtr is supposed to be freshly initialized */ + Tcl_AbstractListSetConcreteRep(copyPtr, copyArithSeries); +} + + +/* + *---------------------------------------------------------------------- + * + * FreeArithSeriesRep -- + * + * Free any allocated memory in the ArithSeries Rep + * + * Results: + * None. + * + * Side effects: + * + *---------------------------------------------------------------------- + */ +static void +FreeArithSeriesRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */ +{ + ArithSeries *arithSeriesPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr); + if (arithSeriesPtr) { + if (arithSeriesPtr->elements) { + Tcl_WideInt i, len = arithSeriesPtr->len; + for (i=0; i<len; i++) { + Tcl_DecrRefCount(arithSeriesPtr->elements[i]); + } + ckfree((char*)arithSeriesPtr->elements); + arithSeriesPtr->elements = NULL; + } + ckfree((char*)arithSeriesPtr); + } +} + /* *---------------------------------------------------------------------- @@ -135,13 +202,12 @@ Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); - Tcl_Obj *arithSeriesPtr; + Tcl_Obj *arithSeriesObj; ArithSeries *arithSeriesRepPtr; - TclNewObj(arithSeriesPtr); - if (length <= 0) { - return arithSeriesPtr; + TclNewObj(arithSeriesObj); + return arithSeriesObj; } arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); @@ -151,13 +217,14 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; - arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; + + arithSeriesObj = Tcl_AbstractListObjNew(NULL, &arithSeriesType); + Tcl_AbstractListSetConcreteRep(arithSeriesObj, arithSeriesRepPtr); + if (length > 0) - Tcl_InvalidateStringRep(arithSeriesPtr); + Tcl_InvalidateStringRep(arithSeriesObj); - return arithSeriesPtr; + return arithSeriesObj; } /* @@ -182,13 +249,12 @@ Tcl_Obj * TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); - Tcl_Obj *arithSeriesPtr; + Tcl_Obj *arithSeriesObj; ArithSeriesDbl *arithSeriesRepPtr; - TclNewObj(arithSeriesPtr); - if (length <= 0) { - return arithSeriesPtr; + TclNewObj(arithSeriesObj); + return arithSeriesObj; } arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); @@ -198,13 +264,14 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; - arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; + + arithSeriesObj = Tcl_AbstractListObjNew(NULL, &arithSeriesType); + Tcl_AbstractListSetConcreteRep(arithSeriesObj, arithSeriesRepPtr); + if (length > 0) - Tcl_InvalidateStringRep(arithSeriesPtr); + Tcl_InvalidateStringRep(arithSeriesObj); - return arithSeriesPtr; + return arithSeriesObj; } /* @@ -212,7 +279,7 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) * * assignNumber -- * - * Create the appropriate Tcl_Obj value for the given numeric values. + * Create the approprite Tcl_Obj value for the given numeric values. * Used locally only for decoding [lseq] numeric arguments. * refcount = 0. * @@ -227,26 +294,33 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) *---------------------------------------------------------------------- */ static void -assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) +assignNumber( + int useDoubles, + Tcl_WideInt *intNumberPtr, + double *dblNumberPtr, + Tcl_Obj *numberObj) { - void *clientData; + union { + double d; + Tcl_WideInt i; + } *number; int tcl_number_type; - if (Tcl_GetNumberFromObj(NULL, numberObj, &clientData, &tcl_number_type) != TCL_OK + if (Tcl_GetNumberFromObj(NULL, numberObj, (void**)&number, &tcl_number_type) != TCL_OK || tcl_number_type == TCL_NUMBER_BIG) { return; } if (useDoubles) { - if (tcl_number_type != TCL_NUMBER_INT) { - *dblNumberPtr = *(double *)clientData; + if (tcl_number_type == TCL_NUMBER_DOUBLE) { + *dblNumberPtr = number->d; } else { - *dblNumberPtr = (double)*(Tcl_WideInt *)clientData; + *dblNumberPtr = (double)number->i; } } else { if (tcl_number_type == TCL_NUMBER_INT) { - *intNumberPtr = *(Tcl_WideInt *)clientData; + *intNumberPtr = number->i; } else { - *intNumberPtr = (Tcl_WideInt)*(double *)clientData; + *intNumberPtr = (Tcl_WideInt)number->d; } } } @@ -270,16 +344,17 @@ assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tc * None. *---------------------------------------------------------------------- */ + int TclNewArithSeriesObj( - Tcl_Interp *interp, /* For error reporting */ - Tcl_Obj **arithSeriesObj, /* return value */ - int useDoubles, /* Flag indicates values start, - ** end, step, are treated as doubles */ - Tcl_Obj *startObj, /* Starting value */ - Tcl_Obj *endObj, /* Ending limit */ - Tcl_Obj *stepObj, /* increment value */ - Tcl_Obj *lenObj) /* Number of elements */ + Tcl_Interp *interp, /* For error reporting */ + Tcl_Obj **arithSeriesObj, /* return value */ + int useDoubles, /* Promote values to double when true, + * int otherwise */ + Tcl_Obj *startObj, /* First value in list */ + Tcl_Obj *endObj, /* Upper bound value of list */ + Tcl_Obj *stepObj, /* Increment amount */ + Tcl_Obj *lenObj) /* Number of elements */ { double dstart, dend, dstep; Tcl_WideInt start, end, step, len; @@ -299,7 +374,7 @@ TclNewArithSeriesObj( } if (dstep == 0) { *arithSeriesObj = Tcl_NewObj(); - return TCL_OK; + return TCL_OK; } } if (endObj) { @@ -360,43 +435,25 @@ TclNewArithSeriesObj( /* *---------------------------------------------------------------------- * - * TclArithSeriesObjStep -- + * TclArithSeriesObjLength * - * Return a Tcl_Obj with the step value from the give ArithSeries Obj. - * refcount = 0. + * Returns the length of the arithmentic series. * * Results: * - * A Tcl_Obj pointer to the created ArithSeries object. - * A NULL pointer of the range is invalid. + * The length of the series as Tcl_WideInt. * * Side Effects: * * None. + * *---------------------------------------------------------------------- */ -/* - * TclArithSeriesObjStep -- - */ -int -TclArithSeriesObjStep( - Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj) +Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj) { - ArithSeries *arithSeriesRepPtr; - - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (arithSeriesRepPtr->isDouble) { - *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); - } else { - *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); - } - return TCL_OK; + ArithSeries *arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesObj); + return arithSeriesRepPtr->len; } - /* *---------------------------------------------------------------------- @@ -404,14 +461,14 @@ TclArithSeriesObjStep( * TclArithSeriesObjIndex -- * * Returns the element with the specified index in the list - * represented by the specified Arithmetic Sequence object. + * represented by the specified Arithmentic Sequence object. * If the index is out of range, TCL_ERROR is returned, * otherwise TCL_OK is returned and the integer value of the * element is stored in *element. * * Results: * - * TCL_OK on success, TCL_ERROR on index out of range. + * TCL_OK on succes, TCL_ERROR on index out of range. * * Side Effects: * @@ -421,266 +478,92 @@ TclArithSeriesObjStep( */ int -TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj) +TclArithSeriesObjIndex( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *arithSeriesPtr, /* List obj */ + Tcl_WideInt index, /* index to element of interest */ + Tcl_Obj **elemObj) /* Return value */ { - ArithSeries *arithSeriesRepPtr; - - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (index < 0 || index >= arithSeriesRepPtr->len) { - return TCL_ERROR; - } - /* List[i] = Start + (Step * index) */ - if (arithSeriesRepPtr->isDouble) { - *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + ArithSeries *arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr); + (void)interp; // quiet compiler + if (0 <= index || index < arithSeriesRepPtr->len) { + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elemObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } else { + *elemObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } } else { - *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + TclNewObj(*elemObj); // empty value } + return TCL_OK; } - + /* *---------------------------------------------------------------------- * - * TclArithSeriesObjLength + * TclArithSeriesObjStep -- * - * Returns the length of the arithmetic series. + * Return a Tcl_Obj with the step value from the give ArithSeries Obj. + * refcount = 0. * * Results: * - * The length of the series as Tcl_WideInt. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * * Side Effects: * * None. - * - *---------------------------------------------------------------------- - */ -Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) -{ - ArithSeries *arithSeriesRepPtr = (ArithSeries*) - arithSeriesPtr->internalRep.twoPtrValue.ptr1; - return arithSeriesRepPtr->len; -} - -/* - *---------------------------------------------------------------------- - * - * FreeArithSeriesInternalRep -- - * - * Deallocate the storage associated with an arithseries object's - * internal representation. - * - * Results: - * None. - * - * Side effects: - * Frees arithSeriesPtr's ArithSeries* internal representation and - * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. - * - *---------------------------------------------------------------------- - */ - -static void -FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) -{ - ArithSeries *arithSeriesRepPtr = - (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i; - Tcl_Obj**elmts = arithSeriesRepPtr->elements; - for(i=0; i<arithSeriesRepPtr->len; i++) { - if (elmts[i]) { - Tcl_DecrRefCount(elmts[i]); - } - } - ckfree((char *) arithSeriesRepPtr->elements); - } - ckfree((char *) arithSeriesRepPtr); - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DupArithSeriesInternalRep -- - * - * Initialize the internal representation of a arithseries Tcl_Obj to a - * copy of the internal representation of an existing arithseries object. - * - * Results: - * None. - * - * Side effects: - * We set "copyPtr"s internal rep to a pointer to a - * newly allocated ArithSeries structure. - *---------------------------------------------------------------------- - */ - -static void -DupArithSeriesInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - ArithSeries *srcArithSeriesRepPtr = - (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; - ArithSeries *copyArithSeriesRepPtr; - - /* - * Allocate a new ArithSeries structure. */ - - copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries)); - *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; - copyArithSeriesRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclArithSeriesType; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfArithSeries -- - * - * Update the string representation for an arithseries object. - * Note: This procedure does not invalidate an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from - * the list-to-string conversion. This string will be empty if the - * list has no elements. The list internal representation - * should not be NULL and we assume it is not NULL. - * - * Notes: - * At the cost of overallocation it's possible to estimate - * the length of the string representation and make this procedure - * much faster. Because the programmer shouldn't expect the - * string conversion of a big arithmetic sequence to be fast - * this version takes more care of space than time. - * *---------------------------------------------------------------------- */ -static void -UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj) { - ArithSeries *arithSeriesRepPtr = - (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - char *elem, *p; - Tcl_Obj *elemObj; - Tcl_WideInt i; - Tcl_WideInt length = 0; - int slen; - - /* - * Pass 1: estimate space. - */ - for (i = 0; i < arithSeriesRepPtr->len; i++) { - TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); - elem = TclGetStringFromObj(elemObj, &slen); - Tcl_DecrRefCount(elemObj); - slen += 1; /* + 1 is for the space or the nul-term */ - length += slen; - } - - /* - * Pass 2: generate the string repr. - */ - - p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); - for (i = 0; i < arithSeriesRepPtr->len; i++) { - TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); - elem = TclGetStringFromObj(elemObj, &slen); - strcpy(p, elem); - p[slen] = ' '; - p += slen+1; - Tcl_DecrRefCount(elemObj); + ArithSeries *arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr); + if (arithSeriesRepPtr->isDouble) { + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + } else { + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } - if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; - arithSeriesPtr->length = length-1; -} - -/* - *---------------------------------------------------------------------- - * - * SetArithSeriesFromAny -- - * - * The Arithmetic Series object is just an way to optimize - * Lists space complexity, so no one should try to convert - * a string to an Arithmetic Series object. - * - * This function is here just to populate the Type structure. - * - * Results: - * - * The result is always TCL_ERROR. But see Side Effects. - * - * Side effects: - * - * Tcl Panic if called. - * - *---------------------------------------------------------------------- - */ - -static int -SetArithSeriesFromAny( - TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ - TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */ -{ - Tcl_Panic("SetArithSeriesFromAny: should never be called"); - return TCL_ERROR; + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclArithSeriesObjCopy -- + * Tcl_NewArithSeriesObj -- * - * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C - * level a counterpart of the [lrange $list 0 end] command, while using - * internals details to be as efficient as possible. + * Creates a new ArithSeries object. The returned object has + * refcount = 0. * * Results: * - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a - * refCount of zero. If *arithSeriesPtr does not hold an arithSeries, - * NULL is returned, and if interp is non-NULL, an error message is - * recorded there. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * - * Side effects: - * None. + * Side Effects: * + * None. *---------------------------------------------------------------------- */ Tcl_Obj * -TclArithSeriesObjCopy( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *arithSeriesPtr) /* List object for which an element array is - * to be returned. */ +Tcl_NewArithSeriesObj(int objc, Tcl_Obj * const objv[]) { - Tcl_Obj *copyPtr; - ArithSeries *arithSeriesRepPtr; - - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); - if (NULL == arithSeriesRepPtr) { - if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) { - /* We know this is going to panic, but it's the message we want */ - return NULL; - } + Tcl_Obj *arithSeriesObj; + if (objc != 4) return NULL; + // TODO: Define this use model! + if (TclNewArithSeriesObj(NULL, &arithSeriesObj, 0/*TODO: int vs double support */, + objv[0]/*start*/, objv[1]/*end*/, + objv[2]/*step*/, objv[3]/*len*/) != TCL_OK) { + arithSeriesObj = NULL; } - - TclNewObj(copyPtr); - TclInvalidateStringRep(copyPtr); - DupArithSeriesInternalRep(arithSeriesPtr, copyPtr); - return copyPtr; + return arithSeriesObj; } /* @@ -702,46 +585,45 @@ TclArithSeriesObjCopy( *---------------------------------------------------------------------- */ -Tcl_Obj * +int TclArithSeriesObjRange( - Tcl_Interp *interp, /* For error message(s) */ + Tcl_Interp *interp, /* for error messages. */ Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ - int fromIdx, /* Index of first element to include. */ - int toIdx) /* Index of last element to include. */ + Tcl_WideInt fromIdx, /* Index of first element to include. */ + Tcl_WideInt toIdx, /* Index of last element to include. */ + Tcl_Obj **newObjPtr) /* return value */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + (void)interp; /* silence compiler */ + + arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr); if (fromIdx < 0) { fromIdx = 0; } if (fromIdx > toIdx) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + TclNewObj(*newObjPtr); + return TCL_OK; } - TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); + TclArithSeriesObjIndex(NULL, arithSeriesPtr, fromIdx, &startObj); Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); + TclArithSeriesObjIndex(NULL, arithSeriesPtr, toIdx, &endObj); Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { - Tcl_Obj *newSlicePtr; - if (TclNewArithSeriesObj(interp, &newSlicePtr, - arithSeriesRepPtr->isDouble, startObj, endObj, - stepObj, NULL) != TCL_OK) { - newSlicePtr = NULL; - } - Tcl_DecrRefCount(startObj); - Tcl_DecrRefCount(endObj); - Tcl_DecrRefCount(stepObj); - return newSlicePtr; + int status = TclNewArithSeriesObj(NULL, newObjPtr, + arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); + + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + return status; } /* @@ -749,7 +631,7 @@ TclArithSeriesObjRange( */ /* - * Even if nothing below causes any changes, we still want the + * Even if nothing below cause any changes, we still want the * string-canonizing effect of [lrange 0 end]. */ @@ -783,125 +665,19 @@ TclArithSeriesObjRange( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return arithSeriesPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesGetElements -- - * - * This function returns an (objc,objv) array of the elements in a list - * object. - * - * Results: - * The return value is normally TCL_OK; in this case *objcPtr is set to - * the count of list elements and *objvPtr is set to a pointer to an - * array of (*objcPtr) pointers to each list element. If listPtr does not - * refer to an Abstract List object and the object can not be converted - * to one, TCL_ERROR is returned and an error message will be left in the - * interpreter's result if interp is not NULL. - * - * The objects referenced by the returned array should be treated as - * readonly and their ref counts are _not_ incremented; the caller must - * do that if it holds on to a reference. Furthermore, the pointer and - * length returned by this function may change as soon as any function is - * called on the list object; be careful about retaining the pointer in a - * local data structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclArithSeriesGetElements( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *objPtr, /* AbstractList object for which an element - * array is to be returned. */ - ListSizeT *objcPtr, /* Where to store the count of objects - * referenced by objv. */ - Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of - * pointers to the list's objects. */ -{ - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { - ArithSeries *arithSeriesRepPtr; - Tcl_Obj **objv; - 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 **)ckalloc(sizeof(Tcl_Obj*) * objc); - if (objv == NULL) { - if (interp) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; - } - arithSeriesRepPtr->elements = objv; - for (i = 0; i < objc; i++) { - if (TclArithSeriesObjIndex(objPtr, i, &objv[i]) != TCL_OK) { - if (interp) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("indexing error", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; - } - Tcl_IncrRefCount(objv[i]); - } - } - } else { - objv = NULL; - } - *objvPtr = objv; - *objcPtr = objc; - } else { - if (interp != NULL) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("value is not an arithseries")); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); - } - return TCL_ERROR; - } + *newObjPtr = arithSeriesPtr; return TCL_OK; } /* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjReverse -- - * - * Reverse the order of the ArithSeries value. - * *arithSeriesPtr must be known to be a valid list. - * - * Results: - * Returns a pointer to the reordered series. - * This may be a new object or the same object if not shared. - * - * Side effects: - * ?The possible conversion of the object referenced by listPtr? - * ?to a list object.? - * - *---------------------------------------------------------------------- + * Handle ArithSeries special case - don't shimmer a series into a list + * just to reverse it. */ - -Tcl_Obj * +int TclArithSeriesObjReverse( - Tcl_Interp *interp, /* For error message(s) */ - Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ + Tcl_Interp *interp, /* For error messages */ + Tcl_Obj *arithSeriesPtr, /* List object to reverse. */ + Tcl_Obj **newObjPtr) { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; @@ -910,14 +686,20 @@ TclArithSeriesObjReverse( double dstart, dend, dstep; int isDouble; - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + (void)interp; + + if (newObjPtr == NULL) { + return TCL_ERROR; + } + + arithSeriesRepPtr = (ArithSeries *)Tcl_AbstractListGetConcreteRep(arithSeriesPtr); isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + TclArithSeriesObjIndex(NULL, arithSeriesPtr, (len-1), &startObj); Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + TclArithSeriesObjIndex(NULL, arithSeriesPtr, 0, &endObj); Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); Tcl_IncrRefCount(stepObj); @@ -936,14 +718,18 @@ TclArithSeriesObjReverse( TclSetIntObj(stepObj, step); } + Tcl_IncrRefCount(startObj); + Tcl_IncrRefCount(endObj); + Tcl_IncrRefCount(stepObj); + if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); - if (TclNewArithSeriesObj(interp, &resultObj, - isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { - resultObj = NULL; - } - Tcl_DecrRefCount(lenObj); + if (TclNewArithSeriesObj(NULL, &resultObj, isDouble, + startObj, endObj, stepObj, lenObj) != TCL_OK) { + resultObj = NULL; + } + Tcl_DecrRefCount(lenObj); } else { /* @@ -979,5 +765,120 @@ TclArithSeriesObjReverse( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return resultObj; + *newObjPtr = resultObj; + + return TCL_OK; +} + +/* +** Handle ArithSeries GetElements call +*/ + +int +TclArithSeriesGetElements( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *arithSeriesObjPtr, /* ArithSeries object for which an element + * array is to be returned. */ + int *objcPtr, /* Where to store the count of objects + * referenced by objv. */ + Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of + * pointers to the list's objects. */ +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr); + Tcl_Obj **objv; + int i, objc; + + objc = arithSeriesRepPtr->len; + + if (objvPtr == NULL) { + if (objcPtr) { + *objcPtr = objc; + return TCL_OK; + } + return TCL_ERROR; + } + + if (objc && objvPtr && arithSeriesRepPtr->elements) { + objv = arithSeriesRepPtr->elements; + } else if (objc > 0) { + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); + if (objv == NULL) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + for (i = 0; i < objc; i++) { + if (TclArithSeriesObjIndex(interp, arithSeriesObjPtr, i, &objv[i]) == TCL_OK) { + Tcl_IncrRefCount(objv[i]); + } else { + // TODO: some cleanup needed here + return TCL_ERROR; + } + } + } else { + objv = NULL; + } + arithSeriesRepPtr->elements = objv; + *objvPtr = objv; + *objcPtr = objc; + return TCL_OK; } + +static void +UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*)Tcl_AbstractListGetConcreteRep(arithSeriesObjPtr); + char *p, *str; + Tcl_Obj *eleObj; + Tcl_WideInt length = 0; + int llen, slen, i; + + + /* + * Pass 1: estimate space. + */ + llen = arithSeriesRepPtr->len; + if (llen <= 0) { + Tcl_InitStringRep(arithSeriesObjPtr, NULL, 0); + return; + } + for (i = 0; i < llen; i++) { + if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) { + Tcl_GetStringFromObj(eleObj, &slen); + length += slen + 1; /* one more for the space char */ + Tcl_DecrRefCount(eleObj); + } else { + // TODO: report error? + } + } + + /* + * Pass 2: generate the string repr. + */ + + p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, length); + for (i = 0; i < llen; i++) { + if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) { + str = Tcl_GetStringFromObj(eleObj, &slen); + strcpy(p, str); + p[slen] = ' '; + p += slen+1; + Tcl_DecrRefCount(eleObj); + } // else TODO: report error here? + } + if (length > 0) arithSeriesObjPtr->bytes[length-1] = '\0'; + arithSeriesObjPtr->length = length-1; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 3ace052..0f5468d 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -11,7 +11,7 @@ */ /* - * The structure used for the ArithSeries internal representation. + * The structure used for the AirthSeries internal representation. * Note that the len can in theory be always computed by start,end,step * but it's faster to cache it inside the internal representation. */ @@ -23,6 +23,7 @@ typedef struct ArithSeries { Tcl_Obj **elements; int isDouble; } ArithSeries; + typedef struct ArithSeriesDbl { double start; double end; @@ -32,26 +33,16 @@ typedef struct ArithSeriesDbl { int isDouble; } ArithSeriesDbl; +MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesPtr, + int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, + Tcl_Obj *stepObj, Tcl_Obj *lenObj); + -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj); -MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, - Tcl_WideInt index, Tcl_Obj **elementObj); -MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step, - Tcl_WideInt len); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, - double step, Tcl_WideInt len); -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: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 13715f8..172e444 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -322,7 +322,7 @@ static const CmdInfo builtInCmds[] = { {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1e9832a..94f4859 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -12,10 +12,10 @@ */ #include "tclInt.h" +#include "tclAbstractList.h" #ifdef _WIN32 # include "tclWinInt.h" #endif -#include "tclArithSeries.h" /* * The state structure used by [foreach]. Note that the actual structure has @@ -2874,24 +2874,23 @@ EachloopCmd( } /* Values */ - if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { - /* Special case for Arith Series */ - statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (TclHasInternalRep(objv[2+i*2],&tclAbstractListType)) { + /* Special case for Abstract List */ + statePtr->aCopyList[i] = Tcl_AbstractListObjCopy(interp, objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last momement */ - statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); + statePtr->argcList[i] = Tcl_AbstractListObjLength(statePtr->aCopyList[i]); } else { - /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } TclListObjGetElementsM(NULL, statePtr->aCopyList[i], - &statePtr->argcList[i], &statePtr->argvList[i]); + &statePtr->argcList[i], &statePtr->argvList[i]); } /* account for variable <> value mismatch */ j = statePtr->argcList[i] / statePtr->varcList[i]; @@ -3015,16 +3014,19 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); + int isAbstractList = + TclHasInternalRep(statePtr->aCopyList[i],&tclAbstractListType); + for (v=0 ; v<statePtr->varcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { - if (isarithseries) { - if (TclArithSeriesObjIndex(statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { + if (isAbstractList) { + if (Tcl_AbstractListObjIndex(interp, statePtr->aCopyList[i], k, &valuePtr) + != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (setting %s loop variable \"%s\")", - (statePtr->resultList != NULL ? "lmap" : "foreach"), - TclGetString(statePtr->varvList[i][v]))); + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + TclGetString(statePtr->varvList[i][v]))); return TCL_ERROR; } } else { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4b7bd48..b4c1fa8 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -17,10 +17,11 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include <math.h> #include "tclInt.h" #include "tclRegexp.h" +#include "tclAbstractList.h" #include "tclArithSeries.h" -#include <math.h> #include <assert.h> /* @@ -97,23 +98,6 @@ typedef struct { #define SORTMODE_ASCII_NC 8 /* - * Definitions for [lseq] command - */ -static const char *const seq_operations[] = { - "..", "to", "count", "by", NULL -}; -typedef enum Sequence_Operators { - LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY -} SequenceOperators; -static const char *const seq_step_keywords[] = {"by", NULL}; -typedef enum Step_Operators { - STEP_BY = 4 -} SequenceByMode; -typedef enum Sequence_Decoded { - NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg -} SequenceDecoded; - -/* * Forward declarations for procedures defined in this file: */ @@ -181,6 +165,24 @@ static const EnsembleImplMap defaultInfoMap[] = { {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; + +/* + * Definitions for [lseq] command + */ +static const char *const seq_operations[] = { + "..", "to", "count", "by", NULL +}; +typedef enum Sequence_Operators { + LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY +} SequenceOperators; +static const char *const seq_step_keywords[] = {"by", NULL}; +typedef enum Step_Operators { + STEP_BY = 4 +} SequenceByMode; +typedef enum Sequence_Decoded { + NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg +} SequenceDecoded; + /* *---------------------------------------------------------------------- @@ -2201,7 +2203,7 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int length, listLen, isArithSeries = 0; + int length, listLen, isAbstractList = 0; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2214,14 +2216,18 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - isArithSeries = 1; - listLen = TclArithSeriesObjLength(objv[1]); - } else { - if (TclListObjGetElementsM(interp, objv[1], &listLen, - &elemPtrs) != TCL_OK) { + if (TclHasInternalRep(objv[1],&tclAbstractListType) && + TclAbstractListHasProc(objv[1], TCL_ABSL_GETELEMENTS)) { + listLen = Tcl_AbstractListObjLength(objv[1]); + isAbstractList = (listLen ? 1 : 0); + if (listLen > 1 && + Tcl_AbstractListObjGetElements(interp, objv[1], &listLen, &elemPtrs) + != TCL_OK) { return TCL_ERROR; } + } else if (TclListObjGetElementsM(interp, objv[1], &listLen, + &elemPtrs) != TCL_OK) { + return TCL_ERROR; } if (listLen == 0) { @@ -2230,14 +2236,15 @@ Tcl_JoinObjCmd( } if (listLen == 1) { /* One element; return it */ - if (isArithSeries) { - Tcl_Obj *valueObj; - if (TclArithSeriesObjIndex(objv[1], 0, &valueObj) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, valueObj); - } else { + if (!isAbstractList) { Tcl_SetObjResult(interp, elemPtrs[0]); + } else { + Tcl_Obj *elemObj; + if (Tcl_AbstractListObjIndex(interp, objv[1], 0, &elemObj) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, elemObj); } return TCL_OK; } @@ -2252,41 +2259,19 @@ Tcl_JoinObjCmd( int i; TclNewObj(resObjPtr); - if (isArithSeries) { - Tcl_Obj *valueObj; - for (i = 0; i < listLen; i++) { - if (i > 0) { - - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ - - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - if (TclArithSeriesObjIndex(objv[1], i, &valueObj) != TCL_OK) { - return TCL_ERROR; - } - Tcl_AppendObjToObj(resObjPtr, valueObj); - Tcl_DecrRefCount(valueObj); - } - } else { - for (i = 0; i < listLen; i++) { - if (i > 0) { + for (i = 0; i < listLen; i++) { + if (i > 0) { - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } } Tcl_DecrRefCount(joinObjPtr); @@ -2742,14 +2727,14 @@ Tcl_LrangeObjCmd( return result; } - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_Obj *rangeObj; - rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); - if (rangeObj) { - Tcl_SetObjResult(interp, rangeObj); - } else { - return TCL_ERROR; + if (TclHasInternalRep(objv[1],&tclAbstractListType) && + TclAbstractListHasProc(objv[1], TCL_ABSL_SLICE)) { + Tcl_Obj *resultObj; + int status = Tcl_AbstractListObjRange(interp, objv[1], first, last, &resultObj); + if (status == TCL_OK) { + Tcl_SetObjResult(interp, resultObj); } + return status; } else { Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); } @@ -3136,22 +3121,20 @@ Tcl_LreverseObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - /* - * Handle ArithSeries special case - don't shimmer a series into a list - * just to reverse it. + * Handle AbstractList special case - do not shimmer into a list, if it + * supports a private Reverse function, just to reverse it. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); - if (resObj) { - Tcl_SetObjResult(interp, resObj); + if (TclHasInternalRep(objv[1],&tclAbstractListType) && + TclAbstractListHasProc(objv[1], TCL_ABSL_REVERSE)) { + Tcl_Obj *resultObj; + + if (Tcl_AbstractListObjReverse(interp, objv[1], &resultObj) == TCL_OK) { + Tcl_SetObjResult(interp, resultObj); return TCL_OK; - } else { - return TCL_ERROR; } - } /* end ArithSeries */ + } /* end Abstract List */ - /* True List */ if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } @@ -3963,91 +3946,7 @@ Tcl_LsearchObjCmd( } return result; } - -/* - *---------------------------------------------------------------------- - * - * Tcl_LsetObjCmd -- - * - * This procedure is invoked to process the "lset" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_LsetObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument values. */ -{ - Tcl_Obj *listPtr; /* Pointer to the list being altered. */ - Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ - - /* - * Check parameter count. - */ - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "listVar ?index? ?index ...? value"); - return TCL_ERROR; - } - - /* - * Look up the list variable's value. - */ - - listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); - if (listPtr == NULL) { - return TCL_ERROR; - } - - /* - * Substitute the value in the value. Return either the value or else an - * unshared copy of it. - */ - if (objc == 4) { - finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); - } else { - finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); - } - - /* - * If substitution has failed, bail out. - */ - - if (finalValuePtr == NULL) { - return TCL_ERROR; - } - - /* - * Finally, update the variable so that traces fire. - */ - - listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, - TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(finalValuePtr); - if (listPtr == NULL) { - return TCL_ERROR; - } - - /* - * Return the new value of the variable as the interpreter result. - */ - - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} /* *---------------------------------------------------------------------- @@ -4077,9 +3976,12 @@ SequenceIdentifyArgument( int status; SequenceOperators opmode; SequenceByMode bymode; - void *clientData; + union { + Tcl_WideInt i; + double d; + } *nvalue; - status = Tcl_GetNumberFromObj(NULL, argPtr, &clientData, keywordIndexPtr); + status = Tcl_GetNumberFromObj(NULL, argPtr, (void**)&nvalue, keywordIndexPtr); if (status == TCL_OK) { if (numValuePtr) { *numValuePtr = argPtr; @@ -4189,7 +4091,7 @@ Tcl_LseqObjCmd( Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; - int status, keyword, useDoubles = 0; + int status = TCL_ERROR, keyword, useDoubles = 0; Tcl_Obj *arithSeriesPtr; SequenceOperators opmode; SequenceDecoded decoded; @@ -4259,11 +4161,10 @@ Tcl_LseqObjCmd( case 0: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); - status = TCL_ERROR; goto done; break; -/* range n */ +/* lseq n */ case 1: start = zero; elementCount = numValues[0]; @@ -4271,22 +4172,22 @@ Tcl_LseqObjCmd( step = one; break; -/* range n n */ +/* lseq n n */ case 11: start = numValues[0]; end = numValues[1]; break; -/* range n n n */ +/* lseq n n n */ case 111: start = numValues[0]; end = numValues[1]; step = numValues[2]; break; -/* range n 'to' n */ -/* range n 'count' n */ -/* range n 'by' n */ +/* lseq n 'to' n */ +/* lseq n 'count' n */ +/* lseq n 'by' n */ case 121: opmode = (SequenceOperators)values[1]; switch (opmode) { @@ -4306,13 +4207,12 @@ Tcl_LseqObjCmd( step = one; break; default: - status = TCL_ERROR; goto done; } break; -/* range n 'to' n n */ -/* range n 'count' n n */ +/* lseq n 'to' n n */ +/* lseq n 'count' n n */ case 1211: opmode = (SequenceOperators)values[1]; switch (opmode) { @@ -4329,17 +4229,15 @@ Tcl_LseqObjCmd( break; case LSEQ_BY: /* Error case */ - status = TCL_ERROR; goto done; break; default: - status = TCL_ERROR; goto done; break; } break; -/* range n n 'by' n */ +/* lseq n n 'by' n */ case 1121: start = numValues[0]; end = numValues[1]; @@ -4352,14 +4250,13 @@ Tcl_LseqObjCmd( case LSEQ_TO: case LSEQ_COUNT: default: - status = TCL_ERROR; goto done; break; } break; -/* range n 'to' n 'by' n */ -/* range n 'count' n 'by' n */ +/* lseq n 'to' n 'by' n */ +/* lseq n 'count' n 'by' n */ case 12121: start = numValues[0]; opmode = (SequenceOperators)values[3]; @@ -4368,7 +4265,6 @@ Tcl_LseqObjCmd( step = numValues[4]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4384,7 +4280,6 @@ Tcl_LseqObjCmd( elementCount = numValues[2]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4398,7 +4293,6 @@ Tcl_LseqObjCmd( case 1212: opmode = (SequenceOperators)values[3]; goto KeywordError; break; KeywordError: - status = TCL_ERROR; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: @@ -4414,14 +4308,12 @@ Tcl_LseqObjCmd( "missing \"by\" value.")); break; } - status = TCL_ERROR; goto done; break; /* All other argument errors */ default: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); - status = TCL_ERROR; goto done; break; } @@ -4429,11 +4321,9 @@ Tcl_LseqObjCmd( /* * Success! Now lets create the series object. */ - status = TclNewArithSeriesObj(interp, &arithSeriesPtr, - useDoubles, start, end, step, elementCount); - + status = TclNewArithSeriesObj(interp, &arithSeriesPtr, useDoubles, start, end, step, elementCount); if (status == TCL_OK) { - Tcl_SetObjResult(interp, arithSeriesPtr); + Tcl_SetObjResult(interp, arithSeriesPtr); } done: @@ -4452,6 +4342,96 @@ Tcl_LseqObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_LsetObjCmd -- + * + * This procedure is invoked to process the "lset" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LsetObjCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + Tcl_Obj *listPtr; /* Pointer to the list being altered. */ + Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */ + + /* + * Check parameter count. + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "listVar ?index? ?index ...? value"); + return TCL_ERROR; + } + + /* + * Look up the list variable's value. + */ + + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Substitute the value in the value. Return either the value or else an + * unshared copy of it. + */ + + if (TclHasInternalRep(listPtr,&tclAbstractListType) && + TclAbstractListHasProc(listPtr, TCL_ABSL_SETELEMENT) && + objc == 4) { + finalValuePtr = Tcl_AbstractListSetElement(interp, listPtr, objv[2], objv[3]); + if (finalValuePtr) Tcl_IncrRefCount(finalValuePtr); + } else if (objc == 4) { + finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); + } else { + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); + } + + /* + * If substitution has failed, bail out. + */ + + if (finalValuePtr == NULL) { + return TCL_ERROR; + } + + /* + * Finally, update the variable so that traces fire. + */ + + listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(finalValuePtr); + if (listPtr == NULL) { + return TCL_ERROR; + } + + /* + * Return the new value of the variable as the interpreter result. + */ + + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LsortObjCmd -- * * This procedure is invoked to process the "lsort" Tcl command. See the @@ -4717,9 +4697,10 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - sortInfo.resultCode = TclArithSeriesGetElements(interp, - listObj, &length, &listObjPtrs); + if (TclHasInternalRep(listObj,&tclAbstractListType) && + TclAbstractListHasProc(objv[1], TCL_ABSL_GETELEMENTS)) { + sortInfo.resultCode = + Tcl_AbstractListObjGetElements(interp, listObj, &length, &listObjPtrs); } else { sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, &length, &listObjPtrs); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e54ea2c..937b5a2 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2019,6 +2019,37 @@ EXTERN int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, /* 682 */ EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); +/* 683 */ +EXTERN Tcl_Obj * Tcl_AbstractListObjNew(Tcl_Interp *interp, + const Tcl_AbstractListType*vTablePtr); +/* 684 */ +EXTERN Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr); +/* 685 */ +EXTERN int Tcl_AbstractListObjIndex(Tcl_Interp *interp, + Tcl_Obj *abstractListPtr, Tcl_WideInt index, + Tcl_Obj **elemObjPtr); +/* 686 */ +EXTERN int Tcl_AbstractListObjRange(Tcl_Interp *interp, + Tcl_Obj *abstractListPtr, + Tcl_WideInt fromIdx, Tcl_WideInt toIdx, + Tcl_Obj **newObjPtr); +/* 687 */ +EXTERN int Tcl_AbstractListObjReverse(Tcl_Interp *interp, + Tcl_Obj *abstractListPtr, + Tcl_Obj **newObjPtr); +/* 688 */ +EXTERN int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *objcPtr, + Tcl_Obj ***objvPtr); +/* 689 */ +EXTERN Tcl_Obj * Tcl_AbstractListObjCopy(Tcl_Interp *interp, + Tcl_Obj *listPtr); +/* 690 */ +EXTERN void * Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr); +/* 691 */ +EXTERN Tcl_Obj * Tcl_AbstractListSetElement(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Obj *indicies, + Tcl_Obj *valueObj); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2737,6 +2768,15 @@ typedef struct TclStubs { int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ + Tcl_Obj * (*tcl_AbstractListObjNew) (Tcl_Interp *interp, const Tcl_AbstractListType*vTablePtr); /* 683 */ + Tcl_WideInt (*tcl_AbstractListObjLength) (Tcl_Obj *abstractListPtr); /* 684 */ + int (*tcl_AbstractListObjIndex) (Tcl_Interp *interp, Tcl_Obj *abstractListPtr, Tcl_WideInt index, Tcl_Obj **elemObjPtr); /* 685 */ + int (*tcl_AbstractListObjRange) (Tcl_Interp *interp, Tcl_Obj *abstractListPtr, Tcl_WideInt fromIdx, Tcl_WideInt toIdx, Tcl_Obj **newObjPtr); /* 686 */ + int (*tcl_AbstractListObjReverse) (Tcl_Interp *interp, Tcl_Obj *abstractListPtr, Tcl_Obj **newObjPtr); /* 687 */ + int (*tcl_AbstractListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 688 */ + Tcl_Obj * (*tcl_AbstractListObjCopy) (Tcl_Interp *interp, Tcl_Obj *listPtr); /* 689 */ + void * (*tcl_AbstractListGetConcreteRep) (Tcl_Obj *objPtr); /* 690 */ + Tcl_Obj * (*tcl_AbstractListSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indicies, Tcl_Obj *valueObj); /* 691 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4133,6 +4173,24 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNumber) /* 681 */ #define Tcl_RemoveChannelMode \ (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */ +#define Tcl_AbstractListObjNew \ + (tclStubsPtr->tcl_AbstractListObjNew) /* 683 */ +#define Tcl_AbstractListObjLength \ + (tclStubsPtr->tcl_AbstractListObjLength) /* 684 */ +#define Tcl_AbstractListObjIndex \ + (tclStubsPtr->tcl_AbstractListObjIndex) /* 685 */ +#define Tcl_AbstractListObjRange \ + (tclStubsPtr->tcl_AbstractListObjRange) /* 686 */ +#define Tcl_AbstractListObjReverse \ + (tclStubsPtr->tcl_AbstractListObjReverse) /* 687 */ +#define Tcl_AbstractListObjGetElements \ + (tclStubsPtr->tcl_AbstractListObjGetElements) /* 688 */ +#define Tcl_AbstractListObjCopy \ + (tclStubsPtr->tcl_AbstractListObjCopy) /* 689 */ +#define Tcl_AbstractListGetConcreteRep \ + (tclStubsPtr->tcl_AbstractListGetConcreteRep) /* 690 */ +#define Tcl_AbstractListSetElement \ + (tclStubsPtr->tcl_AbstractListSetElement) /* 691 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 408032b..795b48d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -19,7 +19,7 @@ #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" -#include "tclArithSeries.h" +#include "tclAbstractList.h" #include <math.h> #include <assert.h> @@ -4867,16 +4867,15 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - length = TclArithSeriesObjLength(valuePtr); + /* special case for AbstractList */ + if (TclHasInternalRep(valuePtr,&tclAbstractListType)) { + length = Tcl_AbstractListObjLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + if (Tcl_AbstractListObjIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -4931,33 +4930,30 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - length = TclArithSeriesObjLength(valuePtr); + /* + * Get the contents of the list, making sure that it really is a list + * in the process. + */ - /* Decode end-offset index values. */ + /* special case for AbstractList */ + if (TclHasInternalRep(valuePtr,&tclAbstractListType)) { + length = Tcl_AbstractListObjLength(valuePtr); + /* Decode end-offset index values. */ index = TclIndexDecode(opnd, length-1); /* Compute value @ index */ - if (index >= 0 && index < length) { - if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - } else { - TclNewObj(objResultPtr); + if (Tcl_AbstractListObjIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; } + pcAdjustment = 5; goto lindexFastPath2; } - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - + /* List case */ if (TclListObjGetElementsM(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -5152,9 +5148,8 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); - if (objResultPtr == NULL) { + if (TclHasInternalRep(valuePtr,&tclAbstractListType)) { + if (Tcl_AbstractListObjRange(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5180,14 +5175,18 @@ TEBCresume( if (length > 0) { int i = 0; Tcl_Obj *o; - int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); + int isAbstractList = TclHasInternalRep(value2Ptr,&tclAbstractListType); + /* * An empty list doesn't match anything. */ do { - if (isArithSeries) { - TclArithSeriesObjIndex(value2Ptr, i, &o); + if (isAbstractList) { + if (Tcl_AbstractListObjIndex(interp, value2Ptr, i, &o) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } } else { Tcl_ListObjIndex(NULL, value2Ptr, i, &o); } @@ -5200,7 +5199,7 @@ TEBCresume( if (s1len == s2len) { match = (memcmp(s1, s2, s1len) == 0); } - if (isArithSeries) { + if (isAbstractList) { TclDecrRefCount(o); } i++; diff --git a/generic/tclInt.h b/generic/tclInt.h index 0092322..d2ad1af 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2643,6 +2643,47 @@ typedef struct ListRep { #define TclListObjIsCanonical(listObj_) \ (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0) + +#define AbstractListGetType(abstractListObjPtr) \ + (Tcl_AbstractListType *) ((abstractListObjPtr)->internalRep.twoPtrValue.ptr1) + +static inline Tcl_WideInt +AbstractListObjLength(Tcl_Obj* abstractListObjPtr) +{ + Tcl_AbstractListType *typePtr = + (Tcl_AbstractListType *) abstractListObjPtr->internalRep.twoPtrValue.ptr1; + return typePtr->lengthProc(abstractListObjPtr); +} + +static inline int +TclAbstractListHasProc(Tcl_Obj* abstractListObjPtr, Tcl_AbstractListProcType ptype) +{ + Tcl_AbstractListType *typePtr = AbstractListGetType(abstractListObjPtr); + switch (ptype) { + case TCL_ABSL_NEW: + return (typePtr->newObjProc != NULL); + case TCL_ABSL_DUPREP: + return (typePtr->dupRepProc != NULL); + case TCL_ABSL_LENGTH: + return (typePtr->lengthProc != NULL); + case TCL_ABSL_INDEX: + return (typePtr->indexProc != NULL); + case TCL_ABSL_SLICE: + return (typePtr->sliceProc != NULL); + case TCL_ABSL_REVERSE: + return (typePtr->reverseProc != NULL); + case TCL_ABSL_GETELEMENTS: + return (typePtr->getElementsProc != NULL); + case TCL_ABSL_FREEREP: + return (typePtr->freeRepProc != NULL); + case TCL_ABSL_TOSTRING: + return (typePtr->toStringProc != NULL); + case TCL_ABSL_SETELEMENT: + return (typePtr->setElementProc != NULL); + } + return 0; +} + /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, * TclNRLmapCmd and their compilations. @@ -2909,8 +2950,8 @@ MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; -MODULE_SCOPE const Tcl_ObjType tclArithSeriesType; MODULE_SCOPE const Tcl_ObjType tclDictType; +MODULE_SCOPE const Tcl_ObjType tclAbstractListType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclUniCharStringType; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 78eb8a7..5fe3819 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -9,9 +9,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include "tclAbstractList.h" #include <assert.h> #include "tclInt.h" -#include "tclArithSeries.h" /* * TODO - memmove is fast. Measure at what size we should prefer memmove @@ -1369,8 +1369,8 @@ TclListObjCopy( Tcl_Obj *copyObj; if (!TclHasInternalRep(listObj, &tclListType)) { - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - return TclArithSeriesObjCopy(interp, listObj); + if (TclHasInternalRep(listObj,&tclAbstractListType)) { + return Tcl_AbstractListObjCopy(interp, listObj); } if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; @@ -1667,12 +1667,20 @@ Tcl_ListObjGetElements( { ListRep listRep; - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { - return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr); + if (TclHasInternalRep(objPtr,&tclAbstractListType) && + TclAbstractListHasProc(objPtr, TCL_ABSL_GETELEMENTS) && + Tcl_AbstractListObjGetElements(interp, objPtr, objcPtr, objvPtr) == TCL_OK) { + return TCL_OK; + } else if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { + int length; + (void) Tcl_GetStringFromObj(objPtr, &length); + if (length == 0) { + *objcPtr = 0; + *objvPtr = NULL; + return TCL_OK; + } + return TCL_ERROR; } - - if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) - return TCL_ERROR; ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; } @@ -1997,8 +2005,10 @@ Tcl_ListObjLength( { ListRep listRep; - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - *lenPtr = TclArithSeriesObjLength(listObj); + /* Handle AbstractList before attempting SetListFromAny */ + if (!TclHasInternalRep(listObj, &tclListType) && + TclHasInternalRep(listObj, &tclAbstractListType)) { + *lenPtr = Tcl_AbstractListObjLength(listObj); return TCL_OK; } @@ -2629,9 +2639,9 @@ TclLindexFlat( { ListSizeT i; - /* Handle ArithSeries as special case */ - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); + /* Handle AbstractList as special case */ + if (TclHasInternalRep(listObj,&tclAbstractListType)) { + Tcl_WideInt listLen = Tcl_AbstractListObjLength(listObj); ListSizeT index; Tcl_Obj *elemObj = NULL; for (i=0 ; i<indexCount && listObj ; i++) { @@ -2639,15 +2649,18 @@ TclLindexFlat( &index) == TCL_OK) { } if (i==0) { - TclArithSeriesObjIndex(listObj, index, &elemObj); + if (Tcl_AbstractListObjIndex(interp, listObj, index, &elemObj) != TCL_OK) { + return NULL; + } } else if (index > 0) { - /* ArithSeries cannot be a list of lists */ + // TODO: support nested lists + // For now, only support 1 index, which is all an ArithSeries has Tcl_DecrRefCount(elemObj); TclNewObj(elemObj); - Tcl_IncrRefCount(elemObj); break; } } + Tcl_IncrRefCount(elemObj); return elemObj; } @@ -2748,12 +2761,22 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (!TclHasInternalRep(indexArgObj, &tclListType) - && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) - == TCL_OK) { + if (!TclHasInternalRep(indexArgObj, &tclListType) && + TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) + == TCL_OK) { + + if (TclHasInternalRep(listObj,&tclAbstractListType) && + TclAbstractListHasProc(listObj, TCL_ABSL_SETELEMENT)) { + Tcl_Obj *returnValue = + Tcl_AbstractListSetElement(interp, listObj, indexArgObj, valueObj); + if (returnValue) Tcl_IncrRefCount(returnValue); + return returnValue; + } + /* indexArgPtr designates a single index. */ - /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ + /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); + } indexListCopy = TclListObjCopy(NULL, indexArgObj); @@ -3278,33 +3301,32 @@ SetListFromAny( Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } - } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { - /* - * Convertion from Arithmetic Series is a special case - * because it can be done an order of magnitude faster - * and may occur frequently. - */ - ListSizeT j, size = TclArithSeriesObjLength(objPtr); + } else if (TclHasInternalRep(objPtr,&tclAbstractListType)) { + ListSizeT elemCount, i; - /* TODO - leave space in front and/or back? */ - if (ListRepInitAttempt( - interp, size > 0 ? size : 1, NULL, &listRep) - != TCL_OK) { + elemCount = Tcl_AbstractListObjLength(objPtr); + + if (ListRepInitAttempt(interp, elemCount, NULL, &listRep) != TCL_OK) { return TCL_ERROR; } LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ LIST_ASSERT(listRep.storePtr->firstUsed == 0); - LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0); - listRep.storePtr->numUsed = size; elemPtrs = listRep.storePtr->slots; - for (j = 0; j < size; j++) { - if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) { - return TCL_ERROR; - } + + /* Each iteration, store a list element */ + for (i = 0; i < elemCount; i++) { + if (Tcl_AbstractListObjIndex(interp, objPtr, i, elemPtrs) != TCL_OK) { + return TCL_ERROR; + } + Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } + LIST_ASSERT((elemPtrs - listRep.storePtr->slots) == elemCount); + + listRep.storePtr->numUsed = elemCount; + } else { ListSizeT estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); diff --git a/generic/tclObj.c b/generic/tclObj.c index 4a660b2..c0d13f7 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -16,6 +16,7 @@ #include "tclInt.h" #include "tclTomMath.h" +#include "tclAbstractList.h" #include <math.h> #include <assert.h> @@ -406,6 +407,8 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&oldBooleanType); #endif + Tcl_RegisterObjType(&tclAbstractListType); + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; @@ -4857,12 +4860,19 @@ Tcl_RepresentationCmd( Tcl_Obj *const objv[]) { Tcl_Obj *descObj; - + const char *typeName; + if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "value"); return TCL_ERROR; } + typeName = (TclHasInternalRep(objv[1],&tclAbstractListType) + ? Tcl_AbstractListTypeName(objv[1]) + : (objv[1]->typePtr + ? objv[1]->typePtr->name + : "pure string")); + /* * Value is a bignum with a refcount of 14, object pointer at 0x12345678, * internal representation 0x45671234:0x98765432, string representation @@ -4871,7 +4881,7 @@ Tcl_RepresentationCmd( descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," " object pointer at %p", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->typePtr ? typeName : "pure string", objv[1]->refCount, objv[1]); if (objv[1]->typePtr) { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e6f6b5c..cc17e4b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2048,6 +2048,15 @@ const TclStubs tclStubs = { Tcl_GetNumberFromObj, /* 680 */ Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ + Tcl_AbstractListObjNew, /* 683 */ + Tcl_AbstractListObjLength, /* 684 */ + Tcl_AbstractListObjIndex, /* 685 */ + Tcl_AbstractListObjRange, /* 686 */ + Tcl_AbstractListObjReverse, /* 687 */ + Tcl_AbstractListObjGetElements, /* 688 */ + Tcl_AbstractListObjCopy, /* 689 */ + Tcl_AbstractListGetConcreteRep, /* 690 */ + Tcl_AbstractListSetElement, /* 691 */ }; /* !END!: Do not edit above this line. */ |