diff options
39 files changed, 3858 insertions, 856 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 @@ -20,18 +20,47 @@ lseq \- Build a numeric sequence returned as a list .SH DESCRIPTION .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 -.QW \fB..\fR -or -.QW \fBto\fR -defines an inclusive range; if it is omitted, the range is exclusive. -The \fBcount\fR option is used to define a count of the number of elements in -the list. -The \fIstep\fR (which may be preceded by \fBby\fR) is 1 if not provided. -The short form with a -single \fIcount\fR value will create a range from 0 to \fIcount\fR-1 (i.e., -\fIcount\fR values). +parameters \fIstart\fR, \fIend\fR, and \fIstep\fR. The \fIoperation\fR +argument "\fB..\fR" or "\fBto\fR" defines the range. The "\fBcount\fR" 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 \fIstart\fR and \fIend\fR are provided without a +\fIstep\fR value, then if \fIstart\fR <= \fIend\fR, the sequence will be +increasing and if \fIstart\fR > \fIend\fR it will be decreasing. If a +\fIstep\fR 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 \" +% \fBlseq\fR 1 to 5 ;# increasing +\fI\(-> 1 2 3 4 5 + +% \fBlseq\fR 5 to 1 ;# decreasing +\fI\(-> 5 4 3 2 1 + +% \fBlseq\fR 6 to 1 by 2 ;# decreasing, step wrong sign, empty list + +% \fBlseq\fR 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, +may also be a valid expression. The expression will be evaluated and the +numeric result will be used. An expression that does not evaluate to a number +will produce an invalid argument error. +.PP +\fIStart\fR defines the initial value and \fIend\fR defines the limit, not +necessarily the last value. \fBlseq\fR produces a list with \fIcount\fR +elements, and if \fIcount\fR is not supplied, it is computed as + +.CS \" + \fIcount\fR = int( (\fIend\fR - \fIstart\fR + \fIstep\fR) / \fIstep\fR ) +.\" +.CE + .PP The numeric arguments, \fIstart\fR, \fIend\fR, \fIstep\fR, and \fIcount\fR, can also be a valid expression. the \fBlseq\fR command will evaluate the @@ -43,53 +72,53 @@ value; a non-numeric expression result will result in an error. .CS .\" \fBlseq\fR 3 - \fI\(-> 0 1 2\fR +\fI\(-> 0 1 2\fR \fBlseq\fR 3 0 - \fI\(-> 3 2 1 0\fR +\fI\(-> 3 2 1 0\fR \fBlseq\fR 10 .. 1 by -2 - \fI\(-> 10 8 6 4 2\fR +\fI\(-> 10 8 6 4 2\fR set l [\fBlseq\fR 0 -5] - \fI\(-> 0 -1 -2 -3 -4 -5\fR +\fI\(-> 0 -1 -2 -3 -4 -5\fR foreach i [\fBlseq\fR [llength $l]] { puts l($i)=[lindex $l $i] } - \fI\(-> l(0)=0\fR - \fI\(-> l(1)=-1\fR - \fI\(-> l(2)=-2\fR - \fI\(-> l(3)=-3\fR - \fI\(-> l(4)=-4\fR - \fI\(-> l(5)=-5\fR +\fI\(-> l(0)=0\fR +\fI\(-> l(1)=-1\fR +\fI\(-> l(2)=-2\fR +\fI\(-> l(3)=-3\fR +\fI\(-> l(4)=-4\fR +\fI\(-> l(5)=-5\fR foreach i [\fBlseq\fR {[llength $l]-1} 0] { puts l($i)=[lindex $l $i] } - \fI\(-> l(5)=-5\fR - \fI\(-> l(4)=-4\fR - \fI\(-> l(3)=-3\fR - \fI\(-> l(2)=-2\fR - \fI\(-> l(1)=-1\fR - \fI\(-> l(0)=0\fR +\fI\(-> l(5)=-5\fR +\fI\(-> l(4)=-4\fR +\fI\(-> l(3)=-3\fR +\fI\(-> l(2)=-2\fR +\fI\(-> l(1)=-1\fR +\fI\(-> l(0)=0\fR set i 17 \fI\(-> 17\fR -if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i < 50) +if {$i in [\fBlseq\fR 0 50]} { # equivalent to: (0 <= $i && $i <= 50) puts "Ok" } else { puts "outside :(" } - \fI\(-> Ok\fR +\fI\(-> Ok\fR set sqrs [lmap i [\fBlseq\fR 1 10] { expr {$i*$i} }] - \fI\(-> 1 4 9 16 25 36 49 64 81 100\fR +\fI\(-> 1 4 9 16 25 36 49 64 81 100\fR .\" .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 b43fcec..ac4b252 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -608,6 +608,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 @@ -637,11 +659,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 1 +#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 @@ -694,7 +744,6 @@ typedef struct Tcl_Obj { Tcl_ObjInternalRep internalRep; /* The internal representation: */ } Tcl_Obj; - /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first @@ -2427,6 +2476,25 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); # undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) +/* + * Free the Obj by effectively doing: + * + * Tcl_IncrRefCount(objPtr); + * Tcl_DecrRefCount(objPtr); + * + * This will free the obj if there are no references to the obj. + */ +# define Tcl_BumpObj(objPtr) \ + TclBumpObj(objPtr, __FILE__, __LINE__) + +static inline void TclBumpObj(Tcl_Obj* objPtr, const char* fn, int line) +{ + if (objPtr) { + if ((objPtr)->refCount == 0) { + Tcl_DbDecrRefCount(objPtr, fn, line); + } + } +} #else # undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ @@ -2446,6 +2514,24 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); # undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) + +/* + * Declare that obj will no longer be used or referenced. + * This will release the obj if there is no referece count, + * otherwise let it be. + */ +# define Tcl_BumpObj(objPtr) \ + TclBumpObj(objPtr); + +static inline void TclBumpObj(Tcl_Obj* objPtr) +{ + if (objPtr) { + if ((objPtr)->refCount == 0) { + Tcl_DecrRefCount(objPtr); + } + } +} + #endif /* 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 1019677..f8428e6 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -10,13 +10,95 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include "tcl.h" #include "tclInt.h" -#include "tclArithSeries.h" #include <assert.h> #include <math.h> +/* + * The structure below defines the arithmetic series Tcl object type by + * means of procedures that can be invoked by generic object code. + * + * The arithmetic series object is a special case of Tcl list representing + * an interval of an arithmetic series in constant space. + * + * The arithmetic series is internally represented with three integers, + * *start*, *end*, and *step*, Where the length is calculated with + * the following algorithm: + * + * if RANGE == 0 THEN + * ERROR + * if RANGE > 0 + * LEN is (((END-START)-1)/STEP) + 1 + * else if RANGE < 0 + * LEN is (((END-START)-1)/STEP) - 1 + * + * And where the equivalent's list I-th element is calculated + * as: + * + * LIST[i] = START + (STEP * i) + * + * Zero elements ranges, like in the case of START=10 END=10 STEP=1 + * are valid and will be equivalent to the empty list. + */ + +/* + * 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; + int precision; +} ArithSeriesDbl; + /* -------------------------- ArithSeries object ---------------------------- */ +static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_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_V1( + ArithSeriesObjLength, + NULL, + TclArithSeriesObjIndex, + TclArithSeriesObjRange, + TclArithSeriesObjReverse, + TclArithSeriesGetElements, + NULL, // SetElement + NULL, // Replace + NULL) // GetDouble +}; + /* * Helper functions * @@ -68,7 +150,7 @@ static inline ArithSeries* ArithSeriesGetInternalRep(Tcl_Obj *objPtr) { const Tcl_ObjInternalRep *irPtr; - irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType.objType); + irPtr = TclFetchInternalRep((objPtr), &arithSeriesType); return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; } @@ -93,54 +175,7 @@ maxPrecision(double start, double end, double step) return dp; } -/* - * 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. - * - * The arithmetic series object is a special case of Tcl list representing - * an interval of an arithmetic series in constant space. - * - * The arithmetic series is internally represented with three integers, - * *start*, *end*, and *step*, Where the length is calculated with - * the following algorithm: - * - * if RANGE == 0 THEN - * ERROR - * if RANGE > 0 - * LEN is (((END-START)-1)/STEP) + 1 - * else if RANGE < 0 - * LEN is (((END-START)-1)/STEP) - 1 - * - * And where the equivalent's list I-th element is calculated - * as: - * - * LIST[i] = START + (STEP * i) - * - * Zero elements ranges, like in the case of START=10 END=10 STEP=1 - * are valid and will be equivalent to the empty list. - */ - -const TclObjTypeWithAbstractList tclArithSeriesType = { - {"arithseries", /* name */ - FreeArithSeriesInternalRep, /* freeIntRepProc */ - DupArithSeriesInternalRep, /* dupIntRepProc */ - UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1( - ArithSeriesObjLength - )} -}; +static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, Tcl_Obj **stepObj); /* *---------------------------------------------------------------------- @@ -189,6 +224,86 @@ ArithSeriesLenDbl(double start, double end, double step) return (len < 0) ? -1 : len; } + +/* + *---------------------------------------------------------------------- + * + * 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; + /* + * Allocate a new ArithSeries structure. */ + + if (srcArithSeriesRepPtr->isDouble) { + ArithSeriesDbl *srcArithSeriesDblRepPtr = + (ArithSeriesDbl *)srcArithSeriesRepPtr; + ArithSeriesDbl *copyArithSeriesDblRepPtr = + (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl)); + *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr; + copyArithSeriesDblRepPtr->elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr; + } else { + ArithSeries *copyArithSeriesRepPtr = + (ArithSeries *) Tcl_Alloc(sizeof(ArithSeries)); + *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; + copyArithSeriesRepPtr->elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; + } + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + copyPtr->typePtr = &arithSeriesType; +} + +/* + *---------------------------------------------------------------------- + * + * FreeArithSeriesInternalRep -- + * + * Free any allocated memory in the ArithSeries Rep + * + * Results: + * None. + * + * Side effects: + * + *---------------------------------------------------------------------- + */ +static void +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */ +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + + if (arithSeriesRepPtr) { + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i, len = arithSeriesRepPtr->len; + for (i=0; i<len; i++) { + Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]); + } + Tcl_Free((char*)arithSeriesRepPtr->elements); + arithSeriesRepPtr->elements = NULL; + } + Tcl_Free((char*)arithSeriesRepPtr); + } +} + + /* *---------------------------------------------------------------------- * @@ -233,7 +348,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); @@ -288,7 +403,7 @@ NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->precision = maxPrecision(start,end,step); arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &tclArithSeriesType.objType; + arithSeriesObj->typePtr = &arithSeriesType; if (length > 0) { Tcl_InvalidateStringRep(arithSeriesObj); @@ -456,53 +571,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 = ArithSeriesGetInternalRep(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: * @@ -511,27 +590,27 @@ ArithSeriesObjStep( *---------------------------------------------------------------------- */ -Tcl_Obj * +int TclArithSeriesObjIndex( - TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *arithSeriesObj, - Tcl_WideInt index) + TCL_UNUSED(Tcl_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; + ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (arithSeriesObj->typePtr != &tclArithSeriesType.objType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (index < 0 || (Tcl_Size)index >= arithSeriesRepPtr->len) { - return Tcl_NewObj(); - } - /* List[i] = Start + (Step * index) */ - if (arithSeriesRepPtr->isDouble) { - return Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index)); + if (index < 0 || arithSeriesRepPtr->len <= index) { + *elemObj = Tcl_NewObj(); } else { - return Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elemObj = Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index)); + } else { + *elemObj = Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); + } } + + return TCL_OK; } /* @@ -557,174 +636,40 @@ Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj) arithSeriesObj->internalRep.twoPtrValue.ptr1; return arithSeriesRepPtr->len; } - + /* *---------------------------------------------------------------------- * - * FreeArithSeriesInternalRep -- + * TclArithSeriesObjStep -- * - * Deallocate the storage associated with an arithseries object's - * internal representation. + * Return a Tcl_Obj with the step value from the give ArithSeries Obj. + * refcount = 0. * * 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. + * A Tcl_Obj pointer to the created ArithSeries object. + * A NULL pointer of the range is invalid. * - * Results: - * None. + * Side Effects: * - * Side effects: - * We set "copyPtr"s internal rep to a pointer to a - * newly allocated ArithSeries structure. + * None. *---------------------------------------------------------------------- */ -static void -DupArithSeriesInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesObj, + Tcl_Obj **stepObj) { - ArithSeries *srcArithSeriesRepPtr = - (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; - /* - * Allocate a new ArithSeries structure. */ - - if (srcArithSeriesRepPtr->isDouble) { - ArithSeriesDbl *srcArithSeriesDblRepPtr = - (ArithSeriesDbl *)srcArithSeriesRepPtr; - ArithSeriesDbl *copyArithSeriesDblRepPtr = - (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl)); - *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr; - copyArithSeriesDblRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr; + ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); + if (arithSeriesRepPtr->isDouble) { + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); } else { - ArithSeries *copyArithSeriesRepPtr = - (ArithSeries *) Tcl_Alloc(sizeof(ArithSeries)); - *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; - copyArithSeriesRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclArithSeriesType.objType; + 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 *arithSeriesObj) -{ - ArithSeries *arithSeriesRepPtr = - (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1; - char *elem, *p; - Tcl_Obj *elemObj; - Tcl_Size i; - Tcl_Size length = 0; - Tcl_Size slen; - - /* - * Pass 1: estimate space. - */ - if (!arithSeriesRepPtr->isDouble) { - for (i = 0; i < arithSeriesRepPtr->len; i++) { - double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); - slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1; - length += slen; - } - } else { - for (i = 0; i < arithSeriesRepPtr->len; i++) { - double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); - char tmp[TCL_DOUBLE_SPACE+2]; - tmp[0] = 0; - Tcl_PrintDouble(NULL,d,tmp); - if ((length + strlen(tmp)) > TCL_SIZE_MAX) { - break; // overflow - } - length += strlen(tmp); - } - } - length += arithSeriesRepPtr->len; // Space for each separator - - /* - * Pass 2: generate the string repr. - */ - - p = Tcl_InitStringRep(arithSeriesObj, NULL, length); - if (p == NULL) { - Tcl_Panic("Unable to allocate string size %" TCL_Z_MODIFIER "u", length); - } - for (i = 0; i < arithSeriesRepPtr->len; i++) { - elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i); - elem = Tcl_GetStringFromObj(elemObj, &slen); - if (((p - arithSeriesObj->bytes)+slen) > length) { - break; - } - strncpy(p, elem, slen); - p[slen] = ' '; - p += slen+1; - Tcl_DecrRefCount(elemObj); - } - if (length > 0) arithSeriesObj->bytes[length-1] = '\0'; - arithSeriesObj->length = length-1; -} /* *---------------------------------------------------------------------- @@ -776,28 +721,33 @@ SetArithSeriesFromAny( *---------------------------------------------------------------------- */ -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; + (void)interp; /* silence compiler */ + arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); if (fromIdx == TCL_INDEX_NONE) { fromIdx = 0; } + if (toIdx >= arithSeriesRepPtr->len) { + toIdx = arithSeriesRepPtr->len-1; + } + if (fromIdx > toIdx || - (toIdx > arithSeriesRepPtr->len-1 && - fromIdx > arithSeriesRepPtr->len-1)) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + fromIdx >= arithSeriesRepPtr->len) { + TclNewObj(*newObjPtr); + return TCL_OK; } if (fromIdx < 0) { @@ -810,31 +760,22 @@ TclArithSeriesObjRange( toIdx = arithSeriesRepPtr->len-1; } - startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx); - if (startObj == NULL) { - return NULL; - } + 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; } /* @@ -878,7 +819,8 @@ TclArithSeriesObjRange( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return arithSeriesObj; + *newObjPtr = arithSeriesObj; + return TCL_OK; } /* @@ -920,12 +862,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; arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr); + objc = arithSeriesRepPtr->len; if (objc > 0) { if (arithSeriesRepPtr->elements) { @@ -945,8 +888,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]); @@ -974,24 +917,23 @@ TclArithSeriesGetElements( * * TclArithSeriesObjReverse -- * - * Reverse the order of the ArithSeries value. - * *arithSeriesObj must be known to be a valid list. + * Reverse the order of the ArithSeries value. The arithSeriesObj is + * assumed to be a valid ArithSeries. The new Obj has the Start and End + * values appropriately swapped and the Step value sign is changed. * * Results: - * Returns a pointer to the reordered series. - * This may be a new object or the same object if not shared. + * The result will be an ArithSeries in the reverse order. * * Side effects: - * ?The possible conversion of the object referenced by listPtr? - * ?to a list object.? + * The ogiginal obj will be modified and returned if it is not Shared. * *---------------------------------------------------------------------- */ - -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; @@ -1000,16 +942,22 @@ TclArithSeriesObjReverse( double dstart, dend, dstep; int isDouble; + (void)interp; + + if (newObjPtr == NULL) { + return TCL_ERROR; + } + arithSeriesRepPtr = ArithSeriesGetInternalRep(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) { @@ -1030,8 +978,8 @@ TclArithSeriesObjReverse( ((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); @@ -1070,7 +1018,87 @@ 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*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + char *p; + Tcl_Obj *eleObj; + Tcl_Size i, bytlen = 0; + + /* + * Pass 1: estimate space. + */ + if (!arithSeriesRepPtr->isDouble) { + for (i = 0; i < arithSeriesRepPtr->len; i++) { + double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); + size_t slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1; + bytlen += slen; + } + } else { + for (i = 0; i < arithSeriesRepPtr->len; i++) { + double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); + char tmp[TCL_DOUBLE_SPACE+2]; + tmp[0] = 0; + Tcl_PrintDouble(NULL,d,tmp); + if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) { + break; // overflow + } + bytlen += strlen(tmp); + } + } + bytlen += arithSeriesRepPtr->len; // Space for each separator + + /* + * Pass 2: generate the string repr. + */ + + p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); + for (i = 0; i < arithSeriesRepPtr->len; i++) { + if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) { + Tcl_Size slen; + char *str = Tcl_GetStringFromObj(eleObj, &slen); + strcpy(p, str); + p[slen] = ' '; + p += slen+1; + Tcl_DecrRefCount(eleObj); + } // else TODO: report error here? + } + if (bytlen > 0) arithSeriesObjPtr->bytes[bytlen-1] = '\0'; + arithSeriesObjPtr->length = bytlen-1; } /* diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h deleted file mode 100644 index 8002239..0000000 --- a/generic/tclArithSeries.h +++ /dev/null @@ -1,56 +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_WideInt len; - Tcl_Obj **elements; - int isDouble; - Tcl_WideInt start; - Tcl_WideInt end; - Tcl_WideInt step; -} ArithSeries; -typedef struct { - Tcl_WideInt len; - Tcl_Obj **elements; - int isDouble; - double start; - double end; - double step; - int precision; -} ArithSeriesDbl; - - -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 20248a9..22c4278 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6152,7 +6152,7 @@ TclNREvalObjEx( */ Tcl_IncrRefCount(objPtr); - listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType.objType); + listPtr = TclDuplicatePureObj(interp, objPtr, &tclListType); if (!listPtr) { Tcl_DecrRefCount(objPtr); return TCL_ERROR; @@ -7050,7 +7050,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]); @@ -7090,7 +7090,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]); @@ -7236,7 +7236,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]); @@ -7290,7 +7290,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; @@ -7354,7 +7354,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; @@ -7369,7 +7369,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; @@ -7530,7 +7530,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 81ea3f3..c97ee2e 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2001,7 +2001,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; } @@ -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; diff --git a/generic/tclClock.c b/generic/tclClock.c index a54e36b..bef10c2 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 0a24d88..4c15daf 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 @@ -2783,7 +2782,7 @@ EachloopCmd( /* List */ /* Variables */ statePtr->vCopyList[i] = TclDuplicatePureObj( - interp, objv[1+i*2], &tclListType.objType); + interp, objv[1+i*2], &tclListType); if (!statePtr->vCopyList[i]) { result = TCL_ERROR; goto done; @@ -2808,8 +2807,9 @@ EachloopCmd( &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ - if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType.objType)) { - /* Special case for Arith Series */ + if (!TclHasInternalRep(objv[2+i*2], &tclListType) && + 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; @@ -2818,9 +2818,8 @@ 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] = TclDuplicatePureObj( - interp, objv[2+i*2], &tclListType.objType); + interp, objv[2+i*2], &tclListType); if (!statePtr->aCopyList[i]) { result = TCL_ERROR; goto done; @@ -2958,17 +2957,18 @@ ForeachAssignments( 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 3fc1d2a..60af33c 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. */ { Tcl_Size 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,42 +2256,19 @@ Tcl_JoinObjCmd( Tcl_Size 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); - Tcl_DecrRefCount(valueObj); - } - } else { - for (i = 0; i < listLen; i++) { - if (i > 0) { + for (i = 0; i < listLen; i++) { + if (i > 0) { - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); - } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } } Tcl_DecrRefCount(joinObjPtr); @@ -2334,7 +2314,7 @@ Tcl_LassignObjCmd( return TCL_ERROR; } - listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType.objType); + listCopyPtr = TclDuplicatePureObj(interp, objv[1], &tclListType); if (!listCopyPtr) { return TCL_ERROR; } @@ -2504,7 +2484,7 @@ Tcl_LinsertObjCmd( listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType); + listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); if (!listPtr) { return TCL_ERROR; } @@ -2704,7 +2684,7 @@ Tcl_LpopObjCmd( if (objc == 2) { if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType); + listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); if (!listPtr) { return TCL_ERROR; } @@ -2787,11 +2767,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; } @@ -2891,7 +2871,7 @@ Tcl_LremoveObjCmd( */ if (Tcl_IsShared(listObj)) { - listObj = TclDuplicatePureObj(interp, listObj, &tclListType.objType); + listObj = TclDuplicatePureObj(interp, listObj, &tclListType); if (!listObj) { status = TCL_ERROR; goto done; @@ -3146,7 +3126,7 @@ Tcl_LreplaceObjCmd( listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType); + listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); if (!listPtr) { return TCL_ERROR; } @@ -3207,20 +3187,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; } @@ -3313,7 +3291,7 @@ Tcl_LsearchObjCmd( int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; - Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL; SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { @@ -3758,9 +3736,14 @@ Tcl_LsearchObjCmd( lower = start - groupSize; upper = listc; + itemPtr = NULL; while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; i -= i % groupSize; + + Tcl_BumpObj(itemPtr); + itemPtr = NULL; + if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { @@ -3859,6 +3842,9 @@ Tcl_LsearchObjCmd( } for (i = start; i < listc; i += groupSize) { match = 0; + Tcl_BumpObj(itemPtr); + itemPtr = NULL; + if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { @@ -3985,6 +3971,9 @@ Tcl_LsearchObjCmd( } } + Tcl_BumpObj(itemPtr); + itemPtr = NULL; + /* * Return everything or a single value. */ @@ -4044,91 +4033,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) * @@ -4266,7 +4170,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; @@ -4336,11 +4240,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]; @@ -4348,22 +4251,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) { @@ -4383,13 +4286,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) { @@ -4406,17 +4308,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]; @@ -4429,14 +4329,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]; @@ -4445,7 +4344,6 @@ Tcl_LseqObjCmd( step = numValues[4]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4461,7 +4359,6 @@ Tcl_LseqObjCmd( elementCount = numValues[2]; break; default: - status = TCL_ERROR; goto done; break; } @@ -4475,7 +4372,6 @@ Tcl_LseqObjCmd( case 1212: opmode = (SequenceOperators)values[3]; goto KeywordError; break; KeywordError: - status = TCL_ERROR; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: @@ -4491,14 +4387,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; } @@ -4529,6 +4423,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 @@ -4770,7 +4757,7 @@ Tcl_LsortObjCmd( * 1675116] */ - listObj = TclDuplicatePureObj(interp ,listObj, &tclListType.objType); + listObj = TclDuplicatePureObj(interp ,listObj, &tclListType); if (listObj == NULL) { sortInfo.resultCode = TCL_ERROR; goto done; @@ -4795,9 +4782,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); @@ -5126,7 +5113,7 @@ Tcl_LeditObjCmd( } if (Tcl_IsShared(listPtr)) { - listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType.objType); + listPtr = TclDuplicatePureObj(interp, listPtr, &tclListType); if (!listPtr) { return TCL_ERROR; } @@ -5546,7 +5533,7 @@ SelectObjFromSublist( for (i=0 ; i<infoPtr->indexc ; i++) { Tcl_Size listLen; int index; - Tcl_Obj *currentObj; + Tcl_Obj *currentObj, *lastObj=NULL; if (TclListObjLengthM(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; @@ -5577,6 +5564,8 @@ SelectObjFromSublist( return NULL; } objPtr = currentObj; + Tcl_BumpObj(lastObj); + lastObj = currentObj; } return objPtr; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index a4e999c..9cdbcea 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; @@ -1681,9 +1681,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); @@ -1712,8 +1712,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 69b69b2..ae365c3 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 18a9a97..d37d279 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)) { Tcl_Size objc, i; Tcl_Obj **objv; @@ -3789,6 +3803,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/tclEnsemble.c b/generic/tclEnsemble.c index 7c4c5f4..c238141 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -607,7 +607,7 @@ TclNamespaceEnsembleCmd( cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = TclDuplicatePureObj( - interp, listObj, &tclListType.objType); + interp, listObj, &tclListType); if (!newList) { if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -624,7 +624,7 @@ TclNamespaceEnsembleCmd( &newCmd); if (patchedDict == NULL) { patchedDict = TclDuplicatePureObj( - interp, objv[1], &tclListType.objType); + interp, objv[1], &tclListType); if (!patchedDict) { goto freeMapAndError; } @@ -1926,7 +1926,7 @@ NsEnsembleImplementationCmdNR( if (objc == 2) { copyPtr = TclDuplicatePureObj( - interp, prefixObj, &tclListType.objType); + interp, prefixObj, &tclListType); if (!copyPtr) { return TCL_ERROR; } @@ -2330,7 +2330,7 @@ EnsembleUnknownCallback( */ unknownCmd = TclDuplicatePureObj( - interp, ensemblePtr->unknownHandler, &tclListType.objType); + interp, ensemblePtr->unknownHandler, &tclListType); if (!unknownCmd) { return TCL_ERROR; } diff --git a/generic/tclEvent.c b/generic/tclEvent.c index caa4567..88a568a 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -233,7 +233,7 @@ HandleBgErrors( */ Tcl_Obj *copyObj = TclDuplicatePureObj( - interp, assocPtr->cmdPrefix, &tclListType.objType); + interp, assocPtr->cmdPrefix, &tclListType); if (!copyObj) { return; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index e9494d9..8fc2ae6 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> @@ -451,11 +450,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)), \ @@ -674,7 +673,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 }; /* @@ -3375,7 +3375,7 @@ TEBCresume( } if (Tcl_IsShared(objResultPtr)) { Tcl_Obj *newValue = TclDuplicatePureObj( - interp, objResultPtr, &tclListType.objType); + interp, objResultPtr, &tclListType); if (!newValue) { TRACE_ERROR(interp); goto gotError; @@ -3439,7 +3439,7 @@ TEBCresume( } else { if (Tcl_IsShared(objResultPtr)) { valueToAssign = TclDuplicatePureObj( - interp, objResultPtr, &tclListType.objType); + interp, objResultPtr, &tclListType); if (!valueToAssign) { goto errorInLappendListPtr; } @@ -4668,17 +4668,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; @@ -4696,7 +4694,7 @@ TEBCresume( Tcl_Obj *indexListPtr = value2Ptr; if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) && ( - !TclHasInternalRep(value2Ptr, &tclListType.objType) + !TclHasInternalRep(value2Ptr, &tclListType) || ((Tcl_ListObjLength(interp,value2Ptr,&value2Length), value2Length == 1 @@ -4754,34 +4752,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 >= 0 && 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; @@ -4854,8 +4848,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; @@ -4976,8 +4977,10 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { - objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); + if (ABSTRACTLIST_PROC(valuePtr, sliceProc)) { + if (Tcl_ObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) { + objResultPtr = NULL; + } } else { objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx); } @@ -5004,14 +5007,18 @@ TEBCresume( if (length > 0) { Tcl_Size 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); } @@ -5024,7 +5031,7 @@ TEBCresume( if (s1len == s2len) { match = (memcmp(s1, s2, s1len) == 0); } - if (isArithSeries) { + if (isAbstractList) { TclDecrRefCount(o); } i++; @@ -6368,7 +6375,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); @@ -6436,7 +6443,7 @@ TEBCresume( } if (Tcl_IsShared(listPtr)) { objPtr = TclDuplicatePureObj( - interp, listPtr, &tclListType.objType); + interp, listPtr, &tclListType); if (!objPtr) { goto gotError; } @@ -8398,7 +8405,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", -1)); diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 3206a4f..215c6c7 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -380,7 +380,7 @@ ExecuteCallback( Tcl_InterpState state = NULL; int res = TCL_OK; Tcl_Obj *command = TclDuplicatePureObj( - interp, dataPtr->command, &tclListType.objType); + interp, dataPtr->command, &tclListType); if (!command) { return TCL_ERROR; } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index c7cbfe5..a657021 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2261,7 +2261,7 @@ NewReflectedChannel( rcPtr->mode = mode; rcPtr->interest = 0; /* Initially no interest registered */ - rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType.objType); + rcPtr->cmd = TclDuplicatePureObj(interp, cmdpfxObj, &tclListType); if (!rcPtr->cmd) { return NULL; } @@ -2401,7 +2401,7 @@ InvokeTclMethod( * before the channel id. */ - cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType.objType); + cmd = TclDuplicatePureObj(NULL, rcPtr->cmd, &tclListType); if (!cmd) { return TCL_ERROR; } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index cec6ad3..57c9fe7 100644..100755 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1687,7 +1687,7 @@ Tcl_FSEvalFileEx( use the utf-8 encoding. */ { Tcl_Size length; - int result = TCL_ERROR; + int result = TCL_ERROR; Tcl_StatBuf statBuf; Tcl_Obj *oldScriptFile; Interp *iPtr; @@ -1802,7 +1802,7 @@ Tcl_FSEvalFileEx( const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); unsigned limit = 150; - int overflow = (length > limit); + int overflow = ((unsigned)length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", @@ -1954,7 +1954,7 @@ EvalFileCallback( Tcl_Size length; const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); - const unsigned int limit = 150; + const unsigned limit = 150; int overflow = (length > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( diff --git a/generic/tclInt.h b/generic/tclInt.h index 497c3a5..a4dca79 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1086,20 +1086,39 @@ 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 { - Tcl_Size (*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) +#define ABSTRACTLIST_PROC(objPtr, proc) \ + (((objPtr)->typePtr \ + && (objPtr)->typePtr->version == TCL_OBJTYPE_CURRENT) ? \ + ((objPtr)->typePtr)->proc : NULL) MODULE_SCOPE Tcl_Size 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)) + + /* * 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 @@ -2613,7 +2632,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( \ @@ -2625,12 +2644,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, @@ -2650,27 +2669,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) \ @@ -2678,13 +2697,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) \ && ((objPtr)->internalRep.wideValue <= endValue)) \ ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) @@ -2698,7 +2717,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))) @@ -2973,13 +2992,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; @@ -3359,6 +3377,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, Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); @@ -4871,7 +4892,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; /* @@ -4903,7 +4924,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) \ @@ -4911,7 +4932,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) /* @@ -4936,7 +4957,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) @@ -4955,7 +4976,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) @@ -4970,7 +4991,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 7474769..b136709 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 6288ffb..de74539 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(TclHasInternalRep((listObj_), &tclListType.objType)) + LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType)) /* * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the @@ -151,15 +150,22 @@ static Tcl_Size 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 */ @@ -205,7 +211,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_) \ @@ -1251,7 +1257,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) { @@ -1622,12 +1628,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; } @@ -1907,6 +1920,7 @@ Tcl_ListObjIndex( { Tcl_Obj **elemObjs; Tcl_Size numElems; + int hasAbstractList = ABSTRACTLIST_PROC(listObj,indexProc) != 0; /* Empty string => empty list. Avoid unnecessary shimmering */ if (listObj->bytes == &tclEmptyString) { @@ -1914,6 +1928,9 @@ Tcl_ListObjIndex( return TCL_OK; } + if (hasAbstractList) { + return Tcl_ObjTypeIndex(interp, listObj, index, objPtrPtr); + } if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs) != TCL_OK) { return TCL_ERROR; @@ -2048,6 +2065,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 */ @@ -2527,7 +2549,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, TCL_SIZE_MAX - 1, &index) == TCL_OK) { /* @@ -2548,7 +2570,7 @@ TclLindexList( * does not. */ - indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType.objType); + indexListCopy = TclDuplicatePureObj(interp, argObj, &tclListType); if (!indexListCopy) { /* * The argument is neither an index nor a well-formed list. @@ -2609,9 +2631,9 @@ TclLindexFlat( int status; 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++) { @@ -2619,12 +2641,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); @@ -2668,7 +2692,7 @@ TclLindexFlat( * Must set the internal rep again because it may have been * changed by TclGetIntForIndexM. See test lindex-8.4. */ - if (!TclHasInternalRep(listObj, &tclListType.objType)) { + if (!TclHasInternalRep(listObj, &tclListType)) { status = SetListFromAny(interp, listObj); if (status != TCL_OK) { /* The list is not a list at all => error. */ @@ -2740,16 +2764,26 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (!TclHasInternalRep(indexArgObj, &tclListType.objType) - && TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index) - == TCL_OK) { + if (!TclHasInternalRep(indexArgObj, &tclListType) && + TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_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); + } indexListCopy = TclDuplicatePureObj( - interp, indexArgObj, &tclListType.objType); + interp, indexArgObj, &tclListType); if (!indexListCopy) { /* * indexArgPtr designates something that is neither an index nor a @@ -2772,7 +2806,10 @@ TclLsetList( */ retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj); - Tcl_DecrRefCount(indexListCopy); + if (indexListCopy) { + Tcl_DecrRefCount(indexListCopy); + } + return retValueObj; } @@ -2847,7 +2884,7 @@ TclLsetFlat( */ subListObj = Tcl_IsShared(listObj) - ? TclDuplicatePureObj(interp, listObj, &tclListType.objType) : listObj; + ? TclDuplicatePureObj(interp, listObj, &tclListType) : listObj; if (!subListObj) { return NULL; } @@ -2934,7 +2971,7 @@ TclLsetFlat( } if (Tcl_IsShared(subListObj)) { subListObj = TclDuplicatePureObj( - interp, subListObj, &tclListType.objType); + interp, subListObj, &tclListType); if (!subListObj) { return NULL; } @@ -2958,7 +2995,7 @@ TclLsetFlat( if (Tcl_IsShared(subListObj)) { Tcl_Obj * newSubListObj; newSubListObj = TclDuplicatePureObj( - interp, subListObj, &tclListType.objType); + interp, subListObj, &tclListType); if (copied) { Tcl_DecrRefCount(subListObj); } @@ -3289,35 +3326,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; - } - Tcl_IncrRefCount(elemPtrs[j]); + + /* 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); @@ -3399,7 +3433,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 cdd3b5d..259c26e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -228,45 +228,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) }; /* @@ -388,15 +416,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; @@ -1613,7 +1650,9 @@ int SetDuplicatePureObj( { char *bytes = objPtr->bytes; int status = TCL_OK; - + const Tcl_ObjType *useTypePtr = + objPtr->typePtr ? objPtr->typePtr : typePtr; + TclInvalidateStringRep(dupPtr); assert(dupPtr->typePtr == NULL); @@ -1624,13 +1663,13 @@ int SetDuplicatePureObj( dupPtr->typePtr = objPtr->typePtr; } - if (typePtr != NULL && dupPtr->typePtr != typePtr) { + if (typePtr != NULL && dupPtr->typePtr != useTypePtr) { if (bytes) { dupPtr->bytes = bytes; dupPtr->length = objPtr->length; } /* borrow bytes from original object */ - status = Tcl_ConvertToType(interp, dupPtr, typePtr); + status = Tcl_ConvertToType(interp, dupPtr, useTypePtr); if (bytes) { dupPtr->bytes = NULL; dupPtr->length = 0; @@ -1653,7 +1692,7 @@ int SetDuplicatePureObj( if (bytes && (dupPtr->typePtr == NULL || dupPtr->typePtr->updateStringProc == NULL - || typePtr == &tclStringType + || useTypePtr == &tclStringType ) ) { TclInitStringRep(dupPtr, bytes, objPtr->length); @@ -2137,11 +2176,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 @@ -2158,7 +2197,7 @@ Tcl_GetBoolFromObj( result = (d != 0.0); goto boolEnd; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { result = 1; boolEnd: if (charPtr != NULL) { @@ -2226,18 +2265,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; } } @@ -2368,13 +2407,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; } @@ -2466,7 +2505,7 @@ Tcl_DbNewDoubleObj( objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType.objType; + objPtr->typePtr = &tclDoubleType; return objPtr; } @@ -2539,7 +2578,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( @@ -2552,11 +2595,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); @@ -2770,12 +2813,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 @@ -2794,7 +2837,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\"", @@ -2803,7 +2846,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 @@ -3031,11 +3074,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\"", @@ -3044,7 +3087,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. @@ -3116,7 +3159,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) { @@ -3130,10 +3173,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. @@ -3200,11 +3243,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\"", @@ -3213,7 +3256,7 @@ TclGetWideBitsFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType.objType) { + if (objPtr->typePtr == &tclBignumType) { mp_int big; mp_err err; @@ -3317,7 +3360,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"); @@ -3487,7 +3530,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; @@ -3512,14 +3555,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\"", @@ -3679,7 +3722,7 @@ TclSetBignumInternalRep( void *big) { mp_int *bignumValue = (mp_int *)big; - objPtr->typePtr = &tclBignumType.objType; + objPtr->typePtr = &tclBignumType; PACK_BIGNUM(*bignumValue, objPtr); /* @@ -3722,7 +3765,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 { @@ -3731,12 +3774,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)); @@ -4697,7 +4740,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 b7bd94a..774d499 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1046,7 +1046,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 5a173af..03a7ab7 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)) { Tcl_Size 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 f0dd5bc..4bfd810 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -741,6 +741,10 @@ Tcltest_Init( } #endif + if (Tcl_ABSListTest_Init(interp) != TCL_OK) { + return TCL_ERROR; + } + /* * Check for special options used in ../tests/main.test */ @@ -8802,4 +8806,3 @@ vamoose: * indent-tabs-mode: nil * End: */ - diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c new file mode 100644 index 0000000..13fc799 --- /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*)lstringObj->internalRep.twoPtrValue.ptr1; + + (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 *)lstringObjPtr->internalRep.twoPtrValue.ptr1; + 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*)srcPtr->internalRep.twoPtrValue.ptr1; + 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*)lstringObj->internalRep.twoPtrValue.ptr1; + 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*)returnObj->internalRep.twoPtrValue.ptr1; + + 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*)lstringObj->internalRep.twoPtrValue.ptr1; + 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*)srcObj->internalRep.twoPtrValue.ptr1; + 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*)listObj->internalRep.twoPtrValue.ptr1; + 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*)lstringObj->internalRep.twoPtrValue.ptr1; + 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*)lstringObj->internalRep.twoPtrValue.ptr1; + 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/tclTestObj.c b/generic/tclTestObj.c index 6ad45e9..5271a54 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -974,12 +974,13 @@ TestlistobjCmd( != TCL_OK) { return TCL_ERROR; } - if (objP->refCount <= 0) { + if (objP->refCount < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Tcl_ListObjIndex returned object with ref count <= 0", + "Tcl_ListObjIndex returned object with ref count < 0", TCL_INDEX_NONE)); /* Keep looping since we are also looping for leaks */ } + Tcl_BumpObj(objP); } break; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index cf6dc75..5426bdf 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -123,17 +123,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) }; - + Tcl_Size TclLengthOne( TCL_UNUSED(Tcl_Obj *)) @@ -1975,7 +1982,8 @@ Tcl_ConcatObj( Tcl_Size length; objPtr = objv[i]; - if (TclListObjIsCanonical(objPtr)) { + if (TclListObjIsCanonical(objPtr) || + ABSTRACTLIST_PROC(objPtr,indexProc)) { continue; } (void)Tcl_GetStringFromObj(objPtr, &length); @@ -1987,7 +1995,8 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (!TclListObjIsCanonical(objPtr)) { + if (!TclListObjIsCanonical(objPtr) && + !ABSTRACTLIST_PROC(objPtr,indexProc)) { continue; } if (resPtr) { @@ -2005,7 +2014,7 @@ Tcl_ConcatObj( } } else { resPtr = TclDuplicatePureObj( - NULL, objPtr, &tclListType.objType); + NULL, objPtr, &tclListType); if (!resPtr) { return NULL; } @@ -3497,7 +3506,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; Tcl_Size length; const char *bytes = Tcl_GetStringFromObj(objPtr, &length); @@ -3683,7 +3692,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; @@ -3835,7 +3844,7 @@ TclIndexEncode( */ const Tcl_ObjInternalRep *irPtr = - TclFetchInternalRep(objPtr, &endOffsetType.objType); + TclFetchInternalRep(objPtr, &endOffsetType); if (irPtr && irPtr->wideValue >= 0) { /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 32ee631..dcb4db4 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) \ @@ -3097,7 +3099,7 @@ ArrayForNRCmd( * loop) don't vanish. */ - varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType.objType); + varListObj = TclDuplicatePureObj(interp, objv[1], &tclListType); if (!varListObj) { return TCL_ERROR; } @@ -4074,7 +4076,7 @@ ArraySetCmd( */ copyListObj = - TclDuplicatePureObj(interp, arrayElemObj, &tclListType.objType); + TclDuplicatePureObj(interp, arrayElemObj, &tclListType); if (!copyListObj) { return TCL_ERROR; } 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 1515675..f0e11fb 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 543ad89..a4055b1 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 @@ -443,6 +444,21 @@ test lseq-3.31 {lreverse inplace with doubles} {arithSeriesDouble has64BitLength # lsearch - # -- should not shimmer lseq list # -- should not leak lseq elements +test lseq-3.32 {lsearch nested lists of lseq} arithSeriesShimmer { + set srchlist {} + for {set i 5} {$i < 25} {incr i} { + lappend srchlist [lseq $i count 7 by 3] + } + set a [lsearch -all -inline -index 1 $srchlist 23] + set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}] + list [lindex [tcl::unsupported::representation $a] 3] $a $b \ + [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] +} {list {{20 23 26 29 32 35 38}} arithseries arithseries} + + +# lsearch - +# -- should not shimmer lseq list +# -- should not leak lseq elements test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body { set srchlist {} for {set i 5} {$i < 25} {incr i} { @@ -545,9 +561,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} diff --git a/unix/Makefile.in b/unix/Makefile.in index e7dee7a..5b6c542 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/unix/tclConfig.h.in b/unix/tclConfig.h.in index 4d8230a..658ba11 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -444,7 +444,7 @@ /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS -/* Do 'long' and 'long long' have the same size (64-bit)? */ +/* 'long' and 'long long' have the same size */ #undef TCL_WIDE_INT_IS_LONG /* Tcl with external libtommath */ diff --git a/win/Makefile.in b/win/Makefile.in index 2713e73..2bde8b6 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 e5f0b43..ceb2903e 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) $?
|