From 82a85e5b1eb378f5a45526e1b098459f6b848f42 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 5 Apr 2022 07:18:37 +0000 Subject: RFE [655300]: Deprecate Tcl_MakeSafe() --- doc/CrtAlias.3 | 1 + generic/tcl.decls | 2 +- generic/tclDecls.h | 5 +++-- generic/tclInt.h | 2 ++ generic/tclInterp.c | 6 +++--- generic/tclStubInit.c | 2 ++ 6 files changed, 12 insertions(+), 6 deletions(-) diff --git a/doc/CrtAlias.3 b/doc/CrtAlias.3 index 2623dcd..77a3bc2 100644 --- a/doc/CrtAlias.3 +++ b/doc/CrtAlias.3 @@ -160,6 +160,7 @@ parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. Callers will want to take care with their use of \fBTcl_MakeSafe\fR to avoid false claims of safety. For many situations, \fBTcl_CreateChild\fR may be a better choice, since it creates interpreters in a known-safe state. +\fBTcl_MakeSafe\fR is deprecated and will be removed in Tcl 9.0. .PP \fBTcl_GetChild\fR returns a pointer to a child interpreter of \fIinterp\fR. The child interpreter is identified by \fIname\fR. diff --git a/generic/tcl.decls b/generic/tcl.decls index 3cf794e..95b66f9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -678,7 +678,7 @@ declare 187 { declare 189 { Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode) } -declare 190 { +declare 190 {deprecated {}} { int Tcl_MakeSafe(Tcl_Interp *interp) } declare 191 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 790cddb..9a9be7a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -602,7 +602,8 @@ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); /* 190 */ -EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); +TCL_DEPRECATED("") +int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ @@ -2188,7 +2189,7 @@ typedef struct TclStubs { int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ - int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ + TCL_DEPRECATED_API("") int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index af839fc..2546e17 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3112,6 +3112,8 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); +MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp); + MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e590775..115882b 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -2468,7 +2468,7 @@ ChildCreate( ((Interp *) parentInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(childInterp) == TCL_ERROR) { + if (TclMakeSafe(childInterp) == TCL_ERROR) { goto error; } } else { @@ -3253,7 +3253,7 @@ Tcl_IsSafe( /* *---------------------------------------------------------------------- * - * Tcl_MakeSafe -- + * TclMakeSafe -- * * Makes its argument interpreter contain only functionality that is * defined to be part of Safe Tcl. Unsafe commands are hidden, the env @@ -3270,7 +3270,7 @@ Tcl_IsSafe( */ int -Tcl_MakeSafe( +TclMakeSafe( Tcl_Interp *interp) /* Interpreter to be made safe. */ { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 257c3ce..7b682d2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -713,6 +713,7 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define TclBN_s_mp_sqr 0 # undef TclBN_s_mp_sub # define TclBN_s_mp_sub 0 +# define Tcl_MakeSafe 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld @@ -734,6 +735,7 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime +# define Tcl_MakeSafe TclMakeSafe static int seekOld( -- cgit v0.12 From 898e72c9041eb7f8e2985c08dc6a2b80a0bee24a Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 5 Jul 2022 21:32:22 +0000 Subject: (bares some resemblance to) TIP-629 Implementation. --- generic/tclBasic.c | 1 + generic/tclCmdIL.c | 283 +++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 3 + tests/range.test | 225 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 512 insertions(+) create mode 100644 tests/range.test diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5f32e7d..f40a2db 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -326,6 +326,7 @@ static const CmdInfo builtInCmds[] = { {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"range", Tcl_RangeObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f32fd98..04ab5d1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4469,6 +4469,289 @@ Tcl_LsortObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_RangeObjCmd -- + * + * This procedure is invoked to process the "range" Tcl command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RangeObjCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) + /* The argument objects. */ +{ + Tcl_WideInt elementCount, i, totalElems, status; + Tcl_Obj *const *argPtr; + Tcl_WideInt start, end, step;//, count; + Tcl_Obj *listPtr, **dataArray = NULL; + int argc, opmode, bymode; + double dstart, dend, dstep; + int really = 0; + static const char *const operations[] = { + "..", "to", "-count", "by", NULL + }; + enum Range_Operators { + RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY + }; + /* + * Check arguments for legality: + * range from op to ?by step? + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "start op end ?by step?"); + return TCL_ERROR; + } + + argc = objc; + argPtr = objv; + + /* Skip command name */ + /* Process first argument */ + argPtr++; + argc--; + + /* From argument */ + status = Tcl_GetWideIntFromObj(interp, *argPtr, &start); + if (status != TCL_OK) { + status = Tcl_GetDoubleFromObj(interp, *argPtr, &dstart); + if (status != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "double conversion for Start value: \"%s\"\n", + Tcl_GetString(*argPtr))); + return status; + } + really++; + } + + /* Process ?Op? argument */ + argPtr++; + argc--; + + /* Decode range (optional) OPeration argument */ + if (argc && + Tcl_GetIndexFromObj(interp, *argPtr, operations, "operations", 0, &opmode) == TCL_OK) { + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + opmode = RANGE_TO; + break; + case RANGE_COUNT: + break; + case RANGE_BY: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Invalid range operation, %s, must be one of \"%s\" or \"%s\".", + operations[opmode], operations[RANGE_DOTS], operations[RANGE_TO])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "BADOPERATOR", NULL); + return TCL_ERROR; + break; + } + /* next argument */ + argPtr++; + argc--; + } else { + /* Default when not specified */ + opmode = RANGE_TO; + } + + /* No more arguments, set the defaults */ + if (argc==0) { + if (really) { + dend = dstart; + dstart = 0.0; + dstep = 1.0; + } else { + end = start - (start>0?1:-1); + start = 0; + step = 1; + } + } + + /* Process To argument */ + if (argc) { + if ((status = Tcl_GetWideIntFromObj(interp, *argPtr, &end)) != TCL_OK) { + status = Tcl_GetDoubleFromObj(interp, *argPtr, &dend); + if (status != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "double conversion for End value: \"%s\"\n", + Tcl_GetString(*argPtr))); + return status; + } + really++; + if (really == 1) { + dstart = (double)start; + } + } else if (really) { + dend = (double)end; + } + + argPtr++; + argc--; + } + + /* Process ?by? argument */ + if (argc && + (Tcl_GetIndexFromObj(interp, *argPtr, operations, "operations", 0, &bymode) == TCL_OK && + bymode == RANGE_BY)) { + argPtr++; + argc--; + } + + /* Proess Step argument */ + if (argc == 0) { + step = 1; + dstep = 1; + } else { + status = Tcl_GetWideIntFromObj(interp, *argPtr, &step); + if (status != TCL_OK) { + status = Tcl_GetDoubleFromObj(interp, *argPtr, &dstep); + if (status) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "double conversion for Step value: \"%s\"\n", + Tcl_GetString(*argPtr))); + return status; + } + if (really == 0) { + dstart = (double)start; + dend = (double)end; + } + really++; + } else if (really) { + dstep = (double)step; + } + argPtr++; + argc--; + } + + /* Calculate the number of elements in the return values */ + + if (!really) { /* Integers */ + if (step == 0 + || (opmode != RANGE_COUNT + && ((step < 0 && start <= end) || (step > 0 && end < start)))) { + step = -step; + } + + if (opmode == RANGE_COUNT) { + elementCount = end; + end = start + (elementCount * step); + } else if (start <= end) { + elementCount = (end-start+1)/step; + } else { + elementCount = (start-end+1)/(-step); + } + if (elementCount < 0) { + /* TODO: implement correct error message */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%lld\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", + NULL); + return TCL_ERROR; + } + + /* Final sanity check. Do not exceed limits on max list length. */ + + if (elementCount && objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + totalElems = elementCount; + } else { + if (dstep == 0.0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid step value")); + return TCL_ERROR; + } + if ((opmode != RANGE_COUNT + && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { + // Align step direction with the start, end direction + dstep = -dstep; + } + + if (opmode == RANGE_COUNT) { + elementCount = end; + dend = dstart + (elementCount * dstep); + } else if (dstart <= dend) { + elementCount = (Tcl_WideInt)(dend-dstart+dstep)/dstep; + } else { + double absstep = dstep<0 ? -dstep : dstep; + elementCount = (Tcl_WideInt)(dstart-dend+absstep)/absstep; + } + if (elementCount < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%lld\": must be integer >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", + NULL); + return TCL_ERROR; + } + + /* Final sanity check. Do not exceed limits on max list length. */ + + if (elementCount && objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + totalElems = elementCount; + } + + /* + * Get an empty list object that is allocated large enough to hold each + * init value elementCount times. + */ + + listPtr = Tcl_NewListObj(totalElems, NULL); + if (totalElems) { + List *listRepPtr = ListRepPtr(listPtr); + + listRepPtr->elemCount = elementCount; + dataArray = &listRepPtr->elements; + } + + /* + * Set the elements. + */ + + CLANG_ASSERT(dataArray || totalElems == 0 ); + + if (!really) { + int k = 0; + + for (i=0 ; i Date: Tue, 5 Jul 2022 22:15:38 +0000 Subject: Missed step == 0 check. --- generic/tclCmdIL.c | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 04ab5d1..3bdbae7 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4622,13 +4622,24 @@ Tcl_RangeObjCmd( Tcl_GetString(*argPtr))); return status; } + if (dstep == 0.0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Step cannot be 0")); + return TCL_ERROR; + } if (really == 0) { dstart = (double)start; dend = (double)end; } really++; - } else if (really) { - dstep = (double)step; + } else { + if (step == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("Step cannot be 0")); + return TCL_ERROR; + } + if (really) { + // Some other arg is double, promote step to double + dstep = (double)step; + } } argPtr++; argc--; @@ -4670,10 +4681,6 @@ Tcl_RangeObjCmd( } totalElems = elementCount; } else { - if (dstep == 0.0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("Invalid step value")); - return TCL_ERROR; - } if ((opmode != RANGE_COUNT && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { // Align step direction with the start, end direction -- cgit v0.12 From 9d171e0b8b68db98cdbfe1652cd4976cf06ce227 Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 6 Jul 2022 19:15:41 +0000 Subject: Improve error checking and testing. --- generic/tclCmdIL.c | 151 ++++++++++++++++++++++++++++------------------------- tests/range.test | 85 ++++++++++++++++++++++++++++-- 2 files changed, 163 insertions(+), 73 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 3bdbae7..c2e0b42 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -19,6 +19,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include /* * During execution of the "lsort" command, structures of the following type @@ -4495,15 +4496,21 @@ Tcl_RangeObjCmd( Tcl_Obj *const *argPtr; Tcl_WideInt start, end, step;//, count; Tcl_Obj *listPtr, **dataArray = NULL; + Tcl_Obj *OPError = NULL, *BYError = NULL; int argc, opmode, bymode; double dstart, dend, dstep; int really = 0; static const char *const operations[] = { - "..", "to", "-count", "by", NULL + "..", "to", "-count", NULL }; enum Range_Operators { - RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY + RANGE_DOTS, RANGE_TO, RANGE_COUNT }; + static const char *const step_keywords[] = {"by", NULL}; + enum Step_Operators { + STEP_BY + }; + /* * Check arguments for legality: * range from op to ?by step? @@ -4511,7 +4518,8 @@ Tcl_RangeObjCmd( if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "start op end ?by step?"); - return TCL_ERROR; + status = TCL_ERROR; + goto done; } argc = objc; @@ -4528,9 +4536,9 @@ Tcl_RangeObjCmd( status = Tcl_GetDoubleFromObj(interp, *argPtr, &dstart); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "double conversion for Start value: \"%s\"\n", + "bad start value: \"%s\"", Tcl_GetString(*argPtr))); - return status; + goto done; } really++; } @@ -4541,7 +4549,7 @@ Tcl_RangeObjCmd( /* Decode range (optional) OPeration argument */ if (argc && - Tcl_GetIndexFromObj(interp, *argPtr, operations, "operations", 0, &opmode) == TCL_OK) { + Tcl_GetIndexFromObj(interp, *argPtr, operations, "range operation", 0, &opmode) == TCL_OK) { switch (opmode) { case RANGE_DOTS: case RANGE_TO: @@ -4549,18 +4557,17 @@ Tcl_RangeObjCmd( break; case RANGE_COUNT: break; - case RANGE_BY: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Invalid range operation, %s, must be one of \"%s\" or \"%s\".", - operations[opmode], operations[RANGE_DOTS], operations[RANGE_TO])); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "BADOPERATOR", NULL); - return TCL_ERROR; - break; } /* next argument */ argPtr++; argc--; } else { + if (objc > 3) { + OPError = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(OPError); + } else { + OPError = NULL; + } /* Default when not specified */ opmode = RANGE_TO; } @@ -4583,10 +4590,13 @@ Tcl_RangeObjCmd( if ((status = Tcl_GetWideIntFromObj(interp, *argPtr, &end)) != TCL_OK) { status = Tcl_GetDoubleFromObj(interp, *argPtr, &dend); if (status != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "double conversion for End value: \"%s\"\n", - Tcl_GetString(*argPtr))); - return status; + if (OPError) { + Tcl_SetObjResult(interp, OPError); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad end value: \"%s\"", Tcl_GetString(*argPtr))); + } + goto done; } really++; if (really == 1) { @@ -4601,11 +4611,15 @@ Tcl_RangeObjCmd( } /* Process ?by? argument */ - if (argc && - (Tcl_GetIndexFromObj(interp, *argPtr, operations, "operations", 0, &bymode) == TCL_OK && - bymode == RANGE_BY)) { - argPtr++; - argc--; + if (argc) { + if (Tcl_GetIndexFromObj(interp, *argPtr, step_keywords, "step keyword", 0, &bymode) == TCL_OK + && bymode == STEP_BY) { + argPtr++; + argc--; + } else { + BYError = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(BYError); + } } /* Proess Step argument */ @@ -4617,14 +4631,18 @@ Tcl_RangeObjCmd( if (status != TCL_OK) { status = Tcl_GetDoubleFromObj(interp, *argPtr, &dstep); if (status) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "double conversion for Step value: \"%s\"\n", - Tcl_GetString(*argPtr))); - return status; + if (BYError) { + Tcl_SetObjResult(interp, BYError); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad step value: \"%s\"\n", + Tcl_GetString(*argPtr))); + } + goto done; } if (dstep == 0.0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("Step cannot be 0")); - return TCL_ERROR; + goto done; } if (really == 0) { dstart = (double)start; @@ -4633,8 +4651,9 @@ Tcl_RangeObjCmd( really++; } else { if (step == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("Step cannot be 0")); - return TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad step value: 0")); + status = TCL_ERROR; + goto done; } if (really) { // Some other arg is double, promote step to double @@ -4658,29 +4677,11 @@ Tcl_RangeObjCmd( elementCount = end; end = start + (elementCount * step); } else if (start <= end) { - elementCount = (end-start+1)/step; + elementCount = (end-start+step)/step; } else { - elementCount = (start-end+1)/(-step); + elementCount = (start-end-step)/(-step); } - if (elementCount < 0) { - /* TODO: implement correct error message */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%lld\": must be integer >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", - NULL); - return TCL_ERROR; - } - - /* Final sanity check. Do not exceed limits on max list length. */ - - if (elementCount && objc > LIST_MAX/elementCount) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; - } - totalElems = elementCount; - } else { + } else { // double if ((opmode != RANGE_COUNT && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { // Align step direction with the start, end direction @@ -4691,29 +4692,30 @@ Tcl_RangeObjCmd( elementCount = end; dend = dstart + (elementCount * dstep); } else if (dstart <= dend) { - elementCount = (Tcl_WideInt)(dend-dstart+dstep)/dstep; + elementCount = (Tcl_WideInt)round((dend-dstart+dstep)/dstep); } else { - double absstep = dstep<0 ? -dstep : dstep; - elementCount = (Tcl_WideInt)(dstart-dend+absstep)/absstep; - } - if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%lld\": must be integer >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", - NULL); - return TCL_ERROR; + double absdstep = dstep<0 ? -dstep : dstep; + elementCount = (Tcl_WideInt)round((dstart-dend-dstep)/absdstep); } + } + if (elementCount < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%lld\": must be a number >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", NULL); + status = TCL_ERROR; + goto done; + } - /* Final sanity check. Do not exceed limits on max list length. */ + /* Final sanity check. Do not exceed limits on max list length. */ - if (elementCount && objc > LIST_MAX/elementCount) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; - } - totalElems = elementCount; + if (elementCount && objc > LIST_MAX/elementCount) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + status = TCL_ERROR; + goto done; } + totalElems = elementCount; /* * Get an empty list object that is allocated large enough to hold each @@ -4751,9 +4753,18 @@ Tcl_RangeObjCmd( dataArray[k++] = elemPtr; } } - + Tcl_SetObjResult(interp, listPtr); - return TCL_OK; + status = TCL_OK; + + done: + if (OPError) { + Tcl_DecrRefCount(OPError); + } + if (BYError) { + Tcl_DecrRefCount(BYError); + } + return status; } /* diff --git a/tests/range.test b/tests/range.test index e074144..27aeda3 100644 --- a/tests/range.test +++ b/tests/range.test @@ -30,11 +30,13 @@ test range-1.2 {step magnitude} { -result {10 8 6 4 2} } -test range-1.3 {step wrong sign} { +test range-1.3 {synergy between int and double} { -body { - range 25. to 5. by 5 ;# ditto - maybe this is an error + set rl [range 25. to 5. by 5] + set il [range 25 to 5 by 5] + lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } } - -result {25.0 20.0 15.0 10.0 5.0} + -result {1 1 1 1 1} } test range-1.4 {integer decreasing} { @@ -122,6 +124,13 @@ test range-1.15 {count with decreasing step} { -result {5 3 1 -1 -3} } +test range-1.16 {large numbers} { + -body { + range [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}] + } + -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} +} + # # Short-hand use cases # @@ -223,3 +232,73 @@ test range-2.15 {count with decreasing step} { } -result {5 3 1 -1 -3} } + +test range-2.16 {large numbers} { + -body { + range 1e6 2e6 1e5 + } + -result {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} +} + +test range-3.1 {experiement} { + -body { + set ans {} + foreach factor [range 2.0 10.0] { + set start 1 + set end 10 + for {set step 1} {$step < 1e8} {} { + set l [range $start to $end by $step] + if {[llength $l] != ($step == 1 ? 10 : 11)} { + lappend ans $factor $step [llength $l] $l + } + set step [expr {$step * $factor}] + set end [expr {$end * $factor}] + } + } + if {$ans eq {}} { + set ans OK + } + set ans + } + -result {OK} +} + +test range-3.2 {error case} { + -body { + range foo + } + -returnCodes 1 + -result {bad start value: "foo"} +} + +test range-3.3 {error case} { + -body { + range 10 foo + } + -returnCodes 1 + -result {bad end value: "foo"} +} + +test range-3.4 {error case} { + -body { + range 25 or 6 + } + -returnCodes 1 + -result {bad range operation "or": must be .., to, or -count} +} + +test range-3.5 {error case} { + -body { + range 25 by 6 + } + -returnCodes 1 + -result {bad range operation "by": must be .., to, or -count} +} + +test range-3.6 {error case} { + -body { + range 1 7 or 3 + } + -returnCodes 1 + -result {bad step keyword "or": must be by} +} -- cgit v0.12 From 1d4256a37e4dd01fbd76f44bb9f9a28603e903ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 7 Jul 2022 12:44:45 +0000 Subject: Review: 1) cleanupTests missing in "range.test". 2) status should be int, not Tcl_WideInt 3) make opmode/bymode enum. 4) Tcl_GetWideIntFromObj(NULL, ..), not poluting interp too much. 5) Use TCL_LL_MODIFIER in stead of "%ll". 6) LIST_MAX could be > INT_MAX (in Tcl 9) --- generic/tclCmdIL.c | 42 +++++++++++++++++++++--------------------- tests/range.test | 8 ++++++++ 2 files changed, 29 insertions(+), 21 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c2e0b42..05b20d4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4492,12 +4492,12 @@ Tcl_RangeObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount, i, totalElems, status; + Tcl_WideInt elementCount, i, totalElems; Tcl_Obj *const *argPtr; Tcl_WideInt start, end, step;//, count; Tcl_Obj *listPtr, **dataArray = NULL; Tcl_Obj *OPError = NULL, *BYError = NULL; - int argc, opmode, bymode; + int argc, status; double dstart, dend, dstep; int really = 0; static const char *const operations[] = { @@ -4505,12 +4505,12 @@ Tcl_RangeObjCmd( }; enum Range_Operators { RANGE_DOTS, RANGE_TO, RANGE_COUNT - }; + } opmode; static const char *const step_keywords[] = {"by", NULL}; enum Step_Operators { STEP_BY - }; - + } bymode; + /* * Check arguments for legality: * range from op to ?by step? @@ -4531,9 +4531,9 @@ Tcl_RangeObjCmd( argc--; /* From argument */ - status = Tcl_GetWideIntFromObj(interp, *argPtr, &start); + status = Tcl_GetWideIntFromObj(NULL, *argPtr, &start); if (status != TCL_OK) { - status = Tcl_GetDoubleFromObj(interp, *argPtr, &dstart); + status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstart); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad start value: \"%s\"", @@ -4546,7 +4546,7 @@ Tcl_RangeObjCmd( /* Process ?Op? argument */ argPtr++; argc--; - + /* Decode range (optional) OPeration argument */ if (argc && Tcl_GetIndexFromObj(interp, *argPtr, operations, "range operation", 0, &opmode) == TCL_OK) { @@ -4587,8 +4587,8 @@ Tcl_RangeObjCmd( /* Process To argument */ if (argc) { - if ((status = Tcl_GetWideIntFromObj(interp, *argPtr, &end)) != TCL_OK) { - status = Tcl_GetDoubleFromObj(interp, *argPtr, &dend); + if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { + status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dend); if (status != TCL_OK) { if (OPError) { Tcl_SetObjResult(interp, OPError); @@ -4605,7 +4605,7 @@ Tcl_RangeObjCmd( } else if (really) { dend = (double)end; } - + argPtr++; argc--; } @@ -4627,10 +4627,10 @@ Tcl_RangeObjCmd( step = 1; dstep = 1; } else { - status = Tcl_GetWideIntFromObj(interp, *argPtr, &step); + status = Tcl_GetWideIntFromObj(NULL, *argPtr, &step); if (status != TCL_OK) { - status = Tcl_GetDoubleFromObj(interp, *argPtr, &dstep); - if (status) { + status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstep); + if (status != TCL_OK) { if (BYError) { Tcl_SetObjResult(interp, BYError); } else { @@ -4665,7 +4665,7 @@ Tcl_RangeObjCmd( } /* Calculate the number of elements in the return values */ - + if (!really) { /* Integers */ if (step == 0 || (opmode != RANGE_COUNT @@ -4700,23 +4700,23 @@ Tcl_RangeObjCmd( } if (elementCount < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%lld\": must be a number >= 0", elementCount)); + "bad count \"%" TCL_LL_MODIFIER "d\": must be a number >= 0", elementCount)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", NULL); status = TCL_ERROR; goto done; } /* Final sanity check. Do not exceed limits on max list length. */ - + if (elementCount && objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + "max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", (size_t)LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); status = TCL_ERROR; goto done; } totalElems = elementCount; - + /* * Get an empty list object that is allocated large enough to hold each * init value elementCount times. @@ -4735,7 +4735,7 @@ Tcl_RangeObjCmd( */ CLANG_ASSERT(dataArray || totalElems == 0 ); - + if (!really) { int k = 0; @@ -4753,7 +4753,7 @@ Tcl_RangeObjCmd( dataArray[k++] = elemPtr; } } - + Tcl_SetObjResult(interp, listPtr); status = TCL_OK; diff --git a/tests/range.test b/tests/range.test index 27aeda3..eab77fb 100644 --- a/tests/range.test +++ b/tests/range.test @@ -302,3 +302,11 @@ test range-3.6 {error case} { -returnCodes 1 -result {bad step keyword "or": must be by} } + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 6b55b10a00d68be898d259e1b0331f8235d805e9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 7 Jul 2022 13:03:38 +0000 Subject: Eliminate totalElems (left-over from 'lrepeat'). Bug in checking LIST_MAX (also originally taken from 'lrepeat') --- generic/tclCmdIL.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 05b20d4..c28c283 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4492,7 +4492,7 @@ Tcl_RangeObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount, i, totalElems; + Tcl_WideInt elementCount, i; Tcl_Obj *const *argPtr; Tcl_WideInt start, end, step;//, count; Tcl_Obj *listPtr, **dataArray = NULL; @@ -4708,22 +4708,21 @@ Tcl_RangeObjCmd( /* Final sanity check. Do not exceed limits on max list length. */ - if (elementCount && objc > LIST_MAX/elementCount) { + if (elementCount > LIST_MAX) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", (size_t)LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); status = TCL_ERROR; goto done; } - totalElems = elementCount; /* * Get an empty list object that is allocated large enough to hold each * init value elementCount times. */ - listPtr = Tcl_NewListObj(totalElems, NULL); - if (totalElems) { + listPtr = Tcl_NewListObj(elementCount, NULL); + if (elementCount) { List *listRepPtr = ListRepPtr(listPtr); listRepPtr->elemCount = elementCount; @@ -4734,7 +4733,7 @@ Tcl_RangeObjCmd( * Set the elements. */ - CLANG_ASSERT(dataArray || totalElems == 0 ); + CLANG_ASSERT(dataArray || elementCount == 0 ); if (!really) { int k = 0; -- cgit v0.12 From 31f8d4fe4301c3a516d916f6f3ea56fae636ca55 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 12 Jul 2022 00:58:16 +0000 Subject: Implement TIP-225 ArithSeries. And other changes. --- doc/range.n | 61 ++++++ generic/tcl.decls | 11 ++ generic/tclCmdAH.c | 55 ++++-- generic/tclCmdIL.c | 129 ++++++++++--- generic/tclDecls.h | 17 ++ generic/tclExecute.c | 28 ++- generic/tclInt.h | 25 +++ generic/tclListObj.c | 518 ++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 3 + tests/range.test | 199 ++++++++++--------- 10 files changed, 907 insertions(+), 139 deletions(-) create mode 100644 doc/range.n diff --git a/doc/range.n b/doc/range.n new file mode 100644 index 0000000..6033961 --- /dev/null +++ b/doc/range.n @@ -0,0 +1,61 @@ +'\" +'\" Copyright (c) 2022 Eric Taylor. 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 range n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +range \- Build a numeric sequence returned as a list +.SH SYNOPSIS +\fBrange \fIStart \fR?(\fB..\fR|\fBto\fR)? \fIEnd\fR ??\fBby\fR? \fIStep\fR? + +\fBrange \fIStart \fBcount\fR \fICount\fR ??\fBby? \fIStep\fR? + +\fBrange \fICount\fR +.BE +.SH DESCRIPTION +.PP +The \fBrange\fR command creates a sequence of numeric values using the given +parameters \fIStart\fR, \fIEnd\fR, and \fIStep\fR. The \fIoperation\fR +argument ".." or "to" defines an inclusive range. The "count" option is used +to define a count of the number of elements in the list. The short form with a +single count value will create a range from 0 to count-1. +.SH EXAMPLES +.CS +\fBrange\fR 3 + \fI\(-> 0 1 2\fR +\fBrange\fR 3 0] + \fI\(-> 3 2 1 0}\fR +\fBrange\fR 10 .. 1 by 2 + \fI\(-> 10 8 6 4 2\fR +set l [\fBrange\fR 0 -5] + \fI\(-> 0 -1 -2 -3 -4 -5\fR +\fRforeach i [\fBrange\fR [llength $l]] { + puts l($i)=[lindex $l $i] +} + \fI\(-> l(0)=0 + l(1)=-1 + l(2)=-2 + l(3)=-3 + l(4)=-4 + l(5)=-5 + + +set sqrs [lmap i [\fBrange\fR 1 10] {expr $i*$i}] + \fI\(-> 1 4 9 16 25 36 49 64 81 100\fR + +.CE +.SH "SEE ALSO" +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 +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: diff --git a/generic/tcl.decls b/generic/tcl.decls index 99c0e25..0726b0a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2501,6 +2501,17 @@ declare 672 { declare 673 { int TclGetUniChar(Tcl_Obj *objPtr, int index) } +declare 674 generic { + Tcl_Obj * Tcl_NewArithSeriesObj(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step) +} +declare 675 generic { + int Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, + Tcl_WideInt *element) +} +declare 676 generic { + Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 28fc210..41b7403 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2801,32 +2801,47 @@ EachloopCmd( */ for (i=0 ; ivCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); if (statePtr->vCopyList[i] == NULL) { result = TCL_ERROR; goto done; } TclListObjGetElementsM(NULL, statePtr->vCopyList[i], - &statePtr->varcList[i], &statePtr->varvList[i]); + &statePtr->varcList[i], &statePtr->varvList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s varlist is empty", - (statePtr->resultList != NULL ? "lmap" : "foreach"))); + "%s varlist is empty", + (statePtr->resultList != NULL ? "lmap" : "foreach"))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", - (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), - "NEEDVARS", NULL); + (statePtr->resultList != NULL ? "LMAP" : "FOREACH"), + "NEEDVARS", NULL); result = TCL_ERROR; goto done; } - statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); - if (statePtr->aCopyList[i] == NULL) { - result = TCL_ERROR; - goto done; - } - TclListObjGetElementsM(NULL, statePtr->aCopyList[i], + /* Values */ + if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { + /* Special case for Arith Series */ + statePtr->vCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (statePtr->vCopyList[i] == NULL) { + result = TCL_ERROR; + goto done; + } + /* Don't compute values here, wait until the last momement */ + statePtr->argcList[i] = Tcl_ArithSeriesObjLength(statePtr->vCopyList[i]); + } else { + /* List values */ + statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { + result = TCL_ERROR; + goto done; + } + TclListObjGetElementsM(NULL, statePtr->aCopyList[i], &statePtr->argcList[i], &statePtr->argvList[i]); - + } + /* account for variable <> value mismatch */ j = statePtr->argcList[i] / statePtr->varcList[i]; if ((statePtr->argcList[i] % statePtr->varcList[i]) != 0) { j++; @@ -2948,11 +2963,23 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { + int isarithseries = TclHasInternalRep(statePtr->vCopyList[i],&tclArithSeriesType); for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; - if (k < statePtr->argcList[i]) { - valuePtr = statePtr->argvList[i][k]; + if (isarithseries) { + Tcl_WideInt value; + if (Tcl_ArithSeriesObjIndex(statePtr->vCopyList[i], k, &value) != TCL_OK) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (setting %s loop variable \"%s\")", + (statePtr->resultList != NULL ? "lmap" : "foreach"), + TclGetString(statePtr->varvList[i][v]))); + return TCL_ERROR; + } + valuePtr = Tcl_NewWideIntObj(value); + } else { + valuePtr = statePtr->argvList[i][k]; + } } else { TclNewObj(valuePtr); /* Empty string */ } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c28c283..09c7fff 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2689,7 +2689,11 @@ Tcl_LrangeObjCmd( return result; } - Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + Tcl_SetObjResult(interp, TclArithSeriesObjRange(objv[1], first, last)); + } else { + Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); + } return TCL_OK; } @@ -3068,6 +3072,43 @@ Tcl_LreverseObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } + + /* + * Handle ArithSeries special case - don't shimmer a series into a list + * just to reverse it. + */ + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + ArithSeries *arithSeriesPtr = ArithSeriesRepPtr(objv[1]); + Tcl_WideInt rstart, rend, rstep, len; + + len = Tcl_ArithSeriesObjLength(objv[1]); + if (Tcl_ArithSeriesObjIndex(objv[1], 0, &rend) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_ArithSeriesObjIndex(objv[1], (len-1), &rstart) != TCL_OK) { + return TCL_ERROR; + } + rstep = -arithSeriesPtr->step; + + if (Tcl_IsShared(objv[1])) { + Tcl_Obj *resultObj = Tcl_NewArithSeriesObj(rstart, rend, rstep, len); + Tcl_SetObjResult(interp, resultObj); + } else { + + /* + * Not shared, so swap in place. + */ + + arithSeriesPtr->start = rstart; + arithSeriesPtr->end = rend; + arithSeriesPtr->step = rstep; + TclInvalidateStringRep(objv[1]); + Tcl_SetObjResult(interp, objv[1]); + } + return TCL_OK; + } /* end ArithSeries */ + + /* True List */ if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) { return TCL_ERROR; } @@ -4492,16 +4533,16 @@ Tcl_RangeObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount, i; + Tcl_WideInt elementCount = -1, i; Tcl_Obj *const *argPtr; - Tcl_WideInt start, end, step;//, count; + Tcl_WideInt start, end, step; Tcl_Obj *listPtr, **dataArray = NULL; Tcl_Obj *OPError = NULL, *BYError = NULL; int argc, status; double dstart, dend, dstep; int really = 0; static const char *const operations[] = { - "..", "to", "-count", NULL + "..", "to", "count", NULL }; enum Range_Operators { RANGE_DOTS, RANGE_TO, RANGE_COUNT @@ -4534,13 +4575,24 @@ Tcl_RangeObjCmd( status = Tcl_GetWideIntFromObj(NULL, *argPtr, &start); if (status != TCL_OK) { status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstart); - if (status != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad start value: \"%s\"", - Tcl_GetString(*argPtr))); - goto done; + if (status == TCL_OK) { + really++; + } else { + /* Check for an index expression */ + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, *argPtr, &value) != TCL_OK) { + status = Tcl_RestoreInterpState(interp, savedstate); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad start value: \"%s\"", + Tcl_GetString(*argPtr))); + goto done; + } else { + status = Tcl_RestoreInterpState(interp, savedstate); + start = value; + } } - really++; } /* Process ?Op? argument */ @@ -4575,11 +4627,11 @@ Tcl_RangeObjCmd( /* No more arguments, set the defaults */ if (argc==0) { if (really) { - dend = dstart; + dend = dstart - (dstart>=0.0?1.0:-1.0); dstart = 0.0; dstep = 1.0; } else { - end = start - (start>0?1:-1); + end = start - (start>=0?1:-1); start = 0; step = 1; } @@ -4589,6 +4641,16 @@ Tcl_RangeObjCmd( if (argc) { if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dend); + if (status == TCL_OK) { + really++; + } else { + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + status = Tcl_ExprLongObj(interp, *argPtr, &value); + if (status == TCL_OK) end = value; + (void)Tcl_RestoreInterpState(interp, savedstate); // keep current status + } if (status != TCL_OK) { if (OPError) { Tcl_SetObjResult(interp, OPError); @@ -4598,7 +4660,6 @@ Tcl_RangeObjCmd( } goto done; } - really++; if (really == 1) { dstart = (double)start; } @@ -4631,16 +4692,25 @@ Tcl_RangeObjCmd( if (status != TCL_OK) { status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstep); if (status != TCL_OK) { - if (BYError) { - Tcl_SetObjResult(interp, BYError); + /* Evaluate possible expression */ + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, *argPtr, &value) == TCL_OK) { + step = value; + status = Tcl_RestoreInterpState(interp, savedstate); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad step value: \"%s\"\n", - Tcl_GetString(*argPtr))); + status = Tcl_RestoreInterpState(interp, savedstate); + if (BYError) { + Tcl_SetObjResult(interp, BYError); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad step value: \"%s\"\n", + Tcl_GetString(*argPtr))); + } + goto done; } - goto done; - } - if (dstep == 0.0) { + } else if (dstep == 0.0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("Step cannot be 0")); goto done; } @@ -4692,10 +4762,10 @@ Tcl_RangeObjCmd( elementCount = end; dend = dstart + (elementCount * dstep); } else if (dstart <= dend) { - elementCount = (Tcl_WideInt)round((dend-dstart+dstep)/dstep); + elementCount = (Tcl_WideInt)floor((dend-dstart+dstep)/dstep); } else { double absdstep = dstep<0 ? -dstep : dstep; - elementCount = (Tcl_WideInt)round((dstart-dend-dstep)/absdstep); + elementCount = (Tcl_WideInt)floor((dstart-dend-dstep)/absdstep); } } if (elementCount < 0) { @@ -4706,16 +4776,13 @@ Tcl_RangeObjCmd( goto done; } - /* Final sanity check. Do not exceed limits on max list length. */ - - if (elementCount > LIST_MAX) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", (size_t)LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - status = TCL_ERROR; + if (!really) { + Tcl_Obj *arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step, elementCount); + Tcl_SetObjResult(interp, arithSeriesPtr); + status = TCL_OK; goto done; } - + /* * Get an empty list object that is allocated large enough to hold each * init value elementCount times. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b869c97..675dabf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1975,6 +1975,14 @@ EXTERN const char * TclUtfAtIndex(const char *src, int index); EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); /* 673 */ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); +/* 674 */ +EXTERN Tcl_Obj * Tcl_NewArithSeriesObj (Tcl_WideInt start, Tcl_WideInt end, + Tcl_WideInt step, Tcl_WideInt len); +/* 675 */ +EXTERN int Tcl_ArithSeriesObjIndex (Tcl_Obj * arithSeriesPtr, + Tcl_WideInt index, Tcl_WideInt * element); +/* 676 */ +EXTERN Tcl_WideInt Tcl_ArithSeriesObjLength (Tcl_Obj * arithSeriesPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2684,6 +2692,9 @@ typedef struct TclStubs { const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ + Tcl_Obj * (*tcl_NewArithSeriesObj) (Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step); /* 674 */ + int (*tcl_ArithSeriesObjIndex) (Tcl_Obj * arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt * element); /* 675 */ + Tcl_WideInt (*tcl_ArithSeriesObjLength) (Tcl_Obj * arithSeriesPtr); /* 676 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4062,6 +4073,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetRange) /* 672 */ #define TclGetUniChar \ (tclStubsPtr->tclGetUniChar) /* 673 */ +#define Tcl_NewArithSeriesObj \ + (tclStubsPtr->tcl_NewArithSeriesObj) /* 674 */ +#define Tcl_ArithSeriesObjIndex \ + (tclStubsPtr->tcl_ArithSeriesObjIndex) /* 675 */ +#define Tcl_ArithSeriesObjLength \ + (tclStubsPtr->tcl_ArithSeriesObjLength) /* 676 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 923aae3..406a804 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4859,6 +4859,21 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + + /* special case for ArithSeries */ + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + ArithSeries *arithSeriesRepPtr = + (ArithSeries*) valuePtr->internalRep.twoPtrValue.ptr1; + length = arithSeriesRepPtr->len; + if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + objResultPtr = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + goto lindexDone; + } + /* * Extract the desired list element. */ @@ -4880,6 +4895,8 @@ TEBCresume( } objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); + + lindexDone: if (!objResultPtr) { TRACE_ERROR(interp); goto gotError; @@ -5100,7 +5117,11 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + objResultPtr = TclArithSeriesObjRange(valuePtr, fromIdx, toIdx); + } else { + objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); + } TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); @@ -5120,7 +5141,7 @@ TEBCresume( if (length > 0) { int i = 0; Tcl_Obj *o; - + int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); /* * An empty list doesn't match anything. */ @@ -5136,6 +5157,9 @@ TEBCresume( if (s1len == s2len) { match = (memcmp(s1, s2, s1len) == 0); } + if (isArithSeries) { + TclDecrRefCount(o); + } i++; } while (i < length && match == 0); } diff --git a/generic/tclInt.h b/generic/tclInt.h index c67b46d..76ac062 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2480,6 +2480,26 @@ typedef struct List { (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) /* + * The structure used for the AirthSeries internal representation. + * Note that the len can in theory be always computed by start,end,step + * but it's faster to cache it inside the internal representation. + */ +typedef struct ArithSeries { + Tcl_WideInt start; + Tcl_WideInt end; + Tcl_WideInt step; + Tcl_WideInt len; + Tcl_Obj *wideObjPtr; /* Used to speedup [foreach] reusing the same obj. */ +} ArithSeries; + +#define ArithSeriesRepPtr(arithSeriesObjPtr) \ + (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) + +#define ArithSeriesIndexM(arithSeriesRepPtr, index) \ + (arithSeriesRepPtr)->start+((index)*arithSeriesRepPtr->step) + + +/* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, * TclNRLmapCmd and their compilations. */ @@ -2758,6 +2778,7 @@ MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; +MODULE_SCOPE const Tcl_ObjType tclArithSeriesType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; @@ -2920,6 +2941,10 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, + int fromIdx, int toIdx); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, ClientData clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index a7f723d..da30daa 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -68,6 +68,14 @@ const Tcl_ObjType tclListType = { #define ListResetInternalRep(objPtr, listRepPtr) \ TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) +#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \ + do { \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \ + (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + + #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif @@ -852,6 +860,15 @@ Tcl_ListObjIndex( List *listRepPtr; ListGetInternalRep(listPtr, listRepPtr); + + if (listRepPtr == NULL && TclHasInternalRep(listPtr,&tclArithSeriesType)) { + Tcl_WideInt widint; + if (Tcl_ArithSeriesObjIndex(listPtr, index, &widint) == TCL_OK) { + *objPtrPtr = Tcl_NewWideIntObj(widint); + return TCL_OK; + } + } + if (listRepPtr == NULL) { int result, length; @@ -911,6 +928,11 @@ Tcl_ListObjLength( if (listRepPtr == NULL) { int result, length; + if (TclHasInternalRep(listPtr,&tclArithSeriesType)) { + *intPtr = Tcl_ArithSeriesObjLength(listPtr); + return TCL_OK; + } + (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { *intPtr = 0; @@ -2032,6 +2054,27 @@ SetListFromAny( Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } + } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + /* + * Convertion from Arithmetic Series is a special case + * because it can be done an order of magnitude faster + * and may occur frequently. + */ + Tcl_WideInt wideLen = Tcl_ArithSeriesObjLength(objPtr), j; + ArithSeries *arithSeriesRepPtr = (ArithSeries*) + objPtr->internalRep.twoPtrValue.ptr1; + listRepPtr = AttemptNewList(interp, wideLen, NULL); + if (listRepPtr == NULL) { + return TCL_ERROR; + } + elemPtrs = &listRepPtr->elements; + for (j = 0; j < wideLen; j++) { + elemPtrs[j] = Tcl_NewWideIntObj( + ArithSeriesIndexM(arithSeriesRepPtr, j)); //->start+(j*arithSeriesRepPtr->step)); + Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */ + } + listRepPtr->elemCount = wideLen; + } else { int estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); @@ -2208,6 +2251,481 @@ UpdateStringOfList( ckfree(flagPtr); } } +/* -------------------------- ArithSeries object ---------------------------- */ + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr); +static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); + +/* + * The structure below defines the arithmetic series Tcl object type by + * means of procedures that can be invoked by generic object code. + * + * The 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 Tcl_ObjType tclArithSeriesType = { + "arithseries", /* name */ + FreeArithSeriesInternalRep, /* freeIntRepProc */ + DupArithSeriesInternalRep, /* dupIntRepProc */ + UpdateStringOfArithSeries, /* updateStringProc */ + SetArithSeriesFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * ArithSeriesLen -- + * + * Compute the length of the equivalent list where + * every element is generated starting from *start*, + * and adding *step* to generate every successive element + * that's < *end* for positive steps, or > *end* for negative + * steps. + * + * Results: + * + * The length of the list generated by the given range, + * that may be zero. + * The function returns -1 if the list is of length infiite. + * + * Side effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +static Tcl_WideInt +ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) +{ + Tcl_WideInt len; + + if (step == 0) return 0; + len = (step ? (1 + (((end-start))/step)) : 0); + return (len < 0) ? -1 : len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewArithSeriesObj -- + * + * Creates a new ArithSeries object. The returned object has + * 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 * +Tcl_NewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +{ + Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); + Tcl_Obj *arithSeriesPtr; + ArithSeries *arithSeriesRepPtr; + + if (length == -1) return NULL; /* Invalid range error */ + TclNewObj(arithSeriesPtr); + + arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); + Tcl_IncrRefCount(arithSeriesRepPtr->wideObjPtr); + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesPtr->typePtr = &tclArithSeriesType; + if (length > 0) + Tcl_InvalidateStringRep(arithSeriesPtr); + + return arithSeriesPtr; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArithSeriesObjIndex -- + * + * Returns the element with the specified index in the list + * represented by the specified Arithmentic Sequence object. + * If the index is out of range, TCL_ERROR is returned, + * otherwise TCL_OK is returned and the integer value of the + * element is stored in *element. + * + * Results: + * + * TCL_OK on succes, TCL_ERROR on index out of range. + * + * Side Effects: + * + * On success, the integer pointed by *element is modified. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt *element) +{ + ArithSeries *arithSeriesRepPtr; + + if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + Tcl_Panic("Tcl_ArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = (ArithSeries*) + arithSeriesPtr->internalRep.twoPtrValue.ptr1; + if (index < 0 || index >= arithSeriesRepPtr->len) + return TCL_ERROR; + /* List[i] = Start + (Step * i) */ + *element = ArithSeriesIndexM(arithSeriesRepPtr, index);//->start+(index*arithSeriesRepPtr->step); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArithSeriesObjLength + * + * Returns the length of the arithmentic series. + * + * Results: + * + * The length of the series as Tcl_WideInt. + * + * Side Effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*) + arithSeriesPtr->internalRep.twoPtrValue.ptr1; + return arithSeriesRepPtr->len; +} + +/* + *---------------------------------------------------------------------- + * + * FreeArithSeriesInternalRep -- + * + * Deallocate the storage associated with an arithseries object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Frees arithSeriesPtr's ArithSeries* internal representation and + * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. + * + *---------------------------------------------------------------------- + */ + +static void +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + Tcl_DecrRefCount(arithSeriesRepPtr->wideObjPtr); + ckfree((char *) arithSeriesRepPtr); + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupArithSeriesInternalRep -- + * + * Initialize the internal representation of a arithseries Tcl_Obj to a + * copy of the internal representation of an existing arithseries object. + * + * Results: + * None. + * + * Side effects: + * We set "copyPtr"s internal rep to a pointer to a + * newly allocated ArithSeries structure. + *---------------------------------------------------------------------- + */ + +static void +DupArithSeriesInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + ArithSeries *srcArithSeriesRepPtr = + (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *copyArithSeriesRepPtr; + + /* + * Allocate a new ArithSeries structure. */ + + copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries)); + copyArithSeriesRepPtr->start = srcArithSeriesRepPtr->start; + copyArithSeriesRepPtr->end = srcArithSeriesRepPtr->end; + copyArithSeriesRepPtr->step = srcArithSeriesRepPtr->step; + copyArithSeriesRepPtr->len = srcArithSeriesRepPtr->len; + copyArithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); + Tcl_IncrRefCount(copyArithSeriesRepPtr->wideObjPtr); + + copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyArithSeriesRepPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + copyPtr->typePtr = &tclArithSeriesType; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfArithSeries -- + * + * Update the string representation for an arithseries object. + * Note: This procedure does not invalidate an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the list-to-string conversion. This string will be empty if the + * list has no elements. The list internal representation + * should not be NULL and we assume it is not NULL. + * + * Notes: + * At the cost of overallocation it's possible to estimate + * the length of the string representation and make this procedure + * much faster. Because the programmer shouldn't expect the + * string conversion of a big arithmetic sequence to be fast + * this version takes more care of space than time. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + char buffer[TCL_INTEGER_SPACE+2], *p; + Tcl_WideInt i; + Tcl_WideInt length = 0, ele; + int slen; + + /* + * Pass 1: estimate space. + */ + for (i = 0; i < arithSeriesRepPtr->len; i++) { + ele = arithSeriesRepPtr->start + (i*arithSeriesRepPtr->step); + /* + * Note that sprintf will generate a compiler warning under + * Mingw claiming %I64 is an unknown format specifier. + * Just ignore this warning. We can't use %L as the format + * specifier since that gets printed as a 32 bit value. + */ + sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele); + slen = strlen(buffer) + 1; /* + 1 is for the space or the nul-term */ + length += slen; + } + + /* + * Pass 2: generate the string repr. + */ + + p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); + for (i = 0; i < arithSeriesRepPtr->len; i++) { + ele = arithSeriesRepPtr->start + (i*arithSeriesRepPtr->step); + sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele); + slen = strlen(buffer); + strcpy(p, buffer); + p[slen] = ' '; + p += slen+1; + } + if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; + arithSeriesPtr->length = length-1; +} + +/* + *---------------------------------------------------------------------- + * + * SetArithSeriesFromAny -- + * + * The Arithmetic Series object is just an way to optimize + * Lists space complexity, so no one should try to convert + * a string to an Arithmetic Series object. + * + * This function is here just to populate the Type structure. + * + * Results: + * + * The result is always TCL_ERROR. But see Side Effects. + * + * Side effects: + * + * Tcl Panic if called. + * + *---------------------------------------------------------------------- + */ + +static int +SetArithSeriesFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + (void)interp; + (void)objPtr; + Tcl_Panic("SetArithSeriesFromAny: should never be called"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjCopy -- + * + * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. + * + * Results: + * + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a + * refCount of zero. If *arithSeriesPtr does not hold an arithSeries, + * NULL is returned, and if interp is non-NULL, an error message is + * recorded there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjCopy( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *arithSeriesPtr) /* List object for which an element array is + * to be returned. */ +{ + Tcl_Obj *copyPtr; + ArithSeries *arithSeriesRepPtr; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + if (NULL == arithSeriesRepPtr) { + if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) { + /* We know this is going to panic, but it's the message we want */ + return NULL; + } + } + + TclNewObj(copyPtr); + TclInvalidateStringRep(copyPtr); + DupArithSeriesInternalRep(arithSeriesPtr, copyPtr); + return copyPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjRange -- + * + * Makes a slice of an ArithSeries value. + * *arithSeriesPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced series. + * This may be a new object or the same object if not shared. + * + * Side effects: + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjRange( + Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + ArithSeries *arithSeriesRepPtr; + Tcl_WideInt start, end, step, len; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (fromIdx > toIdx) { + Tcl_Obj *obj; + TclNewObj(obj); + return obj; + } + + Tcl_ArithSeriesObjIndex(arithSeriesPtr, fromIdx, &start); + Tcl_ArithSeriesObjIndex(arithSeriesPtr, toIdx, &end); + step = arithSeriesRepPtr->step; + len = ArithSeriesLen(start, end, step); + + if (Tcl_IsShared(arithSeriesPtr) || + ((arithSeriesPtr->refCount > 1))) { + return Tcl_NewArithSeriesObj(start, end, step, len); + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(arithSeriesPtr); + + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = len; + + return arithSeriesPtr; +} + /* * Local Variables: diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index eae72ba..1cad186d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2033,6 +2033,9 @@ const TclStubs tclStubs = { TclUtfAtIndex, /* 671 */ TclGetRange, /* 672 */ TclGetUniChar, /* 673 */ + Tcl_NewArithSeriesObj, /* 674 */ + Tcl_ArithSeriesObjIndex, /* 675 */ + Tcl_ArithSeriesObjLength, /* 676 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/range.test b/tests/range.test index eab77fb..bccb692 100644 --- a/tests/range.test +++ b/tests/range.test @@ -15,86 +15,55 @@ if {"::tcltest" ni [namespace children]} { } ## Arg errors -test range-1.1 {error cases} { - -body { - range - } - -returnCodes 1 +test range-1.1 {error cases} -body { + range +} \ + -returnCodes 1 \ -result {wrong # args: should be "range start op end ?by step?"} -} + test range-1.2 {step magnitude} { - -body { - range 10 .. 1 by 2 ;# or this could be an error - or not - } - -result {10 8 6 4 2} -} + range 10 .. 1 by 2 ;# or this could be an error - or not +} {10 8 6 4 2} test range-1.3 {synergy between int and double} { - -body { - set rl [range 25. to 5. by 5] - set il [range 25 to 5 by 5] - lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } - } - -result {1 1 1 1 1} -} + set rl [range 25. to 5. by 5] + set il [range 25 to 5 by 5] + lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } +} {1 1 1 1 1} test range-1.4 {integer decreasing} { - -body { - range 10 .. 1 - } - -result {10 9 8 7 6 5 4 3 2 1} -} + range 10 .. 1 +} {10 9 8 7 6 5 4 3 2 1} test range-1.5 {integer increasing} { - -body { - range 1 .. 10 - } - -result {1 2 3 4 5 6 7 8 9 10} -} + range 1 .. 10 +} {1 2 3 4 5 6 7 8 9 10} test range-1.6 {integer decreasing with step} { - -body { - range 10 .. 1 by -2 - } - -result {10 8 6 4 2} -} + range 10 .. 1 by -2 +} {10 8 6 4 2} test range-1.7 {real increasing range} { - -body { - range 5.0 to 15. - } - -result {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} -} + range 5.0 to 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} test range-1.8 {real increasing range with step} { - -body { - range 5.0 to 25. by 5 - } - -result {5.0 10.0 15.0 20.0 25.0} -} + range 5.0 to 25. by 5 +} {5.0 10.0 15.0 20.0 25.0} test range-1.9 {real decreasing with step} { - -body { - range 25. to 5. by -5 - } - -result {25.0 20.0 15.0 10.0 5.0} -} + range 25. to 5. by -5 +} {25.0 20.0 15.0 10.0 5.0} # note, 10 cannot be in such a list, but allowed test range-1.10 {integer range with step} { - -body { - range 1 to 10 by 2 - } - -result {1 3 5 7 9} -} + range 1 to 10 by 2 +} {1 3 5 7 9} test range-1.11 {error case: increasing wrong step direction} { - -body { - range 1 to 10 by -2 - } - -result {1 3 5 7 9} -} + range 1 to 10 by -2 +} {1 3 5 7 9} test range-1.12 {decreasing range with step} { -body { @@ -105,21 +74,21 @@ test range-1.12 {decreasing range with step} { test range-1.13 {count operation} { -body { - range 5 -count 5 + range 5 count 5 } -result {5 6 7 8 9} } test range-1.14 {count with step} { -body { - range 5 -count 5 by 2 + range 5 count 5 by 2 } -result {5 7 9 11 13} } test range-1.15 {count with decreasing step} { -body { - range 5 -count 5 by -2 + range 5 count 5 by -2 } -result {5 3 1 -1 -3} } @@ -221,47 +190,39 @@ test range-2.13 {count only operation} { test range-2.14 {count with step} { -body { - range 5 -count 5 2 + range 5 count 5 2 } -result {5 7 9 11 13} } test range-2.15 {count with decreasing step} { - -body { - range 5 -count 5 -2 - } - -result {5 3 1 -1 -3} -} + range 5 count 5 -2 +} {5 3 1 -1 -3} + test range-2.16 {large numbers} { - -body { - range 1e6 2e6 1e5 - } - -result {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} -} + range 1e6 2e6 1e5 +} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} test range-3.1 {experiement} { - -body { - set ans {} - foreach factor [range 2.0 10.0] { - set start 1 - set end 10 - for {set step 1} {$step < 1e8} {} { - set l [range $start to $end by $step] - if {[llength $l] != ($step == 1 ? 10 : 11)} { - lappend ans $factor $step [llength $l] $l - } - set step [expr {$step * $factor}] - set end [expr {$end * $factor}] + set ans {} + foreach factor [range 2.0 10.0] { + set start 1 + set end 10 + for {set step 1} {$step < 1e8} {} { + set l [range $start to $end by $step] + if {[llength $l] != 10} { + lappend ans $factor $step [llength $l] $l } + set step [expr {$step * $factor}] + set end [expr {$end * $factor}] } - if {$ans eq {}} { - set ans OK - } - set ans } - -result {OK} -} + if {$ans eq {}} { + set ans OK + } + set ans +} {OK} test range-3.2 {error case} { -body { @@ -284,7 +245,7 @@ test range-3.4 {error case} { range 25 or 6 } -returnCodes 1 - -result {bad range operation "or": must be .., to, or -count} + -result {bad range operation "or": must be .., to, or count} } test range-3.5 {error case} { @@ -292,7 +253,7 @@ test range-3.5 {error case} { range 25 by 6 } -returnCodes 1 - -result {bad range operation "by": must be .., to, or -count} + -result {bad range operation "by": must be .., to, or count} } test range-3.6 {error case} { @@ -303,6 +264,60 @@ test range-3.6 {error case} { -result {bad step keyword "or": must be by} } +test range-3.7 {lmap} { + lmap x [range 5] { expr {$x * $x} } +} {0 1 4 9 16} + +test range-3.8 {lrange} { + set r [lrange [range 1 100] 10 20] + lindex [tcl::unsupported::representation $r] 3 +} {arithseries} + +test range-3.9 {lassign} { + set r [range 15] + lassign $r a b + list [lindex [tcl::unsupported::representation $r] 3] $a $b +} {arithseries 0 1} + +test range-3.10 {lsearch} { + set r [range 15 0] + set a [lsearch $r 9] + list [lindex [tcl::unsupported::representation $r] 3] $a +} {arithseries 6} + +test range-3.11 {lreverse} { + set r [range 15 0] + set a [lreverse $r] + join [list \ + [lindex [tcl::unsupported::representation $r] 3] \ + $r \ + [lindex [tcl::unsupported::representation $a] 3] \ + $a] \n +} {arithseries +15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 +arithseries +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} + +# Test lmap +# Test "in" expression operator +# Test llength +# Test lindex +# Test lrange (lrange of a [range] list produces another [range] list) +# Test start,end,step expressions +# Test lreverse +# Test lsearch + +test range-4.1 {end expressions} { + set start 7 + range $start $start+11 +} {7 8 9 10 11 12 13 14 15 16 17 18} + +test range-4.2 {start expressions} { + set base [clock seconds] + set tl [range $base-60 $base 10] + lmap t $tl {expr {$t - $base + 60}} +} {0 10 20 30 40 50 60} + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 595c3bb71f0ee135eaa1cadf0f5350b0e2acd823 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Jul 2022 09:57:46 +0000 Subject: Fix build --- generic/tcl.decls | 2 +- generic/tclDecls.h | 17 +++++++++-------- generic/tclListObj.c | 6 +++--- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 0726b0a..a200bbb 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2503,7 +2503,7 @@ declare 673 { } declare 674 generic { Tcl_Obj * Tcl_NewArithSeriesObj(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step) + Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) } declare 675 generic { int Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 675dabf..bf32563 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1976,13 +1976,14 @@ EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); /* 673 */ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); /* 674 */ -EXTERN Tcl_Obj * Tcl_NewArithSeriesObj (Tcl_WideInt start, Tcl_WideInt end, - Tcl_WideInt step, Tcl_WideInt len); +EXTERN Tcl_Obj * Tcl_NewArithSeriesObj(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step, + Tcl_WideInt len); /* 675 */ -EXTERN int Tcl_ArithSeriesObjIndex (Tcl_Obj * arithSeriesPtr, - Tcl_WideInt index, Tcl_WideInt * element); +EXTERN int Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, + Tcl_WideInt index, Tcl_WideInt *element); /* 676 */ -EXTERN Tcl_WideInt Tcl_ArithSeriesObjLength (Tcl_Obj * arithSeriesPtr); +EXTERN Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2692,9 +2693,9 @@ typedef struct TclStubs { const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ - Tcl_Obj * (*tcl_NewArithSeriesObj) (Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step); /* 674 */ - int (*tcl_ArithSeriesObjIndex) (Tcl_Obj * arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt * element); /* 675 */ - Tcl_WideInt (*tcl_ArithSeriesObjLength) (Tcl_Obj * arithSeriesPtr); /* 676 */ + Tcl_Obj * (*tcl_NewArithSeriesObj) (Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len); /* 674 */ + int (*tcl_ArithSeriesObjIndex) (Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt *element); /* 675 */ + Tcl_WideInt (*tcl_ArithSeriesObjLength) (Tcl_Obj *arithSeriesPtr); /* 676 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index da30daa..5d4a65b 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2365,7 +2365,7 @@ Tcl_NewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_ arithSeriesRepPtr->len = length; arithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); Tcl_IncrRefCount(arithSeriesRepPtr->wideObjPtr); - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesPtr->typePtr = &tclArithSeriesType; if (length > 0) @@ -2503,7 +2503,7 @@ DupArithSeriesInternalRep(srcPtr, copyPtr) copyArithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); Tcl_IncrRefCount(copyArithSeriesRepPtr->wideObjPtr); - copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyArithSeriesRepPtr; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclArithSeriesType; } @@ -2684,7 +2684,7 @@ TclArithSeriesObjRange( int toIdx) /* Index of last element to include. */ { ArithSeries *arithSeriesRepPtr; - Tcl_WideInt start, end, step, len; + Tcl_WideInt start = -1, end = -1, step, len; ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); -- cgit v0.12 From f484f2ebf5e3887655907f9098ac8f626b2ddab9 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 12 Jul 2022 18:57:03 +0000 Subject: Fix issue with sign of step value: if the sign of the step value is in conflict with the range, the command will return an empty list instead of an error. Add support for the form [range 20 by 4] which defines a range 20 elements long, starting at 0, with a step value of 4. --- generic/tclCmdIL.c | 50 +++++++++++++++++++++++++++++--------------------- tests/range.test | 40 ++++++++++++++++++---------------------- 2 files changed, 47 insertions(+), 43 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 09c7fff..8d6a93c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4542,10 +4542,10 @@ Tcl_RangeObjCmd( double dstart, dend, dstep; int really = 0; static const char *const operations[] = { - "..", "to", "count", NULL + "..", "to", "count", "by", NULL }; enum Range_Operators { - RANGE_DOTS, RANGE_TO, RANGE_COUNT + RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY } opmode; static const char *const step_keywords[] = {"by", NULL}; enum Step_Operators { @@ -4609,6 +4609,11 @@ Tcl_RangeObjCmd( break; case RANGE_COUNT: break; + case RANGE_BY: + // count mode with a step value + end = start-1; + start = 0; + break; } /* next argument */ argPtr++; @@ -4638,7 +4643,7 @@ Tcl_RangeObjCmd( } /* Process To argument */ - if (argc) { + if (argc && (opmode == RANGE_TO || opmode == RANGE_COUNT)) { if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dend); if (status == TCL_OK) { @@ -4685,8 +4690,13 @@ Tcl_RangeObjCmd( /* Proess Step argument */ if (argc == 0) { - step = 1; - dstep = 1; + if (opmode == RANGE_COUNT) { + step = 1; + dstep = 1; + } else { + step = start < end ? 1 : -1; + dstep = dstart < dend ? 1.0 : -1.0; + } } else { status = Tcl_GetWideIntFromObj(NULL, *argPtr, &step); if (status != TCL_OK) { @@ -4710,9 +4720,6 @@ Tcl_RangeObjCmd( } goto done; } - } else if (dstep == 0.0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("Step cannot be 0")); - goto done; } if (really == 0) { dstart = (double)start; @@ -4720,11 +4727,6 @@ Tcl_RangeObjCmd( } really++; } else { - if (step == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad step value: 0")); - status = TCL_ERROR; - goto done; - } if (really) { // Some other arg is double, promote step to double dstep = (double)step; @@ -4740,32 +4742,36 @@ Tcl_RangeObjCmd( if (step == 0 || (opmode != RANGE_COUNT && ((step < 0 && start <= end) || (step > 0 && end < start)))) { - step = -step; + step = 0; } if (opmode == RANGE_COUNT) { - elementCount = end; + elementCount = step ? end : 0; // 0 step -> empty list end = start + (elementCount * step); } else if (start <= end) { - elementCount = (end-start+step)/step; + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list } else { - elementCount = (start-end-step)/(-step); + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list } } else { // double if ((opmode != RANGE_COUNT && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { // Align step direction with the start, end direction - dstep = -dstep; + dstep = 0; } if (opmode == RANGE_COUNT) { - elementCount = end; + elementCount = dstep != 0.0 ? end : 0; // 0 step -> empty list dend = dstart + (elementCount * dstep); } else if (dstart <= dend) { - elementCount = (Tcl_WideInt)floor((dend-dstart+dstep)/dstep); + elementCount = (dstep != 0.0) + ? (Tcl_WideInt)floor((dend-dstart+dstep)/dstep) + : 0; // 0 step -> empty list } else { double absdstep = dstep<0 ? -dstep : dstep; - elementCount = (Tcl_WideInt)floor((dstart-dend-dstep)/absdstep); + elementCount = (dstep != 0.0) + ? (Tcl_WideInt)floor((dstart-dend-dstep)/absdstep) + : 0; // 0 step -> empty list } } if (elementCount < 0) { @@ -4784,6 +4790,8 @@ Tcl_RangeObjCmd( } /* + * For list of double (real) values, create actual list. + * * Get an empty list object that is allocated large enough to hold each * init value elementCount times. */ diff --git a/tests/range.test b/tests/range.test index bccb692..7d70b09 100644 --- a/tests/range.test +++ b/tests/range.test @@ -23,12 +23,12 @@ test range-1.1 {error cases} -body { test range-1.2 {step magnitude} { - range 10 .. 1 by 2 ;# or this could be an error - or not + range 10 .. 1 by -2 ;# or this could be an error - or not } {10 8 6 4 2} test range-1.3 {synergy between int and double} { - set rl [range 25. to 5. by 5] - set il [range 25 to 5 by 5] + set rl [range 25. to 5. by -5] + set il [range 25 to 5 by -5] lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } } {1 1 1 1 1} @@ -63,7 +63,7 @@ test range-1.10 {integer range with step} { test range-1.11 {error case: increasing wrong step direction} { range 1 to 10 by -2 -} {1 3 5 7 9} +} {} test range-1.12 {decreasing range with step} { -body { @@ -105,16 +105,16 @@ test range-1.16 {large numbers} { # test range-2.2 {step magnitude} { -body { - range 10 1 2 ;# or this could be an error - or not + range 10 1 2 ;# this is an empty case since step has wrong sign } - -result {10 8 6 4 2} + -result {} } test range-2.3 {step wrong sign} { -body { - range 25. 5. 5 ;# ditto - maybe this is an error + range 25. 5. 5 ;# ditto - empty list } - -result {25.0 20.0 15.0 10.0 5.0} + -result {} } test range-2.4 {integer decreasing} { @@ -171,7 +171,7 @@ test range-2.11 {error case: increasing wrong step direction} { -body { range 1 10 -2 } - -result {1 3 5 7 9} + -result {} } test range-2.12 {decreasing range with step} { @@ -245,16 +245,12 @@ test range-3.4 {error case} { range 25 or 6 } -returnCodes 1 - -result {bad range operation "or": must be .., to, or count} + -result {bad range operation "or": must be .., to, count, or by} } -test range-3.5 {error case} { - -body { - range 25 by 6 - } - -returnCodes 1 - -result {bad range operation "by": must be .., to, or count} -} +test range-3.5 {simple count and step arguments} { + range 25 by 6 +} {0 6 12 18 24} test range-3.6 {error case} { -body { @@ -264,28 +260,28 @@ test range-3.6 {error case} { -result {bad step keyword "or": must be by} } -test range-3.7 {lmap} { +test range-3.7 {lmap range} { lmap x [range 5] { expr {$x * $x} } } {0 1 4 9 16} -test range-3.8 {lrange} { +test range-3.8 {lrange range} { set r [lrange [range 1 100] 10 20] lindex [tcl::unsupported::representation $r] 3 } {arithseries} -test range-3.9 {lassign} { +test range-3.9 {lassign range} { set r [range 15] lassign $r a b list [lindex [tcl::unsupported::representation $r] 3] $a $b } {arithseries 0 1} -test range-3.10 {lsearch} { +test range-3.10 {lsearch range} { set r [range 15 0] set a [lsearch $r 9] list [lindex [tcl::unsupported::representation $r] 3] $a } {arithseries 6} -test range-3.11 {lreverse} { +test range-3.11 {lreverse range} { set r [range 15 0] set a [lreverse $r] join [list \ -- cgit v0.12 From 790c4449ac6e39e6987b5ff91806a27692c975a3 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 14 Jul 2022 01:16:01 +0000 Subject: typo; nfc --- generic/tclCmdIL.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8d6a93c..aa7ee33 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4688,7 +4688,7 @@ Tcl_RangeObjCmd( } } - /* Proess Step argument */ + /* Process Step argument */ if (argc == 0) { if (opmode == RANGE_COUNT) { step = 1; -- cgit v0.12 From 86691e22e4a596a816587214d6b4884c8554dfd6 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 14 Jul 2022 01:33:01 +0000 Subject: "range", Tcl_RangeObjCmd() to proper compilation unit --- generic/tclCmdIL.c | 333 ----------------------------------------------------- generic/tclCmdMZ.c | 333 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 333 insertions(+), 333 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index aa7ee33..35a71f1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4511,339 +4511,6 @@ Tcl_LsortObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_RangeObjCmd -- - * - * This procedure is invoked to process the "range" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RangeObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* The argument objects. */ -{ - Tcl_WideInt elementCount = -1, i; - Tcl_Obj *const *argPtr; - Tcl_WideInt start, end, step; - Tcl_Obj *listPtr, **dataArray = NULL; - Tcl_Obj *OPError = NULL, *BYError = NULL; - int argc, status; - double dstart, dend, dstep; - int really = 0; - static const char *const operations[] = { - "..", "to", "count", "by", NULL - }; - enum Range_Operators { - RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY - } opmode; - static const char *const step_keywords[] = {"by", NULL}; - enum Step_Operators { - STEP_BY - } bymode; - - /* - * Check arguments for legality: - * range from op to ?by step? - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "start op end ?by step?"); - status = TCL_ERROR; - goto done; - } - - argc = objc; - argPtr = objv; - - /* Skip command name */ - /* Process first argument */ - argPtr++; - argc--; - - /* From argument */ - status = Tcl_GetWideIntFromObj(NULL, *argPtr, &start); - if (status != TCL_OK) { - status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstart); - if (status == TCL_OK) { - really++; - } else { - /* Check for an index expression */ - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, *argPtr, &value) != TCL_OK) { - status = Tcl_RestoreInterpState(interp, savedstate); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad start value: \"%s\"", - Tcl_GetString(*argPtr))); - goto done; - } else { - status = Tcl_RestoreInterpState(interp, savedstate); - start = value; - } - } - } - - /* Process ?Op? argument */ - argPtr++; - argc--; - - /* Decode range (optional) OPeration argument */ - if (argc && - Tcl_GetIndexFromObj(interp, *argPtr, operations, "range operation", 0, &opmode) == TCL_OK) { - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - opmode = RANGE_TO; - break; - case RANGE_COUNT: - break; - case RANGE_BY: - // count mode with a step value - end = start-1; - start = 0; - break; - } - /* next argument */ - argPtr++; - argc--; - } else { - if (objc > 3) { - OPError = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(OPError); - } else { - OPError = NULL; - } - /* Default when not specified */ - opmode = RANGE_TO; - } - - /* No more arguments, set the defaults */ - if (argc==0) { - if (really) { - dend = dstart - (dstart>=0.0?1.0:-1.0); - dstart = 0.0; - dstep = 1.0; - } else { - end = start - (start>=0?1:-1); - start = 0; - step = 1; - } - } - - /* Process To argument */ - if (argc && (opmode == RANGE_TO || opmode == RANGE_COUNT)) { - if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { - status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dend); - if (status == TCL_OK) { - really++; - } else { - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - status = Tcl_ExprLongObj(interp, *argPtr, &value); - if (status == TCL_OK) end = value; - (void)Tcl_RestoreInterpState(interp, savedstate); // keep current status - } - if (status != TCL_OK) { - if (OPError) { - Tcl_SetObjResult(interp, OPError); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad end value: \"%s\"", Tcl_GetString(*argPtr))); - } - goto done; - } - if (really == 1) { - dstart = (double)start; - } - } else if (really) { - dend = (double)end; - } - - argPtr++; - argc--; - } - - /* Process ?by? argument */ - if (argc) { - if (Tcl_GetIndexFromObj(interp, *argPtr, step_keywords, "step keyword", 0, &bymode) == TCL_OK - && bymode == STEP_BY) { - argPtr++; - argc--; - } else { - BYError = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(BYError); - } - } - - /* Process Step argument */ - if (argc == 0) { - if (opmode == RANGE_COUNT) { - step = 1; - dstep = 1; - } else { - step = start < end ? 1 : -1; - dstep = dstart < dend ? 1.0 : -1.0; - } - } else { - status = Tcl_GetWideIntFromObj(NULL, *argPtr, &step); - if (status != TCL_OK) { - status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstep); - if (status != TCL_OK) { - /* Evaluate possible expression */ - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, *argPtr, &value) == TCL_OK) { - step = value; - status = Tcl_RestoreInterpState(interp, savedstate); - } else { - status = Tcl_RestoreInterpState(interp, savedstate); - if (BYError) { - Tcl_SetObjResult(interp, BYError); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad step value: \"%s\"\n", - Tcl_GetString(*argPtr))); - } - goto done; - } - } - if (really == 0) { - dstart = (double)start; - dend = (double)end; - } - really++; - } else { - if (really) { - // Some other arg is double, promote step to double - dstep = (double)step; - } - } - argPtr++; - argc--; - } - - /* Calculate the number of elements in the return values */ - - if (!really) { /* Integers */ - if (step == 0 - || (opmode != RANGE_COUNT - && ((step < 0 && start <= end) || (step > 0 && end < start)))) { - step = 0; - } - - if (opmode == RANGE_COUNT) { - elementCount = step ? end : 0; // 0 step -> empty list - end = start + (elementCount * step); - } else if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - } else { // double - if ((opmode != RANGE_COUNT - && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { - // Align step direction with the start, end direction - dstep = 0; - } - - if (opmode == RANGE_COUNT) { - elementCount = dstep != 0.0 ? end : 0; // 0 step -> empty list - dend = dstart + (elementCount * dstep); - } else if (dstart <= dend) { - elementCount = (dstep != 0.0) - ? (Tcl_WideInt)floor((dend-dstart+dstep)/dstep) - : 0; // 0 step -> empty list - } else { - double absdstep = dstep<0 ? -dstep : dstep; - elementCount = (dstep != 0.0) - ? (Tcl_WideInt)floor((dstart-dend-dstep)/absdstep) - : 0; // 0 step -> empty list - } - } - if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%" TCL_LL_MODIFIER "d\": must be a number >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", NULL); - status = TCL_ERROR; - goto done; - } - - if (!really) { - Tcl_Obj *arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step, elementCount); - Tcl_SetObjResult(interp, arithSeriesPtr); - status = TCL_OK; - goto done; - } - - /* - * For list of double (real) values, create actual list. - * - * Get an empty list object that is allocated large enough to hold each - * init value elementCount times. - */ - - listPtr = Tcl_NewListObj(elementCount, NULL); - if (elementCount) { - List *listRepPtr = ListRepPtr(listPtr); - - listRepPtr->elemCount = elementCount; - dataArray = &listRepPtr->elements; - } - - /* - * Set the elements. - */ - - CLANG_ASSERT(dataArray || elementCount == 0 ); - - if (!really) { - int k = 0; - - for (i=0 ; i 3) { + OPError = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(OPError); + } else { + OPError = NULL; + } + /* Default when not specified */ + opmode = RANGE_TO; + } + + /* No more arguments, set the defaults */ + if (argc==0) { + if (really) { + dend = dstart - (dstart>=0.0?1.0:-1.0); + dstart = 0.0; + dstep = 1.0; + } else { + end = start - (start>=0?1:-1); + start = 0; + step = 1; + } + } + + /* Process To argument */ + if (argc && (opmode == RANGE_TO || opmode == RANGE_COUNT)) { + if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { + status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dend); + if (status == TCL_OK) { + really++; + } else { + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + status = Tcl_ExprLongObj(interp, *argPtr, &value); + if (status == TCL_OK) end = value; + (void)Tcl_RestoreInterpState(interp, savedstate); // keep current status + } + if (status != TCL_OK) { + if (OPError) { + Tcl_SetObjResult(interp, OPError); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad end value: \"%s\"", Tcl_GetString(*argPtr))); + } + goto done; + } + if (really == 1) { + dstart = (double)start; + } + } else if (really) { + dend = (double)end; + } + + argPtr++; + argc--; + } + + /* Process ?by? argument */ + if (argc) { + if (Tcl_GetIndexFromObj(interp, *argPtr, step_keywords, "step keyword", 0, &bymode) == TCL_OK + && bymode == STEP_BY) { + argPtr++; + argc--; + } else { + BYError = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(BYError); + } + } + + /* Process Step argument */ + if (argc == 0) { + if (opmode == RANGE_COUNT) { + step = 1; + dstep = 1; + } else { + step = start < end ? 1 : -1; + dstep = dstart < dend ? 1.0 : -1.0; + } + } else { + status = Tcl_GetWideIntFromObj(NULL, *argPtr, &step); + if (status != TCL_OK) { + status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstep); + if (status != TCL_OK) { + /* Evaluate possible expression */ + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, *argPtr, &value) == TCL_OK) { + step = value; + status = Tcl_RestoreInterpState(interp, savedstate); + } else { + status = Tcl_RestoreInterpState(interp, savedstate); + if (BYError) { + Tcl_SetObjResult(interp, BYError); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad step value: \"%s\"\n", + Tcl_GetString(*argPtr))); + } + goto done; + } + } + if (really == 0) { + dstart = (double)start; + dend = (double)end; + } + really++; + } else { + if (really) { + // Some other arg is double, promote step to double + dstep = (double)step; + } + } + argPtr++; + argc--; + } + + /* Calculate the number of elements in the return values */ + + if (!really) { /* Integers */ + if (step == 0 + || (opmode != RANGE_COUNT + && ((step < 0 && start <= end) || (step > 0 && end < start)))) { + step = 0; + } + + if (opmode == RANGE_COUNT) { + elementCount = step ? end : 0; // 0 step -> empty list + end = start + (elementCount * step); + } else if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + } else { // double + if ((opmode != RANGE_COUNT + && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { + // Align step direction with the start, end direction + dstep = 0; + } + + if (opmode == RANGE_COUNT) { + elementCount = dstep != 0.0 ? end : 0; // 0 step -> empty list + dend = dstart + (elementCount * dstep); + } else if (dstart <= dend) { + elementCount = (dstep != 0.0) + ? (Tcl_WideInt)floor((dend-dstart+dstep)/dstep) + : 0; // 0 step -> empty list + } else { + double absdstep = dstep<0 ? -dstep : dstep; + elementCount = (dstep != 0.0) + ? (Tcl_WideInt)floor((dstart-dend-dstep)/absdstep) + : 0; // 0 step -> empty list + } + } + if (elementCount < 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad count \"%" TCL_LL_MODIFIER "d\": must be a number >= 0", elementCount)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", NULL); + status = TCL_ERROR; + goto done; + } + + if (!really) { + Tcl_Obj *arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step, elementCount); + Tcl_SetObjResult(interp, arithSeriesPtr); + status = TCL_OK; + goto done; + } + + /* + * For list of double (real) values, create actual list. + * + * Get an empty list object that is allocated large enough to hold each + * init value elementCount times. + */ + + listPtr = Tcl_NewListObj(elementCount, NULL); + if (elementCount) { + List *listRepPtr = ListRepPtr(listPtr); + + listRepPtr->elemCount = elementCount; + dataArray = &listRepPtr->elements; + } + + /* + * Set the elements. + */ + + CLANG_ASSERT(dataArray || elementCount == 0 ); + + if (!really) { + int k = 0; + + for (i=0 ; i Date: Thu, 14 Jul 2022 01:42:25 +0000 Subject: floor() wants math.h *at least* on NetBSD, and appears other *nix too(?) --- generic/tclCmdMZ.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2302eb2..0337af6 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -16,6 +16,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include #include "tclInt.h" #include "tclCompile.h" #include "tclRegexp.h" -- cgit v0.12 From cd56027275903e364902e51a3b3b2c1d006f5864 Mon Sep 17 00:00:00 2001 From: griffin Date: Thu, 14 Jul 2022 03:23:49 +0000 Subject: Remove support for double (real) values. Fix a couple cases of shimmering. Don't update the string rep just to convert an ArithSeries to a List. Manpage update. --- doc/range.n | 23 ++++-- generic/tclCmdMZ.c | 226 ++++++++++++++------------------------------------- generic/tclExecute.c | 24 +++++- generic/tclListObj.c | 13 +-- tests/range.test | 181 +++++++++++++++-------------------------- 5 files changed, 175 insertions(+), 292 deletions(-) diff --git a/doc/range.n b/doc/range.n index 6033961..16e0079 100644 --- a/doc/range.n +++ b/doc/range.n @@ -13,9 +13,9 @@ range \- Build a numeric sequence returned as a list .SH SYNOPSIS \fBrange \fIStart \fR?(\fB..\fR|\fBto\fR)? \fIEnd\fR ??\fBby\fR? \fIStep\fR? -\fBrange \fIStart \fBcount\fR \fICount\fR ??\fBby? \fIStep\fR? +\fBrange \fIStart \fBcount\fR \fICount\fR ??\fBby\fR? \fIStep\fR? -\fBrange \fICount\fR +\fBrange \fICount\fR ?\fBby \fIStep\fR? .BE .SH DESCRIPTION .PP @@ -24,12 +24,17 @@ parameters \fIStart\fR, \fIEnd\fR, and \fIStep\fR. The \fIoperation\fR argument ".." or "to" defines an inclusive range. The "count" option is used to define a count of the number of elements in the list. The short form with a single count value will create a range from 0 to count-1. + +The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR, +can also be a valid expression. the range command will evaluate the expression +and use the numeric result, or error as with any invalid argument value. + .SH EXAMPLES .CS \fBrange\fR 3 \fI\(-> 0 1 2\fR -\fBrange\fR 3 0] - \fI\(-> 3 2 1 0}\fR +\fBrange\fR 3 0 + \fI\(-> 3 2 1 0\fR \fBrange\fR 10 .. 1 by 2 \fI\(-> 10 8 6 4 2\fR set l [\fBrange\fR 0 -5] @@ -43,7 +48,15 @@ set l [\fBrange\fR 0 -5] l(3)=-3 l(4)=-4 l(5)=-5 - +\fRforeach i [\fBrange\fR [llength $l]-1 0] { + puts l($i)=[lindex $l $i] +} + \fI\(-> l(5)=-5 + l(4)=-4 + l(3)=-3 + l(2)=-2 + l(1)=-1 + l(0)=0 set sqrs [lmap i [\fBrange\fR 1 10] {expr $i*$i}] \fI\(-> 1 4 9 16 25 36 49 64 81 100\fR diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0337af6..3442d10 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -129,14 +129,12 @@ Tcl_RangeObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount = -1, i; + Tcl_WideInt elementCount = -1; Tcl_Obj *const *argPtr; Tcl_WideInt start, end, step; - Tcl_Obj *listPtr, **dataArray = NULL; Tcl_Obj *OPError = NULL, *BYError = NULL; int argc, status; - double dstart, dend, dstep; - int really = 0; + Tcl_Obj *arithSeriesPtr; static const char *const operations[] = { "..", "to", "count", "by", NULL }; @@ -170,24 +168,19 @@ Tcl_RangeObjCmd( /* From argument */ status = Tcl_GetWideIntFromObj(NULL, *argPtr, &start); if (status != TCL_OK) { - status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstart); - if (status == TCL_OK) { - really++; + /* Check for an index expression */ + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, *argPtr, &value) != TCL_OK) { + status = Tcl_RestoreInterpState(interp, savedstate); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad start value: \"%s\"", + Tcl_GetString(*argPtr))); + goto done; } else { - /* Check for an index expression */ - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, *argPtr, &value) != TCL_OK) { - status = Tcl_RestoreInterpState(interp, savedstate); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad start value: \"%s\"", - Tcl_GetString(*argPtr))); - goto done; - } else { - status = Tcl_RestoreInterpState(interp, savedstate); - start = value; - } + status = Tcl_RestoreInterpState(interp, savedstate); + start = value; } } @@ -227,45 +220,29 @@ Tcl_RangeObjCmd( /* No more arguments, set the defaults */ if (argc==0) { - if (really) { - dend = dstart - (dstart>=0.0?1.0:-1.0); - dstart = 0.0; - dstep = 1.0; - } else { - end = start - (start>=0?1:-1); - start = 0; - step = 1; - } + end = start - (start>=0?1:-1); + start = 0; + step = 1; } /* Process To argument */ if (argc && (opmode == RANGE_TO || opmode == RANGE_COUNT)) { if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { - status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dend); - if (status == TCL_OK) { - really++; + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + status = Tcl_ExprLongObj(interp, *argPtr, &value); + if (status == TCL_OK) end = value; + (void)Tcl_RestoreInterpState(interp, savedstate); // keep current status + } + if (status != TCL_OK) { + if (OPError) { + Tcl_SetObjResult(interp, OPError); } else { - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - status = Tcl_ExprLongObj(interp, *argPtr, &value); - if (status == TCL_OK) end = value; - (void)Tcl_RestoreInterpState(interp, savedstate); // keep current status - } - if (status != TCL_OK) { - if (OPError) { - Tcl_SetObjResult(interp, OPError); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad end value: \"%s\"", Tcl_GetString(*argPtr))); - } - goto done; - } - if (really == 1) { - dstart = (double)start; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad end value: \"%s\"", Tcl_GetString(*argPtr))); } - } else if (really) { - dend = (double)end; + goto done; } argPtr++; @@ -284,48 +261,33 @@ Tcl_RangeObjCmd( } } - /* Process Step argument */ + /* Proess Step argument */ if (argc == 0) { if (opmode == RANGE_COUNT) { step = 1; - dstep = 1; } else { step = start < end ? 1 : -1; - dstep = dstart < dend ? 1.0 : -1.0; } } else { status = Tcl_GetWideIntFromObj(NULL, *argPtr, &step); if (status != TCL_OK) { - status = Tcl_GetDoubleFromObj(NULL, *argPtr, &dstep); - if (status != TCL_OK) { - /* Evaluate possible expression */ - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, *argPtr, &value) == TCL_OK) { - step = value; - status = Tcl_RestoreInterpState(interp, savedstate); + /* Evaluate possible expression */ + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, *argPtr, &value) == TCL_OK) { + step = value; + status = Tcl_RestoreInterpState(interp, savedstate); + } else { + status = Tcl_RestoreInterpState(interp, savedstate); + if (BYError) { + Tcl_SetObjResult(interp, BYError); } else { - status = Tcl_RestoreInterpState(interp, savedstate); - if (BYError) { - Tcl_SetObjResult(interp, BYError); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad step value: \"%s\"\n", - Tcl_GetString(*argPtr))); - } - goto done; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad step value: \"%s\"\n", + Tcl_GetString(*argPtr))); } - } - if (really == 0) { - dstart = (double)start; - dend = (double)end; - } - really++; - } else { - if (really) { - // Some other arg is double, promote step to double - dstep = (double)step; + goto done; } } argPtr++; @@ -334,42 +296,21 @@ Tcl_RangeObjCmd( /* Calculate the number of elements in the return values */ - if (!really) { /* Integers */ - if (step == 0 - || (opmode != RANGE_COUNT - && ((step < 0 && start <= end) || (step > 0 && end < start)))) { - step = 0; - } - - if (opmode == RANGE_COUNT) { - elementCount = step ? end : 0; // 0 step -> empty list - end = start + (elementCount * step); - } else if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - } else { // double - if ((opmode != RANGE_COUNT - && ((dstep < 0.0 && dstart <= dend) || (dstep > 0.0 && dend < dstart)))) { - // Align step direction with the start, end direction - dstep = 0; - } + if (step == 0 + || (opmode != RANGE_COUNT + && ((step < 0 && start <= end) || (step > 0 && end < start)))) { + step = 0; + } - if (opmode == RANGE_COUNT) { - elementCount = dstep != 0.0 ? end : 0; // 0 step -> empty list - dend = dstart + (elementCount * dstep); - } else if (dstart <= dend) { - elementCount = (dstep != 0.0) - ? (Tcl_WideInt)floor((dend-dstart+dstep)/dstep) - : 0; // 0 step -> empty list - } else { - double absdstep = dstep<0 ? -dstep : dstep; - elementCount = (dstep != 0.0) - ? (Tcl_WideInt)floor((dstart-dend-dstep)/absdstep) - : 0; // 0 step -> empty list - } + if (opmode == RANGE_COUNT) { + elementCount = step ? end : 0; // 0 step -> empty list + end = start + (elementCount * step); + } else if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list } + if (elementCount < 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad count \"%" TCL_LL_MODIFIER "d\": must be a number >= 0", elementCount)); @@ -378,53 +319,8 @@ Tcl_RangeObjCmd( goto done; } - if (!really) { - Tcl_Obj *arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step, elementCount); - Tcl_SetObjResult(interp, arithSeriesPtr); - status = TCL_OK; - goto done; - } - - /* - * For list of double (real) values, create actual list. - * - * Get an empty list object that is allocated large enough to hold each - * init value elementCount times. - */ - - listPtr = Tcl_NewListObj(elementCount, NULL); - if (elementCount) { - List *listRepPtr = ListRepPtr(listPtr); - - listRepPtr->elemCount = elementCount; - dataArray = &listRepPtr->elements; - } - - /* - * Set the elements. - */ - - CLANG_ASSERT(dataArray || elementCount == 0 ); - - if (!really) { - int k = 0; - - for (i=0 ; i ", O2S(valuePtr), opnd)); + /* special case for ArithSeries */ + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + ArithSeries *arithSeriesRepPtr = + (ArithSeries*) valuePtr->internalRep.twoPtrValue.ptr1; + length = arithSeriesRepPtr->len; + + /* Decode end-offset index values. */ + + index = TclIndexDecode(opnd, length); + + /* Compute value @ index */ + if (index >= 0 && index < length) { + objResultPtr = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } else { + TclNewObj(objResultPtr); + } + pcAdjustment = 5; + goto lindexFastPath2; + } + /* * Get the contents of the list, making sure that it really is a list * in the process. @@ -4941,7 +4961,9 @@ TEBCresume( } else { TclNewObj(objResultPtr); } - + + lindexFastPath2: + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 5d4a65b..6544feb 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -579,12 +579,13 @@ Tcl_ListObjGetElements( if (listRepPtr == NULL) { int result, length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *objcPtr = 0; - *objvPtr = NULL; - return TCL_OK; + if ( ! TclHasInternalRep(listPtr,&tclArithSeriesType)) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { + *objcPtr = 0; + *objvPtr = NULL; + return TCL_OK; + } } result = SetListFromAny(interp, listPtr); if (result != TCL_OK) { diff --git a/tests/range.test b/tests/range.test index 7d70b09..9ac0a7a 100644 --- a/tests/range.test +++ b/tests/range.test @@ -14,6 +14,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint arithSeriesDouble 0 +testConstraint arithSeriesShimmer 1 + ## Arg errors test range-1.1 {error cases} -body { range @@ -44,15 +47,15 @@ test range-1.6 {integer decreasing with step} { range 10 .. 1 by -2 } {10 8 6 4 2} -test range-1.7 {real increasing range} { +test range-1.7 {real increasing range} arithSeriesDouble { range 5.0 to 15. } {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} -test range-1.8 {real increasing range with step} { +test range-1.8 {real increasing range with step} arithSeriesDouble { range 5.0 to 25. by 5 } {5.0 10.0 15.0 20.0 25.0} -test range-1.9 {real decreasing with step} { +test range-1.9 {real decreasing with step} arithSeriesDouble { range 25. to 5. by -5 } {25.0 20.0 15.0 10.0 5.0} @@ -65,12 +68,9 @@ test range-1.11 {error case: increasing wrong step direction} { range 1 to 10 by -2 } {} -test range-1.12 {decreasing range with step} { - -body { - range 25. to -25. by -5 - } - -result { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} -} +test range-1.12 {decreasing range with step} arithSeriesDouble { + range 25. to -25. by -5 +} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} test range-1.13 {count operation} { -body { @@ -104,106 +104,72 @@ test range-1.16 {large numbers} { # Short-hand use cases # test range-2.2 {step magnitude} { - -body { - range 10 1 2 ;# this is an empty case since step has wrong sign - } - -result {} -} + range 10 1 2 ;# this is an empty case since step has wrong sign +} {} -test range-2.3 {step wrong sign} { - -body { - range 25. 5. 5 ;# ditto - empty list - } - -result {} -} +test range-2.3 {step wrong sign} arithSeriesDouble { + range 25. 5. 5 ;# ditto - empty list +} {} test range-2.4 {integer decreasing} { - -body { - range 10 1 - } - -result {10 9 8 7 6 5 4 3 2 1} -} + range 10 1 +} {10 9 8 7 6 5 4 3 2 1} test range-2.5 {integer increasing} { - -body { - range 1 10 - } - -result {1 2 3 4 5 6 7 8 9 10} -} + range 1 10 +} {1 2 3 4 5 6 7 8 9 10} test range-2.6 {integer decreasing with step} { - -body { - range 10 1 by -2 - } - -result {10 8 6 4 2} -} + range 10 1 by -2 +} {10 8 6 4 2} -test range-2.7 {real increasing range} { - -body { - range 5.0 15. - } - -result {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} -} +test range-2.7 {real increasing range} arithSeriesDouble { + range 5.0 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} -test range-2.8 {real increasing range with step} { - -body { - range 5.0 25. 5 - } - -result {5.0 10.0 15.0 20.0 25.0} -} -test range-2.9 {real decreasing with step} { - -body { - range 25. 5. -5 - } - -result {25.0 20.0 15.0 10.0 5.0} -} +test range-2.8 {real increasing range with step} arithSeriesDouble { + range 5.0 25. 5 +} {5.0 10.0 15.0 20.0 25.0} + + +test range-2.9 {real decreasing with step} arithSeriesDouble { + range 25. 5. -5 +} {25.0 20.0 15.0 10.0 5.0} -# note, 10 cannot be in such a list, but allowed test range-2.10 {integer range with step} { - -body { - range 1 10 2 - } - -result {1 3 5 7 9} -} + range 1 10 2 +} {1 3 5 7 9} test range-2.11 {error case: increasing wrong step direction} { - -body { - range 1 10 -2 - } - -result {} -} + range 1 10 -2 +} {} -test range-2.12 {decreasing range with step} { - -body { - range 25. -25. -5 - } - -result { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} -} +test range-2.12 {decreasing range with step} arithSeriesDouble { + range 25. -25. -5 +} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} test range-2.13 {count only operation} { - -body { - range 5 - } - -result {0 1 2 3 4} -} + range 5 +} {0 1 2 3 4} test range-2.14 {count with step} { - -body { - range 5 count 5 2 - } - -result {5 7 9 11 13} -} + range 5 count 5 2 +} {5 7 9 11 13} test range-2.15 {count with decreasing step} { range 5 count 5 -2 } {5 3 1 -1 -3} - test range-2.16 {large numbers} { range 1e6 2e6 1e5 +} {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} + +test range-2.17 {large numbers} arithSeriesDouble { + range 1e6 2e6 1e5 } {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} + test range-3.1 {experiement} { set ans {} foreach factor [range 2.0 10.0] { @@ -224,41 +190,25 @@ test range-3.1 {experiement} { set ans } {OK} -test range-3.2 {error case} { - -body { - range foo - } - -returnCodes 1 - -result {bad start value: "foo"} -} +test range-3.2 {error case} -body { + range foo +} -returnCodes 1 -result {bad start value: "foo"} -test range-3.3 {error case} { - -body { - range 10 foo - } - -returnCodes 1 - -result {bad end value: "foo"} -} +test range-3.3 {error case} -body { + range 10 foo +} -returnCodes 1 -result {bad end value: "foo"} -test range-3.4 {error case} { - -body { - range 25 or 6 - } - -returnCodes 1 - -result {bad range operation "or": must be .., to, count, or by} -} +test range-3.4 {error case} -body { + range 25 or 6 +} -returnCodes 1 -result {bad range operation "or": must be .., to, count, or by} test range-3.5 {simple count and step arguments} { range 25 by 6 } {0 6 12 18 24} -test range-3.6 {error case} { - -body { - range 1 7 or 3 - } - -returnCodes 1 - -result {bad step keyword "or": must be by} -} +test range-3.6 {error case} -body { + range 1 7 or 3 +} -returnCodes 1 -result {bad step keyword "or": must be by} test range-3.7 {lmap range} { lmap x [range 5] { expr {$x * $x} } @@ -269,17 +219,18 @@ test range-3.8 {lrange range} { lindex [tcl::unsupported::representation $r] 3 } {arithseries} -test range-3.9 {lassign range} { +test range-3.9 {lassign range} arithSeriesShimmer { set r [range 15] - lassign $r a b - list [lindex [tcl::unsupported::representation $r] 3] $a $b -} {arithseries 0 1} + set r2 [lassign $r a b] + list [lindex [tcl::unsupported::representation $r] 3] $a $b \ + [lindex [tcl::unsupported::representation $r2] 3] +} {arithseries 0 1 arithseries} -test range-3.10 {lsearch range} { +test range-3.10 {lsearch range must shimmer?} arithSeriesShimmer { set r [range 15 0] set a [lsearch $r 9] list [lindex [tcl::unsupported::representation $r] 3] $a -} {arithseries 6} +} {list 6} test range-3.11 {lreverse range} { set r [range 15 0] -- cgit v0.12 From 59814de67b021d7f37ac7dd71c6943e223cab441 Mon Sep 17 00:00:00 2001 From: griffin Date: Sat, 16 Jul 2022 17:25:33 +0000 Subject: Fix nroff errors in range man page. --- doc/range.n | 65 ++++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 36 insertions(+), 29 deletions(-) diff --git a/doc/range.n b/doc/range.n index 16e0079..f6b5f17 100644 --- a/doc/range.n +++ b/doc/range.n @@ -31,36 +31,43 @@ and use the numeric result, or error as with any invalid argument value. .SH EXAMPLES .CS -\fBrange\fR 3 - \fI\(-> 0 1 2\fR -\fBrange\fR 3 0 - \fI\(-> 3 2 1 0\fR -\fBrange\fR 10 .. 1 by 2 - \fI\(-> 10 8 6 4 2\fR -set l [\fBrange\fR 0 -5] - \fI\(-> 0 -1 -2 -3 -4 -5\fR -\fRforeach i [\fBrange\fR [llength $l]] { +.\" + + range 3 + \(-> 0 1 + + range 3 0 + \(-> 3 2 1 0 + + range 10 .. 1 by 2 + \(-> 10 8 6 4 2 + + set l [range 0 -5] + \(-> 0 -1 -2 -3 -4 -5 + + foreach i [range [llength $l]] { + puts l($i)=[lindex $l $i] + } + \(-> l(0)=0 + l(1)=-1 + l(2)=-2 + l(3)=-3 + l(4)=-4 + l(5)=-5 + + foreach i [range [llength $l]-1 0] { puts l($i)=[lindex $l $i] -} - \fI\(-> l(0)=0 - l(1)=-1 - l(2)=-2 - l(3)=-3 - l(4)=-4 - l(5)=-5 -\fRforeach i [\fBrange\fR [llength $l]-1 0] { - puts l($i)=[lindex $l $i] -} - \fI\(-> l(5)=-5 - l(4)=-4 - l(3)=-3 - l(2)=-2 - l(1)=-1 - l(0)=0 - -set sqrs [lmap i [\fBrange\fR 1 10] {expr $i*$i}] - \fI\(-> 1 4 9 16 25 36 49 64 81 100\fR - + } + \(-> l(5)=-5 + l(4)=-4 + l(3)=-3 + l(2)=-2 + l(1)=-1 + l(0)=0 + + set sqrs [lmap i [range 1 10] {expr $i*$i}] + \(-> 1 4 9 16 25 36 49 64 81 100 +.\" .CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n), -- cgit v0.12 From 91d2dee1010be253cb830d0e45bb10cdc17ac523 Mon Sep 17 00:00:00 2001 From: griffin Date: Fri, 22 Jul 2022 19:15:12 +0000 Subject: Rewrite argument processing code. All correct and error conditions are handled. Add some new tests and disable some tests that should maybe work. --- generic/tclCmdMZ.c | 564 +++++++++++++++++++++++++++++++++++------------------ tests/range.test | 81 +++++++- 2 files changed, 447 insertions(+), 198 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3442d10..23df26f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -63,6 +63,24 @@ const char tclDefaultTrimSet[] = "\xE3\x80\x80" /* ideographic space (U+3000) */ "\xEF\xBB\xBF" /* zero width no-break space (U+feff) */ ; + +/* + * Definitions for [lseq] command + */ +static const char *const seq_operations[] = { + "..", "to", "count", "by", NULL +}; +typedef enum Sequence_Operators { + RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY +} SequenceOperators; +static const char *const seq_step_keywords[] = {"by", NULL}; +typedef enum Step_Operators { + STEP_BY = 4 +} SequenceByMode; +typedef enum Sequence_Decoded { + NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg +} SequenceDecoded; + /* *---------------------------------------------------------------------- @@ -107,229 +125,391 @@ Tcl_PwdObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_RangeObjCmd -- - * - * This procedure is invoked to process the "range" Tcl command. See - * the user documentation for details on what it does. - * - * Results: - * A standard Tcl object result. + * SequenceIdentifyArgument -- * - * Side effects: - * See the user documentation. + * Given a Tcl_Obj, identify if it is a keyword or a number + * + * Return Value + * 0 - failure, unexpected value + * 1 - value is a number + * 2 - value is an operand keyword + * 3 - value is a by keyword * - *---------------------------------------------------------------------- + * The decoded value will be assigned to the appropriate + * pointer, if supplied. */ -int -Tcl_RangeObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) - /* The argument objects. */ +static SequenceDecoded +SequenceIdentifyArgument( + Tcl_Interp *interp, /* for error reporting */ + Tcl_Obj *argPtr, /* Argument to decode */ + Tcl_WideInt *intValuePtr, /* Return numeric value */ + int *keywordIndexPtr) /* Return keyword enum */ { - Tcl_WideInt elementCount = -1; - Tcl_Obj *const *argPtr; - Tcl_WideInt start, end, step; - Tcl_Obj *OPError = NULL, *BYError = NULL; - int argc, status; - Tcl_Obj *arithSeriesPtr; - static const char *const operations[] = { - "..", "to", "count", "by", NULL - }; - enum Range_Operators { - RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY - } opmode; - static const char *const step_keywords[] = {"by", NULL}; - enum Step_Operators { - STEP_BY - } bymode; - - /* - * Check arguments for legality: - * range from op to ?by step? - */ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "start op end ?by step?"); - status = TCL_ERROR; - goto done; - } - - argc = objc; - argPtr = objv; - - /* Skip command name */ - /* Process first argument */ - argPtr++; - argc--; - - /* From argument */ - status = Tcl_GetWideIntFromObj(NULL, *argPtr, &start); + int status; + Tcl_WideInt number; + SequenceOperators opmode; + SequenceByMode bymode; + + status = Tcl_GetWideIntFromObj(NULL, argPtr, &number); if (status != TCL_OK) { /* Check for an index expression */ long value; Tcl_InterpState savedstate; savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, *argPtr, &value) != TCL_OK) { + if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { status = Tcl_RestoreInterpState(interp, savedstate); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad start value: \"%s\"", - Tcl_GetString(*argPtr))); - goto done; } else { status = Tcl_RestoreInterpState(interp, savedstate); - start = value; - } - } - - /* Process ?Op? argument */ - argPtr++; - argc--; - - /* Decode range (optional) OPeration argument */ - if (argc && - Tcl_GetIndexFromObj(interp, *argPtr, operations, "range operation", 0, &opmode) == TCL_OK) { - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - opmode = RANGE_TO; - break; - case RANGE_COUNT: - break; - case RANGE_BY: - // count mode with a step value - end = start-1; - start = 0; - break; + if (intValuePtr) { + *intValuePtr = value; + } + return NumericArg; } - /* next argument */ - argPtr++; - argc--; } else { - if (objc > 3) { - OPError = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(OPError); - } else { - OPError = NULL; + if (intValuePtr) { + *intValuePtr = number; } - /* Default when not specified */ - opmode = RANGE_TO; + return NumericArg; } - - /* No more arguments, set the defaults */ - if (argc==0) { - end = start - (start>=0?1:-1); - start = 0; - step = 1; - } - - /* Process To argument */ - if (argc && (opmode == RANGE_TO || opmode == RANGE_COUNT)) { - if ((status = Tcl_GetWideIntFromObj(NULL, *argPtr, &end)) != TCL_OK) { - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - status = Tcl_ExprLongObj(interp, *argPtr, &value); - if (status == TCL_OK) end = value; - (void)Tcl_RestoreInterpState(interp, savedstate); // keep current status - } - if (status != TCL_OK) { - if (OPError) { - Tcl_SetObjResult(interp, OPError); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad end value: \"%s\"", Tcl_GetString(*argPtr))); - } - goto done; - } - - argPtr++; - argc--; - } - - /* Process ?by? argument */ - if (argc) { - if (Tcl_GetIndexFromObj(interp, *argPtr, step_keywords, "step keyword", 0, &bymode) == TCL_OK - && bymode == STEP_BY) { - argPtr++; - argc--; - } else { - BYError = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(BYError); + + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, + "range operation", 0, &opmode); + if (status == TCL_OK) { + if (keywordIndexPtr) { + *keywordIndexPtr = opmode; } + return RangeKeywordArg; } - - /* Proess Step argument */ - if (argc == 0) { - if (opmode == RANGE_COUNT) { - step = 1; - } else { - step = start < end ? 1 : -1; - } - } else { - status = Tcl_GetWideIntFromObj(NULL, *argPtr, &step); - if (status != TCL_OK) { - /* Evaluate possible expression */ - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, *argPtr, &value) == TCL_OK) { - step = value; - status = Tcl_RestoreInterpState(interp, savedstate); - } else { - status = Tcl_RestoreInterpState(interp, savedstate); - if (BYError) { - Tcl_SetObjResult(interp, BYError); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad step value: \"%s\"\n", - Tcl_GetString(*argPtr))); - } - goto done; - } + + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, + "step keyword", 0, &bymode); + if (status == TCL_OK) { + if (keywordIndexPtr) { + *keywordIndexPtr = bymode; } - argPtr++; - argc--; + return ByKeywordArg; } + return NoneArg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RangeObjCmd -- + * + * This procedure is invoked to process the "range" Tcl command. See + * the user documentation for details on what it does. + * + * Enumerated possible argument patterns: + * + * 1: + * range n + * 2: + * range n n + * 3: + * range n n n + * range n 'to' n + * range n 'count' n + * range n 'by' n + * 4: + * range n 'to' n n + * range n n 'by' n + * range n 'count' n n + * 5: + * range n 'to' n 'by' n + * range n 'count' n 'by' n + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - /* Calculate the number of elements in the return values */ - - if (step == 0 - || (opmode != RANGE_COUNT - && ((step < 0 && start <= end) || (step > 0 && end < start)))) { - step = 0; +int +Tcl_RangeObjCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt elementCount = -1; + Tcl_WideInt start = 0, end = 0, step = 0, number = 0; + Tcl_WideInt values[5]; + int status, keyword; + Tcl_Obj *arithSeriesPtr; + SequenceOperators opmode; + SequenceDecoded decoded; + int i, arg_key = 0, value_i = 0; + + /* + * Create a decoding key by looping through the arguments and identify + * what kind of argument each one is. Encode each argument as a decimal + * digit. + */ + if (objc > 6) { + /* Too many arguments */ + arg_key=0; + } else for (i=1; i empty list - end = start + (elementCount * step); - } else if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - - if (elementCount < 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad count \"%" TCL_LL_MODIFIER "d\": must be a number >= 0", elementCount)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RANGE", "NEGARG", NULL); - status = TCL_ERROR; - goto done; + /* + * The key encoding defines a valid set of arguments, or indicates an + * error condition; process the values accordningly. + */ + switch (arg_key) { + +/* No argument */ + case 0: + Tcl_WrongNumArgs(interp, 1, objv, + "n ??op? n ??by? n??"); + status = TCL_ERROR; + goto done; + break; + +/* range n */ + case 1: + start = 0; + elementCount = (values[0] <= 0 ? 0 : values[0]); + end = values[0]-1; + step = 1; + break; + +/* range n n */ + case 11: + start = values[0]; + end = values[1]; + step = (start <= end) ? 1 : -1; + if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + if (elementCount < 0) elementCount = 0; + break; + +/* range n n n */ + case 111: + start = values[0]; + end = values[1]; + step = values[2]; + if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + if (elementCount < 0) elementCount = 0; + break; + +/* range n 'to' n */ +/* range n 'count' n */ +/* range n 'by' n */ + case 121: + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = values[0]; + end = values[2]; + step = (start <= end) ? 1 : -1; + elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list + break; + case RANGE_BY: + start = 0; + elementCount = values[0]; + step = values[2]; + end = start + (step * elementCount); + elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list + break; + case RANGE_COUNT: + start = values[0]; + elementCount = (values[2] >= 0 ? values[2] : 0); + step = 1; + end = start + (step * elementCount); + break; + default: + status = TCL_ERROR; + goto done; + } + break; + +/* range n 'to' n n */ +/* range n 'count' n n */ + case 1211: + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = values[0]; + end = values[2]; + step = values[3]; + break; + case RANGE_COUNT: + start = values[0]; + elementCount = (values[2] >= 0 ? values[2] : 0); + step = values[3]; + end = start + (step * elementCount); + break; + case RANGE_BY: + /* Error case */ + status = TCL_ERROR; + goto done; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + break; + +/* range n n 'by' n */ + case 1121: + start = values[0]; + end = values[1]; + opmode = (SequenceOperators)values[2]; + switch (opmode) { + case RANGE_BY: + step = values[3]; + break; + case RANGE_DOTS: + case RANGE_TO: + case RANGE_COUNT: + default: + status = TCL_ERROR; + goto done; + break; + } + if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + break; + +/* range n 'to' n 'by' n */ +/* range n 'count' n 'by' n */ + case 12121: + start = values[0]; + opmode = (SequenceOperators)values[3]; + switch (opmode) { + case RANGE_BY: + step = values[4]; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = values[0]; + end = values[2]; + if ((step == 0) || + (start <= end && step < 0) || + (start >= end && step > 0)) { + elementCount = 0; + } else if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else if (step > 0) { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + break; + case RANGE_COUNT: + start = values[0]; + elementCount = (values[2] >= 0 ? values[2] : 0); + end = start + (step * elementCount); + break; + default: + status = TCL_ERROR; + goto done; + break; + } + break; + +/* Error cases: incomplete arguments */ + case 12: + opmode = values[1]; goto KeywordError; break; + case 112: + opmode = values[2]; goto KeywordError; break; + case 1212: + opmode = values[3]; goto KeywordError; break; + KeywordError: + status = TCL_ERROR; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing \"to\" value.")); + break; + case RANGE_COUNT: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing \"count\" value.")); + break; + case RANGE_BY: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "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??"); + goto done; + break; } + /* + * Success! Now lets create the series object. + */ arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step, elementCount); Tcl_SetObjResult(interp, arithSeriesPtr); status = TCL_OK; done: - if (OPError) { - Tcl_DecrRefCount(OPError); - } - if (BYError) { - Tcl_DecrRefCount(BYError); - } return status; } diff --git a/tests/range.test b/tests/range.test index 9ac0a7a..c68a8f9 100644 --- a/tests/range.test +++ b/tests/range.test @@ -16,13 +16,14 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 0 testConstraint arithSeriesShimmer 1 +testConstraint arithSeriesShimmerOk 0 ## Arg errors test range-1.1 {error cases} -body { range } \ -returnCodes 1 \ - -result {wrong # args: should be "range start op end ?by step?"} + -result {wrong # args: should be "range n ??op? n ??by? n??"} test range-1.2 {step magnitude} { @@ -100,6 +101,18 @@ test range-1.16 {large numbers} { -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} } +test range-1.17 {too many arguments} -body { + range 12 to 24 by 2 with feeling +} -returnCodes 1 -result {wrong # args: should be "range n ??op? n ??by? n??"} + +test range-1.18 {too many arguments extra valid keyword} -body { + range 12 to 24 by 2 count +} -returnCodes 1 -result {wrong # args: should be "range n ??op? n ??by? n??"} + +test range-1.19 {too many arguments extra numeric value} -body { + range 12 to 24 by 2 7 +} -returnCodes 1 -result {wrong # args: should be "range n ??op? n ??by? n??"} + # # Short-hand use cases # @@ -192,23 +205,23 @@ test range-3.1 {experiement} { test range-3.2 {error case} -body { range foo -} -returnCodes 1 -result {bad start value: "foo"} +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} test range-3.3 {error case} -body { range 10 foo -} -returnCodes 1 -result {bad end value: "foo"} +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} test range-3.4 {error case} -body { range 25 or 6 -} -returnCodes 1 -result {bad range operation "or": must be .., to, count, or by} +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} test range-3.5 {simple count and step arguments} { range 25 by 6 -} {0 6 12 18 24} +} {0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144 150} test range-3.6 {error case} -body { range 1 7 or 3 -} -returnCodes 1 -result {bad step keyword "or": must be by} +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} test range-3.7 {lmap range} { lmap x [range 5] { expr {$x * $x} } @@ -245,6 +258,60 @@ test range-3.11 {lreverse range} { arithseries 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} +test range-3.12 {in operator} { + set r [range 9] + set i [expr {7 in $r}] + set j [expr {10 ni $r}] + set k [expr {-1 in $r}] + set l [expr {4 ni $r}] + list $i $j $k $l [lindex [tcl::unsupported::representation $r] 3] +} {1 1 0 0 arithseries} + +test range-3.13 {lmap range shimmer} arithSeriesShimmer { + set r [range 15] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set m [lmap i $r { expr {$i * 7} }] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + set rep-m [lindex [tcl::unsupported::representation $m] 3] + list $r ${rep-before} ${rep-after} ${rep-m} $m +} {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}} + +test range-3.14 {array for shimmer} arithSeriesShimmerOk { + array set testarray {a Test for This great Function} + set vars [range 2] + set vars-rep [lindex [tcl::unsupported::representation $vars] 3] + array for $vars testarray { + lappend keys $0 + lappend vals $1 + } + # Since hash order is not guaranteed, have to validate content ignoring order + set valk [lmap k $keys {expr {$k in {a for great}}}] + set valv [lmap v $vals {expr {$v in {Test This Function}}}] + set vars-after [lindex [tcl::unsupported::representation $vars] 3] + list ${vars-rep} $valk $valv ${vars-after} +} {arithseries {1 1 1} {1 1 1} arithseries} + +test range-3.15 {join for shimmer} arithSeriesShimmerOk { + set r [range 3] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set str [join $r :] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $str ${rep-after} +} {arithseries 0:1:2 arithseries} + +test range-3.16 {error case} -body { + range 16 to +} -returnCodes 1 -result {missing "to" value.} + +test range-3.17 {error case} -body { + range 17 to 13 by +} -returnCodes 1 -result {missing "by" value.} + +test range-3.18 {error case} -body { + range 18 count +} -returnCodes 1 -result {missing "count" value.} + + # Test lmap # Test "in" expression operator # Test llength @@ -253,6 +320,8 @@ arithseries # Test start,end,step expressions # Test lreverse # Test lsearch +# Test array for +# Test join for shimmer. test range-4.1 {end expressions} { set start 7 -- cgit v0.12 From c0b4b17c115f5bd0872e62ff51bf9230c41a3089 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 24 Jul 2022 20:04:58 +0000 Subject: Fix windows build (invalid '&'). Eliminate end-of-line spacing --- doc/range.n | 14 +++++++------- generic/tclCmdAH.c | 2 +- generic/tclCmdIL.c | 2 +- generic/tclCmdMZ.c | 24 ++++++++++++------------ generic/tclExecute.c | 6 +++--- generic/tclListObj.c | 22 +++++++++++----------- tests/range.test | 2 +- 7 files changed, 36 insertions(+), 36 deletions(-) diff --git a/doc/range.n b/doc/range.n index f6b5f17..9978bb9 100644 --- a/doc/range.n +++ b/doc/range.n @@ -32,19 +32,19 @@ and use the numeric result, or error as with any invalid argument value. .SH EXAMPLES .CS .\" - + range 3 \(-> 0 1 - + range 3 0 \(-> 3 2 1 0 - + range 10 .. 1 by 2 \(-> 10 8 6 4 2 - + set l [range 0 -5] \(-> 0 -1 -2 -3 -4 -5 - + foreach i [range [llength $l]] { puts l($i)=[lindex $l $i] } @@ -54,7 +54,7 @@ and use the numeric result, or error as with any invalid argument value. l(3)=-3 l(4)=-4 l(5)=-5 - + foreach i [range [llength $l]-1 0] { puts l($i)=[lindex $l $i] } @@ -64,7 +64,7 @@ and use the numeric result, or error as with any invalid argument value. l(2)=-2 l(1)=-1 l(0)=0 - + set sqrs [lmap i [range 1 10] {expr $i*$i}] \(-> 1 4 9 16 25 36 49 64 81 100 .\" diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 41b7403..73ef295 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2979,7 +2979,7 @@ ForeachAssignments( valuePtr = Tcl_NewWideIntObj(value); } else { valuePtr = statePtr->argvList[i][k]; - } + } } else { TclNewObj(valuePtr); /* Empty string */ } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c593afc..8213d45 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3072,7 +3072,7 @@ Tcl_LreverseObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "list"); return TCL_ERROR; } - + /* * Handle ArithSeries special case - don't shimmer a series into a list * just to reverse it. diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 23df26f..c48771a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -128,7 +128,7 @@ Tcl_PwdObjCmd( * SequenceIdentifyArgument -- * * Given a Tcl_Obj, identify if it is a keyword or a number - * + * * Return Value * 0 - failure, unexpected value * 1 - value is a number @@ -150,7 +150,7 @@ SequenceIdentifyArgument( Tcl_WideInt number; SequenceOperators opmode; SequenceByMode bymode; - + status = Tcl_GetWideIntFromObj(NULL, argPtr, &number); if (status != TCL_OK) { /* Check for an index expression */ @@ -172,7 +172,7 @@ SequenceIdentifyArgument( } return NumericArg; } - + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, "range operation", 0, &opmode); if (status == TCL_OK) { @@ -181,7 +181,7 @@ SequenceIdentifyArgument( } return RangeKeywordArg; } - + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, "step keyword", 0, &bymode); if (status == TCL_OK) { @@ -245,7 +245,7 @@ Tcl_RangeObjCmd( SequenceDecoded decoded; int i, arg_key = 0, value_i = 0; - /* + /* * Create a decoding key by looping through the arguments and identify * what kind of argument each one is. Encode each argument as a decimal * digit. @@ -259,7 +259,7 @@ Tcl_RangeObjCmd( switch (decoded) { case NoneArg: - /* + /* * Unrecognizable argument * Reproduce operation error message */ @@ -278,13 +278,13 @@ Tcl_RangeObjCmd( values[value_i] = keyword; value_i++; break; - + case ByKeywordArg: arg_key += ByKeywordArg; values[value_i] = keyword; value_i++; break; - + default: arg_key += 9; // Error state value_i++; @@ -305,7 +305,7 @@ Tcl_RangeObjCmd( status = TCL_ERROR; goto done; break; - + /* range n */ case 1: start = 0; @@ -339,7 +339,7 @@ Tcl_RangeObjCmd( } if (elementCount < 0) elementCount = 0; break; - + /* range n 'to' n */ /* range n 'count' n */ /* range n 'by' n */ @@ -400,7 +400,7 @@ Tcl_RangeObjCmd( break; } break; - + /* range n n 'by' n */ case 1121: start = values[0]; @@ -424,7 +424,7 @@ Tcl_RangeObjCmd( elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list } break; - + /* range n 'to' n 'by' n */ /* range n 'count' n 'by' n */ case 12121: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c9ee65d..407b4ed 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4927,7 +4927,7 @@ TEBCresume( ArithSeries *arithSeriesRepPtr = (ArithSeries*) valuePtr->internalRep.twoPtrValue.ptr1; length = arithSeriesRepPtr->len; - + /* Decode end-offset index values. */ index = TclIndexDecode(opnd, length); @@ -4963,9 +4963,9 @@ TEBCresume( } else { TclNewObj(objResultPtr); } - + lindexFastPath2: - + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_F(pcAdjustment, 1, 1); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index ef7d515..2bcca64 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -845,7 +845,7 @@ Tcl_ListObjIndex( List *listRepPtr; ListGetInternalRep(listPtr, listRepPtr); - + if (listRepPtr == NULL && TclHasInternalRep(listPtr,&tclArithSeriesType)) { Tcl_WideInt widint; if (Tcl_ArithSeriesObjIndex(listPtr, index, &widint) == TCL_OK) { @@ -853,7 +853,7 @@ Tcl_ListObjIndex( return TCL_OK; } } - + if (listRepPtr == NULL) { int result; int length; @@ -920,7 +920,7 @@ Tcl_ListObjLength( *intPtr = Tcl_ArithSeriesObjLength(listPtr); return TCL_OK; } - + (void) Tcl_GetStringFromObj(listPtr, &length); if (length == 0) { *intPtr = 0; @@ -2060,14 +2060,14 @@ SetListFromAny( if (listRepPtr == NULL) { return TCL_ERROR; } - elemPtrs = &listRepPtr->elements; + elemPtrs = listRepPtr->elements; for (j = 0; j < wideLen; j++) { elemPtrs[j] = Tcl_NewWideIntObj( ArithSeriesIndexM(arithSeriesRepPtr, j)); //->start+(j*arithSeriesRepPtr->step)); Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */ } - listRepPtr->elemCount = wideLen; - + listRepPtr->elemCount = wideLen; + } else { int estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); @@ -2260,7 +2260,7 @@ static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); * * 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: @@ -2464,7 +2464,7 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) * DupArithSeriesInternalRep -- * * Initialize the internal representation of a arithseries Tcl_Obj to a - * copy of the internal representation of an existing arithseries object. + * copy of the internal representation of an existing arithseries object. * * Results: * None. @@ -2507,7 +2507,7 @@ DupArithSeriesInternalRep(srcPtr, copyPtr) * * 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. + * so storage will be lost if this has not already been done. * * Results: * None. @@ -2677,9 +2677,9 @@ TclArithSeriesObjRange( { ArithSeries *arithSeriesRepPtr; Tcl_WideInt start = -1, end = -1, step, len; - + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); - + if (fromIdx < 0) { fromIdx = 0; } diff --git a/tests/range.test b/tests/range.test index c68a8f9..d1e96ad 100644 --- a/tests/range.test +++ b/tests/range.test @@ -163,7 +163,7 @@ test range-2.12 {decreasing range with step} arithSeriesDouble { } { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} test range-2.13 {count only operation} { - range 5 + range 5 } {0 1 2 3 4} test range-2.14 {count with step} { -- cgit v0.12 From 83338ca1ed9e949a6a68ea80c7bdc4a103ea1c05 Mon Sep 17 00:00:00 2001 From: griffin Date: Sun, 14 Aug 2022 01:22:24 +0000 Subject: Rename command from "range" to "lseq". Remove public C API calls, not part of the TIP. Fix shimmer in [join] command. Implement GetElements call for ArithSeries. --- doc/lseq.n | 81 +++++++++ generic/tcl.decls | 11 -- generic/tclBasic.c | 2 +- generic/tclCmdAH.c | 4 +- generic/tclCmdIL.c | 489 ++++++++++++++++++++++++++++++++++++++++++++++++-- generic/tclCmdMZ.c | 409 ----------------------------------------- generic/tclDecls.h | 18 -- generic/tclInt.h | 17 +- generic/tclListObj.c | 125 +++++++++++-- generic/tclStubInit.c | 3 - tests/lseq.test | 387 +++++++++++++++++++++++++++++++++++++++ 11 files changed, 1066 insertions(+), 480 deletions(-) create mode 100644 doc/lseq.n create mode 100644 tests/lseq.test diff --git a/doc/lseq.n b/doc/lseq.n new file mode 100644 index 0000000..0e452d8 --- /dev/null +++ b/doc/lseq.n @@ -0,0 +1,81 @@ +'\" +'\" Copyright (c) 2022 Eric Taylor. 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 lseq n 8.7 Tcl "Tcl Built-In Commands" +.so man.macros +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +lseq \- Build a numeric sequence returned as a list +.SH SYNOPSIS +\fBlseq \fIStart \fR?(\fB..\fR|\fBto\fR)? \fIEnd\fR ??\fBby\fR? \fIStep\fR? + +\fBlseq \fIStart \fBcount\fR \fICount\fR ??\fBby\fR? \fIStep\fR? + +\fBlseq \fICount\fR ?\fBby \fIStep\fR? +.BE +.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 ".." or "to" defines an inclusive range. The "count" option is used +to define a count of the number of elements in the list. The short form with a +single count value will create a range from 0 to count-1. + +The numeric arguments, \fIStart\fR, \fIEnd\fR, \fIStep\fR, and \fICount\fR, +can also be a valid expression. the lseq command will evaluate the expression +and use the numeric result, or error as with any invalid argument value. + +.SH EXAMPLES +.CS +.\" + + lseq 3 + \(-> 0 1 + + lseq 3 0 + \(-> 3 2 1 0 + + lseq 10 .. 1 by 2 + \(-> 10 8 6 4 2 + + set l [lseq 0 -5] + \(-> 0 -1 -2 -3 -4 -5 + + foreach i [lseq [llength $l]] { + puts l($i)=[lindex $l $i] + } + \(-> l(0)=0 + l(1)=-1 + l(2)=-2 + l(3)=-3 + l(4)=-4 + l(5)=-5 + + foreach i [lseq [llength $l]-1 0] { + puts l($i)=[lindex $l $i] + } + \(-> l(5)=-5 + l(4)=-4 + l(3)=-3 + l(2)=-2 + l(1)=-1 + l(0)=0 + + set sqrs [lmap i [lseq 1 10] {expr $i*$i}] + \(-> 1 4 9 16 25 36 49 64 81 100 +.\" +.CE +.SH "SEE ALSO" +foreach(n), list(n), lappend(n), lassign(n), 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 +'\" Local Variables: +'\" mode: nroff +'\" fill-column: 78 +'\" End: diff --git a/generic/tcl.decls b/generic/tcl.decls index a200bbb..99c0e25 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2501,17 +2501,6 @@ declare 672 { declare 673 { int TclGetUniChar(Tcl_Obj *objPtr, int index) } -declare 674 generic { - Tcl_Obj * Tcl_NewArithSeriesObj(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) -} -declare 675 generic { - int Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, - Tcl_WideInt *element) -} -declare 676 generic { - Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) -} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b78e983..6727118 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -322,11 +322,11 @@ static const CmdInfo builtInCmds[] = { {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"range", Tcl_RangeObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 73ef295..f31eabc 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2830,7 +2830,7 @@ EachloopCmd( goto done; } /* Don't compute values here, wait until the last momement */ - statePtr->argcList[i] = Tcl_ArithSeriesObjLength(statePtr->vCopyList[i]); + statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->vCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); @@ -2969,7 +2969,7 @@ ForeachAssignments( if (k < statePtr->argcList[i]) { if (isarithseries) { Tcl_WideInt value; - if (Tcl_ArithSeriesObjIndex(statePtr->vCopyList[i], k, &value) != TCL_OK) { + if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &value) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8213d45..065bc2a 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -95,6 +95,23 @@ typedef struct { #define SORTMODE_ASCII_NC 8 /* + * Definitions for [lseq] command + */ +static const char *const seq_operations[] = { + "..", "to", "count", "by", NULL +}; +typedef enum Sequence_Operators { + RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY +} SequenceOperators; +static const char *const seq_step_keywords[] = {"by", NULL}; +typedef enum Step_Operators { + STEP_BY = 4 +} SequenceByMode; +typedef enum Sequence_Decoded { + NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg +} SequenceDecoded; + +/* * Forward declarations for procedures defined in this file: */ @@ -2182,7 +2199,7 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int length, listLen; + int length, listLen, isArithSeries = 0; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2195,9 +2212,14 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclListObjGetElementsM(interp, objv[1], &listLen, + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + isArithSeries = 1; + listLen = TclArithSeriesObjLength(objv[1]); + } else { + if (TclListObjGetElementsM(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; + } } if (listLen == 0) { @@ -2206,7 +2228,15 @@ Tcl_JoinObjCmd( } if (listLen == 1) { /* One element; return it */ - Tcl_SetObjResult(interp, elemPtrs[0]); + if (isArithSeries) { + Tcl_WideInt value; + if (TclArithSeriesObjIndex(objv[1], 0, &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(value)); + } else { + Tcl_SetObjResult(interp, elemPtrs[0]); + } return TCL_OK; } @@ -2220,19 +2250,40 @@ Tcl_JoinObjCmd( int i; TclNewObj(resObjPtr); - for (i = 0; i < listLen; i++) { - if (i > 0) { + if (isArithSeries) { + Tcl_WideInt value; + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ + + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + if (TclArithSeriesObjIndex(objv[1], i, &value) != TCL_OK) { + return TCL_ERROR; + } + Tcl_AppendObjToObj(resObjPtr, Tcl_NewWideIntObj(value)); + } + } else { + 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, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } } Tcl_DecrRefCount(joinObjPtr); @@ -3081,17 +3132,17 @@ Tcl_LreverseObjCmd( ArithSeries *arithSeriesPtr = ArithSeriesRepPtr(objv[1]); Tcl_WideInt rstart, rend, rstep, len; - len = Tcl_ArithSeriesObjLength(objv[1]); - if (Tcl_ArithSeriesObjIndex(objv[1], 0, &rend) != TCL_OK) { + len = TclArithSeriesObjLength(objv[1]); + if (TclArithSeriesObjIndex(objv[1], 0, &rend) != TCL_OK) { return TCL_ERROR; } - if (Tcl_ArithSeriesObjIndex(objv[1], (len-1), &rstart) != TCL_OK) { + if (TclArithSeriesObjIndex(objv[1], (len-1), &rstart) != TCL_OK) { return TCL_ERROR; } rstep = -arithSeriesPtr->step; if (Tcl_IsShared(objv[1])) { - Tcl_Obj *resultObj = Tcl_NewArithSeriesObj(rstart, rend, rstep, len); + Tcl_Obj *resultObj = TclNewArithSeriesObj(rstart, rend, rstep, len); Tcl_SetObjResult(interp, resultObj); } else { @@ -4002,6 +4053,401 @@ Tcl_LsetObjCmd( /* *---------------------------------------------------------------------- * + * SequenceIdentifyArgument -- + * (for [lseq] command) + * + * Given a Tcl_Obj, identify if it is a keyword or a number + * + * Return Value + * 0 - failure, unexpected value + * 1 - value is a number + * 2 - value is an operand keyword + * 3 - value is a by keyword + * + * The decoded value will be assigned to the appropriate + * pointer, if supplied. + */ + +static SequenceDecoded +SequenceIdentifyArgument( + Tcl_Interp *interp, /* for error reporting */ + Tcl_Obj *argPtr, /* Argument to decode */ + Tcl_WideInt *intValuePtr, /* Return numeric value */ + int *keywordIndexPtr) /* Return keyword enum */ +{ + int status; + Tcl_WideInt number; + SequenceOperators opmode; + SequenceByMode bymode; + + status = Tcl_GetWideIntFromObj(NULL, argPtr, &number); + if (status != TCL_OK) { + /* Check for an index expression */ + long value; + Tcl_InterpState savedstate; + savedstate = Tcl_SaveInterpState(interp, status); + if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { + status = Tcl_RestoreInterpState(interp, savedstate); + } else { + status = Tcl_RestoreInterpState(interp, savedstate); + if (intValuePtr) { + *intValuePtr = value; + } + return NumericArg; + } + } else { + if (intValuePtr) { + *intValuePtr = number; + } + return NumericArg; + } + + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, + "range operation", 0, &opmode); + if (status == TCL_OK) { + if (keywordIndexPtr) { + *keywordIndexPtr = opmode; + } + return RangeKeywordArg; + } + + status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, + "step keyword", 0, &bymode); + if (status == TCL_OK) { + if (keywordIndexPtr) { + *keywordIndexPtr = bymode; + } + return ByKeywordArg; + } + return NoneArg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LseqObjCmd -- + * + * This procedure is invoked to process the "range" Tcl command. See + * the user documentation for details on what it does. + * + * Enumerated possible argument patterns: + * + * 1: + * range n + * 2: + * range n n + * 3: + * range n n n + * range n 'to' n + * range n 'count' n + * range n 'by' n + * 4: + * range n 'to' n n + * range n n 'by' n + * range n 'count' n n + * 5: + * range n 'to' n 'by' n + * range n 'count' n 'by' n + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LseqObjCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt elementCount = -1; + Tcl_WideInt start = 0, end = 0, step = 0, number = 0; + Tcl_WideInt values[5]; + int status, keyword; + Tcl_Obj *arithSeriesPtr; + SequenceOperators opmode; + SequenceDecoded decoded; + int i, arg_key = 0, value_i = 0; + + /* + * Create a decoding key by looping through the arguments and identify + * what kind of argument each one is. Encode each argument as a decimal + * digit. + */ + if (objc > 6) { + /* Too many arguments */ + arg_key=0; + } else for (i=1; i empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + if (elementCount < 0) elementCount = 0; + break; + +/* range n n n */ + case 111: + start = values[0]; + end = values[1]; + step = values[2]; + if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + if (elementCount < 0) elementCount = 0; + break; + +/* range n 'to' n */ +/* range n 'count' n */ +/* range n 'by' n */ + case 121: + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = values[0]; + end = values[2]; + step = (start <= end) ? 1 : -1; + elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list + break; + case RANGE_BY: + start = 0; + elementCount = values[0]; + step = values[2]; + end = start + (step * elementCount); + elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list + break; + case RANGE_COUNT: + start = values[0]; + elementCount = (values[2] >= 0 ? values[2] : 0); + step = 1; + end = start + (step * elementCount); + break; + default: + status = TCL_ERROR; + goto done; + } + break; + +/* range n 'to' n n */ +/* range n 'count' n n */ + case 1211: + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = values[0]; + end = values[2]; + step = values[3]; + break; + case RANGE_COUNT: + start = values[0]; + elementCount = (values[2] >= 0 ? values[2] : 0); + step = values[3]; + end = start + (step * elementCount); + break; + case RANGE_BY: + /* Error case */ + status = TCL_ERROR; + goto done; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + break; + +/* range n n 'by' n */ + case 1121: + start = values[0]; + end = values[1]; + opmode = (SequenceOperators)values[2]; + switch (opmode) { + case RANGE_BY: + step = values[3]; + break; + case RANGE_DOTS: + case RANGE_TO: + case RANGE_COUNT: + default: + status = TCL_ERROR; + goto done; + break; + } + if (start <= end) { + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + } else { + elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + } + break; + +/* range n 'to' n 'by' n */ +/* range n 'count' n 'by' n */ + case 12121: + start = values[0]; + opmode = (SequenceOperators)values[3]; + switch (opmode) { + case RANGE_BY: + step = values[4]; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = values[0]; + end = values[2]; + if ((step == 0) || + (start < end && step < 0) || + (start > end && step > 0)) { + elementCount = 0; + } else { + elementCount = (end-start+step)/step; + } + break; + case RANGE_COUNT: + start = values[0]; + elementCount = (values[2] >= 0 ? values[2] : 0); + if (step != 0) { + end = start + (step * elementCount); + } else { + end = start; + elementCount = 0; /* empty list when step is 0 */ + } + break; + default: + status = TCL_ERROR; + goto done; + break; + } + break; + +/* Error cases: incomplete arguments */ + case 12: + opmode = (SequenceOperators)values[1]; goto KeywordError; break; + case 112: + opmode = (SequenceOperators)values[2]; goto KeywordError; break; + case 1212: + opmode = (SequenceOperators)values[3]; goto KeywordError; break; + KeywordError: + status = TCL_ERROR; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing \"to\" value.")); + break; + case RANGE_COUNT: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing \"count\" value.")); + break; + case RANGE_BY: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "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??"); + goto done; + break; + } + + /* + * Success! Now lets create the series object. + */ + arithSeriesPtr = TclNewArithSeriesObj(start, end, step, elementCount); + Tcl_SetObjResult(interp, arithSeriesPtr); + status = TCL_OK; + + done: + return status; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_LsortObjCmd -- * * This procedure is invoked to process the "lsort" Tcl command. See the @@ -4267,8 +4713,13 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + sortInfo.resultCode = TclArithSeriesGetElements(interp, + listObj, &length, &listObjPtrs); + } else { + sortInfo.resultCode = TclListObjGetElementsM(interp, listObj, &length, &listObjPtrs); + } if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c48771a..cff182d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -16,7 +16,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" #include "tclCompile.h" #include "tclRegexp.h" @@ -64,23 +63,6 @@ const char tclDefaultTrimSet[] = "\xEF\xBB\xBF" /* zero width no-break space (U+feff) */ ; -/* - * Definitions for [lseq] command - */ -static const char *const seq_operations[] = { - "..", "to", "count", "by", NULL -}; -typedef enum Sequence_Operators { - RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY -} SequenceOperators; -static const char *const seq_step_keywords[] = {"by", NULL}; -typedef enum Step_Operators { - STEP_BY = 4 -} SequenceByMode; -typedef enum Sequence_Decoded { - NoneArg, NumericArg, RangeKeywordArg, ByKeywordArg -} SequenceDecoded; - /* *---------------------------------------------------------------------- @@ -125,397 +107,6 @@ Tcl_PwdObjCmd( /* *---------------------------------------------------------------------- * - * SequenceIdentifyArgument -- - * - * Given a Tcl_Obj, identify if it is a keyword or a number - * - * Return Value - * 0 - failure, unexpected value - * 1 - value is a number - * 2 - value is an operand keyword - * 3 - value is a by keyword - * - * The decoded value will be assigned to the appropriate - * pointer, if supplied. - */ - -static SequenceDecoded -SequenceIdentifyArgument( - Tcl_Interp *interp, /* for error reporting */ - Tcl_Obj *argPtr, /* Argument to decode */ - Tcl_WideInt *intValuePtr, /* Return numeric value */ - int *keywordIndexPtr) /* Return keyword enum */ -{ - int status; - Tcl_WideInt number; - SequenceOperators opmode; - SequenceByMode bymode; - - status = Tcl_GetWideIntFromObj(NULL, argPtr, &number); - if (status != TCL_OK) { - /* Check for an index expression */ - long value; - Tcl_InterpState savedstate; - savedstate = Tcl_SaveInterpState(interp, status); - if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { - status = Tcl_RestoreInterpState(interp, savedstate); - } else { - status = Tcl_RestoreInterpState(interp, savedstate); - if (intValuePtr) { - *intValuePtr = value; - } - return NumericArg; - } - } else { - if (intValuePtr) { - *intValuePtr = number; - } - return NumericArg; - } - - status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, - "range operation", 0, &opmode); - if (status == TCL_OK) { - if (keywordIndexPtr) { - *keywordIndexPtr = opmode; - } - return RangeKeywordArg; - } - - status = Tcl_GetIndexFromObj(NULL, argPtr, seq_step_keywords, - "step keyword", 0, &bymode); - if (status == TCL_OK) { - if (keywordIndexPtr) { - *keywordIndexPtr = bymode; - } - return ByKeywordArg; - } - return NoneArg; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RangeObjCmd -- - * - * This procedure is invoked to process the "range" Tcl command. See - * the user documentation for details on what it does. - * - * Enumerated possible argument patterns: - * - * 1: - * range n - * 2: - * range n n - * 3: - * range n n n - * range n 'to' n - * range n 'count' n - * range n 'by' n - * 4: - * range n 'to' n n - * range n n 'by' n - * range n 'count' n n - * 5: - * range n 'to' n 'by' n - * range n 'count' n 'by' n - * - * Results: - * A standard Tcl object result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RangeObjCmd( - TCL_UNUSED(ClientData), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Tcl_WideInt elementCount = -1; - Tcl_WideInt start = 0, end = 0, step = 0, number = 0; - Tcl_WideInt values[5]; - int status, keyword; - Tcl_Obj *arithSeriesPtr; - SequenceOperators opmode; - SequenceDecoded decoded; - int i, arg_key = 0, value_i = 0; - - /* - * Create a decoding key by looping through the arguments and identify - * what kind of argument each one is. Encode each argument as a decimal - * digit. - */ - if (objc > 6) { - /* Too many arguments */ - arg_key=0; - } else for (i=1; i empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - if (elementCount < 0) elementCount = 0; - break; - -/* range n n n */ - case 111: - start = values[0]; - end = values[1]; - step = values[2]; - if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - if (elementCount < 0) elementCount = 0; - break; - -/* range n 'to' n */ -/* range n 'count' n */ -/* range n 'by' n */ - case 121: - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - start = values[0]; - end = values[2]; - step = (start <= end) ? 1 : -1; - elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list - break; - case RANGE_BY: - start = 0; - elementCount = values[0]; - step = values[2]; - end = start + (step * elementCount); - elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list - break; - case RANGE_COUNT: - start = values[0]; - elementCount = (values[2] >= 0 ? values[2] : 0); - step = 1; - end = start + (step * elementCount); - break; - default: - status = TCL_ERROR; - goto done; - } - break; - -/* range n 'to' n n */ -/* range n 'count' n n */ - case 1211: - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - start = values[0]; - end = values[2]; - step = values[3]; - break; - case RANGE_COUNT: - start = values[0]; - elementCount = (values[2] >= 0 ? values[2] : 0); - step = values[3]; - end = start + (step * elementCount); - break; - case RANGE_BY: - /* Error case */ - status = TCL_ERROR; - goto done; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - break; - -/* range n n 'by' n */ - case 1121: - start = values[0]; - end = values[1]; - opmode = (SequenceOperators)values[2]; - switch (opmode) { - case RANGE_BY: - step = values[3]; - break; - case RANGE_DOTS: - case RANGE_TO: - case RANGE_COUNT: - default: - status = TCL_ERROR; - goto done; - break; - } - if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - break; - -/* range n 'to' n 'by' n */ -/* range n 'count' n 'by' n */ - case 12121: - start = values[0]; - opmode = (SequenceOperators)values[3]; - switch (opmode) { - case RANGE_BY: - step = values[4]; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - start = values[0]; - end = values[2]; - if ((step == 0) || - (start <= end && step < 0) || - (start >= end && step > 0)) { - elementCount = 0; - } else if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else if (step > 0) { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } - break; - case RANGE_COUNT: - start = values[0]; - elementCount = (values[2] >= 0 ? values[2] : 0); - end = start + (step * elementCount); - break; - default: - status = TCL_ERROR; - goto done; - break; - } - break; - -/* Error cases: incomplete arguments */ - case 12: - opmode = values[1]; goto KeywordError; break; - case 112: - opmode = values[2]; goto KeywordError; break; - case 1212: - opmode = values[3]; goto KeywordError; break; - KeywordError: - status = TCL_ERROR; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"to\" value.")); - break; - case RANGE_COUNT: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing \"count\" value.")); - break; - case RANGE_BY: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "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??"); - goto done; - break; - } - - /* - * Success! Now lets create the series object. - */ - arithSeriesPtr = Tcl_NewArithSeriesObj(start, end, step, elementCount); - Tcl_SetObjResult(interp, arithSeriesPtr); - status = TCL_OK; - - done: - return status; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_RegexpObjCmd -- * * This procedure is invoked to process the "regexp" Tcl command. See diff --git a/generic/tclDecls.h b/generic/tclDecls.h index bf32563..b869c97 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1975,15 +1975,6 @@ EXTERN const char * TclUtfAtIndex(const char *src, int index); EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); /* 673 */ EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); -/* 674 */ -EXTERN Tcl_Obj * Tcl_NewArithSeriesObj(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step, - Tcl_WideInt len); -/* 675 */ -EXTERN int Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, - Tcl_WideInt index, Tcl_WideInt *element); -/* 676 */ -EXTERN Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2693,9 +2684,6 @@ typedef struct TclStubs { const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ - Tcl_Obj * (*tcl_NewArithSeriesObj) (Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len); /* 674 */ - int (*tcl_ArithSeriesObjIndex) (Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt *element); /* 675 */ - Tcl_WideInt (*tcl_ArithSeriesObjLength) (Tcl_Obj *arithSeriesPtr); /* 676 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4074,12 +4062,6 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclGetRange) /* 672 */ #define TclGetUniChar \ (tclStubsPtr->tclGetUniChar) /* 673 */ -#define Tcl_NewArithSeriesObj \ - (tclStubsPtr->tcl_NewArithSeriesObj) /* 674 */ -#define Tcl_ArithSeriesObjIndex \ - (tclStubsPtr->tcl_ArithSeriesObjIndex) /* 675 */ -#define Tcl_ArithSeriesObjLength \ - (tclStubsPtr->tcl_ArithSeriesObjLength) /* 676 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 76b6469..bfbf1bc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2489,6 +2489,7 @@ typedef struct ArithSeries { Tcl_WideInt end; Tcl_WideInt step; Tcl_WideInt len; + Tcl_Obj **elements; Tcl_Obj *wideObjPtr; /* Used to speedup [foreach] reusing the same obj. */ } ArithSeries; @@ -2496,7 +2497,7 @@ typedef struct ArithSeries { (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) #define ArithSeriesIndexM(arithSeriesRepPtr, index) \ - (arithSeriesRepPtr)->start+((index)*arithSeriesRepPtr->step) + (arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step) /* @@ -2943,8 +2944,16 @@ MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, + Tcl_WideInt index, Tcl_WideInt *element); +MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx); +MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step, + Tcl_WideInt len); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, ClientData clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); @@ -3575,6 +3584,9 @@ MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LseqObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3601,9 +3613,6 @@ MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RangeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 2bcca64..d62583a 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -848,7 +848,7 @@ Tcl_ListObjIndex( if (listRepPtr == NULL && TclHasInternalRep(listPtr,&tclArithSeriesType)) { Tcl_WideInt widint; - if (Tcl_ArithSeriesObjIndex(listPtr, index, &widint) == TCL_OK) { + if (TclArithSeriesObjIndex(listPtr, index, &widint) == TCL_OK) { *objPtrPtr = Tcl_NewWideIntObj(widint); return TCL_OK; } @@ -917,7 +917,7 @@ Tcl_ListObjLength( int length; if (TclHasInternalRep(listPtr,&tclArithSeriesType)) { - *intPtr = Tcl_ArithSeriesObjLength(listPtr); + *intPtr = TclArithSeriesObjLength(listPtr); return TCL_OK; } @@ -2053,7 +2053,7 @@ SetListFromAny( * because it can be done an order of magnitude faster * and may occur frequently. */ - Tcl_WideInt wideLen = Tcl_ArithSeriesObjLength(objPtr), j; + Tcl_WideInt wideLen = TclArithSeriesObjLength(objPtr), j; ArithSeries *arithSeriesRepPtr = (ArithSeries*) objPtr->internalRep.twoPtrValue.ptr1; listRepPtr = AttemptNewList(interp, wideLen, NULL); @@ -2325,7 +2325,7 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) /* *---------------------------------------------------------------------- * - * Tcl_NewArithSeriesObj -- + * TclNewArithSeriesObj -- * * Creates a new ArithSeries object. The returned object has * refcount = 0. @@ -2341,7 +2341,7 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) *---------------------------------------------------------------------- */ Tcl_Obj * -Tcl_NewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); Tcl_Obj *arithSeriesPtr; @@ -2355,6 +2355,7 @@ Tcl_NewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_ arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; arithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); Tcl_IncrRefCount(arithSeriesRepPtr->wideObjPtr); arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; @@ -2370,7 +2371,7 @@ Tcl_NewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_ /* *---------------------------------------------------------------------- * - * Tcl_ArithSeriesObjIndex -- + * TclArithSeriesObjIndex -- * * Returns the element with the specified index in the list * represented by the specified Arithmentic Sequence object. @@ -2390,12 +2391,12 @@ Tcl_NewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_ */ int -Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt *element) +TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt *element) { ArithSeries *arithSeriesRepPtr; if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("Tcl_ArithSeriesObjIndex called with a not ArithSeries Obj."); + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); } arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; @@ -2409,7 +2410,7 @@ Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt /* *---------------------------------------------------------------------- * - * Tcl_ArithSeriesObjLength + * TclArithSeriesObjLength * * Returns the length of the arithmentic series. * @@ -2423,7 +2424,7 @@ Tcl_ArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt * *---------------------------------------------------------------------- */ -Tcl_WideInt Tcl_ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; @@ -2453,6 +2454,16 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + Tcl_Obj**elmts = arithSeriesRepPtr->elements; + for(i=0; ilen; i++) { + if (elmts[i]) { + Tcl_DecrRefCount(elmts[i]); + } + } + ckfree((char *) arithSeriesRepPtr->elements); + } Tcl_DecrRefCount(arithSeriesRepPtr->wideObjPtr); ckfree((char *) arithSeriesRepPtr); arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; @@ -2492,6 +2503,7 @@ DupArithSeriesInternalRep(srcPtr, copyPtr) copyArithSeriesRepPtr->end = srcArithSeriesRepPtr->end; copyArithSeriesRepPtr->step = srcArithSeriesRepPtr->step; copyArithSeriesRepPtr->len = srcArithSeriesRepPtr->len; + copyArithSeriesRepPtr->elements = NULL; copyArithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); Tcl_IncrRefCount(copyArithSeriesRepPtr->wideObjPtr); @@ -2689,14 +2701,14 @@ TclArithSeriesObjRange( return obj; } - Tcl_ArithSeriesObjIndex(arithSeriesPtr, fromIdx, &start); - Tcl_ArithSeriesObjIndex(arithSeriesPtr, toIdx, &end); + TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &start); + TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &end); step = arithSeriesRepPtr->step; len = ArithSeriesLen(start, end, step); if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { - return Tcl_NewArithSeriesObj(start, end, step, len); + return TclNewArithSeriesObj(start, end, step, len); } /* @@ -2714,9 +2726,96 @@ TclArithSeriesObjRange( arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = len; + arithSeriesRepPtr->elements = NULL; return arithSeriesPtr; } + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesGetElements -- + * + * This function returns an (objc,objv) array of the elements in a list + * object. + * + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to an Abstract List object and the object can not be converted + * to one, TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclArithSeriesGetElements( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *objPtr, /* AbstractList object for which an element + * array is to be returned. */ + int *objcPtr, /* Where to store the count of objects + * referenced by objv. */ + Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of + * pointers to the list's objects. */ +{ + if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + ArithSeries *arithSeriesRepPtr; + Tcl_Obj **objv; + int i, objc; + + ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); + objc = arithSeriesRepPtr->len; + if (objc > 0) { + if (arithSeriesRepPtr->elements) { + /* If this exists, it has already been populated */ + objv = arithSeriesRepPtr->elements; + } else { + /* Construct the elements array */ + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); + if (objv == NULL) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + arithSeriesRepPtr->elements = objv; + for (i = 0; i < objc; i++) { + Tcl_WideInt wi = ArithSeriesIndexM(arithSeriesRepPtr, (Tcl_WideInt)i); + objv[i] = Tcl_NewWideIntObj(wi); + Tcl_IncrRefCount(objv[i]); + } + } + } else { + objv = NULL; + } + *objvPtr = objv; + *objcPtr = objc; + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an arithseries")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f8d3cde..2b7952d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2034,9 +2034,6 @@ const TclStubs tclStubs = { TclUtfAtIndex, /* 671 */ TclGetRange, /* 672 */ TclGetUniChar, /* 673 */ - Tcl_NewArithSeriesObj, /* 674 */ - Tcl_ArithSeriesObjIndex, /* 675 */ - Tcl_ArithSeriesObjLength, /* 676 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/lseq.test b/tests/lseq.test new file mode 100644 index 0000000..082111b --- /dev/null +++ b/tests/lseq.test @@ -0,0 +1,387 @@ +# Commands covered: lseq +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright © 2003 Simon Geard. +# +# 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::* +} + +testConstraint arithSeriesDouble 0 +testConstraint arithSeriesShimmer 1 +testConstraint arithSeriesShimmerOk 0 + +## Arg errors +test lseq-1.1 {error cases} -body { + lseq +} \ + -returnCodes 1 \ + -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + + +test lseq-1.2 {step magnitude} { + lseq 10 .. 1 by -2 ;# or this could be an error - or not +} {10 8 6 4 2} + +test lseq-1.3 {synergy between int and double} { + set rl [lseq 25. to 5. by -5] + set il [lseq 25 to 5 by -5] + lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } +} {1 1 1 1 1} + +test lseq-1.4 {integer decreasing} { + lseq 10 .. 1 +} {10 9 8 7 6 5 4 3 2 1} + +test lseq-1.5 {integer increasing} { + lseq 1 .. 10 +} {1 2 3 4 5 6 7 8 9 10} + +test lseq-1.6 {integer decreasing with step} { + lseq 10 .. 1 by -2 +} {10 8 6 4 2} + +test lseq-1.7 {real increasing lseq} arithSeriesDouble { + lseq 5.0 to 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} + +test lseq-1.8 {real increasing lseq with step} arithSeriesDouble { + lseq 5.0 to 25. by 5 +} {5.0 10.0 15.0 20.0 25.0} + +test lseq-1.9 {real decreasing with step} arithSeriesDouble { + lseq 25. to 5. by -5 +} {25.0 20.0 15.0 10.0 5.0} + +# note, 10 cannot be in such a list, but allowed +test lseq-1.10 {integer lseq with step} { + lseq 1 to 10 by 2 +} {1 3 5 7 9} + +test lseq-1.11 {error case: increasing wrong step direction} { + lseq 1 to 10 by -2 +} {} + +test lseq-1.12 {decreasing lseq with step} arithSeriesDouble { + lseq 25. to -25. by -5 +} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} + +test lseq-1.13 {count operation} { + -body { + lseq 5 count 5 + } + -result {5 6 7 8 9} +} + +test lseq-1.14 {count with step} { + -body { + lseq 5 count 5 by 2 + } + -result {5 7 9 11 13} +} + +test lseq-1.15 {count with decreasing step} { + -body { + lseq 5 count 5 by -2 + } + -result {5 3 1 -1 -3} +} + +test lseq-1.16 {large numbers} { + -body { + lseq [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}] + } + -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} +} + +test lseq-1.17 {too many arguments} -body { + lseq 12 to 24 by 2 with feeling +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.18 {too many arguments extra valid keyword} -body { + lseq 12 to 24 by 2 count +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +test lseq-1.19 {too many arguments extra numeric value} -body { + lseq 12 to 24 by 2 7 +} -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} + +# +# Short-hand use cases +# +test lseq-2.2 {step magnitude} { + lseq 10 1 2 ;# this is an empty case since step has wrong sign +} {} + +test lseq-2.3 {step wrong sign} arithSeriesDouble { + lseq 25. 5. 5 ;# ditto - empty list +} {} + +test lseq-2.4 {integer decreasing} { + lseq 10 1 +} {10 9 8 7 6 5 4 3 2 1} + +test lseq-2.5 {integer increasing} { + lseq 1 10 +} {1 2 3 4 5 6 7 8 9 10} + +test lseq-2.6 {integer decreasing with step} { + lseq 10 1 by -2 +} {10 8 6 4 2} + +test lseq-2.7 {real increasing lseq} arithSeriesDouble { + lseq 5.0 15. +} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} + + +test lseq-2.8 {real increasing lseq with step} arithSeriesDouble { + lseq 5.0 25. 5 +} {5.0 10.0 15.0 20.0 25.0} + + +test lseq-2.9 {real decreasing with step} arithSeriesDouble { + lseq 25. 5. -5 +} {25.0 20.0 15.0 10.0 5.0} + +test lseq-2.10 {integer lseq with step} { + lseq 1 10 2 +} {1 3 5 7 9} + +test lseq-2.11 {error case: increasing wrong step direction} { + lseq 1 10 -2 +} {} + +test lseq-2.12 {decreasing lseq with step} arithSeriesDouble { + lseq 25. -25. -5 +} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} + +test lseq-2.13 {count only operation} { + lseq 5 +} {0 1 2 3 4} + +test lseq-2.14 {count with step} { + lseq 5 count 5 2 +} {5 7 9 11 13} + +test lseq-2.15 {count with decreasing step} { + lseq 5 count 5 -2 +} {5 3 1 -1 -3} + +test lseq-2.16 {large numbers} { + lseq 1e6 2e6 1e5 +} {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} + +test lseq-2.17 {large numbers} arithSeriesDouble { + lseq 1e6 2e6 1e5 +} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} + + +test lseq-3.1 {experiement} { + set ans {} + foreach factor [lseq 2.0 10.0] { + set start 1 + set end 10 + for {set step 1} {$step < 1e8} {} { + set l [lseq $start to $end by $step] + if {[llength $l] != 10} { + lappend ans $factor $step [llength $l] $l + } + set step [expr {$step * $factor}] + set end [expr {$end * $factor}] + } + } + if {$ans eq {}} { + set ans OK + } + set ans +} {OK} + +test lseq-3.2 {error case} -body { + lseq foo +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} + +test lseq-3.3 {error case} -body { + lseq 10 foo +} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} + +test lseq-3.4 {error case} -body { + lseq 25 or 6 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} + +test lseq-3.5 {simple count and step arguments} { + lseq 25 by 6 +} {0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144 150} + +test lseq-3.6 {error case} -body { + lseq 1 7 or 3 +} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} + +test lseq-3.7 {lmap lseq} { + lmap x [lseq 5] { expr {$x * $x} } +} {0 1 4 9 16} + +test lseq-3.8 {lrange lseq} { + set r [lrange [lseq 1 100] 10 20] + lindex [tcl::unsupported::representation $r] 3 +} {arithseries} + +test lseq-3.9 {lassign lseq} arithSeriesShimmer { + set r [lseq 15] + set r2 [lassign $r a b] + list [lindex [tcl::unsupported::representation $r] 3] $a $b \ + [lindex [tcl::unsupported::representation $r2] 3] +} {arithseries 0 1 arithseries} + +test lseq-3.10 {lsearch lseq must shimmer?} arithSeriesShimmer { + set r [lseq 15 0] + set a [lsearch $r 9] + list [lindex [tcl::unsupported::representation $r] 3] $a +} {list 6} + +test lseq-3.11 {lreverse lseq} { + set r [lseq 15 0] + set a [lreverse $r] + join [list \ + [lindex [tcl::unsupported::representation $r] 3] \ + $r \ + [lindex [tcl::unsupported::representation $a] 3] \ + $a] \n +} {arithseries +15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 +arithseries +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} + +test lseq-3.12 {in operator} { + set r [lseq 9] + set i [expr {7 in $r}] + set j [expr {10 ni $r}] + set k [expr {-1 in $r}] + set l [expr {4 ni $r}] + list $i $j $k $l [lindex [tcl::unsupported::representation $r] 3] +} {1 1 0 0 arithseries} + +test lseq-3.13 {lmap lseq shimmer} arithSeriesShimmer { + set r [lseq 15] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set m [lmap i $r { expr {$i * 7} }] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + set rep-m [lindex [tcl::unsupported::representation $m] 3] + list $r ${rep-before} ${rep-after} ${rep-m} $m +} {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}} + +test lseq-3.14 {array for shimmer} arithSeriesShimmerOk { + array set testarray {a Test for This great Function} + set vars [lseq 2] + set vars-rep [lindex [tcl::unsupported::representation $vars] 3] + array for $vars testarray { + lappend keys $0 + lappend vals $1 + } + # Since hash order is not guaranteed, have to validate content ignoring order + set valk [lmap k $keys {expr {$k in {a for great}}}] + set valv [lmap v $vals {expr {$v in {Test This Function}}}] + set vars-after [lindex [tcl::unsupported::representation $vars] 3] + list ${vars-rep} $valk $valv ${vars-after} +} {arithseries {1 1 1} {1 1 1} arithseries} + +test lseq-3.15 {join for shimmer} arithSeriesShimmer { + set r [lseq 3] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set str [join $r :] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $str ${rep-after} +} {arithseries 0:1:2 arithseries} + +test lseq-3.16 {error case} -body { + lseq 16 to +} -returnCodes 1 -result {missing "to" value.} + +test lseq-3.17 {error case} -body { + lseq 17 to 13 by +} -returnCodes 1 -result {missing "by" value.} + +test lseq-3.18 {error case} -body { + lseq 18 count +} -returnCodes 1 -result {missing "count" value.} + +test lseq-3.19 {edge case} -body { + lseq 1 count 5 by 0 +} -result {} +# 1 1 1 1 1 + +# My thought is that this is likely a user error, since they can always use lrepeat for this. + +test lseq-3.20 {edge case} -body { + lseq 1 to 1 by 0 +} -result {} + +# hmmm, I guess this is right, in a way, so... + +test lseq-3.21 {edge case} { + lseq 1 to 1 by 1 +} {1} + +test lseq-3.22 {edge case} { + lseq 1 1 1 +} {1} + +test lseq-3.23 {edge case} { + llength [lseq 1 1 1] +} {1} + +test lseq-3.24 {edge case} { + llength [lseq 1 to 1 1] +} {1} + +test lseq-3.25 {edge case} { + llength [lseq 1 to 1 by 1] +} {1} + +test lseq-3.26 {lsort shimmer} arithSeriesShimmer { + set r [lseq 15 0] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set lexical_sort [lsort $r] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $lexical_sort ${rep-after} +} {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries} + +test lseq-3.27 {lreplace shimmer} arithSeriesShimmer { + set r [lseq 15 0] + set rep-before [lindex [tcl::unsupported::representation $r] 3] + set lexical_sort [lreplace $r 3 5 A B C] + set rep-after [lindex [tcl::unsupported::representation $r] 3] + list ${rep-before} $lexical_sort ${rep-after} +} {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} + +test lseq-3.28 {lreverse bug in ArithSeries} {} { + set r [lseq -5 17 3] + set rr [lreverse $r] + list $r $rr [string equal $r [lreverse $rr]] +} {{-5 -2 1 4 7 10 13 16} {16 13 10 7 4 1 -2 -5} 1} + +test lseq-4.1 {end expressions} { + set start 7 + lseq $start $start+11 +} {7 8 9 10 11 12 13 14 15 16 17 18} + +test lseq-4.2 {start expressions} { + set base [clock seconds] + set tl [lseq $base-60 $base 10] + lmap t $tl {expr {$t - $base + 60}} +} {0 10 20 30 40 50 60} + + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From 2439b064ea3e521e50f6c7bd43ef0a69d183bff9 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 16 Aug 2022 18:33:47 +0000 Subject: Implement lrange for arithseries. Code cleanup. --- generic/tclCmdIL.c | 41 ++++++++-------------------------- generic/tclCmdMZ.c | 1 - generic/tclInt.h | 1 + generic/tclListObj.c | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 4 files changed, 71 insertions(+), 35 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 065bc2a..669f34b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3129,33 +3129,7 @@ Tcl_LreverseObjCmd( * just to reverse it. */ if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { - ArithSeries *arithSeriesPtr = ArithSeriesRepPtr(objv[1]); - Tcl_WideInt rstart, rend, rstep, len; - - len = TclArithSeriesObjLength(objv[1]); - if (TclArithSeriesObjIndex(objv[1], 0, &rend) != TCL_OK) { - return TCL_ERROR; - } - if (TclArithSeriesObjIndex(objv[1], (len-1), &rstart) != TCL_OK) { - return TCL_ERROR; - } - rstep = -arithSeriesPtr->step; - - if (Tcl_IsShared(objv[1])) { - Tcl_Obj *resultObj = TclNewArithSeriesObj(rstart, rend, rstep, len); - Tcl_SetObjResult(interp, resultObj); - } else { - - /* - * Not shared, so swap in place. - */ - - arithSeriesPtr->start = rstart; - arithSeriesPtr->end = rend; - arithSeriesPtr->step = rstep; - TclInvalidateStringRep(objv[1]); - Tcl_SetObjResult(interp, objv[1]); - } + Tcl_SetObjResult(interp, TclArithSeriesObjReverse(objv[1])); return TCL_OK; } /* end ArithSeries */ @@ -4127,8 +4101,8 @@ SequenceIdentifyArgument( * * Tcl_LseqObjCmd -- * - * This procedure is invoked to process the "range" Tcl command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the "lseq" Tcl command. + * See the user documentation for details on what it does. * * Enumerated possible argument patterns: * @@ -4347,10 +4321,13 @@ Tcl_LseqObjCmd( goto done; break; } - if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list + if (step == 0) { + // 0 step -> empty list + elementCount = 0; + } else if (start <= end) { + elementCount = (end-start+step)/step; } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list + elementCount = (start-end-step)/(-step); } break; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index cff182d..a9d1f11 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -62,7 +62,6 @@ const char tclDefaultTrimSet[] = "\xE3\x80\x80" /* ideographic space (U+3000) */ "\xEF\xBB\xBF" /* zero width no-break space (U+feff) */ ; - /* *---------------------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index bfbf1bc..f66814e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2949,6 +2949,7 @@ MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_WideInt start, diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d62583a..37d941d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2554,7 +2554,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) * Pass 1: estimate space. */ for (i = 0; i < arithSeriesRepPtr->len; i++) { - ele = arithSeriesRepPtr->start + (i*arithSeriesRepPtr->step); + ele = ArithSeriesIndexM(arithSeriesRepPtr, i); /* * Note that sprintf will generate a compiler warning under * Mingw claiming %I64 is an unknown format specifier. @@ -2572,7 +2572,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); for (i = 0; i < arithSeriesRepPtr->len; i++) { - ele = arithSeriesRepPtr->start + (i*arithSeriesRepPtr->step); + ele = ArithSeriesIndexM(arithSeriesRepPtr, i); sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele); slen = strlen(buffer); strcpy(p, buffer); @@ -2816,6 +2816,65 @@ TclArithSeriesGetElements( } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjReverse -- + * + * Reverse the order of the ArithSeries value. + * *arithSeriesPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the reordered series. + * This may be a new object or the same object if not shared. + * + * Side effects: + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjReverse( + Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ +{ + ArithSeries *arithSeriesRepPtr; + Tcl_WideInt start = -1, end = -1, step, len; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + + len = arithSeriesRepPtr->len; + TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &start); + TclArithSeriesObjIndex(arithSeriesPtr, 0, &end); + step = -arithSeriesRepPtr->step; + + if (Tcl_IsShared(arithSeriesPtr) || + ((arithSeriesPtr->refCount > 1))) { + return TclNewArithSeriesObj(start, end, step, len); + } + + /* + * In-place is possible. + */ + + TclInvalidateStringRep(arithSeriesPtr); + + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + for (i=0; ielements[i]); + } + ckfree((char*)arithSeriesRepPtr->elements); + } + arithSeriesRepPtr->elements = NULL; + + return arithSeriesPtr; +} /* -- cgit v0.12 From 9a179b641897fc4e631dfe3dbd737d864f5df96d Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 17 Aug 2022 22:32:34 +0000 Subject: Bug fixes --- doc/lseq.n | 4 ++-- generic/tclCmdIL.c | 33 ++++++--------------------------- generic/tclListObj.c | 5 ++++- tests/lseq.test | 34 +++++++++++++++++++++++++++++++--- 4 files changed, 43 insertions(+), 33 deletions(-) diff --git a/doc/lseq.n b/doc/lseq.n index 0e452d8..4eb0fcf 100644 --- a/doc/lseq.n +++ b/doc/lseq.n @@ -34,12 +34,12 @@ and use the numeric result, or error as with any invalid argument value. .\" lseq 3 - \(-> 0 1 + \(-> 0 1 2 lseq 3 0 \(-> 3 2 1 0 - lseq 10 .. 1 by 2 + lseq 10 .. 1 by -2 \(-> 10 8 6 4 2 set l [lseq 0 -5] diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 669f34b..332c77b 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4222,11 +4222,7 @@ Tcl_LseqObjCmd( start = values[0]; end = values[1]; step = (start <= end) ? 1 : -1; - if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list if (elementCount < 0) elementCount = 0; break; @@ -4235,11 +4231,7 @@ Tcl_LseqObjCmd( start = values[0]; end = values[1]; step = values[2]; - if (start <= end) { - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - } else { - elementCount = step ? (start-end-step)/(-step) : 0; // 0 step -> empty list - } + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list if (elementCount < 0) elementCount = 0; break; @@ -4261,7 +4253,6 @@ Tcl_LseqObjCmd( elementCount = values[0]; step = values[2]; end = start + (step * elementCount); - elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list break; case RANGE_COUNT: start = values[0]; @@ -4285,6 +4276,7 @@ Tcl_LseqObjCmd( start = values[0]; end = values[2]; step = values[3]; + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list break; case RANGE_COUNT: start = values[0]; @@ -4321,14 +4313,7 @@ Tcl_LseqObjCmd( goto done; break; } - if (step == 0) { - // 0 step -> empty list - elementCount = 0; - } else if (start <= end) { - elementCount = (end-start+step)/step; - } else { - elementCount = (start-end-step)/(-step); - } + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list break; /* range n 'to' n 'by' n */ @@ -4351,17 +4336,11 @@ Tcl_LseqObjCmd( case RANGE_TO: start = values[0]; end = values[2]; - if ((step == 0) || - (start < end && step < 0) || - (start > end && step > 0)) { - elementCount = 0; - } else { - elementCount = (end-start+step)/step; - } + elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list break; case RANGE_COUNT: start = values[0]; - elementCount = (values[2] >= 0 ? values[2] : 0); + elementCount = values[2] >= 0 ? values[2] : 0; if (step != 0) { end = start + (step * elementCount); } else { diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 37d941d..6b5ab7e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2347,9 +2347,12 @@ TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W Tcl_Obj *arithSeriesPtr; ArithSeries *arithSeriesRepPtr; - if (length == -1) return NULL; /* Invalid range error */ TclNewObj(arithSeriesPtr); + if (length <= 0) { + return arithSeriesPtr; + } + arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; diff --git a/tests/lseq.test b/tests/lseq.test index 082111b..04f9c77 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -113,6 +113,18 @@ test lseq-1.19 {too many arguments extra numeric value} -body { lseq 12 to 24 by 2 7 } -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} +test lseq-1.20 {bug: wrong length computed} { + lseq 1 to 10 -1 +} {} + +test lseq-1.21 {n n by n} { + lseq 66 84 by 3 +} {66 69 72 75 78 81 84} + +test lseq-1.22 {n n by -n} { + lseq 84 66 by -3 +} {84 81 78 75 72 69 66} + # # Short-hand use cases # @@ -182,6 +194,17 @@ test lseq-2.17 {large numbers} arithSeriesDouble { lseq 1e6 2e6 1e5 } {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} +# Covered: {10 1 2 } {1 10 2} {1 10 -2} {1 1 1} {1 1 1} {-5 17 3} +# Missing: {- - +} {- - -} {- + -} {+ - -} {- - +} {+ + -} +test lseq-2.18 {signs} { + list [lseq -10 -1 2] \ + [lseq -10 -1 -1] \ + [lseq -10 1 -3] \ + [lseq 10 -1 -4] \ + [lseq -10 -1 3] \ + [lseq 10 1 -5] + +} {{-10 -8 -6 -4 -2} {} {} {10 6 2} {-10 -7 -4 -1} {10 5}} test lseq-3.1 {experiement} { set ans {} @@ -216,8 +239,9 @@ test lseq-3.4 {error case} -body { } -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} test lseq-3.5 {simple count and step arguments} { - lseq 25 by 6 -} {0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144 150} + set s [lseq 25 by 6] + list $s length=[llength $s] +} {{0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144} length=25} test lseq-3.6 {error case} -body { lseq 1 7 or 3 @@ -335,7 +359,7 @@ test lseq-3.22 {edge case} { test lseq-3.23 {edge case} { llength [lseq 1 1 1] } {1} - + test lseq-3.24 {edge case} { llength [lseq 1 to 1 1] } {1} @@ -366,6 +390,10 @@ test lseq-3.28 {lreverse bug in ArithSeries} {} { list $r $rr [string equal $r [lreverse $rr]] } {{-5 -2 1 4 7 10 13 16} {16 13 10 7 4 1 -2 -5} 1} +test lseq-3.29 {edge case: negative count} { + lseq -15 +} {} + test lseq-4.1 {end expressions} { set start 7 lseq $start $start+11 -- cgit v0.12 From 85da0b0875d23f8af54cef159f7878f8bc3d30f3 Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 24 Aug 2022 23:22:21 +0000 Subject: Implement support for float (double) values. Add more test coverage. --- generic/tclCmdAH.c | 4 +- generic/tclCmdIL.c | 312 ++++++++++++++++++++------------------ generic/tclInt.h | 45 ++++-- generic/tclListObj.c | 416 ++++++++++++++++++++++++++++++++++++++++++--------- tests/lseq.test | 75 +++++++++- 5 files changed, 619 insertions(+), 233 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index f31eabc..adb4044 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2968,15 +2968,13 @@ ForeachAssignments( k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { if (isarithseries) { - Tcl_WideInt value; - if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &value) != TCL_OK) { + if (TclArithSeriesObjIndex(statePtr->vCopyList[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]))); return TCL_ERROR; } - valuePtr = Tcl_NewWideIntObj(value); } else { valuePtr = statePtr->argvList[i][k]; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 332c77b..77a8ffc 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2229,11 +2229,11 @@ Tcl_JoinObjCmd( if (listLen == 1) { /* One element; return it */ if (isArithSeries) { - Tcl_WideInt value; - if (TclArithSeriesObjIndex(objv[1], 0, &value) != TCL_OK) { + Tcl_Obj *valueObj; + if (TclArithSeriesObjIndex(objv[1], 0, &valueObj) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(value)); + Tcl_SetObjResult(interp, valueObj); } else { Tcl_SetObjResult(interp, elemPtrs[0]); } @@ -2251,7 +2251,7 @@ Tcl_JoinObjCmd( TclNewObj(resObjPtr); if (isArithSeries) { - Tcl_WideInt value; + Tcl_Obj *valueObj; for (i = 0; i < listLen; i++) { if (i > 0) { @@ -2264,10 +2264,11 @@ Tcl_JoinObjCmd( Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } - if (TclArithSeriesObjIndex(objv[1], i, &value) != TCL_OK) { + if (TclArithSeriesObjIndex(objv[1], i, &valueObj) != TCL_OK) { return TCL_ERROR; } - Tcl_AppendObjToObj(resObjPtr, Tcl_NewWideIntObj(value)); + Tcl_AppendObjToObj(resObjPtr, valueObj); + Tcl_DecrRefCount(valueObj); } } else { for (i = 0; i < listLen; i++) { @@ -4046,34 +4047,57 @@ static SequenceDecoded SequenceIdentifyArgument( Tcl_Interp *interp, /* for error reporting */ Tcl_Obj *argPtr, /* Argument to decode */ - Tcl_WideInt *intValuePtr, /* Return numeric value */ + Tcl_Obj **numValuePtr, /* Return numeric value */ int *keywordIndexPtr) /* Return keyword enum */ { int status; - Tcl_WideInt number; SequenceOperators opmode; SequenceByMode bymode; + union { + Tcl_WideInt i; + double d; + } nvalue; - status = Tcl_GetWideIntFromObj(NULL, argPtr, &number); - if (status != TCL_OK) { + status = TclGetNumberFromObj(NULL, argPtr, (ClientData*)&nvalue, keywordIndexPtr); + if (status == TCL_OK) { + if (numValuePtr) { + *numValuePtr = argPtr; + } + return NumericArg; + } else { /* Check for an index expression */ long value; + double dvalue; + Tcl_Obj *exprValueObj; + int keyword; Tcl_InterpState savedstate; savedstate = Tcl_SaveInterpState(interp, status); if (Tcl_ExprLongObj(interp, argPtr, &value) != TCL_OK) { status = Tcl_RestoreInterpState(interp, savedstate); + exprValueObj = argPtr; } else { + // Determine if expression is double or int + if (Tcl_ExprDoubleObj(interp, argPtr, &dvalue) != TCL_OK) { + keyword = TCL_NUMBER_INT; + exprValueObj = argPtr; + } else { + if (floor(dvalue) == dvalue) { + exprValueObj = Tcl_NewWideIntObj(value); + keyword = TCL_NUMBER_INT; + } else { + exprValueObj = Tcl_NewDoubleObj(dvalue); + keyword = TCL_NUMBER_DOUBLE; + } + } status = Tcl_RestoreInterpState(interp, savedstate); - if (intValuePtr) { - *intValuePtr = value; + if (numValuePtr) { + *numValuePtr = exprValueObj; + } + if (keywordIndexPtr) { + *keywordIndexPtr = keyword ;// type of expression result } return NumericArg; } - } else { - if (intValuePtr) { - *intValuePtr = number; - } - return NumericArg; } status = Tcl_GetIndexFromObj(NULL, argPtr, seq_operations, @@ -4139,14 +4163,19 @@ Tcl_LseqObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - Tcl_WideInt elementCount = -1; - Tcl_WideInt start = 0, end = 0, step = 0, number = 0; + Tcl_Obj *elementCount = NULL; + Tcl_Obj *start = NULL, *end = NULL, *step = NULL; Tcl_WideInt values[5]; - int status, keyword; + Tcl_Obj *numValues[5]; + Tcl_Obj *numberObj; + int status, keyword, useDoubles = 0; Tcl_Obj *arithSeriesPtr; SequenceOperators opmode; SequenceDecoded decoded; int i, arg_key = 0, value_i = 0; + // Default constants + Tcl_Obj *zero = Tcl_NewIntObj(0); + Tcl_Obj *one = Tcl_NewIntObj(1); /* * Create a decoding key by looping through the arguments and identify @@ -4158,7 +4187,8 @@ Tcl_LseqObjCmd( arg_key=0; } else for (i=1; i empty list - if (elementCount < 0) elementCount = 0; - break; + start = numValues[0]; + end = numValues[1]; + break; /* range n n n */ case 111: - start = values[0]; - end = values[1]; - step = values[2]; - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - if (elementCount < 0) elementCount = 0; - break; + start = numValues[0]; + end = numValues[1]; + step = numValues[2]; + break; /* range n 'to' n */ /* range n 'count' n */ /* range n 'by' n */ case 121: - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - start = values[0]; - end = values[2]; - step = (start <= end) ? 1 : -1; - elementCount = step ? (start-end+step)/step : 0; // 0 step -> empty list - break; - case RANGE_BY: - start = 0; - elementCount = values[0]; - step = values[2]; - end = start + (step * elementCount); - break; - case RANGE_COUNT: - start = values[0]; - elementCount = (values[2] >= 0 ? values[2] : 0); - step = 1; - end = start + (step * elementCount); - break; - default: - status = TCL_ERROR; - goto done; - } - break; + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = numValues[0]; + end = numValues[2]; + break; + case RANGE_BY: + start = zero; + elementCount = numValues[0]; + step = numValues[2]; + break; + case RANGE_COUNT: + start = numValues[0]; + elementCount = numValues[2]; + step = one; + break; + default: + status = TCL_ERROR; + goto done; + } + break; /* range n 'to' n n */ /* range n 'count' n n */ case 1211: - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - start = values[0]; - end = values[2]; - step = values[3]; - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - break; - case RANGE_COUNT: - start = values[0]; - elementCount = (values[2] >= 0 ? values[2] : 0); - step = values[3]; - end = start + (step * elementCount); - break; - case RANGE_BY: - /* Error case */ - status = TCL_ERROR; - goto done; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - break; + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = numValues[0]; + end = numValues[2]; + step = numValues[3]; + break; + case RANGE_COUNT: + start = numValues[0]; + elementCount = numValues[2]; + step = numValues[3]; + break; + case RANGE_BY: + /* Error case */ + status = TCL_ERROR; + goto done; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + break; /* range n n 'by' n */ case 1121: - start = values[0]; - end = values[1]; - opmode = (SequenceOperators)values[2]; - switch (opmode) { - case RANGE_BY: - step = values[3]; - break; - case RANGE_DOTS: - case RANGE_TO: - case RANGE_COUNT: - default: - status = TCL_ERROR; - goto done; - break; - } - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - break; + start = numValues[0]; + end = numValues[1]; + opmode = (SequenceOperators)values[2]; + switch (opmode) { + case RANGE_BY: + step = numValues[3]; + break; + case RANGE_DOTS: + case RANGE_TO: + case RANGE_COUNT: + default: + status = TCL_ERROR; + goto done; + break; + } + break; /* range n 'to' n 'by' n */ /* range n 'count' n 'by' n */ case 12121: - start = values[0]; - opmode = (SequenceOperators)values[3]; - switch (opmode) { - case RANGE_BY: - step = values[4]; - break; - default: - status = TCL_ERROR; - goto done; - break; - } - opmode = (SequenceOperators)values[1]; - switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: - start = values[0]; - end = values[2]; - elementCount = step ? (end-start+step)/step : 0; // 0 step -> empty list - break; - case RANGE_COUNT: - start = values[0]; - elementCount = values[2] >= 0 ? values[2] : 0; - if (step != 0) { - end = start + (step * elementCount); - } else { - end = start; - elementCount = 0; /* empty list when step is 0 */ - } - break; - default: - status = TCL_ERROR; - goto done; - break; - } - break; + start = numValues[0]; + opmode = (SequenceOperators)values[3]; + switch (opmode) { + case RANGE_BY: + step = numValues[4]; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + opmode = (SequenceOperators)values[1]; + switch (opmode) { + case RANGE_DOTS: + case RANGE_TO: + start = numValues[0]; + end = numValues[2]; + break; + case RANGE_COUNT: + start = numValues[0]; + elementCount = numValues[2]; + break; + default: + status = TCL_ERROR; + goto done; + break; + } + break; /* Error cases: incomplete arguments */ case 12: @@ -4393,11 +4407,21 @@ Tcl_LseqObjCmd( /* * Success! Now lets create the series object. */ - arithSeriesPtr = TclNewArithSeriesObj(start, end, step, elementCount); + arithSeriesPtr = TclNewArithSeriesObj(useDoubles, start, end, step, elementCount); + Tcl_SetObjResult(interp, arithSeriesPtr); status = TCL_OK; done: + // Free number arguments. + while (--value_i>=0) { + if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]); + } + + // Free constants + Tcl_DecrRefCount(zero); + Tcl_DecrRefCount(one); + return status; } diff --git a/generic/tclInt.h b/generic/tclInt.h index f66814e..95abe4c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2490,14 +2490,31 @@ typedef struct ArithSeries { Tcl_WideInt step; Tcl_WideInt len; Tcl_Obj **elements; - Tcl_Obj *wideObjPtr; /* Used to speedup [foreach] reusing the same obj. */ + int isDouble; } ArithSeries; +typedef struct ArithSeriesDbl { + double start; + double end; + double step; + Tcl_WideInt len; + Tcl_Obj **elements; + int isDouble; +} ArithSeriesDbl; #define ArithSeriesRepPtr(arithSeriesObjPtr) \ (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) #define ArithSeriesIndexM(arithSeriesRepPtr, index) \ - (arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step) + ((arithSeriesRepPtr)->isDouble ? \ + (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \ + : \ + ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step))) + +#define ArithSeriesStepM(arithSeriesRepPtr) \ + ((arithSeriesRepPtr)->isDouble ? \ + ((ArithSeriesDbl*)(arithSeriesRepPtr))->step \ + : \ + (arithSeriesRepPtr)->step) /* @@ -2942,19 +2959,25 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, - Tcl_WideInt index, Tcl_WideInt *element); +MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj); +MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, + Tcl_WideInt index, Tcl_Obj **elementObj); MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step, - Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step, + Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, + double step, Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, + Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, ClientData clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 6b5ab7e..4366782 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -847,11 +847,7 @@ Tcl_ListObjIndex( ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL && TclHasInternalRep(listPtr,&tclArithSeriesType)) { - Tcl_WideInt widint; - if (TclArithSeriesObjIndex(listPtr, index, &widint) == TCL_OK) { - *objPtrPtr = Tcl_NewWideIntObj(widint); - return TCL_OK; - } + return TclArithSeriesObjIndex(listPtr, index, objPtrPtr); } if (listRepPtr == NULL) { @@ -2325,7 +2321,7 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) /* *---------------------------------------------------------------------- * - * TclNewArithSeriesObj -- + * TclNewArithSeriesInt -- * * Creates a new ArithSeries object. The returned object has * refcount = 0. @@ -2341,7 +2337,7 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) *---------------------------------------------------------------------- */ Tcl_Obj * -TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); Tcl_Obj *arithSeriesPtr; @@ -2354,13 +2350,12 @@ TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W } arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); + arithSeriesRepPtr->isDouble = 0; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; - arithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); - Tcl_IncrRefCount(arithSeriesRepPtr->wideObjPtr); arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; arithSeriesPtr->typePtr = &tclArithSeriesType; @@ -2369,8 +2364,227 @@ TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W return arithSeriesPtr; } + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesDbl -- + * + * Creates a new ArithSeries object with doubles. The returned object has + * 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 * +TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) +{ + Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); + Tcl_Obj *arithSeriesPtr; + ArithSeriesDbl *arithSeriesRepPtr; + TclNewObj(arithSeriesPtr); + + if (length <= 0) { + return arithSeriesPtr; + } + + arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); + arithSeriesRepPtr->isDouble = 1; + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesPtr->typePtr = &tclArithSeriesType; + if (length > 0) + Tcl_InvalidateStringRep(arithSeriesPtr); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * assignNumber -- + * + * Create the approprite Tcl_Obj value for the given numeric values. + * Used locally only for decoding [lseq] numeric arguments. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer. + * No assignment on error. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +static void +assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) +{ + union { + double d; + Tcl_WideInt i; + } *number; + int tcl_number_type; + if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) { + return; + } + if (useDoubles) { + if (tcl_number_type == TCL_NUMBER_DOUBLE) { + *dblNumberPtr = number->d; + } else { + *dblNumberPtr = (double)number->i; + } + } else { + if (tcl_number_type == TCL_NUMBER_INT) { + *intNumberPtr = number->i; + } else { + *intNumberPtr = (Tcl_WideInt)number->d; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesObj -- + * + * Creates a new ArithSeries object. Some arguments may be NULL and will + * be computed based on the other given arguments. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created ArithSeries object. + * An empty Tcl_Obj if the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj) +{ + double dstart, dend, dstep; + Tcl_WideInt start, end, step, len; + + if (startObj) { + assignNumber(useDoubles, &start, &dstart, startObj); + } else { + start = 0; + dstart = start; + } + if (stepObj) { + assignNumber(useDoubles, &step, &dstep, stepObj); + if (useDoubles) { + step = dstep; + } else { + dstep = step; + } + if (dstep == 0) { + return Tcl_NewObj(); + } + } + if (endObj) { + assignNumber(useDoubles, &end, &dend, endObj); + } + if (lenObj) { + Tcl_GetWideIntFromObj(NULL, lenObj, &len); + } + + if (startObj && endObj) { + if (!stepObj) { + if (useDoubles) { + dstep = (dstart < dend) ? 1.0 : -1.0; + step = dstep; + } else { + step = (start < end) ? 1 : -1; + dstep = step; + } + } + assert(dstep!=0); + if (!lenObj) { + if (useDoubles) { + len = (dend - dstart + dstep)/dstep; + } else { + len = (end - start + step)/step; + } + } + } + + if (!endObj) { + if (useDoubles) { + dend = dstart + (dstep * (len-1)); + end = dend; + } else { + end = start + (step * (len-1)); + dend = end; + } + } + + if (useDoubles) { + return TclNewArithSeriesDbl(dstart, dend, dstep, len); + } else { + return TclNewArithSeriesInt(start, end, step, len); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjStep -- + * + * 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. + *---------------------------------------------------------------------- + */ +/* + * TclArithSeriesObjStep -- + */ +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj) +{ + ArithSeries *arithSeriesRepPtr; + + if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + if (arithSeriesRepPtr->isDouble) { + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + } else { + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); + } + return TCL_OK; +} + + /* *---------------------------------------------------------------------- * @@ -2394,19 +2608,23 @@ TclNewArithSeriesObj(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W */ int -TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_WideInt *element) +TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj) { ArithSeries *arithSeriesRepPtr; if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + if (index < 0 || index >= arithSeriesRepPtr->len) { + return TCL_ERROR; + } + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } else { + *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); } - arithSeriesRepPtr = (ArithSeries*) - arithSeriesPtr->internalRep.twoPtrValue.ptr1; - if (index < 0 || index >= arithSeriesRepPtr->len) - return TCL_ERROR; - /* List[i] = Start + (Step * i) */ - *element = ArithSeriesIndexM(arithSeriesRepPtr, index);//->start+(index*arithSeriesRepPtr->step); return TCL_OK; } @@ -2467,7 +2685,6 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) } ckfree((char *) arithSeriesRepPtr->elements); } - Tcl_DecrRefCount(arithSeriesRepPtr->wideObjPtr); ckfree((char *) arithSeriesRepPtr); arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; } @@ -2502,14 +2719,8 @@ DupArithSeriesInternalRep(srcPtr, copyPtr) * Allocate a new ArithSeries structure. */ copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries)); - copyArithSeriesRepPtr->start = srcArithSeriesRepPtr->start; - copyArithSeriesRepPtr->end = srcArithSeriesRepPtr->end; - copyArithSeriesRepPtr->step = srcArithSeriesRepPtr->step; - copyArithSeriesRepPtr->len = srcArithSeriesRepPtr->len; + *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; copyArithSeriesRepPtr->elements = NULL; - copyArithSeriesRepPtr->wideObjPtr = Tcl_NewWideIntObj(0); - Tcl_IncrRefCount(copyArithSeriesRepPtr->wideObjPtr); - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; copyPtr->typePtr = &tclArithSeriesType; @@ -2548,24 +2759,20 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - char buffer[TCL_INTEGER_SPACE+2], *p; + char *elem, *p; + Tcl_Obj *elemObj; Tcl_WideInt i; - Tcl_WideInt length = 0, ele; + Tcl_WideInt length = 0; int slen; /* * Pass 1: estimate space. */ for (i = 0; i < arithSeriesRepPtr->len; i++) { - ele = ArithSeriesIndexM(arithSeriesRepPtr, i); - /* - * Note that sprintf will generate a compiler warning under - * Mingw claiming %I64 is an unknown format specifier. - * Just ignore this warning. We can't use %L as the format - * specifier since that gets printed as a 32 bit value. - */ - sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele); - slen = strlen(buffer) + 1; /* + 1 is for the space or the nul-term */ + TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elem = TclGetStringFromObj(elemObj, &slen); + Tcl_DecrRefCount(elemObj); + slen += 1; /* + 1 is for the space or the nul-term */ length += slen; } @@ -2575,12 +2782,12 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); for (i = 0; i < arithSeriesRepPtr->len; i++) { - ele = ArithSeriesIndexM(arithSeriesRepPtr, i); - sprintf(buffer, "%" TCL_LL_MODIFIER "d", ele); - slen = strlen(buffer); - strcpy(p, buffer); + TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elem = TclGetStringFromObj(elemObj, &slen); + strcpy(p, elem); p[slen] = ' '; p += slen+1; + Tcl_DecrRefCount(elemObj); } if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; arithSeriesPtr->length = length-1; @@ -2691,7 +2898,7 @@ TclArithSeriesObjRange( int toIdx) /* Index of last element to include. */ { ArithSeries *arithSeriesRepPtr; - Tcl_WideInt start = -1, end = -1, step, len; + Tcl_Obj *startObj, *endObj, *stepObj; ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); @@ -2704,14 +2911,21 @@ TclArithSeriesObjRange( return obj; } - TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &start); - TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &end); - step = arithSeriesRepPtr->step; - len = ArithSeriesLen(start, end, step); + TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); + Tcl_IncrRefCount(startObj); + TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); + Tcl_IncrRefCount(endObj); + TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { - return TclNewArithSeriesObj(start, end, step, len); + Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble, + startObj, endObj, stepObj, NULL); + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + return newSlicePtr; } /* @@ -2725,11 +2939,33 @@ TclArithSeriesObjRange( TclInvalidateStringRep(arithSeriesPtr); - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = len; - arithSeriesRepPtr->elements = NULL; + if (arithSeriesRepPtr->isDouble) { + ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesPtr; + double start, end, step; + Tcl_GetDoubleFromObj(NULL, startObj, &start); + Tcl_GetDoubleFromObj(NULL, endObj, &end); + Tcl_GetDoubleFromObj(NULL, stepObj, &step); + arithSeriesDblRepPtr->start = start; + arithSeriesDblRepPtr->end = end; + arithSeriesDblRepPtr->step = step; + arithSeriesDblRepPtr->len = (end-start+step)/step; + arithSeriesDblRepPtr->elements = NULL; + + } else { + Tcl_WideInt start, end, step; + Tcl_GetWideIntFromObj(NULL, startObj, &start); + Tcl_GetWideIntFromObj(NULL, endObj, &end); + Tcl_GetWideIntFromObj(NULL, stepObj, &step); + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = (end-start+step)/step; + arithSeriesRepPtr->elements = NULL; + } + + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); return arithSeriesPtr; } @@ -2844,39 +3080,77 @@ TclArithSeriesObjReverse( Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ { ArithSeries *arithSeriesRepPtr; - Tcl_WideInt start = -1, end = -1, step, len; + Tcl_Obj *startObj, *endObj, *stepObj; + Tcl_Obj *resultObj; + Tcl_WideInt start, end, step, len; + double dstart, dend, dstep; + int isDouble; ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &start); - TclArithSeriesObjIndex(arithSeriesPtr, 0, &end); - step = -arithSeriesRepPtr->step; + + TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + + if (isDouble) { + Tcl_GetDoubleFromObj(NULL, startObj, &dstart); + Tcl_GetDoubleFromObj(NULL, endObj, &dend); + Tcl_GetDoubleFromObj(NULL, stepObj, &dstep); + dstep = -dstep; + TclSetDoubleObj(stepObj, dstep); + } else { + Tcl_GetWideIntFromObj(NULL, startObj, &start); + Tcl_GetWideIntFromObj(NULL, endObj, &end); + Tcl_GetWideIntFromObj(NULL, stepObj, &step); + step = -step; + TclSetIntObj(stepObj, step); + } if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { - return TclNewArithSeriesObj(start, end, step, len); - } + Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); + resultObj = TclNewArithSeriesObj(isDouble, + startObj, endObj, stepObj, lenObj); + Tcl_DecrRefCount(lenObj); + } else { - /* - * In-place is possible. - */ + /* + * In-place is possible. + */ - TclInvalidateStringRep(arithSeriesPtr); + TclInvalidateStringRep(arithSeriesPtr); - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i; - for (i=0; ielements[i]); + if (isDouble) { + ArithSeriesDbl *arithSeriesDblRepPtr = + (ArithSeriesDbl*)arithSeriesRepPtr; + arithSeriesDblRepPtr->start = dstart; + arithSeriesDblRepPtr->end = dend; + arithSeriesDblRepPtr->step = dstep; + } else { + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; } - ckfree((char*)arithSeriesRepPtr->elements); + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + for (i=0; ielements[i]); + } + ckfree((char*)arithSeriesRepPtr->elements); + } + arithSeriesRepPtr->elements = NULL; + + resultObj = arithSeriesPtr; } - arithSeriesRepPtr->elements = NULL; - return arithSeriesPtr; + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + + return resultObj; } diff --git a/tests/lseq.test b/tests/lseq.test index 04f9c77..4c837ba 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -testConstraint arithSeriesDouble 0 +testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 testConstraint arithSeriesShimmerOk 0 @@ -71,7 +71,7 @@ test lseq-1.11 {error case: increasing wrong step direction} { test lseq-1.12 {decreasing lseq with step} arithSeriesDouble { lseq 25. to -25. by -5 -} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} +} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} test lseq-1.13 {count operation} { -body { @@ -172,7 +172,7 @@ test lseq-2.11 {error case: increasing wrong step direction} { test lseq-2.12 {decreasing lseq with step} arithSeriesDouble { lseq 25. -25. -5 -} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} +} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} test lseq-2.13 {count only operation} { lseq 5 @@ -188,7 +188,7 @@ test lseq-2.15 {count with decreasing step} { test lseq-2.16 {large numbers} { lseq 1e6 2e6 1e5 -} {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} +} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} test lseq-2.17 {large numbers} arithSeriesDouble { lseq 1e6 2e6 1e5 @@ -394,6 +394,23 @@ test lseq-3.29 {edge case: negative count} { lseq -15 } {} +test lseq-3.30 {lreverse with double values} arithSeriesDouble { + set r [lseq 3.5 18.5 1.5] + set a [lreverse $r] + join [list \ + [lindex [tcl::unsupported::representation $r] 3] \ + $r \ + [lindex [tcl::unsupported::representation $a] 3] \ + $a] \n +} {arithseries +3.5 5.0 6.5 8.0 9.5 11.0 12.5 14.0 15.5 17.0 18.5 +arithseries +18.5 17.0 15.5 14.0 12.5 11.0 9.5 8.0 6.5 5.0 3.5} + +test lseq-3.31 {lreverse inplace with doubles} arithSeriesDouble { + lreverse [lseq 1.1 29.9 0.3] +} {29.9 29.599999999999998 29.299999999999997 29.0 28.7 28.4 28.099999999999998 27.799999999999997 27.5 27.2 26.9 26.599999999999998 26.299999999999997 26.0 25.7 25.4 25.099999999999998 24.799999999999997 24.5 24.2 23.9 23.599999999999998 23.299999999999997 23.0 22.7 22.4 22.099999999999998 21.799999999999997 21.5 21.2 20.9 20.6 20.299999999999997 20.0 19.7 19.4 19.1 18.799999999999997 18.5 18.2 17.9 17.6 17.299999999999997 17.0 16.7 16.4 16.1 15.799999999999999 15.5 15.2 14.899999999999999 14.6 14.299999999999999 14.0 13.7 13.399999999999999 13.099999999999998 12.8 12.5 12.2 11.899999999999999 11.599999999999998 11.3 11.0 10.7 10.399999999999999 10.099999999999998 9.8 9.5 9.2 8.899999999999999 8.599999999999998 8.3 8.0 7.699999999999999 7.399999999999999 7.099999999999998 6.800000000000001 6.5 6.199999999999999 5.899999999999999 5.599999999999998 5.300000000000001 5.0 4.699999999999999 4.399999999999999 4.099999999999998 3.8000000000000007 3.5 3.1999999999999993 2.8999999999999986 2.599999999999998 2.3000000000000007 2.0 1.6999999999999993 1.3999999999999986 1.1000000000000014} + test lseq-4.1 {end expressions} { set start 7 lseq $start $start+11 @@ -405,6 +422,56 @@ test lseq-4.2 {start expressions} { lmap t $tl {expr {$t - $base + 60}} } {0 10 20 30 40 50 60} +## lseq 1 to 10 by -2 +## # -> lseq: invalid step = -2 with a = 1 and b = 10 + +test lseq-4.3 {TIP examples} { + set examples {# Examples from TIP-629 + # --- Begin --- + lseq 10 .. 1 + # -> 10 9 8 7 6 5 4 3 2 1 + lseq 1 .. 10 + # -> 1 2 3 4 5 6 7 8 9 10 + lseq 10 .. 1 by 2 + # -> + lseq 10 .. 1 by -2 + # -> 10 8 6 4 2 + lseq 5.0 to 15. + # -> 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0 + lseq 5.0 to 25. by 5 + # -> 5.0 10.0 15.0 20.0 25.0 + lseq 25. to 5. by 5 + # -> + lseq 25. to 5. by -5 + # -> 25.0 20.0 15.0 10.0 5.0 + lseq 1 to 10 by 2 + # -> 1 3 5 7 9 + lseq 25. to -25. by -5 + # -> 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0 + lseq 5 5 + # -> 5 + lseq 5 5 2 + # -> 5 + lseq 5 5 -2 + # -> 5 + } + + foreach {cmd expect} [split $examples \n] { + if {[string trim $cmd] ne ""} { + set cmd [string trimleft $cmd] + if {[string match {\#*} $cmd]} continue + set status [catch $cmd ans] + lappend res $ans + if {[regexp {\# -> (.*)$} $expect -> expected]} { + if {$expected ne $ans} { + lappend res [list Mismatch: $cmd -> $ans ne $expected] + } + } + } + } + set res +} {{10 9 8 7 6 5 4 3 2 1} {1 2 3 4 5 6 7 8 9 10} {} {10 8 6 4 2} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} {5.0 10.0 15.0 20.0 25.0} {} {25.0 20.0 15.0 10.0 5.0} {1 3 5 7 9} {25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} 5 5 5} + # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 858a9e55021e040d64d6183b62ca8e8559f4538c Mon Sep 17 00:00:00 2001 From: griffin Date: Sun, 28 Aug 2022 22:55:17 +0000 Subject: Move ArithSeries code to its own files. More bug fixes. --- generic/tclArithSeries.c | 955 +++++++++++++++++++++++++++++++++++++++++++++++ generic/tclArithSeries.h | 54 +++ generic/tclCmdAH.c | 1 + generic/tclCmdIL.c | 65 ++-- generic/tclExecute.c | 21 +- generic/tclInt.h | 57 --- generic/tclListObj.c | 931 +-------------------------------------------- unix/Makefile.in | 11 +- win/makefile.vc | 1 + 9 files changed, 1070 insertions(+), 1026 deletions(-) create mode 100644 generic/tclArithSeries.c create mode 100644 generic/tclArithSeries.h diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c new file mode 100644 index 0000000..ae9299a --- /dev/null +++ b/generic/tclArithSeries.c @@ -0,0 +1,955 @@ +/* + * tclArithSeries.c -- + * + * 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. + */ + +#include +#include "tcl.h" +#include "tclInt.h" +#include "tclArithSeries.h" + +/* -------------------------- ArithSeries object ---------------------------- */ + + +#define ArithSeriesRepPtr(arithSeriesObjPtr) \ + (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) + +#define ArithSeriesIndexM(arithSeriesRepPtr, index) \ + ((arithSeriesRepPtr)->isDouble ? \ + (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \ + : \ + ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step))) + +#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \ + do { \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \ + (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr); +static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); + +/* + * The structure below defines the arithmetic series Tcl object type by + * means of procedures that can be invoked by generic object code. + * + * The 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 Tcl_ObjType tclArithSeriesType = { + "arithseries", /* name */ + FreeArithSeriesInternalRep, /* freeIntRepProc */ + DupArithSeriesInternalRep, /* dupIntRepProc */ + UpdateStringOfArithSeries, /* updateStringProc */ + SetArithSeriesFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * ArithSeriesLen -- + * + * Compute the length of the equivalent list where + * every element is generated starting from *start*, + * and adding *step* to generate every successive element + * that's < *end* for positive steps, or > *end* for negative + * steps. + * + * Results: + * + * The length of the list generated by the given range, + * that may be zero. + * The function returns -1 if the list is of length infiite. + * + * Side effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +static Tcl_WideInt +ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) +{ + Tcl_WideInt len; + + if (step == 0) return 0; + len = (step ? (1 + (((end-start))/step)) : 0); + return (len < 0) ? -1 : len; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesInt -- + * + * Creates a new ArithSeries object. The returned object has + * 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 * +TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +{ + Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); + Tcl_Obj *arithSeriesPtr; + ArithSeries *arithSeriesRepPtr; + + TclNewObj(arithSeriesPtr); + + if (length <= 0) { + return arithSeriesPtr; + } + + arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); + arithSeriesRepPtr->isDouble = 0; + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesPtr->typePtr = &tclArithSeriesType; + if (length > 0) + Tcl_InvalidateStringRep(arithSeriesPtr); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesDbl -- + * + * Creates a new ArithSeries object with doubles. The returned object has + * 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 * +TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) +{ + Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); + Tcl_Obj *arithSeriesPtr; + ArithSeriesDbl *arithSeriesRepPtr; + + TclNewObj(arithSeriesPtr); + + if (length <= 0) { + return arithSeriesPtr; + } + + arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); + arithSeriesRepPtr->isDouble = 1; + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesPtr->typePtr = &tclArithSeriesType; + if (length > 0) + Tcl_InvalidateStringRep(arithSeriesPtr); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * assignNumber -- + * + * Create the approprite Tcl_Obj value for the given numeric values. + * Used locally only for decoding [lseq] numeric arguments. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer. + * No assignment on error. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +static void +assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) +{ + union { + double d; + Tcl_WideInt i; + } *number; + int tcl_number_type; + + if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) { + return; + } + if (useDoubles) { + if (tcl_number_type == TCL_NUMBER_DOUBLE) { + *dblNumberPtr = number->d; + } else { + *dblNumberPtr = (double)number->i; + } + } else { + if (tcl_number_type == TCL_NUMBER_INT) { + *intNumberPtr = number->i; + } else { + *intNumberPtr = (Tcl_WideInt)number->d; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclNewArithSeriesObj -- + * + * Creates a new ArithSeries object. Some arguments may be NULL and will + * be computed based on the other given arguments. + * refcount = 0. + * + * Results: + * + * A Tcl_Obj pointer to the created ArithSeries object. + * An empty Tcl_Obj if the range is invalid. + * + * Side Effects: + * + * None. + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj) +{ + double dstart, dend, dstep; + Tcl_WideInt start, end, step, len; + + if (startObj) { + assignNumber(useDoubles, &start, &dstart, startObj); + } else { + start = 0; + dstart = start; + } + if (stepObj) { + assignNumber(useDoubles, &step, &dstep, stepObj); + if (useDoubles) { + step = dstep; + } else { + dstep = step; + } + if (dstep == 0) { + return Tcl_NewObj(); + } + } + if (endObj) { + assignNumber(useDoubles, &end, &dend, endObj); + } + if (lenObj) { + Tcl_GetWideIntFromObj(NULL, lenObj, &len); + } + + if (startObj && endObj) { + if (!stepObj) { + if (useDoubles) { + dstep = (dstart < dend) ? 1.0 : -1.0; + step = dstep; + } else { + step = (start < end) ? 1 : -1; + dstep = step; + } + } + assert(dstep!=0); + if (!lenObj) { + if (useDoubles) { + len = (dend - dstart + dstep)/dstep; + } else { + len = (end - start + step)/step; + } + } + } + + if (!endObj) { + if (useDoubles) { + dend = dstart + (dstep * (len-1)); + end = dend; + } else { + end = start + (step * (len-1)); + dend = end; + } + } + + if (useDoubles) { + return TclNewArithSeriesDbl(dstart, dend, dstep, len); + } else { + return TclNewArithSeriesInt(start, end, step, len); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjStep -- + * + * 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. + *---------------------------------------------------------------------- + */ +/* + * TclArithSeriesObjStep -- + */ +int +TclArithSeriesObjStep( + Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj) +{ + ArithSeries *arithSeriesRepPtr; + + if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + if (arithSeriesRepPtr->isDouble) { + *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + } else { + *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjIndex -- + * + * Returns the element with the specified index in the list + * represented by the specified Arithmentic Sequence object. + * If the index is out of range, TCL_ERROR is returned, + * otherwise TCL_OK is returned and the integer value of the + * element is stored in *element. + * + * Results: + * + * TCL_OK on succes, TCL_ERROR on index out of range. + * + * Side Effects: + * + * On success, the integer pointed by *element is modified. + * + *---------------------------------------------------------------------- + */ + +int +TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj) +{ + ArithSeries *arithSeriesRepPtr; + + if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + if (index < 0 || index >= arithSeriesRepPtr->len) { + return TCL_ERROR; + } + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } else { + *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjLength + * + * Returns the length of the arithmentic series. + * + * Results: + * + * The length of the series as Tcl_WideInt. + * + * Side Effects: + * + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = (ArithSeries*) + arithSeriesPtr->internalRep.twoPtrValue.ptr1; + return arithSeriesRepPtr->len; +} + +/* + *---------------------------------------------------------------------- + * + * FreeArithSeriesInternalRep -- + * + * Deallocate the storage associated with an arithseries object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Frees arithSeriesPtr's ArithSeries* internal representation and + * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. + * + *---------------------------------------------------------------------- + */ + +static void +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + Tcl_Obj**elmts = arithSeriesRepPtr->elements; + for(i=0; ilen; i++) { + if (elmts[i]) { + Tcl_DecrRefCount(elmts[i]); + } + } + ckfree((char *) arithSeriesRepPtr->elements); + } + ckfree((char *) arithSeriesRepPtr); + arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DupArithSeriesInternalRep -- + * + * Initialize the internal representation of a arithseries Tcl_Obj to a + * copy of the internal representation of an existing arithseries object. + * + * Results: + * None. + * + * Side effects: + * We set "copyPtr"s internal rep to a pointer to a + * newly allocated ArithSeries structure. + *---------------------------------------------------------------------- + */ + +static void +DupArithSeriesInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + ArithSeries *srcArithSeriesRepPtr = + (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *copyArithSeriesRepPtr; + + /* + * Allocate a new ArithSeries structure. */ + + copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries)); + *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; + copyArithSeriesRepPtr->elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; + copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + copyPtr->typePtr = &tclArithSeriesType; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateStringOfArithSeries -- + * + * Update the string representation for an arithseries object. + * Note: This procedure does not invalidate an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the list-to-string conversion. This string will be empty if the + * list has no elements. The list internal representation + * should not be NULL and we assume it is not NULL. + * + * Notes: + * At the cost of overallocation it's possible to estimate + * the length of the string representation and make this procedure + * much faster. Because the programmer shouldn't expect the + * string conversion of a big arithmetic sequence to be fast + * this version takes more care of space than time. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) +{ + ArithSeries *arithSeriesRepPtr = + (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + char *elem, *p; + Tcl_Obj *elemObj; + Tcl_WideInt i; + Tcl_WideInt length = 0; + int slen; + + /* + * Pass 1: estimate space. + */ + for (i = 0; i < arithSeriesRepPtr->len; i++) { + TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elem = TclGetStringFromObj(elemObj, &slen); + Tcl_DecrRefCount(elemObj); + slen += 1; /* + 1 is for the space or the nul-term */ + length += slen; + } + + /* + * Pass 2: generate the string repr. + */ + + p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); + for (i = 0; i < arithSeriesRepPtr->len; i++) { + TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elem = TclGetStringFromObj(elemObj, &slen); + strcpy(p, elem); + p[slen] = ' '; + p += slen+1; + Tcl_DecrRefCount(elemObj); + } + if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; + arithSeriesPtr->length = length-1; +} + +/* + *---------------------------------------------------------------------- + * + * SetArithSeriesFromAny -- + * + * The Arithmetic Series object is just an way to optimize + * Lists space complexity, so no one should try to convert + * a string to an Arithmetic Series object. + * + * This function is here just to populate the Type structure. + * + * Results: + * + * The result is always TCL_ERROR. But see Side Effects. + * + * Side effects: + * + * Tcl Panic if called. + * + *---------------------------------------------------------------------- + */ + +static int +SetArithSeriesFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + (void)interp; + (void)objPtr; + Tcl_Panic("SetArithSeriesFromAny: should never be called"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjCopy -- + * + * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. + * + * Results: + * + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a + * refCount of zero. If *arithSeriesPtr does not hold an arithSeries, + * NULL is returned, and if interp is non-NULL, an error message is + * recorded there. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjCopy( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *arithSeriesPtr) /* List object for which an element array is + * to be returned. */ +{ + Tcl_Obj *copyPtr; + ArithSeries *arithSeriesRepPtr; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + if (NULL == arithSeriesRepPtr) { + if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) { + /* We know this is going to panic, but it's the message we want */ + return NULL; + } + } + + TclNewObj(copyPtr); + TclInvalidateStringRep(copyPtr); + DupArithSeriesInternalRep(arithSeriesPtr, copyPtr); + return copyPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjRange -- + * + * Makes a slice of an ArithSeries value. + * *arithSeriesPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the sliced series. + * This may be a new object or the same object if not shared. + * + * Side effects: + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjRange( + Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + ArithSeries *arithSeriesRepPtr; + Tcl_Obj *startObj, *endObj, *stepObj; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (fromIdx > toIdx) { + Tcl_Obj *obj; + TclNewObj(obj); + return obj; + } + + TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); + Tcl_IncrRefCount(startObj); + TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); + Tcl_IncrRefCount(endObj); + TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + Tcl_IncrRefCount(stepObj); + + if (Tcl_IsShared(arithSeriesPtr) || + ((arithSeriesPtr->refCount > 1))) { + Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble, + startObj, endObj, stepObj, NULL); + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + return newSlicePtr; + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(arithSeriesPtr); + + if (arithSeriesRepPtr->isDouble) { + ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesPtr; + double start, end, step; + Tcl_GetDoubleFromObj(NULL, startObj, &start); + Tcl_GetDoubleFromObj(NULL, endObj, &end); + Tcl_GetDoubleFromObj(NULL, stepObj, &step); + arithSeriesDblRepPtr->start = start; + arithSeriesDblRepPtr->end = end; + arithSeriesDblRepPtr->step = step; + arithSeriesDblRepPtr->len = (end-start+step)/step; + arithSeriesDblRepPtr->elements = NULL; + + } else { + Tcl_WideInt start, end, step; + Tcl_GetWideIntFromObj(NULL, startObj, &start); + Tcl_GetWideIntFromObj(NULL, endObj, &end); + Tcl_GetWideIntFromObj(NULL, stepObj, &step); + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = (end-start+step)/step; + arithSeriesRepPtr->elements = NULL; + } + + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + + return arithSeriesPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesGetElements -- + * + * This function returns an (objc,objv) array of the elements in a list + * object. + * + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to an Abstract List object and the object can not be converted + * to one, TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclArithSeriesGetElements( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *objPtr, /* AbstractList object for which an element + * array is to be returned. */ + int *objcPtr, /* Where to store the count of objects + * referenced by objv. */ + Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of + * pointers to the list's objects. */ +{ + if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + ArithSeries *arithSeriesRepPtr; + Tcl_Obj **objv; + int i, objc; + + ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); + objc = arithSeriesRepPtr->len; + if (objc > 0) { + if (arithSeriesRepPtr->elements) { + /* If this exists, it has already been populated */ + objv = arithSeriesRepPtr->elements; + } else { + /* Construct the elements array */ + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); + if (objv == NULL) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + arithSeriesRepPtr->elements = objv; + for (i = 0; i < objc; i++) { + if (TclArithSeriesObjIndex(objPtr, i, &objv[i]) != TCL_OK) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("indexing error", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + Tcl_IncrRefCount(objv[i]); + } + } + } else { + objv = NULL; + } + *objvPtr = objv; + *objcPtr = objc; + } else { + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("value is not an arithseries")); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclArithSeriesObjReverse -- + * + * Reverse the order of the ArithSeries value. + * *arithSeriesPtr must be known to be a valid list. + * + * Results: + * Returns a pointer to the reordered series. + * This may be a new object or the same object if not shared. + * + * Side effects: + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclArithSeriesObjReverse( + Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ +{ + ArithSeries *arithSeriesRepPtr; + Tcl_Obj *startObj, *endObj, *stepObj; + Tcl_Obj *resultObj; + Tcl_WideInt start, end, step, len; + double dstart, dend, dstep; + int isDouble; + + ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + + isDouble = arithSeriesRepPtr->isDouble; + len = arithSeriesRepPtr->len; + + TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + + if (isDouble) { + Tcl_GetDoubleFromObj(NULL, startObj, &dstart); + Tcl_GetDoubleFromObj(NULL, endObj, &dend); + Tcl_GetDoubleFromObj(NULL, stepObj, &dstep); + dstep = -dstep; + TclSetDoubleObj(stepObj, dstep); + } else { + Tcl_GetWideIntFromObj(NULL, startObj, &start); + Tcl_GetWideIntFromObj(NULL, endObj, &end); + Tcl_GetWideIntFromObj(NULL, stepObj, &step); + step = -step; + TclSetIntObj(stepObj, step); + } + + if (Tcl_IsShared(arithSeriesPtr) || + ((arithSeriesPtr->refCount > 1))) { + Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); + resultObj = TclNewArithSeriesObj(isDouble, + startObj, endObj, stepObj, lenObj); + Tcl_DecrRefCount(lenObj); + } else { + + /* + * In-place is possible. + */ + + TclInvalidateStringRep(arithSeriesPtr); + + if (isDouble) { + ArithSeriesDbl *arithSeriesDblRepPtr = + (ArithSeriesDbl*)arithSeriesRepPtr; + arithSeriesDblRepPtr->start = dstart; + arithSeriesDblRepPtr->end = dend; + arithSeriesDblRepPtr->step = dstep; + } else { + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + } + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + for (i=0; ielements[i]); + } + ckfree((char*)arithSeriesRepPtr->elements); + } + arithSeriesRepPtr->elements = NULL; + + resultObj = arithSeriesPtr; + } + + Tcl_DecrRefCount(startObj); + Tcl_DecrRefCount(endObj); + Tcl_DecrRefCount(stepObj); + + return resultObj; +} diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h new file mode 100644 index 0000000..5d014d0 --- /dev/null +++ b/generic/tclArithSeries.h @@ -0,0 +1,54 @@ +/* + * 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 AirthSeries internal representation. + * Note that the len can in theory be always computed by start,end,step + * but it's faster to cache it inside the internal representation. + */ +typedef struct ArithSeries { + Tcl_WideInt start; + Tcl_WideInt end; + Tcl_WideInt step; + Tcl_WideInt len; + Tcl_Obj **elements; + int isDouble; +} ArithSeries; +typedef struct ArithSeriesDbl { + double start; + double end; + double step; + Tcl_WideInt len; + Tcl_Obj **elements; + int isDouble; +} ArithSeriesDbl; + + +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, + Tcl_Obj **stepObj); +MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, + Tcl_WideInt index, Tcl_Obj **elementObj); +MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, + int fromIdx, int toIdx); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, + Tcl_WideInt end, Tcl_WideInt step, + Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, + double step, Tcl_WideInt len); +MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, + Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index adb4044..eb9c337 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -15,6 +15,7 @@ #ifdef _WIN32 # include "tclWinInt.h" #endif +#include "tclArithSeries.h" /* * The state structure used by [foreach]. Note that the actual structure has diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 77a8ffc..bcee3ca 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -20,6 +20,7 @@ #include "tclInt.h" #include "tclRegexp.h" #include +#include "tclArithSeries.h" /* * During execution of the "lsort" command, structures of the following type @@ -101,7 +102,7 @@ static const char *const seq_operations[] = { "..", "to", "count", "by", NULL }; typedef enum Sequence_Operators { - RANGE_DOTS, RANGE_TO, RANGE_COUNT, RANGE_BY + LSEQ_DOTS, LSEQ_TO, LSEQ_COUNT, LSEQ_BY } SequenceOperators; static const char *const seq_step_keywords[] = {"by", NULL}; typedef enum Step_Operators { @@ -4131,21 +4132,21 @@ SequenceIdentifyArgument( * Enumerated possible argument patterns: * * 1: - * range n + * lseq n * 2: - * range n n + * lseq n n * 3: - * range n n n - * range n 'to' n - * range n 'count' n - * range n 'by' n + * lseq n n n + * lseq n 'to' n + * lseq n 'count' n + * lseq n 'by' n * 4: - * range n 'to' n n - * range n n 'by' n - * range n 'count' n n + * lseq n 'to' n n + * lseq n n 'by' n + * lseq n 'count' n n * 5: - * range n 'to' n 'by' n - * range n 'count' n 'by' n + * lseq n 'to' n 'by' n + * lseq n 'count' n 'by' n * * Results: * A standard Tcl object result. @@ -4269,17 +4270,17 @@ Tcl_LseqObjCmd( case 121: opmode = (SequenceOperators)values[1]; switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: + case LSEQ_DOTS: + case LSEQ_TO: start = numValues[0]; end = numValues[2]; break; - case RANGE_BY: + case LSEQ_BY: start = zero; elementCount = numValues[0]; step = numValues[2]; break; - case RANGE_COUNT: + case LSEQ_COUNT: start = numValues[0]; elementCount = numValues[2]; step = one; @@ -4295,18 +4296,18 @@ Tcl_LseqObjCmd( case 1211: opmode = (SequenceOperators)values[1]; switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: + case LSEQ_DOTS: + case LSEQ_TO: start = numValues[0]; end = numValues[2]; step = numValues[3]; break; - case RANGE_COUNT: + case LSEQ_COUNT: start = numValues[0]; elementCount = numValues[2]; step = numValues[3]; break; - case RANGE_BY: + case LSEQ_BY: /* Error case */ status = TCL_ERROR; goto done; @@ -4324,12 +4325,12 @@ Tcl_LseqObjCmd( end = numValues[1]; opmode = (SequenceOperators)values[2]; switch (opmode) { - case RANGE_BY: + case LSEQ_BY: step = numValues[3]; break; - case RANGE_DOTS: - case RANGE_TO: - case RANGE_COUNT: + case LSEQ_DOTS: + case LSEQ_TO: + case LSEQ_COUNT: default: status = TCL_ERROR; goto done; @@ -4343,7 +4344,7 @@ Tcl_LseqObjCmd( start = numValues[0]; opmode = (SequenceOperators)values[3]; switch (opmode) { - case RANGE_BY: + case LSEQ_BY: step = numValues[4]; break; default: @@ -4353,12 +4354,12 @@ Tcl_LseqObjCmd( } opmode = (SequenceOperators)values[1]; switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: + case LSEQ_DOTS: + case LSEQ_TO: start = numValues[0]; end = numValues[2]; break; - case RANGE_COUNT: + case LSEQ_COUNT: start = numValues[0]; elementCount = numValues[2]; break; @@ -4379,16 +4380,16 @@ Tcl_LseqObjCmd( KeywordError: status = TCL_ERROR; switch (opmode) { - case RANGE_DOTS: - case RANGE_TO: + case LSEQ_DOTS: + case LSEQ_TO: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "missing \"to\" value.")); break; - case RANGE_COUNT: + case LSEQ_COUNT: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "missing \"count\" value.")); break; - case RANGE_BY: + case LSEQ_BY: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "missing \"by\" value.")); break; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d4bba5e..2df2611 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -19,6 +19,7 @@ #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" +#include "tclArithSeries.h" #include #include @@ -4868,15 +4869,17 @@ TEBCresume( /* special case for ArithSeries */ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - ArithSeries *arithSeriesRepPtr = - (ArithSeries*) valuePtr->internalRep.twoPtrValue.ptr1; - length = arithSeriesRepPtr->len; + length = TclArithSeriesObjLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - objResultPtr = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } goto lindexDone; } @@ -4928,9 +4931,7 @@ TEBCresume( /* special case for ArithSeries */ if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { - ArithSeries *arithSeriesRepPtr = - (ArithSeries*) valuePtr->internalRep.twoPtrValue.ptr1; - length = arithSeriesRepPtr->len; + length = TclArithSeriesObjLength(valuePtr); /* Decode end-offset index values. */ @@ -4938,7 +4939,11 @@ TEBCresume( /* Compute value @ index */ if (index >= 0 && index < length) { - objResultPtr = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } } else { TclNewObj(objResultPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 95abe4c..eebf7ea 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2480,44 +2480,6 @@ typedef struct List { (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) /* - * The structure used for the AirthSeries internal representation. - * Note that the len can in theory be always computed by start,end,step - * but it's faster to cache it inside the internal representation. - */ -typedef struct ArithSeries { - Tcl_WideInt start; - Tcl_WideInt end; - Tcl_WideInt step; - Tcl_WideInt len; - Tcl_Obj **elements; - int isDouble; -} ArithSeries; -typedef struct ArithSeriesDbl { - double start; - double end; - double step; - Tcl_WideInt len; - Tcl_Obj **elements; - int isDouble; -} ArithSeriesDbl; - -#define ArithSeriesRepPtr(arithSeriesObjPtr) \ - (ArithSeries *) ((arithSeriesObjPtr)->internalRep.twoPtrValue.ptr1) - -#define ArithSeriesIndexM(arithSeriesRepPtr, index) \ - ((arithSeriesRepPtr)->isDouble ? \ - (((ArithSeriesDbl*)(arithSeriesRepPtr))->start+((index) * ((ArithSeriesDbl*)(arithSeriesRepPtr))->step)) \ - : \ - ((arithSeriesRepPtr)->start+((index) * arithSeriesRepPtr->step))) - -#define ArithSeriesStepM(arithSeriesRepPtr) \ - ((arithSeriesRepPtr)->isDouble ? \ - ((ArithSeriesDbl*)(arithSeriesRepPtr))->step \ - : \ - (arithSeriesRepPtr)->step) - - -/* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, * TclNRLmapCmd and their compilations. */ @@ -2959,25 +2921,6 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj); -MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, - Tcl_WideInt index, Tcl_Obj **elementObj); -MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Obj *arithSeriesPtr, - int fromIdx, int toIdx); -MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step, - Tcl_WideInt len); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, - double step, Tcl_WideInt len); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, - Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, ClientData clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 4366782..74b3a29 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -11,8 +11,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include "tclInt.h" #include +#include "tclInt.h" +#include "tclArithSeries.h" /* * Prototypes for functions defined later in this file: @@ -68,14 +69,6 @@ const Tcl_ObjType tclListType = { #define ListResetInternalRep(objPtr, listRepPtr) \ TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) -#define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \ - do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \ - (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \ - } while (0) - - #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif @@ -2050,16 +2043,15 @@ SetListFromAny( * and may occur frequently. */ Tcl_WideInt wideLen = TclArithSeriesObjLength(objPtr), j; - ArithSeries *arithSeriesRepPtr = (ArithSeries*) - objPtr->internalRep.twoPtrValue.ptr1; listRepPtr = AttemptNewList(interp, wideLen, NULL); if (listRepPtr == NULL) { return TCL_ERROR; } elemPtrs = listRepPtr->elements; for (j = 0; j < wideLen; j++) { - elemPtrs[j] = Tcl_NewWideIntObj( - ArithSeriesIndexM(arithSeriesRepPtr, j)); //->start+(j*arithSeriesRepPtr->step)); + if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) { + return TCL_ERROR; + } Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */ } listRepPtr->elemCount = wideLen; @@ -2239,919 +2231,6 @@ UpdateStringOfList( ckfree(flagPtr); } } -/* -------------------------- ArithSeries object ---------------------------- */ - -/* - * Prototypes for procedures defined later in this file: - */ - -static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr); -static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); - -/* - * The structure below defines the arithmetic series Tcl object type by - * means of procedures that can be invoked by generic object code. - * - * The 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 Tcl_ObjType tclArithSeriesType = { - "arithseries", /* name */ - FreeArithSeriesInternalRep, /* freeIntRepProc */ - DupArithSeriesInternalRep, /* dupIntRepProc */ - UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny /* setFromAnyProc */ -}; - -/* - *---------------------------------------------------------------------- - * - * ArithSeriesLen -- - * - * Compute the length of the equivalent list where - * every element is generated starting from *start*, - * and adding *step* to generate every successive element - * that's < *end* for positive steps, or > *end* for negative - * steps. - * - * Results: - * - * The length of the list generated by the given range, - * that may be zero. - * The function returns -1 if the list is of length infiite. - * - * Side effects: - * - * None. - * - *---------------------------------------------------------------------- - */ -static Tcl_WideInt -ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) -{ - Tcl_WideInt len; - - if (step == 0) return 0; - len = (step ? (1 + (((end-start))/step)) : 0); - return (len < 0) ? -1 : len; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewArithSeriesInt -- - * - * Creates a new ArithSeries object. The returned object has - * 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 * -TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) -{ - Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); - Tcl_Obj *arithSeriesPtr; - ArithSeries *arithSeriesRepPtr; - - TclNewObj(arithSeriesPtr); - - if (length <= 0) { - return arithSeriesPtr; - } - - arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); - arithSeriesRepPtr->isDouble = 0; - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = length; - arithSeriesRepPtr->elements = NULL; - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; - arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; - if (length > 0) - Tcl_InvalidateStringRep(arithSeriesPtr); - - return arithSeriesPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclNewArithSeriesDbl -- - * - * Creates a new ArithSeries object with doubles. The returned object has - * 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 * -TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) -{ - Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); - Tcl_Obj *arithSeriesPtr; - ArithSeriesDbl *arithSeriesRepPtr; - - TclNewObj(arithSeriesPtr); - - if (length <= 0) { - return arithSeriesPtr; - } - - arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); - arithSeriesRepPtr->isDouble = 1; - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = length; - arithSeriesRepPtr->elements = NULL; - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; - arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; - if (length > 0) - Tcl_InvalidateStringRep(arithSeriesPtr); - - return arithSeriesPtr; -} - -/* - *---------------------------------------------------------------------- - * - * assignNumber -- - * - * Create the approprite Tcl_Obj value for the given numeric values. - * Used locally only for decoding [lseq] numeric arguments. - * refcount = 0. - * - * Results: - * - * A Tcl_Obj pointer. - * No assignment on error. - * - * Side Effects: - * - * None. - *---------------------------------------------------------------------- - */ -static void -assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) -{ - union { - double d; - Tcl_WideInt i; - } *number; - int tcl_number_type; - - if (TclGetNumberFromObj(NULL, numberObj, (ClientData*)&number, &tcl_number_type) != TCL_OK) { - return; - } - if (useDoubles) { - if (tcl_number_type == TCL_NUMBER_DOUBLE) { - *dblNumberPtr = number->d; - } else { - *dblNumberPtr = (double)number->i; - } - } else { - if (tcl_number_type == TCL_NUMBER_INT) { - *intNumberPtr = number->i; - } else { - *intNumberPtr = (Tcl_WideInt)number->d; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclNewArithSeriesObj -- - * - * Creates a new ArithSeries object. Some arguments may be NULL and will - * be computed based on the other given arguments. - * refcount = 0. - * - * Results: - * - * A Tcl_Obj pointer to the created ArithSeries object. - * An empty Tcl_Obj if the range is invalid. - * - * Side Effects: - * - * None. - *---------------------------------------------------------------------- - */ -Tcl_Obj * -TclNewArithSeriesObj(int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj) -{ - double dstart, dend, dstep; - Tcl_WideInt start, end, step, len; - - if (startObj) { - assignNumber(useDoubles, &start, &dstart, startObj); - } else { - start = 0; - dstart = start; - } - if (stepObj) { - assignNumber(useDoubles, &step, &dstep, stepObj); - if (useDoubles) { - step = dstep; - } else { - dstep = step; - } - if (dstep == 0) { - return Tcl_NewObj(); - } - } - if (endObj) { - assignNumber(useDoubles, &end, &dend, endObj); - } - if (lenObj) { - Tcl_GetWideIntFromObj(NULL, lenObj, &len); - } - - if (startObj && endObj) { - if (!stepObj) { - if (useDoubles) { - dstep = (dstart < dend) ? 1.0 : -1.0; - step = dstep; - } else { - step = (start < end) ? 1 : -1; - dstep = step; - } - } - assert(dstep!=0); - if (!lenObj) { - if (useDoubles) { - len = (dend - dstart + dstep)/dstep; - } else { - len = (end - start + step)/step; - } - } - } - - if (!endObj) { - if (useDoubles) { - dend = dstart + (dstep * (len-1)); - end = dend; - } else { - end = start + (step * (len-1)); - dend = end; - } - } - - if (useDoubles) { - return TclNewArithSeriesDbl(dstart, dend, dstep, len); - } else { - return TclNewArithSeriesInt(start, end, step, len); - } -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjStep -- - * - * 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. - *---------------------------------------------------------------------- - */ -/* - * TclArithSeriesObjStep -- - */ -int -TclArithSeriesObjStep( - Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj) -{ - ArithSeries *arithSeriesRepPtr; - - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (arithSeriesRepPtr->isDouble) { - *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); - } else { - *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); - } - return TCL_OK; -} - - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjIndex -- - * - * Returns the element with the specified index in the list - * represented by the specified Arithmentic Sequence object. - * If the index is out of range, TCL_ERROR is returned, - * otherwise TCL_OK is returned and the integer value of the - * element is stored in *element. - * - * Results: - * - * TCL_OK on succes, TCL_ERROR on index out of range. - * - * Side Effects: - * - * On success, the integer pointed by *element is modified. - * - *---------------------------------------------------------------------- - */ - -int -TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj) -{ - ArithSeries *arithSeriesRepPtr; - - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); - } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (index < 0 || index >= arithSeriesRepPtr->len) { - return TCL_ERROR; - } - /* List[i] = Start + (Step * index) */ - if (arithSeriesRepPtr->isDouble) { - *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); - } else { - *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjLength - * - * Returns the length of the arithmentic series. - * - * Results: - * - * The length of the series as Tcl_WideInt. - * - * Side Effects: - * - * None. - * - *---------------------------------------------------------------------- - */ -Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) -{ - ArithSeries *arithSeriesRepPtr = (ArithSeries*) - arithSeriesPtr->internalRep.twoPtrValue.ptr1; - return arithSeriesRepPtr->len; -} - -/* - *---------------------------------------------------------------------- - * - * FreeArithSeriesInternalRep -- - * - * Deallocate the storage associated with an arithseries object's - * internal representation. - * - * Results: - * None. - * - * Side effects: - * Frees arithSeriesPtr's ArithSeries* internal representation and - * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. - * - *---------------------------------------------------------------------- - */ - -static void -FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) -{ - ArithSeries *arithSeriesRepPtr = - (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i; - Tcl_Obj**elmts = arithSeriesRepPtr->elements; - for(i=0; ilen; i++) { - if (elmts[i]) { - Tcl_DecrRefCount(elmts[i]); - } - } - ckfree((char *) arithSeriesRepPtr->elements); - } - ckfree((char *) arithSeriesRepPtr); - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DupArithSeriesInternalRep -- - * - * Initialize the internal representation of a arithseries Tcl_Obj to a - * copy of the internal representation of an existing arithseries object. - * - * Results: - * None. - * - * Side effects: - * We set "copyPtr"s internal rep to a pointer to a - * newly allocated ArithSeries structure. - *---------------------------------------------------------------------- - */ - -static void -DupArithSeriesInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - ArithSeries *srcArithSeriesRepPtr = - (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; - ArithSeries *copyArithSeriesRepPtr; - - /* - * Allocate a new ArithSeries structure. */ - - copyArithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof(ArithSeries)); - *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; - copyArithSeriesRepPtr->elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclArithSeriesType; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfArithSeries -- - * - * Update the string representation for an arithseries object. - * Note: This procedure does not invalidate an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from - * the list-to-string conversion. This string will be empty if the - * list has no elements. The list internal representation - * should not be NULL and we assume it is not NULL. - * - * Notes: - * At the cost of overallocation it's possible to estimate - * the length of the string representation and make this procedure - * much faster. Because the programmer shouldn't expect the - * string conversion of a big arithmetic sequence to be fast - * this version takes more care of space than time. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) -{ - ArithSeries *arithSeriesRepPtr = - (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - char *elem, *p; - Tcl_Obj *elemObj; - Tcl_WideInt i; - Tcl_WideInt length = 0; - int slen; - - /* - * Pass 1: estimate space. - */ - for (i = 0; i < arithSeriesRepPtr->len; i++) { - TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); - elem = TclGetStringFromObj(elemObj, &slen); - Tcl_DecrRefCount(elemObj); - slen += 1; /* + 1 is for the space or the nul-term */ - length += slen; - } - - /* - * Pass 2: generate the string repr. - */ - - p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); - for (i = 0; i < arithSeriesRepPtr->len; i++) { - TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); - elem = TclGetStringFromObj(elemObj, &slen); - strcpy(p, elem); - p[slen] = ' '; - p += slen+1; - Tcl_DecrRefCount(elemObj); - } - if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; - arithSeriesPtr->length = length-1; -} - -/* - *---------------------------------------------------------------------- - * - * SetArithSeriesFromAny -- - * - * The Arithmetic Series object is just an way to optimize - * Lists space complexity, so no one should try to convert - * a string to an Arithmetic Series object. - * - * This function is here just to populate the Type structure. - * - * Results: - * - * The result is always TCL_ERROR. But see Side Effects. - * - * Side effects: - * - * Tcl Panic if called. - * - *---------------------------------------------------------------------- - */ - -static int -SetArithSeriesFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ -{ - (void)interp; - (void)objPtr; - Tcl_Panic("SetArithSeriesFromAny: should never be called"); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjCopy -- - * - * Makes a "pure arithSeries" copy of an ArithSeries value. This provides for the C - * level a counterpart of the [lrange $list 0 end] command, while using - * internals details to be as efficient as possible. - * - * Results: - * - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a - * refCount of zero. If *arithSeriesPtr does not hold an arithSeries, - * NULL is returned, and if interp is non-NULL, an error message is - * recorded there. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclArithSeriesObjCopy( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *arithSeriesPtr) /* List object for which an element array is - * to be returned. */ -{ - Tcl_Obj *copyPtr; - ArithSeries *arithSeriesRepPtr; - - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); - if (NULL == arithSeriesRepPtr) { - if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) { - /* We know this is going to panic, but it's the message we want */ - return NULL; - } - } - - TclNewObj(copyPtr); - TclInvalidateStringRep(copyPtr); - DupArithSeriesInternalRep(arithSeriesPtr, copyPtr); - return copyPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjRange -- - * - * Makes a slice of an ArithSeries value. - * *arithSeriesPtr must be known to be a valid list. - * - * Results: - * Returns a pointer to the sliced series. - * This may be a new object or the same object if not shared. - * - * Side effects: - * ?The possible conversion of the object referenced by listPtr? - * ?to a list object.? - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclArithSeriesObjRange( - Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ - int fromIdx, /* Index of first element to include. */ - int toIdx) /* Index of last element to include. */ -{ - ArithSeries *arithSeriesRepPtr; - Tcl_Obj *startObj, *endObj, *stepObj; - - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); - - if (fromIdx < 0) { - fromIdx = 0; - } - if (fromIdx > toIdx) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; - } - - TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); - Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); - Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesPtr, &stepObj); - Tcl_IncrRefCount(stepObj); - - if (Tcl_IsShared(arithSeriesPtr) || - ((arithSeriesPtr->refCount > 1))) { - Tcl_Obj *newSlicePtr = TclNewArithSeriesObj(arithSeriesRepPtr->isDouble, - startObj, endObj, stepObj, NULL); - Tcl_DecrRefCount(startObj); - Tcl_DecrRefCount(endObj); - Tcl_DecrRefCount(stepObj); - return newSlicePtr; - } - - /* - * In-place is possible. - */ - - /* - * Even if nothing below cause any changes, we still want the - * string-canonizing effect of [lrange 0 end]. - */ - - TclInvalidateStringRep(arithSeriesPtr); - - if (arithSeriesRepPtr->isDouble) { - ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesPtr; - double start, end, step; - Tcl_GetDoubleFromObj(NULL, startObj, &start); - Tcl_GetDoubleFromObj(NULL, endObj, &end); - Tcl_GetDoubleFromObj(NULL, stepObj, &step); - arithSeriesDblRepPtr->start = start; - arithSeriesDblRepPtr->end = end; - arithSeriesDblRepPtr->step = step; - arithSeriesDblRepPtr->len = (end-start+step)/step; - arithSeriesDblRepPtr->elements = NULL; - - } else { - Tcl_WideInt start, end, step; - Tcl_GetWideIntFromObj(NULL, startObj, &start); - Tcl_GetWideIntFromObj(NULL, endObj, &end); - Tcl_GetWideIntFromObj(NULL, stepObj, &step); - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = (end-start+step)/step; - arithSeriesRepPtr->elements = NULL; - } - - Tcl_DecrRefCount(startObj); - Tcl_DecrRefCount(endObj); - Tcl_DecrRefCount(stepObj); - - return arithSeriesPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesGetElements -- - * - * This function returns an (objc,objv) array of the elements in a list - * object. - * - * Results: - * The return value is normally TCL_OK; in this case *objcPtr is set to - * the count of list elements and *objvPtr is set to a pointer to an - * array of (*objcPtr) pointers to each list element. If listPtr does not - * refer to an Abstract List object and the object can not be converted - * to one, TCL_ERROR is returned and an error message will be left in the - * interpreter's result if interp is not NULL. - * - * The objects referenced by the returned array should be treated as - * readonly and their ref counts are _not_ incremented; the caller must - * do that if it holds on to a reference. Furthermore, the pointer and - * length returned by this function may change as soon as any function is - * called on the list object; be careful about retaining the pointer in a - * local data structure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclArithSeriesGetElements( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *objPtr, /* AbstractList object for which an element - * array is to be returned. */ - int *objcPtr, /* Where to store the count of objects - * referenced by objv. */ - Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of - * pointers to the list's objects. */ -{ - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { - ArithSeries *arithSeriesRepPtr; - Tcl_Obj **objv; - int i, objc; - - ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); - objc = arithSeriesRepPtr->len; - if (objc > 0) { - if (arithSeriesRepPtr->elements) { - /* If this exists, it has already been populated */ - objv = arithSeriesRepPtr->elements; - } else { - /* Construct the elements array */ - objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); - if (objv == NULL) { - if (interp) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; - } - arithSeriesRepPtr->elements = objv; - for (i = 0; i < objc; i++) { - Tcl_WideInt wi = ArithSeriesIndexM(arithSeriesRepPtr, (Tcl_WideInt)i); - objv[i] = Tcl_NewWideIntObj(wi); - Tcl_IncrRefCount(objv[i]); - } - } - } else { - objv = NULL; - } - *objvPtr = objv; - *objcPtr = objc; - } else { - if (interp != NULL) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("value is not an arithseries")); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", NULL); - } - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclArithSeriesObjReverse -- - * - * Reverse the order of the ArithSeries value. - * *arithSeriesPtr must be known to be a valid list. - * - * Results: - * Returns a pointer to the reordered series. - * This may be a new object or the same object if not shared. - * - * Side effects: - * ?The possible conversion of the object referenced by listPtr? - * ?to a list object.? - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclArithSeriesObjReverse( - Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ -{ - ArithSeries *arithSeriesRepPtr; - Tcl_Obj *startObj, *endObj, *stepObj; - Tcl_Obj *resultObj; - Tcl_WideInt start, end, step, len; - double dstart, dend, dstep; - int isDouble; - - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); - - isDouble = arithSeriesRepPtr->isDouble; - len = arithSeriesRepPtr->len; - - TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); - TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); - TclArithSeriesObjStep(arithSeriesPtr, &stepObj); - - if (isDouble) { - Tcl_GetDoubleFromObj(NULL, startObj, &dstart); - Tcl_GetDoubleFromObj(NULL, endObj, &dend); - Tcl_GetDoubleFromObj(NULL, stepObj, &dstep); - dstep = -dstep; - TclSetDoubleObj(stepObj, dstep); - } else { - Tcl_GetWideIntFromObj(NULL, startObj, &start); - Tcl_GetWideIntFromObj(NULL, endObj, &end); - Tcl_GetWideIntFromObj(NULL, stepObj, &step); - step = -step; - TclSetIntObj(stepObj, step); - } - - if (Tcl_IsShared(arithSeriesPtr) || - ((arithSeriesPtr->refCount > 1))) { - Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); - resultObj = TclNewArithSeriesObj(isDouble, - startObj, endObj, stepObj, lenObj); - Tcl_DecrRefCount(lenObj); - } else { - - /* - * In-place is possible. - */ - - TclInvalidateStringRep(arithSeriesPtr); - - if (isDouble) { - ArithSeriesDbl *arithSeriesDblRepPtr = - (ArithSeriesDbl*)arithSeriesRepPtr; - arithSeriesDblRepPtr->start = dstart; - arithSeriesDblRepPtr->end = dend; - arithSeriesDblRepPtr->step = dstep; - } else { - arithSeriesRepPtr->start = start; - arithSeriesRepPtr->end = end; - arithSeriesRepPtr->step = step; - } - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i; - for (i=0; ielements[i]); - } - ckfree((char*)arithSeriesRepPtr->elements); - } - arithSeriesRepPtr->elements = NULL; - - resultObj = arithSeriesPtr; - } - - Tcl_DecrRefCount(startObj); - Tcl_DecrRefCount(endObj); - Tcl_DecrRefCount(stepObj); - - return resultObj; -} /* diff --git a/unix/Makefile.in b/unix/Makefile.in index 30d9462..1769aa4 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -299,8 +299,8 @@ XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \ tclThreadTest.o tclUnixTest.o tclXtNotify.o tclXtTest.o GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ - tclAssembly.o tclAsync.o tclBasic.o tclBinary.o tclCkalloc.o \ - tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ + tclArithSeries.o tclAssembly.o tclAsync.o tclBasic.o tclBinary.o \ + tclCkalloc.o tclClock.o tclCmdAH.o tclCmdIL.o tclCmdMZ.o \ tclCompCmds.o tclCompCmdsGR.o tclCompCmdsSZ.o tclCompExpr.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclDisassemble.o \ tclEncoding.o tclEnsemble.o \ @@ -393,7 +393,8 @@ GENERIC_HDRS = \ $(GENERIC_DIR)/tclPatch.h \ $(GENERIC_DIR)/tclPlatDecls.h \ $(GENERIC_DIR)/tclPort.h \ - $(GENERIC_DIR)/tclRegexp.h + $(GENERIC_DIR)/tclRegexp.h \ + $(GENERIC_DIR)/tclArithSeries.h GENERIC_SRCS = \ $(GENERIC_DIR)/regcomp.c \ @@ -401,6 +402,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ $(GENERIC_DIR)/tclAlloc.c \ + $(GENERIC_DIR)/tclArithSeries.c \ $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ @@ -1250,6 +1252,9 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c +tclArithSeries.o: $(GENERIC_DIR)/tclArithSeries.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclArithSeries.c + tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c diff --git a/win/makefile.vc b/win/makefile.vc index 7c61580..f9c9242 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -238,6 +238,7 @@ COREOBJS = \ $(TMP_DIR)\regexec.obj \ $(TMP_DIR)\regfree.obj \ $(TMP_DIR)\tclAlloc.obj \ + $(TMP_DIR)\tclArithSeries.obj \ $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ -- cgit v0.12 From 7fda2c560ac829fc808182cfc2f71bed71ebb4df Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 31 Aug 2022 23:41:13 +0000 Subject: Fix build issues. --- generic/tclArithSeries.c | 3 +-- generic/tclCmdIL.c | 1 + win/Makefile.in | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) mode change 100644 => 100755 generic/tclArithSeries.c diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c old mode 100644 new mode 100755 index ae9299a..3bb1593 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -10,10 +10,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include -#include "tcl.h" #include "tclInt.h" #include "tclArithSeries.h" +#include /* -------------------------- ArithSeries object ---------------------------- */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fa8d1a5..9430eb5 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -4414,6 +4414,7 @@ Tcl_LseqObjCmd( /* All other argument errors */ default: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); + status = TCL_ERROR; goto done; break; } diff --git a/win/Makefile.in b/win/Makefile.in index 4e14ddc..7b9440e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -278,6 +278,7 @@ GENERIC_OBJS = \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ + tclArithSeries.$(OBJEXT) \ tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ -- cgit v0.12 From 2da690df065ecf6648f8bcd07048efca00b78726 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Sep 2022 14:09:11 +0000 Subject: Add empty "range.test": GIT doesn't handling file renames well .... --- tests/range.test | 343 ------------------------------------------------------- 1 file changed, 343 deletions(-) diff --git a/tests/range.test b/tests/range.test index d1e96ad..e69de29 100644 --- a/tests/range.test +++ b/tests/range.test @@ -1,343 +0,0 @@ -# Commands covered: range -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright © 2003 Simon Geard. -# -# 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::* -} - -testConstraint arithSeriesDouble 0 -testConstraint arithSeriesShimmer 1 -testConstraint arithSeriesShimmerOk 0 - -## Arg errors -test range-1.1 {error cases} -body { - range -} \ - -returnCodes 1 \ - -result {wrong # args: should be "range n ??op? n ??by? n??"} - - -test range-1.2 {step magnitude} { - range 10 .. 1 by -2 ;# or this could be an error - or not -} {10 8 6 4 2} - -test range-1.3 {synergy between int and double} { - set rl [range 25. to 5. by -5] - set il [range 25 to 5 by -5] - lmap r $rl i $il { if {$r ne "" && $i ne ""} {expr {int($r) == $i}} else {list $r $i} } -} {1 1 1 1 1} - -test range-1.4 {integer decreasing} { - range 10 .. 1 -} {10 9 8 7 6 5 4 3 2 1} - -test range-1.5 {integer increasing} { - range 1 .. 10 -} {1 2 3 4 5 6 7 8 9 10} - -test range-1.6 {integer decreasing with step} { - range 10 .. 1 by -2 -} {10 8 6 4 2} - -test range-1.7 {real increasing range} arithSeriesDouble { - range 5.0 to 15. -} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} - -test range-1.8 {real increasing range with step} arithSeriesDouble { - range 5.0 to 25. by 5 -} {5.0 10.0 15.0 20.0 25.0} - -test range-1.9 {real decreasing with step} arithSeriesDouble { - range 25. to 5. by -5 -} {25.0 20.0 15.0 10.0 5.0} - -# note, 10 cannot be in such a list, but allowed -test range-1.10 {integer range with step} { - range 1 to 10 by 2 -} {1 3 5 7 9} - -test range-1.11 {error case: increasing wrong step direction} { - range 1 to 10 by -2 -} {} - -test range-1.12 {decreasing range with step} arithSeriesDouble { - range 25. to -25. by -5 -} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} - -test range-1.13 {count operation} { - -body { - range 5 count 5 - } - -result {5 6 7 8 9} -} - -test range-1.14 {count with step} { - -body { - range 5 count 5 by 2 - } - -result {5 7 9 11 13} -} - -test range-1.15 {count with decreasing step} { - -body { - range 5 count 5 by -2 - } - -result {5 3 1 -1 -3} -} - -test range-1.16 {large numbers} { - -body { - range [expr {int(1e6)}] [expr {int(2e6)}] [expr {int(1e5)}] - } - -result {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} -} - -test range-1.17 {too many arguments} -body { - range 12 to 24 by 2 with feeling -} -returnCodes 1 -result {wrong # args: should be "range n ??op? n ??by? n??"} - -test range-1.18 {too many arguments extra valid keyword} -body { - range 12 to 24 by 2 count -} -returnCodes 1 -result {wrong # args: should be "range n ??op? n ??by? n??"} - -test range-1.19 {too many arguments extra numeric value} -body { - range 12 to 24 by 2 7 -} -returnCodes 1 -result {wrong # args: should be "range n ??op? n ??by? n??"} - -# -# Short-hand use cases -# -test range-2.2 {step magnitude} { - range 10 1 2 ;# this is an empty case since step has wrong sign -} {} - -test range-2.3 {step wrong sign} arithSeriesDouble { - range 25. 5. 5 ;# ditto - empty list -} {} - -test range-2.4 {integer decreasing} { - range 10 1 -} {10 9 8 7 6 5 4 3 2 1} - -test range-2.5 {integer increasing} { - range 1 10 -} {1 2 3 4 5 6 7 8 9 10} - -test range-2.6 {integer decreasing with step} { - range 10 1 by -2 -} {10 8 6 4 2} - -test range-2.7 {real increasing range} arithSeriesDouble { - range 5.0 15. -} {5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0 14.0 15.0} - - -test range-2.8 {real increasing range with step} arithSeriesDouble { - range 5.0 25. 5 -} {5.0 10.0 15.0 20.0 25.0} - - -test range-2.9 {real decreasing with step} arithSeriesDouble { - range 25. 5. -5 -} {25.0 20.0 15.0 10.0 5.0} - -test range-2.10 {integer range with step} { - range 1 10 2 -} {1 3 5 7 9} - -test range-2.11 {error case: increasing wrong step direction} { - range 1 10 -2 -} {} - -test range-2.12 {decreasing range with step} arithSeriesDouble { - range 25. -25. -5 -} { 25.0 20.0 15.0 10.0 5.0 0.0 -5.0 -10.0 -15.0 -20.0 -25.0} - -test range-2.13 {count only operation} { - range 5 -} {0 1 2 3 4} - -test range-2.14 {count with step} { - range 5 count 5 2 -} {5 7 9 11 13} - -test range-2.15 {count with decreasing step} { - range 5 count 5 -2 -} {5 3 1 -1 -3} - -test range-2.16 {large numbers} { - range 1e6 2e6 1e5 -} {1000000 1100000 1200000 1300000 1400000 1500000 1600000 1700000 1800000 1900000 2000000} - -test range-2.17 {large numbers} arithSeriesDouble { - range 1e6 2e6 1e5 -} {1000000.0 1100000.0 1200000.0 1300000.0 1400000.0 1500000.0 1600000.0 1700000.0 1800000.0 1900000.0 2000000.0} - - -test range-3.1 {experiement} { - set ans {} - foreach factor [range 2.0 10.0] { - set start 1 - set end 10 - for {set step 1} {$step < 1e8} {} { - set l [range $start to $end by $step] - if {[llength $l] != 10} { - lappend ans $factor $step [llength $l] $l - } - set step [expr {$step * $factor}] - set end [expr {$end * $factor}] - } - } - if {$ans eq {}} { - set ans OK - } - set ans -} {OK} - -test range-3.2 {error case} -body { - range foo -} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} - -test range-3.3 {error case} -body { - range 10 foo -} -returnCodes 1 -result {bad operation "foo": must be .., to, count, or by} - -test range-3.4 {error case} -body { - range 25 or 6 -} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} - -test range-3.5 {simple count and step arguments} { - range 25 by 6 -} {0 6 12 18 24 30 36 42 48 54 60 66 72 78 84 90 96 102 108 114 120 126 132 138 144 150} - -test range-3.6 {error case} -body { - range 1 7 or 3 -} -returnCodes 1 -result {bad operation "or": must be .., to, count, or by} - -test range-3.7 {lmap range} { - lmap x [range 5] { expr {$x * $x} } -} {0 1 4 9 16} - -test range-3.8 {lrange range} { - set r [lrange [range 1 100] 10 20] - lindex [tcl::unsupported::representation $r] 3 -} {arithseries} - -test range-3.9 {lassign range} arithSeriesShimmer { - set r [range 15] - set r2 [lassign $r a b] - list [lindex [tcl::unsupported::representation $r] 3] $a $b \ - [lindex [tcl::unsupported::representation $r2] 3] -} {arithseries 0 1 arithseries} - -test range-3.10 {lsearch range must shimmer?} arithSeriesShimmer { - set r [range 15 0] - set a [lsearch $r 9] - list [lindex [tcl::unsupported::representation $r] 3] $a -} {list 6} - -test range-3.11 {lreverse range} { - set r [range 15 0] - set a [lreverse $r] - join [list \ - [lindex [tcl::unsupported::representation $r] 3] \ - $r \ - [lindex [tcl::unsupported::representation $a] 3] \ - $a] \n -} {arithseries -15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 -arithseries -0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15} - -test range-3.12 {in operator} { - set r [range 9] - set i [expr {7 in $r}] - set j [expr {10 ni $r}] - set k [expr {-1 in $r}] - set l [expr {4 ni $r}] - list $i $j $k $l [lindex [tcl::unsupported::representation $r] 3] -} {1 1 0 0 arithseries} - -test range-3.13 {lmap range shimmer} arithSeriesShimmer { - set r [range 15] - set rep-before [lindex [tcl::unsupported::representation $r] 3] - set m [lmap i $r { expr {$i * 7} }] - set rep-after [lindex [tcl::unsupported::representation $r] 3] - set rep-m [lindex [tcl::unsupported::representation $m] 3] - list $r ${rep-before} ${rep-after} ${rep-m} $m -} {{0 1 2 3 4 5 6 7 8 9 10 11 12 13 14} arithseries arithseries list {0 7 14 21 28 35 42 49 56 63 70 77 84 91 98}} - -test range-3.14 {array for shimmer} arithSeriesShimmerOk { - array set testarray {a Test for This great Function} - set vars [range 2] - set vars-rep [lindex [tcl::unsupported::representation $vars] 3] - array for $vars testarray { - lappend keys $0 - lappend vals $1 - } - # Since hash order is not guaranteed, have to validate content ignoring order - set valk [lmap k $keys {expr {$k in {a for great}}}] - set valv [lmap v $vals {expr {$v in {Test This Function}}}] - set vars-after [lindex [tcl::unsupported::representation $vars] 3] - list ${vars-rep} $valk $valv ${vars-after} -} {arithseries {1 1 1} {1 1 1} arithseries} - -test range-3.15 {join for shimmer} arithSeriesShimmerOk { - set r [range 3] - set rep-before [lindex [tcl::unsupported::representation $r] 3] - set str [join $r :] - set rep-after [lindex [tcl::unsupported::representation $r] 3] - list ${rep-before} $str ${rep-after} -} {arithseries 0:1:2 arithseries} - -test range-3.16 {error case} -body { - range 16 to -} -returnCodes 1 -result {missing "to" value.} - -test range-3.17 {error case} -body { - range 17 to 13 by -} -returnCodes 1 -result {missing "by" value.} - -test range-3.18 {error case} -body { - range 18 count -} -returnCodes 1 -result {missing "count" value.} - - -# Test lmap -# Test "in" expression operator -# Test llength -# Test lindex -# Test lrange (lrange of a [range] list produces another [range] list) -# Test start,end,step expressions -# Test lreverse -# Test lsearch -# Test array for -# Test join for shimmer. - -test range-4.1 {end expressions} { - set start 7 - range $start $start+11 -} {7 8 9 10 11 12 13 14 15 16 17 18} - -test range-4.2 {start expressions} { - set base [clock seconds] - set tl [range $base-60 $base 10] - lmap t $tl {expr {$t - $base + 60}} -} {0 10 20 30 40 50 60} - -# cleanup -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: -- cgit v0.12 From 41516d6ea03d8b26e83d30afb272bbc650e50cb6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Sep 2022 16:22:51 +0000 Subject: Restore compatibility with C++ compiler --- generic/tclArithSeries.c | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 3bb1593..8a9037a 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -500,9 +500,9 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) */ static void -DupArithSeriesInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +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; @@ -609,12 +609,10 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) */ static int -SetArithSeriesFromAny(interp, objPtr) - Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr; /* The object to convert. */ +SetArithSeriesFromAny( + TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ + TCL_UNUSED(Tcl_Obj *)) /* The object to convert. */ { - (void)interp; - (void)objPtr; Tcl_Panic("SetArithSeriesFromAny: should never be called"); return TCL_ERROR; } -- cgit v0.12 From a10ceedaec45bd6c5cb247ee80ad91d59e87cda3 Mon Sep 17 00:00:00 2001 From: fvogel Date: Mon, 5 Sep 2022 19:42:00 +0000 Subject: Fix some typos in comments. --- generic/tclArithSeries.c | 12 ++++++------ generic/tclArithSeries.h | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 8a9037a..93177a7 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -93,7 +93,7 @@ const Tcl_ObjType tclArithSeriesType = { * * The length of the list generated by the given range, * that may be zero. - * The function returns -1 if the list is of length infiite. + * The function returns -1 if the list is of length infinite. * * Side effects: * @@ -210,7 +210,7 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) * * assignNumber -- * - * Create the approprite Tcl_Obj value for the given numeric values. + * Create the appropriate Tcl_Obj value for the given numeric values. * Used locally only for decoding [lseq] numeric arguments. * refcount = 0. * @@ -384,14 +384,14 @@ TclArithSeriesObjStep( * TclArithSeriesObjIndex -- * * Returns the element with the specified index in the list - * represented by the specified Arithmentic Sequence object. + * represented by the specified Arithmetic Sequence object. * If the index is out of range, TCL_ERROR is returned, * otherwise TCL_OK is returned and the integer value of the * element is stored in *element. * * Results: * - * TCL_OK on succes, TCL_ERROR on index out of range. + * TCL_OK on success, TCL_ERROR on index out of range. * * Side Effects: * @@ -426,7 +426,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele * * TclArithSeriesObjLength * - * Returns the length of the arithmentic series. + * Returns the length of the arithmetic series. * * Results: * @@ -724,7 +724,7 @@ TclArithSeriesObjRange( */ /* - * Even if nothing below cause any changes, we still want the + * Even if nothing below causes any changes, we still want the * string-canonizing effect of [lrange 0 end]. */ diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 5d014d0..f855c22 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -11,7 +11,7 @@ */ /* - * The structure used for the AirthSeries internal representation. + * 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. */ -- cgit v0.12 From cdecc6d50946d64936ade03c2384bf0361e9156e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Sep 2022 11:45:29 +0000 Subject: Revive TIP #220 implementation: Escalate Privileges in VFS Close Callback --- doc/CrtChannel.3 | 15 +++++++ generic/tcl.decls | 5 +++ generic/tclDecls.h | 6 +++ generic/tclIO.c | 52 ++++++++++++++++++++++ generic/tclIO.h | 2 + generic/tclStubInit.c | 1 + generic/tclTest.c | 39 +++++++++++++++++ tests/io.test | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 238 insertions(+) diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 02772e8..1496631 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -35,6 +35,11 @@ Tcl_ThreadId int \fBTcl_GetChannelMode\fR(\fIchannel\fR) .sp +.VS 8.7 +int +\fBTcl_RemoveChannelMode\fR(\fIinterp, channel, mode\fR) +.VE 8.7 +.sp int \fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) .sp @@ -243,6 +248,16 @@ events to the correct event queue even for a multi-threaded core. and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input and output. .PP +.VS 8.7 +.PP +\fBTcl_RemoveChannelMode\fR removes an access privilege from the +channel, either \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR, and returns +a regular Tcl result code, \fBTCL_OK\fR, or \fBTCL_ERROR\fR. The +function throws an error if either an invalid mode is specified or the +result of the removal would be an inaccessible channel. In that case +an error message is left in the interp argument, if not NULL. +.VE 8.7 +.PP \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers allocated to store input or output in \fIchannel\fR. If the value was not set by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then diff --git a/generic/tcl.decls b/generic/tcl.decls index d08ba0a..c7c917f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2524,6 +2524,11 @@ declare 679 { void *clientData, size_t objc, Tcl_Obj *const objv[]) } +# TIP #220. +declare 680 { + int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3917d0f..fc61249 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1996,6 +1996,9 @@ EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); +/* 680 */ +EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, + Tcl_Channel chan, int mode); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2711,6 +2714,7 @@ typedef struct TclStubs { Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ + int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 680 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4099,6 +4103,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */ #define Tcl_NRCallObjProc2 \ (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */ +#define Tcl_RemoveChannelMode \ + (tclStubsPtr->tcl_RemoveChannelMode) /* 680 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 5313eed..532f758 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1681,6 +1681,7 @@ Tcl_CreateChannel( } statePtr->channelName = tmp; statePtr->flags = mask; + statePtr->maxPerms = mask; /* Save max privileges for close callback */ /* * Set the channel to system default encoding. @@ -2166,8 +2167,11 @@ Tcl_UnstackChannel( /* * Close and free the channel driver state. + * TIP #220: This is done with maximum privileges (as created). */ + statePtr->flags &= ~(TCL_READABLE|TCL_WRITABLE); + statePtr->flags |= statePtr->maxPerms; result = ChanClose(chanPtr, interp); ChannelFree(chanPtr); @@ -2447,6 +2451,54 @@ Tcl_GetChannelHandle( } /* + *---------------------------------------------------------------------- + * + * Tcl_RemoveChannelMode -- + * + * Remove either read or write privileges from the channel. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * May change the access mode of the channel. + * May leave an error message in the interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RemoveChannelMode( + Tcl_Interp* interp, /* The interp for an error message. Allowed to be NULL. */ + Tcl_Channel chan, /* The channel which is modified. */ + int mode) /* The access mode to drop from the channel */ +{ + const char* emsg; + ChannelState *statePtr = ((Channel *) chan)->state; + /* State of actual channel. */ + + if ((mode != TCL_READABLE) && (mode != TCL_WRITABLE)) { + emsg = "Illegal mode value."; + goto error; + } + if (0 == (statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & ~mode)) { + emsg = "Bad mode, would make channel inacessible"; + goto error; + } + + statePtr->flags &= ~mode; + return TCL_OK; + + error: + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "Tcl_RemoveChannelMode error: %s. Channel: \"%s\"", + emsg, Tcl_GetChannelName((Tcl_Channel) chan))); + } + return TCL_ERROR; +} + +/* *--------------------------------------------------------------------------- * * AllocChannelBuffer -- diff --git a/generic/tclIO.h b/generic/tclIO.h index 54aa5af..3d2b7be 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -216,6 +216,8 @@ typedef struct ChannelState { * companion to 'unreportedError'. */ size_t epoch; /* Used to test validity of stored channelname * lookup results. */ + int maxPerms; /* TIP #220: Max access privileges + * the channel was created with. */ } ChannelState; /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 87c9d0a..f31146c 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2042,6 +2042,7 @@ const TclStubs tclStubs = { Tcl_CreateObjTrace2, /* 677 */ Tcl_NRCreateCommand2, /* 678 */ Tcl_NRCallObjProc2, /* 679 */ + Tcl_RemoveChannelMode, /* 680 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index d13b7ce..3d64992 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6042,6 +6042,45 @@ TestChannelCmd( return TCL_OK; } + if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", NULL); + return TCL_ERROR; + } + + if (statePtr->maxPerms & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (statePtr->maxPerms & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + return TCL_OK; + } + + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE); + } + + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE); + } + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", NULL); diff --git a/tests/io.test b/tests/io.test index 6314ace..767c22e 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8954,6 +8954,124 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { # ### ### ### ######### ######### ######### + + +test io-75.0 {channel modes} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r] +} -constraints testchannel -body { + testchannel mode $f +} -cleanup { + close $f + removeFile dummy +} -result {read {}} + +test io-75.1 {channel modes} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile w] +} -constraints testchannel -body { + testchannel mode $f +} -cleanup { + close $f + removeFile dummy +} -result {{} write} + +test io-75.2 {channel modes} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mode $f +} -cleanup { + close $f + removeFile dummy +} -result {read write} + +test io-75.3 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r] +} -constraints testchannel -body { + testchannel mremove-wr $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{read {}} {read {}}} + +test io-75.4 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r] +} -constraints testchannel -body { + testchannel mremove-rd $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} + +test io-75.5 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile w] +} -constraints testchannel -body { + testchannel mremove-rd $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{{} write} {{} write}} + +test io-75.6 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile w] +} -constraints testchannel -body { + testchannel mremove-wr $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} + +test io-75.7 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-rd $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{{} write} {read write}} + +test io-75.8 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-wr $f + list [testchannel mode $f] [testchannel maxmode $f] +} -cleanup { + close $f + removeFile dummy +} -result {{read {}} {read write}} + +test io-75.9 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-wr $f + testchannel mremove-rd $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} + +test io-75.10 {channel mode dropping} -setup { + set datafile [makeFile {some characters} dummy] + set f [open $datafile r+] +} -constraints testchannel -body { + testchannel mremove-rd $f + testchannel mremove-wr $f +} -returnCodes error -cleanup { + close $f + removeFile dummy +} -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} + # cleanup foreach file [list fooBar longfile script script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { -- cgit v0.12 From 5c0c8a2c84ae92a60624623d05f43e3189a9653c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Sep 2022 15:33:02 +0000 Subject: TIP #594 implementation: Modernize "file stat" interface --- doc/file.n | 37 ++++++++++++++++++------------------ generic/tclCmdAH.c | 55 ++++++++++++++++++++++++++++++++++++++++++++++-------- tests/cmdAH.test | 18 ++++++++++++++---- 3 files changed, 80 insertions(+), 30 deletions(-) diff --git a/doc/file.n b/doc/file.n index c5a5eed..b0ad4ca 100644 --- a/doc/file.n +++ b/doc/file.n @@ -251,14 +251,14 @@ symbolic and hard links (the latter for files only). Windows supports symbolic directory links and hard file links on NTFS drives. .RE .TP -\fBfile lstat \fIname varName\fR +\fBfile lstat \fIname ?varName?\fR . Same as \fBstat\fR option (see below) except uses the \fIlstat\fR kernel call instead of \fIstat\fR. This means that if \fIname\fR -refers to a symbolic link the information returned in \fIvarName\fR -is for the link rather than the file it refers to. On systems that -do not support symbolic links this option behaves exactly the same -as the \fBstat\fR option. +refers to a symbolic link the information returned is for the link +rather than the file it refers to. On systems that do not support +symbolic links this option behaves exactly the same as the +\fBstat\fR option. .TP \fBfile mkdir\fR ?\fIdir\fR ...? . @@ -393,19 +393,20 @@ that use the third component do not attempt to perform tilde substitution. .RE .TP -\fBfile stat \fIname varName\fR -. -Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable -given by \fIvarName\fR to hold information returned from the kernel call. -\fIVarName\fR is treated as an array variable, and the following elements -of that variable are set: \fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, -\fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR, \fBsize\fR, \fBtype\fR, -\fBuid\fR. Each element except \fBtype\fR is a decimal string with the -value of the corresponding field from the \fBstat\fR return structure; -see the manual entry for \fBstat\fR for details on the meanings of the -values. The \fBtype\fR element gives the type of the file in the same -form returned by the command \fBfile type\fR. This command returns an -empty string. +\fBfile stat \fIname ?varName?\fR +. +Invokes the \fBstat\fR kernel call on \fIname\fR, and returns a +dictionary with the information returned from the kernel call. If +\fIvarName\fR is given, it uses the variable to hold the information. +\fIVarName\fR is treated as an array variable, and in such case the +command returns the empty string. The following elements are set: +\fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, +\fBmtime\fR, \fBnlink\fR, \fBsize\fR, \fBtype\fR, \fBuid\fR. Each element +except \fBtype\fR is a decimal string with the value of the corresponding +field from the \fBstat\fR return structure; see the manual entry for +\fBstat\fR for details on the meanings of the values. The \fBtype\fR +element gives the type of the file in the same form returned by the +command \fBfile type\fR. .TP \fBfile system \fIname\fR . diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 28fc210..f0d6966 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1409,14 +1409,18 @@ FileAttrLinkStatCmd( { Tcl_StatBuf buf; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?"); return TCL_ERROR; } if (GetStatBuf(interp, objv[1], Tcl_FSLstat, &buf) != TCL_OK) { return TCL_ERROR; } - return StoreStatData(interp, objv[2], &buf); + if (objc == 2) { + return StoreStatData(interp, NULL, &buf); + } else { + return StoreStatData(interp, objv[2], &buf); + } } /* @@ -1445,14 +1449,18 @@ FileAttrStatCmd( { Tcl_StatBuf buf; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "name varName"); + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?varName?"); return TCL_ERROR; } if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } - return StoreStatData(interp, objv[2], &buf); + if (objc == 2) { + return StoreStatData(interp, NULL, &buf); + } else { + return StoreStatData(interp, objv[2], &buf); + } } /* @@ -2352,7 +2360,7 @@ GetStatBuf( * * This is a utility procedure that breaks out the fields of a "stat" * structure and stores them in textual form into the elements of an - * associative array. + * associative array (if given) or returns a dictionary. * * Results: * Returns a standard Tcl return value. If an error occurs then a message @@ -2372,9 +2380,40 @@ StoreStatData( Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to * store in varName. */ { - Tcl_Obj *field, *value; + Tcl_Obj *field, *value, *result; unsigned short mode; + if (varName == NULL) { + result = Tcl_NewObj(); + Tcl_IncrRefCount(result); +#define DOBJPUT(key, objValue) \ + Tcl_DictObjPut(NULL, result, \ + Tcl_NewStringObj((key), -1), \ + (objValue)); + DOBJPUT("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); + DOBJPUT("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); + DOBJPUT("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); + DOBJPUT("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); + DOBJPUT("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); + DOBJPUT("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS + DOBJPUT("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); +#endif +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + DOBJPUT("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); +#endif + DOBJPUT("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); + DOBJPUT("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); + DOBJPUT("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); + mode = (unsigned short) statPtr->st_mode; + DOBJPUT("mode", Tcl_NewWideIntObj(mode)); + DOBJPUT("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); +#undef DOBJPUT + Tcl_SetObjResult(interp, result); + Tcl_DecrRefCount(result); + return TCL_OK; + } + /* * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! * diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ab1a8e6..1a79fa3 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1527,14 +1527,14 @@ catch {file attributes $gorpfile -permissions 0o765} # stat test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body { - file stat _bogus_ -} -result {wrong # args: should be "file stat name varName"} + file stat +} -result {wrong # args: should be "file stat name ?varName?"} test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ a b -} -result {wrong # args: should be "file stat name varName"} +} -result {wrong # args: should be "file stat name ?varName?"} test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { unset -nocomplain stat - set stat(blocks) [set stat(blksize) {}] + array set stat {blocks {} blksize {}} } -body { file stat $gorpfile stat unset stat(blocks) stat(blksize); # Ignore these fields; not always set @@ -1627,6 +1627,16 @@ test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints } set res } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} +test cmdAH-28.14 {Tcl_FileObjCmd: stat} -setup { + unset -nocomplain stat +} -body { + file stat $gorpfile stat + expr { + [lsort -stride 2 [array get stat]] + eq + [lsort -stride 2 [file stat $gorpfile]] + } +} -result {1} unset -nocomplain stat # type -- cgit v0.12 From 0eddd55ab6d8747fd749f24f769a4025e5863e8b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Sep 2022 13:01:43 +0000 Subject: Fix cmdAH-23.* testcases --- tests/cmdAH.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 1a79fa3..984100e 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -1194,10 +1194,10 @@ test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0 catch {file link -symbolic $linkfile $gorpfile} test cmdAH-23.1 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a -} -result {wrong # args: should be "file lstat name varName"} +} -result {could not read "a": no such file or directory} test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a b c -} -result {wrong # args: should be "file lstat name varName"} +} -result {wrong # args: should be "file lstat name ?varName?"} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { -- cgit v0.12 From 4590e2d12033ebf1ad82a2b46da552f0638b763a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Sep 2022 20:42:30 +0000 Subject: Proposed fix for [c0bc269178], with testcase --- generic/tclCmdMZ.c | 8 ++++++-- tests/switch.test | 7 +++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3ff9947..53e12c5 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3930,8 +3930,12 @@ TclNRSwitchObjCmd( if (matchVarObj != NULL) { Tcl_Obj *substringObj; - substringObj = Tcl_GetRange(stringObj, - info.matches[j].start, info.matches[j].end-1); + if (info.matches[j].end > 0) { + substringObj = Tcl_GetRange(stringObj, + info.matches[j].start, info.matches[j].end-1); + } else { + TclNewObj(substringObj); + } /* * Never fails; the object is always clean at this point. diff --git a/tests/switch.test b/tests/switch.test index 8ca049c..a7211cb 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -745,6 +745,13 @@ test switch-14.16 {switch -regexp compilation} { } }} } no +test switch-14.17 {switch -regexp bug [c0bc269178]} { + set result {} + switch -regexp -matchvar m -indexvar i ac { + {(a)(b)?(c)} {set result $m} + } + set result +} {ac a {} c} test switch-15.1 {coroutine safety of non-bytecoded switch} {*}{ -body { -- cgit v0.12 -- cgit v0.12 From 159cb3d31d8b70d7ef29798372421c08c9274a85 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Sep 2022 18:23:14 +0000 Subject: Another test related to TIP 623. --- tests/stringObj.test | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/stringObj.test b/tests/stringObj.test index b799828..dce932b 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -505,6 +505,11 @@ test stringObj-16.5 {Tcl_GetRange: fist = last = -1} testobj { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde +test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj { + # Older implementations could return "cde" + teststringobj set 1 abcde + teststringobj range 1 2 0 +} {} if {[testConstraint testobj]} { -- cgit v0.12 From 9babdebe9d5537c0026d149ca8810b9ffad51d0d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Sep 2022 18:38:51 +0000 Subject: Update docs and comments to agree with TIP 623. --- doc/StringObj.3 | 4 +++- generic/tclStringObj.c | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 7870b21..90678c4 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -211,7 +211,9 @@ appropriate range. characters between \fIfirst\fR and \fIlast\fR (inclusive) in the value's Unicode representation. If the value's Unicode representation is invalid, the Unicode representation is regenerated -from the value's string representation. +from the value's string representation. If \fIfirst\fR < 0, then +the returned string starts at the beginning of the value. If \fIlast\fR < 0, +then the returned string ends at the end of the value. .PP \fBTcl_GetCharLength\fR returns the number of characters (as opposed to bytes) in the string value. diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index b81e711..b109808 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -739,7 +739,9 @@ Tcl_GetUnicodeFromObj( * * Create a Tcl Object that contains the chars between first and last of * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. + * String object, convert it to one. If first is negative, the returned + * string start at the beginning of objPtr. If last is negative, the + * returned string ends at the end of objPtr. * * Results: * Returns a new Tcl Object of the String type. -- cgit v0.12 From cccb9994ce059b965d7537c824ddd63a839f8c21 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Sep 2022 12:30:11 +0000 Subject: Fix [22ab2ae64a]: Build with minizip broken (actually, only a problem in 8.7, but let's keep tinydir.h the same in all branches) --- compat/zlib/contrib/minizip/tinydir.h | 6 ------ 1 file changed, 6 deletions(-) diff --git a/compat/zlib/contrib/minizip/tinydir.h b/compat/zlib/contrib/minizip/tinydir.h index ba20c3e..b8133ac 100644 --- a/compat/zlib/contrib/minizip/tinydir.h +++ b/compat/zlib/contrib/minizip/tinydir.h @@ -546,12 +546,6 @@ int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file) #ifndef _MSC_VER #ifdef __MINGW32__ if (_tstat( -#elif (defined _BSD_SOURCE) || (defined _DEFAULT_SOURCE) \ - || ((defined _XOPEN_SOURCE) && (_XOPEN_SOURCE >= 500)) \ - || ((defined _POSIX_C_SOURCE) && (_POSIX_C_SOURCE >= 200112L)) \ - || ((defined __APPLE__) && (defined __MACH__)) \ - || (defined BSD) - if (lstat( #else if (stat( #endif -- cgit v0.12 From aca56ccb68a14a617153b07b8c272f8838d1f3f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Sep 2022 15:32:59 +0000 Subject: Make TclObjInterpProc a macro (since it always should be used through TclGetObjInterpProc()) Add some unused stub entries. Add some more type-casts to tclProc.c --- generic/tcl.decls | 2 +- generic/tclDecls.h | 24 ++++++++++++++--- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 6 +++-- generic/tclProc.c | 75 +++++++++++++++++---------------------------------- generic/tclStubInit.c | 11 ++++++-- 6 files changed, 61 insertions(+), 59 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6b67e77..0c18c78 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2325,7 +2325,7 @@ declare 630 { # ----- BASELINE -- FOR -- 8.6.0 ----- # -declare 675 { +declare 681 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index f2eed87..8731144 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1859,7 +1859,13 @@ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( /* Slot 672 is reserved */ /* Slot 673 is reserved */ /* Slot 674 is reserved */ -/* 675 */ +/* Slot 675 is reserved */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ +/* Slot 680 is reserved */ +/* 681 */ EXTERN void TclUnusedStubEntry(void); typedef struct { @@ -2571,7 +2577,13 @@ typedef struct TclStubs { void (*reserved672)(void); void (*reserved673)(void); void (*reserved674)(void); - void (*tclUnusedStubEntry) (void); /* 675 */ + void (*reserved675)(void); + void (*reserved676)(void); + void (*reserved677)(void); + void (*reserved678)(void); + void (*reserved679)(void); + void (*reserved680)(void); + void (*tclUnusedStubEntry) (void); /* 681 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3908,8 +3920,14 @@ extern const TclStubs *tclStubsPtr; /* Slot 672 is reserved */ /* Slot 673 is reserved */ /* Slot 674 is reserved */ +/* Slot 675 is reserved */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ +/* Slot 680 is reserved */ #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 675 */ + (tclStubsPtr->tclUnusedStubEntry) /* 681 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 0e909a2..c2d8253 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -175,7 +175,7 @@ declare 38 { const char **simpleNamePtr) } declare 39 { - TclObjCmdProcType TclGetObjInterpProc(void) + Tcl_ObjCmdProc *TclGetObjInterpProc(void) } declare 40 { int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 0282259..c524608 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -143,7 +143,7 @@ EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 39 */ -EXTERN TclObjCmdProcType TclGetObjInterpProc(void); +EXTERN Tcl_ObjCmdProc * TclGetObjInterpProc(void); /* 40 */ EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr); @@ -692,7 +692,7 @@ typedef struct TclIntStubs { void (*reserved36)(void); int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */ int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */ - TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */ + Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ @@ -1377,6 +1377,8 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TclSetStartupScriptPath #undef TclBackgroundException #undef TclUnusedStubEntry +#undef TclObjInterpProc +#define TclObjInterpProc TclGetObjInterpProc() #if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) # undef Tcl_SetStartupScript diff --git a/generic/tclProc.c b/generic/tclProc.c index 7550bfa..97a32a6 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -163,8 +163,8 @@ Tcl_ProcObjCmd( * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], - &procPtr) != TCL_OK) { + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], + objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); @@ -200,7 +200,6 @@ Tcl_ProcObjCmd( CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; - if (contextPtr->type == TCL_LOCATION_BC) { /* * Retrieve source information from the bytecode, if possible. If @@ -255,7 +254,7 @@ Tcl_ProcObjCmd( * is able to trigger this situation. */ - CmdFrame *cfOldPtr = Tcl_GetHashValue(hePtr); + CmdFrame *cfOldPtr = (CmdFrame *)Tcl_GetHashValue(hePtr); if (cfOldPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfOldPtr->data.eval.path); @@ -541,7 +540,7 @@ TclCreateProc( * (its value was kept the same as pre VarReform to simplify * tbcload's processing of older byetcodes). * - * The only other flag vlaue that is important to retrieve from + * The only other flag value that is important to retrieve from * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ @@ -861,7 +860,7 @@ Uplevel_Callback( Tcl_Interp *interp, int result) { - CallFrame *savedVarFramePtr = data[0]; + CallFrame *savedVarFramePtr = (CallFrame *)data[0]; if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -876,15 +875,14 @@ Uplevel_Callback( return result; } - /* ARGSUSED */ int Tcl_UplevelObjCmd( - ClientData dummy, /* Not used. */ + ClientData clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv); } int @@ -1045,7 +1043,7 @@ TclIsProc( cmdPtr = (Command *) origCmd; } if (cmdPtr->deleteProc == TclProcDeleteProc) { - return cmdPtr->objClientData; + return (Proc *)cmdPtr->objClientData; } return NULL; } @@ -1067,7 +1065,7 @@ ProcWrongNumArgs( numArgs = framePtr->procPtr->numArgs; desiredObjs = (Tcl_Obj **)TclStackAlloc(interp, - (int) sizeof(Tcl_Obj *) * (numArgs+1)); + sizeof(Tcl_Obj *) * (numArgs+1)); if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); @@ -1318,7 +1316,7 @@ InitLocalCache( Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; - int new; + int isNew; /* * Cache the names and initial values of local variables; store the @@ -1339,7 +1337,7 @@ InitLocalCache( } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, localPtr->nameLength, /* hash */ (unsigned int) -1, - &new, /* nsPtr */ NULL, 0, NULL); + &isNew, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } @@ -1414,7 +1412,7 @@ InitArgsAndLocals( * parameters. */ - varPtr = TclStackAlloc(interp, localCt * sizeof(Var)); + varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var)); framePtr->compiledLocals = varPtr; framePtr->numCompiledLocals = localCt; @@ -1552,7 +1550,7 @@ TclPushProcCallFrame( int isLambda) /* 1 if this is a call by ApplyObjCmd: it * needs special rules for error msg */ { - Proc *procPtr = clientData; + Proc *procPtr = (Proc *)clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame *framePtr, **framePtrPtr; int result; @@ -1635,6 +1633,7 @@ TclPushProcCallFrame( *---------------------------------------------------------------------- */ +#undef TclObjInterpProc int TclObjInterpProc( ClientData clientData, /* Record describing procedure to be @@ -1795,7 +1794,7 @@ InterpProcNR2( Interp *iPtr = (Interp *) interp; Proc *procPtr = iPtr->varFramePtr->procPtr; CallFrame *freePtr; - Tcl_Obj *procNameObj = data[0]; + Tcl_Obj *procNameObj = (Tcl_Obj *)data[0]; ProcErrorProc *errorProc = (ProcErrorProc *)data[1]; if (TCL_DTRACE_PROC_RETURN_ENABLED()) { @@ -2033,7 +2032,7 @@ TclProcCompileProc( */ iPtr->invokeWord = 0; - iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL); + iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL; TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; TclPopStackFrame(interp); @@ -2108,7 +2107,7 @@ void TclProcDeleteProc( ClientData clientData) /* Procedure to be deleted. */ { - Proc *procPtr = clientData; + Proc *procPtr = (Proc *)clientData; if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); @@ -2190,7 +2189,7 @@ TclProcCleanupProc( return; } - cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); + cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr); if (cfPtr) { if (cfPtr->type == TCL_LOCATION_SOURCE) { @@ -2271,10 +2270,10 @@ TclUpdateReturnInfo( *---------------------------------------------------------------------- */ -TclObjCmdProcType +Tcl_ObjCmdProc * TclGetObjInterpProc(void) { - return (TclObjCmdProcType) TclObjInterpProc; + return TclObjInterpProc; } /* @@ -2497,7 +2496,7 @@ SetLambdaFromAny( */ if (iPtr->cmdFramePtr) { - CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); *contextPtr = *iPtr->cmdFramePtr; if (contextPtr->type == TCL_LOCATION_BC) { @@ -2616,12 +2615,12 @@ SetLambdaFromAny( int Tcl_ApplyObjCmd( - ClientData dummy, /* Not used. */ + ClientData clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, dummy, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv); } int @@ -2653,30 +2652,6 @@ TclNRApplyObjCmd( procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } -#define JOE_EXTENSION 0 -/* - * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT - * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt - * the code. (MS) - */ - -#if JOE_EXTENSION - else { - /* - * Joe English's suggestion to allow cmdNames to function as lambdas. - */ - - Tcl_Obj *elemPtr; - int numElem; - - if ((lambdaPtr->typePtr == &tclCmdNameType) || - (TclListObjGetElements(interp, lambdaPtr, &numElem, - &elemPtr) == TCL_OK && numElem == 1)) { - return Tcl_EvalObjv(interp, objc-1, objv+1, 0); - } - } -#endif - if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { result = SetLambdaFromAny(interp, lambdaPtr); if (result != TCL_OK) { @@ -2696,7 +2671,7 @@ TclNRApplyObjCmd( return TCL_ERROR; } - extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData)); + extraPtr = (ApplyExtraData *)TclStackAlloc(interp, sizeof(ApplyExtraData)); memset(&extraPtr->cmd, 0, sizeof(Command)); procPtr->cmdPtr = &extraPtr->cmd; extraPtr->cmd.nsPtr = (Namespace *) nsPtr; @@ -2731,7 +2706,7 @@ ApplyNR2( Tcl_Interp *interp, int result) { - ApplyExtraData *extraPtr = data[0]; + ApplyExtraData *extraPtr = (ApplyExtraData *)data[0]; TclStackFree(interp, extraPtr); return result; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 93efecd..7f21d83 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -54,6 +54,7 @@ #undef TclBN_mp_tc_and #undef TclBN_mp_tc_or #undef TclBN_mp_tc_xor +#undef TclObjInterpProc #define TclBN_mp_tc_and TclBN_mp_and #define TclBN_mp_tc_or TclBN_mp_or #define TclBN_mp_tc_xor TclBN_mp_xor @@ -225,7 +226,7 @@ void *TclWinGetTclInstance() int TclpGetPid(Tcl_Pid pid) { - return (int) (size_t) pid; + return (int)(size_t)pid; } static void @@ -1665,7 +1666,13 @@ const TclStubs tclStubs = { 0, /* 672 */ 0, /* 673 */ 0, /* 674 */ - TclUnusedStubEntry, /* 675 */ + 0, /* 675 */ + 0, /* 676 */ + 0, /* 677 */ + 0, /* 678 */ + 0, /* 679 */ + 0, /* 680 */ + TclUnusedStubEntry, /* 681 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 0eab000d0ed26d3e5a80a5a4a76bc58c8c5d3634 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Sep 2022 15:42:32 +0000 Subject: Do the "#undef TclObjInterpProc" slightly earlier --- generic/tclProc.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 97a32a6..bf24c83 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -114,7 +114,7 @@ const Tcl_ObjType tclLambdaType = { *---------------------------------------------------------------------- */ - /* ARGSUSED */ +#undef TclObjInterpProc int Tcl_ProcObjCmd( ClientData dummy, /* Not used. */ @@ -1633,7 +1633,6 @@ TclPushProcCallFrame( *---------------------------------------------------------------------- */ -#undef TclObjInterpProc int TclObjInterpProc( ClientData clientData, /* Record describing procedure to be -- cgit v0.12 From 33195f9318b46186be7801d1a05bfee3f03c529b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 23 Sep 2022 09:56:25 +0000 Subject: Testcase stringObj-16.6 cannot run with -DTCL_NO_DEPRECATED=1. Merge 8.6 --- tests/stringObj.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/stringObj.test b/tests/stringObj.test index 14ba79d..0c65cdc 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -497,7 +497,7 @@ test stringObj-16.5 {Tcl_GetRange: fist = last = -1} {testobj deprecated} { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde -test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj { +test stringObj-16.6 {Tcl_GetRange: old anomaly} {testobj deprecated} { # Older implementations could return "cde" teststringobj set 1 abcde teststringobj range 1 2 0 -- cgit v0.12 From 5257269714cc2a8444e2f5602e8232b1f9f3c594 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 Sep 2022 12:18:46 +0000 Subject: Add some more unused stub entries --- generic/tcl.decls | 6 +++--- generic/tclDecls.h | 27 ++++++++++++++++++++++++--- generic/tclStubInit.c | 9 ++++++++- 3 files changed, 35 insertions(+), 7 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index e07ae5e..9716b32 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -5,8 +5,8 @@ # This file is used to generate the tclDecls.h, tclPlatDecls.h # and tclStubInit.c files. # -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2001, 2002 Kevin B. Kenny. All rights reserved. # Copyright (c) 2007 Daniel A. Steffen # # See the file "license.terms" for information on usage and redistribution @@ -2111,7 +2111,7 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 675 { +declare 682 { void TclUnusedStubEntry(void) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 246e2c9..6d7a8a3 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3507,9 +3507,16 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 672 is reserved */ /* Slot 673 is reserved */ /* Slot 674 is reserved */ +/* Slot 675 is reserved */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ +/* Slot 680 is reserved */ +/* Slot 681 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 675 */ +/* 682 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -4222,7 +4229,14 @@ typedef struct TclStubs { VOID *reserved672; VOID *reserved673; VOID *reserved674; - void (*tclUnusedStubEntry) (void); /* 675 */ + VOID *reserved675; + VOID *reserved676; + VOID *reserved677; + VOID *reserved678; + VOID *reserved679; + VOID *reserved680; + VOID *reserved681; + void (*tclUnusedStubEntry) (void); /* 682 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6670,9 +6684,16 @@ extern TclStubs *tclStubsPtr; /* Slot 672 is reserved */ /* Slot 673 is reserved */ /* Slot 674 is reserved */ +/* Slot 675 is reserved */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ +/* Slot 680 is reserved */ +/* Slot 681 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 675 */ + (tclStubsPtr->tclUnusedStubEntry) /* 682 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0d2a3c2..f1cf6a2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1474,7 +1474,14 @@ TclStubs tclStubs = { NULL, /* 672 */ NULL, /* 673 */ NULL, /* 674 */ - TclUnusedStubEntry, /* 675 */ + NULL, /* 675 */ + NULL, /* 676 */ + NULL, /* 677 */ + NULL, /* 678 */ + NULL, /* 679 */ + NULL, /* 680 */ + NULL, /* 681 */ + TclUnusedStubEntry, /* 682 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From a5fc6492213184ed373920e0afb5dd2f569c8f84 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 Sep 2022 12:19:22 +0000 Subject: Update tzdata to 2022d --- library/tzdata/Asia/Gaza | 310 +++++++++++++++++++-------------------- library/tzdata/Asia/Hebron | 310 +++++++++++++++++++-------------------- library/tzdata/Europe/Uzhgorod | 255 +------------------------------- library/tzdata/Europe/Zaporozhye | 254 +------------------------------- 4 files changed, 316 insertions(+), 813 deletions(-) diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza index e819d87..1ceb680 100644 --- a/library/tzdata/Asia/Gaza +++ b/library/tzdata/Asia/Gaza @@ -126,159 +126,159 @@ set TZData(:Asia/Gaza) { {1616796000 10800 1 EEST} {1635458400 7200 0 EET} {1648332000 10800 1 EEST} - {1666908000 7200 0 EET} - {1679781600 10800 1 EEST} - {1698357600 7200 0 EET} - {1711836000 10800 1 EEST} - {1729807200 7200 0 EET} - {1743285600 10800 1 EEST} - {1761256800 7200 0 EET} - {1774735200 10800 1 EEST} - {1792706400 7200 0 EET} - {1806184800 10800 1 EEST} - {1824760800 7200 0 EET} - {1837634400 10800 1 EEST} - {1856210400 7200 0 EET} - {1869084000 10800 1 EEST} - {1887660000 7200 0 EET} - {1901138400 10800 1 EEST} - {1919109600 7200 0 EET} - {1932588000 10800 1 EEST} - {1950559200 7200 0 EET} - {1964037600 10800 1 EEST} - {1982613600 7200 0 EET} - {1995487200 10800 1 EEST} - {2014063200 7200 0 EET} - {2026936800 10800 1 EEST} - {2045512800 7200 0 EET} - {2058386400 10800 1 EEST} - {2076962400 7200 0 EET} - {2090440800 10800 1 EEST} - {2108412000 7200 0 EET} - {2121890400 10800 1 EEST} - {2139861600 7200 0 EET} - {2153340000 10800 1 EEST} - {2171916000 7200 0 EET} - {2184789600 10800 1 EEST} - {2203365600 7200 0 EET} - {2216239200 10800 1 EEST} - {2234815200 7200 0 EET} - {2248293600 10800 1 EEST} - {2266264800 7200 0 EET} - {2279743200 10800 1 EEST} - {2297714400 7200 0 EET} - {2311192800 10800 1 EEST} - {2329164000 7200 0 EET} - {2342642400 10800 1 EEST} - {2361218400 7200 0 EET} - {2374092000 10800 1 EEST} - {2392668000 7200 0 EET} - {2405541600 10800 1 EEST} - {2424117600 7200 0 EET} - {2437596000 10800 1 EEST} - {2455567200 7200 0 EET} - {2469045600 10800 1 EEST} - {2487016800 7200 0 EET} - {2500495200 10800 1 EEST} - {2519071200 7200 0 EET} - {2531944800 10800 1 EEST} - {2550520800 7200 0 EET} - {2563394400 10800 1 EEST} - {2581970400 7200 0 EET} - {2595448800 10800 1 EEST} - {2613420000 7200 0 EET} - {2626898400 10800 1 EEST} - {2644869600 7200 0 EET} - {2658348000 10800 1 EEST} - {2676319200 7200 0 EET} - {2689797600 10800 1 EEST} - {2708373600 7200 0 EET} - {2721247200 10800 1 EEST} - {2739823200 7200 0 EET} - {2752696800 10800 1 EEST} - {2771272800 7200 0 EET} - {2784751200 10800 1 EEST} - {2802722400 7200 0 EET} - {2816200800 10800 1 EEST} - {2834172000 7200 0 EET} - {2847650400 10800 1 EEST} - {2866226400 7200 0 EET} - {2879100000 10800 1 EEST} - {2897676000 7200 0 EET} - {2910549600 10800 1 EEST} - {2929125600 7200 0 EET} - {2941999200 10800 1 EEST} - {2960575200 7200 0 EET} - {2974053600 10800 1 EEST} - {2992024800 7200 0 EET} - {3005503200 10800 1 EEST} - {3023474400 7200 0 EET} - {3036952800 10800 1 EEST} - {3055528800 7200 0 EET} - {3068402400 10800 1 EEST} - {3086978400 7200 0 EET} - {3099852000 10800 1 EEST} - {3118428000 7200 0 EET} - {3131906400 10800 1 EEST} - {3149877600 7200 0 EET} - {3163356000 10800 1 EEST} - {3181327200 7200 0 EET} - {3194805600 10800 1 EEST} - {3212776800 7200 0 EET} - {3226255200 10800 1 EEST} - {3244831200 7200 0 EET} - {3257704800 10800 1 EEST} - {3276280800 7200 0 EET} - {3289154400 10800 1 EEST} - {3307730400 7200 0 EET} - {3321208800 10800 1 EEST} - {3339180000 7200 0 EET} - {3352658400 10800 1 EEST} - {3370629600 7200 0 EET} - {3384108000 10800 1 EEST} - {3402684000 7200 0 EET} - {3415557600 10800 1 EEST} - {3434133600 7200 0 EET} - {3447007200 10800 1 EEST} - {3465583200 7200 0 EET} - {3479061600 10800 1 EEST} - {3497032800 7200 0 EET} - {3510511200 10800 1 EEST} - {3528482400 7200 0 EET} - {3541960800 10800 1 EEST} - {3559932000 7200 0 EET} - {3573410400 10800 1 EEST} - {3591986400 7200 0 EET} - {3604860000 10800 1 EEST} - {3623436000 7200 0 EET} - {3636309600 10800 1 EEST} - {3654885600 7200 0 EET} - {3668364000 10800 1 EEST} - {3686335200 7200 0 EET} - {3699813600 10800 1 EEST} - {3717784800 7200 0 EET} - {3731263200 10800 1 EEST} - {3749839200 7200 0 EET} - {3762712800 10800 1 EEST} - {3781288800 7200 0 EET} - {3794162400 10800 1 EEST} - {3812738400 7200 0 EET} - {3825612000 10800 1 EEST} - {3844188000 7200 0 EET} - {3857666400 10800 1 EEST} - {3875637600 7200 0 EET} - {3889116000 10800 1 EEST} - {3907087200 7200 0 EET} - {3920565600 10800 1 EEST} - {3939141600 7200 0 EET} - {3952015200 10800 1 EEST} - {3970591200 7200 0 EET} - {3983464800 10800 1 EEST} - {4002040800 7200 0 EET} - {4015519200 10800 1 EEST} - {4033490400 7200 0 EET} - {4046968800 10800 1 EEST} - {4064940000 7200 0 EET} - {4078418400 10800 1 EEST} - {4096389600 7200 0 EET} + {1666998000 7200 0 EET} + {1679702400 10800 1 EEST} + {1698447600 7200 0 EET} + {1711756800 10800 1 EEST} + {1729897200 7200 0 EET} + {1743206400 10800 1 EEST} + {1761346800 7200 0 EET} + {1774656000 10800 1 EEST} + {1792796400 7200 0 EET} + {1806105600 10800 1 EEST} + {1824850800 7200 0 EET} + {1837555200 10800 1 EEST} + {1856300400 7200 0 EET} + {1869004800 10800 1 EEST} + {1887750000 7200 0 EET} + {1901059200 10800 1 EEST} + {1919199600 7200 0 EET} + {1932508800 10800 1 EEST} + {1950649200 7200 0 EET} + {1963958400 10800 1 EEST} + {1982703600 7200 0 EET} + {1995408000 10800 1 EEST} + {2014153200 7200 0 EET} + {2026857600 10800 1 EEST} + {2045602800 7200 0 EET} + {2058307200 10800 1 EEST} + {2077052400 7200 0 EET} + {2090361600 10800 1 EEST} + {2108502000 7200 0 EET} + {2121811200 10800 1 EEST} + {2139951600 7200 0 EET} + {2153260800 10800 1 EEST} + {2172006000 7200 0 EET} + {2184710400 10800 1 EEST} + {2203455600 7200 0 EET} + {2216160000 10800 1 EEST} + {2234905200 7200 0 EET} + {2248214400 10800 1 EEST} + {2266354800 7200 0 EET} + {2279664000 10800 1 EEST} + {2297804400 7200 0 EET} + {2311113600 10800 1 EEST} + {2329254000 7200 0 EET} + {2342563200 10800 1 EEST} + {2361308400 7200 0 EET} + {2374012800 10800 1 EEST} + {2392758000 7200 0 EET} + {2405462400 10800 1 EEST} + {2424207600 7200 0 EET} + {2437516800 10800 1 EEST} + {2455657200 7200 0 EET} + {2468966400 10800 1 EEST} + {2487106800 7200 0 EET} + {2500416000 10800 1 EEST} + {2519161200 7200 0 EET} + {2531865600 10800 1 EEST} + {2550610800 7200 0 EET} + {2563315200 10800 1 EEST} + {2582060400 7200 0 EET} + {2595369600 10800 1 EEST} + {2613510000 7200 0 EET} + {2626819200 10800 1 EEST} + {2644959600 7200 0 EET} + {2658268800 10800 1 EEST} + {2676409200 7200 0 EET} + {2689718400 10800 1 EEST} + {2708463600 7200 0 EET} + {2721168000 10800 1 EEST} + {2739913200 7200 0 EET} + {2752617600 10800 1 EEST} + {2771362800 7200 0 EET} + {2784672000 10800 1 EEST} + {2802812400 7200 0 EET} + {2816121600 10800 1 EEST} + {2834262000 7200 0 EET} + {2847571200 10800 1 EEST} + {2866316400 7200 0 EET} + {2879020800 10800 1 EEST} + {2897766000 7200 0 EET} + {2910470400 10800 1 EEST} + {2929215600 7200 0 EET} + {2941920000 10800 1 EEST} + {2960665200 7200 0 EET} + {2973974400 10800 1 EEST} + {2992114800 7200 0 EET} + {3005424000 10800 1 EEST} + {3023564400 7200 0 EET} + {3036873600 10800 1 EEST} + {3055618800 7200 0 EET} + {3068323200 10800 1 EEST} + {3087068400 7200 0 EET} + {3099772800 10800 1 EEST} + {3118518000 7200 0 EET} + {3131827200 10800 1 EEST} + {3149967600 7200 0 EET} + {3163276800 10800 1 EEST} + {3181417200 7200 0 EET} + {3194726400 10800 1 EEST} + {3212866800 7200 0 EET} + {3226176000 10800 1 EEST} + {3244921200 7200 0 EET} + {3257625600 10800 1 EEST} + {3276370800 7200 0 EET} + {3289075200 10800 1 EEST} + {3307820400 7200 0 EET} + {3321129600 10800 1 EEST} + {3339270000 7200 0 EET} + {3352579200 10800 1 EEST} + {3370719600 7200 0 EET} + {3384028800 10800 1 EEST} + {3402774000 7200 0 EET} + {3415478400 10800 1 EEST} + {3434223600 7200 0 EET} + {3446928000 10800 1 EEST} + {3465673200 7200 0 EET} + {3478982400 10800 1 EEST} + {3497122800 7200 0 EET} + {3510432000 10800 1 EEST} + {3528572400 7200 0 EET} + {3541881600 10800 1 EEST} + {3560022000 7200 0 EET} + {3573331200 10800 1 EEST} + {3592076400 7200 0 EET} + {3604780800 10800 1 EEST} + {3623526000 7200 0 EET} + {3636230400 10800 1 EEST} + {3654975600 7200 0 EET} + {3668284800 10800 1 EEST} + {3686425200 7200 0 EET} + {3699734400 10800 1 EEST} + {3717874800 7200 0 EET} + {3731184000 10800 1 EEST} + {3749929200 7200 0 EET} + {3762633600 10800 1 EEST} + {3781378800 7200 0 EET} + {3794083200 10800 1 EEST} + {3812828400 7200 0 EET} + {3825532800 10800 1 EEST} + {3844278000 7200 0 EET} + {3857587200 10800 1 EEST} + {3875727600 7200 0 EET} + {3889036800 10800 1 EEST} + {3907177200 7200 0 EET} + {3920486400 10800 1 EEST} + {3939231600 7200 0 EET} + {3951936000 10800 1 EEST} + {3970681200 7200 0 EET} + {3983385600 10800 1 EEST} + {4002130800 7200 0 EET} + {4015440000 10800 1 EEST} + {4033580400 7200 0 EET} + {4046889600 10800 1 EEST} + {4065030000 7200 0 EET} + {4078339200 10800 1 EEST} + {4096479600 7200 0 EET} } diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron index b484c6f..b92db8d 100644 --- a/library/tzdata/Asia/Hebron +++ b/library/tzdata/Asia/Hebron @@ -125,159 +125,159 @@ set TZData(:Asia/Hebron) { {1616796000 10800 1 EEST} {1635458400 7200 0 EET} {1648332000 10800 1 EEST} - {1666908000 7200 0 EET} - {1679781600 10800 1 EEST} - {1698357600 7200 0 EET} - {1711836000 10800 1 EEST} - {1729807200 7200 0 EET} - {1743285600 10800 1 EEST} - {1761256800 7200 0 EET} - {1774735200 10800 1 EEST} - {1792706400 7200 0 EET} - {1806184800 10800 1 EEST} - {1824760800 7200 0 EET} - {1837634400 10800 1 EEST} - {1856210400 7200 0 EET} - {1869084000 10800 1 EEST} - {1887660000 7200 0 EET} - {1901138400 10800 1 EEST} - {1919109600 7200 0 EET} - {1932588000 10800 1 EEST} - {1950559200 7200 0 EET} - {1964037600 10800 1 EEST} - {1982613600 7200 0 EET} - {1995487200 10800 1 EEST} - {2014063200 7200 0 EET} - {2026936800 10800 1 EEST} - {2045512800 7200 0 EET} - {2058386400 10800 1 EEST} - {2076962400 7200 0 EET} - {2090440800 10800 1 EEST} - {2108412000 7200 0 EET} - {2121890400 10800 1 EEST} - {2139861600 7200 0 EET} - {2153340000 10800 1 EEST} - {2171916000 7200 0 EET} - {2184789600 10800 1 EEST} - {2203365600 7200 0 EET} - {2216239200 10800 1 EEST} - {2234815200 7200 0 EET} - {2248293600 10800 1 EEST} - {2266264800 7200 0 EET} - {2279743200 10800 1 EEST} - {2297714400 7200 0 EET} - {2311192800 10800 1 EEST} - {2329164000 7200 0 EET} - {2342642400 10800 1 EEST} - {2361218400 7200 0 EET} - {2374092000 10800 1 EEST} - {2392668000 7200 0 EET} - {2405541600 10800 1 EEST} - {2424117600 7200 0 EET} - {2437596000 10800 1 EEST} - {2455567200 7200 0 EET} - {2469045600 10800 1 EEST} - {2487016800 7200 0 EET} - {2500495200 10800 1 EEST} - {2519071200 7200 0 EET} - {2531944800 10800 1 EEST} - {2550520800 7200 0 EET} - {2563394400 10800 1 EEST} - {2581970400 7200 0 EET} - {2595448800 10800 1 EEST} - {2613420000 7200 0 EET} - {2626898400 10800 1 EEST} - {2644869600 7200 0 EET} - {2658348000 10800 1 EEST} - {2676319200 7200 0 EET} - {2689797600 10800 1 EEST} - {2708373600 7200 0 EET} - {2721247200 10800 1 EEST} - {2739823200 7200 0 EET} - {2752696800 10800 1 EEST} - {2771272800 7200 0 EET} - {2784751200 10800 1 EEST} - {2802722400 7200 0 EET} - {2816200800 10800 1 EEST} - {2834172000 7200 0 EET} - {2847650400 10800 1 EEST} - {2866226400 7200 0 EET} - {2879100000 10800 1 EEST} - {2897676000 7200 0 EET} - {2910549600 10800 1 EEST} - {2929125600 7200 0 EET} - {2941999200 10800 1 EEST} - {2960575200 7200 0 EET} - {2974053600 10800 1 EEST} - {2992024800 7200 0 EET} - {3005503200 10800 1 EEST} - {3023474400 7200 0 EET} - {3036952800 10800 1 EEST} - {3055528800 7200 0 EET} - {3068402400 10800 1 EEST} - {3086978400 7200 0 EET} - {3099852000 10800 1 EEST} - {3118428000 7200 0 EET} - {3131906400 10800 1 EEST} - {3149877600 7200 0 EET} - {3163356000 10800 1 EEST} - {3181327200 7200 0 EET} - {3194805600 10800 1 EEST} - {3212776800 7200 0 EET} - {3226255200 10800 1 EEST} - {3244831200 7200 0 EET} - {3257704800 10800 1 EEST} - {3276280800 7200 0 EET} - {3289154400 10800 1 EEST} - {3307730400 7200 0 EET} - {3321208800 10800 1 EEST} - {3339180000 7200 0 EET} - {3352658400 10800 1 EEST} - {3370629600 7200 0 EET} - {3384108000 10800 1 EEST} - {3402684000 7200 0 EET} - {3415557600 10800 1 EEST} - {3434133600 7200 0 EET} - {3447007200 10800 1 EEST} - {3465583200 7200 0 EET} - {3479061600 10800 1 EEST} - {3497032800 7200 0 EET} - {3510511200 10800 1 EEST} - {3528482400 7200 0 EET} - {3541960800 10800 1 EEST} - {3559932000 7200 0 EET} - {3573410400 10800 1 EEST} - {3591986400 7200 0 EET} - {3604860000 10800 1 EEST} - {3623436000 7200 0 EET} - {3636309600 10800 1 EEST} - {3654885600 7200 0 EET} - {3668364000 10800 1 EEST} - {3686335200 7200 0 EET} - {3699813600 10800 1 EEST} - {3717784800 7200 0 EET} - {3731263200 10800 1 EEST} - {3749839200 7200 0 EET} - {3762712800 10800 1 EEST} - {3781288800 7200 0 EET} - {3794162400 10800 1 EEST} - {3812738400 7200 0 EET} - {3825612000 10800 1 EEST} - {3844188000 7200 0 EET} - {3857666400 10800 1 EEST} - {3875637600 7200 0 EET} - {3889116000 10800 1 EEST} - {3907087200 7200 0 EET} - {3920565600 10800 1 EEST} - {3939141600 7200 0 EET} - {3952015200 10800 1 EEST} - {3970591200 7200 0 EET} - {3983464800 10800 1 EEST} - {4002040800 7200 0 EET} - {4015519200 10800 1 EEST} - {4033490400 7200 0 EET} - {4046968800 10800 1 EEST} - {4064940000 7200 0 EET} - {4078418400 10800 1 EEST} - {4096389600 7200 0 EET} + {1666998000 7200 0 EET} + {1679702400 10800 1 EEST} + {1698447600 7200 0 EET} + {1711756800 10800 1 EEST} + {1729897200 7200 0 EET} + {1743206400 10800 1 EEST} + {1761346800 7200 0 EET} + {1774656000 10800 1 EEST} + {1792796400 7200 0 EET} + {1806105600 10800 1 EEST} + {1824850800 7200 0 EET} + {1837555200 10800 1 EEST} + {1856300400 7200 0 EET} + {1869004800 10800 1 EEST} + {1887750000 7200 0 EET} + {1901059200 10800 1 EEST} + {1919199600 7200 0 EET} + {1932508800 10800 1 EEST} + {1950649200 7200 0 EET} + {1963958400 10800 1 EEST} + {1982703600 7200 0 EET} + {1995408000 10800 1 EEST} + {2014153200 7200 0 EET} + {2026857600 10800 1 EEST} + {2045602800 7200 0 EET} + {2058307200 10800 1 EEST} + {2077052400 7200 0 EET} + {2090361600 10800 1 EEST} + {2108502000 7200 0 EET} + {2121811200 10800 1 EEST} + {2139951600 7200 0 EET} + {2153260800 10800 1 EEST} + {2172006000 7200 0 EET} + {2184710400 10800 1 EEST} + {2203455600 7200 0 EET} + {2216160000 10800 1 EEST} + {2234905200 7200 0 EET} + {2248214400 10800 1 EEST} + {2266354800 7200 0 EET} + {2279664000 10800 1 EEST} + {2297804400 7200 0 EET} + {2311113600 10800 1 EEST} + {2329254000 7200 0 EET} + {2342563200 10800 1 EEST} + {2361308400 7200 0 EET} + {2374012800 10800 1 EEST} + {2392758000 7200 0 EET} + {2405462400 10800 1 EEST} + {2424207600 7200 0 EET} + {2437516800 10800 1 EEST} + {2455657200 7200 0 EET} + {2468966400 10800 1 EEST} + {2487106800 7200 0 EET} + {2500416000 10800 1 EEST} + {2519161200 7200 0 EET} + {2531865600 10800 1 EEST} + {2550610800 7200 0 EET} + {2563315200 10800 1 EEST} + {2582060400 7200 0 EET} + {2595369600 10800 1 EEST} + {2613510000 7200 0 EET} + {2626819200 10800 1 EEST} + {2644959600 7200 0 EET} + {2658268800 10800 1 EEST} + {2676409200 7200 0 EET} + {2689718400 10800 1 EEST} + {2708463600 7200 0 EET} + {2721168000 10800 1 EEST} + {2739913200 7200 0 EET} + {2752617600 10800 1 EEST} + {2771362800 7200 0 EET} + {2784672000 10800 1 EEST} + {2802812400 7200 0 EET} + {2816121600 10800 1 EEST} + {2834262000 7200 0 EET} + {2847571200 10800 1 EEST} + {2866316400 7200 0 EET} + {2879020800 10800 1 EEST} + {2897766000 7200 0 EET} + {2910470400 10800 1 EEST} + {2929215600 7200 0 EET} + {2941920000 10800 1 EEST} + {2960665200 7200 0 EET} + {2973974400 10800 1 EEST} + {2992114800 7200 0 EET} + {3005424000 10800 1 EEST} + {3023564400 7200 0 EET} + {3036873600 10800 1 EEST} + {3055618800 7200 0 EET} + {3068323200 10800 1 EEST} + {3087068400 7200 0 EET} + {3099772800 10800 1 EEST} + {3118518000 7200 0 EET} + {3131827200 10800 1 EEST} + {3149967600 7200 0 EET} + {3163276800 10800 1 EEST} + {3181417200 7200 0 EET} + {3194726400 10800 1 EEST} + {3212866800 7200 0 EET} + {3226176000 10800 1 EEST} + {3244921200 7200 0 EET} + {3257625600 10800 1 EEST} + {3276370800 7200 0 EET} + {3289075200 10800 1 EEST} + {3307820400 7200 0 EET} + {3321129600 10800 1 EEST} + {3339270000 7200 0 EET} + {3352579200 10800 1 EEST} + {3370719600 7200 0 EET} + {3384028800 10800 1 EEST} + {3402774000 7200 0 EET} + {3415478400 10800 1 EEST} + {3434223600 7200 0 EET} + {3446928000 10800 1 EEST} + {3465673200 7200 0 EET} + {3478982400 10800 1 EEST} + {3497122800 7200 0 EET} + {3510432000 10800 1 EEST} + {3528572400 7200 0 EET} + {3541881600 10800 1 EEST} + {3560022000 7200 0 EET} + {3573331200 10800 1 EEST} + {3592076400 7200 0 EET} + {3604780800 10800 1 EEST} + {3623526000 7200 0 EET} + {3636230400 10800 1 EEST} + {3654975600 7200 0 EET} + {3668284800 10800 1 EEST} + {3686425200 7200 0 EET} + {3699734400 10800 1 EEST} + {3717874800 7200 0 EET} + {3731184000 10800 1 EEST} + {3749929200 7200 0 EET} + {3762633600 10800 1 EEST} + {3781378800 7200 0 EET} + {3794083200 10800 1 EEST} + {3812828400 7200 0 EET} + {3825532800 10800 1 EEST} + {3844278000 7200 0 EET} + {3857587200 10800 1 EEST} + {3875727600 7200 0 EET} + {3889036800 10800 1 EEST} + {3907177200 7200 0 EET} + {3920486400 10800 1 EEST} + {3939231600 7200 0 EET} + {3951936000 10800 1 EEST} + {3970681200 7200 0 EET} + {3983385600 10800 1 EEST} + {4002130800 7200 0 EET} + {4015440000 10800 1 EEST} + {4033580400 7200 0 EET} + {4046889600 10800 1 EEST} + {4065030000 7200 0 EET} + {4078339200 10800 1 EEST} + {4096479600 7200 0 EET} } diff --git a/library/tzdata/Europe/Uzhgorod b/library/tzdata/Europe/Uzhgorod index 0a058db..2a0f450 100644 --- a/library/tzdata/Europe/Uzhgorod +++ b/library/tzdata/Europe/Uzhgorod @@ -1,254 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Uzhgorod) { - {-9223372036854775808 5352 0 LMT} - {-2500939752 3600 0 CET} - {-946774800 3600 0 CET} - {-938905200 7200 1 CEST} - {-857257200 3600 0 CET} - {-844556400 7200 1 CEST} - {-828226800 3600 0 CET} - {-812502000 7200 1 CEST} - {-796870800 7200 1 CEST} - {-794714400 3600 0 CET} - {-773456400 10800 0 MSD} - {354920400 14400 1 MSD} - {370728000 10800 0 MSK} - {386456400 14400 1 MSD} - {402264000 10800 0 MSK} - {417992400 14400 1 MSD} - {433800000 10800 0 MSK} - {449614800 14400 1 MSD} - {465346800 10800 0 MSK} - {481071600 14400 1 MSD} - {496796400 10800 0 MSK} - {512521200 14400 1 MSD} - {528246000 10800 0 MSK} - {543970800 14400 1 MSD} - {559695600 10800 0 MSK} - {575420400 14400 1 MSD} - {591145200 10800 0 MSK} - {606870000 14400 1 MSD} - {622594800 10800 0 MSK} - {631141200 10800 0 MSK} - {646786800 3600 0 CET} - {670384800 7200 0 EET} - {701042400 7200 0 EET} - {701827200 10800 1 EEST} - {717552000 7200 0 EET} - {733276800 10800 1 EEST} - {749001600 7200 0 EET} - {764726400 10800 1 EEST} - {780451200 7200 0 EET} - {796176000 10800 1 EEST} - {811900800 7200 0 EET} - {828230400 10800 1 EEST} - {831938400 10800 0 EEST} - {846378000 7200 0 EET} - {859683600 10800 1 EEST} - {877827600 7200 0 EET} - {891133200 10800 1 EEST} - {909277200 7200 0 EET} - {922582800 10800 1 EEST} - {941331600 7200 0 EET} - {954032400 10800 1 EEST} - {972781200 7200 0 EET} - {985482000 10800 1 EEST} - {1004230800 7200 0 EET} - {1017536400 10800 1 EEST} - {1035680400 7200 0 EET} - {1048986000 10800 1 EEST} - {1067130000 7200 0 EET} - {1080435600 10800 1 EEST} - {1099184400 7200 0 EET} - {1111885200 10800 1 EEST} - {1130634000 7200 0 EET} - {1143334800 10800 1 EEST} - {1162083600 7200 0 EET} - {1174784400 10800 1 EEST} - {1193533200 7200 0 EET} - {1206838800 10800 1 EEST} - {1224982800 7200 0 EET} - {1238288400 10800 1 EEST} - {1256432400 7200 0 EET} - {1269738000 10800 1 EEST} - {1288486800 7200 0 EET} - {1301187600 10800 1 EEST} - {1319936400 7200 0 EET} - {1332637200 10800 1 EEST} - {1351386000 7200 0 EET} - {1364691600 10800 1 EEST} - {1382835600 7200 0 EET} - {1396141200 10800 1 EEST} - {1414285200 7200 0 EET} - {1427590800 10800 1 EEST} - {1445734800 7200 0 EET} - {1459040400 10800 1 EEST} - {1477789200 7200 0 EET} - {1490490000 10800 1 EEST} - {1509238800 7200 0 EET} - {1521939600 10800 1 EEST} - {1540688400 7200 0 EET} - {1553994000 10800 1 EEST} - {1572138000 7200 0 EET} - {1585443600 10800 1 EEST} - {1603587600 7200 0 EET} - {1616893200 10800 1 EEST} - {1635642000 7200 0 EET} - {1648342800 10800 1 EEST} - {1667091600 7200 0 EET} - {1679792400 10800 1 EEST} - {1698541200 7200 0 EET} - {1711846800 10800 1 EEST} - {1729990800 7200 0 EET} - {1743296400 10800 1 EEST} - {1761440400 7200 0 EET} - {1774746000 10800 1 EEST} - {1792890000 7200 0 EET} - {1806195600 10800 1 EEST} - {1824944400 7200 0 EET} - {1837645200 10800 1 EEST} - {1856394000 7200 0 EET} - {1869094800 10800 1 EEST} - {1887843600 7200 0 EET} - {1901149200 10800 1 EEST} - {1919293200 7200 0 EET} - {1932598800 10800 1 EEST} - {1950742800 7200 0 EET} - {1964048400 10800 1 EEST} - {1982797200 7200 0 EET} - {1995498000 10800 1 EEST} - {2014246800 7200 0 EET} - {2026947600 10800 1 EEST} - {2045696400 7200 0 EET} - {2058397200 10800 1 EEST} - {2077146000 7200 0 EET} - {2090451600 10800 1 EEST} - {2108595600 7200 0 EET} - {2121901200 10800 1 EEST} - {2140045200 7200 0 EET} - {2153350800 10800 1 EEST} - {2172099600 7200 0 EET} - {2184800400 10800 1 EEST} - {2203549200 7200 0 EET} - {2216250000 10800 1 EEST} - {2234998800 7200 0 EET} - {2248304400 10800 1 EEST} - {2266448400 7200 0 EET} - {2279754000 10800 1 EEST} - {2297898000 7200 0 EET} - {2311203600 10800 1 EEST} - {2329347600 7200 0 EET} - {2342653200 10800 1 EEST} - {2361402000 7200 0 EET} - {2374102800 10800 1 EEST} - {2392851600 7200 0 EET} - {2405552400 10800 1 EEST} - {2424301200 7200 0 EET} - {2437606800 10800 1 EEST} - {2455750800 7200 0 EET} - {2469056400 10800 1 EEST} - {2487200400 7200 0 EET} - {2500506000 10800 1 EEST} - {2519254800 7200 0 EET} - {2531955600 10800 1 EEST} - {2550704400 7200 0 EET} - {2563405200 10800 1 EEST} - {2582154000 7200 0 EET} - {2595459600 10800 1 EEST} - {2613603600 7200 0 EET} - {2626909200 10800 1 EEST} - {2645053200 7200 0 EET} - {2658358800 10800 1 EEST} - {2676502800 7200 0 EET} - {2689808400 10800 1 EEST} - {2708557200 7200 0 EET} - {2721258000 10800 1 EEST} - {2740006800 7200 0 EET} - {2752707600 10800 1 EEST} - {2771456400 7200 0 EET} - {2784762000 10800 1 EEST} - {2802906000 7200 0 EET} - {2816211600 10800 1 EEST} - {2834355600 7200 0 EET} - {2847661200 10800 1 EEST} - {2866410000 7200 0 EET} - {2879110800 10800 1 EEST} - {2897859600 7200 0 EET} - {2910560400 10800 1 EEST} - {2929309200 7200 0 EET} - {2942010000 10800 1 EEST} - {2960758800 7200 0 EET} - {2974064400 10800 1 EEST} - {2992208400 7200 0 EET} - {3005514000 10800 1 EEST} - {3023658000 7200 0 EET} - {3036963600 10800 1 EEST} - {3055712400 7200 0 EET} - {3068413200 10800 1 EEST} - {3087162000 7200 0 EET} - {3099862800 10800 1 EEST} - {3118611600 7200 0 EET} - {3131917200 10800 1 EEST} - {3150061200 7200 0 EET} - {3163366800 10800 1 EEST} - {3181510800 7200 0 EET} - {3194816400 10800 1 EEST} - {3212960400 7200 0 EET} - {3226266000 10800 1 EEST} - {3245014800 7200 0 EET} - {3257715600 10800 1 EEST} - {3276464400 7200 0 EET} - {3289165200 10800 1 EEST} - {3307914000 7200 0 EET} - {3321219600 10800 1 EEST} - {3339363600 7200 0 EET} - {3352669200 10800 1 EEST} - {3370813200 7200 0 EET} - {3384118800 10800 1 EEST} - {3402867600 7200 0 EET} - {3415568400 10800 1 EEST} - {3434317200 7200 0 EET} - {3447018000 10800 1 EEST} - {3465766800 7200 0 EET} - {3479072400 10800 1 EEST} - {3497216400 7200 0 EET} - {3510522000 10800 1 EEST} - {3528666000 7200 0 EET} - {3541971600 10800 1 EEST} - {3560115600 7200 0 EET} - {3573421200 10800 1 EEST} - {3592170000 7200 0 EET} - {3604870800 10800 1 EEST} - {3623619600 7200 0 EET} - {3636320400 10800 1 EEST} - {3655069200 7200 0 EET} - {3668374800 10800 1 EEST} - {3686518800 7200 0 EET} - {3699824400 10800 1 EEST} - {3717968400 7200 0 EET} - {3731274000 10800 1 EEST} - {3750022800 7200 0 EET} - {3762723600 10800 1 EEST} - {3781472400 7200 0 EET} - {3794173200 10800 1 EEST} - {3812922000 7200 0 EET} - {3825622800 10800 1 EEST} - {3844371600 7200 0 EET} - {3857677200 10800 1 EEST} - {3875821200 7200 0 EET} - {3889126800 10800 1 EEST} - {3907270800 7200 0 EET} - {3920576400 10800 1 EEST} - {3939325200 7200 0 EET} - {3952026000 10800 1 EEST} - {3970774800 7200 0 EET} - {3983475600 10800 1 EEST} - {4002224400 7200 0 EET} - {4015530000 10800 1 EEST} - {4033674000 7200 0 EET} - {4046979600 10800 1 EEST} - {4065123600 7200 0 EET} - {4078429200 10800 1 EEST} - {4096573200 7200 0 EET} +if {![info exists TZData(Europe/Kyiv)]} { + LoadTimeZoneFile Europe/Kyiv } +set TZData(:Europe/Uzhgorod) $TZData(:Europe/Kyiv) diff --git a/library/tzdata/Europe/Zaporozhye b/library/tzdata/Europe/Zaporozhye index 8ae9604..385d862 100644 --- a/library/tzdata/Europe/Zaporozhye +++ b/library/tzdata/Europe/Zaporozhye @@ -1,253 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:Europe/Zaporozhye) { - {-9223372036854775808 8440 0 LMT} - {-2840149240 8400 0 +0220} - {-1441160400 7200 0 EET} - {-1247536800 10800 0 MSK} - {-894769200 3600 0 CET} - {-857257200 3600 0 CET} - {-844556400 7200 1 CEST} - {-828226800 3600 0 CET} - {-826419600 10800 0 MSD} - {354920400 14400 1 MSD} - {370728000 10800 0 MSK} - {386456400 14400 1 MSD} - {402264000 10800 0 MSK} - {417992400 14400 1 MSD} - {433800000 10800 0 MSK} - {449614800 14400 1 MSD} - {465346800 10800 0 MSK} - {481071600 14400 1 MSD} - {496796400 10800 0 MSK} - {512521200 14400 1 MSD} - {528246000 10800 0 MSK} - {543970800 14400 1 MSD} - {559695600 10800 0 MSK} - {575420400 14400 1 MSD} - {591145200 10800 0 MSK} - {606870000 14400 1 MSD} - {622594800 10800 0 MSK} - {638319600 14400 1 MSD} - {654649200 10800 0 MSK} - {670374000 10800 0 EEST} - {686091600 7200 0 EET} - {701042400 7200 0 EET} - {701827200 10800 1 EEST} - {717552000 7200 0 EET} - {733276800 10800 1 EEST} - {749001600 7200 0 EET} - {764726400 10800 1 EEST} - {780451200 7200 0 EET} - {796176000 10800 1 EEST} - {811900800 7200 0 EET} - {828230400 10800 1 EEST} - {831938400 10800 0 EEST} - {846378000 7200 0 EET} - {859683600 10800 1 EEST} - {877827600 7200 0 EET} - {891133200 10800 1 EEST} - {909277200 7200 0 EET} - {922582800 10800 1 EEST} - {941331600 7200 0 EET} - {954032400 10800 1 EEST} - {972781200 7200 0 EET} - {985482000 10800 1 EEST} - {1004230800 7200 0 EET} - {1017536400 10800 1 EEST} - {1035680400 7200 0 EET} - {1048986000 10800 1 EEST} - {1067130000 7200 0 EET} - {1080435600 10800 1 EEST} - {1099184400 7200 0 EET} - {1111885200 10800 1 EEST} - {1130634000 7200 0 EET} - {1143334800 10800 1 EEST} - {1162083600 7200 0 EET} - {1174784400 10800 1 EEST} - {1193533200 7200 0 EET} - {1206838800 10800 1 EEST} - {1224982800 7200 0 EET} - {1238288400 10800 1 EEST} - {1256432400 7200 0 EET} - {1269738000 10800 1 EEST} - {1288486800 7200 0 EET} - {1301187600 10800 1 EEST} - {1319936400 7200 0 EET} - {1332637200 10800 1 EEST} - {1351386000 7200 0 EET} - {1364691600 10800 1 EEST} - {1382835600 7200 0 EET} - {1396141200 10800 1 EEST} - {1414285200 7200 0 EET} - {1427590800 10800 1 EEST} - {1445734800 7200 0 EET} - {1459040400 10800 1 EEST} - {1477789200 7200 0 EET} - {1490490000 10800 1 EEST} - {1509238800 7200 0 EET} - {1521939600 10800 1 EEST} - {1540688400 7200 0 EET} - {1553994000 10800 1 EEST} - {1572138000 7200 0 EET} - {1585443600 10800 1 EEST} - {1603587600 7200 0 EET} - {1616893200 10800 1 EEST} - {1635642000 7200 0 EET} - {1648342800 10800 1 EEST} - {1667091600 7200 0 EET} - {1679792400 10800 1 EEST} - {1698541200 7200 0 EET} - {1711846800 10800 1 EEST} - {1729990800 7200 0 EET} - {1743296400 10800 1 EEST} - {1761440400 7200 0 EET} - {1774746000 10800 1 EEST} - {1792890000 7200 0 EET} - {1806195600 10800 1 EEST} - {1824944400 7200 0 EET} - {1837645200 10800 1 EEST} - {1856394000 7200 0 EET} - {1869094800 10800 1 EEST} - {1887843600 7200 0 EET} - {1901149200 10800 1 EEST} - {1919293200 7200 0 EET} - {1932598800 10800 1 EEST} - {1950742800 7200 0 EET} - {1964048400 10800 1 EEST} - {1982797200 7200 0 EET} - {1995498000 10800 1 EEST} - {2014246800 7200 0 EET} - {2026947600 10800 1 EEST} - {2045696400 7200 0 EET} - {2058397200 10800 1 EEST} - {2077146000 7200 0 EET} - {2090451600 10800 1 EEST} - {2108595600 7200 0 EET} - {2121901200 10800 1 EEST} - {2140045200 7200 0 EET} - {2153350800 10800 1 EEST} - {2172099600 7200 0 EET} - {2184800400 10800 1 EEST} - {2203549200 7200 0 EET} - {2216250000 10800 1 EEST} - {2234998800 7200 0 EET} - {2248304400 10800 1 EEST} - {2266448400 7200 0 EET} - {2279754000 10800 1 EEST} - {2297898000 7200 0 EET} - {2311203600 10800 1 EEST} - {2329347600 7200 0 EET} - {2342653200 10800 1 EEST} - {2361402000 7200 0 EET} - {2374102800 10800 1 EEST} - {2392851600 7200 0 EET} - {2405552400 10800 1 EEST} - {2424301200 7200 0 EET} - {2437606800 10800 1 EEST} - {2455750800 7200 0 EET} - {2469056400 10800 1 EEST} - {2487200400 7200 0 EET} - {2500506000 10800 1 EEST} - {2519254800 7200 0 EET} - {2531955600 10800 1 EEST} - {2550704400 7200 0 EET} - {2563405200 10800 1 EEST} - {2582154000 7200 0 EET} - {2595459600 10800 1 EEST} - {2613603600 7200 0 EET} - {2626909200 10800 1 EEST} - {2645053200 7200 0 EET} - {2658358800 10800 1 EEST} - {2676502800 7200 0 EET} - {2689808400 10800 1 EEST} - {2708557200 7200 0 EET} - {2721258000 10800 1 EEST} - {2740006800 7200 0 EET} - {2752707600 10800 1 EEST} - {2771456400 7200 0 EET} - {2784762000 10800 1 EEST} - {2802906000 7200 0 EET} - {2816211600 10800 1 EEST} - {2834355600 7200 0 EET} - {2847661200 10800 1 EEST} - {2866410000 7200 0 EET} - {2879110800 10800 1 EEST} - {2897859600 7200 0 EET} - {2910560400 10800 1 EEST} - {2929309200 7200 0 EET} - {2942010000 10800 1 EEST} - {2960758800 7200 0 EET} - {2974064400 10800 1 EEST} - {2992208400 7200 0 EET} - {3005514000 10800 1 EEST} - {3023658000 7200 0 EET} - {3036963600 10800 1 EEST} - {3055712400 7200 0 EET} - {3068413200 10800 1 EEST} - {3087162000 7200 0 EET} - {3099862800 10800 1 EEST} - {3118611600 7200 0 EET} - {3131917200 10800 1 EEST} - {3150061200 7200 0 EET} - {3163366800 10800 1 EEST} - {3181510800 7200 0 EET} - {3194816400 10800 1 EEST} - {3212960400 7200 0 EET} - {3226266000 10800 1 EEST} - {3245014800 7200 0 EET} - {3257715600 10800 1 EEST} - {3276464400 7200 0 EET} - {3289165200 10800 1 EEST} - {3307914000 7200 0 EET} - {3321219600 10800 1 EEST} - {3339363600 7200 0 EET} - {3352669200 10800 1 EEST} - {3370813200 7200 0 EET} - {3384118800 10800 1 EEST} - {3402867600 7200 0 EET} - {3415568400 10800 1 EEST} - {3434317200 7200 0 EET} - {3447018000 10800 1 EEST} - {3465766800 7200 0 EET} - {3479072400 10800 1 EEST} - {3497216400 7200 0 EET} - {3510522000 10800 1 EEST} - {3528666000 7200 0 EET} - {3541971600 10800 1 EEST} - {3560115600 7200 0 EET} - {3573421200 10800 1 EEST} - {3592170000 7200 0 EET} - {3604870800 10800 1 EEST} - {3623619600 7200 0 EET} - {3636320400 10800 1 EEST} - {3655069200 7200 0 EET} - {3668374800 10800 1 EEST} - {3686518800 7200 0 EET} - {3699824400 10800 1 EEST} - {3717968400 7200 0 EET} - {3731274000 10800 1 EEST} - {3750022800 7200 0 EET} - {3762723600 10800 1 EEST} - {3781472400 7200 0 EET} - {3794173200 10800 1 EEST} - {3812922000 7200 0 EET} - {3825622800 10800 1 EEST} - {3844371600 7200 0 EET} - {3857677200 10800 1 EEST} - {3875821200 7200 0 EET} - {3889126800 10800 1 EEST} - {3907270800 7200 0 EET} - {3920576400 10800 1 EEST} - {3939325200 7200 0 EET} - {3952026000 10800 1 EEST} - {3970774800 7200 0 EET} - {3983475600 10800 1 EEST} - {4002224400 7200 0 EET} - {4015530000 10800 1 EEST} - {4033674000 7200 0 EET} - {4046979600 10800 1 EEST} - {4065123600 7200 0 EET} - {4078429200 10800 1 EEST} - {4096573200 7200 0 EET} +if {![info exists TZData(Europe/Kyiv)]} { + LoadTimeZoneFile Europe/Kyiv } +set TZData(:Europe/Zaporozhye) $TZData(:Europe/Kyiv) -- cgit v0.12