From 02daccc325c05a024ab3845f580d7cd7e5869244 Mon Sep 17 00:00:00 2001 From: bch Date: Mon, 6 Feb 2017 21:54:30 +0000 Subject: s/then/than/ in Eval.3 manpage --- doc/Eval.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 8661923..191bace 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -205,7 +205,7 @@ and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code -from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. +from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS execute, file, global, result, script, value -- cgit v0.12 From 59d58114edd5bd6eef5c80dc0e3a9cf1d59938a1 Mon Sep 17 00:00:00 2001 From: bch Date: Mon, 6 Feb 2017 21:58:48 +0000 Subject: cherrypick typo fix. --- doc/Eval.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 8661923..191bace 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -205,7 +205,7 @@ and sets \fIinterp\fR's result to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code -from \fBTcl_EvalObjEx\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. +from \fBTcl_EvalObjEx\fR other than \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS execute, file, global, result, script, value -- cgit v0.12 From 9b8fe92d1ec10b1010d91d504deab315538cce0e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Feb 2017 12:11:29 +0000 Subject: =?UTF-8?q?Code=20cleanup=20(based=20on=20feedback=20from=20Ren?= =?UTF-8?q?=C3=A9=20Zaumseil):=20Only=20call=20GetInvalidIntFromObj()=20wh?= =?UTF-8?q?en=20Tcl=5FGetIntFromObj()=20fails.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclLink.c | 203 +++++++++++++++++++++++------------------------------- 1 file changed, 85 insertions(+), 118 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index f8f2342..7d1e3a8 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -67,10 +67,9 @@ typedef struct Link { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); -static int GetInvalidIntFromObj(Tcl_Obj *objPtr, - int *intPtr); -static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, - double *doublePtr); +static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); +static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -263,7 +262,8 @@ LinkTraceProc( int flags) /* Miscellaneous additional information. */ { Link *linkPtr = clientData; - int changed, valueLength; + int changed; + size_t valueLength; const char *value; char **pp; Tcl_Obj *valueObj; @@ -382,40 +382,31 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) - != TCL_OK) { - if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK + && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; - } + return (char *) "variable must have integer value"; } LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) - != TCL_OK) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK + && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; - } - linkPtr->lastValue.w = (Tcl_WideInt) valueInt; + return (char *) "variable must have integer value"; } LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) - != TCL_OK) { + if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { #ifdef ACCEPT_NAN if (valueObj->typePtr != &tclDoubleType) { #endif - if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) - != TCL_OK) { + if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have real value"; @@ -429,8 +420,7 @@ LinkTraceProc( break; case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) - != TCL_OK) { + if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have boolean value"; @@ -439,148 +429,113 @@ LinkTraceProc( break; case TCL_LINK_CHAR: - if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; - } + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; } - linkPtr->lastValue.c = (char)valueInt; - LinkedVar(char) = linkPtr->lastValue.c; + LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; case TCL_LINK_UCHAR: - if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < 0 || valueInt > UCHAR_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; - } + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; } - linkPtr->lastValue.uc = (unsigned char) valueInt; - LinkedVar(unsigned char) = linkPtr->lastValue.uc; + LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; break; case TCL_LINK_SHORT: - if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; - } + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; } - linkPtr->lastValue.s = (short)valueInt; - LinkedVar(short) = linkPtr->lastValue.s; + LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; break; case TCL_LINK_USHORT: - if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK + && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) || valueInt < 0 || valueInt > USHRT_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; - } + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; } - linkPtr->lastValue.us = (unsigned short)valueInt; - LinkedVar(unsigned short) = linkPtr->lastValue.us; + LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; break; case TCL_LINK_UINT: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) || valueWide < 0 || valueWide > UINT_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; - } - linkPtr->lastValue.ui = (unsigned int)valueInt; - } else { - linkPtr->lastValue.ui = (unsigned int)valueWide; + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; } - LinkedVar(unsigned int) = linkPtr->lastValue.ui; + LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; case TCL_LINK_LONG: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) || valueWide < LONG_MIN || valueWide > LONG_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; - } - linkPtr->lastValue.l = (long)valueInt; - } else { - linkPtr->lastValue.l = (long)valueWide; + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; } - LinkedVar(long) = linkPtr->lastValue.l; + LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; break; case TCL_LINK_ULONG: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; - } - linkPtr->lastValue.ul = (unsigned long)valueInt; - } else { - linkPtr->lastValue.ul = (unsigned long)valueWide; + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned long value"; } - LinkedVar(unsigned long) = linkPtr->lastValue.ul; + LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; case TCL_LINK_WIDE_UINT: /* * FIXME: represent as a bignum. */ - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) { - if (GetInvalidIntFromObj(valueObj, &valueInt) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; - } - linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt; - } else { - linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; + if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK + && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw; + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; break; case TCL_LINK_FLOAT: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK + if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK + && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { - if (GetInvalidDoubleFromObj(valueObj, &valueDouble) - != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; - } + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; } - linkPtr->lastValue.f = (float)valueDouble; - LinkedVar(float) = linkPtr->lastValue.f; + LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; break; case TCL_LINK_STRING: - value = TclGetStringFromObj(valueObj, &valueLength); - valueLength++; + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; pp = (char **) linkPtr->addr; *pp = ckrealloc(*pp, valueLength); - memcpy(*pp, value, (unsigned) valueLength); + memcpy(*pp, value, valueLength); break; default: @@ -742,6 +697,18 @@ GetInvalidIntFromObj(Tcl_Obj *objPtr, return TCL_ERROR; } +int +GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) +{ + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return TCL_ERROR; + } + *widePtr = intValue; + return TCL_OK; +} + /* * This function checks for double representations, which are valid * when linking with C variables, but which are invalid in other -- cgit v0.12 From 8eedc41ff2550dbd1882d89dd2770074fcfd4bcd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Feb 2017 11:42:12 +0000 Subject: FlightAware feedback: "Aside: Any way to find out what the pkgIndex.tcl file a package was defined in was, or does that happen at too high a level?" Answer: Even though the name of the pkgIndex file is available earlier, it is very well possible to remember it and store it with the other files. This commit does exactly that. --- generic/tclPkg.c | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 0759faa..9ad3cb7 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -32,6 +32,7 @@ typedef struct PkgAvail { char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ + char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; @@ -573,6 +574,9 @@ PkgRequireCore( pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; + if (bestPtr->pkgIndex) { + TclPkgFileSeen(interp, bestPtr->pkgIndex); + } code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ pkgFiles->names = pkgName->nextPtr; @@ -921,6 +925,9 @@ Tcl_PackageObjCmd( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + } ckfree(availPtr); } ckfree(pkgPtr); @@ -971,6 +978,9 @@ Tcl_PackageObjCmd( return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + } break; } } @@ -981,6 +991,7 @@ Tcl_PackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); + availPtr->pkgIndex = 0; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -991,6 +1002,10 @@ Tcl_PackageObjCmd( prevPtr->nextPtr = availPtr; } } + if (iPtr->scriptFile) { + argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); + DupBlock(availPtr->pkgIndex, argv4, (unsigned) length + 1); + } argv4 = TclGetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; @@ -1346,6 +1361,9 @@ TclFreePackageInfo( pkgPtr->availPtr = availPtr->nextPtr; Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + } ckfree(availPtr); } ckfree(pkgPtr); -- cgit v0.12 From f0d4f625858cad553260fa36346ff6f023a77473 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Feb 2017 14:32:13 +0000 Subject: Shortcut in TclParseNumber(): If obj is a dict or list, don't bother to generate the string representation if we know already beforehand that the parsing will fail. Use TCL_NO_DEPRECATED in stead of KILL_OCTAL for removing the (deprecated un-prefixed) octal support. Adapt test-cases, so they work without octal support as well. --- generic/tclHistory.c | 5 ++--- generic/tclStrToD.c | 27 +++++++++++++++++---------- tests/get.test | 8 ++++---- tests/parseExpr.test | 5 ++--- 4 files changed, 25 insertions(+), 20 deletions(-) diff --git a/generic/tclHistory.c b/generic/tclHistory.c index b08e352..47806d4 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -62,15 +62,14 @@ Tcl_RecordAndEval( * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; - int length = strlen(cmd); int result; - if (length > 0) { + if (cmd[0]) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 6da6df3..77e1839 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -18,13 +18,6 @@ #include /* - * Define KILL_OCTAL to suppress interpretation of numbers with leading zero - * as octal. (Ceterum censeo: numeros octonarios delendos esse.) - */ - -#undef KILL_OCTAL - -/* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. @@ -546,6 +539,20 @@ TclParseNumber( */ if (bytes == NULL) { + if (endPtrPtr == NULL) { + if (objPtr->typePtr == &tclDictType) { + /* A dict can never be a (single) number */ + return TCL_ERROR; + } + if (objPtr->typePtr == &tclListType) { + int length; + /* A list can only be a (single) number if its length == 1 */ + TclListObjLength(NULL, objPtr, &length); + if (length != 1) { + return TCL_ERROR; + } + } + } bytes = TclGetString(objPtr); } @@ -657,7 +664,7 @@ TclParseNumber( state = ZERO_O; break; } -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED goto decimal; #endif /* FALLTHROUGH */ @@ -740,7 +747,7 @@ TclParseNumber( goto endgame; } -#ifndef KILL_OCTAL +#ifndef TCL_NO_DEPRECATED /* * Scanned a number with a leading zero that contains an 8, 9, @@ -879,7 +886,7 @@ TclParseNumber( * digits. */ -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED decimal: #endif acceptState = state; diff --git a/tests/get.test b/tests/get.test index 7aa06c1..d6a7206 100644 --- a/tests/get.test +++ b/tests/get.test @@ -98,17 +98,17 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 52 52 46} +} {44 44 44 44 54 51 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} # cleanup ::tcltest::cleanupTests diff --git a/tests/parseExpr.test b/tests/parseExpr.test index fda25b7..47dbec5 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -1044,9 +1044,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { } -result {- {} 0 subexpr naner() 1 operator naner 0 {}} test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body { - catch {testexprparser 08 -1} m o - dict get $o -errorcode -} -result {TCL PARSE EXPR BADNUMBER OCTAL} + testexprparser 07 -1 +} -result {- {} 0 subexpr 07 1 text 07 0 {}} test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0o8 -1} m o dict get $o -errorcode -- cgit v0.12 From 3d6a406232dc52b9f475ef7ef3cfa77f8fa01b35 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Feb 2017 14:25:08 +0000 Subject: On Windows, Cygwin and 64-bit platforms, no need to handle 'long' in tclLink.c, since its size is equal to either 'int' or 'Tcl_WideInt'. This enhances interoperabilty between win64 extensions loaded in cygwin64 using Tcl_LinkVar(), whill still being 100% compatible. init.tcl: unnecessary spacing. --- generic/tcl.h | 5 +++++ generic/tclLink.c | 16 ++++++++++++++++ library/init.tcl | 4 ++-- 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index c0cee27..d678229 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1147,8 +1147,13 @@ typedef struct Tcl_DString { #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 +#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) +#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) +#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) +#else #define TCL_LINK_LONG 11 #define TCL_LINK_ULONG 12 +#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_READ_ONLY 0x80 diff --git a/generic/tclLink.c b/generic/tclLink.c index 1507804..a39dfcd 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -36,8 +36,10 @@ typedef struct Link { unsigned int ui; short s; unsigned short us; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) long l; unsigned long ul; +#endif Tcl_WideInt w; Tcl_WideUInt uw; float f; @@ -129,6 +131,14 @@ Tcl_LinkVar( Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; +#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \ + || defined(_WIN32) || defined(__CYGWIN__)) + if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) { + linkPtr->type = TCL_LINK_LONG; + } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) { + linkPtr->type = TCL_LINK_ULONG; + } +#endif if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; } else { @@ -335,12 +345,14 @@ LinkTraceProc( case TCL_LINK_UINT: changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: changed = (LinkedVar(long) != linkPtr->lastValue.l); break; case TCL_LINK_ULONG: changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); break; +#endif case TCL_LINK_FLOAT: changed = (LinkedVar(float) != linkPtr->lastValue.f); break; @@ -483,6 +495,7 @@ LinkTraceProc( LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide; break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) @@ -504,6 +517,7 @@ LinkTraceProc( } LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; +#endif case TCL_LINK_WIDE_UINT: /* @@ -597,12 +611,14 @@ ObjValue( case TCL_LINK_UINT: linkPtr->lastValue.ui = LinkedVar(unsigned int); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui); +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) case TCL_LINK_LONG: linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); +#endif case TCL_LINK_FLOAT: linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); diff --git a/library/init.tcl b/library/init.tcl index 49a523c..fac1722 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -470,9 +470,9 @@ proc auto_load {cmd {namespace {}}} { proc ::tcl::Pkg::source {filename} { if {[interp issafe]} { - uplevel 1 [list ::source $filename] + uplevel 1 [list ::source $filename] } else { - uplevel 1 [list ::source -nopkg $filename] + uplevel 1 [list ::source -nopkg $filename] } } -- cgit v0.12 From 3b5e7e9792b9b34111146557a3353756711b8133 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Feb 2017 14:04:15 +0000 Subject: More internal use of size_t in stead of int, e.g. for epoch's --- generic/tclBasic.c | 2 +- generic/tclCompile.h | 2 +- generic/tclEnsemble.c | 2 +- generic/tclIO.c | 2 +- generic/tclIO.h | 2 +- generic/tclInt.h | 12 ++++++------ generic/tclObj.c | 6 +++--- 7 files changed, 14 insertions(+), 14 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 63c5590..6ff5faa 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4705,7 +4705,7 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5ef154e..5bc3e81 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -425,7 +425,7 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this + size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 6ada155..f3e8187 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -92,7 +92,7 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - int epoch; /* Used to confirm when the data in this + size_t epoch; /* Used to confirm when the data in this * really structure matches up with the * ensemble. */ Command *token; /* Reference to the command for which this diff --git a/generic/tclIO.c b/generic/tclIO.c index 506e6d5..6bf8451 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -321,7 +321,7 @@ static int WillRead(Channel *chanPtr); typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - int epoch; /* The epoch of the channel when the lookup + size_t epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ size_t refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; diff --git a/generic/tclIO.h b/generic/tclIO.h index ffbfa31..07c54fa 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -214,7 +214,7 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - int epoch; /* Used to test validity of stored channelname + size_t epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; diff --git a/generic/tclInt.h b/generic/tclInt.h index 4b87962..f078d18 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -265,7 +265,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - long nsId; /* Unique id for the namespace. */ + size_t nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -299,12 +299,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command + size_t cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - int resolverEpoch; /* Incremented whenever (a) the name + size_t resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -331,7 +331,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - int exportLookupEpoch; /* Incremented whenever a command is added to + size_t exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -432,7 +432,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of + size_t epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -1639,7 +1639,7 @@ typedef struct Command { * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references + size_t cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL diff --git a/generic/tclObj.c b/generic/tclObj.c index 1abbb31..7ec259f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -344,17 +344,17 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - long refNsId; /* refNsPtr's unique namespace id. Used to + size_t refNsId; /* refNsPtr's unique namespace id. Used to * verify that refNsPtr is still valid (e.g., * it's possible that the cmd's containing * namespace was deleted and a new one created * at the same address). */ - int refNsCmdEpoch; /* Value of the referencing namespace's + size_t refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ - int cmdEpoch; /* Value of the command's cmdEpoch when this + size_t cmdEpoch; /* Value of the command's cmdEpoch when this * pointer was cached. Before using the cached * pointer, we check if the cmd's epoch was * incremented; if so, the cmd was renamed, -- cgit v0.12