From 0bc040dc409a30e0269975baec7cca5ac29a99ae Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 19 Oct 2022 04:35:15 +0000 Subject: More work on lset support in AbstractLists --- generic/tcl.decls | 3 +++ generic/tcl.h | 2 +- generic/tclAbstractList.c | 36 ++++++++++++++++++++++++++++++++++++ generic/tclAbstractList.h | 3 ++- generic/tclCmdIL.c | 9 +++++++-- generic/tclDecls.h | 7 +++++++ generic/tclListObj.c | 18 ++++++++++++++---- generic/tclStubInit.c | 1 + tests/lseq.test | 6 ++++++ 9 files changed, 77 insertions(+), 8 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 459534a..75eac1e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2564,6 +2564,9 @@ declare 689 { declare 690 { void *Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr) } +declare 691 { + Tcl_Obj *Tcl_AbstractListSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indicies, Tcl_Obj *valueObj) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tcl.h b/generic/tcl.h index 535ae39..00c0462 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -743,7 +743,7 @@ typedef int (Tcl_ALGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr int *objcptr, struct Tcl_Obj ***objvptr); typedef void (Tcl_ALFreeConcreteRep) (struct Tcl_Obj *listPtr); typedef void (Tcl_ALToStringRep) (struct Tcl_Obj *listPtr); -typedef int (Tcl_ALSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, +typedef struct Tcl_Obj* (Tcl_ALSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, struct Tcl_Obj *indicies, struct Tcl_Obj *valueObj); diff --git a/generic/tclAbstractList.c b/generic/tclAbstractList.c index 5f9466d..209e9ac 100644 --- a/generic/tclAbstractList.c +++ b/generic/tclAbstractList.c @@ -628,6 +628,42 @@ void* Tcl_AbstractListGetConcreteRep( return objPtr->internalRep.twoPtrValue.ptr2; } +/* Replace or add the element in the list @indicies with the given new value + */ +Tcl_Obj * +Tcl_AbstractListSetElement( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj *indicies, + Tcl_Obj *valueObj) +{ + Tcl_Obj *returnObj = NULL; + + if (TclHasInternalRep(objPtr,&tclAbstractListType)) { + Tcl_AbstractListType *typePtr = Tcl_AbstractListGetType(objPtr); + if (TclAbstractListHasProc(objPtr, TCL_ABSL_SETELEMENT)) { + returnObj = typePtr->setElementProc(interp, objPtr, indicies, valueObj); + } else { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("SetElement not supported!", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + returnObj = NULL; + } + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an abstract list")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + returnObj = NULL; + } + return returnObj; +} + /* * Local Variables: * mode: c diff --git a/generic/tclAbstractList.h b/generic/tclAbstractList.h index 561d7ba..1c92b42 100644 --- a/generic/tclAbstractList.h +++ b/generic/tclAbstractList.h @@ -41,7 +41,8 @@ int Tcl_AbstractListObjGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int Tcl_Obj ***objvPtr); Tcl_Obj * Tcl_AbstractListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); void * Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr); - +Tcl_Obj * Tcl_AbstractListSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj *indicies, Tcl_Obj *valueObj); #endif diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 23fca3f..2ce9779 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4390,11 +4390,16 @@ Tcl_LsetObjCmd( * unshared copy of it. */ - if (objc == 4) { + if (TclHasInternalRep(listPtr,&tclAbstractListType) && + TclAbstractListHasProc(listPtr, TCL_ABSL_SETELEMENT) && + objc == 4) { + finalValuePtr = Tcl_AbstractListSetElement(interp, listPtr, objv[2], objv[3]); + if (finalValuePtr) Tcl_IncrRefCount(finalValuePtr); + } else if (objc == 4) { finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); + objv[objc-1]); } /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index a4ea41f..8432945 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2040,6 +2040,10 @@ EXTERN Tcl_Obj * Tcl_AbstractListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); /* 690 */ EXTERN void * Tcl_AbstractListGetConcreteRep(Tcl_Obj *objPtr); +/* 691 */ +EXTERN Tcl_Obj * Tcl_AbstractListSetElement(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Obj *indicies, + Tcl_Obj *valueObj); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2766,6 +2770,7 @@ typedef struct TclStubs { int (*tcl_AbstractListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 688 */ Tcl_Obj * (*tcl_AbstractListObjCopy) (Tcl_Interp *interp, Tcl_Obj *listPtr); /* 689 */ void * (*tcl_AbstractListGetConcreteRep) (Tcl_Obj *objPtr); /* 690 */ + Tcl_Obj * (*tcl_AbstractListSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indicies, Tcl_Obj *valueObj); /* 691 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4176,6 +4181,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AbstractListObjCopy) /* 689 */ #define Tcl_AbstractListGetConcreteRep \ (tclStubsPtr->tcl_AbstractListGetConcreteRep) /* 690 */ +#define Tcl_AbstractListSetElement \ + (tclStubsPtr->tcl_AbstractListSetElement) /* 691 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 24082ec..5fe3819 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2761,12 +2761,22 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (!TclHasInternalRep(indexArgObj, &tclListType) - && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) - == TCL_OK) { + if (!TclHasInternalRep(indexArgObj, &tclListType) && + TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) + == TCL_OK) { + + if (TclHasInternalRep(listObj,&tclAbstractListType) && + TclAbstractListHasProc(listObj, TCL_ABSL_SETELEMENT)) { + Tcl_Obj *returnValue = + Tcl_AbstractListSetElement(interp, listObj, indexArgObj, valueObj); + if (returnValue) Tcl_IncrRefCount(returnValue); + return returnValue; + } + /* indexArgPtr designates a single index. */ - /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ + /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); + } indexListCopy = TclListObjCopy(NULL, indexArgObj); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c2b83a8..c1d288e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2056,6 +2056,7 @@ const TclStubs tclStubs = { Tcl_AbstractListObjGetElements, /* 688 */ Tcl_AbstractListObjCopy, /* 689 */ Tcl_AbstractListGetConcreteRep, /* 690 */ + Tcl_AbstractListSetElement, /* 691 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/lseq.test b/tests/lseq.test index 2e5d7e1..c5adbae 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -510,6 +510,12 @@ test lseq-4.5 {lindex off by one} -body { unset res } -result {4 3} +test lseq-4.6 {lset shimmer} -body { + set l [lseq 15] + lappend res $l [lindex [tcl::unsupported::representation $l] 3] + lset l 3 25 + lappend res $l [lindex [tcl::unsupported::representation $l] 3] +} -result {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries {0 1 2 25 4 5 6 7 8 9 10 11 12 13 14} list} # cleanup ::tcltest::cleanupTests -- cgit v0.12