diff options
32 files changed, 3733 insertions, 842 deletions
diff --git a/doc/AbstractListObj.3 b/doc/AbstractListObj.3 new file mode 100644 index 0000000..ff3329c --- /dev/null +++ b/doc/AbstractListObj.3 @@ -0,0 +1,319 @@ +'\" +'\" Copyright (c) 2022 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. +'\" +.TH Tcl_AbstractListType 3 8.7 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_AbstractListObjNew, +Tcl_AbsstractListObjCopy, +Tcl_AbstractListGetConcreteRep, +Tcl_AbstractListGetElements, +Tcl_AbstractListGetType, +Tcl_AbstractListObjIndex, +Tcl_AbstractListObjLength, +Tcl_AbstractListObjRange, +Tcl_AbstractListObjReverse, +Tcl_AbstractListSetConcreteRep, +\- manipulate Tcl values as abstract lists. +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +Tcl_Obj * +\fBTcl_AbstractListObjNew\fR(\fIinterp, abstractListType\fR) +Tcl_AbstractListType * +\fBTcl_AbstractListGetType\fR(\fIlistPtr\fR) +void +\fBTcl_AbstractListSetConcreteRep\fR(\fIlistPtr, repPtr\fR) +void * +\fBTcl_AbstractListGetConcreteRep\fR(\fIlistPtr\fR) +Tcl_WideInt +\fBTcl_AbstractListObjLength\fR(\fIlistPtr\fR) +int +\fBTcl_AbstractListObjIndex\fR(\fIinterp\fR, \fIlistPtr, index\fR, \fIelemObjPtr*\fR) +int +\fBTcl_AbstractListObjRange\fR(\fIinterp\fR, \fIlistPtr, fromIdx, toIdx\fR, \fInewObjPtr\fR) +int +\fBTcl_AbstractListObjReverse(\fIinterp\fR, \fIlistPtr\fR, \fInewObjPtr\fR) +int +\fBTcl_AbstraceListObjGetElements\fR(\fIinterp\fR, \fIlistPtr\fR, \fIobjcPtr\fR, \fIobjvPtr\fR) +Tcl_Obj * +\fBTcl_AbstractListObjCopy\fR(\fIinterp\fR, \fIlistPtr\fR); +typedef Tcl_Obj* (Tcl_ALNewObjProc) (int objc, Tcl_Obj * const objv[]); +typedef void (Tcl_ALDupRepProc) (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +typedef Tcl_WideInt (Tcl_ALLengthProc) (Tcl_Obj *listPtr); +typedef int (Tcl_ALIndexProc) (Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_WideInt index, Tcl_Obj** elemObj); +typedef int (Tcl_ALSliceProc) (Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_WideInt fromIdx, Tcl_WideInt toIdx, + Tcl_Obj **newObjPtr); +typedef int (Tcl_ALReverseProc) (Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj **newObjPtr); +typedef int (Tcl_ALGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, + int *objcptr, Tcl_Obj ***objvptr); +typedef void (Tcl_ALFreeConcreteRep) (Tcl_Obj *listPtr); +typedef void (Tcl_ALToStringRep) (Tcl_Obj *listPtr); +.SH ARGUMENTS +.AS +.AP Tcl_Interp *interp in +If an error occurs while converting a value to be a list value, +an error message is left in the interpreter's result value +unless \fIinterp\fR is NULL. +.AP Tcl_AbstractListType *abstractListType in +This structure defines the behavior for the \fBAbstractList\fR for a +given concrete \fBAbstractList\fR type. The struct provides the name +plus a collection of functions that implement the various List +operations on the AbstractType value. \fBTcl_AbstractListObjNew\fR +call creates a new Tcl_Obj based on a preinitilized AbstractList +struct. +.AP Tcl_Obj *listPtr in/out +A Tcl_Obj of type AbstractList. Use to read or modify the type or +value content an AbstractList type. +.AP void *repPtr in +A reference to the concrete type representation storage. Specific +concrete types allocate and use this space to store whatever details +of value are needed. +.AP Tcl_WideInt index in +Index of the list element that \fBTcl_AbstractListObjIndex\fR +is to return. +The first element has index 0. +.AP Tcl_Obj **elemObjPtr +A location where the returned reference to an element Obj is to be +stored. +.AP Tcl_WideInt fromIdx in +The starting index of the list element for the slice that +\fBTcl_AbstractListObjRange\fR is to return. +.AP Tcl_WideInt toIdx in +The ending index of the list element for the slice that +\fBTcl_AbstractListObjRange\fR is to return. +.AP Tcl_Obj **newObjPtr in +A location where the new slice or reversed Obj reference is to be +stored. +.AP (Tcl_ALNewObjProc) in +Function pointer for a function used to create new instances of the +custom AbstractList listPtr. +.AP (Tcl_ALDupRepProc) in +Function pointer for a function used to duplicate (make a copy) of the +custom AbstractList listPtr. +.AP (Tcl_ALLengthProc) in +Function pointer for a function used to return the length of the +custom AbstractList. +.AP (Tcl_ALIndexProc) in +Function pointer for a function used to return an element listPtr for +the given index value. +.AP (Tcl_ALSliceProc) in +Function pointer for a function used to create a new slice from an +existing AbstractList. +.AP (Tcl_ALReverseProc) in +Function pointer for a function used to create a new AbstractList with +the element order reversed. +.BE + +.SH DESCRIPTION +.PP +The AbstractList type provides an interface for creating new List type +representations. An AbstractList behaves like a List when using script +level list commands. How the values are stored or produced is up to +the implementation. A simple example of an AbstractList is the [lseq] +command which produces a list of numeric values in sequence. The +underlying implementation does not store a list of numeric values. +Instead, it produces values on demand based on the index using an +arithmetic expression: "value = start + (step * index)". +.PP +An AbstractList is created by defining an internal storage +representation for the list along with a set of functions that manage +and manipulate the list value(s). These functions provide +"List" like results from the List family of commands. + +.SH ABSTRACTLIST C API +.PP +\fBTcl_AbstractListObjNew\fR returns a new Tcl_Obj based on the +concrete type definition given. The caller must then complete the +initialization of the Obj by setting the concrete represtation. (see +\fBTcl_AbstractListSetConcreteRep\fR()) + +\fBTcl_AbstractListGetType\fR returns the Tcl_AbstractList struct for +the given Obj. This function is used internally to access the +implementation functions. It can also be used in a specific +implementation to confirm that the Obj is of the expected AbstractList +type. + +\fBTcl_AbstractListSetConcreteRep\fR is called when creating an +instance of an AbstractList. It stores the repPtr, to the allocated +value Representation, in the Tcl_Obj. + +\fBTcl_AbstractListGetConcreteRep\fR returns the previously stored +repPtr for a given Obj value. + +\fBTcl_AbstractListObjLength\fR returns the list length, i.e., number +of elements in the given AbstractList. This function is typically used +internally by when evaluating various List operations. It would not +typically be used by an AbstractList concrete implementaion since the +internal representation is readily available within the +implementation, presumably. + +\fBTcl_AbstractListObjIndex\fR returns the element Tcl_Obj for a given +index location. + +\fBTcl_AbstractListObjRange\fR returns a new Obj value constructed +from a slice of the original AbstractList value, ranging from +\fIfromIdx\fR to the \fItoIdx\fR. If this function is not provided, +the default behavior will be to construct a traditional List using the +Index function. + +\fBTcl_AbstractListObjReverse\fR returns a new Obj value constructed by +reversing the index order. If this function is not provided, the +default behavior will be to construct a traditional List using the +Index function. + +\fBTcl_AbstraceListObjGetElements\fR returns an objv array containing +all elements of the AbstractList. (*** need words about memory +ownership ***) + +\fBTcl_AbstractListObjCopy\fR returns a duplicate Obj from the original. + +.SH ABSTRACTLIST IMPLEMENTATION FUNCTIONS +The following functions are to be defined by a specific implementation +to provide full or parcial List compatible behavior. The Length and +Index functions are required, and the rest are optional. +Unimplemented functions will either use a default implementation that +relies on Length and Index functions, or, the AbstractList will +"shimmer" into a formal List value. +.PP +.CS +typedef Tcl_Obj* (Tcl_ALNewObjProc) (int objc, Tcl_Obj * const objv[]); +typedef void (Tcl_ALDupRepProc) (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +typedef Tcl_WideInt (Tcl_ALLengthProc) (Tcl_Obj *listPtr); +typedef int (Tcl_ALIndexProc) (Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_WideInt index, Tcl_Obj** elemObj); +typedef int (Tcl_ALSliceProc) (Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_WideInt fromIdx, Tcl_WideInt toIdx, + Tcl_Obj **newObjPtr); +typedef int (Tcl_ALReverseProc) (Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj **newObjPtr); +typedef int (Tcl_ALGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, + int *objcptr, Tcl_Obj ***objvptr); +typedef void (Tcl_ALFreeConcreteRep) (Tcl_Obj *listPtr); +typedef void (Tcl_ALToStringRep) (Tcl_Obj *listPtr); +.CE +.PP +.SH AbstractList Example +.PP +\fBTcl_AbstractListObjNew\fR is used to create an object with a custom +List representation. +.PP +.CS +/* +** Define the AbstractList type callbacks +*/ +static \fBTcl_AbstractListType\fR arithSeriesType = { + TCL_ABSTRACTLIST_VERSION_1, + "arithseries", + Tcl_NewArithSeriesObj, + DupArithSeriesRep, + TclArithSeriesObjLength, + TclArithSeriesObjIndex, + TclArithSeriesObjRange, + TclArithSeriesObjReverse, + TclArithSeriesGetElements, + FreeArithSeriesRep, + UpdateStringOfArithSeries +}; +.CE +.PP +The Index and Length procs must be defined. The others are optional. +If an optional proc is not defined, it may use a default routine that +makes use of Length and Index, or the value will be converted to a +List, and then the operation will proceed normally, and note: this +will permanently change the value representation to a \fBList\fR +representation. +.PP +.CS +/* +** Define the concrete representation for the ArithSeries type +*/ +typedef struct ArithSeries { + int start, + int end, + int step, + int length +} ArithSeries; + +/* +** Allocate and initialize the concrete repdresentation. +*/ +arithSeriesRepPtr = (ArithSeries*)\fBTcl_Alloc\fR(sizeof (ArithSeries)); +arithSeriesRepPtr->isDouble = 0; +arithSeriesRepPtr->start = 0; +arithSeriesRepPtr->end = 15; +arithSeriesRepPtr->step = 1; +arithSeriesRepPtr->len = 15; +arithSeriesRepPtr->elements = NULL; + +/* +** Create an instance Tcl_Obj +*/ +\fBTcl_Obj\fR *arithObj = \fBTcl_AbstractListObjNew\fR(interp, &arithSeriesType); + +/* +** Set the concrete value for the Obj. +*/ +\fBTcl_AbstractListSetConcreteRep\fR(arithObj, arithSeriesRepPtr); + +return arithObj; +.CE +.PP +If any List operation is used to modify the AbstractList, for example +[lset $abstraceList 3 17], it will first be converted to a List before +completing the change. +.PP +.CS +/* Example functions */ +Tcl_Obj* +ArithSeriesObjIndex(Tcl_Obj *arithSeriesObjPtr, Tcl_WideInt index) +{ + ArithSeries *arithSeriesRepPtr; + Tcl_WideInt element; + if (arithSeriesObjPtr->typePtr != &tclAbstractListType) { + Tcl_Panic("ArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObjPtr); + + if (index < 0 || index >= arithSeriesRepPtr->length) { + return NULL; + } + + /* List[i] = Start + (Step * i) */ + element = (arithSeriesRepPtr->start + (index) * arithSeriesRepPtr->step); + + return Tcl_NewWideIntObj(element); +} + +Tcl_WideInt ArithSeriesObjLength(Tcl_Obj *arithSeriesObjPtr) +{ + ArithSeries *arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObjPtr); + return arithSeriesRepPtr->length; +} + +.CE +.PP +The functions \fBTcl_AbstractListObjLength\fR, +\fBTcl_AbstractListObjIndex\fR, \fBTcl_AbstractListObjRange\fR, and +\fBTcl_AbstractListObjReverse\fR can be used to interact with a known +AbstatractList Tcl_Obj value, as well as \fBTcl_ListObjLength\fR, +\fBTcl_ListObjIndex\fR, without causing the obj value to converted to +a \fBList\fR. Tcl_ListObjGetElements can also be used on an +AbstractList, just note that this call may result in new element +objects being created for every element in the abstract list. Since +an abstract list can be arbitrarily large and not consume space, this +call may have undesired consequences. +.PP +.SH "SEE ALSO" +Tcl_NewListObj(3), Tcl_NewObj(3), Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_GetObjResult(3) +.SH KEYWORDS +index, internal representation, length, list, list value, +list type, value, value type, replace, string representation @@ -21,15 +21,36 @@ lseq \- Build a numeric sequence returned as a list .PP The \fBlseq\fR command creates a sequence of numeric values using the given parameters \fIStart\fR, \fIEnd\fR, and \fIStep\fR. The \fIoperation\fR -argument ".." or "to" defines an inclusive range. The "count" option is used -to define a count of the number of elements in the list. The short form with a -single count value will create a range from 0 to count-1. +argument ".." or "to" defines the range. The "count" option is used +to define a count of the number of elements in the list. A short form use of +the command, with a +single count value, will create a range from 0 to count-1. + +The \fBlseq\fR command can produce both increasing and decreasing sequences. When +both Start and End are provided without a Step value, then if Start <= End, +the sequence will be increasing and if Start > End it will be decreasing. If a +Step vale is included, it's sign should agree with the direction of the +sequence (descending -> negative and ascending -> positive), otherwise an +empty list is returned. For example: + +.CS \" + % lseq 1 to 5 ;# increasing + 1 2 3 4 5 + + % lseq 5 to 1 ;# decreasing + 5 4 3 2 1 + + % lseq 6 to 1 by 2 ;# decreasing, step wrong sign, empty list + + % lseq 1 to 5 by 0 ;# all step sizes of 0 produce an empty list + +.\" +.CE The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR, -can also be a valid expression. the lseq command will evaluate the expression -and use the numeric result, or return an error as with any invalid argument -value. A valid expression is a valid [expr] expression, however, the result -must be numeric; a non-numeric string will result in an error. +may also be a valid expression. The expression will be evaluate and the +numeric result be used. An expression that does not evaluate to a number will +produce an invalid argument error. .SH EXAMPLES .CS @@ -67,22 +88,13 @@ must be numeric; a non-numeric string will result in an error. l(1)=-1 l(0)=0 - set i 17 - \(-> 17 - if {$i in [lseq 0 50]} { # equivalent to: (0 <= $i && $i < 50) - puts "Ok" - } else { - puts "outside :(" - } - \(-> Ok - set sqrs [lmap i [lseq 1 10] {expr $i*$i}] \(-> 1 4 9 16 25 36 49 64 81 100 .\" .CE .SH "SEE ALSO" -foreach(n), list(n), lappend(n), lassign(n), ledit(n), lindex(n), linsert(n), -llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), +foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), +lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n), lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS element, index, list diff --git a/generic/tcl.h b/generic/tcl.h index 946d7b9..860c506 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -602,6 +602,28 @@ typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); +/* Abstract List functions */ +typedef Tcl_Size (Tcl_ALLengthProc) (struct Tcl_Obj *listPtr); +typedef int (Tcl_ALIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size index, struct Tcl_Obj** elemObj); +typedef int (Tcl_ALSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size fromIdx, Tcl_Size 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, + Tcl_Size *objcptr, struct Tcl_Obj ***objvptr); +typedef struct Tcl_Obj* (Tcl_ALSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, + Tcl_Size indexCount, + struct Tcl_Obj *const indexArray[], + struct Tcl_Obj *valueObj); +typedef int (Tcl_ALReplaceProc) (Tcl_Interp *interp, struct Tcl_Obj *listObj, + Tcl_Size first, Tcl_Size numToDelete, + Tcl_Size numToInsert, + struct Tcl_Obj *const insertObjs[]); +typedef int (Tcl_ALGetDblProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr, + double *doublePtr); + #ifndef TCL_NO_DEPRECATED # define Tcl_PackageInitProc Tcl_LibraryInitProc # define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc @@ -631,11 +653,39 @@ typedef struct Tcl_ObjType { * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ size_t version; + + /* List emulation functions - ObjType Version 1 */ + Tcl_ALLengthProc *lengthProc; /* Return the [llength] of the + ** AbstractList */ + void *reserved; + 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_ALSetElement *setElementProc; /* Replace the element at the indicie + ** with the given valueObj. */ + Tcl_ALReplaceProc *replaceProc; /* Replace subset with subset */ + Tcl_ALGetDblProc *getDoubleProc; /* GetDouble from internal rep */ } Tcl_ObjType; -#define TCL_OBJTYPE_V0 0 /* Pre-Tcl 9. Set to 0 so compiler will auto-init - * when existing code that does not init this - * field is compiled with Tcl9 headers */ -#define TCL_OBJTYPE_CURRENT TCL_OBJTYPE_V0 + +#define TCL_OBJTYPE_V0 0, /* Pre-Tcl 9 */ \ + NULL, \ + NULL, \ + NULL, \ + NULL, \ + NULL, \ + NULL, \ + NULL, \ + NULL, \ + NULL +#define TCL_OBJTYPE_CURRENT sizeof(Tcl_ObjType) +#define TCL_OBJTYPE_V1(a,b,c,d,e,f,g,h,i) \ + TCL_OBJTYPE_CURRENT, \ + a,b,c,d,e,f,g,h,i /* Tcl 9 - AbstractLists */ /* * The following structure stores an internal representation (internalrep) for @@ -688,7 +738,6 @@ typedef struct Tcl_Obj { Tcl_ObjInternalRep internalRep; /* The internal representation: */ } Tcl_Obj; - /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first diff --git a/generic/tclAbstractList.c b/generic/tclAbstractList.c new file mode 100644 index 0000000..7c053da --- /dev/null +++ b/generic/tclAbstractList.c @@ -0,0 +1,747 @@ +/* + * 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); + Tcl_StoreInternalRep(objPtr, &tclAbstractListType, &itr); + Tcl_AbstractListSetType(objPtr, (void*)vTablePtr); /* dispatch table for concrete type */ + Tcl_AbstractListSetConcreteRep(objPtr, NULL); + 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_Size 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.ptr2 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.ptr2 = NULL; + abstractListObjPtr->internalRep.twoPtrValue.ptr1 = 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 = Tcl_AbstractListGetType(srcPtr); + Tcl_AbstractListSetType(copyPtr, typePtr); + Tcl_AbstractListSetConcreteRep(copyPtr, 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? */ + Tcl_AbstractListSetConcreteRep + (copyPtr, Tcl_AbstractListGetConcreteRep(srcPtr)); + } + + 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 = Tcl_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 *) Tcl_Alloc(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 *) Tcl_Alloc(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) { + Tcl_Free(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_Size fromIdx, /* Index of first element to include. */ + Tcl_Size 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, (Tcl_Size)fromIdx, (Tcl_Size)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. */ + Tcl_Size *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.ptr2; +} + +/* 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.ptr1; +} + +/* 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_Size indexCount, + Tcl_Obj *const indexArray[], + 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, indexCount, indexArray, 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; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AbstractListObjReplace -- + * + * This function mimics the Tcl_ListObjReplace operation, iff the + * concrete abstract list type supports the Replace operation, and if + * not, it will return with an error. + * + * This function replaces zero or more elements of the abstract list + * referenced by listObj with the objects from an (objc,objv) array. The + * objc elements of the array referenced by objv replace the count + * elements in listPtr starting at first. + * + * If the argument first is zero or negative, it refers to the first + * element. If first is greater than or equal to the number of elements + * in the list, then no elements are deleted; the new elements are + * appended to the list. Count gives the number of elements to replace. + * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before first. + * + * The argument objv refers to an array of objc pointers to the new + * elements to be added to listPtr in place of those that were deleted. + * If objv is NULL, no new elements are added. + * + * Results: + * The return value is normally TCL_OK. If listPtr does not support the + * Replace opration then TCL_ERROR is returned and an error message will + * be left in the interpreter's result if interp is not NULL. + * + * Side effects: + * The ref counts of the objc elements in objv maybe incremented iff the + * concrete type retains a reference to the element(s), otherwise there + * will be no change to the ref counts. Similarly, the ref counts for + * replaced objects are decremented. listObj's old string representation, + * if any, is freed. + * + *---------------------------------------------------------------------- + */ +int Tcl_AbstractListObjReplace( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* List object whose elements to replace. */ + Tcl_Size first, /* Index of first element to replace. */ + Tcl_Size numToDelete, /* Number of elements to replace. */ + Tcl_Size numToInsert, /* Number of objects to insert. */ + Tcl_Obj *const insertObjs[]) /* Tcl objects to insert */ +{ + int status; + if (TclHasInternalRep(objPtr,&tclAbstractListType)) { + Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr); + if (TclAbstractListHasProc(objPtr, TCL_ABSL_REPLACE)) { + status = typePtr->replaceProc(interp, objPtr, first, numToDelete, numToInsert, insertObjs); + } else { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("Replace not supported!", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + status = TCL_ERROR; + } + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an abstract list")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + status = TCL_ERROR; + } + return status; +} + +/* + * 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..1c19f9c --- /dev/null +++ b/generic/tclAbstractList.h @@ -0,0 +1,56 @@ +/* + * 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" + +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 *vTablePtr); +Tcl_WideInt Tcl_AbstractListObjLength(Tcl_Obj *abstractListPtr); +int Tcl_AbstractListObjIndex(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, + Tcl_Size index, Tcl_Obj **elemObj); +int Tcl_AbstractListObjRange(Tcl_Interp *interp, Tcl_Obj *abstractListPtr, + Tcl_Size fromIdx, Tcl_Size 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, Tcl_Size *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_Size indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valueObj); +int Tcl_AbstractListObjReplace(Tcl_Interp *interp, Tcl_Obj *listObj, + Tcl_Size first, Tcl_Size numToDelete, Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]); + +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 0232746..19fe864 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -11,40 +11,8 @@ */ #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.objType); \ - (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 *arithSeriesObj); -static Tcl_Obj *ArithSeriesObjStep(Tcl_Obj *arithSeriesPtr); -static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); - /* * The structure below defines the arithmetic series Tcl object type by * means of procedures that can be invoked by generic object code. @@ -72,15 +40,67 @@ static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); * are valid and will be equivalent to the empty list. */ -const TclObjTypeWithAbstractList tclArithSeriesType = { - {"arithseries", /* name */ +/* + * The structure used for the ArithSeries 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. + */ +typedef struct { + Tcl_Size len; + Tcl_Obj **elements; + int isDouble; + Tcl_WideInt start; + Tcl_WideInt end; + Tcl_WideInt step; +} ArithSeries; +typedef struct { + Tcl_Size len; + Tcl_Obj **elements; + int isDouble; + double start; + double end; + double step; +} ArithSeriesDbl; + +static inline double ArithSeriesIndexDbl(ArithSeriesDbl *repPtr, Tcl_Size index) +{ + return (repPtr->start + ((double)index * repPtr->step)); +} +static inline Tcl_WideInt ArithSeriesIndexInt(ArithSeries *repPtr, Tcl_Size index) +{ + return (repPtr->start + (index * repPtr->step)); +} + +static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); +static int TclArithSeriesObjIndex(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, + Tcl_Size index, Tcl_Obj **elemObj); +static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj); +static int TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, + Tcl_Size fromIdx, Tcl_Size toIdx, Tcl_Obj **newObjPtr); +static int TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr); +static int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); +static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr); +static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); +static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +static const Tcl_ObjType arithSeriesType = { + "arithseries", /* name */ FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ SetArithSeriesFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - ArithSeriesObjLength - )} + TCL_OBJTYPE_V1( + ArithSeriesObjLength, + NULL, + TclArithSeriesObjIndex, + TclArithSeriesObjRange, + TclArithSeriesObjReverse, + TclArithSeriesGetElements, + NULL, // SetElement + NULL, // Replace + NULL) // GetDouble }; /* @@ -117,6 +137,78 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) len = 1 + ((end-start)/step); return (len < 0) ? -1 : len; } + +/* + *---------------------------------------------------------------------- + * + * DupArithSeriesInternalRep -- + * + * 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 +DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) +{ + ArithSeries *srcArithSeries = (ArithSeries*)Tcl_ObjGetConcreteRep(srcPtr); + ArithSeries *copyArithSeries = (ArithSeries *)Tcl_Alloc(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_ObjInternalRep itr; + itr.twoPtrValue.ptr1 = copyArithSeries; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr); + if (copyArithSeries->len > 0) { + Tcl_InvalidateStringRep(copyPtr); + } else { + Tcl_InitStringRep(copyPtr, NULL, 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * FreeArithSeriesInternalRep -- + * + * Free any allocated memory in the ArithSeries Rep + * + * Results: + * None. + * + * Side effects: + * + *---------------------------------------------------------------------- + */ +static void +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */ +{ + ArithSeries *arithSeriesObj = (ArithSeries*)Tcl_ObjGetConcreteRep(arithSeriesObjPtr); + if (arithSeriesObj) { + if (arithSeriesObj->elements) { + Tcl_WideInt i, len = arithSeriesObj->len; + for (i=0; i<len; i++) { + Tcl_DecrRefCount(arithSeriesObj->elements[i]); + } + Tcl_Free((char*)arithSeriesObj->elements); + arithSeriesObj->elements = NULL; + } + Tcl_Free((char*)arithSeriesObj); + } +} + /* *---------------------------------------------------------------------- @@ -159,7 +251,7 @@ NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_Wide arithSeriesRepPtr->elements = NULL; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &tclArithSeriesType.objType; + arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) Tcl_InvalidateStringRep(arithSeriesObj); @@ -207,7 +299,7 @@ NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->elements = NULL; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &tclArithSeriesType.objType; + arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) Tcl_InvalidateStringRep(arithSeriesObj); @@ -373,53 +465,17 @@ TclNewArithSeriesObj( /* *---------------------------------------------------------------------- * - * ArithSeriesObjStep -- - * - * Return a Tcl_Obj with the step value from the give ArithSeries Obj. - * refcount = 0. - * - * Results: - * - * A Tcl_Obj pointer to the created ArithSeries object. - * A NULL pointer of the range is invalid. - * - * Side Effects: - * - * None. - *---------------------------------------------------------------------- - */ -Tcl_Obj * -ArithSeriesObjStep( - Tcl_Obj *arithSeriesObj) -{ - ArithSeries *arithSeriesRepPtr; - Tcl_Obj *stepObj; - - if (arithSeriesObj->typePtr != &tclArithSeriesType.objType) { - Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj); - if (arithSeriesRepPtr->isDouble) { - TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step); - } else { - TclNewIntObj(stepObj, arithSeriesRepPtr->step); - } - return stepObj; -} - - -/* - *---------------------------------------------------------------------- - * * TclArithSeriesObjIndex -- * * Returns the element with the specified index in the list * represented by the specified Arithmetic Sequence object. - * If the index is out of range, NULL is returned. + * 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: * - * The element on success, NULL on index out of range. + * TCL_OK on success, TCL_ERROR on index out of range. * * Side Effects: * @@ -428,33 +484,27 @@ ArithSeriesObjStep( *---------------------------------------------------------------------- */ -Tcl_Obj * +int TclArithSeriesObjIndex( - Tcl_Interp *interp, - Tcl_Obj *arithSeriesObj, - Tcl_WideInt index) + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *arithSeriesObj, /* List obj */ + Tcl_Size index, /* index to element of interest */ + Tcl_Obj **elemObj) /* Return value */ { - ArithSeries *arithSeriesRepPtr; - - if (arithSeriesObj->typePtr != &tclArithSeriesType.objType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj); - if (index < 0 || (Tcl_Size)index >= arithSeriesRepPtr->len) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("index %" TCL_LL_MODIFIER "d is out of bounds 0 to %" - TCL_Z_MODIFIER "d", index, (arithSeriesRepPtr->len-1))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + ArithSeries *arithSeriesRepPtr = (ArithSeries *)Tcl_ObjGetConcreteRep(arithSeriesObj); + (void)interp; // quiet compiler + if (index < arithSeriesRepPtr->len) { + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elemObj = Tcl_NewDoubleObj(ArithSeriesIndexDbl((ArithSeriesDbl*)arithSeriesRepPtr, index)); + } else { + *elemObj = Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); } - return NULL; - } - /* List[i] = Start + (Step * index) */ - if (arithSeriesRepPtr->isDouble) { - return Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); } else { - return Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + TclNewObj(*elemObj); // empty value } + + return TCL_OK; } /* @@ -480,146 +530,38 @@ Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj) arithSeriesObj->internalRep.twoPtrValue.ptr1; return arithSeriesRepPtr->len; } - -/* - *---------------------------------------------------------------------- - * - * FreeArithSeriesInternalRep -- - * - * Deallocate the storage associated with an arithseries object's - * internal representation. - * - * Results: - * None. - * - * Side effects: - * Frees arithSeriesObj's ArithSeries* internal representation and - * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. - * - *---------------------------------------------------------------------- - */ - -static void -FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObj) -{ - ArithSeries *arithSeriesRepPtr = - (ArithSeries *) arithSeriesObj->internalRep.twoPtrValue.ptr1; - if (arithSeriesRepPtr->elements) { - Tcl_Size i; - Tcl_Obj**elmts = arithSeriesRepPtr->elements; - for(i=0; i<arithSeriesRepPtr->len; i++) { - if (elmts[i]) { - Tcl_DecrRefCount(elmts[i]); - } - } - Tcl_Free((char *) arithSeriesRepPtr->elements); - } - Tcl_Free((char *) arithSeriesRepPtr); - arithSeriesObj->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*) Tcl_Alloc(sizeof(ArithSeries)); - *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; - copyArithSeriesRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclArithSeriesType.objType; -} - + /* *---------------------------------------------------------------------- * - * UpdateStringOfArithSeries -- + * TclArithSeriesObjStep -- * - * 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. + * Return a Tcl_Obj with the step value from the give ArithSeries Obj. + * refcount = 0. * * 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. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * - * 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. + * Side Effects: * + * None. *---------------------------------------------------------------------- */ -static void -UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObj) +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesObj, + Tcl_Obj **stepObj) { - ArithSeries *arithSeriesRepPtr = - (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1; - char *elem, *p; - Tcl_Obj *elemObj; - Tcl_Size i; - Tcl_WideInt length = 0; - size_t slen; - - /* - * Pass 1: estimate space. - */ - for (i = 0; i < arithSeriesRepPtr->len; i++) { - elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i); - elem = Tcl_GetStringFromObj(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(arithSeriesObj, NULL, length); - for (i = 0; i < arithSeriesRepPtr->len; i++) { - elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i); - elem = Tcl_GetStringFromObj(elemObj, &slen); - strcpy(p, elem); - p[slen] = ' '; - p += slen+1; - Tcl_DecrRefCount(elemObj); + ArithSeries *arithSeriesRepPtr = (ArithSeries *)Tcl_ObjGetConcreteRep(arithSeriesObj); + if (arithSeriesRepPtr->isDouble) { + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + } else { + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } - if (length > 0) arithSeriesObj->bytes[length-1] = '\0'; - arithSeriesObj->length = length-1; + return TCL_OK; } /* @@ -656,52 +598,6 @@ SetArithSeriesFromAny( /* *---------------------------------------------------------------------- * - * TclArithSeriesObjCopy -- - * - * 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. - * - * Results: - * - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * arithSeries value as *arithSeriesObj does. The returned Tcl_Obj has a - * refCount of zero. If *arithSeriesObj does not hold an arithSeries, - * NULL is returned, and if interp is non-NULL, an error message is - * recorded there. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclArithSeriesObjCopy( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *arithSeriesObj) /* List object for which an element array is - * to be returned. */ -{ - Tcl_Obj *copyPtr; - ArithSeries *arithSeriesRepPtr; - - ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr); - if (NULL == arithSeriesRepPtr) { - if (SetArithSeriesFromAny(interp, arithSeriesObj) != TCL_OK) { - /* We know this is going to panic, but it's the message we want */ - return NULL; - } - } - - TclNewObj(copyPtr); - TclInvalidateStringRep(copyPtr); - DupArithSeriesInternalRep(arithSeriesObj, copyPtr); - return copyPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclArithSeriesObjRange -- * * Makes a slice of an ArithSeries value. @@ -718,52 +614,51 @@ TclArithSeriesObjCopy( *---------------------------------------------------------------------- */ -Tcl_Obj * +int TclArithSeriesObjRange( Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */ Tcl_Size fromIdx, /* Index of first element to include. */ - Tcl_Size toIdx) /* Index of last element to include. */ + Tcl_Size toIdx, /* Index of last element to include. */ + Tcl_Obj **newObjPtr) /* return value */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; - ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr); + (void)interp; /* silence compiler */ + + arithSeriesRepPtr = (ArithSeries *)Tcl_ObjGetConcreteRep(arithSeriesObj); if (fromIdx == TCL_INDEX_NONE) { fromIdx = 0; } - if (fromIdx > toIdx) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + + if (toIdx >= arithSeriesRepPtr->len) { + toIdx = arithSeriesRepPtr->len-1; } - startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx); - if (startObj == NULL) { - return NULL; + if (fromIdx > toIdx || + fromIdx >= arithSeriesRepPtr->len) { + TclNewObj(*newObjPtr); + return TCL_OK; } + + TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); Tcl_IncrRefCount(startObj); - endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx); - if (endObj == NULL) { - return NULL; - } + TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); Tcl_IncrRefCount(endObj); - stepObj = ArithSeriesObjStep(arithSeriesObj); + TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) { - Tcl_Obj *newSlicePtr; - if (TclNewArithSeriesObj(interp, &newSlicePtr, - arithSeriesRepPtr->isDouble, startObj, endObj, - stepObj, NULL) != TCL_OK) { - newSlicePtr = NULL; - } + int status = TclNewArithSeriesObj(NULL, newObjPtr, + arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); + Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return newSlicePtr; + return status; } /* @@ -805,7 +700,8 @@ TclArithSeriesObjRange( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return arithSeriesObj; + *newObjPtr = arithSeriesObj; + return TCL_OK; } /* @@ -847,12 +743,13 @@ TclArithSeriesGetElements( Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) { + if (TclHasInternalRep(objPtr,&arithSeriesType)) { ArithSeries *arithSeriesRepPtr; Tcl_Obj **objv; int i, objc; - ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); + arithSeriesRepPtr = (ArithSeries *)Tcl_ObjGetConcreteRep(objPtr); + objc = arithSeriesRepPtr->len; if (objc > 0) { if (arithSeriesRepPtr->elements) { @@ -872,8 +769,8 @@ TclArithSeriesGetElements( } arithSeriesRepPtr->elements = objv; for (i = 0; i < objc; i++) { - objv[i] = TclArithSeriesObjIndex(interp, objPtr, i); - if (objv[i] == NULL) { + int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]); + if (status) { return TCL_ERROR; } Tcl_IncrRefCount(objv[i]); @@ -897,28 +794,14 @@ TclArithSeriesGetElements( } /* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjReverse -- - * - * Reverse the order of the ArithSeries value. - * *arithSeriesObj 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 *arithSeriesObj) /* List object to reverse. */ + Tcl_Obj *arithSeriesObj, /* List object to reverse. */ + Tcl_Obj **newObjPtr) { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; @@ -927,16 +810,22 @@ TclArithSeriesObjReverse( double dstart, dend, dstep; int isDouble; - ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr); + (void)interp; + + if (newObjPtr == NULL) { + return TCL_ERROR; + } + + arithSeriesRepPtr = (ArithSeries *)Tcl_ObjGetConcreteRep(arithSeriesObj); isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1)); + TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1), &startObj); Tcl_IncrRefCount(startObj); - endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0); + TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj); Tcl_IncrRefCount(endObj); - stepObj = ArithSeriesObjStep(arithSeriesObj); + TclArithSeriesObjStep(arithSeriesObj, &stepObj); Tcl_IncrRefCount(stepObj); if (isDouble) { @@ -953,12 +842,16 @@ TclArithSeriesObjReverse( TclSetIntObj(stepObj, step); } + Tcl_IncrRefCount(startObj); + Tcl_IncrRefCount(endObj); + Tcl_IncrRefCount(stepObj); + if (Tcl_IsShared(arithSeriesObj) || ((arithSeriesObj->refCount > 1))) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); - if (TclNewArithSeriesObj(interp, &resultObj, - isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { + if (TclNewArithSeriesObj(NULL, &resultObj, isDouble, + startObj, endObj, stepObj, lenObj) != TCL_OK) { resultObj = NULL; } Tcl_DecrRefCount(lenObj); @@ -997,7 +890,82 @@ TclArithSeriesObjReverse( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return resultObj; + *newObjPtr = resultObj; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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 *arithSeriesObjPtr) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*)Tcl_ObjGetConcreteRep(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; } /* diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h deleted file mode 100644 index f59720c..0000000 --- a/generic/tclArithSeries.h +++ /dev/null @@ -1,57 +0,0 @@ -/* - * tclArithSeries.h -- - * - * This file contains the ArithSeries concrete abstract list - * implementation. It implements the inner workings of the lseq command. - * - * Copyright © 2022 Brian S. Griffin. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -/* - * The structure used for the ArithSeries 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. - */ -typedef struct { - Tcl_Size len; - Tcl_Obj **elements; - int isDouble; - Tcl_WideInt start; - Tcl_WideInt end; - Tcl_WideInt step; -} ArithSeries; -typedef struct { - Tcl_Size len; - Tcl_Obj **elements; - int isDouble; - double start; - double end; - double step; -} ArithSeriesDbl; - - -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *, - Tcl_WideInt index); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); -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 9b1b5a5..4de1966 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7031,7 +7031,7 @@ ExprCeilFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7071,7 +7071,7 @@ ExprFloorFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7217,7 +7217,7 @@ ExprSqrtFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7271,7 +7271,7 @@ ExprUnaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { d = irPtr->doubleValue; @@ -7335,7 +7335,7 @@ ExprBinaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { d1 = irPtr->doubleValue; @@ -7350,7 +7350,7 @@ ExprBinaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { d2 = irPtr->doubleValue; @@ -7511,7 +7511,7 @@ ExprDoubleFunc( } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (TclHasInternalRep(objv[1], &tclDoubleType.objType)) { + if (TclHasInternalRep(objv[1], &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 1083533..45489cc 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2021,7 +2021,7 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); if (irPtr == NULL) { return TCL_ERROR; } @@ -2041,7 +2041,7 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); if (irPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclClock.c b/generic/tclClock.c index 1d33886..2647da5 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -433,7 +433,7 @@ ClockGetdatefieldsObjCmd( * that it isn't. */ - if (TclHasInternalRep(objv[1], &tclBignumType.objType)) { + if (TclHasInternalRep(objv[1], &tclBignumType)) { Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5dbadb8..8d0f43e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -17,7 +17,6 @@ #ifdef _WIN32 # include "tclWinInt.h" #endif -#include "tclArithSeries.h" /* * The state structure used by [foreach]. Note that the actual structure has @@ -2808,9 +2807,11 @@ EachloopCmd( &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ - if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType.objType)) { - /* Special case for Arith Series */ - statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (!TclHasInternalRep(objv[2+i*2], &tclListType) && + ABSTRACTLIST_PROC(objv[2+i*2],dupIntRepProc) && + ABSTRACTLIST_PROC(objv[2+i*2],indexProc)) { + /* Special case for AbstractList */ + statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; @@ -2818,14 +2819,13 @@ EachloopCmd( /* Don't compute values here, wait until the last moment */ statePtr->argcList[i] = ABSTRACTLIST_PROC(statePtr->aCopyList[i], lengthProc)(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]; @@ -2946,21 +2946,22 @@ ForeachAssignments( struct ForeachState *statePtr) { int i; - size_t v, k; + Tcl_Size v, k; Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType.objType); + int isAbstractList = + ABSTRACTLIST_PROC(statePtr->aCopyList[i],indexProc) != NULL; + for (v=0 ; v<statePtr->varcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { - if (isarithseries) { - valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k); - if (valuePtr == NULL) { + if (isAbstractList) { + if (Tcl_ObjTypeIndex(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 e1949a5..6a77c17 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -19,7 +19,6 @@ #include "tclInt.h" #include "tclRegexp.h" -#include "tclArithSeries.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> @@ -2202,7 +2201,7 @@ Tcl_JoinObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { size_t length, listLen; - int isArithSeries = 0; + int isAbstractList = 0; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2215,14 +2214,17 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) { - isArithSeries = 1; + if (ABSTRACTLIST_PROC(objv[1], getElementsProc)) { listLen = ABSTRACTLIST_PROC(objv[1], lengthProc)(objv[1]); - } else { - if (TclListObjGetElementsM(interp, objv[1], &listLen, - &elemPtrs) != TCL_OK) { + isAbstractList = (listLen ? 1 : 0); + if (listLen > 1 && + Tcl_ObjTypeGetElements(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) { @@ -2231,14 +2233,15 @@ Tcl_JoinObjCmd( } if (listLen == 1) { /* One element; return it */ - if (isArithSeries) { - Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0); - if (valueObj == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, valueObj); - } else { + if (!isAbstractList) { Tcl_SetObjResult(interp, elemPtrs[0]); + } else { + Tcl_Obj *elemObj; + if (Tcl_ObjTypeIndex(interp, objv[1], 0, &elemObj) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, elemObj); } return TCL_OK; } @@ -2253,41 +2256,19 @@ Tcl_JoinObjCmd( size_t i; resObjPtr = Tcl_NewObj(); - 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); - } - valueObj = TclArithSeriesObjIndex(interp, objv[1], i); - if (valueObj == NULL) { - return TCL_ERROR; - } - Tcl_AppendObjToObj(resObjPtr, 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); @@ -2749,11 +2730,11 @@ Tcl_LrangeObjCmd( return result; } - if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) { - Tcl_Obj *rangeObj; - rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); - if (rangeObj) { - Tcl_SetObjResult(interp, rangeObj); + if (ABSTRACTLIST_PROC(objv[1], sliceProc)) { + Tcl_Obj *resultObj; + int status = Tcl_ObjTypeSlice(interp, objv[1], first, last, &resultObj); + if (status == TCL_OK) { + Tcl_SetObjResult(interp, resultObj); } else { return TCL_ERROR; } @@ -3145,20 +3126,18 @@ Tcl_LreverseObjCmd( } /* - * 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.objType)) { - Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); - if (resObj) { - Tcl_SetObjResult(interp, resObj); + if (ABSTRACTLIST_PROC(objv[1], reverseProc)) { + Tcl_Obj *resultObj; + + if (Tcl_ObjTypeReverse(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 (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) { return TCL_ERROR; } @@ -3981,91 +3960,6 @@ Tcl_LsearchObjCmd( /* *---------------------------------------------------------------------- * - * 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(void *), - 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; -} - -/* - *---------------------------------------------------------------------- - * * SequenceIdentifyArgument -- * (for [lseq] command) * @@ -4203,7 +4097,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; @@ -4273,11 +4167,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]; @@ -4285,22 +4178,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) { @@ -4320,13 +4213,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) { @@ -4343,17 +4235,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]; @@ -4366,14 +4256,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]; @@ -4382,7 +4271,6 @@ Tcl_LseqObjCmd( step = numValues[4]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4398,7 +4286,6 @@ Tcl_LseqObjCmd( elementCount = numValues[2]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4412,7 +4299,6 @@ Tcl_LseqObjCmd( case 1212: opmode = (SequenceOperators)values[3]; goto KeywordError; break; KeywordError: - status = TCL_ERROR; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: @@ -4428,14 +4314,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; } @@ -4466,6 +4350,99 @@ 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 (objc == 4) { + finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); + } else { + if (ABSTRACTLIST_PROC(listPtr, setElementProc)) { + finalValuePtr = Tcl_ObjTypeSetElement(interp, listPtr, + objc-3, objv+2, objv[objc-1]); + if (finalValuePtr) { + Tcl_IncrRefCount(finalValuePtr); + } + } 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 @@ -4734,9 +4711,9 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { - sortInfo.resultCode = TclArithSeriesGetElements(interp, - listObj, &length, &listObjPtrs); + if (ABSTRACTLIST_PROC(objv[1], getElementsProc)) { + sortInfo.resultCode = + Tcl_ObjTypeGetElements(interp, listObj, &length, &listObjPtrs); } else { sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, &length, &listObjPtrs); diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 77c8cb4..4fffadc 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1612,7 +1612,7 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (!TclHasInternalRep(objPtr, &tclBooleanType.objType) + if (!TclHasInternalRep(objPtr, &tclBooleanType) && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; @@ -1682,9 +1682,9 @@ StringIsCmd( chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if (TclHasInternalRep(objPtr, &tclDoubleType.objType) || - TclHasInternalRep(objPtr, &tclIntType.objType) || - TclHasInternalRep(objPtr, &tclBignumType.objType)) { + if (TclHasInternalRep(objPtr, &tclDoubleType) || + TclHasInternalRep(objPtr, &tclIntType) || + TclHasInternalRep(objPtr, &tclBignumType)) { break; } string1 = Tcl_GetStringFromObj(objPtr, &length1); @@ -1713,8 +1713,8 @@ StringIsCmd( break; case STR_IS_INT: case STR_IS_ENTIER: - if (TclHasInternalRep(objPtr, &tclIntType.objType) || - TclHasInternalRep(objPtr, &tclBignumType.objType)) { + if (TclHasInternalRep(objPtr, &tclIntType) || + TclHasInternalRep(objPtr, &tclBignumType)) { break; } string1 = Tcl_GetStringFromObj(objPtr, &length1); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index c503304..8313134 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2111,7 +2111,7 @@ ParseLexeme( * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ - if (TclHasInternalRep(literal, &tclDoubleType.objType)) { + if (TclHasInternalRep(literal, &tclDoubleType)) { const char *p = start; while (p < end) { diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 5c18c8a..61c9737 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -61,6 +61,8 @@ static Tcl_ObjCmdProc DictForNRCmd; static Tcl_ObjCmdProc DictMapNRCmd; static Tcl_NRPostProc DictForLoopCallback; static Tcl_NRPostProc DictMapLoopCallback; +static Tcl_ALLengthProc DictAsListLength; +static Tcl_ALIndexProc DictAsListIndex; /* * Table of dict subcommand names and implementations. @@ -143,11 +145,23 @@ typedef struct Dict { const Tcl_ObjType tclDictType = { "dict", - FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ - UpdateStringOfDict, /* updateStringProc */ - SetDictFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + FreeDictInternalRep, /* freeIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ + UpdateStringOfDict, /* updateStringProc */ + SetDictFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V1( /* Extended type for AbstractLists */ + DictAsListLength, /* return "list" length of dict value w/o + * shimmering */ + NULL, + DictAsListIndex, /* return key or value at "list" index + * location. (keysare at even indicies, + * values at odd indicies) */ + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; #define DictSetInternalRep(objPtr, dictRepPtr) \ @@ -603,7 +617,7 @@ SetDictFromAny( * the conversion from lists to dictionaries. */ - if (TclHasInternalRep(objPtr, &tclListType.objType)) { + if (TclHasInternalRep(objPtr, &tclListType)) { size_t objc, i; Tcl_Obj **objv; @@ -3769,6 +3783,158 @@ TclInitDictCmd( } /* + *---------------------------------------------------------------------- + * + * DictAsListLength -- + * + * Compute the length of a list as if the dict value were converted to a + * list. + * + * Note: the list length may not match the dict size * 2. This occurs when + * there are duplicate keys in the original string representation. + * + * Side Effects -- + * + * The intent is to have no side effects. + */ + +static Tcl_Size +DictAsListLength( + Tcl_Obj *objPtr) +{ + Tcl_Size estCount, length, llen; + const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Obj *elemPtr; + + /* + * Allocate enough space to hold a (Tcl_Obj *) for each + * (possible) list element. + */ + + estCount = TclMaxListLength(nextElem, length, &limit); + estCount += (estCount == 0); /* Smallest list struct holds 1 + * element. */ + elemPtr = Tcl_NewObj(); + + llen = 0; + + while (nextElem < limit) { + const char *elemStart; + char *check; + Tcl_Size elemSize; + int literal; + + if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem, + &elemStart, &nextElem, &elemSize, &literal)) { + Tcl_DecrRefCount(elemPtr); + return 0; + } + if (elemStart == limit) { + break; + } + + TclInvalidateStringRep(elemPtr); + check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + Tcl_DecrRefCount(elemPtr); + return 0; + } + if (!literal) { + Tcl_InitStringRep(elemPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); + } + llen++; + } + Tcl_DecrRefCount(elemPtr); + return llen; +} + + +/* + *---------------------------------------------------------------------- + * + * DictAsListIndex -- + * + * Return the key or value at the given "list" index, i.e., as if the string + * value where treated as a list. The intent is to support this list + * operation w/o causing the Obj value to shimmer into a List. + * + * Side Effects -- + * + * The intent is to have no side effects. + * + */ + +static int +DictAsListIndex( + Tcl_Interp *interp, + struct Tcl_Obj *objPtr, + Tcl_Size index, + Tcl_Obj** elemObjPtr) +{ + Tcl_Size /*estCount,*/ length, llen; + const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); + Tcl_Obj *elemPtr; + + /* + * Compute limit of the list string + */ + + TclMaxListLength(nextElem, length, &limit); + elemPtr = Tcl_NewObj(); + + llen = 0; + + /* + * parse out each element until reaching the "index"th element. + * Sure this is slow, but shimmering is slower. + */ + while (nextElem < limit) { + const char *elemStart; + char *check; + Tcl_Size elemSize; + int literal; + + if (TCL_OK != TclFindElement(NULL, nextElem, limit - nextElem, + &elemStart, &nextElem, &elemSize, &literal)) { + Tcl_DecrRefCount(elemPtr); + return 0; + } + if (elemStart == limit) { + break; + } + + TclInvalidateStringRep(elemPtr); + check = Tcl_InitStringRep(elemPtr, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + Tcl_DecrRefCount(elemPtr); + if (interp) { + // Need error message here + } + return TCL_ERROR; + } + if (!literal) { + Tcl_InitStringRep(elemPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); + } + if (llen == index) { + *elemObjPtr = elemPtr; + return TCL_OK; + } + llen++; + } + + /* + * Index is beyond end of list - return empty + */ + Tcl_InitStringRep(elemPtr, NULL, 0); + *elemObjPtr = elemPtr; + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 724a49e..2b887a6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -19,7 +19,6 @@ #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" -#include "tclArithSeries.h" #include <math.h> #include <assert.h> @@ -452,11 +451,11 @@ VarHashCreateVar( */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType.objType)) \ + ((TclHasInternalRep((objPtr), &tclIntType)) \ ? (*(tPtr) = TCL_NUMBER_INT, \ *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - TclHasInternalRep((objPtr), &tclDoubleType.objType) \ + TclHasInternalRep((objPtr), &tclDoubleType) \ ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ @@ -675,7 +674,8 @@ static const Tcl_ObjType exprCodeType = { static const Tcl_ObjType dictIteratorType = { "dictIterator", ReleaseDictIterator, - NULL, NULL, NULL, TCL_OBJTYPE_V0 + NULL, NULL, NULL, + TCL_OBJTYPE_V0 }; /* @@ -4647,7 +4647,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewUIntObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE_APPEND(("%" TCL_Z_MODIFIER "u\n", length)); NEXT_INST_F(1, 1, 1); @@ -4656,17 +4656,15 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { + /* special case for AbstractList */ + if (ABSTRACTLIST_PROC(valuePtr,indexProc)) { length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); - if (objResultPtr == NULL) { + if (Tcl_ObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -4679,8 +4677,9 @@ TEBCresume( * Extract the desired list element. */ + /* TODO: handle AbstractList here? */ if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasInternalRep(value2Ptr, &tclListType.objType)) { + && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; DECACHE_STACK_INFO(); @@ -4721,34 +4720,30 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); - /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { + /* + * Get the contents of the list, making sure that it really is a list + * in the process. + */ + + /* special case for AbstractList */ + if (ABSTRACTLIST_PROC(valuePtr,indexProc)) { length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr); /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, length-1); /* Compute value @ index */ - if (index < length) { - objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); - if (objResultPtr == NULL) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - } else { - TclNewObj(objResultPtr); + if (Tcl_ObjTypeIndex(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; @@ -4821,8 +4816,15 @@ TEBCresume( * Compute the new variable value. */ - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, + if (ABSTRACTLIST_PROC(valuePtr, setElementProc)) { + + objResultPtr = Tcl_ObjTypeSetElement(interp, + valuePtr, numIndices, + &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); + } else { + objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); + } if (!objResultPtr) { TRACE_ERROR(interp); goto gotError; @@ -4943,9 +4945,8 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { - objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); - if (objResultPtr == NULL) { + if (ABSTRACTLIST_PROC(valuePtr, sliceProc)) { + if (Tcl_ObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4971,14 +4972,18 @@ TEBCresume( if (length > 0) { size_t i = 0; Tcl_Obj *o; - int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType.objType); + int isAbstractList = ABSTRACTLIST_PROC(value2Ptr,indexProc) != NULL; + /* * An empty list doesn't match anything. */ do { - if (isArithSeries) { - o = TclArithSeriesObjIndex(NULL, value2Ptr, i); + if (isAbstractList) { + if (Tcl_ObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } } else { Tcl_ListObjIndex(NULL, value2Ptr, i, &o); } @@ -4991,7 +4996,7 @@ TEBCresume( if (s1len == s2len) { match = (memcmp(s1, s2, s1len) == 0); } - if (isArithSeries) { + if (isAbstractList) { TclDecrRefCount(o); } i++; @@ -6335,7 +6340,7 @@ TEBCresume( case INST_TRY_CVT_TO_BOOLEAN: valuePtr = OBJ_AT_TOS; - if (TclHasInternalRep(valuePtr, &tclBooleanType.objType)) { + if (TclHasInternalRep(valuePtr, &tclBooleanType)) { objResultPtr = TCONST(1); } else { int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); @@ -8355,7 +8360,7 @@ ExecuteExtendedBinaryMathOp( overflowExpon: if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) - || (value2Ptr->typePtr != &tclIntType.objType) + || (value2Ptr->typePtr != &tclIntType) || (Tcl_WideUInt)w2 >= (1<<28)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", TCL_INDEX_NONE)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 50d992c..7660a2a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1091,20 +1091,49 @@ typedef struct ActiveInterpTrace { #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 -typedef struct { /* For internal core use only */ - Tcl_ObjType objType; - struct { - size_t (*lengthProc)(Tcl_Obj *obj); - } abstractList; -} TclObjTypeWithAbstractList; -#define TCL_OBJTYPE_V0_1(lengthProc) (sizeof(TclObjTypeWithAbstractList)) \ - }, {lengthProc /* For internal core use only */ #define ABSTRACTLIST_PROC(objPtr, proc) (((objPtr)->typePtr \ - && ((objPtr)->typePtr->version > offsetof(TclObjTypeWithAbstractList, abstractList.proc))) ? \ - ((const TclObjTypeWithAbstractList *)(objPtr)->typePtr)->abstractList.proc : NULL) + && ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \ + || ((objPtr)->typePtr->version > offsetof(Tcl_ObjType, proc)))) ? \ + ((objPtr)->typePtr)->proc : NULL) MODULE_SCOPE size_t TclLengthOne(Tcl_Obj *); + +/* + * Abstract List + * + * This structure provides the functions used in List operations to emulate a + * List for AbstractList types. + */ + + +#define Tcl_ObjTypeLength(objPtr) (objPtr)->typePtr->lengthProc(objPtr) +#define Tcl_ObjTypeIndex(interp, objPtr, index, elemObjPtr) \ + (objPtr)->typePtr->indexProc((interp),(objPtr),(index),(elemObjPtr)) +#define Tcl_ObjTypeSlice(interp, objPtr, fromIdx, toIdx, newObjPtr) \ + (objPtr)->typePtr->sliceProc((interp),(objPtr),(fromIdx),(toIdx),(newObjPtr)) +#define Tcl_ObjTypeReverse(interp, objPtr, newObjPtr) \ + (objPtr)->typePtr->reverseProc((interp),(objPtr),(newObjPtr)) +#define Tcl_ObjTypeGetElements(interp, objPtr, objCPtr, objVPtr) \ + (objPtr)->typePtr->getElementsProc((interp),(objPtr),(objCPtr),(objVPtr)) +#define Tcl_ObjTypeSetElement(interp, objPtr, indexCount, indexArray, valueObj) \ + (objPtr)->typePtr->setElementProc((interp), (objPtr), (indexCount), (indexArray), (valueObj)) +#define Tcl_ObjTypeReplace(interp, objPtr, first, numToDelete, numToInsert, insertObjs) \ + (objPtr)->typePtr->replaceProc((interp), (objPtr), (first), (numToDelete), (numToInsert), (insertObjs)) +#define Tcl_ObjTypeGetDouble(interp, objPtr, doublePtr) \ + (objPtr)->typePtr->getDoubleProc((interp), (objPtr), (doublePtr)) + + +/* + * Return the internal rep for the Obj. + * Note: Caller is responsible for confirming and casting returned value. + */ +static inline void* Tcl_ObjGetConcreteRep( + Tcl_Obj *objPtr) /* Object of type AbstractList */ +{ + return objPtr->internalRep.twoPtrValue.ptr1; +} + /* * The structure below defines an entry in the assocData hash table which is * associated with an interpreter. The entry contains a pointer to a function @@ -2627,7 +2656,7 @@ typedef struct ListRep { * converted to a list. */ #define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \ - (((listObj_)->typePtr == &tclListType.objType) \ + (((listObj_)->typePtr == &tclListType) \ ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \ TCL_OK) \ : Tcl_ListObjGetElements( \ @@ -2639,12 +2668,12 @@ typedef struct ListRep { * Tcl_Obj cannot be converted to a list. */ #define TclListObjLengthM(interp_, listObj_, lenPtr_) \ - (((listObj_)->typePtr == &tclListType.objType) \ + (((listObj_)->typePtr == &tclListType) \ ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \ : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_))) #define TclListObjIsCanonical(listObj_) \ - (((listObj_)->typePtr == &tclListType.objType) ? ListObjIsCanonical((listObj_)) : 0) + (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0) /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, @@ -2664,27 +2693,27 @@ typedef struct ListRep { #if TCL_MAJOR_VERSION > 8 #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType.objType \ - || (objPtr)->typePtr == &tclBooleanType.objType) \ + (((objPtr)->typePtr == &tclIntType \ + || (objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) #else #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType.objType) \ + (((objPtr)->typePtr == &tclIntType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ - : ((objPtr)->typePtr == &tclBooleanType.objType) \ + : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) #endif #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType.objType) \ + (((objPtr)->typePtr == &tclIntType) \ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) #else #define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType.objType \ + (((objPtr)->typePtr == &tclIntType \ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ @@ -2692,13 +2721,13 @@ typedef struct ListRep { #endif #define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType.objType \ + (((objPtr)->typePtr == &tclIntType \ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - ((((objPtr)->typePtr == &tclIntType.objType) && ((objPtr)->internalRep.wideValue >= 0) \ + ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) @@ -2712,7 +2741,7 @@ typedef struct ListRep { */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType.objType) \ + (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = \ ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) @@ -2902,13 +2931,12 @@ MODULE_SCOPE void *tclTimeClientData; * Variables denoting the Tcl object types defined in the core. */ -MODULE_SCOPE const TclObjTypeWithAbstractList tclBignumType; -MODULE_SCOPE const TclObjTypeWithAbstractList tclBooleanType; +MODULE_SCOPE const Tcl_ObjType tclBignumType; +MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; -MODULE_SCOPE const TclObjTypeWithAbstractList tclDoubleType; -MODULE_SCOPE const TclObjTypeWithAbstractList tclIntType; -MODULE_SCOPE const TclObjTypeWithAbstractList tclListType; -MODULE_SCOPE const TclObjTypeWithAbstractList tclArithSeriesType; +MODULE_SCOPE const Tcl_ObjType tclDoubleType; +MODULE_SCOPE const Tcl_ObjType tclIntType; +MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; @@ -3284,6 +3312,9 @@ MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); +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 * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, size_t len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); @@ -4759,7 +4790,7 @@ MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; - +MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* @@ -4791,7 +4822,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_ObjInternalRep ir; \ ir.wideValue = (Tcl_WideInt) i; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreInternalRep(objPtr, &tclIntType.objType, &ir); \ + Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \ } while (0) #define TclSetDoubleObj(objPtr, d) \ @@ -4799,7 +4830,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_ObjInternalRep ir; \ ir.doubleValue = (double) d; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreInternalRep(objPtr, &tclDoubleType.objType, &ir); \ + Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \ } while (0) /* @@ -4824,7 +4855,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclIntType.objType; \ + (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4843,7 +4874,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TclSetBignumInternalRep((objPtr), &bignumValue_); \ } else { \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \ - (objPtr)->typePtr = &tclIntType.objType; \ + (objPtr)->typePtr = &tclIntType; \ } \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4857,7 +4888,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_WideUInt uw_ = (uw); \ if (uw_ >= TCL_INDEX_NONE) { \ (objPtr)->internalRep.wideValue = -1; \ - (objPtr)->typePtr = &tclIntType.objType; \ + (objPtr)->typePtr = &tclIntType; \ } else if (uw_ > WIDE_MAX) { \ mp_int bignumValue_; \ if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \ @@ -4866,7 +4897,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TclSetBignumInternalRep((objPtr), &bignumValue_); \ } else { \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \ - (objPtr)->typePtr = &tclIntType.objType; \ + (objPtr)->typePtr = &tclIntType; \ } \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4878,7 +4909,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.doubleValue = (double)(d); \ - (objPtr)->typePtr = &tclDoubleType.objType; \ + (objPtr)->typePtr = &tclDoubleType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) diff --git a/generic/tclLink.c b/generic/tclLink.c index eec778a..f6cff9d 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -547,7 +547,7 @@ GetDouble( return 0; } else { #ifdef ACCEPT_NAN - Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType.objType); + Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType); if (irPtr != NULL) { *dblPtr = irPtr->doubleValue; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 7cf96cb..64d525d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -12,7 +12,6 @@ #include <assert.h> #include "tclInt.h" #include "tclTomMath.h" -#include "tclArithSeries.h" /* * TODO - memmove is fast. Measure at what size we should prefer memmove @@ -69,7 +68,7 @@ /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ - LIST_ASSERT((listObj_)->typePtr == &tclListType.objType); + LIST_ASSERT((listObj_)->typePtr == &tclListType); /* @@ -152,15 +151,22 @@ static size_t ListLength(Tcl_Obj *listPtr); * The internal representation of a list object is ListRep defined in tcl.h. */ -const TclObjTypeWithAbstractList tclListType = { - {"list", /* name */ +const Tcl_ObjType tclListType = { + "list", /* name */ FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - ListLength - )} + TCL_OBJTYPE_V1( + ListLength, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; /* Macros to manipulate the List internal rep */ @@ -206,7 +212,7 @@ const TclObjTypeWithAbstractList tclListType = { do { \ (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ - (objPtr_)->typePtr = &tclListType.objType; \ + (objPtr_)->typePtr = &tclListType; \ } while (0) #define ListObjOverwriteRep(objPtr_, repPtr_) \ @@ -1276,7 +1282,7 @@ TclListObjGetRep( * to be returned. */ ListRep *repPtr) /* Location to store descriptor */ { - if (!TclHasInternalRep(listObj, &tclListType.objType)) { + if (!TclHasInternalRep(listObj, &tclListType)) { int result; result = SetListFromAny(interp, listObj); if (result != TCL_OK) { @@ -1370,9 +1376,10 @@ TclListObjCopy( { Tcl_Obj *copyObj; - if (!TclHasInternalRep(listObj, &tclListType.objType)) { - if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { - return TclArithSeriesObjCopy(interp, listObj); + if (!TclHasInternalRep(listObj, &tclListType)) { + if (ABSTRACTLIST_PROC(listObj,dupIntRepProc) && + ABSTRACTLIST_PROC(listObj,indexProc)) { + return Tcl_DuplicateObj(listObj); } if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; @@ -1667,12 +1674,19 @@ Tcl_ListObjGetElements( { ListRep listRep; - if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) { - return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr); + if (ABSTRACTLIST_PROC(objPtr, getElementsProc) && + objPtr->typePtr->getElementsProc(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; } @@ -2087,6 +2101,11 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } + if (ABSTRACTLIST_PROC(listObj, replaceProc)) { + return Tcl_ObjTypeReplace(interp, listObj, first, + numToDelete, numToInsert, insertObjs); + } + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) return TCL_ERROR; /* Cannot be converted to a list */ @@ -2567,7 +2586,7 @@ TclLindexList( * shimmering; if internal rep is already a list do not shimmer it. * see TIP#22 and TIP#33 for the details. */ - if (!TclHasInternalRep(argObj, &tclListType.objType) + if (!TclHasInternalRep(argObj, &tclListType) && TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index) == TCL_OK) { /* @@ -2639,9 +2658,9 @@ TclLindexFlat( { Tcl_Size i; - /* Handle ArithSeries as special case */ - if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { - Tcl_Size listLen = ABSTRACTLIST_PROC(listObj, lengthProc)(listObj); + /* Handle AbstractList as special case */ + if (ABSTRACTLIST_PROC(listObj,indexProc)) { + Tcl_Size listLen = ABSTRACTLIST_PROC(listObj,lengthProc)(listObj); Tcl_Size index; Tcl_Obj *elemObj = NULL; for (i=0 ; i<indexCount && listObj ; i++) { @@ -2649,12 +2668,14 @@ TclLindexFlat( &index) == TCL_OK) { } if (i==0) { - elemObj = TclArithSeriesObjIndex(NULL, listObj, index); + if (Tcl_ObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) { + return NULL; + } } else if (index > 0) { - /* ArithSeries cannot be a list of lists */ + // TODO: support nested lists + Tcl_Obj *e2Obj = TclLindexFlat(interp, elemObj, 1, &indexArray[i]); Tcl_DecrRefCount(elemObj); - TclNewObj(elemObj); - break; + elemObj = e2Obj; } } Tcl_IncrRefCount(elemObj); @@ -2758,32 +2779,51 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (!TclHasInternalRep(indexArgObj, &tclListType.objType) - && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) - == TCL_OK) { + if (!TclHasInternalRep(indexArgObj, &tclListType) && + TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) + == TCL_OK) { + + if (ABSTRACTLIST_PROC(listObj, setElementProc)) { + indices = &indexArgObj; + Tcl_Obj *returnValue = + Tcl_ObjTypeSetElement(interp, listObj, 1, indices, 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); + } + /* + * Make copy to not shimmer index argument + */ indexListCopy = TclListObjCopy(NULL, indexArgObj); + if (indexListCopy == NULL) { /* * indexArgPtr designates something that is neither an index nor a * well formed list. Report the error via TclLsetFlat. */ - return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); - } - LIST_ASSERT_TYPE(indexListCopy); - ListObjGetElements(indexListCopy, indexCount, indices); + indexCount = 1; + indices = &indexArgObj; - /* - * Let TclLsetFlat handle the actual lset'ting. - */ + } else { + /* + * Expand list into indicies array + */ + LIST_ASSERT_TYPE(indexListCopy); + ListObjGetElements(indexListCopy, indexCount, indices); + } retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj); - Tcl_DecrRefCount(indexListCopy); + if (indexListCopy) { + Tcl_DecrRefCount(indexListCopy); + } + return retValueObj; } @@ -3288,34 +3328,32 @@ SetListFromAny( Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } - } else if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) { - /* - * Convertion from Arithmetic Series is a special case - * because it can be done an order of magnitude faster - * and may occur frequently. - */ - Tcl_Size j, size = ABSTRACTLIST_PROC(objPtr, lengthProc)(objPtr); + } else if (ABSTRACTLIST_PROC(objPtr,indexProc)) { + Tcl_Size elemCount, i; - /* TODO - leave space in front and/or back? */ - if (ListRepInitAttempt( - interp, size > 0 ? size : 1, NULL, &listRep) - != TCL_OK) { + elemCount = ABSTRACTLIST_PROC(objPtr,lengthProc)(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++) { - elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j); - if (elemPtrs[j] == NULL) { - return TCL_ERROR; - } + + /* Each iteration, store a list element */ + for (i = 0; i < elemCount; i++) { + if (Tcl_ObjTypeIndex(interp, objPtr, i, elemPtrs) != TCL_OK) { + return TCL_ERROR; + } + Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } + LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount); + + listRep.storePtr->numUsed = elemCount; + } else { Tcl_Size estCount, length; const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); @@ -3397,7 +3435,7 @@ fail: TclFreeInternalRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr; objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr; - objPtr->typePtr = &tclListType.objType; + objPtr->typePtr = &tclListType; return TCL_OK; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 16b9ca1..22dcf11 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -225,45 +225,73 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -const TclObjTypeWithAbstractList tclBooleanType= { - {"boolean", /* name */ +const Tcl_ObjType tclBooleanType= { + "boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - TclLengthOne - )} + TCL_OBJTYPE_V1( + TclLengthOne, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; -const TclObjTypeWithAbstractList tclDoubleType= { - {"double", /* name */ +const Tcl_ObjType tclDoubleType= { + "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - TclLengthOne - )} + TCL_OBJTYPE_V1( + TclLengthOne, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; -const TclObjTypeWithAbstractList tclIntType = { - {"int", /* name */ +const Tcl_ObjType tclIntType = { + "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - TclLengthOne - )} + TCL_OBJTYPE_V1( + TclLengthOne, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; -const TclObjTypeWithAbstractList tclBignumType = { - {"bignum", /* name */ +const Tcl_ObjType tclBignumType = { + "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - TclLengthOne - )} + TCL_OBJTYPE_V1( + TclLengthOne, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; /* @@ -373,15 +401,24 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclDoubleType.objType); + Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclStringType); - Tcl_RegisterObjType(&tclListType.objType); + Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); + /* For backward compatibility only ... */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + Tcl_RegisterObjType(&tclIntType); +#if !defined(TCL_WIDE_INT_IS_LONG) + Tcl_RegisterObjType(&oldIntType); +#endif + Tcl_RegisterObjType(&oldBooleanType); +#endif + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; @@ -2015,11 +2052,11 @@ Tcl_GetBoolFromObj( return TCL_ERROR; } do { - if (objPtr->typePtr == &tclIntType.objType || objPtr->typePtr == &tclBooleanType.objType) { + if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" * Tcl_ObjType and then compare the internalrep to 0.0. This isn't @@ -2036,7 +2073,7 @@ Tcl_GetBoolFromObj( result = (d != 0.0); goto boolEnd; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { result = 1; boolEnd: if (charPtr != NULL) { @@ -2104,18 +2141,18 @@ TclSetBooleanFromAny( */ if (objPtr->bytes == NULL) { - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { return TCL_OK; } goto badBoolean; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { goto badBoolean; } - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } } @@ -2246,13 +2283,13 @@ ParseBoolean( goodBoolean: TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = newBool; - objPtr->typePtr = &tclBooleanType.objType; + objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = newBool; - objPtr->typePtr = &tclIntType.objType; + objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2344,7 +2381,7 @@ Tcl_DbNewDoubleObj( objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType.objType; + objPtr->typePtr = &tclDoubleType; return objPtr; } @@ -2417,7 +2454,11 @@ Tcl_GetDoubleFromObj( double *dblPtr) /* Place to store resulting double. */ { do { - if (objPtr->typePtr == &tclDoubleType.objType) { + Tcl_ALGetDblProc *dblProc = ABSTRACTLIST_PROC(objPtr, getDoubleProc); + if (dblProc) { + return dblProc(interp, objPtr, dblPtr); + } + if (objPtr->typePtr == &tclDoubleType) { if (isnan(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2430,11 +2471,11 @@ Tcl_GetDoubleFromObj( *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { mp_int big; TclUnpackBignum(objPtr, big); @@ -2648,12 +2689,12 @@ Tcl_GetLongFromObj( { do { #ifdef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } #else - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { /* * We return any integer in the range LONG_MIN to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves @@ -2672,7 +2713,7 @@ Tcl_GetLongFromObj( goto tooLarge; } #endif - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -2681,7 +2722,7 @@ Tcl_GetLongFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed @@ -2909,11 +2950,11 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -2922,7 +2963,7 @@ Tcl_GetWideIntFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. @@ -2994,7 +3035,7 @@ Tcl_GetWideUIntFromObj( /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { if (objPtr->internalRep.wideValue < 0) { wideUIntOutOfRange: if (interp != NULL) { @@ -3008,10 +3049,10 @@ Tcl_GetWideUIntFromObj( *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { goto wideUIntOutOfRange; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a * Tcl_WideUInt, even when auto-narrowing is enabled. @@ -3078,11 +3119,11 @@ TclGetWideBitsFromObj( Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { do { - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -3091,7 +3132,7 @@ TclGetWideBitsFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { mp_int big; mp_err err; @@ -3170,7 +3211,7 @@ DupBignum( mp_int bignumVal; mp_int bignumCopy; - copyPtr->typePtr = &tclBignumType.objType; + copyPtr->typePtr = &tclBignumType; TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); @@ -3340,7 +3381,7 @@ GetBignumFromObj( mp_int *bignumValue) /* Returned bignum value. */ { do { - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; @@ -3365,14 +3406,14 @@ GetBignumFromObj( } return TCL_OK; } - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { if (mp_init_i64(bignumValue, objPtr->internalRep.wideValue) != MP_OKAY) { return TCL_ERROR; } return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -3532,7 +3573,7 @@ TclSetBignumInternalRep( void *big) { mp_int *bignumValue = (mp_int *)big; - objPtr->typePtr = &tclBignumType.objType; + objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); /* @@ -3575,7 +3616,7 @@ Tcl_GetNumberFromObj( int *typePtr) { do { - if (objPtr->typePtr == &tclDoubleType.objType) { + if (objPtr->typePtr == &tclDoubleType) { if (isnan(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { @@ -3584,12 +3625,12 @@ Tcl_GetNumberFromObj( *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } - if (objPtr->typePtr == &tclIntType.objType) { + if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_INT; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey, sizeof(mp_int)); @@ -4528,7 +4569,7 @@ Tcl_RepresentationCmd( objv[1]->refCount, objv[1]); if (objv[1]->typePtr) { - if (objv[1]->typePtr == &tclDoubleType.objType) { + if (objv[1]->typePtr == &tclDoubleType) { Tcl_AppendPrintfToObj(descObj, ", internal representation %g", objv[1]->internalRep.doubleValue); } else { diff --git a/generic/tclScan.c b/generic/tclScan.c index 6a5bfb7..9e72a53 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1019,7 +1019,7 @@ Tcl_ScanObjCmd( if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN const Tcl_ObjInternalRep *irPtr - = TclFetchInternalRep(objPtr, &tclDoubleType.objType); + = TclFetchInternalRep(objPtr, &tclDoubleType); if (irPtr) { dvalue = irPtr->doubleValue; } else diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 2f29617..49610be 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -555,7 +555,7 @@ TclParseNumber( /* A dict can never be a (single) number */ return TCL_ERROR; } - if (TclHasInternalRep(objPtr, &tclListType.objType)) { + if (TclHasInternalRep(objPtr, &tclListType)) { size_t length; /* A list can only be a (single) number if its length == 1 */ TclListObjLengthM(NULL, objPtr, &length); @@ -1378,7 +1378,7 @@ TclParseNumber( octalSignificandWide); octalSignificandOverflow = 1; } else { - objPtr->typePtr = &tclIntType.objType; + objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = (Tcl_WideInt)(-octalSignificandWide); @@ -1414,7 +1414,7 @@ TclParseNumber( significandWide); significandOverflow = 1; } else { - objPtr->typePtr = &tclIntType.objType; + objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = (Tcl_WideInt)(-significandWide); @@ -1446,7 +1446,7 @@ TclParseNumber( * k = numTrailZeros+exponent-numDigitsAfterDp. */ - objPtr->typePtr = &tclDoubleType.objType; + objPtr->typePtr = &tclDoubleType; if (exponentSignum) { /* * At this point exponent>=0, so the following calculation @@ -1497,14 +1497,14 @@ TclParseNumber( } else { objPtr->internalRep.doubleValue = HUGE_VAL; } - objPtr->typePtr = &tclDoubleType.objType; + objPtr->typePtr = &tclDoubleType; break; #ifdef IEEE_FLOATING_POINT case sNAN: case sNANFINISH: objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide); - objPtr->typePtr = &tclDoubleType.objType; + objPtr->typePtr = &tclDoubleType; break; #endif case INITIAL: diff --git a/generic/tclTest.c b/generic/tclTest.c index ca2d9cb..9491bca 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -735,6 +735,10 @@ Tcltest_Init( } #endif + if (Tcl_ABSListTest_Init(interp) != TCL_OK) { + return TCL_ERROR; + } + /* * Check for special options used in ../tests/main.test */ @@ -8598,4 +8602,3 @@ int TestApplyLambdaObjCmd ( * indent-tabs-mode: nil * End: */ - diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c new file mode 100644 index 0000000..1593a85 --- /dev/null +++ b/generic/tclTestABSList.c @@ -0,0 +1,950 @@ +// Tcl Abstract List test command: "lstring" + +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include <string.h> +#include <limits.h> +#include "tclInt.h" + +/* + * Forward references + */ + +Tcl_Obj *myNewLStringObj(Tcl_WideInt start, + Tcl_WideInt length); +static void freeRep(Tcl_Obj* alObj); +static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size numIndcies, + Tcl_Obj *const indicies[], + Tcl_Obj *valueObj); +static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr); +static int my_LStringObjIndex(Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size index, + Tcl_Obj **charObjPtr); +static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj, + Tcl_Size fromIdx, Tcl_Size toIdx, + Tcl_Obj **newObjPtr); +static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, + Tcl_Obj **newObjPtr); +static int my_LStringReplace(Tcl_Interp *interp, + Tcl_Obj *listObj, + Tcl_Size first, + Tcl_Size numToDelete, + Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]); +static int my_LStringGetElements(Tcl_Interp *interp, + Tcl_Obj *listPtr, + Tcl_Size *objcptr, + Tcl_Obj ***objvptr); +static void UpdateStringOfLString(Tcl_Obj *objPtr); + +/* + * Internal Representation of an lstring type value + */ + +typedef struct LString { + char *string; // NULL terminated utf-8 string + Tcl_Size strlen; // num bytes in string + Tcl_Size allocated; // num bytes allocated + Tcl_Obj**elements; // elements array, allocated when GetElements is + // called +} LString; + +/* + * AbstractList definition of an lstring type + */ +static const Tcl_ObjType lstringTypes[11] = { + {/*0*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*1*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + NULL, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*2*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + NULL, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*3*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + NULL, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*4*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + NULL, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*5*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + NULL, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*6*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + NULL, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*7*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + NULL, /* Replace */ + NULL) /* getDouble */ + }, + {/*8*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*9*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + }, + {/*10*/ + "lstring", + freeRep, + DupLStringRep, + UpdateStringOfLString, + NULL, + TCL_OBJTYPE_V1( + my_LStringObjLength, /* Length */ + NULL, /* RESERVED */ + my_LStringObjIndex, /* Index */ + my_LStringObjRange, /* Slice */ + my_LStringObjReverse, /* Reverse */ + my_LStringGetElements, /* GetElements */ + my_LStringObjSetElem, /* SetElement */ + my_LStringReplace, /* Replace */ + NULL) /* getDouble */ + } +}; + + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjIndex -- + * + * Implements the AbstractList Index function for the lstring type. The + * Index function returns the value at the index position given. Caller + * is resposible for freeing the Obj. + * + * Results: + * TCL_OK on success. Returns a new Obj, with a 0 refcount in the + * supplied charObjPtr location. Call has ownership of the Obj. + * + * Side effects: + * Obj allocated. + * + *---------------------------------------------------------------------- + */ + +static int +my_LStringObjIndex( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size index, + Tcl_Obj **charObjPtr) +{ + LString *lstringRepPtr = (LString*)Tcl_ObjGetConcreteRep(lstringObj); + + (void)interp; + + if (index < lstringRepPtr->strlen) { + char cchar[2]; + cchar[0] = lstringRepPtr->string[index]; + cchar[1] = 0; + *charObjPtr = Tcl_NewStringObj(cchar,1); + } else { + *charObjPtr = Tcl_NewObj(); + } + + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjLength -- + * + * Implements the AbstractList Length function for the lstring type. + * The Length function returns the number of elements in the list. + * + * Results: + * WideInt number of elements in the list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Size +my_LStringObjLength(Tcl_Obj *lstringObjPtr) +{ + LString *lstringRepPtr = (LString *)Tcl_ObjGetConcreteRep(lstringObjPtr); + return lstringRepPtr->strlen; +} + + +/* + *---------------------------------------------------------------------- + * + * DupLStringRep -- + * + * Replicates the internal representation of the src value, and storing + * it in the copy + * + * Results: + * void + * + * Side effects: + * Modifies the rep of the copyObj. + * + *---------------------------------------------------------------------- + */ + +static void +DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) +{ + LString *srcLString = (LString*)Tcl_ObjGetConcreteRep(srcPtr); + LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString)); + + memcpy(copyLString, srcLString, sizeof(LString)); + copyLString->string = (char*)Tcl_Alloc(srcLString->allocated); + strcpy(copyLString->string, srcLString->string); + copyLString->elements = NULL; + Tcl_ObjInternalRep itr; + itr.twoPtrValue.ptr1 = copyLString; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr); + + return; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjSetElem -- + * + * Replace the element value at the given (nested) index with the + * valueObj provided. If the lstring obj is shared, a new list is + * created conntaining the modifed element. + * + * Results: + * The modifed lstring is returned, either new or original. If the + * index is invalid, NULL is returned, and an error is added to the + * interp, if provided. + * + * Side effects: + * A new obj may be created. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +my_LStringObjSetElem( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size numIndicies, + Tcl_Obj *const indicies[], + Tcl_Obj *valueObj) +{ + LString *lstringRepPtr = (LString*)Tcl_ObjGetConcreteRep(lstringObj); + Tcl_Size index; + const char *newvalue; + int status; + Tcl_Obj *returnObj; + + if (numIndicies > 1) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Multiple indicies not supported by lstring.")); + return NULL; + } + + status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index); + if (status != TCL_OK) { + return NULL; + } + + returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj; + lstringRepPtr = (LString*)Tcl_ObjGetConcreteRep(returnObj); + + if (index >= lstringRepPtr->strlen) { + index = lstringRepPtr->strlen; + lstringRepPtr->strlen++; + lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1); + } + + newvalue = Tcl_GetString(valueObj); + lstringRepPtr->string[index] = newvalue[0]; + + Tcl_InvalidateStringRep(returnObj); + + return returnObj; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjRange -- + * + * Creates a new Obj with a slice of the src listPtr. + * + * Results: + * A new Obj is assigned to newObjPtr. Returns TCL_OK + * + * Side effects: + * A new Obj is created. + * + *---------------------------------------------------------------------- + */ + +static int my_LStringObjRange( + Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size fromIdx, + Tcl_Size toIdx, + Tcl_Obj **newObjPtr) +{ + Tcl_Obj *rangeObj; + LString *lstringRepPtr = (LString*)Tcl_ObjGetConcreteRep(lstringObj); + LString *rangeRep; + Tcl_WideInt len = toIdx - fromIdx + 1; + + if (lstringRepPtr->strlen < fromIdx || + lstringRepPtr->strlen < toIdx) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Range out of bounds ")); + return TCL_ERROR; + } + + if (len <= 0) { + // Return empty value; + *newObjPtr = Tcl_NewObj(); + } else { + rangeRep = (LString*)Tcl_Alloc(sizeof(LString)); + rangeRep->allocated = len+1; + rangeRep->strlen = len; + rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated); + strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len); + rangeRep->string[len] = 0; + rangeRep->elements = NULL; + rangeObj = Tcl_NewObj(); + Tcl_ObjInternalRep itr; + itr.twoPtrValue.ptr1 = rangeRep; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr); + if (rangeRep->strlen > 0) { + Tcl_InvalidateStringRep(rangeObj); + } else { + Tcl_InitStringRep(rangeObj, NULL, 0); + } + *newObjPtr = rangeObj; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringObjReverse -- + * + * Creates a new Obj with the the order of the elements in the lstring + * value reversed, where first is last and last is first, etc. + * + * Results: + * A new Obj is assigned to newObjPtr. Returns TCL_OK + * + * Side effects: + * A new Obj is created. + * + *---------------------------------------------------------------------- + */ + +static int +my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr) +{ + LString *srcRep = (LString*)Tcl_ObjGetConcreteRep(srcObj); + Tcl_Obj *revObj; + LString *revRep = (LString*)Tcl_Alloc(sizeof(LString)); + Tcl_ObjInternalRep itr; + Tcl_Size len; + char *srcp, *dstp, *endp; + (void)interp; + len = srcRep->strlen; + revRep->strlen = len; + revRep->allocated = len+1; + revRep->string = (char*)Tcl_Alloc(revRep->allocated); + revRep->elements = NULL; + srcp = srcRep->string; + endp = &srcRep->string[len]; + dstp = &revRep->string[len]; + *dstp-- = 0; + while (srcp < endp) { + *dstp-- = *srcp++; + } + revObj = Tcl_NewObj(); + itr.twoPtrValue.ptr1 = revRep; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr); + if (revRep->strlen > 0) { + Tcl_InvalidateStringRep(revObj); + } else { + Tcl_InitStringRep(revObj, NULL, 0); + } + *newObjPtr = revObj; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringReplace -- + * + * Delete and/or Insert elements in the list, starting at index first. + * See more details in the comments below. This should not be called with + * a Shared Obj. + * + * Results: + * The value of the listObj is modified. + * + * Side effects: + * The string rep is invalidated. + * + *---------------------------------------------------------------------- + */ + +static int +my_LStringReplace( + Tcl_Interp *interp, + Tcl_Obj *listObj, + Tcl_Size first, + Tcl_Size numToDelete, + Tcl_Size numToInsert, + Tcl_Obj *const insertObjs[]) +{ + LString *lstringRep = (LString*)Tcl_ObjGetConcreteRep(listObj); + Tcl_Size newLen; + Tcl_Size x, ix, kx; + char *newStr; + char *oldStr = lstringRep->string; + (void)interp; + + newLen = lstringRep->strlen - numToDelete + numToInsert; + + if (newLen >= lstringRep->allocated) { + lstringRep->allocated = newLen+1; + newStr = (char*)Tcl_Alloc(lstringRep->allocated); + newStr[newLen] = 0; + } else { + newStr = oldStr; + } + + /* Tcl_ListObjReplace replaces zero or more elements of the list + * referenced by listPtr with the objc values in the array referenced by + * objv. + * + * If listPtr does not point to a list value, Tcl_ListObjReplace + * will attempt to convert it to one; if the conversion fails, it returns + * TCL_ERROR and leaves an error message in the interpreter's result value + * if interp is not NULL. Otherwise, it returns TCL_OK after replacing the + * values. + * + * * If objv is NULL, no new elements are added. + * + * * If the argument first is zero or negative, it refers to the first + * element. + * + * * If first is greater than or equal to the number of elements in the + * list, then no elements are deleted; the new elements are appended + * to the list. count gives the number of elements to replace. + * + * * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before the one designated by first. + * Tcl_ListObjReplace invalidates listPtr's old string representation. + * + * * The reference counts of any elements inserted from objv are + * incremented since the resulting list now refers to them. Similarly, + * the reference counts for any replaced values are decremented. + */ + + // copy 0 to first-1 + if (newStr != oldStr) { + strncpy(newStr, oldStr, first); + } + + // move front elements to keep + for(x=0, kx=0; x<newLen && kx<first; kx++, x++) { + newStr[x] = oldStr[kx]; + } + // Insert new elements into new string + for(x=first, ix=0; ix<numToInsert; x++, ix++) { + char const *svalue = Tcl_GetString(insertObjs[ix]); + newStr[x] = svalue[0]; + } + // Move remaining elements + if ((first+numToDelete) < newLen) { + for(/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) { + newStr[x] = oldStr[kx]; + } + } + + // Terminate new string. + newStr[newLen] = 0; + + + if (oldStr != newStr) { + Tcl_Free(oldStr); + } + lstringRep->string = newStr; + lstringRep->strlen = newLen; + + /* Changes made to value, string rep no longer valid */ + Tcl_InvalidateStringRep(listObj); + + return TCL_OK; +} + +static const Tcl_ObjType * +my_SetAbstractProc(int ptype) +{ + const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */ + if (4 <= ptype && ptype <= 11) { + /* Table has no entries for the slots upto setfromany */ + typePtr = &lstringTypes[(ptype-3)]; + } + return typePtr; +} + + +/* + *---------------------------------------------------------------------- + * + * my_NewLStringObj -- + * + * Creates a new lstring Obj using the string value of objv[0] + * + * Results: + * results + * + * Side effects: + * side effects + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +my_NewLStringObj( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + LString *lstringRepPtr; + Tcl_ObjInternalRep itr; + size_t repSize; + Tcl_Obj *lstringPtr; + const char *string; + static const char* procTypeNames[] = { + "FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY", + "LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS", + "SETELEMENT", "REPLACE", NULL + }; + int i = 0; + int ptype; + const Tcl_ObjType *lstringTypePtr = &lstringTypes[10]; + + repSize = sizeof(LString); + lstringRepPtr = (LString*)Tcl_Alloc(repSize); + + while (i<objc) { + const char *s = Tcl_GetString(objv[i]); + if (strcmp(s, "-not")==0) { + i++; + if (Tcl_GetIndexFromObj(interp, objv[i], procTypeNames, "proctype", 0, &ptype)==TCL_OK) { + lstringTypePtr = my_SetAbstractProc(ptype); + } + } else if (strcmp(s, "--") == 0) { + // End of options + i++; + break; + } else { + break; + } + i++; + } + if (i != objc-1) { + Tcl_WrongNumArgs(interp, 0, objv, "lstring string"); + return NULL; + } + string = Tcl_GetString(objv[i]); + + lstringRepPtr->strlen = strlen(string); + lstringRepPtr->allocated = lstringRepPtr->strlen + 1; + lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated); + strcpy(lstringRepPtr->string, string); + lstringRepPtr->elements = NULL; + lstringPtr = Tcl_NewObj(); + itr.twoPtrValue.ptr1 = lstringRepPtr; + itr.twoPtrValue.ptr2 = NULL; + Tcl_StoreInternalRep(lstringPtr, lstringTypePtr, &itr); + if (lstringRepPtr->strlen > 0) { + Tcl_InvalidateStringRep(lstringPtr); + } else { + Tcl_InitStringRep(lstringPtr, NULL, 0); + } + + return lstringPtr; +} + +/* + *---------------------------------------------------------------------- + * + * freeRep -- + * + * Free the value storage of the lstring Obj. + * + * Results: + * void + * + * Side effects: + * Memory free'd. + * + *---------------------------------------------------------------------- + */ + +static void +freeRep(Tcl_Obj* lstringObj) +{ + LString *lstringRepPtr = (LString*)Tcl_ObjGetConcreteRep(lstringObj); + if (lstringRepPtr->string) { + Tcl_Free(lstringRepPtr->string); + } + if (lstringRepPtr->elements) { + Tcl_Obj **objptr = lstringRepPtr->elements; + while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) { + Tcl_DecrRefCount(*objptr++); + } + Tcl_Free((char*)lstringRepPtr->elements); + lstringRepPtr->elements = NULL; + } + Tcl_Free((char*)lstringRepPtr); + lstringObj->internalRep.twoPtrValue.ptr1 = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * my_LStringGetElements -- + * + * Get the elements of the list in an array. + * + * Results: + * objc, objv return values + * + * Side effects: + * A Tcl_Obj is stored for every element of the abstract list + * + *---------------------------------------------------------------------- + */ + +static int my_LStringGetElements(Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_Size *objcptr, + Tcl_Obj ***objvptr) +{ + LString *lstringRepPtr = (LString*)Tcl_ObjGetConcreteRep(lstringObj); + Tcl_Obj **objPtr; + char *cptr = lstringRepPtr->string; + (void)interp; + if (lstringRepPtr->strlen == 0) { + *objcptr = 0; + *objvptr = NULL; + return TCL_OK; + } + if (lstringRepPtr->elements == NULL) { + lstringRepPtr->elements = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * lstringRepPtr->strlen); + objPtr=lstringRepPtr->elements; + while (objPtr<&lstringRepPtr->elements[lstringRepPtr->strlen]) { + *objPtr = Tcl_NewStringObj(cptr++,1); + Tcl_IncrRefCount(*objPtr++); + } + } + *objvptr = lstringRepPtr->elements; + *objcptr = lstringRepPtr->strlen; + return TCL_OK; +} + +/* +** UpdateStringRep +*/ + +static void +UpdateStringOfLString(Tcl_Obj *objPtr) +{ +# define LOCAL_SIZE 64 + int localFlags[LOCAL_SIZE], *flagPtr = NULL; + Tcl_ObjType const *typePtr = objPtr->typePtr; + char *p; + int bytesNeeded = 0; + int llen, i; + + + /* + * Handle empty list case first, so rest of the routine is simpler. + */ + llen = typePtr->lengthProc(objPtr); + if (llen <= 0) { + Tcl_InitStringRep(objPtr, NULL, 0); + return; + } + + /* + * Pass 1: estimate space. + */ + if (llen <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + /* We know numElems <= LIST_MAX, so this is safe. */ + flagPtr = (int *) Tcl_Alloc(llen*sizeof(int)); + } + 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, objPtr, i, &elemObj); + Tcl_IncrRefCount(elemObj); + elemStr = Tcl_GetStringFromObj(elemObj, &elemLen); + /* Note TclScanElement updates flagPtr[i] */ + bytesNeeded += Tcl_ScanCountedElement(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. + */ + objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded); + p = objPtr->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, objPtr, i, &elemObj); + Tcl_IncrRefCount(elemObj); + elemStr = Tcl_GetStringFromObj(elemObj, &elemLen); + p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]); + *p++ = ' '; + Tcl_DecrRefCount(elemObj); + } + p[-1] = '\0'; /* Overwrite last space added */ + + /* Length of generated string */ + objPtr->length = p - 1 - objPtr->bytes; + + if (flagPtr != localFlags) { + Tcl_Free(flagPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * lLStringObjCmd -- + * + * Script level command that creats an lstring Obj value. + * + * Results: + * Returns and lstring Obj value in the interp results. + * + * Side effects: + * Interp results modified. + * + *---------------------------------------------------------------------- + */ + +static int +lLStringObjCmd( + void *clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_Obj *lstringObj; + + (void)clientData; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]); + + if (lstringObj) { + Tcl_SetObjResult(interp, lstringObj); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Lstring_Init -- + * + * DL load init function. Defines the "lstring" command. + * + * Results: + * "lstring" command added to the interp. + * + * Side effects: + * A new command is defined. + * + *---------------------------------------------------------------------- + */ + +int Tcl_ABSListTest_Init(Tcl_Interp *interp) { + if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { + return TCL_ERROR; + } + Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL); + Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0"); + return TCL_OK; +} diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0ebfb1d..9248571 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -122,17 +122,24 @@ static int FindElement(Tcl_Interp *interp, const char *string, * is unregistered, so has no need of a setFromAnyProc either. */ -static const TclObjTypeWithAbstractList endOffsetType = { - {"end-offset", /* name */ +static const Tcl_ObjType endOffsetType = { + "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - TclLengthOne - )} + TCL_OBJTYPE_V1( + TclLengthOne, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL) }; - + size_t TclLengthOne( TCL_UNUSED(Tcl_Obj *)) @@ -3464,7 +3471,7 @@ GetEndOffsetFromObj( Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */ void *cd; - while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType.objType)) == NULL) { + while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) { Tcl_ObjInternalRep ir; size_t length; const char *bytes = Tcl_GetStringFromObj(objPtr, &length); @@ -3650,7 +3657,7 @@ GetEndOffsetFromObj( parseOK: /* Success. Store the new internal rep. */ ir.wideValue = offset; - Tcl_StoreInternalRep(objPtr, &endOffsetType.objType, &ir); + Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir); } offset = irPtr->wideValue; @@ -3752,7 +3759,7 @@ TclIndexEncode( int idx; if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType.objType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType); if (irPtr && irPtr->wideValue >= 0) { /* "int[+-]int" syntax, works the same here as "int" */ irPtr = NULL; diff --git a/generic/tclVar.c b/generic/tclVar.c index bc94e73..51a9e98 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -245,7 +245,8 @@ static Tcl_DupInternalRepProc DupParsedVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL, TCL_OBJTYPE_V0 + FreeLocalVarName, DupLocalVarName, NULL, NULL, + TCL_OBJTYPE_V0 }; #define LocalSetInternalRep(objPtr, index, namePtr) \ @@ -268,7 +269,8 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0 + FreeParsedVarName, DupParsedVarName, NULL, NULL, + TCL_OBJTYPE_V0 }; #define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ diff --git a/tests/abstractlist.test b/tests/abstractlist.test new file mode 100644 index 0000000..7e27aa7 --- /dev/null +++ b/tests/abstractlist.test @@ -0,0 +1,531 @@ +# Exercise AbstractList via the "lstring" command defined in tclTestABSList.c +# +# Copyright © 2022 Brian Griffin +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] +} + +testConstraint testevalex [llength [info commands testevalex]] + +set abstractlisttestvars [info var *] + +proc value-cmp {vara varb} { + upvar $vara a + upvar $varb b + set ta [tcl::unsupported::representation $a] + set tb [tcl::unsupported::representation $b] + return [string compare $ta $tb] +} + +set str "My name is Inigo Montoya. You killed my father. Prepare to die!" +set str2 "Vizzini: HE DIDN'T FALL? INCONCEIVABLE. Inigo Montoya: You keep using that word. I do not think it means what you think it means." + +test abstractlist-1.0 {error cases} -body { + lstring +} \ + -returnCodes 1 \ + -result {wrong # args: should be "lstring string"} + +test abstractlist-1.1 {error cases} -body { + lstring a b c +} -returnCodes 1 \ + -result {wrong # args: should be "lstring string"} + +test abstractlist-2.0 {no shimmer llength} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring} + +test abstractlist-2.1 {no shimmer lindex} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set ele [lindex $l 22] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring y lstring} + +test abstractlist-2.2 {no shimmer lreverse} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{! e i d { } o t { } e r a p e r P { } . r e h t a f { } y m { } d e l l i k { } u o Y { } . a y o t n o M { } o g i n I { } s i { } e m a n { } y M} lstring lstring lstring} + +test abstractlist-2.3 {no shimmer lrange} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}} + +test abstractlist-2.4 {no shimmer foreach} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-2.5 {!no shimmer lreplace} { + set l [lstring $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 18 23 { } f a i l ?] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {V i z z i n i : { } H E { } D I D N ' T { } f a i l ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring lstring} + +test abstractlist-2.6 {no shimmer ledit} { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [testobj objtype $l] + set e [ledit l 9 8 S] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring} + +test abstractlist-2.7 {no shimmer linsert} { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 12 {*}[split "almost " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring} + +test abstractlist-2.8 {shimmer lassign} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} + +test abstractlist-2.9 {no shimmer lremove} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-2.10 {shimmer lreverse} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-2.11 {shimmer lset} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +# lrepeat +test abstractlist-2.12 {shimmer lrepeat} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +test abstractlist-2.13 {no shimmer join llength==1} { + set l [lstring G] + set l-isa [testobj objtype $l] + set j [join $l :] + set j-isa [testobj objtype $j] + list ${l-isa} $l ${j-isa} $j +} {lstring G none G} + +test abstractlist-2.14 {error case lset multiple indicies} -body { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 0 1 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} -returnCodes 1 \ + -result {Multiple indicies not supported by lstring.} + +# lsort + +test abstractlist-3.0 {no shimmer llength} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring} + +test abstractlist-3.1 {no shimmer lindex} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set n 22 + set ele [lindex $l $n] ;# exercise INST_LIST_INDEX + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring y lstring} + +test abstractlist-3.2 {no shimmer lreverse} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{! e i d { } o t { } e r a p e r P { } . r e h t a f { } y m { } d e l l i k { } u o Y { } . a y o t n o M { } o g i n I { } s i { } e m a n { } y M} lstring lstring lstring} + +test abstractlist-3.3 {shimmer lrange} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring -not SLICE $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l]; # lrange defaults to list behavior + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring list {My name is Inigo Montoya. You killed my father. Prepare to die!}} + +test abstractlist-3.4 {no shimmer foreach} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-3.5 {!no shimmer lreplace} { + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 18 23 { } f a i l ?] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {V i z z i n i : { } H E { } D I D N ' T { } f a i l ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring lstring} + +test abstractlist-3.6 {no shimmer ledit} { + # "ledit m 9 8 S" + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set e [ledit l 9 8 S] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring} + +test abstractlist-3.7 {no shimmer linsert} { + # "ledit m 9 8 S" + set res {} + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 12 {*}[split "almost " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring} + +test abstractlist-3.8 {shimmer lassign} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] ;# must be using lrange internally + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} list list} + +test abstractlist-3.9 {no shimmer lremove} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-3.10 {shimmer lreverse} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-3.11 {shimmer lset} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +# lrepeat +test abstractlist-3.12 {shimmer lrepeat} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +# lsort +foreach not {{} REVERSE SLICE SETELEMENT REPLACE GETELEMENTS} { + + testConstraint [format "%sShimmer" [string totitle $not]] [expr {$not eq ""}] + set options [expr {$not ne "" ? "-not $not" : ""}] + +test abstractlist-$not-4.0 {no shimmer llength} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring 63 lstring} + +test abstractlist-$not-4.1 {no shimmer lindex} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set ele [lindex $l 22] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{M y { } n a m e { } i s { } I n i g o { } M o n t o y a . { } Y o u { } k i l l e d { } m y { } f a t h e r . { } P r e p a r e { } t o { } d i e !} lstring y lstring} + +test abstractlist-$not-4.2 {lreverse} ReverseShimmer { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{! e i d { } o t { } e r a p e r P { } . r e h t a f { } y m { } d e l l i k { } u o Y { } . a y o t n o M { } o g i n I { } s i { } e m a n { } y M} lstring lstring lstring} + +test abstractlist-$not-4.3 {no shimmer lrange} RangeShimmer { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring {*}$options $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}} + +test abstractlist-$not-4.4 {no shimmer foreach} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {My name is Inigo Montoya. You killed my father. Prepare to die!}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-$not-4.5 {!no shimmer lreplace} RangeShimmer { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 18 23 { } f a i l ?] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {V i z z i n i : { } H E { } D I D N ' T { } f a i l ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} list lstring} + +test abstractlist-$not-4.6 {no shimmer ledit} {SetelementShimmer ReplaceShimmer} { + # "ledit m 9 8 S" + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set e [ledit l 9 8 S] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {V i z z i n i : { } S H E { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring} + +test abstractlist-$not-4.7 {no shimmer linsert} ReplaceShimmer { + # "ledit m 9 8 S" + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 12 {*}[split "almost " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {V i z z i n i : { } H E { } a l m o s t { } D I D N ' T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} lstring ' none {V i z z i n i : { } H E { } a l m o s t { } D I D N T { } F A L L ? { } I N C O N C E I V A B L E . { } I n i g o { } M o n t o y a : { } Y o u { } k e e p { } u s i n g { } t h a t { } w o r d . { } I { } d o { } n o t { } t h i n k { } i t { } m e a n s { } w h a t { } y o u { } t h i n k { } i t { } m e a n s .} list} + +# lassign probably uses lrange internally +test abstractlist-$not-4.8 {shimmer lassign} RangeShimmer { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} + +test abstractlist-$not-4.9 {no shimmer lremove} ReplaceShimmer { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-$not-4.10 {shimmer lreverse} ReverseShimmer { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-$not-4.11 {shimmer lset} SetelementShimmer { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +test abstractlist-$not-4.11x {lset not compiled} {SetelementShimmer testevalex} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [testevalex {lset l 2 k}] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +test abstractlist-$not-4.11e {error case lset multiple indicies} \ + -constraints {SetelementShimmer testevalex} -body { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [testevalex {lset l 2 0 1 k}] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} -returnCodes 1 \ + -result {Multiple indicies not supported by lstring.} + +# lrepeat +test abstractlist-$not-4.12 {shimmer lrepeat} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +# Disable constraint +testConstraint [format "%sShimmer" [string totitle $not]] 1 + +} + +# lsort + +# cleanup +::tcltest::cleanupTests + +proc my_abstl_cleanup {vars} { + set nowvars [uplevel info vars] + foreach var $nowvars { + if {$var ni $vars} { + uplevel unset $var + lappend clean-list $var + } + } + return ${clean-list} +} + +my_abstl_cleanup $abstractlisttestvars diff --git a/tests/dict.test b/tests/dict.test index d67f703..9513d89 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -14,6 +14,11 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] +} + # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { @@ -27,6 +32,7 @@ if {[testConstraint memory]} { expr {$end - $tmp} } } + test dict-1.1 {dict command basic syntax} -returnCodes error -body { dict @@ -138,8 +144,16 @@ test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body { dict get $a(z) d }} } -returnCodes error -result {key "d" not known in dictionary} -test dict-3.16 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;set l} {p 1 p 2 q 3} -test dict-3.17 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;llength $l} 6 +test dict-3.16 {dict/list shimmering - Bug 3004007} { + set l [list p 1 p 2 q 3] + dict get $l q + list $l [testobj objtype $l] +} {{p 1 p 2 q 3} dict} +test dict-3.17 {dict/list shimmering - Bug 3004007} { + set l [list p 1 p 2 q 3] + dict get $l q + list [llength $l] [testobj objtype $l] +} {6 dict} test dict-4.1 {dict replace command} { dict replace {a b c d} @@ -662,15 +676,15 @@ test dict-14.14 {dict for command: handle representation loss} -body { set keys {} set values {} dict for {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v } } - list [lsort $keys] [lsort $values] + list [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v -} -result {{a c e g} {b d f h}} +} -result {{a c e g} {b d f h} string} test dict-14.15 {dict for command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} @@ -1808,27 +1822,27 @@ test dict-24.14 {dict map command: handle representation loss} -setup { } -body { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } - }]] [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v -} -result {4 {a c e g} {b d f h}} +} -result {4 {a c e g} {b d f h} string} test dict-24.14a {dict map command: handle representation loss} -body { apply {{} { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } - }]] [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] }} -} -result {4 {a c e g} {b d f h}} +} -result {4 {a c e g} {b d f h} string} test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} diff --git a/tests/lseq.test b/tests/lseq.test index 1dff72d..2529455 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -17,6 +17,7 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 testConstraint arithSeriesShimmerOk 1 +testConstraint knownBug 0 testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] ## Arg errors @@ -434,7 +435,7 @@ test lseq-4.2 {start expressions} { ## lseq 1 to 10 by -2 ## # -> lseq: invalid step = -2 with a = 1 and b = 10 -test lseq-4.3 {TIP examples} { +test lseq-4.3 {TIP examples} -body { set examples {# Examples from TIP-629 # --- Begin --- lseq 10 .. 1 @@ -479,7 +480,9 @@ test lseq-4.3 {TIP examples} { } } set res -} {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5} +} -cleanup { + unset res +} -result {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5} # # Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case @@ -507,9 +510,6 @@ test lseq-4.4 {lseq corner case} -constraints has64BitLengths -body { test lseq-4.5 {lindex off by one} -body { lappend res [eval {lindex [lseq 1 4] end}] lappend res [eval {lindex [lseq 1 4] end-1}] -} -setup { - # Since 4.3 does not clean up and 4.4 may not run under constraint - set res {} } -cleanup { unset res } -result {4 3} @@ -541,9 +541,16 @@ test lseq-4.8 {error case lrange} -body { test lseq-4.9 {error case lrange} -body { set fred 7 set ginger 8 - lrange [lseq 1 5] $fred $ginger -} -returnCodes 1 \ - -result {index 7 is out of bounds 0 to 4} + lrange [lseq 1 10] $fred $ginger +} -result {8 9} + +test lseq-4.10 {lset shimmer} -body { + set l [lseq 15] + lappend res $l [lindex [tcl::unsupported::representation $l] 3] + lset l 3 25 + lappend res $l [lindex [tcl::unsupported::representation $l] 3] +} -result {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries {0 1 2 25 4 5 6 7 8 9 10 11 12 13 14} list} + # Panic when using variable value? test lseq-4.10 {panic using variable index} { @@ -551,6 +558,20 @@ test lseq-4.10 {panic using variable index} { lindex [lseq 10] $i } {0} +test lseq-4.11 {bug e5f06285de} knownBug { + set a1 [lseq 4 40 0.1] + set b1 [lseq 6 40 0.1] + for {set i 0} {$i < [llength $b1]} {incr i} { + set e1 [lindex $a1 $i+20] + set e2 [lindex $b1 $i] + set c1 [expr {4.0 + (double($i+20) * 0.1)}] + set c2 [expr {6.0 + (double($i) * 0.1)}] + if {[string compare $e1 $e2]} { + lappend bad [list $i $e1 $e2 [format %g $e1]] + } + } + set bad +} {} # cleanup ::tcltest::cleanupTests diff --git a/unix/Makefile.in b/unix/Makefile.in index 1bf5814..5ffba83 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -293,10 +293,11 @@ DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \ TCLSH_OBJS = tclAppInit.o TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o + tclThreadTest.o tclUnixTest.o tclTestABSList.o XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ - tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o + tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o \ + tclTestABSList.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \ @@ -468,6 +469,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ $(GENERIC_DIR)/tclTest.c \ + $(GENERIC_DIR)/tclTestABSList.c \ $(GENERIC_DIR)/tclTestObj.c \ $(GENERIC_DIR)/tclTestProcBodyObj.c \ $(GENERIC_DIR)/tclThread.c \ @@ -1559,6 +1561,9 @@ tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c +tclTestABSList.o: $(GENERIC_DIR)/tclTestABSList.c $(MATHHDRS) + $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestABSList.c + tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c diff --git a/win/Makefile.in b/win/Makefile.in index 2255681..e16a08e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -269,6 +269,7 @@ ${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} TCLTEST_OBJS = \ tclTest.$(OBJEXT) \ + tclTestABSList.$(OBJEXT) \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ diff --git a/win/makefile.vc b/win/makefile.vc index 8b05950..20875ef 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -225,6 +225,7 @@ TCLTESTOBJS = \ $(TMP_DIR)\tclTestProcBodyObj.obj \
$(TMP_DIR)\tclThreadTest.obj \
$(TMP_DIR)\tclWinTest.obj \
+ $(TMP_DIR)\tclTestABSList.obj \
!if !$(STATIC_BUILD)
$(OUT_DIR)\tommath.lib \
!endif
@@ -235,8 +236,8 @@ COREOBJS = \ $(TMP_DIR)\regerror.obj \
$(TMP_DIR)\regexec.obj \
$(TMP_DIR)\regfree.obj \
- $(TMP_DIR)\tclAlloc.obj \
$(TMP_DIR)\tclArithSeries.obj \
+ $(TMP_DIR)\tclAlloc.obj \
$(TMP_DIR)\tclAssembly.obj \
$(TMP_DIR)\tclAsync.obj \
$(TMP_DIR)\tclBasic.obj \
@@ -829,6 +830,9 @@ $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
$(cc32) $(appcflags) -Fo$@ $?
+$(TMP_DIR)\tclTestABSList.obj: $(GENERICDIR)\tclTestABSList.c
+ $(cc32) $(appcflags) -Fo$@ $?
+
$(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c
$(CCAPPCMD) $?
|