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