From 6d3452eeac482d86c96b2bb357130a6f5ac9eb09 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 25 Oct 2022 01:13:45 +0000 Subject: Add AbstractList regression test (exercise the C API) --- generic/tclAbstractList.h | 14 +- generic/tclCmdIL.c | 9 +- generic/tclExecute.c | 1 + generic/tclInt.h | 1 + generic/tclListObj.c | 3 +- generic/tclTest.c | 5 +- generic/tclTestABSList.c | 580 ++++++++++++++++++++++++++++++++++++++++++++++ tests/abstractlist.test | 133 +++++++++++ unix/Makefile.in | 9 +- win/makefile.vc | 4 + 10 files changed, 739 insertions(+), 20 deletions(-) create mode 100644 generic/tclTestABSList.c create mode 100644 tests/abstractlist.test diff --git a/generic/tclAbstractList.h b/generic/tclAbstractList.h index 09d6dbe..c3dd14b 100644 --- a/generic/tclAbstractList.h +++ b/generic/tclAbstractList.h @@ -29,7 +29,7 @@ Tcl_AbstractListTypeName( } } -Tcl_Obj * Tcl_AbstractListObjNew(Tcl_Interp *interp, const Tcl_AbstractListType *); +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_WideInt index, Tcl_Obj **elemObj); @@ -42,14 +42,10 @@ int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int Tcl_Obj * Tcl_AbstractListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); void * Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr); Tcl_Obj * Tcl_AbstractListSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *indicies, Tcl_Obj *valueObj); -int Tcl_AbstractListObjReplace( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *listObj, /* 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 */ + Tcl_Obj *indicies, 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 diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index b4c1fa8..0a4c9f4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2216,8 +2216,7 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclHasInternalRep(objv[1],&tclAbstractListType) && - TclAbstractListHasProc(objv[1], TCL_ABSL_GETELEMENTS)) { + if (TclAbstractListHasProc(objv[1], TCL_ABSL_GETELEMENTS)) { listLen = Tcl_AbstractListObjLength(objv[1]); isAbstractList = (listLen ? 1 : 0); if (listLen > 1 && @@ -3125,8 +3124,7 @@ Tcl_LreverseObjCmd( * 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],&tclAbstractListType) && - TclAbstractListHasProc(objv[1], TCL_ABSL_REVERSE)) { + if (TclAbstractListHasProc(objv[1], TCL_ABSL_REVERSE)) { Tcl_Obj *resultObj; if (Tcl_AbstractListObjReverse(interp, objv[1], &resultObj) == TCL_OK) { @@ -4697,8 +4695,7 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - if (TclHasInternalRep(listObj,&tclAbstractListType) && - TclAbstractListHasProc(objv[1], TCL_ABSL_GETELEMENTS)) { + if (TclAbstractListHasProc(objv[1], TCL_ABSL_GETELEMENTS)) { sortInfo.resultCode = Tcl_AbstractListObjGetElements(interp, listObj, &length, &listObjPtrs); } else { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 795b48d..ab41550 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4888,6 +4888,7 @@ TEBCresume( * Extract the desired list element. */ + /* TODO: handle AbstractList here? */ if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; diff --git a/generic/tclInt.h b/generic/tclInt.h index 54be442..cf3e0ca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4833,6 +4833,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; /* *---------------------------------------------------------------- diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 351e721..5df2e78 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1667,8 +1667,7 @@ Tcl_ListObjGetElements( { ListRep listRep; - if (TclHasInternalRep(objPtr,&tclAbstractListType) && - TclAbstractListHasProc(objPtr, TCL_ABSL_GETELEMENTS) && + if (TclAbstractListHasProc(objPtr, TCL_ABSL_GETELEMENTS) && Tcl_AbstractListObjGetElements(interp, objPtr, objcPtr, objvPtr) == TCL_OK) { return TCL_OK; } else if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { diff --git a/generic/tclTest.c b/generic/tclTest.c index ee6062b..88ba8b1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -768,6 +768,10 @@ Tcltest_Init( } #endif + if (Tcl_ABSListTest_Init(interp) != TCL_OK) { + return TCL_ERROR; + } + /* * Check for special options used in ../tests/main.test */ @@ -8475,4 +8479,3 @@ int TestApplyLambdaObjCmd ( * indent-tabs-mode: nil * End: */ - diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c new file mode 100644 index 0000000..1ddc442 --- /dev/null +++ b/generic/tclTestABSList.c @@ -0,0 +1,580 @@ +// Tcl Abstract List test command: "lstring" +#include +#include +#include "tcl.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_Obj *indicies, + Tcl_Obj *valueObj); +static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static Tcl_WideInt my_LStringObjLength(Tcl_Obj *lstringObjPtr); +static int my_LStringObjIndex(Tcl_Interp *interp, + Tcl_Obj *lstringObj, + Tcl_WideInt index, + Tcl_Obj **charObjPtr); +static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj, + Tcl_WideInt fromIdx, Tcl_WideInt 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_WideInt first, + Tcl_WideInt numToDelete, + Tcl_WideInt numToInsert, + Tcl_Obj *const insertObjs[]); + +/* + * Internal Representation of an lstring type value + */ + +typedef struct LString { + char *string; // NULL terminated utf-8 string + Tcl_WideInt strlen; // num bytes in string + Tcl_WideInt allocated; // num bytes allocated +} LString; + +/* + * AbstractList definition of an lstring type + */ +static Tcl_AbstractListType lstringType = { + TCL_ABSTRACTLIST_VERSION_1, + "lstring", + NULL, + DupLStringRep, + my_LStringObjLength, + my_LStringObjIndex, + my_LStringObjRange,/*ObjRange*/ + my_LStringObjReverse, + NULL/*my_LStringGetElements*/, + freeRep, + NULL /*toString*/, + my_LStringObjSetElem, /* use default update string */ + my_LStringReplace +}; + + + + +/* + *---------------------------------------------------------------------- + * + * 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_WideInt index, + Tcl_Obj **charObjPtr) +{ + LString *lstringRepPtr = (LString*)Tcl_AbstractListGetConcreteRep(lstringObj); + + (void)interp; + + if (0 <= index && 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_WideInt +my_LStringObjLength(Tcl_Obj *lstringObjPtr) +{ + LString *lstringRepPtr = (LString *)Tcl_AbstractListGetConcreteRep(lstringObjPtr); + return lstringRepPtr->strlen; +} + + +/* + *---------------------------------------------------------------------- + * + * DupLStringRep -- + * + * Replicates the internal representation of the src value, and storing + * it in the copy + * + * Results: + * void + * + * Side effects: + * Modifies the rep of the copyObj. + * + *---------------------------------------------------------------------- + */ + +static void +DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) +{ + LString *srcLString = (LString*)Tcl_AbstractListGetConcreteRep(srcPtr); + LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString)); + + memcpy(copyLString, srcLString, sizeof(LString)); + copyLString->string = (char*)Tcl_Alloc(srcLString->allocated); + strcpy(copyLString->string, srcLString->string); + Tcl_AbstractListSetConcreteRep(copyPtr,copyLString); + + 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_Obj *indicies, + Tcl_Obj *valueObj) +{ + LString *lstringRepPtr = (LString*)Tcl_AbstractListGetConcreteRep(lstringObj); + int indc; + Tcl_Obj **indv; + int index; + const char *newvalue; + int status; + Tcl_Obj *returnObj; + + if (Tcl_ListObjGetElements(interp, indicies, &indc, &indv) != TCL_OK) { + return NULL; + } + + if (indc > 1) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Multiple indicies not supported by lstring.")); + return NULL; + } + + status = Tcl_GetIntForIndex(interp, indv[0], lstringRepPtr->strlen, &index); + if (status != TCL_OK) { + return NULL; + } + + returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj; + lstringRepPtr = (LString*)Tcl_AbstractListGetConcreteRep(returnObj); + + if (index < 0) { + index = 0; + } + 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_WideInt fromIdx, + Tcl_WideInt toIdx, + Tcl_Obj **newObjPtr) +{ + Tcl_Obj *rangeObj; + LString *lstringRepPtr = (LString*)Tcl_AbstractListGetConcreteRep(lstringObj); + LString *rangeRep; + Tcl_WideInt len = toIdx - fromIdx + 1; + + if ((fromIdx < 0 || lstringRepPtr->strlen < fromIdx) || + (toIdx < 0 || lstringRepPtr->strlen < toIdx)) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Range out of bounds ")); + return TCL_ERROR; + } + + rangeObj = Tcl_AbstractListObjNew(interp, &lstringType); + + 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; + Tcl_AbstractListSetConcreteRep(rangeObj, rangeRep); + *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) +{ + Tcl_Obj *revObj = Tcl_AbstractListObjNew(interp, &lstringType); + LString *srcRep = (LString*)Tcl_AbstractListGetConcreteRep(srcObj); + LString *revRep = (LString*)Tcl_Alloc(sizeof(LString)); + Tcl_WideInt len; + char *srcp, *dstp, *endp; + len = srcRep->strlen; + revRep->strlen = len; + revRep->allocated = len+1; + revRep->string = (char*)Tcl_Alloc(revRep->allocated); + srcp = srcRep->string; + endp = &srcRep->string[len]; + dstp = &revRep->string[len]; + *dstp-- = 0; + while (srcp < endp) { + *dstp-- = *srcp++; + } + Tcl_AbstractListSetConcreteRep(revObj, revRep); + *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_WideInt first, + Tcl_WideInt numToDelete, + Tcl_WideInt numToInsert, + Tcl_Obj *const insertObjs[]) +{ + LString *lstringRep = (LString*)Tcl_AbstractListGetConcreteRep(listObj); + Tcl_WideInt newLen; + Tcl_WideInt x, ix, kx; + char *newStr; + char *oldStr = lstringRep->string; + (void)interp; + + if (numToDelete < 0) numToDelete = 0; + if (numToInsert < 0) numToInsert = 0; + + newLen = lstringRep->strlen - numToDelete + numToInsert; + + if (newLen >= lstringRep->allocated) { + lstringRep->allocated = newLen+1; + newStr = 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; xstrlen && xstring = newStr; + lstringRep->strlen = newLen; + + /* Changes made to value, string rep no longer valid */ + Tcl_InvalidateStringRep(listObj); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * 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; + size_t repSize; + Tcl_Obj *lstringPtr; + const char *string; + + if (objc != 1) { + return NULL; + } + string = Tcl_GetString(objv[0]); + + repSize = sizeof(LString); + lstringPtr = Tcl_AbstractListObjNew(interp, &lstringType); + lstringRepPtr = (LString*)Tcl_Alloc(repSize); + lstringRepPtr->strlen = strlen(string); + lstringRepPtr->allocated = lstringRepPtr->strlen + 1; + lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated); + strcpy(lstringRepPtr->string, string); + Tcl_AbstractListSetConcreteRep(lstringPtr, lstringRepPtr); + if (lstringRepPtr->strlen > 0) { + Tcl_InvalidateStringRep(lstringPtr); + } else { + Tcl_InitStringRep(lstringPtr, NULL, 0); + } + + return lstringPtr; +} + +/* + *---------------------------------------------------------------------- + * + * freeRep -- + * + * Free the value storage of the lstring Obj. + * + * Results: + * void + * + * Side effects: + * Memory free'd. + * + *---------------------------------------------------------------------- + */ + +static void +freeRep(Tcl_Obj* lstringObj) +{ + LString *lstringRepPtr = (LString*)Tcl_AbstractListGetConcreteRep(lstringObj); + if (lstringRepPtr->string) { + Tcl_Free(lstringRepPtr->string); + } + Tcl_Free((char*)lstringRepPtr); + Tcl_AbstractListSetConcreteRep(lstringObj, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * 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/tests/abstractlist.test b/tests/abstractlist.test new file mode 100644 index 0000000..7b9b2c5 --- /dev/null +++ b/tests/abstractlist.test @@ -0,0 +1,133 @@ +# Exercise AbstractList API 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::* +} + +proc value-isa {var {expected ""}} { + upvar $var v + set t [lindex [tcl::unsupported::representation $v] 3] + if {$expected ne "" && $expected ne $t} { + set fail " expecting: $expected" + } else { + set fail "" + } + return "value in $var is a $t$fail" +} + +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 [value-isa l] + set len [llength $l] + set l-isa2 [value-isa 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 !} {value in l is a lstring} 63 {value in l is a lstring}} + +test abstractlist-2.1 {no shimmer lindex} { + set l [lstring $str] + set l-isa [value-isa l] + set ele [lindex $l 22] + set l-isa2 [value-isa 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 !} {value in l is a lstring} y {value in l is a lstring}} + +test abstractlist-2.2 {no shimmer lreverse} { + set l [lstring $str] + set l-isa [value-isa l] + set r [lreverse $l] + set r-isa [value-isa r] + set l-isa2 [value-isa 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} {value in l is a lstring} {value in r is a lstring} {value in l is a lstring}} + +test abstractlist-2.3 {no shimmer lrange} { + set l [lstring $str] + set l-isa [value-isa l] + set il [lsearch -all [lstring $str] { }] + set l-isa2 [value-isa 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 [value-isa l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {{value in l is a lstring} {2 7 10 16 25 29 36 39 47 55 58 63} {value in l is a lstring} {value in l is a 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 [value-isa 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 [value-isa l] + list ${l-isa} ${l-isa2} $words +} {{value in l is a lstring} {value in l is a 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 results is a list, not an lstring. +# +test abstractlist-2.5 {!no shimmer lreplace} { + set l [lstring $str2] + set l-isa [value-isa l] + set m [lreplace $l 18 23 { } f a i l ?] + set m-isa [value-isa m] + set l-isa1 [value-isa l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {{value in l is a 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 .} {value in m is a list} {value in l is a lstring}} + +test abstractlist-2.6 {no shimmer ledit} { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [value-isa l] + set e [ledit l 9 8 S] + set e-isa [value-isa e] + #puts [list linsert {$m} 13 {*}[split "almost " {}]] + #puts [linsert $m 13 {*}[split "almost " {}]] + list ${l-isa} $e ${e-isa} +} {{value in l is a 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 .} {value in e is a lstring}} + +test abstractlist-2.7 {no shimmer linsert} { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [value-isa l] + set i [linsert $l 12 {*}[split "almost " {}]] + set i-isa [value-isa i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [value-isa p] + set i-isa2 [value-isa i] + lappend res $p ${p-isa} $i ${i-isa2} +} {{value in l is a 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 .} {value in i is a lstring} ' {value in p is a pure} {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 .} {value in i is a list}} diff --git a/unix/Makefile.in b/unix/Makefile.in index 58b42d1..8ef64d4 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 \ tclAbstractList.o tclArithSeries.o tclAlloc.o \ @@ -469,6 +470,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 \ @@ -1540,6 +1542,9 @@ tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c +tclTestABSList.o: $(GENERIC_DIR)/tclTestABSList.c $(MATHHDRS) + $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestABSList.c + tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c diff --git a/win/makefile.vc b/win/makefile.vc index 6232458..92eafd1 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -227,6 +227,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 @@ -828,6 +829,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) $? -- cgit v0.12