From 172896b15a2b5b8a1163c9de824e20297a876ed5 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Oct 2017 16:20:18 +0000 Subject: Implementation branch for TIP 114 - Eliminate Octal Parsing... --- doc/GetInt.3 | 7 +- doc/expr.n | 4 +- doc/scan.n | 6 +- generic/tclBasic.c | 1 - generic/tclExecute.c | 14 +--- generic/tclInt.h | 2 - generic/tclStrToD.c | 65 +--------------- generic/tclUtil.c | 68 ----------------- tests/assemble.test | 2 +- tests/compExpr-old.test | 24 +++--- tests/compile.test | 2 +- tests/execute.test | 22 +++--- tests/expr-old.test | 64 ++++++++-------- tests/expr.test | 46 ++++++------ tests/get.test | 8 +- tests/lindex.test | 16 ++-- tests/mathop.test | 194 ++++++++++++++++++++++++------------------------ tests/string.test | 4 +- tests/stringComp.test | 4 +- tests/while-old.test | 2 +- tests/while.test | 4 +- 21 files changed, 205 insertions(+), 354 deletions(-) mode change 100644 => 100755 generic/tclStrToD.c diff --git a/doc/GetInt.3 b/doc/GetInt.3 index eba549d..5562e28 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -64,12 +64,9 @@ if the first such characters are then \fIsrc\fR is expected to be in octal form; otherwise, if the first such characters are .QW \fB0b\fR -then \fIsrc\fR is expected to be in binary form; otherwise, -if the first such character is -.QW \fB0\fR then \fIsrc\fR -is expected to be in octal form; otherwise, \fIsrc\fR -is expected to be in decimal form. +is expected to be in binary form; otherwise, \fIsrc\fR is +expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a diff --git a/doc/expr.n b/doc/expr.n index d33623c..9cb1625 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -50,9 +50,7 @@ An integer operand may be specified in decimal (the normal case, the optional first two characters are \fB0d\fR), binary (the first two characters are \fB0b\fR), octal (the first two characters are \fB0o\fR), or hexadecimal -(the first two characters are \fB0x\fR) form. For -compatibility with older Tcl releases, an operand that begins with \fB0\fR is -interpreted as an octal integer even if the second character is not \fBo\fR. +(the first two characters are \fB0x\fR) form. A floating-point number may be specified in any of several common decimal formats, and may use the decimal point \fB.\fR, \fBe\fR or \fBE\fR for scientific notation, and diff --git a/doc/scan.n b/doc/scan.n index 0c24fea..e87bef1 100644 --- a/doc/scan.n +++ b/doc/scan.n @@ -224,12 +224,10 @@ set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP -Parse a \fIHH:MM\fR time string, noting that this avoids problems with -octal numbers by forcing interpretation as decimals (if we did not -care, we would use the \fB%i\fR conversion instead): +Parse a \fIHH:MM\fR time string: .PP .CS -set string "08:08" ;# *Not* octal! +set string "08:08" if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} { error "not a valid time string" } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d4fa833..682709b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3583,7 +3583,6 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); - TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f4c71ec..d43ddfd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9626,16 +9626,7 @@ IllegalExprOperandType( } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - int numBytes; - const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); - - if (numBytes == 0) { - description = "empty string"; - } else if (TclCheckBadOctal(NULL, bytes)) { - description = "invalid octal number"; - } else { - description = "non-numeric string"; - } + description = "non-numeric string"; } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { @@ -9646,7 +9637,8 @@ IllegalExprOperandType( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, operator)); + "can't use %s \"%s\" as operand of \"%s\"", description, + Tcl_GetString(opndPtr), operator)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 0b5ff0c..63df300 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2894,8 +2894,6 @@ MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, MODULE_SCOPE double TclCeil(const mp_int *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); -MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, - const char *value); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c old mode 100644 new mode 100755 index 630e498..6502733 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -483,7 +483,7 @@ TclParseNumber( enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, ZERO_D, BINARY, - HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, + HEXADECIMAL, OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY @@ -528,7 +528,6 @@ TclParseNumber( char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ - int explicitOctal = 0; #define ALL_BITS (~(Tcl_WideUInt)0) #define MOST_BITS (ALL_BITS >> 1) @@ -660,7 +659,6 @@ TclParseNumber( goto zerob; } if (c == 'o' || c == 'O') { - explicitOctal = 1; state = ZERO_O; break; } @@ -668,10 +666,7 @@ TclParseNumber( state = ZERO_D; break; } -#ifdef TCL_NO_DEPRECATED goto decimal; -#endif - /* FALLTHROUGH */ case OCTAL: /* @@ -734,58 +729,6 @@ TclParseNumber( state = OCTAL; break; } - /* FALLTHROUGH */ - - case BAD_OCTAL: - if (explicitOctal) { - /* - * No forgiveness for bad digits in explicitly octal numbers. - */ - - goto endgame; - } - if (flags & TCL_PARSE_INTEGER_ONLY) { - /* - * No seeking floating point when parsing only integer. - */ - - goto endgame; - } -#ifndef TCL_NO_DEPRECATED - - /* - * Scanned a number with a leading zero that contains an 8, 9, - * radix point or E. This is an invalid octal number, but might - * still be floating point. - */ - - if (c == '0') { - numTrailZeros++; - state = BAD_OCTAL; - break; - } else if (isdigit(UCHAR(c))) { - if (objPtr != NULL) { - significandOverflow = AccumulateDecimalDigit( - (unsigned)(c-'0'), numTrailZeros, - &significandWide, &significandBig, - significandOverflow); - } - if (numSigDigs != 0) { - numSigDigs += (numTrailZeros + 1); - } else { - numSigDigs = 1; - } - numTrailZeros = 0; - state = BAD_OCTAL; - break; - } else if (c == '.') { - state = FRACTION; - break; - } else if (c == 'E' || c == 'e') { - state = EXPONENT_START; - break; - } -#endif goto endgame; /* @@ -900,9 +843,7 @@ TclParseNumber( * digits. */ -#ifdef TCL_NO_DEPRECATED decimal: -#endif acceptState = state; acceptPoint = p; acceptLen = len; @@ -1186,7 +1127,6 @@ TclParseNumber( TclFreeIntRep(objPtr); switch (acceptState) { case SIGNUM: - case BAD_OCTAL: case ZERO_X: case ZERO_O: case ZERO_B: @@ -1412,9 +1352,6 @@ TclParseNumber( Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); - if (state == BAD_OCTAL) { - Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); - } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 608cd15..6a727a1 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3655,7 +3655,6 @@ TclGetIntForIndex( if (!strncmp(bytes, "end-", 4)) { bytes += 4; } - TclCheckBadOctal(interp, bytes); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } @@ -3799,73 +3798,6 @@ SetEndOffsetFromAny( /* *---------------------------------------------------------------------- * - * TclCheckBadOctal -- - * - * This function checks for a bad octal value and appends a meaningful - * error to the interp's result. - * - * Results: - * 1 if the argument was a bad octal, else 0. - * - * Side effects: - * The interpreter's result is modified. - * - *---------------------------------------------------------------------- - */ - -int -TclCheckBadOctal( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - const char *value) /* String to check. */ -{ - register const char *p = value; - - /* - * A frequent mistake is invalid octal values due to an unwanted leading - * zero. Try to generate a meaningful error message. - */ - - while (TclIsSpaceProc(*p)) { - p++; - } - if (*p == '+' || *p == '-') { - p++; - } - if (*p == '0') { - if ((p[1] == 'o') || p[1] == 'O') { - p += 2; - } - while (isdigit(UCHAR(*p))) { /* INTL: digit. */ - p++; - } - while (TclIsSpaceProc(*p)) { - p++; - } - if (*p == '\0') { - /* - * Reached end of string. - */ - - if (interp != NULL) { - /* - * Don't reset the result here because we want this result to - * be added to an existing error message as extra info. - */ - - Tcl_AppendToObj(Tcl_GetObjResult(interp), - " (looks like invalid octal number)", -1); - } - return 1; - } - } - return 0; -} - -/* - *---------------------------------------------------------------------- - * * ClearHash -- * * Remove all the entries in the hash table *tablePtr. diff --git a/tests/assemble.test b/tests/assemble.test index d17bfd9..9d6965e 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -781,7 +781,7 @@ test assemble-7.43 {uplus} { } } -returnCodes error - -result {can't use non-numeric floating-point value as operand of "+"} + -result {can't use non-numeric floating-point value "NaN" as operand of "+"} } test assemble-7.43.1 {tryCvtToNumeric} { -body { diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..7144487 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -285,10 +285,10 @@ test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { } -returnCodes error -match glob -result * test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 @@ -309,10 +309,10 @@ test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { } -returnCodes error -match glob -result * test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "24.0" as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 @@ -377,10 +377,10 @@ test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { } -returnCodes error -match glob -result * test compExpr-old-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 @@ -399,10 +399,10 @@ test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { } -returnCodes error -match glob -result * test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} @@ -430,10 +430,10 @@ test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body } -returnCodes error -match glob -result * test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "xx" as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 @@ -451,10 +451,10 @@ test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body { } -returnCodes error -match glob -result * test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "xx" as operand of "~"}} test compExpr-old-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} { set a 27 diff --git a/tests/compile.test b/tests/compile.test index 2fa4147..c76bd82 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -323,7 +323,7 @@ test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a 0o9 }} -} -returnCodes error -match glob -result {*invalid octal number*} +} -returnCodes error -match glob -result {*} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; array set var {one two many} }} } -returnCodes error -result {list must have an even number of elements} diff --git a/tests/execute.test b/tests/execute.test index 5b8ce2d..2480a95 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -174,7 +174,7 @@ test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x + 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 + $x} @@ -199,7 +199,7 @@ test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 + $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} # INST_SUB is partially tested: test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { @@ -226,7 +226,7 @@ test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x - 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 - $x} @@ -251,7 +251,7 @@ test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 - $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} # INST_MULT is partially tested: test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { @@ -278,7 +278,7 @@ test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x * 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "foo" as operand of "*"}} test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { set x [testintobj set 1 1] expr {1 * $x} @@ -303,7 +303,7 @@ test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 * $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "foo" as operand of "*"}} # INST_DIV is partially tested: test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { @@ -330,7 +330,7 @@ test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x / 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "foo" as operand of "/"}} test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { set x [testintobj set 1 1] expr {2 / $x} @@ -355,7 +355,7 @@ test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 / $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "foo" as operand of "/"}} # INST_UPLUS is partially tested: test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { @@ -382,7 +382,7 @@ test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {+ $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} # INST_UMINUS is partially tested: test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { @@ -409,7 +409,7 @@ test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testob test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {- $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} # INST_LNOT is partially tested: test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { @@ -457,7 +457,7 @@ test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "foo" as operand of "!"}} # INST_BITNOT not tested # INST_CALL_BUILTIN_FUNC1 not tested diff --git a/tests/expr-old.test b/tests/expr-old.test index 3adfb63..54191b6 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -197,34 +197,34 @@ test expr-old-2.38 {floating-point operators} { test expr-old-3.1 {illegal floating-point operations} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test expr-old-3.2 {illegal floating-point operations} { list [catch {expr 27%4.0} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} +} {1 {can't use floating-point value "4.0" as operand of "%"}} test expr-old-3.3 {illegal floating-point operations} { list [catch {expr 27.0%4} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} +} {1 {can't use floating-point value "27.0" as operand of "%"}} test expr-old-3.4 {illegal floating-point operations} { list [catch {expr 1.0<<3} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} +} {1 {can't use floating-point value "1.0" as operand of "<<"}} test expr-old-3.5 {illegal floating-point operations} { list [catch {expr 3<<1.0} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} +} {1 {can't use floating-point value "1.0" as operand of "<<"}} test expr-old-3.6 {illegal floating-point operations} { list [catch {expr 24.0>>3} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test expr-old-3.7 {illegal floating-point operations} { list [catch {expr 24>>3.0} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "3.0" as operand of ">>"}} test expr-old-3.8 {illegal floating-point operations} { list [catch {expr 24&3.0} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "3.0" as operand of "&"}} test expr-old-3.9 {illegal floating-point operations} { list [catch {expr 24.0|3} msg] $msg -} {1 {can't use floating-point value as operand of "|"}} +} {1 {can't use floating-point value "24.0" as operand of "|"}} test expr-old-3.10 {illegal floating-point operations} { list [catch {expr 24.0^3} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} # Check the string operators individually. @@ -265,46 +265,46 @@ test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-old-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-5.3 {illegal string operations} { list [catch {expr {~"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "a" as operand of "~"}} test expr-old-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "a" as operand of "!"}} test expr-old-5.5 {illegal string operations} { list [catch {expr {"a"*"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "a" as operand of "*"}} test expr-old-5.6 {illegal string operations} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-old-5.7 {illegal string operations} { list [catch {expr {"a"%"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "%"}} +} {1 {can't use non-numeric string "a" as operand of "%"}} test expr-old-5.8 {illegal string operations} { list [catch {expr {"a"+"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-5.9 {illegal string operations} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-old-5.10 {illegal string operations} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test expr-old-5.11 {illegal string operations} { list [catch {expr {"a">>"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of ">>"}} +} {1 {can't use non-numeric string "a" as operand of ">>"}} test expr-old-5.12 {illegal string operations} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test expr-old-5.13 {illegal string operations} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test expr-old-5.14 {illegal string operations} { list [catch {expr {"a"|"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "|"}} +} {1 {can't use non-numeric string "a" as operand of "|"}} test expr-old-5.15 {illegal string operations} { list [catch {expr {"a"&&"b"}} msg] $msg } {1 {expected boolean value but got "a"}} @@ -493,7 +493,7 @@ test expr-old-25.20 {type conversions} {expr 10.0} 10.0 test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * @@ -507,10 +507,10 @@ test expr-old-26.4 {error conditions} { set a xx test expr-old-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-old-26.6 {error conditions} { list [catch {expr {2+[set a]}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-old-26.7 {error conditions} -body { expr {2+(4} } -returnCodes error -match glob -result * @@ -534,7 +534,7 @@ test expr-old-26.12 {error conditions} -body { } -returnCodes error -match glob -result * test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-old-26.14 {error conditions} -body { expr 2:3 } -returnCodes error -match glob -result * @@ -963,7 +963,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} -body { test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number as operand of "+"}} +} {1 {can't use non-numeric string "0o289" as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -1003,11 +1003,11 @@ test expr-old-36.11 {ExprLooksLikeInt procedure} { test expr-old-36.12 {ExprLooksLikeInt procedure} { set x "10;" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "10;" as operand of "+"}} test expr-old-36.13 {ExprLooksLikeInt procedure} { set x " +" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string " +" as operand of "+"}} test expr-old-36.14 {ExprLooksLikeInt procedure} { set x "123456789012345678901234567890 " expr {$x+1} @@ -1015,7 +1015,7 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} { test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number as operand of "+"}} +} {1 {can't use non-numeric string "0o99 " as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} diff --git a/tests/expr.test b/tests/expr.test index 8e083c5..664b479 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -257,7 +257,7 @@ test expr-4.9 {CompileLorExpr: long lor arm} { } 1 test expr-4.10 {CompileLorExpr: error compiling ! operand} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "a" as operand of "!"}} test expr-4.11 {CompileLorExpr: error compiling land arms} { list [catch {expr {"a"||0}} msg] $msg } {1 {expected boolean value but got "a"}} @@ -304,10 +304,10 @@ test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { } -returnCodes error -match glob -result * test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 @@ -328,10 +328,10 @@ test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { } -returnCodes error -match glob -result * test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "24.0" as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { @@ -456,10 +456,10 @@ test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { } -returnCodes error -match glob -result * test expr-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 @@ -478,10 +478,10 @@ test expr-11.9 {CompileAddExpr: error compiling add arm} -body { } -returnCodes error -match glob -result * test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} @@ -509,10 +509,10 @@ test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { } -returnCodes error -match glob -result * test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "xx" as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 @@ -529,10 +529,10 @@ test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body { } -returnCodes error -match glob -result * test expr-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "xx" as operand of "~"}} test expr-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test expr-13.13 {CompileUnaryExpr: just primary expr} { set a 27 @@ -844,15 +844,15 @@ test expr-21.13 {non-numeric boolean literals} -body { } -returnCodes error -match glob -result * test expr-21.14 {non-numeric boolean literals} { list [catch {expr !"truef"} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "truef" as operand of "!"}} test expr-21.15 {non-numeric boolean variables} { set v truef list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "truef" as operand of "!"}} test expr-21.16 {non-numeric boolean variables} { set v "true " list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "true " as operand of "!"}} test expr-21.17 {non-numeric boolean variables} { set v "tru" list [catch {expr {!$v}} err] $err @@ -872,23 +872,23 @@ test expr-21.20 {non-numeric boolean variables} { test expr-21.21 {non-numeric boolean variables} { set v "o" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "o" as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use empty string as operand of "!"}} +} {1 {can't use non-numeric string "" as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { list [catch {expr {NaN + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "+"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} test expr-22.2 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {Inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.3 {non-numeric floats} { set nan NaN list [catch {expr {$nan + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "+"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} test expr-22.4 {non-numeric floats} !ieeeFloatingPoint { set inf Inf list [catch {expr {$inf + 1}} msg] $msg @@ -901,7 +901,7 @@ test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { } {1 {floating-point value too large to represent}} test expr-22.7 {non-numeric floats} { list [catch {expr {1 / NaN}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "/"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "/"}} test expr-22.8 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} @@ -937,10 +937,10 @@ test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { } -returnCodes error -match glob -result * test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "**"}} +} {1 {can't use non-numeric string "xx" as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg -} {1 {can't use non-numeric string as operand of "**"}} +} {1 {can't use non-numeric string "a" as operand of "**"}} test expr-23.11 {CompileExponentialExpr: runtime error} { list [catch {expr {0**-1}} msg] $msg } {1 {exponentiation of zero by negative power}} diff --git a/tests/get.test b/tests/get.test index d6a7206..c82b7e5 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 " " 007 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 51 52 46} +} {44 44 44 44 54 54 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {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} +} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} # cleanup ::tcltest::cleanupTests diff --git a/tests/lindex.test b/tests/lindex.test index 29eb898..4802e28 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -70,11 +70,11 @@ test lindex-3.4 {integer 3} testevalex { test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] @@ -105,11 +105,11 @@ test lindex-4.5 {index = end-3} testevalex { test lindex-4.6 {bad octal} -constraints testevalex -body { set x end-0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-4.7 {bad octal} -constraints testevalex -body { set x end--0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result @@ -261,11 +261,11 @@ test lindex-11.4 {integer 3} { test lindex-11.5 {bad octal} -body { set x 0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-11.6 {bad octal} -body { set x -0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} # Indices relative to end @@ -307,11 +307,11 @@ test lindex-12.5 {index = end-3} { test lindex-12.6 {bad octal} -body { set x end-0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-12.7 {bad octal} -body { set x end--0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result diff --git a/tests/mathop.test b/tests/mathop.test index f122b7b..0808d42 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -114,22 +114,22 @@ namespace eval ::testmathop { test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.11 {compiled +: errors} -returnCodes error -body { + x 0 - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.12 {compiled +: errors} -returnCodes error -body { + nan 0 - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.13 {compiled +: errors} -returnCodes error -body { + 0 x - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.14 {compiled +: errors} -returnCodes error -body { + 0 nan - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError @@ -152,22 +152,22 @@ namespace eval ::testmathop { test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.29 {interpreted +: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.30 {interpreted +: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.31 {interpreted +: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.32 {interpreted +: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -189,22 +189,22 @@ namespace eval ::testmathop { test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.11 {compiled *: errors} -returnCodes error -body { * x 0 - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.12 {compiled *: errors} -returnCodes error -body { * nan 0 - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.13 {compiled *: errors} -returnCodes error -body { * 0 x - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.14 {compiled *: errors} -returnCodes error -body { * 0 nan - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError @@ -227,22 +227,22 @@ namespace eval ::testmathop { test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.29 {interpreted *: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.30 {interpreted *: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.31 {interpreted *: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.32 {interpreted *: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -261,7 +261,7 @@ namespace eval ::testmathop { test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0 test mathop-3.8 {compiled !: errors} -body { ! foobar - } -returnCodes error -result {can't use non-numeric string as operand of "!"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} test mathop-3.9 {compiled !: errors} -body { ! 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" @@ -278,7 +278,7 @@ namespace eval ::testmathop { test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0 test mathop-3.18 {interpreted !: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string as operand of "!"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} test mathop-3.19 {interpreted !: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" @@ -287,10 +287,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.21 {compiled !: error} -returnCodes error -body { ! NaN - } -result {can't use non-numeric floating-point value as operand of "!"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} test mathop-3.22 {interpreted !: error} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value as operand of "!"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} test mathop-4.1 {compiled ~} {~ 0} -1 test mathop-4.2 {compiled ~} {~ 1} -2 @@ -301,7 +301,7 @@ namespace eval ::testmathop { test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001 test mathop-4.8 {compiled ~: errors} -body { ~ foobar - } -returnCodes error -result {can't use non-numeric string as operand of "~"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} test mathop-4.9 {compiled ~: errors} -body { ~ 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" @@ -310,10 +310,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.11 {compiled ~: errors} -returnCodes error -body { ~ 0.0 - } -result {can't use floating-point value as operand of "~"} + } -result {can't use floating-point value "0.0" as operand of "~"} test mathop-4.12 {compiled ~: errors} -returnCodes error -body { ~ NaN - } -result {can't use non-numeric floating-point value as operand of "~"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} set op ~ test mathop-4.13 {interpreted ~} {$op 0} -1 test mathop-4.14 {interpreted ~} {$op 1} -2 @@ -324,7 +324,7 @@ namespace eval ::testmathop { test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001 test mathop-4.20 {interpreted ~: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string as operand of "~"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} test mathop-4.21 {interpreted ~: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" @@ -333,10 +333,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.23 {interpreted ~: errors} -returnCodes error -body { $op 0.0 - } -result {can't use floating-point value as operand of "~"} + } -result {can't use floating-point value "0.0" as operand of "~"} test mathop-4.24 {interpreted ~: errors} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value as operand of "~"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} test mathop-5.1 {compiled eq} {eq {} a} 0 test mathop-5.2 {compiled eq} {eq a a} 1 @@ -377,32 +377,32 @@ namespace eval ::testmathop { test mathop-6.4 {compiled &} { & 3 7 6 } 2 test mathop-6.5 {compiled &} -returnCodes error -body { & 1.0 2 3 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "1.0" as operand of "&"} test mathop-6.6 {compiled &} -returnCodes error -body { & 1 2 3.0 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "3.0" as operand of "&"} test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2 test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85 test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2 test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85 test mathop-6.11 {compiled &: errors} -returnCodes error -body { & x 0 - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.12 {compiled &: errors} -returnCodes error -body { & nan 0 - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.13 {compiled &: errors} -returnCodes error -body { & 0 x - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.14 {compiled &: errors} -returnCodes error -body { & 0 nan - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError @@ -419,32 +419,32 @@ namespace eval ::testmathop { test mathop-6.22 {interpreted &} { $op 3 7 6 } 2 test mathop-6.23 {interpreted &} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "1.0" as operand of "&"} test mathop-6.24 {interpreted &} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "3.0" as operand of "&"} test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2 test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85 test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2 test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85 test mathop-6.29 {interpreted &: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.30 {interpreted &: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.31 {interpreted &: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.32 {interpreted &: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -487,32 +487,32 @@ namespace eval ::testmathop { test mathop-7.4 {compiled |} { | 3 7 6 } 7 test mathop-7.5 {compiled |} -returnCodes error -body { | 1.0 2 3 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "1.0" as operand of "|"} test mathop-7.6 {compiled |} -returnCodes error -body { | 1 2 3.0 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "3.0" as operand of "|"} test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110 test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503 test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110 test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.11 {compiled |: errors} -returnCodes error -body { | x 0 - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.12 {compiled |: errors} -returnCodes error -body { | nan 0 - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.13 {compiled |: errors} -returnCodes error -body { | 0 x - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.14 {compiled |: errors} -returnCodes error -body { | 0 nan - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError @@ -529,32 +529,32 @@ namespace eval ::testmathop { test mathop-7.22 {interpreted |} { $op 3 7 6 } 7 test mathop-7.23 {interpreted |} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "1.0" as operand of "|"} test mathop-7.24 {interpreted |} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "3.0" as operand of "|"} test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110 test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503 test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110 test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.29 {interpreted |: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.30 {interpreted |: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.31 {interpreted |: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.32 {interpreted |: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -597,32 +597,32 @@ namespace eval ::testmathop { test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2 test mathop-8.5 {compiled ^} -returnCodes error -body { ^ 1.0 2 3 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "1.0" as operand of "^"} test mathop-8.6 {compiled ^} -returnCodes error -body { ^ 1 2 3.0 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "3.0" as operand of "^"} test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110 test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333 test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.11 {compiled ^: errors} -returnCodes error -body { ^ x 0 - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.12 {compiled ^: errors} -returnCodes error -body { ^ nan 0 - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.13 {compiled ^: errors} -returnCodes error -body { ^ 0 x - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.14 {compiled ^: errors} -returnCodes error -body { ^ 0 nan - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError @@ -639,32 +639,32 @@ namespace eval ::testmathop { test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2 test mathop-8.23 {interpreted ^} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "1.0" as operand of "^"} test mathop-8.24 {interpreted ^} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "3.0" as operand of "^"} test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110 test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333 test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.29 {interpreted ^: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.30 {interpreted ^: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.31 {interpreted ^: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.32 {interpreted ^: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -775,13 +775,13 @@ test mathop-20.6 { one arg, error } { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] - lappend exp "can't use non-numeric string as operand of \"$op\"\ + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\"\ ARITH DOMAIN {non-numeric string}" } } foreach op {+ * / & | ^ **} { lappend res [TestOp $op NaN 1] - lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\ + lappend exp "can't use non-numeric floating-point value \"NaN\" as operand of \"$op\"\ ARITH DOMAIN {non-numeric floating-point value}" } expr {$res eq $exp ? 0 : $res} @@ -850,15 +850,15 @@ test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] - lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] - lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ x] - lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] - lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ 5.0] - lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { @@ -965,9 +965,9 @@ test mathop-22.4 { unary ops, bad values } { set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } expr {$res eq $exp ? 0 : $res} } 0 @@ -1080,15 +1080,15 @@ test mathop-24.3 { binary ops, bad values } { set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } foreach op {% << >>} { lappend res [TestOp $op 5.0 1] - lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] - lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] @@ -1240,9 +1240,9 @@ test mathop-25.23 { exp operator errors } { lappend res [TestOp ** $huge 2.1] lappend exp "Inf" lappend res [TestOp ** 2 foo] - lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] - lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" expr {$res eq $exp ? 0 : $res} } 0 diff --git a/tests/string.test b/tests/string.test index 549944d..f3160a8 100644 --- a/tests/string.test +++ b/tests/string.test @@ -280,10 +280,10 @@ test string-5.16 {string index, bytearray object with string obj shimmering} { } 0 test string-5.17 {string index, bad integer} -body { list [catch {string index "abc" 0o8} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test string-5.18 {string index, bad integer} -body { list [catch {string index "abc" end-0o0289} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test string-5.19 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] -1 } {} diff --git a/tests/stringComp.test b/tests/stringComp.test index 2aeb08e..3ce2b72 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -355,11 +355,11 @@ test stringComp-5.16 {string index, bytearray object with string obj shimmering} test stringComp-5.17 {string index, bad integer} -body { proc foo {} {string index "abc" 0o8} list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test stringComp-5.18 {string index, bad integer} -body { proc foo {} {string index "abc" end-0o0289} list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test stringComp-5.19 {string index, bytearray object out of bounds} { proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} foo diff --git a/tests/while-old.test b/tests/while-old.test index ee17d0b..e33bd0b 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -92,7 +92,7 @@ test while-old-4.3 {errors in while loops} { test while-old-4.4 {errors in while loops} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test while-old-4.5 {errors in while loops} { catch {unset x} set x 1 diff --git a/tests/while.test b/tests/while.test index 642ec93..c25b404 100644 --- a/tests/while.test +++ b/tests/while.test @@ -32,7 +32,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} -body { } -match glob -result {*"while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} -body { while {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string as operand of "+"} +} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} test while-1.4 {TclCompileWhileCmd: multiline test expr} -body { set value 1 while {($tcl_platform(platform) != "foobar1") && \ @@ -343,7 +343,7 @@ test while-4.3 {while (not compiled): error in test expression} -body { test while-4.4 {while (not compiled): error in test expression} -body { set z while $z {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string as operand of "+"} +} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} test while-4.5 {while (not compiled): multiline test expr} -body { set value 1 set z while -- cgit v0.12 From fe508fa3b5c9dffaebbd68b86344a799a45075c4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Oct 2017 08:47:33 +0000 Subject: Experimental branch meant to eliminate the "wideint" type, just merge it to a single "int" type. No effect on linux64 and similar systems, code simplification for Win64 and 32-bit system. No TIP yet, implementation ongoing. --- generic/tclCmdMZ.c | 4 ++-- generic/tclDisassemble.c | 6 +++--- generic/tclExecute.c | 8 ++++---- generic/tclGet.c | 2 +- generic/tclInt.h | 14 +++++++------- generic/tclObj.c | 26 +++++++++++++------------- generic/tclProc.c | 4 ++-- generic/tclStrToD.c | 8 ++++---- generic/tclStubInit.c | 2 +- generic/tclUtil.c | 8 ++++---- 10 files changed, 41 insertions(+), 41 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 2195aa1..522b76f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1580,9 +1580,9 @@ StringIsCmd( result = length1 == 0; } } else if (((index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) + objPtr->internalRep.wideValue == 0) || ((index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { + objPtr->internalRep.wideValue != 0)) { result = 0; } break; diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index d61ed42..70a5847 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -797,7 +797,7 @@ TclNewInstNameObj( Tcl_Obj *objPtr = Tcl_NewObj(); objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; + objPtr->internalRep.wideValue = (long) inst; objPtr->bytes = NULL; return objPtr; @@ -817,7 +817,7 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.longValue; + int inst = objPtr->internalRep.wideValue; char *s, buf[20]; int len; @@ -825,7 +825,7 @@ UpdateStringOfInstName( sprintf(buf, "inst_%d", inst); s = buf; } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + s = (char *) tclInstructionTable[objPtr->internalRep.wideValue].name; } len = strlen(s); objPtr->bytes = ckalloc(len + 1); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f4c71ec..b068e0d 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -503,7 +503,7 @@ VarHashCreateVar( (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ @@ -518,7 +518,7 @@ VarHashCreateVar( (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_LONG, \ *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ + (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclWideIntType) \ ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ @@ -545,7 +545,7 @@ VarHashCreateVar( #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ ((((objPtr)->typePtr == &tclIntType) \ || ((objPtr)->typePtr == &tclBooleanType)) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* @@ -6692,7 +6692,7 @@ TEBCresume( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; + iterNum = valuePtr->internalRep.wideValue + 1; TclSetLongObj(valuePtr, iterNum); /* diff --git a/generic/tclGet.c b/generic/tclGet.c index 97e8c7b..727db0a 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -142,7 +142,7 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.longValue; + *boolPtr = obj.internalRep.wideValue; } return code; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 0b5ff0c..feffeba 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2453,17 +2453,17 @@ typedef struct List { #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) #if (LONG_MAX == INT_MAX) #define TclGetIntFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + ? ((*(intPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) #else #define TclGetIntFromObj(interp, objPtr, intPtr) \ @@ -2484,7 +2484,7 @@ typedef struct List { #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ + ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ @@ -2492,7 +2492,7 @@ typedef struct List { ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ ((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ + ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ @@ -4545,7 +4545,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (long)(i); \ (objPtr)->typePtr = &tclIntType; \ } while (0) @@ -4589,7 +4589,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (long)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) diff --git a/generic/tclObj.c b/generic/tclObj.c index 1a00011..f0bcc5e 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1810,7 +1810,7 @@ Tcl_DbNewBooleanObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue != 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -1888,11 +1888,11 @@ Tcl_GetBooleanFromObj( { do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.longValue != 0); + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; + *boolPtr = (int) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -1960,7 +1960,7 @@ TclSetBooleanFromAny( if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - switch (objPtr->internalRep.longValue) { + switch (objPtr->internalRep.wideValue) { case 0L: case 1L: return TCL_OK; } @@ -2107,13 +2107,13 @@ ParseBoolean( goodBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2294,7 +2294,7 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; + *dblPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { @@ -2569,7 +2569,7 @@ UpdateStringOfInt( char buffer[TCL_INTEGER_SPACE]; register int len; - len = TclFormatInt(buffer, objPtr->internalRep.longValue); + len = TclFormatInt(buffer, objPtr->internalRep.wideValue); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); @@ -2679,7 +2679,7 @@ Tcl_DbNewLongObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2759,7 +2759,7 @@ Tcl_GetLongFromObj( { do { if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; + *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } #ifndef TCL_WIDE_INT_IS_LONG @@ -3080,7 +3080,7 @@ Tcl_GetWideIntFromObj( } #endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -3402,7 +3402,7 @@ GetBignumFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); + TclInitBignumFromLong(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } #ifndef TCL_WIDE_INT_IS_LONG @@ -3653,7 +3653,7 @@ TclGetNumberFromObj( } if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.longValue; + *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } #ifndef TCL_WIDE_INT_IS_LONG diff --git a/generic/tclProc.c b/generic/tclProc.c index 96bdcf3..133f41d 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -826,7 +826,7 @@ TclObjGetFrame( level = curLevel - level; result = 1; } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + level = (int) objPtr->internalRep.wideValue; result = 1; } else { name = TclGetString(objPtr); @@ -834,7 +834,7 @@ TclObjGetFrame( if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { TclFreeIntRep(objPtr); objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; + objPtr->internalRep.wideValue = level; result = 1; } else { result = -1; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 630e498..c8bc7b5 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1289,10 +1289,10 @@ TclParseNumber( } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = + objPtr->internalRep.wideValue = - (long) octalSignificandWide; } else { - objPtr->internalRep.longValue = + objPtr->internalRep.wideValue = (long) octalSignificandWide; } } @@ -1336,10 +1336,10 @@ TclParseNumber( } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = + objPtr->internalRep.wideValue = - (long) significandWide; } else { - objPtr->internalRep.longValue = + objPtr->internalRep.wideValue = (long) significandWide; } } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ebd2086..c8b4dce 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -244,7 +244,7 @@ static Tcl_Obj *dbNewLongObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (long) intValue; + objPtr->internalRep.wideValue = (long) intValue; objPtr->typePtr = &tclIntType; return objPtr; #else diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 608cd15..da4dc49 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3598,7 +3598,7 @@ TclGetIntForIndex( * be converted to one, use it. */ - *indexPtr = endValue + objPtr->internalRep.longValue; + *indexPtr = endValue + objPtr->internalRep.wideValue; return TCL_OK; } @@ -3690,9 +3690,9 @@ UpdateStringOfEndOffset( register int len = 3; memcpy(buffer, "end", 4); - if (objPtr->internalRep.longValue != 0) { + if (objPtr->internalRep.wideValue != 0) { buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + len += TclFormatInt(buffer+len, -(objPtr->internalRep.wideValue)); } objPtr->bytes = ckalloc((unsigned) len+1); memcpy(objPtr->bytes, buffer, (unsigned) len+1); @@ -3790,7 +3790,7 @@ SetEndOffsetFromAny( */ TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; + objPtr->internalRep.wideValue = offset; objPtr->typePtr = &tclEndOffsetType; return TCL_OK; -- cgit v0.12 From aad24c7ffcbdb7271ba73f1548b5be00185df1b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Oct 2017 11:01:28 +0000 Subject: Change (internal) TclFormatInt() signature, so it can handle WideInt's directly. Ongoing simplifications ... --- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 4 +-- generic/tclObj.c | 83 +++------------------------------------------------ generic/tclTimer.c | 32 +++++++------------- generic/tclUtil.c | 21 +++++++++---- 5 files changed, 33 insertions(+), 109 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index dea698c..63ed6c6 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -114,7 +114,7 @@ declare 23 { } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - int TclFormatInt(char *buffer, long n) + int TclFormatInt(char *buffer, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 5bccfe5..2d437d5 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -113,7 +113,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp, /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN int TclFormatInt(char *buffer, long n); +EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -668,7 +668,7 @@ typedef struct TclIntStubs { void (*reserved21)(void); int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - int (*tclFormatInt) (char *buffer, long n); /* 24 */ + int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); diff --git a/generic/tclObj.c b/generic/tclObj.c index f0bcc5e..bf1a2e6 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -210,10 +210,6 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt(Tcl_Obj *objPtr); -static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -#endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); @@ -275,8 +271,8 @@ const Tcl_ObjType tclWideIntType = { "wideInt", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + UpdateStringOfInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { @@ -2538,9 +2534,8 @@ SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - long l; - - return TclGetLongFromObj(interp, objPtr, &l); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* @@ -2836,49 +2831,6 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfWideInt -- - * - * Update the string representation for a wide integer object. Note: this - * function does not free 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 - * wideInt-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfWideInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; - - /* - * 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", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3133,33 +3085,6 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * SetWideIntFromAny -- - * - * Attempts to force the internal representation for a Tcl object to - * tclWideIntType, specifically. - * - * Results: - * The return value is a standard object Tcl result. If an error occurs - * during conversion, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - *---------------------------------------------------------------------- - */ - -static int -SetWideIntFromAny( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Pointer to the object to convert */ -{ - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 3467305..4bb5a35 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -1045,37 +1045,27 @@ AfterDelay( if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } - if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { - diff = 1; - } + if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) { + diff = 1; + } if (diff > 0) { - Tcl_Sleep((long) diff); - if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { - break; - } + Tcl_Sleep((int) diff); + if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { + break; + } } else { - break; - } + break; + } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff > 0) { - Tcl_Sleep((long) diff); + Tcl_Sleep((int) diff); } if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { @@ -1089,7 +1079,7 @@ AfterDelay( return TCL_ERROR; } } - Tcl_GetTime(&now); + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index da4dc49..27e1877 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3489,9 +3489,9 @@ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { - long intVal; + Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; @@ -3514,7 +3514,7 @@ TclFormatInt( intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%ld", n); + return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* @@ -3722,7 +3722,7 @@ SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { - int offset; /* Offset in the "end-offset" expression */ + Tcl_WideInt offset; /* Offset in the "end-offset" expression */ register const char *bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ @@ -3758,15 +3758,24 @@ SetEndOffsetFromAny( } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. + * after "end-" to TclParseNumber. */ if (TclIsSpaceProc(bytes[4])) { goto badIndexFormat; } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { + if (TclParseNumber(NULL, objPtr, NULL, bytes+4, length-4, NULL, + TCL_PARSE_INTEGER_ONLY) != TCL_OK) { return TCL_ERROR; } + if ((objPtr->typePtr != &tclIntType) +#ifndef TCL_WIDE_INT_IS_LONG + && (objPtr->typePtr != &tclWideIntType) +#endif + ) { + goto badIndexFormat; + } + offset = objPtr->internalRep.wideValue; if (bytes[3] == '-') { offset = -offset; } -- cgit v0.12 From 6642181b9d3599f1bde42f466b34f2d44f9a26e8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 12:41:21 +0000 Subject: Rebase tip-278 branch to workaround CVS conversion woes. --- generic/tclVar.c | 12 ++++++------ tests/namespace-old.test | 24 ++++++++++++++---------- tests/namespace.test | 36 ++++++++++++++++++++++++------------ tests/parse.test | 6 +++--- tests/tcltest.test | 1 + tests/var.test | 9 +++++---- 6 files changed, 53 insertions(+), 35 deletions(-) diff --git a/generic/tclVar.c b/generic/tclVar.c index 7c8bb73..4f2d435 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -816,12 +816,8 @@ TclLookupSimpleVar( *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - if (flags & TCL_AVOID_RESOLVERS) { - flags = (flags | TCL_NAMESPACE_ONLY); - } - if (flags & TCL_NAMESPACE_ONLY) { - *indexPtr = -2; - } + flags = (flags | TCL_NAMESPACE_ONLY); + *indexPtr = -2; } /* @@ -5709,6 +5705,10 @@ ObjFindNamespaceVar( * Find the namespace(s) that contain the variable. */ + if (!(flags & TCL_GLOBAL_ONLY)) { + flags |= TCL_NAMESPACE_ONLY; + } + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d6a805..3f8737b 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -293,12 +293,13 @@ namespace eval test_ns_hier1 { namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } +# TIP 278: secondary lookup disabled for vars, tests disabled with # test namespace-old-5.4 {nested namespaces can access global namespace} { - list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ + list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ - [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \ [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] -} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} +} {{} {cmd in ::} {} {cmd in ::}} test namespace-old-5.5 {variables in different namespaces don't conflict} { list [set test_ns_hier1::test_ns_level] \ [set test_ns_hier1::test_ns_hier2::test_ns_level] @@ -468,11 +469,12 @@ test namespace-old-6.11 {commands affect all parent namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{cache2 version} {cache2 version}} +# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.12 {define test variables} { variable test_ns_cache_var "global version" set trigger {set test_ns_cache_var} - namespace eval test_ns_cache1 $trigger -} {global version} + list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg +} {1 {can't read "test_ns_cache_var": no such variable}} set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { @@ -481,22 +483,24 @@ test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 $trigger } {cache1 version} variable ::test_ns_cache_var "global version" +# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ - [namespace eval test_ns_cache1 $trigger] -} {{cache1 version} {} {global version}} + [catch {namespace eval test_ns_cache1 $trigger}] +} {{cache1 version} {} 1} +# TIP 278: secondary lookup disabled, catch added, result changed test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" } set trigger2 {set test_ns_cache2::test_ns_cache_var} - list [namespace eval test_ns_cache1 $trigger2] \ - [namespace eval test_ns_cache1::test_ns_cache2 $trigger] -} {{global cache2 version} {global version}} + catch {list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger]} +} 1 set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" diff --git a/tests/namespace.test b/tests/namespace.test index f6f817b..24c1c7d 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -46,9 +46,9 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { - lappend l [namespace current] + lappend ::l [namespace current] namespace eval foo { - lappend l [namespace current] + lappend ::l [namespace current] } } lappend l [namespace current] @@ -633,6 +633,8 @@ test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup [catch {namespace children test_ns_777} msg] $msg } } -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} + +# TIP 278: secondary lookup disabled, results changed from {10 20} test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 @@ -644,9 +646,11 @@ test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { } } -body { namespace eval test_ns_1 { - list $v $test_ns_2::v + # list $v $test_ns_2::v + list [catch {set v} msg] $msg [catch {set test_ns_2::v} msg] $msg } -} -result {10 20} +} -result {1 {can't read "v": no such variable} 0 20} + test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -707,15 +711,17 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] } -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} + +# TIP 278: secondary lookup disabled, added catch, result changed from y test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { variable {} - set test_ns_1::(x) y + catch {set test_ns_1::(x) y} ::msg } - set test_ns_1::(x) -} -result y + list $::msg [catch {set test_ns_1::(x)} msg] $msg +} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}} test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -returnCodes error -body { @@ -888,13 +894,15 @@ test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { set x } } -result {777} + +# TIP 278: secondary lookup disabled, catch added, result changed from 314159 test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { variable x 777 unset x - set x ;# must be global x now + list [catch {set x} msg] $msg ;# must not be global x now } -} {314159} +} {1 {can't read "x": no such variable}} test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { set wuzzat @@ -906,6 +914,8 @@ test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { } set test_ns_1::a } {hello} + +# TIP 278: secondary lookup disabled, result changed from 1 test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} } -body { @@ -919,7 +929,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} - namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} -result 1 +} -result 0 catch {unset a} catch {unset x} @@ -1540,6 +1550,8 @@ test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { [namespace which ::test_ns_2::cmd2] } } -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} + +# TIP 278: secondary lookup disabled, catch added, result changed test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { @@ -1559,12 +1571,12 @@ test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { } } -body { namespace eval test_ns_3 { - list [namespace which -variable env] \ + list [catch {namespace which -variable env } msg] $msg \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}} test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} diff --git a/tests/parse.test b/tests/parse.test index 287c392..d36472e 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -376,12 +376,12 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { return "new result" } set handler1 [testasync create async1] - set aresult xxx - set acode yyy + set ::aresult xxx + set ::acode yyy } -cleanup { testasync delete } -body { - list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult + list [testevalobjv 0 testasync mark $handler1 original 0] $::acode $::aresult } -result {{new result} 0 original} test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg diff --git a/tests/tcltest.test b/tests/tcltest.test index 728a018..cd3c621 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -544,6 +544,7 @@ set notReadableDir [file join [temporaryDirectory] notreadable] set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable + switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 00333 diff --git a/tests/var.test b/tests/var.test index 9816d98..e32dbcf 100644 --- a/tests/var.test +++ b/tests/var.test @@ -247,10 +247,11 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 1 a {} vv namespace + testupvar 2 a {} vv namespace } p } + # Modified: that should create a global var according to the docs! list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { @@ -442,7 +443,7 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { set six 666 namespace eval test_ns_var { variable five 5 six - lappend a $five + lappend ::a $five } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six @@ -469,9 +470,9 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l set a "" namespace eval test_ns_var { variable eight 8 - lappend a $eight + lappend ::a $eight variable eight - lappend a $eight + lappend ::a $eight } set a } {8 8} -- cgit v0.12 From ca470c3d4eeb58156583417df4011087612bb186 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Oct 2017 14:32:52 +0000 Subject: more progress in code simplifications --- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 30 +++------- generic/tclCmdMZ.c | 4 -- generic/tclExecute.c | 163 ++++++-------------------------------------------- generic/tclInt.h | 8 +-- generic/tclObj.c | 30 +--------- generic/tclTimer.c | 2 - generic/tclUtil.c | 2 - 8 files changed, 30 insertions(+), 211 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 4c5ae68..c7ded6e 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -4266,7 +4266,7 @@ AddBasicBlockRangeToErrorInfo( Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - TclSetLongObj(lineNo, bbPtr->successor1->startLine); + TclSetWideIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e6022ac..a911028 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7442,12 +7442,12 @@ ExprAbsFunc( return TCL_ERROR; } - if (type == TCL_NUMBER_LONG) { - long l = *((const long *) ptr); + if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) { + Tcl_WideInt l = *((const Tcl_WideInt *) ptr); - if (l > (long)0) { + if (l > (Tcl_WideInt)0) { goto unChanged; - } else if (l == (long)0) { + } else if (l == (Tcl_WideInt)0) { const char *string = objv[1]->bytes; if (string) { while (*string != '0') { @@ -7459,11 +7459,11 @@ ExprAbsFunc( } } goto unChanged; - } else if (l == LONG_MIN) { - TclInitBignumFromLong(&big, l); + } else if (l == LLONG_MIN) { + TclInitBignumFromWideInt(&big, l); goto tooLarge; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); return TCL_OK; } @@ -7487,22 +7487,6 @@ ExprAbsFunc( return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - - if (w >= (Tcl_WideInt)0) { - goto unChanged; - } - if (w == LLONG_MIN) { - TclInitBignumFromWideInt(&big, w); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); - return TCL_OK; - } -#endif - if (type == TCL_NUMBER_BIG) { if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { Tcl_GetBignumFromObj(NULL, objv[1], &big); diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 522b76f..c984bbe 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1596,9 +1596,7 @@ StringIsCmd( /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || -#endif (objPtr->typePtr == &tclBignumType)) { break; } @@ -1633,9 +1631,7 @@ StringIsCmd( goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || -#endif (objPtr->typePtr == &tclBignumType)) { break; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b068e0d..3e64805 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1892,7 +1892,6 @@ TclIncrObj( TclSetLongObj(valuePtr, sum); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG { Tcl_WideInt w1 = (Tcl_WideInt) augend; Tcl_WideInt w2 = (Tcl_WideInt) addend; @@ -1905,7 +1904,6 @@ TclIncrObj( TclSetWideIntObj(valuePtr, w1 + w2); return TCL_OK; } -#endif } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { @@ -1925,7 +1923,6 @@ TclIncrObj( return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; @@ -1942,7 +1939,6 @@ TclIncrObj( return TCL_OK; } } -#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); @@ -3626,9 +3622,7 @@ TEBCresume( { Tcl_Obj *incrPtr; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; -#endif long increment; case INST_INCR_SCALAR1: @@ -3750,7 +3744,6 @@ TEBCresume( } goto doneIncr; } -#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3770,9 +3763,7 @@ TEBCresume( TclSetWideIntObj(objPtr, w+increment); } goto doneIncr; -#endif } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { Tcl_WideInt sum; @@ -3804,7 +3795,6 @@ TEBCresume( goto doneIncr; } } -#endif } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -5915,7 +5905,6 @@ TEBCresume( if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { type1 = TCL_NUMBER_WIDE; } -#ifndef TCL_WIDE_INT_IS_LONG } else if (type1 == TCL_NUMBER_WIDE) { /* value is between WIDE_MIN and WIDE_MAX */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ @@ -5923,7 +5912,6 @@ TEBCresume( if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { type1 = TCL_NUMBER_LONG; } -#endif } else if (type1 == TCL_NUMBER_BIG) { /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ @@ -6307,7 +6295,6 @@ TEBCresume( w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ @@ -6315,14 +6302,12 @@ TEBCresume( if (Overflowing(w1, w2, wResult)) { goto overflow; } -#endif goto wideResultOfArithmetic; case INST_SUB: w1 = (Tcl_WideInt) l1; w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction @@ -6336,7 +6321,6 @@ TEBCresume( if (Overflowing(w1, ~w2, wResult)) { goto overflow; } -#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { @@ -8124,14 +8108,6 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *valuePtr, /* The first operand on the stack. */ Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { -#define LONG_RESULT(l) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ - return objResultPtr; \ - } else { \ - Tcl_SetLongObj(valuePtr, l); \ - return NULL; \ - } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ @@ -8186,7 +8162,6 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } -#ifndef TCL_WIDE_INT_IS_LONG if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); if (type2 != TCL_NUMBER_BIG) { @@ -8231,7 +8206,6 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); return NULL; } -#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); @@ -8258,14 +8232,10 @@ ExecuteExtendedBinaryMathOp( */ switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: + case TCL_NUMBER_LONG: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); invalid = (mp_cmp_d(&big2, 0) == MP_LT); @@ -8345,11 +8315,9 @@ ExecuteExtendedBinaryMathOp( case TCL_NUMBER_LONG: zero = (*(const long *)ptr1 > 0L); break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); zero = (mp_cmp_d(&big1, 0) == MP_GT); @@ -8362,11 +8330,10 @@ ExecuteExtendedBinaryMathOp( if (zero) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } shift = (int)(*(const long *)ptr2); -#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ @@ -8377,11 +8344,10 @@ ExecuteExtendedBinaryMathOp( if (w1 >= (Tcl_WideInt)0) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } WIDE_RESULT(w1 >> shift); } -#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -8549,7 +8515,6 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -8570,7 +8535,6 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } -#endif l1 = *((const long *)ptr1); l2 = *((const long *)ptr2); @@ -8588,7 +8552,7 @@ ExecuteExtendedBinaryMathOp( /* Unused, here to silence compiler warning. */ lResult = 0; } - LONG_RESULT(lResult); + WIDE_RESULT(lResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; @@ -8627,13 +8591,11 @@ ExecuteExtendedBinaryMathOp( negativeExponent = (l2 < 0); oddExponent = (int) (l2 & 1); break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); @@ -8657,7 +8619,7 @@ ExecuteExtendedBinaryMathOp( return EXPONENT_OF_ZERO; case -1: if (oddExponent) { - LONG_RESULT(-1); + WIDE_RESULT(-1); } /* fallthrough */ case 1: @@ -8695,7 +8657,7 @@ ExecuteExtendedBinaryMathOp( if (!oddExponent) { return constants[1]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } } @@ -8720,14 +8682,9 @@ ExecuteExtendedBinaryMathOp( * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(1L << l2); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + if ((Tcl_WideUInt) l2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { WIDE_RESULT(((Tcl_WideInt) 1) << l2); } -#endif goto overflowExpon; } if (l1 == -2) { @@ -8737,14 +8694,9 @@ ExecuteExtendedBinaryMathOp( * Reduce small powers of 2 to shifts. */ - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(signum * (1L << l2)); - } -#if !defined(TCL_WIDE_INT_IS_LONG) if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); } -#endif goto overflowExpon; } #if (LONG_MAX == 0x7fffffff) @@ -8783,7 +8735,7 @@ ExecuteExtendedBinaryMathOp( lResult *= lResult; /* b**8 */ break; } - LONG_RESULT(lResult); + WIDE_RESULT(lResult); } if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize @@ -8796,7 +8748,7 @@ ExecuteExtendedBinaryMathOp( * table lookup. */ - LONG_RESULT(Exp32Value[base]); + WIDE_RESULT(Exp32Value[base]); } } if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize @@ -8811,7 +8763,7 @@ ExecuteExtendedBinaryMathOp( lResult = (oddExponent) ? -Exp32Value[base] : Exp32Value[base]; - LONG_RESULT(lResult); + WIDE_RESULT(lResult); } } #endif @@ -8819,10 +8771,8 @@ ExecuteExtendedBinaryMathOp( #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) if (type1 == TCL_NUMBER_LONG) { w1 = l1; -#ifndef TCL_WIDE_INT_IS_LONG } else if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); -#endif } else { goto overflowExpon; } @@ -9022,9 +8972,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif { /* * Check for overflow. @@ -9038,9 +8986,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; -#ifndef TCL_WIDE_INT_IS_LONG if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif { /* * Must check for overflow. The macro tests for overflows @@ -9164,12 +9110,10 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: -#ifndef TCL_WIDE_INT_IS_LONG if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } -#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ mp_neg(&big, &big); @@ -9180,13 +9124,6 @@ ExecuteExtendedUnaryMathOp( case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclInitBignumFromLong(&big, *(const long *) ptr); - break; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { @@ -9194,7 +9131,6 @@ ExecuteExtendedUnaryMathOp( } TclInitBignumFromWideInt(&big, w); break; -#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } @@ -9205,7 +9141,6 @@ ExecuteExtendedUnaryMathOp( Tcl_Panic("unexpected opcode"); return NULL; } -#undef LONG_RESULT #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT @@ -9237,31 +9172,24 @@ TclCompareTwoNumbers( ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; - long l1, l2; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; -#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - d1 = (double) l1; + d1 = (double) w1; /* * If the double has a fractional part, or if the long can be @@ -9269,7 +9197,7 @@ TclCompareTwoNumbers( * doubles. */ - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } @@ -9292,44 +9220,6 @@ TclCompareTwoNumbers( if (d2 > (double)LONG_MAX) { return MP_LT; } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - return MP_GT; - } - if (d2 > (double)LLONG_MAX) { - return MP_LT; - } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: @@ -9342,7 +9232,6 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } -#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -9352,21 +9241,6 @@ TclCompareTwoNumbers( doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - return MP_LT; - } - if (d1 > (double)LONG_MAX) { - return MP_GT; - } - l1 = (long) d1; - goto longCompare; -#ifndef TCL_WIDE_INT_IS_LONG case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; @@ -9382,7 +9256,6 @@ TclCompareTwoNumbers( } w1 = (Tcl_WideInt) d1; goto wideCompare; -#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; @@ -9410,10 +9283,8 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: -#endif case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; diff --git a/generic/tclInt.h b/generic/tclInt.h index feffeba..bb02ddf 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2720,9 +2720,7 @@ MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -#ifndef TCL_WIDE_INT_IS_LONG MODULE_SCOPE const Tcl_ObjType tclWideIntType; -#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -4545,11 +4543,13 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.wideValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ } while (0) -#ifndef TCL_WIDE_INT_IS_LONG +#ifdef TCL_WIDE_INT_IS_LONG +#define TclSetWideIntObj(objPtr, w) TclSetLongObj(objPtr, w) +#else #define TclSetWideIntObj(objPtr, w) \ do { \ TclInvalidateStringRep(objPtr); \ diff --git a/generic/tclObj.c b/generic/tclObj.c index bf1a2e6..78d7518 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -266,7 +266,6 @@ const Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#ifndef TCL_WIDE_INT_IS_LONG const Tcl_ObjType tclWideIntType = { "wideInt", /* name */ NULL, /* freeIntRepProc */ @@ -274,7 +273,6 @@ const Tcl_ObjType tclWideIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ @@ -403,9 +401,6 @@ TclInitObjSubsystem(void) /* For backward compatibility only ... */ Tcl_RegisterObjType(&oldBooleanType); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_RegisterObjType(&tclWideIntType); -#endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -1912,12 +1907,10 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } -#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1967,11 +1960,9 @@ TclSetBooleanFromAny( goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { goto badBoolean; } -#endif if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; @@ -2300,12 +2291,10 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } -#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2757,7 +2746,6 @@ Tcl_GetLongFromObj( *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX @@ -2776,7 +2764,6 @@ Tcl_GetLongFromObj( } goto tooLarge; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2815,9 +2802,7 @@ Tcl_GetLongFromObj( return TCL_OK; } } -#ifndef TCL_WIDE_INT_IS_LONG tooLarge: -#endif if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -2983,16 +2968,9 @@ Tcl_SetWideIntObj( if ((wideValue >= (Tcl_WideInt) LONG_MIN) && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, (long) wideValue); + TclSetLongObj(objPtr, wideValue); } else { -#ifndef TCL_WIDE_INT_IS_LONG TclSetWideIntObj(objPtr, wideValue); -#else - mp_int big; - - TclInitBignumFromWideInt(&big, wideValue); - Tcl_SetBignumObj(objPtr, &big); -#endif } } @@ -3025,12 +3003,10 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclIntType) { *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.wideValue; return TCL_OK; @@ -3330,13 +3306,11 @@ GetBignumFromObj( TclInitBignumFromLong(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3581,13 +3555,11 @@ TclGetNumberFromObj( *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 4bb5a35..279e110 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -819,9 +819,7 @@ Tcl_AfterObjCmd( */ if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG || objv[1]->typePtr == &tclWideIntType -#endif || objv[1]->typePtr == &tclBignumType || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK)) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e1877..198424f 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3769,9 +3769,7 @@ SetEndOffsetFromAny( return TCL_ERROR; } if ((objPtr->typePtr != &tclIntType) -#ifndef TCL_WIDE_INT_IS_LONG && (objPtr->typePtr != &tclWideIntType) -#endif ) { goto badIndexFormat; } -- cgit v0.12 From 3aa68b1a0bf5f1f0d08c76c900f86e3366c062bd Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 14:56:57 +0000 Subject: Patch to make changes to Tcl 9 prescribed by TIPs 330 and 336. This makes the Tcl_Interp struct fully opaque. No interp->result or interp->errorline --- doc/Interp.3 | 13 -- doc/SetResult.3 | 13 -- generic/tcl.h | 42 +----- generic/tclBasic.c | 109 ++------------- generic/tclHistory.c | 7 - generic/tclInt.h | 74 +++-------- generic/tclLoad.c | 11 ++ generic/tclResult.c | 368 ++------------------------------------------------- generic/tclStubLib.c | 5 +- generic/tclTest.c | 8 +- generic/tclUtil.c | 74 ----------- tests/result.test | 4 +- 12 files changed, 62 insertions(+), 666 deletions(-) diff --git a/doc/Interp.3 b/doc/Interp.3 index 731007b..daf76fb 100644 --- a/doc/Interp.3 +++ b/doc/Interp.3 @@ -33,19 +33,6 @@ the pointer as described below is no longer supported. The supported public routines \fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR, \fBTcl_GetErrorLine\fR must be used instead. .PP -For legacy programs and extensions no longer being maintained, compiles -against the Tcl 8.6 header files are only possible with the compiler -directives -.CS -#define USE_INTERP_RESULT -.CE -and/or -.CS -#define USE_INTERP_ERRORLINE -.CE -depending on which fields of the \fBTcl_Interp\fR struct are accessed. -These directives may be embedded in code or supplied via compiler options. -.PP The \fIresult\fR and \fIfreeProc\fR fields are used to return results or error messages from commands. This information is returned by command procedures back to \fBTcl_Eval\fR, diff --git a/doc/SetResult.3 b/doc/SetResult.3 index e5b81d7..545787c 100644 --- a/doc/SetResult.3 +++ b/doc/SetResult.3 @@ -197,19 +197,6 @@ It also sets \fIinterp->freeProc\fR to zero, but does not change \fIinterp->result\fR or clear error state. \fBTcl_FreeResult\fR is most commonly used when a procedure is about to replace one result value with another. -.SS "DIRECT ACCESS TO INTERP->RESULT" -.PP -It used to be legal for programs to -directly read and write \fIinterp->result\fR -to manipulate the interpreter result. The Tcl headers no longer -permit this access by default, and C code still doing this must -be updated to use supported routines \fBTcl_GetObjResult\fR, -\fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR. -As a migration aid, access can be restored with the compiler directive -.CS -#define USE_INTERP_RESULT -.CE -but this is meant only to offer life support to otherwise dead code. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how diff --git a/generic/tcl.h b/generic/tcl.h index 07d841d..47f0b01 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -492,39 +492,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ -typedef struct Tcl_Interp -#ifndef TCL_NO_DEPRECATED -{ - /* TIP #330: Strongly discourage extensions from using the string - * result. */ -#ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* Zero means the string result is statically - * allocated. TCL_DYNAMIC means it was - * allocated with ckalloc and should be freed - * with ckfree. Other values give the address - * of function to invoke to free the result. - * Tcl_Eval must free it before executing next - * command. */ -#else - char *resultDontUse; /* Don't use in extensions! */ - void (*freeProcDontUse) (char *); /* Don't use in extensions! */ -#endif -#ifdef USE_INTERP_ERRORLINE - int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); - /* When TCL_ERROR is returned, this gives the - * line number within the command where the - * error occurred (1 if first line). */ -#else - int errorLineDontUse; /* Don't use in extensions! */ -#endif -} -#endif /* !TCL_NO_DEPRECATED */ -Tcl_Interp; +typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; @@ -673,8 +641,6 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 -#define TCL_RESULT_SIZE 200 - /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): @@ -865,13 +831,7 @@ int Tcl_IsShared(Tcl_Obj *objPtr); */ typedef struct Tcl_SavedResult { - char *result; - Tcl_FreeProc *freeProc; Tcl_Obj *objResultPtr; - char *appendResult; - int appendAvl; - int appendUsed; - char resultSpace[TCL_RESULT_SIZE+1]; } Tcl_SavedResult; /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e6022ac..4f11a1a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -510,13 +510,12 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; -#ifdef TCL_NO_DEPRECATED - iPtr->result = &tclEmptyString; -#else - iPtr->result = iPtr->resultSpace; -#endif - iPtr->freeProc = NULL; + iPtr->legacyResult = NULL; + /* Special invalid value: Any attempt to free the legacy result + * will cause a crash. */ + iPtr->legacyFreeProc = (void (*) (void))-1; iPtr->errorLine = 0; + iPtr->stubTable = &tclStubs; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); @@ -574,12 +573,6 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; -#ifndef TCL_NO_DEPRECATED - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; -#endif - Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; @@ -608,9 +601,6 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); -#ifndef TCL_NO_DEPRECATED - iPtr->resultSpace[0] = 0; -#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -721,12 +711,6 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ /* - * Initialise the stub table pointer. - */ - - iPtr->stubTable = &tclStubs; - - /* * Initialize the ensemble error message rewriting support. */ @@ -1521,7 +1505,6 @@ DeleteInterpProc( */ Tcl_FreeResult(interp); - iPtr->result = NULL; Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -1543,12 +1526,6 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } -#ifndef TCL_NO_DEPRECATED - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - } -#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -2482,7 +2459,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl string result value. + * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, @@ -2523,13 +2500,6 @@ TclInvokeObjectCommand( } /* - * Move the interpreter's object result to the string result, then reset - * the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. */ @@ -3833,7 +3803,7 @@ Tcl_ListMathFuncs( * otherwise. * * Side effects: - * The interpreters object and string results are cleared. + * The interpreter's result is cleared. * *---------------------------------------------------------------------- */ @@ -3845,8 +3815,8 @@ TclInterpReady( register Interp *iPtr = (Interp *) interp; /* - * Reset both the interpreter's string and object results and clear out - * any previous error information. + * Reset the interpreter's result and clear out any previous error + * information. */ Tcl_ResetResult(interp); @@ -4426,24 +4396,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { - Interp *iPtr = (Interp *) interp; NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; - /* - * If the interpreter has a non-empty string result, the result object is - * either empty or stale because some function set interp->result - * directly. If so, move the string result to the result object, then - * reset the string result. - * - * This only needs to be done for the first item in the list: all other - * are for NR function calls, and those are Tcl_Obj based. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } - while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; @@ -5911,16 +5866,7 @@ Tcl_Eval( * previous call to Tcl_CreateInterp). */ const char *script) /* Pointer to TCL command to execute. */ { - int code = Tcl_EvalEx(interp, script, -1, 0); - - /* - * For backwards compatibility with old C code that predates the object - * system in Tcl 8.0, we have to mirror the object result back into the - * string result (some callers may expect it there). - */ - - (void) Tcl_GetStringResult(interp); - return code; + return Tcl_EvalEx(interp, script, -1, 0); } /* @@ -6343,9 +6289,6 @@ Tcl_ExprLong( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -6372,9 +6315,6 @@ Tcl_ExprDouble( result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ - if (result != TCL_OK) { - (void) Tcl_GetStringResult(interp); - } } return result; } @@ -6400,14 +6340,6 @@ Tcl_ExprBoolean( Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); - if (result != TCL_OK) { - /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - } return result; } } @@ -6723,11 +6655,6 @@ Tcl_ExprString( } } - /* - * Force the string rep of the interp result. - */ - - (void) Tcl_GetStringResult(interp); return code; } @@ -6834,19 +6761,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { - /* - * The interp's string result is set, apparently by some extension - * making a deprecated direct write to it. That extension may - * expect interp->result to continue to be set, so we'll take - * special pains to avoid clearing it, until we drop support for - * interp->result completely. - */ - - iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { - iPtr->errorInfo = iPtr->objResultPtr; - } + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -6924,7 +6839,7 @@ Tcl_VarEvalVA( * * Results: * A standard Tcl return result. An error message or other result may be - * left in interp->result. + * left in the interp. * * Side effects: * Depends on what was done by the command. diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 47806d4..0c8201a 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -74,13 +74,6 @@ Tcl_RecordAndEval( result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* - * Move the interpreter's object result to the string result, then - * reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* * Discard the Tcl object created to hold the command. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 0b5ff0c..6278267 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1773,41 +1773,31 @@ typedef struct AllocCache { typedef struct Interp { /* - * Note: the first three fields must match exactly the fields in a - * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the - * other. - * - * The interpreter's result is held in both the string and the - * objResultPtr fields. These fields hold, respectively, the result's - * string or object value. The interpreter's result is always in the - * result field if that is non-empty, otherwise it is in objResultPtr. - * The two fields are kept consistent unless some C code sets - * interp->result directly. Programs should not access result and - * objResultPtr directly; instead, they should always get and set the - * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and - * Tcl_GetStringResult. See the SetResult man page for details. + * The first two fields were named "result" and "freeProc" in earlier + * verions of Tcl. They are no longer used within Tcl, and are no + * longer available to be accessed by extensions. However, they cannot + * be removed. Why? There is a deployed base of stub-enabled extensions + * that query the value of iPtr->stubTable. For them to continue to work, + * the location of the field "stubTable" within the Interp struct cannot + * change. The most robust way to assure that is to leave all fields up to + * that one undisturbed. */ - char *result; /* If the last command returned a string - * result, this points to it. Should not be - * accessed directly; see comment above. */ - Tcl_FreeProc *freeProc; /* Zero means a string result is statically - * allocated. TCL_DYNAMIC means string result - * was allocated with ckalloc and should be - * freed with ckfree. Other values give - * address of procedure to invoke to free the - * string result. Tcl_Eval must free it before - * executing next command. */ + const char *legacyResult; + void (*legacyFreeProc) (void); int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. On - * previous versions of Tcl this is a pointer - * to the objResultPtr or a pointer to a - * buckets array in a hash table. We therefore - * have to do some careful checking before we - * can use this. */ + /* Pointer to the exported Tcl stub table. In + * ancient pre-8.1 versions of Tcl this was a + * pointer to the objResultptr or a pointer to a + * buckets array in a hash table. Deployed stubs + * enabled extensions check for a NULL pointer value + * and for a TCL_STUBS_MAGIC value to verify they + * are not [load]ing into one of those pre-stubs + * interps. + */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ @@ -1858,25 +1848,6 @@ typedef struct Interp { * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ /* - * Information used by Tcl_AppendResult to keep track of partial results. - * See Tcl_AppendResult code for details. - */ - -#ifndef TCL_NO_DEPRECATED - char *appendResult; /* Storage space for results generated by - * Tcl_AppendResult. Ckalloc-ed. NULL means - * not yet allocated. */ - int appendAvl; /* Total amount of space available at - * partialResult. */ - int appendUsed; /* Number of non-null bytes currently stored - * at partialResult. */ -#else - char *appendResultDontUse; - int appendAvlDontUse; - int appendUsedDontUse; -#endif - - /* * Information about packages. Used only in tclPkg.c. */ @@ -1898,7 +1869,6 @@ typedef struct Interp { * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ - int unused1; /* No longer used (was termOffset) */ LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the @@ -1936,12 +1906,6 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#ifndef TCL_NO_DEPRECATED - char resultSpace[TCL_RESULT_SIZE+1]; - /* Static space holding small results. */ -#else - char resultSpaceDontUse[TCL_RESULT_SIZE+1]; -#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index e0bb5ef..87bb1c1 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -470,6 +470,17 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { + Interp *iPtr = (Interp *) target; + if (iPtr->legacyResult && !iPtr->legacyFreeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); + iPtr->legacyResult = NULL; + iPtr->legacyFreeProc = (void (*) (void))-1; + } Tcl_TransferResult(target, code, interp); goto done; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 57a6de5..0f44ed2 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,9 +27,6 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); -#ifndef TCL_NO_DEPRECATED -static void SetupAppendBuffer(Interp *iPtr, int newSpace); -#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in @@ -250,44 +247,6 @@ Tcl_SaveResult( statePtr->objResultPtr = iPtr->objResultPtr; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - - /* - * Save the string result. - */ - - statePtr->freeProc = iPtr->freeProc; - if (iPtr->result == iPtr->resultSpace) { - /* - * Copy the static string data out of the interp buffer. - */ - - statePtr->result = statePtr->resultSpace; - strcpy(statePtr->result, iPtr->result); - statePtr->appendResult = NULL; - } else if (iPtr->result == iPtr->appendResult) { - /* - * Move the append buffer out of the interp. - */ - - statePtr->appendResult = iPtr->appendResult; - statePtr->appendAvl = iPtr->appendAvl; - statePtr->appendUsed = iPtr->appendUsed; - statePtr->result = statePtr->appendResult; - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - iPtr->appendUsed = 0; - } else { - /* - * Move the dynamic or static string out of the interpreter. - */ - - statePtr->result = iPtr->result; - statePtr->appendResult = NULL; - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - iPtr->freeProc = 0; } /* @@ -319,39 +278,6 @@ Tcl_RestoreResult( Tcl_ResetResult(interp); /* - * Restore the string result. - */ - - iPtr->freeProc = statePtr->freeProc; - if (statePtr->result == statePtr->resultSpace) { - /* - * Copy the static string data into the interp buffer. - */ - - iPtr->result = iPtr->resultSpace; - strcpy(iPtr->result, statePtr->result); - } else if (statePtr->result == statePtr->appendResult) { - /* - * Move the append buffer back into the interp. - */ - - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - - iPtr->appendResult = statePtr->appendResult; - iPtr->appendAvl = statePtr->appendAvl; - iPtr->appendUsed = statePtr->appendUsed; - iPtr->result = iPtr->appendResult; - } else { - /* - * Move the dynamic or static string back into the interpreter. - */ - - iPtr->result = statePtr->result; - } - - /* * Restore the object result. */ @@ -383,14 +309,6 @@ Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { TclDecrRefCount(statePtr->objResultPtr); - - if (statePtr->result == statePtr->appendResult) { - ckfree(statePtr->appendResult); - } else if (statePtr->freeProc == TCL_DYNAMIC) { - ckfree(statePtr->result); - } else if (statePtr->freeProc) { - statePtr->freeProc(statePtr->result); - } } /* @@ -420,49 +338,15 @@ Tcl_SetResult( * TCL_STATIC, TCL_VOLATILE, or the address of * a Tcl_FreeProc such as free. */ { - Interp *iPtr = (Interp *) interp; - register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; - char *oldResult = iPtr->result; - - if (result == NULL) { - iPtr->resultSpace[0] = 0; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } else if (freeProc == TCL_VOLATILE) { - int length = strlen(result); - - if (length > TCL_RESULT_SIZE) { - iPtr->result = ckalloc(length + 1); - iPtr->freeProc = TCL_DYNAMIC; - } else { - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } - memcpy(iPtr->result, result, (unsigned) length+1); - } else { - iPtr->result = (char *) result; - iPtr->freeProc = freeProc; + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + if (result == NULL || freeProc == NULL || freeProc == TCL_VOLATILE) { + return; } - - /* - * If the old result was dynamically-allocated, free it up. Do it here, - * rather than at the beginning, in case the new result value was part of - * the old result value. - */ - - if (oldFreeProc != 0) { - if (oldFreeProc == TCL_DYNAMIC) { - ckfree(oldResult); - } else { - oldFreeProc(oldResult); - } + if (freeProc == TCL_DYNAMIC) { + ckfree(result); + } else { + (*freeProc)(result); } - - /* - * Reset the object result since we just set the string result. - */ - - ResetObjResult(iPtr); } #endif /* !TCL_NO_DEPRECATED */ @@ -488,20 +372,7 @@ Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; -#ifdef TCL_NO_DEPRECATED return Tcl_GetString(iPtr->objResultPtr); -#else - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), - TCL_VOLATILE); - } - return iPtr->result; -#endif } /* @@ -542,23 +413,6 @@ Tcl_SetObjResult( */ TclDecrRefCount(oldObjResult); - -#ifndef TCL_NO_DEPRECATED - /* - * Reset the string result since we just set the result object. - */ - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif } /* @@ -587,34 +441,6 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED - Tcl_Obj *objResultPtr; - int length; - - /* - * If the string result is non-empty, move the string result to the object - * result, then reset the string result. - */ - - if (iPtr->result[0] != 0) { - ResetObjResult(iPtr); - - objResultPtr = iPtr->objResultPtr; - length = strlen(iPtr->result); - TclInitStringRep(objResultPtr, iPtr->result, length); - - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->result[0] = 0; - } -#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } @@ -651,23 +477,6 @@ Tcl_AppendResultVA( } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); - - /* - * Strictly we should call Tcl_GetStringResult(interp) here to make sure - * that interp->result is correct according to the old contract, but that - * makes the performance of much code (e.g. in Tk) absolutely awful. So we - * leave it out; code that really wants interp->result can just insert the - * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] - */ - -#ifdef USE_INTERP_RESULT - /* - * Ensure that the interp->result is legal so old Tcl 7.* code still - * works. There's still embarrasingly much of it about... - */ - - (void) Tcl_GetStringResult(interp); -#endif /* USE_INTERP_RESULT */ } /* @@ -733,7 +542,6 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; -#ifdef TCL_NO_DEPRECATED Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); const char *bytes; @@ -747,134 +555,7 @@ Tcl_AppendElement( } Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); Tcl_DecrRefCount(listPtr); -#else - char *dst; - int size; - int flags; - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - /* - * See how much space is needed, and grow the append buffer if needed to - * accommodate the list element. - */ - - size = Tcl_ScanElement(element, &flags) + 1; - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, size+iPtr->appendUsed); - } - - /* - * Convert the string into a list element and copy it to the buffer that's - * forming, with a space separator if needed. - */ - - dst = iPtr->appendResult + iPtr->appendUsed; - if (TclNeedSpace(iPtr->appendResult, dst)) { - iPtr->appendUsed++; - *dst = ' '; - dst++; - - /* - * If we need a space to separate this element from preceding stuff, - * then this element will not lead a list, and need not have it's - * leading '#' quoted. - */ - - flags |= TCL_DONT_QUOTE_HASH; - } - iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); -#endif /* !TCL_NO_DEPRECATED */ -} - -/* - *---------------------------------------------------------------------- - * - * SetupAppendBuffer -- - * - * This function makes sure that there is an append buffer properly - * initialized, if necessary, from the interpreter's result, and that it - * has at least enough room to accommodate newSpace new bytes of - * information. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_DEPRECATED -static void -SetupAppendBuffer( - Interp *iPtr, /* Interpreter whose result is being set up. */ - int newSpace) /* Make sure that at least this many bytes of - * new information may be added. */ -{ - int totalSpace; - - /* - * Make the append buffer larger, if that's necessary, then copy the - * result into the append buffer and make the append buffer the official - * Tcl result. - */ - - if (iPtr->result != iPtr->appendResult) { - /* - * If an oversized buffer was used recently, then free it up so we go - * back to a smaller buffer. This avoids tying up memory forever after - * a large operation. - */ - - if (iPtr->appendAvl > 500) { - ckfree(iPtr->appendResult); - iPtr->appendResult = NULL; - iPtr->appendAvl = 0; - } - iPtr->appendUsed = strlen(iPtr->result); - } else if (iPtr->result[iPtr->appendUsed] != 0) { - /* - * Most likely someone has modified a result created by - * Tcl_AppendResult et al. so that it has a different size. Just - * recompute the size. - */ - - iPtr->appendUsed = strlen(iPtr->result); - } - - totalSpace = newSpace + iPtr->appendUsed; - if (totalSpace >= iPtr->appendAvl) { - char *new; - - if (totalSpace < 100) { - totalSpace = 200; - } else { - totalSpace *= 2; - } - new = ckalloc(totalSpace); - strcpy(new, iPtr->result); - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - iPtr->appendResult = new; - iPtr->appendAvl = totalSpace; - } else if (iPtr->result != iPtr->appendResult) { - strcpy(iPtr->appendResult, iPtr->result); - } - - Tcl_FreeResult((Tcl_Interp *) iPtr); - iPtr->result = iPtr->appendResult; } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -882,18 +563,16 @@ SetupAppendBuffer( * Tcl_FreeResult -- * * This function frees up the memory associated with an interpreter's - * string result. It also resets the interpreter's result object. - * Tcl_FreeResult is most commonly used when a function is about to - * replace one result value with another. + * result, resetting the interpreter's result object. Tcl_FreeResult is + * most commonly used when a function is about to replace one result + * value with another. * * Results: * None. * * Side effects: - * Frees the memory associated with interp's string result and sets - * interp->freeProc to zero, but does not change interp->result or clear - * error state. Resets interp's result object to an unshared empty - * object. + * Frees the memory associated with interp's result but does not change + * any part of the error dictionary. * *---------------------------------------------------------------------- */ @@ -904,17 +583,6 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - -#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } @@ -944,18 +612,6 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); -#ifndef TCL_NO_DEPRECATED - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - ckfree(iPtr->result); - } else { - iPtr->freeProc(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 5261591..a135465 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -66,8 +66,9 @@ Tcl_InitStubs( */ if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; - iPtr->freeProc = 0; + iPtr->legacyResult + = "interpreter uses an incompatible stubs mechanism"; + iPtr->legacyFreeProc = 0; /* TCL_STATIC */ return NULL; } diff --git a/generic/tclTest.c b/generic/tclTest.c index ebd90ae..6e357c2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5187,7 +5187,6 @@ TestsaveresultCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - Interp* iPtr = (Interp*) interp; int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; @@ -5255,12 +5254,9 @@ TestsaveresultCmd( } switch ((enum options) index) { - case RESULT_DYNAMIC: { - int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; - - Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); + case RESULT_DYNAMIC: + Tcl_AppendElement(interp, freeCount ? "freed" : "leak"); break; - } case RESULT_OBJECT: Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr ? "same" : "different"); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 608cd15..3f809d5 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2923,86 +2923,12 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { -#ifdef TCL_NO_DEPRECATED Tcl_Obj *obj = Tcl_GetObjResult(interp); const char *bytes = TclGetString(obj); Tcl_DStringFree(dsPtr); Tcl_DStringAppend(dsPtr, bytes, obj->length); Tcl_ResetResult(interp); -#else - Interp *iPtr = (Interp *) interp; - - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); - } - - /* - * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no string result, we only have to deal with two cases: - * - * 1. When the string rep is the empty string, when we don't copy but - * instead use the staticSpace in the DString to hold an empty string. - - * 2. When the string rep is not there or there's a real string rep, when - * we use Tcl_GetString to fetch (or generate) the string rep - which - * we know to have been allocated with ckalloc() - and use it to - * populate the DString space. Then, we free the internal rep. and set - * the object's string representation back to the canonical empty - * string. - */ - - if (!iPtr->result[0] && iPtr->objResultPtr - && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == &tclEmptyString) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->string[0] = 0; - dsPtr->length = 0; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = TclGetString(iPtr->objResultPtr); - dsPtr->length = iPtr->objResultPtr->length; - dsPtr->spaceAvl = dsPtr->length + 1; - TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = &tclEmptyString; - iPtr->objResultPtr->length = 0; - } - return; - } - - /* - * If the string result is empty, move the object result to the string - * result, then reset the object result. - */ - - (void) Tcl_GetStringResult(interp); - - dsPtr->length = strlen(iPtr->result); - if (iPtr->freeProc != NULL) { - if (iPtr->freeProc == TCL_DYNAMIC) { - dsPtr->string = iPtr->result; - dsPtr->spaceAvl = dsPtr->length+1; - } else { - dsPtr->string = ckalloc(dsPtr->length+1); - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - iPtr->freeProc(iPtr->result); - } - dsPtr->spaceAvl = dsPtr->length+1; - iPtr->freeProc = NULL; - } else { - if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { - dsPtr->string = dsPtr->staticSpace; - dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - } else { - dsPtr->string = ckalloc(dsPtr->length+1); - dsPtr->spaceAvl = dsPtr->length + 1; - } - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); - } - - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -#endif /* !TCL_NO_DEPRECATED */ } /* diff --git a/tests/result.test b/tests/result.test index 859e546..1eff46e 100644 --- a/tests/result.test +++ b/tests/result.test @@ -31,7 +31,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result presentOrFreed} +} {dynamic result freed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -43,7 +43,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 presentOrFreed} +} {42 freed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} -- cgit v0.12 From 9e80ee005ea69417d49687f4e51dd80bba72deee Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 15:15:06 +0000 Subject: tidying --- generic/tcl.h | 5 ++--- generic/tclBasic.c | 3 +-- generic/tclInt.h | 4 ++-- generic/tclLoad.c | 22 +++++++++++----------- generic/tclStubLib.c | 3 +-- generic/tclUtil.c | 6 +++--- 6 files changed, 20 insertions(+), 23 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 47f0b01..0d40f41 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -825,9 +825,8 @@ int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- - * The following structure contains the state needed by Tcl_SaveResult. No-one - * outside of Tcl should access any of these fields. This structure is - * typically allocated on the stack. + * The following type contains the state needed by Tcl_SaveResult. This + * structure is typically allocated on the stack. */ typedef struct Tcl_SavedResult { diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4f11a1a..32808b8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6654,7 +6654,6 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } - return code; } @@ -6761,7 +6760,7 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - iPtr->errorInfo = iPtr->objResultPtr; + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6278267..9b5efd1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1774,7 +1774,7 @@ typedef struct AllocCache { typedef struct Interp { /* * The first two fields were named "result" and "freeProc" in earlier - * verions of Tcl. They are no longer used within Tcl, and are no + * versions of Tcl. They are no longer used within Tcl, and are no * longer available to be accessed by extensions. However, they cannot * be removed. Why? There is a deployed base of stub-enabled extensions * that query the value of iPtr->stubTable. For them to continue to work, @@ -1792,7 +1792,7 @@ typedef struct Interp { /* Pointer to the exported Tcl stub table. In * ancient pre-8.1 versions of Tcl this was a * pointer to the objResultptr or a pointer to a - * buckets array in a hash table. Deployed stubs + * buckets array in a hash table. Deployed stubs * enabled extensions check for a NULL pointer value * and for a TCL_STUBS_MAGIC value to verify they * are not [load]ing into one of those pre-stubs diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 87bb1c1..4e6ee2f 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -470,17 +470,17 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { - Interp *iPtr = (Interp *) target; - if (iPtr->legacyResult && !iPtr->legacyFreeProc) { - /* - * A call to Tcl_InitStubs() determined the caller extension and - * this interp are incompatible in their stubs mechanisms, and - * recorded the error in the oldest legacy place we have to do so. - */ - Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); - iPtr->legacyResult = NULL; - iPtr->legacyFreeProc = (void (*) (void))-1; - } + Interp *iPtr = (Interp *) target; + if (iPtr->legacyResult && !iPtr->legacyFreeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); + iPtr->legacyResult = NULL; + iPtr->legacyFreeProc = (void (*) (void))-1; + } Tcl_TransferResult(target, code, interp); goto done; } diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index a135465..b26fb01 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -66,8 +66,7 @@ Tcl_InitStubs( */ if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->legacyResult - = "interpreter uses an incompatible stubs mechanism"; + iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; iPtr->legacyFreeProc = 0; /* TCL_STATIC */ return NULL; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 3f809d5..5c0f55c 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2923,11 +2923,11 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { - Tcl_Obj *obj = Tcl_GetObjResult(interp); - const char *bytes = TclGetString(obj); + int length; + char *bytes = TclGetStringFromObj(Tcl_GetObjResult(interp), &length); Tcl_DStringFree(dsPtr); - Tcl_DStringAppend(dsPtr, bytes, obj->length); + Tcl_DStringAppend(dsPtr, bytes, length); Tcl_ResetResult(interp); } -- cgit v0.12 From 312263821fb4b272cff0d1b7de06da1260a75112 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 15:25:36 +0000 Subject: tidy --- generic/tclInt.h | 18 +++++++++--------- generic/tclResult.c | 5 ++++- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9b5efd1..84c8f5f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1789,15 +1789,15 @@ typedef struct Interp { * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. In - * ancient pre-8.1 versions of Tcl this was a - * pointer to the objResultptr or a pointer to a - * buckets array in a hash table. Deployed stubs - * enabled extensions check for a NULL pointer value - * and for a TCL_STUBS_MAGIC value to verify they - * are not [load]ing into one of those pre-stubs - * interps. - */ + /* Pointer to the exported Tcl stub table. In + * ancient pre-8.1 versions of Tcl this was a + * pointer to the objResultPtr or a pointer to a + * buckets array in a hash table. Deployed stubs + * enabled extensions check for a NULL pointer value + * and for a TCL_STUBS_MAGIC value to verify they + * are not [load]ing into one of those pre-stubs + * interps. + */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ diff --git a/generic/tclResult.c b/generic/tclResult.c index 0f44ed2..fb97e0b 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -372,6 +372,7 @@ Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; + return Tcl_GetString(iPtr->objResultPtr); } @@ -441,6 +442,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; + return iPtr->objResultPtr; } @@ -572,7 +574,8 @@ Tcl_AppendElement( * * Side effects: * Frees the memory associated with interp's result but does not change - * any part of the error dictionary. + * any part of the error dictionary (i.e., the errorinfo and errorcode + * remain the same). * *---------------------------------------------------------------------- */ -- cgit v0.12 From 9a322ef01682c544f3a875c9c5f961b4428a9aee Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 15:35:58 +0000 Subject: tidy? --- generic/tclInt.h | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 84c8f5f..6f87abc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1789,15 +1789,15 @@ typedef struct Interp { * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. In - * ancient pre-8.1 versions of Tcl this was a - * pointer to the objResultPtr or a pointer to a - * buckets array in a hash table. Deployed stubs - * enabled extensions check for a NULL pointer value - * and for a TCL_STUBS_MAGIC value to verify they - * are not [load]ing into one of those pre-stubs - * interps. - */ + /* Pointer to the exported Tcl stub table. In + * ancient pre-8.1 versions of Tcl this was a + * pointer to the objResultPtr or a pointer to a + * buckets array in a hash table. Deployed stubs + * enabled extensions check for a NULL pointer value + * and for a TCL_STUBS_MAGIC value to verify they + * are not [load]ing into one of those pre-stubs + * interps. + */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ -- cgit v0.12 From b8b341fea6c287382301eb3de4309197d4390b60 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 30 Oct 2017 16:46:49 +0000 Subject: Fix some pointer arthemeric (only visible on big-endian systems) --- generic/tclExecute.c | 53 ++++++++++++++++++++++++---------------------------- generic/tclInt.h | 19 ++++++++++++++++++- generic/tclObj.c | 7 +------ 3 files changed, 43 insertions(+), 36 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 3e64805..ee9e2e0 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1878,8 +1878,8 @@ TclIncrObj( } if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const long *) ptr1); - long addend = *((const long *) ptr2); + long augend = *((const Tcl_WideInt *) ptr1); + long addend = *((const Tcl_WideInt *) ptr2); long sum = augend + addend; /* @@ -3722,7 +3722,7 @@ TEBCresume( objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); + long augend = *((const Tcl_WideInt *)ptr); long sum = augend + increment; /* @@ -5897,19 +5897,14 @@ TEBCresume( case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; - } else if (type1 == TCL_NUMBER_LONG) { + } else if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { /* value is between LONG_MIN and LONG_MAX */ /* [string is integer] is -UINT_MAX to UINT_MAX range */ int i; if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { type1 = TCL_NUMBER_WIDE; - } - } else if (type1 == TCL_NUMBER_WIDE) { - /* value is between WIDE_MIN and WIDE_MAX */ - /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ - int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + } else { type1 = TCL_NUMBER_LONG; } } else if (type1 == TCL_NUMBER_BIG) { @@ -5957,8 +5952,8 @@ TEBCresume( goto convertComparison; } if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + l1 = *((const Tcl_WideInt *)ptr1); + l2 = *((const Tcl_WideInt *)ptr2); compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); @@ -6036,8 +6031,8 @@ TEBCresume( */ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + l1 = *((const Tcl_WideInt *)ptr1); + l2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_MOD: @@ -6287,8 +6282,8 @@ TEBCresume( if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { Tcl_WideInt w1, w2, wResult; - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + l1 = *((const Tcl_WideInt *)ptr1); + l2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_ADD: @@ -6434,7 +6429,7 @@ TEBCresume( goto gotError; } if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); + l1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, ~l1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); @@ -6471,7 +6466,7 @@ TEBCresume( TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); + l1 = *((const Tcl_WideInt *) ptr1); if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l1); @@ -8150,7 +8145,7 @@ ExecuteExtendedBinaryMathOp( l2 = 0; /* silence gcc warning */ if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); + l2 = *((const Tcl_WideInt *)ptr2); if (l2 == 0) { return DIVIDED_BY_ZERO; } @@ -8255,7 +8250,7 @@ ExecuteExtendedBinaryMathOp( * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + if ((type1==TCL_NUMBER_LONG) && (*((const Tcl_WideInt *)ptr1) == (long)0)) { return constants[0]; } @@ -8269,7 +8264,7 @@ ExecuteExtendedBinaryMathOp( */ if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { + || (*((const Tcl_WideInt *)ptr2) > (long) INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the @@ -8281,7 +8276,7 @@ ExecuteExtendedBinaryMathOp( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } - shift = (int)(*((const long *)ptr2)); + shift = (int)(*((const Tcl_WideInt *)ptr2)); /* * Handle shifts within the native wide range. @@ -8302,7 +8297,7 @@ ExecuteExtendedBinaryMathOp( */ if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { + || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could @@ -8313,7 +8308,7 @@ ExecuteExtendedBinaryMathOp( switch (type1) { case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); + zero = (*(const Tcl_WideInt *)ptr1 > 0L); break; case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); @@ -8332,7 +8327,7 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(-1); } - shift = (int)(*(const long *)ptr2); + shift = (int)(*(const Tcl_WideInt *)ptr2); /* * Handle shifts within the native wide range. @@ -8535,8 +8530,8 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + l1 = *((const Tcl_WideInt *)ptr1); + l2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: @@ -8570,7 +8565,7 @@ ExecuteExtendedBinaryMathOp( } l1 = l2 = 0; if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *) ptr2); + l2 = *((const Tcl_WideInt *) ptr2); if (l2 == 0) { /* * Anything to the zero power is 1. @@ -8606,7 +8601,7 @@ ExecuteExtendedBinaryMathOp( } if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *)ptr1); + l1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { if (type1 == TCL_NUMBER_LONG) { diff --git a/generic/tclInt.h b/generic/tclInt.h index bb02ddf..3799287 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4589,11 +4589,25 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) +#ifndef TCL_WIDE_INT_IS_LONG +#define TclNewWideObj(objPtr, i) \ + do { \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ + (objPtr)->typePtr = &tclWideIntType; \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) +#else +#define TclNewWideObj(objPtr, i) TclNewLongObj(objPtr, i) +#endif #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ @@ -4619,6 +4633,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclNewLongObj(objPtr, l) \ (objPtr) = Tcl_NewLongObj(l) +#define TclNewWideObj(objPtr, w) \ + (objPtr) = Tcl_NewWideIntObj(w) + #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) diff --git a/generic/tclObj.c b/generic/tclObj.c index 78d7518..e4613ba 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3550,12 +3550,7 @@ TclGetNumberFromObj( *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } - if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.wideValue; - return TCL_OK; - } - if (objPtr->typePtr == &tclWideIntType) { + if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclWideIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; -- cgit v0.12 From b0a9f6c55b529b1b7ad08fabce66218512634149 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 09:48:57 +0000 Subject: Simplify implementation of Tcl_SaveResult/Tcl_RestoreResult/Tcl_DiscardResult by no longer assuming that Tcl_SavedResult is a struct. Backported from "novem" branch. --- doc/SaveResult.3 | 4 ++-- generic/tcl.h | 8 +++----- generic/tclDecls.h | 10 +++++----- generic/tclResult.c | 6 +++--- 4 files changed, 13 insertions(+), 15 deletions(-) diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index b2270a2..6dd6cb6 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -54,9 +54,9 @@ is called, Tcl will take care of memory management. .PP The second triplet stores the snapshot of only the interpreter result (not its complete state) in memory allocated by the caller. -These routines are passed a pointer to a \fBTcl_SavedResult\fR structure +These routines are passed a pointer to \fBTcl_SavedResult\fR that is used to store enough information to restore the interpreter result. -This structure can be allocated on the stack of the calling +\fBTcl_SavedResult\fR can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB\-errorcode\fR or \fB\-errorinfo\fR return options, when an error is in progress). diff --git a/generic/tcl.h b/generic/tcl.h index 0d40f41..6d4e6bb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -825,13 +825,11 @@ int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- - * The following type contains the state needed by Tcl_SaveResult. This - * structure is typically allocated on the stack. + * The following type contains the state needed by Tcl_SaveResult. It + * is typically allocated on the stack. */ -typedef struct Tcl_SavedResult { - Tcl_Obj *objResultPtr; -} Tcl_SavedResult; +typedef Tcl_Obj *Tcl_SavedResult; /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 464fc0f..17d60a8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3888,20 +3888,20 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_SaveResult #define Tcl_SaveResult(interp, statePtr) \ do { \ - (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount((statePtr)->objResultPtr); \ + *(statePtr) = Tcl_GetObjResult(interp); \ + Tcl_IncrRefCount(*(statePtr)); \ Tcl_SetObjResult(interp, Tcl_NewObj()); \ } while(0) #undef Tcl_RestoreResult #define Tcl_RestoreResult(interp, statePtr) \ do { \ Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ - Tcl_DecrRefCount((statePtr)->objResultPtr); \ + Tcl_SetObjResult(interp, *(statePtr)); \ + Tcl_DecrRefCount(*(statePtr)); \ } while(0) #undef Tcl_DiscardResult #define Tcl_DiscardResult(statePtr) \ - Tcl_DecrRefCount((statePtr)->objResultPtr) + Tcl_DecrRefCount(*(statePtr)) #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ diff --git a/generic/tclResult.c b/generic/tclResult.c index fb97e0b..5a8ef61 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -244,7 +244,7 @@ Tcl_SaveResult( * reference. Put an empty object into the interpreter. */ - statePtr->objResultPtr = iPtr->objResultPtr; + *statePtr = iPtr->objResultPtr; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); } @@ -282,7 +282,7 @@ Tcl_RestoreResult( */ Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = statePtr->objResultPtr; + iPtr->objResultPtr = *statePtr; } /* @@ -308,7 +308,7 @@ void Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { - TclDecrRefCount(statePtr->objResultPtr); + Tcl_DecrRefCount(*statePtr); } /* -- cgit v0.12 From c8fbbd8f3eef002f8913793c394ddc6f9e416da1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 11:37:29 +0000 Subject: Fix 2 failing test-cases, broken by some earlier commit --- generic/tclExecute.c | 68 ++++++++++++++++++++++++++-------------------------- 1 file changed, 34 insertions(+), 34 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ee9e2e0..76e1496 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5893,13 +5893,15 @@ TEBCresume( ClientData ptr1, ptr2; int type1, type2; long l1, l2, lResult; + Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; } else if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { - /* value is between LONG_MIN and LONG_MAX */ + /* value is between WIDE_MIN and WIDE_MAX */ /* [string is integer] is -UINT_MAX to UINT_MAX range */ + /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ int i; if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { @@ -5909,10 +5911,14 @@ TEBCresume( } } else if (type1 == TCL_NUMBER_BIG) { /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ + /* [string is integer] is -UINT_MAX to UINT_MAX range */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + int i; Tcl_WideInt w; - if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { + type1 = TCL_NUMBER_LONG; + } else if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { type1 = TCL_NUMBER_WIDE; } } @@ -5951,10 +5957,10 @@ TEBCresume( compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const Tcl_WideInt *)ptr1); - l2 = *((const Tcl_WideInt *)ptr2); - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } @@ -6280,15 +6286,13 @@ TEBCresume( */ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - - l1 = *((const Tcl_WideInt *)ptr1); - l2 = *((const Tcl_WideInt *)ptr2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); + l1 = w1; + l2 = w2; switch (*pc) { case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 + w2; /* * Check for overflow. @@ -6300,8 +6304,6 @@ TEBCresume( goto wideResultOfArithmetic; case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 - w2; /* * Must check for overflow. The macro tests for overflows in @@ -6328,40 +6330,40 @@ TEBCresume( NEXT_INST_F(1, 1, 0); case INST_DIV: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l1 == LONG_MIN) && (l2 == -1)) { + } else if ((w1 == LLONG_MIN) && (w2 == -1)) { /* - * Can't represent (-LONG_MIN) as a long. + * Can't represent (-LLONG_MIN) as a long. */ goto overflow; } - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((lResult < 0) || ((lResult == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lResult * l2) != l1)) { - lResult -= 1; + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + ((wResult * w2) != w1)) { + wResult -= 1; } - goto longResultOfArithmetic; + goto wideResultOfArithmetic; case INST_MULT: if (((sizeof(long) >= 2*sizeof(int)) - && (l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) + && (w1 <= INT_MAX) && (w1 >= INT_MIN) + && (w2 <= INT_MAX) && (w2 >= INT_MIN)) || ((sizeof(long) >= 2*sizeof(short)) - && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) - && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { - lResult = l1 * l2; - goto longResultOfArithmetic; + && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) + && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { + wResult = w1 * w2; + goto wideResultOfArithmetic; } } @@ -8227,8 +8229,8 @@ ExecuteExtendedBinaryMathOp( */ switch (type2) { - case TCL_NUMBER_WIDE: case TCL_NUMBER_LONG: + case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; case TCL_NUMBER_BIG: @@ -8250,7 +8252,7 @@ ExecuteExtendedBinaryMathOp( * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG) && (*((const Tcl_WideInt *)ptr1) == (long)0)) { + if ((type1==TCL_NUMBER_LONG || type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { return constants[0]; } @@ -8308,8 +8310,6 @@ ExecuteExtendedBinaryMathOp( switch (type1) { case TCL_NUMBER_LONG: - zero = (*(const Tcl_WideInt *)ptr1 > 0L); - break; case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; @@ -8981,7 +8981,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) + if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { /* * Must check for overflow. The macro tests for overflows -- cgit v0.12 From 8fd76cb8733824c202c3eda72e9716013c8c2d82 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 12:39:16 +0000 Subject: more simplifications --- generic/tclExecute.c | 57 ++++++++++------------------------------------------ 1 file changed, 11 insertions(+), 46 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 76e1496..ed4c00f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1877,35 +1877,6 @@ TclIncrObj( return TCL_ERROR; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const Tcl_WideInt *) ptr1); - long addend = *((const Tcl_WideInt *) ptr2); - long sum = augend + addend; - - /* - * Overflow when (augend and sum have different sign) and (augend and - * addend have the same sign). This is encapsulated in the Overflowing - * macro. - */ - - if (!Overflowing(augend, addend, sum)) { - TclSetLongObj(valuePtr, sum); - return TCL_OK; - } - { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; - - /* - * We know the sum value is outside the long range, so we use the - * macro form that doesn't range test again. - */ - - TclSetWideIntObj(valuePtr, w1 + w2); - return TCL_OK; - } - } - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) @@ -8146,12 +8117,12 @@ ExecuteExtendedBinaryMathOp( /* TODO: Attempts to re-use unshared operands on stack */ l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const Tcl_WideInt *)ptr2); - if (l2 == 0) { + if (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE) { + l2 = w2 = *((const Tcl_WideInt *)ptr2); + if (w2 == 0) { return DIVIDED_BY_ZERO; } - if ((l2 == 1) || (l2 == -1)) { + if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -8583,9 +8554,6 @@ ExecuteExtendedBinaryMathOp( switch (type2) { case TCL_NUMBER_LONG: - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); @@ -8600,12 +8568,12 @@ ExecuteExtendedBinaryMathOp( break; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const Tcl_WideInt *)ptr1); + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + l1 = w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + switch (w1) { case 0: /* * Zero to a negative power is div by zero error. @@ -8635,7 +8603,7 @@ ExecuteExtendedBinaryMathOp( } if (type1 == TCL_NUMBER_LONG) { - switch (l1) { + switch (w1) { case 0: /* * Zero to a positive power is zero. @@ -8764,9 +8732,7 @@ ExecuteExtendedBinaryMathOp( #endif } #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - if (type1 == TCL_NUMBER_LONG) { - w1 = l1; - } else if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); } else { goto overflowExpon; @@ -9001,8 +8967,7 @@ ExecuteExtendedBinaryMathOp( break; case INST_MULT: - if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) - || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { goto overflowBasic; } wResult = w1 * w2; @@ -9105,7 +9070,7 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: - if (type == TCL_NUMBER_WIDE) { + if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } -- cgit v0.12 From 2f2459e12003ac4f386e21b70b7929fe73859258 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 14:40:33 +0000 Subject: more progress --- generic/tclExecute.c | 129 +++++++++++++++++++++++---------------------------- 1 file changed, 59 insertions(+), 70 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ed4c00f..704ee57 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5863,7 +5863,7 @@ TEBCresume( { ClientData ptr1, ptr2; int type1, type2; - long l1, l2, lResult; + long l1; Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: @@ -6008,16 +6008,16 @@ TEBCresume( */ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const Tcl_WideInt *)ptr1); - l2 = *((const Tcl_WideInt *)ptr2); + l1 = w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_MOD: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l2 == 1) || (l2 == -1)) { + } else if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -6026,7 +6026,7 @@ TEBCresume( objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l1 == 0) { + } else if (w1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ @@ -6036,24 +6036,24 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((lResult < 0 || (lResult == 0 && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - (lResult * l2 != l1)) { - lResult -= 1; + if ((wResult < 0 || (wResult == 0 && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult * w2 != w1)) { + wResult -= 1; } - lResult = l1 - l2*lResult; - goto longResultOfArithmetic; + wResult = w1 - w2*wResult; + goto wideResultOfArithmetic; } case INST_RSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR @@ -6064,7 +6064,7 @@ TEBCresume( CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); @@ -6074,7 +6074,7 @@ TEBCresume( * Quickly force large right shifts to 0 or -1. */ - if (l2 >= (long)(CHAR_BIT*sizeof(long))) { + if (w2 >= (long)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe @@ -6083,7 +6083,7 @@ TEBCresume( */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (l1 > 0L) { + if (w1 > 0L) { objResultPtr = TCONST(0); } else { TclNewLongObj(objResultPtr, -1); @@ -6096,12 +6096,12 @@ TEBCresume( * Handle shifts within the native long range. */ - lResult = l1 >> ((int) l2); - goto longResultOfArithmetic; + wResult = w1 >> ((int) w2); + goto wideResultOfArithmetic; } case INST_LSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR @@ -6112,12 +6112,12 @@ TEBCresume( CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l2 > (long) INT_MAX) { + } else if (w2 > (long) INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do @@ -6135,17 +6135,17 @@ TEBCresume( #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { - int shift = (int) l2; + int shift = (int) w2; /* * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) - && !((l1>0 ? l1 : ~l1) & + if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) + && !((w1>0 ? w1 : ~w1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; - goto longResultOfArithmetic; + wResult = w1 << shift; + goto wideResultOfArithmetic; } } @@ -6157,23 +6157,14 @@ TEBCresume( break; case INST_BITAND: - lResult = l1 & l2; - goto longResultOfArithmetic; + wResult = w1 & w2; + goto wideResultOfArithmetic; case INST_BITOR: - lResult = l1 | l2; - goto longResultOfArithmetic; + wResult = w1 | w2; + goto wideResultOfArithmetic; case INST_BITXOR: - lResult = l1 ^ l2; - longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + wResult = w1 ^ w2; + goto wideResultOfArithmetic; } } @@ -6257,10 +6248,8 @@ TEBCresume( */ if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - w1 = *((const Tcl_WideInt *)ptr1); + l1 = w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); - l1 = w1; - l2 = w2; switch (*pc) { case INST_ADD: @@ -6401,14 +6390,14 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const Tcl_WideInt *) ptr1); + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); + TclNewWideObj(objResultPtr, ~w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, ~l1); + TclSetWideIntObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6439,7 +6428,7 @@ TEBCresume( TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: - l1 = *((const Tcl_WideInt *) ptr1); + l1 = w1 = *((const Tcl_WideInt *) ptr1); if (l1 != LONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewLongObj(objResultPtr, -l1); @@ -8501,8 +8490,8 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } - l1 = *((const Tcl_WideInt *)ptr1); - l2 = *((const Tcl_WideInt *)ptr2); + l1 = w1 = *((const Tcl_WideInt *)ptr1); + l2 = w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: @@ -8536,14 +8525,14 @@ ExecuteExtendedBinaryMathOp( } l1 = l2 = 0; if (type2 == TCL_NUMBER_LONG) { - l2 = *((const Tcl_WideInt *) ptr2); - if (l2 == 0) { + l2 = w2 = *((const Tcl_WideInt *) ptr2); + if (w2 == 0) { /* * Anything to the zero power is 1. */ return constants[1]; - } else if (l2 == 1) { + } else if (w2 == 1) { /* * Anything to the first power is itself */ @@ -8640,25 +8629,25 @@ ExecuteExtendedBinaryMathOp( } if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { + if (w1 == 2) { /* * Reduce small powers of 2 to shifts. */ - if ((Tcl_WideUInt) l2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); + if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); } goto overflowExpon; } - if (l1 == -2) { + if (w1 == -2) { int signum = oddExponent ? -1 : 1; /* * Reduce small powers of 2 to shifts. */ - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); + if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } goto overflowExpon; } @@ -8737,19 +8726,19 @@ ExecuteExtendedBinaryMathOp( } else { goto overflowExpon; } - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { + if (w2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[w2 - 2] + && w1 >= -MaxBase64[w2 - 2]) { /* * Small powers of integers whose result is wide. */ wResult = w1 * w1; /* b**2 */ - switch (l2) { + switch (w2) { case 2: break; case 3: - wResult *= l1; /* b**3 */ + wResult *= w1; /* b**3 */ break; case 4: wResult *= wResult; /* b**4 */ @@ -8826,9 +8815,9 @@ ExecuteExtendedBinaryMathOp( */ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -8840,9 +8829,9 @@ ExecuteExtendedBinaryMathOp( } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by -- cgit v0.12 From db930a501ff7f2b3826325f52d9bbcf2f26eaead Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 14:48:28 +0000 Subject: Only use 64-bit tables for all platforms --- generic/tclExecute.c | 105 --------------------------------------------------- 1 file changed, 105 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 704ee57..2c77979 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -576,40 +576,6 @@ VarHashCreateVar( * Auxiliary tables used to compute powers of small integers. */ -#if (LONG_MAX == 0x7fffffff) - -/* - * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit - * signed integer. - */ - -static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; -static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); - -/* - * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they - * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of - * powers of i+3; Exp32Value[i] gives the corresponding powers. - */ - -static const unsigned short Exp32Index[] = { - 0, 11, 18, 23, 26, 29, 31, 32, 33 -}; -static const size_t Exp32IndexSize = - sizeof(Exp32Index) / sizeof(unsigned short); -static const long Exp32Value[] = { - 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, - 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, - 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, - 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, - 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, - 1000000000 -}; -static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); -#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. @@ -713,7 +679,6 @@ static const Tcl_WideInt Exp64Value[] = { (Tcl_WideInt)371293*371293*371293*13*13 }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); -#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ /* * Markers for ExecuteExtendedBinaryMathOp. @@ -8651,76 +8616,7 @@ ExecuteExtendedBinaryMathOp( } goto overflowExpon; } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - - lResult = l1 * l1; /* b**2 */ - switch (l2) { - case 2: - break; - case 3: - lResult *= l1; /* b**3 */ - break; - case 4: - lResult *= lResult; /* b**4 */ - break; - case 5: - lResult *= lResult; /* b**4 */ - lResult *= l1; /* b**5 */ - break; - case 6: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - break; - case 7: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - lResult *= l1; /* b**7 */ - break; - case 8: - lResult *= lResult; /* b**4 */ - lResult *= lResult; /* b**8 */ - break; - } - WIDE_RESULT(lResult); - } - - if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - WIDE_RESULT(Exp32Value[base]); - } - } - if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[-l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[-l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - WIDE_RESULT(lResult); - } - } -#endif } -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); } else { @@ -8842,7 +8738,6 @@ ExecuteExtendedBinaryMathOp( WIDE_RESULT(wResult); } } -#endif overflowExpon: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); -- cgit v0.12 From 1cbd95eeee01fe3a144bba18c710be5c8442ff14 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 16:16:46 +0000 Subject: eliminate most use of (long) type, except for increments --- generic/tclExecute.c | 110 ++++++++++++++++++--------------------------------- 1 file changed, 39 insertions(+), 71 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2c77979..846b04f 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -3657,9 +3657,9 @@ TEBCresume( objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const Tcl_WideInt *)ptr); - long sum = augend + increment; + if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) { + Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); + Tcl_WideInt sum = augend + increment; /* * Overflow when (augend and sum have different sign) and @@ -3671,12 +3671,12 @@ TEBCresume( TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); + TclNewWideObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); + TclSetWideIntObj(objPtr, sum); } goto doneIncr; } @@ -3699,38 +3699,7 @@ TEBCresume( TclSetWideIntObj(objPtr, w+increment); } goto doneIncr; - } /* end if (type == TCL_NUMBER_LONG) */ - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } + } /* end if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) */ } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -5828,7 +5797,6 @@ TEBCresume( { ClientData ptr1, ptr2; int type1, type2; - long l1; Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: @@ -5972,8 +5940,8 @@ TEBCresume( * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = w1 = *((const Tcl_WideInt *)ptr1); + if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { @@ -6039,7 +6007,7 @@ TEBCresume( * Quickly force large right shifts to 0 or -1. */ - if (w2 >= (long)(CHAR_BIT*sizeof(long))) { + if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe @@ -6082,7 +6050,7 @@ TEBCresume( objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (w2 > (long) INT_MAX) { + } else if (w2 > (Tcl_WideInt) INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do @@ -6212,8 +6180,8 @@ TEBCresume( * an external function. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = w1 = *((const Tcl_WideInt *)ptr1); + if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { @@ -6393,14 +6361,15 @@ TEBCresume( TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_LONG: - l1 = w1 = *((const Tcl_WideInt *) ptr1); - if (l1 != LONG_MIN) { + case TCL_NUMBER_WIDE: + w1 = *((const Tcl_WideInt *) ptr1); + if (w1 != LLONG_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); + TclNewWideObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, -l1); + TclSetWideIntObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -8056,7 +8025,6 @@ ExecuteExtendedBinaryMathOp( int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; - long l1, l2, lResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; @@ -8070,9 +8038,9 @@ ExecuteExtendedBinaryMathOp( case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ - l2 = 0; /* silence gcc warning */ + w2 = 0; /* silence gcc warning */ if (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE) { - l2 = w2 = *((const Tcl_WideInt *)ptr2); + w2 = *((const Tcl_WideInt *)ptr2); if (w2 == 0) { return DIVIDED_BY_ZERO; } @@ -8190,7 +8158,7 @@ ExecuteExtendedBinaryMathOp( * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_LONG) + if ((type2 != TCL_NUMBER_LONG && type2 != TCL_NUMBER_WIDE) || (*((const Tcl_WideInt *)ptr2) > (long) INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in @@ -8223,7 +8191,7 @@ ExecuteExtendedBinaryMathOp( * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_LONG) + if ((type2 != TCL_NUMBER_LONG && type2 != TCL_NUMBER_WIDE) || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an @@ -8258,7 +8226,7 @@ ExecuteExtendedBinaryMathOp( * Handle shifts within the native wide range. */ - if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { if (w1 >= (Tcl_WideInt)0) { @@ -8435,7 +8403,7 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { + if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -8455,24 +8423,24 @@ ExecuteExtendedBinaryMathOp( } WIDE_RESULT(wResult); } - l1 = w1 = *((const Tcl_WideInt *)ptr1); - l2 = w2 = *((const Tcl_WideInt *)ptr2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: - lResult = l1 & l2; + wResult = w1 & w2; break; case INST_BITOR: - lResult = l1 | l2; + wResult = w1 | w2; break; case INST_BITXOR: - lResult = l1 ^ l2; + wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ - lResult = 0; + wResult = 0; } - WIDE_RESULT(lResult); + WIDE_RESULT(wResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; @@ -8488,9 +8456,9 @@ ExecuteExtendedBinaryMathOp( dResult = pow(d1, d2); goto doubleResult; } - l1 = l2 = 0; - if (type2 == TCL_NUMBER_LONG) { - l2 = w2 = *((const Tcl_WideInt *) ptr2); + w2 = 0; + if (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE) { + w2 = *((const Tcl_WideInt *) ptr2); if (w2 == 0) { /* * Anything to the zero power is 1. @@ -8523,10 +8491,10 @@ ExecuteExtendedBinaryMathOp( } if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { - l1 = w1 = *((const Tcl_WideInt *)ptr1); + w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG) { + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { switch (w1) { case 0: /* @@ -8556,7 +8524,7 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } - if (type1 == TCL_NUMBER_LONG) { + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { switch (w1) { case 0: /* @@ -8587,13 +8555,13 @@ ExecuteExtendedBinaryMathOp( * accept. */ - if (type2 != TCL_NUMBER_LONG) { + if (type2 != TCL_NUMBER_LONG && type2 != TCL_NUMBER_WIDE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - if (type1 == TCL_NUMBER_LONG) { + if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { if (w1 == 2) { /* * Reduce small powers of 2 to shifts. @@ -8817,7 +8785,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) + if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { /* * Check for overflow. -- cgit v0.12 From adc216698f7b3e45354f185b714df1754c429aa9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Oct 2017 16:40:57 +0000 Subject: Eliminate most usage of TCL_NUMBER_LONG, just use TCL_NUMBER_WIDE in stead (since both have the same internal representation now) --- generic/tclBasic.c | 3 +-- generic/tclExecute.c | 67 +++++++++++++++++++++------------------------------- 2 files changed, 28 insertions(+), 42 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a911028..f69e861 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6466,7 +6466,6 @@ Tcl_ExprLongObj( resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); @@ -7442,7 +7441,7 @@ ExprAbsFunc( return TCL_ERROR; } - if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) { + if (type == TCL_NUMBER_WIDE) { Tcl_WideInt l = *((const Tcl_WideInt *) ptr); if (l > (Tcl_WideInt)0) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 846b04f..9eed936 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -501,7 +501,7 @@ VarHashCreateVar( #ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ + ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclDoubleType) \ @@ -516,7 +516,7 @@ VarHashCreateVar( #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ + ? (*(tPtr) = TCL_NUMBER_WIDE, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ ((objPtr)->typePtr == &tclWideIntType) \ @@ -3657,7 +3657,7 @@ TEBCresume( objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) { + if (type == TCL_NUMBER_WIDE) { Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); Tcl_WideInt sum = augend + increment; @@ -3699,7 +3699,7 @@ TEBCresume( TclSetWideIntObj(objPtr, w+increment); } goto doneIncr; - } /* end if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) */ + } /* end if (type == TCL_NUMBER_WIDE) */ } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -5802,7 +5802,7 @@ TEBCresume( case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; - } else if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + } else if (type1 == TCL_NUMBER_WIDE) { /* value is between WIDE_MIN and WIDE_MAX */ /* [string is integer] is -UINT_MAX to UINT_MAX range */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ @@ -5815,14 +5815,10 @@ TEBCresume( } } else if (type1 == TCL_NUMBER_BIG) { /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ - /* [string is integer] is -UINT_MAX to UINT_MAX range */ /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ - int i; Tcl_WideInt w; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { - type1 = TCL_NUMBER_LONG; - } else if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { type1 = TCL_NUMBER_WIDE; } } @@ -5861,7 +5857,7 @@ TEBCresume( compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); @@ -5940,7 +5936,7 @@ TEBCresume( * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); @@ -6180,7 +6176,7 @@ TEBCresume( * an external function. */ - if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); @@ -6323,7 +6319,7 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewWideObj(objResultPtr, ~w1); @@ -6360,7 +6356,6 @@ TEBCresume( /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *) ptr1); if (w1 != LLONG_MIN) { @@ -8039,7 +8034,7 @@ ExecuteExtendedBinaryMathOp( /* TODO: Attempts to re-use unshared operands on stack */ w2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE) { + if (type2 == TCL_NUMBER_WIDE) { w2 = *((const Tcl_WideInt *)ptr2); if (w2 == 0) { return DIVIDED_BY_ZERO; @@ -8122,7 +8117,6 @@ ExecuteExtendedBinaryMathOp( */ switch (type2) { - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; @@ -8145,7 +8139,7 @@ ExecuteExtendedBinaryMathOp( * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG || type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { + if ((type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { return constants[0]; } @@ -8158,7 +8152,7 @@ ExecuteExtendedBinaryMathOp( * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_LONG && type2 != TCL_NUMBER_WIDE) + if ((type2 != TCL_NUMBER_WIDE) || (*((const Tcl_WideInt *)ptr2) > (long) INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in @@ -8191,7 +8185,7 @@ ExecuteExtendedBinaryMathOp( * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_LONG && type2 != TCL_NUMBER_WIDE) + if ((type2 != TCL_NUMBER_WIDE) || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an @@ -8202,7 +8196,6 @@ ExecuteExtendedBinaryMathOp( */ switch (type1) { - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; @@ -8226,7 +8219,7 @@ ExecuteExtendedBinaryMathOp( * Handle shifts within the native wide range. */ - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { if (w1 >= (Tcl_WideInt)0) { @@ -8403,7 +8396,7 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } - if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) { + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); @@ -8457,7 +8450,7 @@ ExecuteExtendedBinaryMathOp( goto doubleResult; } w2 = 0; - if (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE) { + if (type2 == TCL_NUMBER_WIDE) { w2 = *((const Tcl_WideInt *) ptr2); if (w2 == 0) { /* @@ -8475,7 +8468,6 @@ ExecuteExtendedBinaryMathOp( } switch (type2) { - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); @@ -8490,11 +8482,11 @@ ExecuteExtendedBinaryMathOp( break; } - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { switch (w1) { case 0: /* @@ -8524,7 +8516,7 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { switch (w1) { case 0: /* @@ -8551,17 +8543,17 @@ ExecuteExtendedBinaryMathOp( * which means the max exponent value is 2**28-1 = 0x0fffffff = * 268435455, which fits into a signed 32 bit int which is within the * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_LONG type must hold a value larger than we + * not using TCL_NUMBER_WIDE type must hold a value larger than we * accept. */ - if (type2 != TCL_NUMBER_LONG && type2 != TCL_NUMBER_WIDE) { + if (type2 != TCL_NUMBER_WIDE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { if (w1 == 2) { /* * Reduce small powers of 2 to shifts. @@ -8585,7 +8577,7 @@ ExecuteExtendedBinaryMathOp( goto overflowExpon; } } - if (type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); } else { goto overflowExpon; @@ -8785,7 +8777,7 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = w1 + w2; - if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { /* * Check for overflow. @@ -8799,7 +8791,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; - if ((type1 == TCL_NUMBER_LONG || type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_LONG || type2 == TCL_NUMBER_WIDE)) + if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { /* * Must check for overflow. The macro tests for overflows @@ -8922,7 +8914,7 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: - if (type == TCL_NUMBER_LONG || type == TCL_NUMBER_WIDE) { + if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } @@ -8935,7 +8927,6 @@ ExecuteExtendedUnaryMathOp( switch (type) { case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { @@ -8990,11 +8981,9 @@ TclCompareTwoNumbers( (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); wideCompare: @@ -9052,7 +9041,6 @@ TclCompareTwoNumbers( d2 = *((const double *)ptr2); doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; @@ -9095,7 +9083,6 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { - case TCL_NUMBER_LONG: case TCL_NUMBER_WIDE: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); -- cgit v0.12 From 9e2ed8b729812f2ab4c70025a0e71f255bec1a78 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 1 Nov 2017 12:35:40 +0000 Subject: Finally, get rid of tclWideIntType completely --- generic/tclAssembly.c | 2 +- generic/tclBasic.c | 2 +- generic/tclCmdMZ.c | 4 +-- generic/tclExecute.c | 68 +++++++++++++++++---------------------------------- generic/tclInt.h | 53 +++++---------------------------------- generic/tclObj.c | 67 +++++++++++++++----------------------------------- generic/tclStrToD.c | 4 +-- generic/tclTimer.c | 1 - generic/tclUtil.c | 4 +-- generic/tclZlib.c | 2 +- 10 files changed, 56 insertions(+), 151 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index c7ded6e..0fd7c60 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -4266,7 +4266,7 @@ AddBasicBlockRangeToErrorInfo( Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - TclSetWideIntObj(lineNo, bbPtr->successor1->startLine); + TclSetWideObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f69e861..f84b420 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3651,7 +3651,7 @@ OldMathFuncProc( */ if (funcResult.type == TCL_INT) { - TclNewLongObj(valuePtr, funcResult.intValue); + TclNewWideObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index c984bbe..8ab687f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1596,7 +1596,6 @@ StringIsCmd( /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || - (objPtr->typePtr == &tclWideIntType) || (objPtr->typePtr == &tclBignumType)) { break; } @@ -1631,7 +1630,6 @@ StringIsCmd( goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || - (objPtr->typePtr == &tclWideIntType) || (objPtr->typePtr == &tclBignumType)) { break; } @@ -4289,7 +4287,7 @@ TclNRTryObjCmd( } info[0] = objv[i]; /* type */ - TclNewLongObj(info[1], code); /* returnCode */ + TclNewWideObj(info[1], code); /* returnCode */ if (info[2] == NULL) { /* errorCodePrefix */ TclNewObj(info[2]); } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9eed936..51f9bff 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -325,7 +325,7 @@ VarHashCreateVar( NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewWideObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -346,7 +346,7 @@ VarHashCreateVar( NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewWideObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -357,7 +357,7 @@ VarHashCreateVar( #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewWideObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -366,7 +366,7 @@ VarHashCreateVar( #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewWideObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -498,7 +498,6 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(tPtr) = TCL_NUMBER_WIDE, \ @@ -513,26 +512,6 @@ VarHashCreateVar( (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_WIDE, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclWideIntType) \ - ? (*(tPtr) = TCL_NUMBER_WIDE, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ /* * Macro used in this file to save a function call for common uses of @@ -873,9 +852,9 @@ TclCreateExecEnv( + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewLongObj(eePtr->constants[0], 0); + TclNewWideObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewLongObj(eePtr->constants[1], 1); + TclNewWideObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; @@ -3676,7 +3655,7 @@ TEBCresume( varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetWideIntObj(objPtr, sum); + TclSetWideObj(objPtr, sum); } goto doneIncr; } @@ -3696,7 +3675,7 @@ TEBCresume( * use macro form that doesn't range test again. */ - TclSetWideIntObj(objPtr, w+increment); + TclSetWideObj(objPtr, w+increment); } goto doneIncr; } /* end if (type == TCL_NUMBER_WIDE) */ @@ -3709,7 +3688,7 @@ TEBCresume( } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, increment); + TclNewWideObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); @@ -3723,7 +3702,7 @@ TEBCresume( * All other cases, flow through to generic handling. */ - TclNewLongObj(incrPtr, increment); + TclNewWideObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: @@ -4421,7 +4400,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: - TclNewLongObj(objResultPtr, iPtr->varFramePtr->level); + TclNewWideObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_INFO_LEVEL_ARGS: { @@ -4790,7 +4769,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewLongObj(objResultPtr, length); + TclNewWideObj(objResultPtr, length); TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); @@ -5261,7 +5240,7 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); - TclNewLongObj(objResultPtr, length); + TclNewWideObj(objResultPtr, length); TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); @@ -5616,7 +5595,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewLongObj(objResultPtr, match); + TclNewWideObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: @@ -5624,7 +5603,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewLongObj(objResultPtr, match); + TclNewWideObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: @@ -5822,7 +5801,7 @@ TEBCresume( type1 = TCL_NUMBER_WIDE; } } - TclNewLongObj(objResultPtr, type1); + TclNewWideObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); NEXT_INST_F(1, 1, 1); @@ -6015,7 +5994,7 @@ TEBCresume( if (w1 > 0L) { objResultPtr = TCONST(0); } else { - TclNewLongObj(objResultPtr, -1); + TclNewWideObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -6326,7 +6305,7 @@ TEBCresume( TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetWideIntObj(valuePtr, ~w1); + TclSetWideObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6364,7 +6343,7 @@ TEBCresume( TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetWideIntObj(valuePtr, -w1); + TclSetWideObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6525,10 +6504,10 @@ TEBCresume( oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); + TclNewWideObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { - TclSetLongObj(oldValuePtr, -1); + TclSetWideObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); @@ -6563,7 +6542,7 @@ TEBCresume( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; iterNum = valuePtr->internalRep.wideValue + 1; - TclSetLongObj(valuePtr, iterNum); + TclSetWideObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the @@ -6896,7 +6875,7 @@ TEBCresume( NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewLongObj(objResultPtr, result); + TclNewWideObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); @@ -7562,7 +7541,6 @@ TEBCresume( default: Tcl_Panic("clockRead instruction with unknown clock#"); } - /* TclNewWideObj(objResultPtr, wval); doesn't exist */ objResultPtr = Tcl_NewWideIntObj(wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); diff --git a/generic/tclInt.h b/generic/tclInt.h index 3799287..34e3e43 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2451,12 +2451,13 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ -#define TclGetLongFromObj(interp, objPtr, longPtr) \ +#define TclGetLongFromObj(interp, objPtr, longPtr) Tcl_GetLongFromObj(interp, objPtr, longPtr) +#define TclGetLongFromObjX(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) -#if (LONG_MAX == INT_MAX) +#if 0 #define TclGetIntFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? ((*(intPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ @@ -2480,21 +2481,11 @@ typedef struct List { * Tcl_WideInt *wideIntPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.wideValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ /* * Flag values for TclTraceDictPath(). @@ -2720,7 +2711,6 @@ MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; -MODULE_SCOPE const Tcl_ObjType tclWideIntType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -4533,13 +4523,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); - * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetLongObj(objPtr, i) \ +#define TclSetWideObj(objPtr, i) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ @@ -4547,18 +4536,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr)->typePtr = &tclIntType; \ } while (0) -#ifdef TCL_WIDE_INT_IS_LONG -#define TclSetWideIntObj(objPtr, w) TclSetLongObj(objPtr, w) -#else -#define TclSetWideIntObj(objPtr, w) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclWideIntType; \ - } while (0) -#endif - #define TclSetDoubleObj(objPtr, d) \ do { \ TclInvalidateStringRep(objPtr); \ @@ -4573,7 +4550,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l); * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); @@ -4583,7 +4559,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; */ #ifndef TCL_MEM_DEBUG -#define TclNewLongObj(objPtr, i) \ +#define TclNewWideObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ @@ -4594,20 +4570,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -#ifndef TCL_WIDE_INT_IS_LONG -#define TclNewWideObj(objPtr, i) \ - do { \ - TclIncrObjsAllocated(); \ - TclAllocObjStorage(objPtr); \ - (objPtr)->refCount = 0; \ - (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ - (objPtr)->typePtr = &tclWideIntType; \ - TCL_DTRACE_OBJ_CREATE(objPtr); \ - } while (0) -#else -#define TclNewWideObj(objPtr, i) TclNewLongObj(objPtr, i) -#endif #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ @@ -4630,9 +4592,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewLongObj(objPtr, l) \ - (objPtr) = Tcl_NewLongObj(l) - #define TclNewWideObj(objPtr, w) \ (objPtr) = Tcl_NewWideIntObj(w) diff --git a/generic/tclObj.c b/generic/tclObj.c index e4613ba..04fdeaa 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -266,13 +266,6 @@ const Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ -}; const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ @@ -1753,7 +1746,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, boolValue!=0); + TclNewWideObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1848,7 +1841,7 @@ Tcl_SetBooleanObj( Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetLongObj(objPtr, boolValue!=0); + TclSetWideObj(objPtr, boolValue!=0); } #endif /* TCL_NO_DEPRECATED */ @@ -1907,10 +1900,6 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1960,10 +1949,6 @@ TclSetBooleanFromAny( goto badBoolean; } - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -2281,7 +2266,7 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.wideValue; + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { @@ -2291,10 +2276,6 @@ Tcl_GetDoubleFromObj( *dblPtr = TclBignumToDouble(&big); return TCL_OK; } - if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2412,7 +2393,7 @@ Tcl_NewIntObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, intValue); + TclNewWideObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2445,7 +2426,7 @@ Tcl_SetIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } - TclSetLongObj(objPtr, intValue); + TclSetWideObj(objPtr, intValue); } /* @@ -2610,7 +2591,7 @@ Tcl_NewLongObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewWideObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2711,7 +2692,7 @@ Tcl_SetLongObj( Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetLongObj(objPtr, longValue); + TclSetWideObj(objPtr, longValue); } /* @@ -2742,11 +2723,13 @@ Tcl_GetLongFromObj( register long *longPtr) /* Place to store resulting long. */ { do { +#if (LONG_MAX == LLONG_MAX) if (objPtr->typePtr == &tclIntType) { *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclWideIntType) { +#else + if (objPtr->typePtr == &tclIntType) { /* * We return any integer in the range -ULONG_MAX to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves @@ -2764,6 +2747,7 @@ Tcl_GetLongFromObj( } goto tooLarge; } +#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2802,7 +2786,9 @@ Tcl_GetLongFromObj( return TCL_OK; } } +#if (LONG_MAX != LLONG_MAX) tooLarge: +#endif if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -2966,12 +2952,7 @@ Tcl_SetWideIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((wideValue >= (Tcl_WideInt) LONG_MIN) - && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, wideValue); - } else { - TclSetWideIntObj(objPtr, wideValue); - } + TclSetWideObj(objPtr, wideValue); } /* @@ -3003,12 +2984,8 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.wideValue; + *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -3303,10 +3280,6 @@ GetBignumFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclInitBignumFromLong(bignumValue, objPtr->internalRep.wideValue); - return TCL_OK; - } - if (objPtr->typePtr == &tclWideIntType) { TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; @@ -3435,9 +3408,9 @@ Tcl_SetBignumObj( goto tooLargeForLong; } if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); + TclSetWideObj(objPtr, -(long)value); } else { - TclSetLongObj(objPtr, (long)value); + TclSetWideObj(objPtr, (long)value); } mp_clear(bignumValue); return; @@ -3461,9 +3434,9 @@ Tcl_SetBignumObj( goto tooLargeForWide; } if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); + TclSetWideObj(objPtr, -(Tcl_WideInt)value); } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); + TclSetWideObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; @@ -3550,7 +3523,7 @@ TclGetNumberFromObj( *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } - if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclWideIntType) { + if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index c8bc7b5..9663c21 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1272,7 +1272,7 @@ TclParseNumber( (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { #ifndef TCL_WIDE_INT_IS_LONG if (octalSignificandWide <= (MOST_BITS + signum)) { - objPtr->typePtr = &tclWideIntType; + objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; @@ -1319,7 +1319,7 @@ TclParseNumber( (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { #ifndef TCL_WIDE_INT_IS_LONG if (significandWide <= MOST_BITS+signum) { - objPtr->typePtr = &tclWideIntType; + objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 279e110..54854d0 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -819,7 +819,6 @@ Tcl_AfterObjCmd( */ if (objv[1]->typePtr == &tclIntType - || objv[1]->typePtr == &tclWideIntType || objv[1]->typePtr == &tclBignumType || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) != TCL_OK)) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 198424f..61a84ce 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3768,9 +3768,7 @@ SetEndOffsetFromAny( TCL_PARSE_INTEGER_ONLY) != TCL_OK) { return TCL_ERROR; } - if ((objPtr->typePtr != &tclIntType) - && (objPtr->typePtr != &tclWideIntType) - ) { + if (objPtr->typePtr != &tclIntType) { goto badIndexFormat; } offset = objPtr->internalRep.wideValue; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 33eebd1..dc124f7 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -373,7 +373,7 @@ ConvertErrorToList( default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewLongObj(objv[3], code); + TclNewWideObj(objv[3], code); return Tcl_NewListObj(4, objv); } } -- cgit v0.12 From 1a0c2e24ebd161899980a2a962a854e143d4ae1d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 3 Nov 2017 17:11:13 +0000 Subject: Bump to 9.0a0 --- README | 2 +- generic/tcl.h | 10 +++++----- library/init.tcl | 2 +- macosx/Tcl-Common.xcconfig | 2 +- tools/tcl.hpj.in | 4 ++-- unix/configure | 26 +++++++++++++------------- unix/configure.ac | 10 +++++----- unix/tcl.spec | 2 +- win/README | 4 ++-- win/configure | 8 ++++---- win/configure.ac | 8 ++++---- 11 files changed, 39 insertions(+), 39 deletions(-) diff --git a/README b/README index 322666a..2a3b597 100644 --- a/README +++ b/README @@ -1,5 +1,5 @@ README: Tcl - This is the Tcl 8.7a2 source distribution. + This is the Tcl 9.0a0 source distribution. http://sourceforge.net/projects/tcl/files/Tcl/ You can get any source release of Tcl from the URL above. diff --git a/generic/tcl.h b/generic/tcl.h index 07d841d..007effb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -52,13 +52,13 @@ extern "C" { * tools/tcl.hpj.in (not patchlevel, for windows installer) */ -#define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 7 +#define TCL_MAJOR_VERSION 9 +#define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 2 +#define TCL_RELEASE_SERIAL 0 -#define TCL_VERSION "8.7" -#define TCL_PATCH_LEVEL "8.7a2" +#define TCL_VERSION "9.0" +#define TCL_PATCH_LEVEL "9.0a0" #if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* diff --git a/library/init.tcl b/library/init.tcl index 87d9f14..4ef78a5 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.7a2 +package require -exact Tcl 9.0a0 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/macosx/Tcl-Common.xcconfig b/macosx/Tcl-Common.xcconfig index 77402b7..13b5df5 100644 --- a/macosx/Tcl-Common.xcconfig +++ b/macosx/Tcl-Common.xcconfig @@ -34,4 +34,4 @@ TCL_CONFIGURE_ARGS = --enable-threads --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H -VERSION = 8.7 +VERSION = 9.0 diff --git a/tools/tcl.hpj.in b/tools/tcl.hpj.in index 08d411d..a3d1a49 100644 --- a/tools/tcl.hpj.in +++ b/tools/tcl.hpj.in @@ -5,9 +5,9 @@ HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl87.cnt +CNT=tcl90.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl87.hlp +HLP=tcl90.hlp [FILES] tcl.rtf diff --git a/unix/configure b/unix/configure index 129c283..6b9cedf 100755 --- a/unix/configure +++ b/unix/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for tcl 8.7. +# Generated by GNU Autoconf 2.69 for tcl 9.0. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. @@ -577,8 +577,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' -PACKAGE_VERSION='8.7' -PACKAGE_STRING='tcl 8.7' +PACKAGE_VERSION='9.0' +PACKAGE_STRING='tcl 9.0' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1319,7 +1319,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures tcl 8.7 to adapt to many kinds of systems. +\`configure' configures tcl 9.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1380,7 +1380,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of tcl 8.7:";; + short | recursive ) echo "Configuration of tcl 9.0:";; esac cat <<\_ACEOF @@ -1494,7 +1494,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -tcl configure 8.7 +tcl configure 9.0 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1970,7 +1970,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by tcl $as_me 8.7, which was +It was created by tcl $as_me 9.0, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -2322,10 +2322,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="a0" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -10966,7 +10966,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by tcl $as_me 8.7, which was +This file was extended by tcl $as_me 9.0, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -11023,7 +11023,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -tcl config.status 8.7 +tcl config.status 9.0 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/unix/configure.ac b/unix/configure.ac index e14d85e..bd7a0e4 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. -AC_INIT([tcl],[8.7]) +AC_INIT([tcl],[9.0]) AC_PREREQ(2.69) dnl This is only used when included from macosx/configure.ac @@ -22,10 +22,10 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ #endif /* _TCLCONFIG */]) ]) -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="a0" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 265e4df..0858ee7 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.7a2 +Version: 9.0a0 Release: 2 License: BSD Group: Development/Languages diff --git a/win/README b/win/README index 972923c..c8fdad6 100644 --- a/win/README +++ b/win/README @@ -1,4 +1,4 @@ -Tcl 8.7 for Windows +Tcl 9.0 for Windows 1. Introduction --------------- @@ -16,7 +16,7 @@ The information in this file is maintained on the web at: In order to compile Tcl for Windows, you need the following: - Tcl 8.7 Source Distribution (plus any patches) + Tcl 9.0 Source Distribution (plus any patches) and diff --git a/win/configure b/win/configure index fdd3adb..9554f3a 100755 --- a/win/configure +++ b/win/configure @@ -2099,10 +2099,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="a0" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 diff --git a/win/configure.ac b/win/configure.ac index d03695c..5804754 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -11,10 +11,10 @@ AC_PREREQ(2.69) # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.7 -TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=7 -TCL_PATCH_LEVEL="a2" +TCL_VERSION=9.0 +TCL_MAJOR_VERSION=9 +TCL_MINOR_VERSION=0 +TCL_PATCH_LEVEL="a0" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From 9b30058284ab5a87d78cb96dcd63b95a7ada2393 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 6 Nov 2017 01:33:57 +0000 Subject: Rewrite documentation in comments for brevity and clarity. --- generic/tclListObj.c | 593 +++++++++++++++++++++++++-------------------------- generic/tclObj.c | 31 +-- generic/tclUtil.c | 37 ++-- 3 files changed, 325 insertions(+), 336 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 11374cc..f94433b 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -55,20 +55,22 @@ const Tcl_ObjType tclListType = { * * NewListIntRep -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. Flag value "p" indicates + * Creates a 'List' structure with space for 'objc' elements. 'objc' must + * be > 0. If 'objv' is not NULL, The list is initialized with first + * 'objc' values in that array. Otherwise the list is initialized to have + * 0 elements, with space to add 'objc' more. Flag value 'p' indicates * how to behave on failure. * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then if p=0, NULL is returned and otherwise the - * routine panics. + * Value * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * A new 'List' structure with refCount 0. If some failure + * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' + * is called if it is not. + * + * Effect + * + * The refCount of each value in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -132,22 +134,10 @@ NewListIntRep( /* *---------------------------------------------------------------------- * - * AttemptNewList -- - * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. - * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then NULL is returned, and an error message is left - * in the interp result, unless interp is NULL. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * AttemptNewList -- * + * Like NewListIntRep, but additionally sets an error message on failure. + * *---------------------------------------------------------------------- */ @@ -179,23 +169,20 @@ AttemptNewList( * * Tcl_NewListObj -- * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new list object from an - * (objc,objv) array: that is, each of the objc elements of the array - * referenced by objv is inserted as an element into a new Tcl object. + * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is + * defined, 'Tcl_DbNewListObj' is called instead. * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewListObj. + * Value * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The resulting new list object has ref count 0. + * A new list 'Tcl_Obj' to which is appended values from 'objv', or if + * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no + * elements. The string representation of the new 'Tcl_Obj' is set to + * NULL. The refCount of the list is 0. * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Effect + * + * The refCount of each elements in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -246,28 +233,14 @@ Tcl_NewListObj( /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same - * as the Tcl_NewListObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewListObj. - * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The new list object has ref count 0. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Tcl_DbNewListObj -- + * + * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the + * file name and line number from its caller. This simplifies debugging + * since the [memory active] command will report the correct file + * name and line number when reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. * *---------------------------------------------------------------------- */ @@ -328,19 +301,8 @@ Tcl_DbNewListObj( * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements of - * the object array referenced by objv. - * - * Results: - * None. - * - * Side effects: - * The object is made a list object and is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The ref counts of the elements in objv are incremented since the - * list now refers to them. The object's old string and internal - * representations are freed and its type is set NULL. + * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of + * creating a new one. * *---------------------------------------------------------------------- */ @@ -384,18 +346,20 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Makes a "pure list" copy of a list 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. + * Creates a new 'Tcl_Obj' which is a pure copy of a list 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. + * + * Value * - * Results: - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * list value as *listPtr does. The returned Tcl_Obj has a refCount of - * zero. If *listPtr does not hold a list, NULL is returned, and if - * interp is non-NULL, an error message is recorded there. + * The address of the new 'Tcl_Obj' which shares its internal + * representation with 'listPtr', and whose refCount is 0. If 'listPtr' + * is not actually a list, the value is NULL, and an error message is left + * in 'interp' if it is not NULL. * - * Side effects: - * None. + * Effect + * + * 'listPtr' is converted to a list if it isn't one already. * *---------------------------------------------------------------------- */ @@ -425,27 +389,30 @@ TclListObjCopy( * * Tcl_ListObjGetElements -- * - * This function returns an (objc,objv) array of the elements in a list - * object. + * Retreive the elements in a list 'Tcl_Obj'. + * + * Value + * + * TCL_OK + * + * A count of list elements is stored, 'objcPtr', And a pointer to the + * array of elements in the list is stored in 'objvPtr'. * - * 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 a 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 elements accessible via 'objvPtr' should be treated as readonly + * and the refCount for each object is _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. * - * 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. + * TCL_ERROR * - * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list object if it isn't one already. * *---------------------------------------------------------------------- */ @@ -486,20 +453,27 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the elements in the list value referenced by - * elemListPtr to the list value referenced by listPtr. + * Appends the elements of elemListPtr to those of listPtr. + * + * Value + * + * TCL_OK + * + * Success. * - * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list values, TCL_ERROR is returned and an error message is - * left in the interpreter's result if interp is not NULL. + * TCL_ERROR * - * Side effects: - * The reference counts of the elements in elemListPtr are incremented - * since the list now refers to them. listPtr and elemListPtr are - * converted, if necessary, to list objects. Also, appending the new - * elements may cause listObj's array of element pointers to grow. - * listPtr's old string representation, if any, is invalidated. + * 'listPtr' or 'elemListPtr' are not valid lists. An error + * message is left in the interpreter's result if 'interp' is not NULL. + * + * Effect + * + * The reference count of each element of 'elemListPtr' as it is added to + * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' + * if they are not already. Appending the new elements may cause the + * array of element pointers in 'listObj' to grow. If any objects are + * appended to 'listPtr'. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -538,24 +512,27 @@ Tcl_ListObjAppendList( * * Tcl_ListObjAppendElement -- * - * This function is a special purpose version of Tcl_ListObjAppendList: - * it appends a single object referenced by objPtr to the list object - * referenced by listPtr. If listPtr is not already a list object, an - * attempt will be made to convert it to one. - * - * Results: - * The return value is normally TCL_OK; in this case objPtr is added to - * the end of listPtr's list. If listPtr does not refer to a 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. - * - * Side effects: - * The ref count of objPtr is incremented since the list now refers to - * it. listPtr will be converted, if necessary, to a list object. Also, - * appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, is - * invalidated. + * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. + * + * Value + * + * TCL_OK + * + * 'objPtr' is appended to the elements of 'listPtr'. + * + * TCL_ERROR + * + * listPtr does not refer to a list object and the object can not be + * converted to one. An error message will be left in the + * interpreter's result if interp is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. + * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. + * Appending the new element may cause the the array of element pointers + * in 'listObj' to grow. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -706,23 +683,27 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * This function returns a pointer to the index'th object from the list - * referenced by listPtr. The first element has index 0. If index is - * negative or greater than or equal to the number of elements in the - * list, a NULL is returned. If listPtr is not a list object, an attempt - * will be made to convert it to a list. + * Retrieve a pointer to the element of 'listPtr' at 'index'. The index + * of the first element is 0. + * + * Value + * + * TCL_OK * - * Results: - * The return value is normally TCL_OK; in this case objPtrPtr is set to - * the Tcl_Obj pointer for the index'th list element or NULL if index is - * out of range. This object should be treated as readonly and its ref - * count is _not_ incremented; the caller must do that if it holds on to - * the reference. If listPtr does not refer to a list and can't be - * converted to one, TCL_ERROR is returned and an error message is left - * in the interpreter's result if interp is not NULL. + * A pointer to the element at 'index' is stored in 'objPtrPtr'. If + * 'index' is out of range, NULL is stored in 'objPtrPtr'. This + * object should be treated as readonly and its 'refCount' is _not_ + * incremented. The caller must do that if it holds on to the + * reference. + * + * TCL_ERROR * - * Side effects: - * listPtr will be converted, if necessary, to a list object. + * 'listPtr' is not a valid list. An an error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ @@ -764,19 +745,20 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * This function returns the number of elements in a list object. If the - * object is not already a list object, an attempt will be made to - * convert it to one. + * Retrieve the number of elements in a list. + * + * Value + * + * TCL_OK + * + * A count of list elements is stored at the address provided by + * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is + * converted. * - * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set - * to the integer count of list elements. If listPtr does not refer to a - * 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. + * TCL_ERROR * - * Side effects: - * The possible conversion of the argument object to a list object. + * 'listPtr' is not a valid list. An error message will be left in + * the interpreter's result if 'interp' is not NULL. * *---------------------------------------------------------------------- */ @@ -812,35 +794,36 @@ Tcl_ListObjLength( * * Tcl_ListObjReplace -- * - * This function replaces zero or more elements of the list referenced by - * listPtr with the objects from an (objc,objv) array. The objc elements - * of the array referenced by objv replace the count elements in listPtr - * starting at first. - * - * If the argument first is zero or negative, it refers to the first - * element. If first is greater than or equal to the number of elements - * in the list, then no elements are deleted; the new elements are - * appended to the list. Count gives the number of elements to replace. - * If count is zero or negative then no elements are deleted; the new - * elements are simply inserted before first. - * - * The argument objv refers to an array of objc pointers to the new - * elements to be added to listPtr in place of those that were deleted. - * If objv is NULL, no new elements are added. If listPtr is not a list - * object, an attempt will be made to convert it to one. - * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and 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. - * - * Side effects: - * The ref counts of the objc elements in objv are incremented since the - * resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if necessary, - * to a list object. listPtr's old string representation, if any, is - * freed. + * Replace values in a list. + * + * If 'first' is zero or negative, it refers to the first element. If + * 'first' outside the range of elements in the list, no elements are + * deleted. + * + * If 'count' is zero or negative no elements are deleted, and any new + * elements are inserted at the beginning of the list. + * + * Value + * + * TCL_OK + * + * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' + * starting at 'first'. If 'objc' 0, no new elements are added. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not of type 'tclListType', it is converted if possible. + * + * The 'refCount' of each element appended to the list is incremented. + * Similarly, the 'refCount' for each replaced element is decremented. + * + * If 'listPtr' is modified, any previous string representation is + * invalidated. * *---------------------------------------------------------------------- */ @@ -1098,22 +1081,19 @@ Tcl_ListObjReplace( * * TclLindexList -- * - * This procedure handles the 'lindex' command when objc==3. + * Implements the 'lindex' command when objc==3. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures + * the argument format into required form while taking care to manage + * shimmering so as to tend to keep the most useful intreps + * and/or avoid the most expensive conversions. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLindexFlat. All it does is reconfigure the argument format into the - * form required by TclLindexFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or - * avoid the most expensive conversions. + * A pointer to the specified element, with its 'refCount' incremented, or + * NULL if an error occurred. + * + * Notes * *---------------------------------------------------------------------- */ @@ -1185,25 +1165,20 @@ TclLindexList( /* *---------------------------------------------------------------------- * - * TclLindexFlat -- + * TclLindexFlat -- + * + * The core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * This procedure is the core of the 'lindex' command, with all index - * arguments presented as a flat list. + * Value * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * A pointer to the object extracted, with its 'refCount' incremented, or + * NULL if an error occurred. Thus, the calling code will usually do + * something like: * - * Side effects: - * None. + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * - * Notes: - * The reference count of the returned object includes one reference - * corresponding to the pointer returned. Thus, the calling code will - * usually do something like: - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1279,23 +1254,16 @@ TclLindexFlat( * * TclLsetList -- * - * Core of the 'lset' command when objc == 4. Objv[2] may be either a + * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * - * Results: - * Returns the new value of the list variable, or NULL if there was an - * error. The returned object includes one reference count for the - * pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat', as described + * for 'TclLindexList'. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLsetFlat. All it does is reconfigure the argument format into the - * form required by TclLsetFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or - * avoid the most expensive conversions. + * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if + * there was an error. * *---------------------------------------------------------------------- */ @@ -1357,36 +1325,39 @@ TclLsetList( * * Core engine of the 'lset' command. * - * Results: - * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for the - * pointer returned. - * - * Side effects: - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function is - * to determine whether the object is shared, and to duplicate it if it - * is. The reference count of the duplicate is incremented. At this - * point, the reference count will be 1 for either case, so that the - * object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this - * dismisses any memory that was allocated by this function. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is done - * to a reference count of the duplicate. Now the reference count of an - * unduplicated object is 2 (the returned pointer, plus the one stored in - * the variable). The reference count of a duplicate object is 1, - * reflecting that the returned pointer is the only active reference. The - * caller is expected to store the returned value back in the variable - * and decrement its reference count. (INST_STORE_* does exactly this.) - * - * Surgery is performed on the unshared list value to produce the result. - * TclLsetFlat maintains a linked list of Tcl_Obj's whose string + * Value + * + * The resulting list + * + * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not + * duplicated, its 'refCount' is incremented. The reference count of + * an unduplicated object is therefore 2 (one for the returned pointer + * and one for the variable that holds it). The reference count of a + * duplicate object is 1, reflecting that result is the only active + * reference. The caller is expected to store the result in the + * variable and decrement its reference count. (INST_STORE_* does + * exactly this.) + * + * NULL + * + * An error occurred. If 'listPtr' was duplicated, the reference + * count on the duplicate is decremented so that it is 0, causing any + * memory allocated by this function to be freed. + * + * + * Effect + * + * On entry, the reference count of 'listPtr' does not reflect any + * references held on the stack. The first action of this function is to + * determine whether 'listPtr' is shared and to create a duplicate + * unshared copy if it is. The reference count of the duplicate is + * incremented. At this point, the reference count is 1 in either case so + * that the object is considered unshared. + * + * The unshared list is altered directly to produce the result. + * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to TclLsetFlat, the + * two-pointer internal representation. On entry to 'TclLsetFlat', the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * @@ -1601,26 +1572,38 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value + * Set a single element of a list to a specified value. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and cannot be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter result if interp is - * not NULL. Similarly, if index designates an element outside the range - * [0..listLength-1], where listLength is the count of elements in the - * list object designated by listPtr, TCL_ERROR is returned and an error - * message is left in the interpreter result. + * It is the caller's responsibility to invalidate the string + * representation of the 'listPtr'. * - * Side effects: - * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts - * to convert it to a list with a non-shared internal rep. Decrements the - * ref count of the object at the specified index within the list, - * replaces with the object designated by valuePtr, and increments the - * ref count of the replacement object. + * Value + * + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' does not refer to a list object and cannot be converted + * to one. An error message will be left in the interpreter result if + * interp is not NULL. + * + * TCL_ERROR + * + * An index designates an element outside the range [0..listLength-1], + * where 'listLength' is the count of elements in the list object + * designated by 'listPtr'. An error message is left in the + * interpreter result. + * + * Effect + * + * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If + * 'listPtr' is not already of type 'tclListType', it is converted and the + * internal representation is unshared. The 'refCount' of the element at + * 'index' is decremented and replaced in the list with the 'valuePtr', + * whose 'refCount' in turn is incremented. * - * It is the caller's responsibility to invalidate the string - * representation of the object. * *---------------------------------------------------------------------- */ @@ -1738,16 +1721,14 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with a list object's internal - * representation. + * Deallocate the storage associated with the internal representation of a + * a list object. * - * Results: - * None. + * Effect * - * Side effects: - * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all - * element objects, which may free them. + * The storage for the internal 'List' pointer of 'listPtr' is freed, the + * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' + * of each element of the list is decremented. * *---------------------------------------------------------------------- */ @@ -1776,14 +1757,12 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to share the + * Initialize the internal representation of a list 'Tcl_Obj' to share the * internal representation of an existing list object. * - * Results: - * None. + * Effect * - * Side effects: - * The reference count of the List internal rep is incremented. + * The 'refCount' of the List internal rep is incremented. * *---------------------------------------------------------------------- */ @@ -1803,16 +1782,20 @@ DupListInternalRep( * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object "objPtr". + * Convert any object to a list. + * + * Value * - * Results: - * The return value is TCL_OK or TCL_ERROR. If an error occurs during - * conversion, an error message is left in the interpreter's result - * unless "interp" is NULL. + * TCL_OK + * + * Success. The internal representation of 'objPtr' is set, and the type + * of 'objPtr' is 'tclListType'. + * + * TCL_ERROR + * + * An error occured during conversion. An error message is left in the + * interpreter's result if 'interp' is not NULL. * - * Side effects: - * If no error occurs, a list is stored as "objPtr"s internal - * representation. * *---------------------------------------------------------------------- */ @@ -1937,18 +1920,16 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. Note: This - * function does not invalidate an existing old string rep so storage - * will be lost if this has not already been done. + * Update the string representation for a list object. + * + * Any previously-exising string representation is not invalidated, so + * storage is lost if this has not been taken care of. * - * Results: - * None. + * Effect * - * 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. + * The string representation of 'listPtr' is set to the resulting string. + * This string will be empty if the list has no elements. It is assumed + * that the list internal representation is not NULL. * *---------------------------------------------------------------------- */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 1a00011..fdbc89a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2468,23 +2468,26 @@ Tcl_SetIntObj( * * Tcl_GetIntFromObj -- * - * Attempt to return an int from the Tcl object "objPtr". If the object - * is not already an int, an attempt will be made to convert it to one. + * Retrieve the integer value of 'objPtr'. * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. + * Value * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object can not be - * represented by an int, an error message is left in the interpreter's - * result unless "interp" is NULL. + * TCL_OK * - * Side effects: - * If the object is not already an int, the conversion will free any old - * internal representation. + * Success. + * + * TCL_ERROR + * + * An error occurred during conversion or the integral value can not + * be represented as an integer (it might be too large). An error + * message is left in the interpreter's result if 'interp' is not + * NULL. + * + * Effect + * + * 'objPtr' is converted to an integer if necessary if it is not one + * already. The conversion frees any previously-existing internal + * representation. * *---------------------------------------------------------------------- */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 411eabb..bfa4b2d 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3479,22 +3479,27 @@ TclFormatInt( * * TclGetIntForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. - * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. - * - * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. - * + * Provides an integer corresponding to the list index held in a Tcl + * object. The string value 'objPtr' is expected have the format + * integer([+-]integer)? or end([+-]integer)?. + * + * Value + * TCL_OK + * + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. + * + * TCL_ERROR + * + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. + * + * Effect + * + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. + * *---------------------------------------------------------------------- */ -- cgit v0.12 From 27e8f4db3d5d3fa5840fc71f3cf231238ff2863b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Nov 2017 14:50:08 +0000 Subject: More tcl8 -> tcl9 renumbering, for example related to the installation of Tcl packages where tcl9 actually can find them. --- library/safe.tcl | 2 +- tools/README | 2 +- tools/checkLibraryDoc.tcl | 4 ++-- unix/Makefile.in | 14 +++++++------- win/Makefile.in | 14 +++++++------- win/README | 4 ++-- win/makefile.vc | 26 +++++++++++--------------- win/tcl.hpj.in | 4 ++-- 8 files changed, 33 insertions(+), 37 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index ea6391d..c48d002 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -113,7 +113,7 @@ proc ::safe::CheckInterp {slave} { # we had the bad idea to support for the sake of user simplicity in # create/init but which makes life hard in configure... # So this will be hopefully written and some integrated with opt1.0 -# (hopefully for tcl8.1 ?) +# (hopefully for tcl9.0 ?) proc ::safe::interpConfigure {args} { switch [llength $args] { 1 { diff --git a/tools/README b/tools/README index f4bf627..87a9af4 100644 --- a/tools/README +++ b/tools/README @@ -12,7 +12,7 @@ Generating HTML files. The tcl-tk-man-html.tcl script from Robert Critchlow generates a nice set of HTML with good cross references. Use it like - tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2 + tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl9.0 This script is very picky about the organization of man pages, effectively acting as a style enforcer. diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index 6d147ac..a220ea8 100755 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -3,7 +3,7 @@ # This script attempts to determine what APIs exist in the source base that # have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list -# against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch]) +# against the list of Pkg_ APIs found in the source (e.g., tcl9.0/*/*.[ch]) # we create six lists: # 1) APIs in Source not in Docs. # 2) APIs in Docs not in Source. @@ -106,7 +106,7 @@ proc main {} { if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" - puts " pkgDir == /home/surles/cvs/tcl8.2" + puts " pkgDir == /home/surles/cvs/tcl9.0" exit 1 } diff --git a/unix/Makefile.in b/unix/Makefile.in index 032b5ac..4e2ddc8 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -829,7 +829,7 @@ install-libraries: libraries else true; \ fi; \ done; - @for i in opt0.4 http1.0 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ + @for i in opt0.4 http1.0 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -849,21 +849,21 @@ install-libraries: libraries $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ done; @echo "Installing package http 2.8.12 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/http-2.8.12.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @for i in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \ done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/msgcat-1.6.1.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; + @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/platform/shell-1.1.4.tm; @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ @@ -2097,7 +2097,7 @@ alldist: dist #-------------------------------------------------------------------------- # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & # tk8.* up two directories from the TOOL_DIR. # # Note that for platforms where this is important, it is more common to use a diff --git a/win/Makefile.in b/win/Makefile.in index a3275ba..e8b0ff6 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -630,7 +630,7 @@ install-libraries: libraries install-tzdata install-msgs else true; \ fi; \ done; - @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ + @for i in http1.0 opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -658,20 +658,20 @@ install-libraries: libraries install-tzdata install-msgs $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; @echo "Installing package http 2.8.12 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/http-2.8.12.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.6.1.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; + @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform/shell-1.1.4.tm; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ @@ -858,7 +858,7 @@ genstubs: # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool -# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & +# workspace. It depends on the Tcl & Tk being in directories called tcl9.* & # tk8.* up two directories from the TOOL_DIR. # diff --git a/win/README b/win/README index c8fdad6..022dc11 100644 --- a/win/README +++ b/win/README @@ -79,9 +79,9 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh87.exe, you must ensure that tcl87.dll is +Note that in order to run tclsh90.exe, you must ensure that tcl90.dll is on your path, in the system directory, or in the directory containing -tclsh87.exe. +tclsh90.exe. Note: Tcl no longer provides support for Win32s. diff --git a/win/makefile.vc b/win/makefile.vc index 2bff871..ceedc10 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1116,16 +1116,12 @@ install-binaries: install-libraries: tclConfig install-msgs install-tzdata @if not exist "$(SCRIPT_INSTALL_DIR)$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5" - @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6$(NULL)" \ - $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0" + @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform$(NULL)" \ + $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform" @echo Installing header files @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @@ -1157,19 +1153,19 @@ install-libraries: tclConfig install-msgs install-tzdata "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\http\http.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\msgcat-$(PKG_MSGCAT_VER).tm" @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\tcltest-$(PKG_TCLTEST_VER).tm" @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\platform.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform-$(PKG_PLATFORM_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform-$(PKG_PLATFORM_VER).tm" @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\platform\shell.tcl" \ - "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform\shell-$(PKG_SHELL_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform\shell-$(PKG_SHELL_VER).tm" @echo Installing $(TCLDDELIBNAME) !if $(STATIC_BUILD) !if !$(TCL_USE_STATIC_PACKAGES) diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in index a94cea6..a3d1a49 100644 --- a/win/tcl.hpj.in +++ b/win/tcl.hpj.in @@ -5,9 +5,9 @@ HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl86.cnt +CNT=tcl90.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl86.hlp +HLP=tcl90.hlp [FILES] tcl.rtf -- cgit v0.12 From 42764c99bec23aaae227ff1aba60c1ff9e7d9230 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Nov 2017 16:16:52 +0000 Subject: More code simplifications, with still equal functionality. --- generic/tclExecute.c | 6 ++---- generic/tclObj.c | 33 +++------------------------------ generic/tclStrToD.c | 40 ++++++---------------------------------- 3 files changed, 11 insertions(+), 68 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 51f9bff..68056c6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5776,7 +5776,7 @@ TEBCresume( { ClientData ptr1, ptr2; int type1, type2; - Tcl_WideInt w1, w2, wResult; + Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { @@ -5787,9 +5787,7 @@ TEBCresume( /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ int i; - if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { - type1 = TCL_NUMBER_WIDE; - } else { + if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { type1 = TCL_NUMBER_LONG; } } else if (type1 == TCL_NUMBER_BIG) { diff --git a/generic/tclObj.c b/generic/tclObj.c index 04fdeaa..634f8db 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3393,38 +3393,12 @@ Tcl_SetBignumObj( Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; + <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) { + Tcl_WideUInt value = 0, numBytes = sizeof(Tcl_WideUInt); + Tcl_WideUInt scratch; unsigned char *bytes = (unsigned char *) &scratch; if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForLong; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { - goto tooLargeForLong; - } - if (bignumValue->sign) { - TclSetWideObj(objPtr, -(long)value); - } else { - TclSetWideObj(objPtr, (long)value); - } - mp_clear(bignumValue); - return; - } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) { - Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { goto tooLargeForWide; } while (numBytes-- > 0) { @@ -3442,7 +3416,6 @@ Tcl_SetBignumObj( return; } tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 9663c21..ac2ca68 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -1268,21 +1268,7 @@ TclParseNumber( } } if (!octalSignificandOverflow) { - if (octalSignificandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (octalSignificandWide <= (MOST_BITS + signum)) { - objPtr->typePtr = &tclIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; - } - break; - } -#endif + if (octalSignificandWide > (MOST_BITS + signum)) { TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; @@ -1290,10 +1276,10 @@ TclParseNumber( objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = - - (long) octalSignificandWide; + - (Tcl_WideInt) octalSignificandWide; } else { objPtr->internalRep.wideValue = - (long) octalSignificandWide; + (Tcl_WideInt) octalSignificandWide; } } } @@ -1315,21 +1301,7 @@ TclParseNumber( } returnInteger: if (!significandOverflow) { - if (significandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (significandWide <= MOST_BITS+signum) { - objPtr->typePtr = &tclIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; - } - break; - } -#endif + if (significandWide > MOST_BITS+signum) { TclInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; @@ -1337,10 +1309,10 @@ TclParseNumber( objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = - - (long) significandWide; + - (Tcl_WideInt) significandWide; } else { objPtr->internalRep.wideValue = - (long) significandWide; + (Tcl_WideInt) significandWide; } } } -- cgit v0.12 From 2c1224dce7ce2f827991e0abf968d2ccdb31f32b Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 7 Nov 2017 20:54:02 +0000 Subject: TclOO object allocation: Set classPtr to NULL if it wasn't otherwise set. --- generic/tclOO.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 51731d3..e48158c 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -538,7 +538,8 @@ KillFoundation( * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. + * class's instance list. The caller must set the classPtr on the object, + * either to a class or to NULL. * * ---------------------------------------------------------------------- */ @@ -1701,6 +1702,8 @@ Tcl_NewObjectInstance( AllocClass(interp, oPtr); oPtr->selfCls = classPtr; TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; } /* -- cgit v0.12 From a982dd11fa97fd5c0f45076a0662f40a80f43503 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 8 Nov 2017 00:39:17 +0000 Subject: Modify TclCreateProc to handle arbitrary argument names, not just ASCII. --- generic/tclExecute.c | 4 +-- generic/tclInt.h | 2 +- generic/tclProc.c | 96 +++++++++++++++++++++++----------------------------- 3 files changed, 45 insertions(+), 57 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d43ddfd..3eba833 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1333,12 +1333,12 @@ TclStackAlloc( int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 29956ec..33a0236 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4445,7 +4445,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index 96bdcf3..8fc6dcb 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -393,13 +393,13 @@ TclCreateProc( Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { @@ -436,6 +436,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -473,12 +474,9 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -502,28 +500,28 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { int fieldCount, nameLength; size_t valueLength; - const char **fieldValues; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -531,9 +529,10 @@ TclCreateProc( goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } @@ -542,33 +541,29 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { @@ -584,7 +579,7 @@ TclCreateProc( */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) @@ -592,7 +587,6 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -607,12 +601,13 @@ TclCreateProc( size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -632,7 +627,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -640,19 +635,18 @@ TclCreateProc( procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -660,12 +654,9 @@ TclCreateProc( localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: @@ -686,9 +677,6 @@ TclCreateProc( } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } -- cgit v0.12 From 1ed5a135edb9b30eae6aa9dcc091929aba2c3864 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 14 Nov 2017 18:35:22 +0000 Subject: TIP 484 proposes a re-implementation of Tcl's "int" Tcl_ObjType. Since the new implementation is not consistent with the former one, any callers of Tcl_GetObjType("int") who are expecting the return value to point them at something playing by the former rules are at risk of having their code broken. In this branch I remove the registation of Tcl's "int" type, so such callers will get NULL (which they should already be able to handle) instead of something misleading them into breakage. Examine this branch and decide if it should be incorporated into TIP 484. --- generic/tclObj.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 634f8db..318e41f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -383,7 +383,6 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); -- cgit v0.12 From 07c71d17a255fb07143dbb73659a64a589a214f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 19 Dec 2017 15:20:32 +0000 Subject: Somewhat better backwards compatibility on 64-bit platforms. --- generic/tclObj.c | 4 ++-- generic/tclTestObj.c | 4 ++++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 183ad7f..8ec95ce 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -262,10 +262,10 @@ const Tcl_ObjType tclDoubleType = { SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ #else - "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 */ + "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ #endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 6b08761..547792a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1088,7 +1088,9 @@ TestobjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; +#ifndef TCL_WIDE_INT_IS_LONG if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { @@ -1116,9 +1118,11 @@ TestobjCmd( } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); +#ifndef TCL_WIDE_INT_IS_LONG } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "int", -1); +#endif } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); -- cgit v0.12 From 6631e46bd3d3c18c60f319c4879ce8682f954229 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Dec 2017 16:49:47 +0000 Subject: Remove handling of http 1.0 package files from Makefiles. --- unix/Makefile.in | 9 ++------- win/Makefile.in | 7 +------ win/makefile.vc | 3 --- 3 files changed, 3 insertions(+), 16 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index f3b9782..244ad29 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -829,7 +829,7 @@ install-libraries: libraries else true; \ fi; \ done; - @for i in opt0.4 http1.0 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ + @for i in opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ do \ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -843,11 +843,6 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; - @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"; - @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \ - do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \ - done; @echo "Installing package http 2.8.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm; @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/"; @@ -2010,7 +2005,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library - for i in http1.0 http opt msgcat reg dde tcltest platform; \ + for i in http opt msgcat reg dde tcltest platform; \ do \ mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ diff --git a/win/Makefile.in b/win/Makefile.in index a3275ba..5be7492 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -630,7 +630,7 @@ install-libraries: libraries install-tzdata install-msgs else true; \ fi; \ done; - @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ + @for i in opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -652,11 +652,6 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; - @echo "Installing library http1.0 directory"; - @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ - do \ - $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ - done; @echo "Installing package http 2.8.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm; @echo "Installing library opt0.4 directory"; diff --git a/win/makefile.vc b/win/makefile.vc index de80452..64717af 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -860,9 +860,6 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata @$(CPY) "$(WINDIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(WINDIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\" @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\" - @echo Installing library http1.0 directory - @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ - "$(SCRIPT_INSTALL_DIR)\http1.0\" @echo Installing library opt0.4 directory @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" -- cgit v0.12 From a922e9fd15daadaa80f131c7cb9884423e6873a3 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Dec 2017 16:54:50 +0000 Subject: Remove http 1.0 files from fossil management. --- library/http1.0/http.tcl | 377 ------------------------------------------- library/http1.0/pkgIndex.tcl | 11 -- 2 files changed, 388 deletions(-) delete mode 100644 library/http1.0/http.tcl delete mode 100644 library/http1.0/pkgIndex.tcl diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl deleted file mode 100644 index 8329de4..0000000 --- a/library/http1.0/http.tcl +++ /dev/null @@ -1,377 +0,0 @@ -# http.tcl -# Client-side HTTP for GET, POST, and HEAD commands. -# These routines can be used in untrusted code that uses the Safesock -# security policy. -# These procedures use a callback interface to avoid using vwait, -# which is not defined in the safe base. -# -# See the http.n man page for documentation - -package provide http 1.0 - -array set http { - -accept */* - -proxyhost {} - -proxyport {} - -useragent {Tcl http client package 1.0} - -proxyfilter httpProxyRequired -} -proc http_config {args} { - global http - set options [lsort [array names http -*]] - set usage [join $options ", "] - if {[llength $args] == 0} { - set result {} - foreach name $options { - lappend result $name $http($name) - } - return $result - } - regsub -all -- - $options {} options - set pat ^-([join $options |])$ - if {[llength $args] == 1} { - set flag [lindex $args 0] - if {[regexp -- $pat $flag]} { - return $http($flag) - } else { - return -code error "Unknown option $flag, must be: $usage" - } - } else { - foreach {flag value} $args { - if {[regexp -- $pat $flag]} { - set http($flag) $value - } else { - return -code error "Unknown option $flag, must be: $usage" - } - } - } -} - - proc httpFinish { token {errormsg ""} } { - upvar #0 $token state - global errorInfo errorCode - if {[string length $errormsg] != 0} { - set state(error) [list $errormsg $errorInfo $errorCode] - set state(status) error - } - catch {close $state(sock)} - catch {after cancel $state(after)} - if {[info exists state(-command)]} { - if {[catch {eval $state(-command) {$token}} err]} { - if {[string length $errormsg] == 0} { - set state(error) [list $err $errorInfo $errorCode] - set state(status) error - } - } - unset state(-command) - } -} -proc http_reset { token {why reset} } { - upvar #0 $token state - set state(status) $why - catch {fileevent $state(sock) readable {}} - httpFinish $token - if {[info exists state(error)]} { - set errorlist $state(error) - unset state(error) - eval error $errorlist - } -} -proc http_get { url args } { - global http - if {![info exists http(uid)]} { - set http(uid) 0 - } - set token http#[incr http(uid)] - upvar #0 $token state - http_reset $token - array set state { - -blocksize 8192 - -validate 0 - -headers {} - -timeout 0 - state header - meta {} - currentsize 0 - totalsize 0 - type text/html - body {} - status "" - } - set options {-blocksize -channel -command -handler -headers \ - -progress -query -validate -timeout} - set usage [join $options ", "] - regsub -all -- - $options {} options - set pat ^-([join $options |])$ - foreach {flag value} $args { - if {[regexp $pat $flag]} { - # Validate numbers - if {[info exists state($flag)] && \ - [regexp {^[0-9]+$} $state($flag)] && \ - ![regexp {^[0-9]+$} $value]} { - return -code error "Bad value for $flag ($value), must be integer" - } - set state($flag) $value - } else { - return -code error "Unknown option $flag, can be: $usage" - } - } - if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \ - x proto host y port srvurl]} { - error "Unsupported URL: $url" - } - if {[string length $port] == 0} { - set port 80 - } - if {[string length $srvurl] == 0} { - set srvurl / - } - if {[string length $proto] == 0} { - set url http://$url - } - set state(url) $url - if {![catch {$http(-proxyfilter) $host} proxy]} { - set phost [lindex $proxy 0] - set pport [lindex $proxy 1] - } - if {$state(-timeout) > 0} { - set state(after) [after $state(-timeout) [list http_reset $token timeout]] - } - if {[info exists phost] && [string length $phost]} { - set srvurl $url - set s [socket $phost $pport] - } else { - set s [socket $host $port] - } - set state(sock) $s - - # Send data in cr-lf format, but accept any line terminators - - fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize) - - # The following is disallowed in safe interpreters, but the socket - # is already in non-blocking mode in that case. - - catch {fconfigure $s -blocking off} - set len 0 - set how GET - if {[info exists state(-query)]} { - set len [string length $state(-query)] - if {$len > 0} { - set how POST - } - } elseif {$state(-validate)} { - set how HEAD - } - puts $s "$how $srvurl HTTP/1.0" - puts $s "Accept: $http(-accept)" - puts $s "Host: $host" - puts $s "User-Agent: $http(-useragent)" - foreach {key value} $state(-headers) { - regsub -all \[\n\r\] $value {} value - set key [string trim $key] - if {[string length $key]} { - puts $s "$key: $value" - } - } - if {$len > 0} { - puts $s "Content-Length: $len" - puts $s "Content-Type: application/x-www-form-urlencoded" - puts $s "" - fconfigure $s -translation {auto binary} - puts -nonewline $s $state(-query) - } else { - puts $s "" - } - flush $s - fileevent $s readable [list httpEvent $token] - if {! [info exists state(-command)]} { - http_wait $token - } - return $token -} -proc http_data {token} { - upvar #0 $token state - return $state(body) -} -proc http_status {token} { - upvar #0 $token state - return $state(status) -} -proc http_code {token} { - upvar #0 $token state - return $state(http) -} -proc http_size {token} { - upvar #0 $token state - return $state(currentsize) -} - - proc httpEvent {token} { - upvar #0 $token state - set s $state(sock) - - if {[eof $s]} { - httpEof $token - return - } - if {$state(state) == "header"} { - set n [gets $s line] - if {$n == 0} { - set state(state) body - if {![regexp -nocase ^text $state(type)]} { - # Turn off conversions for non-text data - fconfigure $s -translation binary - if {[info exists state(-channel)]} { - fconfigure $state(-channel) -translation binary - } - } - if {[info exists state(-channel)] && - ![info exists state(-handler)]} { - # Initiate a sequence of background fcopies - fileevent $s readable {} - httpCopyStart $s $token - } - } elseif {$n > 0} { - if {[regexp -nocase {^content-type:(.+)$} $line x type]} { - set state(type) [string trim $type] - } - if {[regexp -nocase {^content-length:(.+)$} $line x length]} { - set state(totalsize) [string trim $length] - } - if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} { - lappend state(meta) $key $value - } elseif {[regexp ^HTTP $line]} { - set state(http) $line - } - } - } else { - if {[catch { - if {[info exists state(-handler)]} { - set n [eval $state(-handler) {$s $token}] - } else { - set block [read $s $state(-blocksize)] - set n [string length $block] - if {$n >= 0} { - append state(body) $block - } - } - if {$n >= 0} { - incr state(currentsize) $n - } - } err]} { - httpFinish $token $err - } else { - if {[info exists state(-progress)]} { - eval $state(-progress) {$token $state(totalsize) $state(currentsize)} - } - } - } -} - proc httpCopyStart {s token} { - upvar #0 $token state - if {[catch { - fcopy $s $state(-channel) -size $state(-blocksize) -command \ - [list httpCopyDone $token] - } err]} { - httpFinish $token $err - } -} - proc httpCopyDone {token count {error {}}} { - upvar #0 $token state - set s $state(sock) - incr state(currentsize) $count - if {[info exists state(-progress)]} { - eval $state(-progress) {$token $state(totalsize) $state(currentsize)} - } - if {([string length $error] != 0)} { - httpFinish $token $error - } elseif {[eof $s]} { - httpEof $token - } else { - httpCopyStart $s $token - } -} - proc httpEof {token} { - upvar #0 $token state - if {$state(state) == "header"} { - # Premature eof - set state(status) eof - } else { - set state(status) ok - } - set state(state) eof - httpFinish $token -} -proc http_wait {token} { - upvar #0 $token state - if {![info exists state(status)] || [string length $state(status)] == 0} { - vwait $token\(status) - } - if {[info exists state(error)]} { - set errorlist $state(error) - unset state(error) - eval error $errorlist - } - return $state(status) -} - -# Call http_formatQuery with an even number of arguments, where the first is -# a name, the second is a value, the third is another name, and so on. - -proc http_formatQuery {args} { - set result "" - set sep "" - foreach i $args { - append result $sep [httpMapReply $i] - if {$sep != "="} { - set sep = - } else { - set sep & - } - } - return $result -} - -# do x-www-urlencoded character mapping -# The spec says: "non-alphanumeric characters are replaced by '%HH'" -# 1 leave alphanumerics characters alone -# 2 Convert every other character to an array lookup -# 3 Escape constructs that are "special" to the tcl parser -# 4 "subst" the result, doing all the array substitutions - - proc httpMapReply {string} { - global httpFormMap - set alphanumeric a-zA-Z0-9 - if {![info exists httpFormMap]} { - - for {set i 1} {$i <= 256} {incr i} { - set c [format %c $i] - if {![string match \[$alphanumeric\] $c]} { - set httpFormMap($c) %[format %.2x $i] - } - } - # These are handled specially - array set httpFormMap { - " " + \n %0d%0a - } - } - regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string - regsub -all \n $string {\\n} string - regsub -all \t $string {\\t} string - regsub -all {[][{})\\]\)} $string {\\&} string - return [subst $string] -} - -# Default proxy filter. - proc httpProxyRequired {host} { - global http - if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { - if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} { - set http(-proxyport) 8080 - } - return [list $http(-proxyhost) $http(-proxyport)] - } else { - return {} - } -} diff --git a/library/http1.0/pkgIndex.tcl b/library/http1.0/pkgIndex.tcl deleted file mode 100644 index ab6170f..0000000 --- a/library/http1.0/pkgIndex.tcl +++ /dev/null @@ -1,11 +0,0 @@ -# Tcl package index file, version 1.0 -# This file is generated by the "pkg_mkIndex" command -# and sourced either when an application starts up or -# by a "package unknown" script. It invokes the -# "package ifneeded" command to set up package-related -# information so that packages will be loaded automatically -# in response to "package require" commands. When this -# script is sourced, the variable $dir must contain the -# full path name of this file's directory. - -package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}] -- cgit v0.12 From b0898beca68aa150062cb6eacc8daee6e6490f55 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Dec 2017 17:38:10 +0000 Subject: Remove http 1.0 tests. --- tests/httpold.test | 300 ----------------------------------------------------- 1 file changed, 300 deletions(-) delete mode 100644 tests/httpold.test diff --git a/tests/httpold.test b/tests/httpold.test deleted file mode 100644 index dda0189..0000000 --- a/tests/httpold.test +++ /dev/null @@ -1,300 +0,0 @@ -# -*- tcl -*- -# Commands covered: http_config, http_get, http_wait, http_reset -# -# This file contains a collection of tests for the http script library. -# Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -if {[catch {package require http 1.0}]} { - if {[info exists httpold]} { - catch {puts "Cannot load http 1.0 package"} - ::tcltest::cleanupTests - return - } else { - catch {puts "Running http 1.0 tests in slave interp"} - set interp [interp create httpold] - $interp eval [list set httpold "running"] - $interp eval [list set argv $argv] - $interp eval [list source [info script]] - interp delete $interp - ::tcltest::cleanupTests - return - } -} - -if {$::tcl_platform(os) eq "Darwin"} { - # Name resolution often a problem on OSX; not focus of HTTP package anyway - set HOST localhost -} else { - set HOST [info hostname] -} - -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} - -## -## The httpd script implement a stub http server -## -source [file join [file dirname [info script]] httpd] - -if [catch {httpd_init 0} listen] { - puts "Cannot start http server, http test skipped" - catch {unset port} - ::tcltest::cleanupTests - return -} - -test httpold-1.1 {http_config} { - http_config -} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} - -test httpold-1.2 {http_config} { - http_config -proxyfilter -} httpProxyRequired - -test httpold-1.3 {http_config} { - catch {http_config -junk} -} 1 - -test httpold-1.4 {http_config} { - http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" - set x [http_config] - http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ - -useragent "Tcl http client package 1.0" - set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} - -test httpold-1.5 {http_config} { - catch {http_config -proxyhost {} -junk 8080} -} 1 - -test httpold-2.1 {http_reset} { - catch {http_reset http#1} -} 0 - -test httpold-3.1 {http_get} { - catch {http_get -bogus flag} -} 1 -test httpold-3.2 {http_get} { - catch {http_get http:junk} err - set err -} {Unsupported URL: http:junk} - -set url ${::HOST}:$port -test httpold-3.3 {http_get} { - set token [http_get $url] - http_data $token -} "HTTP/1.0 TEST -

Hello, World!

-

GET /

-" - -set tail /a/b/c -set url ${::HOST}:$port/a/b/c -set binurl ${::HOST}:$port/binary - -test httpold-3.4 {http_get} { - set token [http_get $url] - http_data $token -} "HTTP/1.0 TEST -

Hello, World!

-

GET $tail

-" - -proc selfproxy {host} { - global port - return [list ${::HOST} $port] -} -test httpold-3.5 {http_get} { - http_config -proxyfilter selfproxy - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "HTTP/1.0 TEST -

Hello, World!

-

GET http://$url

-" - -test httpold-3.6 {http_get} { - http_config -proxyfilter bogus - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "HTTP/1.0 TEST -

Hello, World!

-

GET $tail

-" - -test httpold-3.7 {http_get} { - set token [http_get $url -headers {Pragma no-cache}] - http_data $token -} "HTTP/1.0 TEST -

Hello, World!

-

GET $tail

-" - -test httpold-3.8 {http_get} { - set token [http_get $url -query Name=Value&Foo=Bar] - http_data $token -} "HTTP/1.0 TEST -

Hello, World!

-

POST $tail

-

Query

-
-
Name
Value -
Foo
Bar -
-" - -test httpold-3.9 {http_get} { - set token [http_get $url -validate 1] - http_code $token -} "HTTP/1.0 200 OK" - - -test httpold-4.1 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - expr ($data(totalsize) == $meta(Content-Length)) -} 1 - -test httpold-4.2 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] -} 0 - -test httpold-4.3 {httpEvent} { - set token [http_get $url] - http_code $token -} {HTTP/1.0 200 Data follows} - -test httpold-4.4 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - set in [open $testfile] - set x [read $in] - close $in - removeFile $testfile - set x -} "HTTP/1.0 TEST -

Hello, World!

-

GET $tail

-" - -test httpold-4.5 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - upvar #0 $token data - removeFile $testfile - expr $data(currentsize) == $data(totalsize) -} 1 - -test httpold-4.6 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $binurl -channel $out] - close $out - set in [open $testfile] - fconfigure $in -translation binary - set x [read $in] - close $in - removeFile $testfile - set x -} "$bindata$binurl" - -proc myProgress {token total current} { - global progress httpLog - if {[info exists httpLog] && $httpLog} { - puts "progress $total $current" - } - set progress [list $total $current] -} -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test httpold-4.6 {httpEvent} { - set token [http_get $url -blocksize 50 -progress myProgress] - set progress - } {111 111} -} -test httpold-4.7 {httpEvent} { - set token [http_get $url -progress myProgress] - set progress -} {111 111} -test httpold-4.8 {httpEvent} { - set token [http_get $url] - http_status $token -} {ok} -test httpold-4.9 {httpEvent} { - set token [http_get $url -progress myProgress] - http_code $token -} {HTTP/1.0 200 Data follows} -test httpold-4.10 {httpEvent} { - set token [http_get $url -progress myProgress] - http_size $token -} {111} -test httpold-4.11 {httpEvent} { - set token [http_get $url -timeout 1 -command {#}] - http_reset $token - http_status $token -} {reset} -test httpold-4.12 {httpEvent} { - update - set x {} - after 500 {lappend x ok} - set token [http_get $url -timeout 1 -command {lappend x fail}] - vwait x - list [http_status $token] $x -} {timeout ok} - -test httpold-5.1 {http_formatQuery} { - http_formatQuery name1 value1 name2 "value two" -} {name1=value1&name2=value+two} - -test httpold-5.2 {http_formatQuery} { - http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%a1%a2%a2} - -test httpold-5.3 {http_formatQuery} { - http_formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} - -test httpold-6.1 {httpProxyRequired} { - update - http_config -proxyhost ${::HOST} -proxyport $port - set token [http_get $url] - http_wait $token - http_config -proxyhost {} -proxyport {} - upvar #0 $token data - set data(body) -} "HTTP/1.0 TEST -

Hello, World!

-

GET http://$url

-" - -# cleanup -catch {unset url} -catch {unset port} -catch {unset data} -close $listen -::tcltest::cleanupTests -return -- cgit v0.12 From daa36e9a1bc07b908f1f3fdb5e9fe52b699047e5 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 29 Dec 2017 17:47:50 +0000 Subject: Use http 2 instead of http 1 for Safe Base testing. --- tests/safe.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 33ee166..df60de6 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -180,17 +180,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} { +test safe-7.1 {tests that everything works at high level} -body { set i [safe::interpCreate] # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) - set v [interp eval $i {package require http 1}] + set v [interp eval $i {package require http 2}] # no error shall occur: - interp eval $i {http_config} + interp eval $i {http::config} safe::interpDelete $i set v -} 1.0 +} -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) -- cgit v0.12 From 03a71b070685eecb97de3d3cfe830823b056054e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jan 2018 09:18:19 +0000 Subject: Put old "int" type back. Not used by Tcl anymore, but this restores compatibility with Tk < 8.6.9 and some extensions: "nsf", "tdbcload", "tclxml" and "VecTcl" (this workaround was used by "boolean" as well, when its internal implementation changed, there's still an oldBooleanType because of that) --- generic/tclInt.h | 1 + generic/tclObj.c | 31 +++++++++++++++++++++++++++++++ 2 files changed, 32 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index 50d0469..d74cd0e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2713,6 +2713,7 @@ MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; +MODULE_SCOPE const Tcl_ObjType tclOldIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; diff --git a/generic/tclObj.c b/generic/tclObj.c index 8ec95ce..e02f6c4 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -210,6 +210,9 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void UpdateStringOfOldInt(Tcl_Obj *objPtr); +#endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void UpdateStringOfBignum(Tcl_Obj *objPtr); @@ -272,6 +275,15 @@ const Tcl_ObjType tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +const Tcl_ObjType tclOldIntType = { + "int", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ +}; +#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ @@ -400,6 +412,9 @@ TclInitObjSubsystem(void) /* For backward compatibility only ... */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_RegisterObjType(&tclIntType); +#if !defined(TCL_WIDE_INT_IS_LONG) + Tcl_RegisterObjType(&tclOldIntType); +#endif Tcl_RegisterObjType(&oldBooleanType); #endif @@ -2548,6 +2563,22 @@ UpdateStringOfInt( memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char buffer[TCL_INTEGER_SPACE]; + register int len; + + len = TclFormatInt(buffer, objPtr->internalRep.longValue); + + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, buffer, (unsigned) len + 1); + objPtr->length = len; +} +#endif /* *---------------------------------------------------------------------- -- cgit v0.12 From fb10dc69eead85da6836ed1c28ee1269d1738337 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jan 2018 09:54:40 +0000 Subject: make the old "int" type "static", since it's just used in a single file. --- generic/tclInt.h | 1 - generic/tclObj.c | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index d74cd0e..50d0469 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2713,7 +2713,6 @@ MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; -MODULE_SCOPE const Tcl_ObjType tclOldIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; diff --git a/generic/tclObj.c b/generic/tclObj.c index e02f6c4..ebe1450 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -276,7 +276,7 @@ const Tcl_ObjType tclIntType = { SetIntFromAny /* setFromAnyProc */ }; #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) -const Tcl_ObjType tclOldIntType = { +static const Tcl_ObjType oldIntType = { "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -413,7 +413,7 @@ TclInitObjSubsystem(void) #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_RegisterObjType(&tclIntType); #if !defined(TCL_WIDE_INT_IS_LONG) - Tcl_RegisterObjType(&tclOldIntType); + Tcl_RegisterObjType(&oldIntType); #endif Tcl_RegisterObjType(&oldBooleanType); #endif -- cgit v0.12 From 2eba1ce11e24976640d99ae78cec26cc67508f15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Jan 2018 13:29:01 +0000 Subject: Rename (internal) TclNewWideObj macro to TclNewIntObj. Change Tcl_SetIntObj/Tcl_SetLongObj to macro's referencing Tcl_SetWideIntObj (since all of those do the same now) --- generic/tclBasic.c | 2 +- generic/tclCmdMZ.c | 2 +- generic/tclDecls.h | 6 ++++-- generic/tclExecute.c | 46 +++++++++++++++++++++++----------------------- generic/tclInt.h | 6 +++--- generic/tclObj.c | 11 ++++++----- generic/tclScan.c | 4 ++-- generic/tclStubInit.c | 1 + generic/tclZlib.c | 2 +- 9 files changed, 42 insertions(+), 38 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 51d9a64..e2879f1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3686,7 +3686,7 @@ OldMathFuncProc( */ if (funcResult.type == TCL_INT) { - TclNewWideObj(valuePtr, funcResult.intValue); + TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8ae3f51..fd9858b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -4303,7 +4303,7 @@ TclNRTryObjCmd( } info[0] = objv[i]; /* type */ - TclNewWideObj(info[1], code); /* returnCode */ + TclNewIntObj(info[1], code); /* returnCode */ if (info[2] == NULL) { /* errorCodePrefix */ TclNewObj(info[2]); } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 464609c..49f34e8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3935,7 +3935,6 @@ extern const TclStubs *tclStubsPtr; * without introducing a binary incompatibility. */ # undef Tcl_GetLongFromObj -# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj # undef Tcl_UniCharNcmp @@ -3943,7 +3942,6 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_UtfNcasecmp # undef Tcl_UniCharNcasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) -# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ int intValue; @@ -3975,6 +3973,10 @@ extern const TclStubs *tclStubsPtr; #define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) #undef Tcl_DbNewLongObj #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) +#undef Tcl_SetIntObj +#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (int)(value)) +#undef Tcl_SetLongObj +#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (long)(value)) /* * Deprecated Tcl procedures: diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 81f7fe7..eb730ce 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -325,7 +325,7 @@ VarHashCreateVar( NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewWideObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -346,7 +346,7 @@ VarHashCreateVar( NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewWideObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -357,7 +357,7 @@ VarHashCreateVar( #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewWideObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -366,7 +366,7 @@ VarHashCreateVar( #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewWideObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -851,9 +851,9 @@ TclCreateExecEnv( + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewWideObj(eePtr->constants[0], 0); + TclNewIntObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewWideObj(eePtr->constants[1], 1); + TclNewIntObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; @@ -1849,7 +1849,7 @@ TclIncrObj( */ if (!Overflowing(w1, w2, sum)) { - Tcl_SetWideIntObj(valuePtr, sum); + TclSetIntObj(valuePtr, sum); return TCL_OK; } } @@ -3649,7 +3649,7 @@ TEBCresume( TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewWideObj(objResultPtr, sum); + TclNewIntObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { @@ -3687,7 +3687,7 @@ TEBCresume( } else { objResultPtr = objPtr; } - TclNewWideObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); @@ -3701,7 +3701,7 @@ TEBCresume( * All other cases, flow through to generic handling. */ - TclNewWideObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: @@ -4399,7 +4399,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: - TclNewWideObj(objResultPtr, iPtr->varFramePtr->level); + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_INFO_LEVEL_ARGS: { @@ -4768,7 +4768,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewWideObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); @@ -5239,7 +5239,7 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); - TclNewWideObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); @@ -5594,7 +5594,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewWideObj(objResultPtr, match); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: @@ -5602,7 +5602,7 @@ TEBCresume( TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewWideObj(objResultPtr, match); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: @@ -5798,7 +5798,7 @@ TEBCresume( type1 = TCL_NUMBER_WIDE; } } - TclNewWideObj(objResultPtr, type1); + TclNewIntObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); NEXT_INST_F(1, 1, 1); @@ -5991,7 +5991,7 @@ TEBCresume( if (w1 > 0L) { objResultPtr = TCONST(0); } else { - TclNewWideObj(objResultPtr, -1); + TclNewIntObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -6190,7 +6190,7 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - Tcl_SetWideIntObj(valuePtr, wResult); + TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); @@ -6298,7 +6298,7 @@ TEBCresume( if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewWideObj(objResultPtr, ~w1); + TclNewIntObj(objResultPtr, ~w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } @@ -6336,7 +6336,7 @@ TEBCresume( w1 = *((const Tcl_WideInt *) ptr1); if (w1 != LLONG_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewWideObj(objResultPtr, -w1); + TclNewIntObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } @@ -6501,7 +6501,7 @@ TEBCresume( oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewWideObj(iterVarPtr->value.objPtr, -1); + TclNewIntObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { TclSetIntObj(oldValuePtr, -1); @@ -6872,7 +6872,7 @@ TEBCresume( NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewWideObj(objResultPtr, result); + TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); @@ -7973,7 +7973,7 @@ ExecuteExtendedBinaryMathOp( if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ + TclSetIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ diff --git a/generic/tclInt.h b/generic/tclInt.h index b061ed0..d5f4c9b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4583,7 +4583,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * - * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); @@ -4592,7 +4592,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; */ #ifndef TCL_MEM_DEBUG -#define TclNewWideObj(objPtr, i) \ +#define TclNewIntObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ @@ -4625,7 +4625,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewWideObj(objPtr, w) \ +#define TclNewIntObj(objPtr, w) \ (objPtr) = Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index b4dfc63..5f60d9d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1769,7 +1769,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewWideObj(objPtr, boolValue!=0); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -2416,7 +2416,7 @@ Tcl_NewIntObj( { register Tcl_Obj *objPtr; - TclNewWideObj(objPtr, intValue); + TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2630,7 +2630,7 @@ Tcl_NewLongObj( { register Tcl_Obj *objPtr; - TclNewWideObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2722,6 +2722,7 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ +#undef Tcl_SetLongObj void Tcl_SetLongObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2891,7 +2892,7 @@ Tcl_NewWideIntObj( register Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2943,7 +2944,7 @@ Tcl_DbNewWideIntObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } diff --git a/generic/tclScan.c b/generic/tclScan.c index e0798df..1bdc3ef 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -942,7 +942,7 @@ Tcl_ScanObjCmd( (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); } } else if (!(flags & SCAN_BIG)) { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { @@ -956,7 +956,7 @@ Tcl_ScanObjCmd( sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetLongObj(objPtr, value); + TclSetIntObj(objPtr, value); } } objs[objIndex++] = objPtr; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index d255e97..86406c1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -43,6 +43,7 @@ #undef TclpGetPid #undef TclSockMinimumBuffers #undef Tcl_SetIntObj +#undef Tcl_SetLongObj #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt diff --git a/generic/tclZlib.c b/generic/tclZlib.c index dc124f7..994bcef 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -373,7 +373,7 @@ ConvertErrorToList( default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewWideObj(objv[3], code); + TclNewIntObj(objv[3], code); return Tcl_NewListObj(4, objv); } } -- cgit v0.12 From 1a988444125d7bee60784dbe4958d4a428c310b4 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 28 Jan 2018 18:21:09 +0000 Subject: Preparation to provide TclNRPackageObjectCmd: Eliminate the loop in PkgRequireCore so that TclNRAddCallback can be added at the needed spots. This checkin creates a crash in test package-3.12 . Pushing the work off the 8.7.* branch and onto a feature branch for now. --- generic/tclPkg.c | 553 ++++++++++++++++++++++++++++--------------------------- 1 file changed, 277 insertions(+), 276 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 2b842b4..02f66f0 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -88,6 +88,8 @@ static Package * FindPackage(Tcl_Interp *interp, const char *name); static int PkgRequireCore(Tcl_Interp *interp, const char *name, int reqc, Tcl_Obj *const reqv[], void *clientDataPtr); +static int SelectPackage (Tcl_Interp *interp, const char *name, + Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]); /* * Helper macros. @@ -417,343 +419,342 @@ PkgRequireCore( * available. */ void *clientDataPtr) { - Interp *iPtr = (Interp *) interp; Package *pkgPtr; - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion, *bestStableVersion; - /* Internal rep. of versions */ - int availStable, code, satisfies, pass; + int code, satisfies; char *script, *pkgVersionI; Tcl_DString command; + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } + if (pkgPtr->version == NULL) { + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); + + if ((code != TCL_OK) && (code != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", code)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + code = TCL_ERROR; + } + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return code; + } + Tcl_ResetResult(interp); + } + /* pkgPtr may now be invalid, so refresh it. */ + pkgPtr = FindPackage(interp, name); + code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } + } + } + + if (pkgPtr->version == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; + } + /* - * It can take up to three passes to find the package: one pass to run the - * "package unknown" script, one to run the "package ifneeded" script for - * a specific version, and a final pass to lookup the package loaded by - * the "package ifneeded" script. + * Ensure that the provided version meets the current requirements. */ - for (pass=1 ;; pass++) { - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version != NULL) { - break; - } + if (reqc != 0) { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - /* - * Check whether we're already attempting to load some version of this - * package (circular dependency detection). - */ + ckfree(pkgVersionI); - if (pkgPtr->clientData != NULL) { + if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "circular package dependency:" - " attempt to provide %s %s requires %s", - name, (char *) pkgPtr->clientData, name)); + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return TCL_ERROR; } + } - /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. - */ - - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; - bestStableVersion = NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { - /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. - */ + *ptr = pkgPtr->clientData; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + return TCL_OK; +} + +int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) { + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion, *bestStableVersion; + /* Internal rep. of versions */ + char *script; + int availStable, code, satisfies; + Interp *iPtr = (Interp *) interp; - continue; - } + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ - /* Check satisfaction of requirements before considering the current version further. */ - if (reqc > 0) { - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - ckfree(availVersion); - availVersion = NULL; - continue; - } - } + if (pkgPtr->clientData != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); + AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + return TCL_ERROR; + } - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. + */ - /* - * Note: Used internal reps in the comparison! - */ + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + bestStableVersion = NULL; - if (res > 0) { - /* - * The version of the package sought is better than the - * currently selected version. - */ - ckfree(bestVersion); - bestVersion = NULL; - goto newbest; - } - } else { - newbest: - /* We have found a version which is better than our max. */ + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { + /* + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ - bestPtr = availPtr; - CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); - } + continue; + } - if (!availStable) { + /* Check satisfaction of requirements before considering the current version further. */ + if (reqc > 0) { + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } + } - if (bestStablePtr != NULL) { - int res = CompareVersions(availVersion, bestStableVersion, NULL); + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + if (res > 0) { /* - * Note: Used internal reps in the comparison! + * The version of the package sought is better than the + * currently selected version. */ - - if (res > 0) { - /* - * This stable version of the package sought is better - * than the currently selected stable version. - */ - ckfree(bestStableVersion); - bestStableVersion = NULL; - goto newstable; - } - } else { - newstable: - /* We have found a stable version which is better than our max stable. */ - bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + ckfree(bestVersion); + bestVersion = NULL; + goto newbest; } + } else { + newbest: + /* We have found a version which is better than our max. */ - ckfree(availVersion); - availVersion = NULL; - } /* end for */ - - /* - * Clean up memorized internal reps, if any. - */ - - if (bestVersion != NULL) { - ckfree(bestVersion); - bestVersion = NULL; + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); } - if (bestStableVersion != NULL) { - ckfree(bestStableVersion); - bestStableVersion = NULL; + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; } - /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. - */ - - if ((iPtr->packagePrefer == PKG_PREFER_STABLE) - && (bestStablePtr != NULL)) { - bestPtr = bestStablePtr; - } + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); - if (bestPtr != NULL) { /* - * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * Note: Used internal reps in the comparison! */ - char *versionToProvide = bestPtr->version; - PkgFiles *pkgFiles; - PkgName *pkgName; - script = bestPtr->script; - - pkgPtr->clientData = versionToProvide; - Tcl_Preserve(versionToProvide); - Tcl_Preserve(script); - pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = ckalloc(sizeof(PkgName) + strlen(name)); - 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; - ckfree(pkgName); - Tcl_Release(script); - - pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); - } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } - } - } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; - } - - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); - - if (code != TCL_OK) { + if (res > 0) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This stable version of the package sought is better + * than the currently selected stable version. */ - - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; - } - pkgPtr->clientData = NULL; - return code; + ckfree(bestStableVersion); + bestStableVersion = NULL; + goto newstable; } - - break; - } - - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it (but only on the first pass; after that, we - * should not get here in the first place). - */ - - if (pass > 1) { - break; + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ + bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); + ckfree(availVersion); + availVersion = NULL; + } /* end for */ - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); + /* + * Clean up memorized internal reps, if any. + */ - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return code; - } - Tcl_ResetResult(interp); - } + if (bestVersion != NULL) { + ckfree(bestVersion); + bestVersion = NULL; } - if (pkgPtr->version == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* - * At this point we know that the package is present. Make sure that the - * provided version meets the current requirements. + * Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. */ - if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; + } - ckfree(pkgVersionI); + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; + script = bestPtr->script; + + pkgPtr->clientData = versionToProvide; + Tcl_Preserve(versionToProvide); + Tcl_Preserve(script); + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + 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; + ckfree(pkgName); + Tcl_Release(script); + + pkgPtr = FindPackage(interp, name); + if (code == TCL_OK) { + Tcl_ResetResult(interp); + if (pkgPtr->version == NULL) { + code = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { + code = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + code = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + code = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } + } + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); - if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + code = TCL_ERROR; } - } - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; + if (code == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); - *ptr = pkgPtr->clientData; + if (code != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; + return code; + } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); return TCL_OK; } -- cgit v0.12 From 77821adfe89e6c3507ef12250dec40cf04ff8a0e Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 31 Jan 2018 00:07:22 +0000 Subject: Fix segmentation fault triggered by test package-3.12. Adapt signature of PkgRequireCore to conform to Tcl_ObjCmdProc, and call it in Tcl_PkgRequireProc on an NRE trampoline via Tcl_NRCallObjProc. Additional callbacks still needed to fully NRE-enable [package require]. --- generic/tclInt.h | 1 + generic/tclPkg.c | 83 ++++++++++++++++++++++++++++++++------------------------ 2 files changed, 49 insertions(+), 35 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index a3bd8ba..20d340e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2782,6 +2782,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 02f66f0..ce00fbf 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -65,6 +65,12 @@ typedef struct Package { const void *clientData; /* Client data. */ } Package; +typedef struct Require { + void * clientDataPtr; + const char *name; + Package *pkgPtr; +} Require; + /* * Prototypes for functions defined in this file: */ @@ -85,11 +91,10 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(Tcl_Interp *interp, const char *name, - int reqc, Tcl_Obj *const reqv[], - void *clientDataPtr); -static int SelectPackage (Tcl_Interp *interp, const char *name, - Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]); +static int PkgRequireCore(ClientData clientData, Tcl_Interp *interp, + int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage (Tcl_Interp *interp, Require *reqPtr, + int reqc, Tcl_Obj *const reqv[]); /* * Helper macros. @@ -402,35 +407,41 @@ Tcl_PkgRequireProc( void *clientDataPtr) { int code = CheckAllRequirements(interp, reqc, reqv); + Require require; if (code != TCL_OK) { return code; } - return PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + require.clientDataPtr = clientDataPtr; + require.name = name; + require.pkgPtr = NULL; + return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv); } int PkgRequireCore( + ClientData clientData, Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - const char *name, /* Name of desired package. */ int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *const reqv[], /* 0 means to use the latest version + Tcl_Obj *const reqv[] /* 0 means to use the latest version * available. */ - void *clientDataPtr) + ) { - Package *pkgPtr; int code, satisfies; - char *script, *pkgVersionI; Tcl_DString command; + Require *reqPtr = clientData; + char *script, *pkgVersionI; + const char *name = reqPtr->name /* Name of desired package. */; + void *clientDataPtr = reqPtr->clientDataPtr; - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version == NULL) { - code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + code = SelectPackage(interp, reqPtr, reqc, reqv); if (code != TCL_OK) { return code; } - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { /* * The package is not in the database. If there is a "package unknown" * command, invoke it. @@ -459,17 +470,17 @@ PkgRequireCore( return code; } Tcl_ResetResult(interp); - } - /* pkgPtr may now be invalid, so refresh it. */ - pkgPtr = FindPackage(interp, name); - code = SelectPackage(interp, name, pkgPtr, reqc, reqv); - if (code != TCL_OK) { - return code; + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + code = SelectPackage(interp, reqPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } } } } - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); @@ -482,7 +493,7 @@ PkgRequireCore( */ if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); @@ -490,7 +501,7 @@ PkgRequireCore( if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); + name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -501,18 +512,20 @@ PkgRequireCore( if (clientDataPtr) { const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + *ptr = reqPtr->pkgPtr->clientData; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } -int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) { +int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ char *script; int availStable, code, satisfies; + const char *name = reqPtr->name; + Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; /* @@ -678,10 +691,10 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re ckfree(pkgName); Tcl_Release(script); - pkgPtr = FindPackage(interp, name); + reqPtr->pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { code = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" @@ -692,7 +705,7 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re } else { char *pvi, *vi; - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, NULL) != TCL_OK) { code = TCL_ERROR; } else if (CheckVersionAndConvert(interp, @@ -710,7 +723,7 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, - name, pkgPtr->version)); + name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -747,11 +760,11 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re * either. */ - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } - pkgPtr->clientData = NULL; + reqPtr->pkgPtr->clientData = NULL; return code; } } -- cgit v0.12 From adf9cf554379da013088a310e2d9d4d8c8adec87 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 2 Feb 2018 06:07:26 +0000 Subject: Fixed def for INCLUDE_INSTALL_DIR when building against Tcl source. Bumped to 1.2. --- win/rules.vc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 543e959..8db4752 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 1 +RULES_VERSION_MINOR = 2 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -393,7 +393,7 @@ MSG = ^ !endif -# If INSTALLDIR set to tcl installation root dir then reset to the +# If INSTALLDIR set to Tcl installation root dir then reset to the # lib dir for installing extensions !if exist("$(_INSTALLDIR)\include\tcl.h") _INSTALLDIR=$(_INSTALLDIR)\lib @@ -1209,7 +1209,7 @@ RESFILE = $(TMP_DIR)\$(PROJECT).res # SCRIPT_INSTALL_DIR - where scripts should be installed # INCLUDE_INSTALL_DIR - where C include files should be installed # DEMO_INSTALL_DIR - where demos should be installed -# PRJ_INSTALL_DIR - where package will be installed (not set for tcl and tk) +# PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk) !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib @@ -1231,7 +1231,7 @@ BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos -INCLUDE_INSTALL_DIR = $(_TCLDIR)\include +INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include !endif -- cgit v0.12 From b618278c9fbbc7d48c2005ea9e71afd05425aa32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jos=C3=A9=20Ignacio=20Mar=C3=ADn?= Date: Fri, 2 Feb 2018 09:19:41 +0000 Subject: Update TZ info to tzdata2018c. --- library/tzdata/Africa/Sao_Tome | 9 +- library/tzdata/America/Campo_Grande | 164 ++++++++++++++++++------------------ library/tzdata/America/Cuiaba | 164 ++++++++++++++++++------------------ library/tzdata/America/La_Paz | 2 +- library/tzdata/America/Sao_Paulo | 164 ++++++++++++++++++------------------ library/tzdata/Asia/Tokyo | 16 ++-- 6 files changed, 261 insertions(+), 258 deletions(-) diff --git a/library/tzdata/Africa/Sao_Tome b/library/tzdata/Africa/Sao_Tome index 078591d..fe08d89 100644 --- a/library/tzdata/Africa/Sao_Tome +++ b/library/tzdata/Africa/Sao_Tome @@ -1,5 +1,8 @@ # created by tools/tclZIC.tcl - do not edit -if {![info exists TZData(Africa/Abidjan)]} { - LoadTimeZoneFile Africa/Abidjan + +set TZData(:Africa/Sao_Tome) { + {-9223372036854775808 1616 0 LMT} + {-2713912016 -2205 0 LMT} + {-1830381795 0 0 GMT} + {1514768400 3600 0 WAT} } -set TZData(:Africa/Sao_Tome) $TZData(:Africa/Abidjan) diff --git a/library/tzdata/America/Campo_Grande b/library/tzdata/America/Campo_Grande index 77cb4d1..f8bfb67 100644 --- a/library/tzdata/America/Campo_Grande +++ b/library/tzdata/America/Campo_Grande @@ -91,167 +91,167 @@ set TZData(:America/Campo_Grande) { {1487473200 -14400 0 -04} {1508040000 -10800 1 -03} {1518922800 -14400 0 -04} - {1540094400 -10800 1 -03} + {1541304000 -10800 1 -03} {1550372400 -14400 0 -04} - {1571544000 -10800 1 -03} + {1572753600 -10800 1 -03} {1581822000 -14400 0 -04} - {1602993600 -10800 1 -03} + {1604203200 -10800 1 -03} {1613876400 -14400 0 -04} - {1634443200 -10800 1 -03} + {1636257600 -10800 1 -03} {1645326000 -14400 0 -04} - {1665892800 -10800 1 -03} + {1667707200 -10800 1 -03} {1677380400 -14400 0 -04} - {1697342400 -10800 1 -03} + {1699156800 -10800 1 -03} {1708225200 -14400 0 -04} - {1729396800 -10800 1 -03} + {1730606400 -10800 1 -03} {1739674800 -14400 0 -04} - {1760846400 -10800 1 -03} + {1762056000 -10800 1 -03} {1771729200 -14400 0 -04} - {1792296000 -10800 1 -03} + {1793505600 -10800 1 -03} {1803178800 -14400 0 -04} - {1823745600 -10800 1 -03} + {1825560000 -10800 1 -03} {1834628400 -14400 0 -04} - {1855195200 -10800 1 -03} + {1857009600 -10800 1 -03} {1866078000 -14400 0 -04} - {1887249600 -10800 1 -03} + {1888459200 -10800 1 -03} {1897527600 -14400 0 -04} - {1918699200 -10800 1 -03} + {1919908800 -10800 1 -03} {1928977200 -14400 0 -04} - {1950148800 -10800 1 -03} + {1951358400 -10800 1 -03} {1960426800 -14400 0 -04} - {1981598400 -10800 1 -03} + {1983412800 -10800 1 -03} {1992481200 -14400 0 -04} - {2013048000 -10800 1 -03} + {2014862400 -10800 1 -03} {2024535600 -14400 0 -04} - {2044497600 -10800 1 -03} + {2046312000 -10800 1 -03} {2055380400 -14400 0 -04} - {2076552000 -10800 1 -03} + {2077761600 -10800 1 -03} {2086830000 -14400 0 -04} - {2108001600 -10800 1 -03} + {2109211200 -10800 1 -03} {2118884400 -14400 0 -04} - {2139451200 -10800 1 -03} + {2140660800 -10800 1 -03} {2150334000 -14400 0 -04} - {2170900800 -10800 1 -03} + {2172715200 -10800 1 -03} {2181783600 -14400 0 -04} - {2202350400 -10800 1 -03} + {2204164800 -10800 1 -03} {2213233200 -14400 0 -04} - {2234404800 -10800 1 -03} + {2235614400 -10800 1 -03} {2244682800 -14400 0 -04} - {2265854400 -10800 1 -03} + {2267064000 -10800 1 -03} {2276132400 -14400 0 -04} - {2297304000 -10800 1 -03} + {2298513600 -10800 1 -03} {2307582000 -14400 0 -04} - {2328753600 -10800 1 -03} + {2329963200 -10800 1 -03} {2339636400 -14400 0 -04} - {2360203200 -10800 1 -03} + {2362017600 -10800 1 -03} {2371086000 -14400 0 -04} - {2391652800 -10800 1 -03} + {2393467200 -10800 1 -03} {2402535600 -14400 0 -04} - {2423707200 -10800 1 -03} + {2424916800 -10800 1 -03} {2433985200 -14400 0 -04} - {2455156800 -10800 1 -03} + {2456366400 -10800 1 -03} {2465434800 -14400 0 -04} - {2486606400 -10800 1 -03} + {2487816000 -10800 1 -03} {2497489200 -14400 0 -04} - {2518056000 -10800 1 -03} + {2519870400 -10800 1 -03} {2528938800 -14400 0 -04} - {2549505600 -10800 1 -03} + {2551320000 -10800 1 -03} {2560388400 -14400 0 -04} - {2580955200 -10800 1 -03} + {2582769600 -10800 1 -03} {2591838000 -14400 0 -04} - {2613009600 -10800 1 -03} + {2614219200 -10800 1 -03} {2623287600 -14400 0 -04} - {2644459200 -10800 1 -03} + {2645668800 -10800 1 -03} {2654737200 -14400 0 -04} - {2675908800 -10800 1 -03} + {2677118400 -10800 1 -03} {2686791600 -14400 0 -04} - {2707358400 -10800 1 -03} + {2709172800 -10800 1 -03} {2718241200 -14400 0 -04} - {2738808000 -10800 1 -03} + {2740622400 -10800 1 -03} {2749690800 -14400 0 -04} - {2770862400 -10800 1 -03} + {2772072000 -10800 1 -03} {2781140400 -14400 0 -04} - {2802312000 -10800 1 -03} + {2803521600 -10800 1 -03} {2812590000 -14400 0 -04} - {2833761600 -10800 1 -03} + {2834971200 -10800 1 -03} {2844039600 -14400 0 -04} - {2865211200 -10800 1 -03} + {2867025600 -10800 1 -03} {2876094000 -14400 0 -04} - {2896660800 -10800 1 -03} + {2898475200 -10800 1 -03} {2907543600 -14400 0 -04} - {2928110400 -10800 1 -03} + {2929924800 -10800 1 -03} {2938993200 -14400 0 -04} - {2960164800 -10800 1 -03} + {2961374400 -10800 1 -03} {2970442800 -14400 0 -04} - {2991614400 -10800 1 -03} + {2992824000 -10800 1 -03} {3001892400 -14400 0 -04} - {3023064000 -10800 1 -03} + {3024273600 -10800 1 -03} {3033946800 -14400 0 -04} - {3054513600 -10800 1 -03} + {3056328000 -10800 1 -03} {3065396400 -14400 0 -04} - {3085963200 -10800 1 -03} + {3087777600 -10800 1 -03} {3096846000 -14400 0 -04} - {3118017600 -10800 1 -03} + {3119227200 -10800 1 -03} {3128295600 -14400 0 -04} - {3149467200 -10800 1 -03} + {3150676800 -10800 1 -03} {3159745200 -14400 0 -04} - {3180916800 -10800 1 -03} + {3182126400 -10800 1 -03} {3191194800 -14400 0 -04} - {3212366400 -10800 1 -03} + {3213576000 -10800 1 -03} {3223249200 -14400 0 -04} - {3243816000 -10800 1 -03} + {3245630400 -10800 1 -03} {3254698800 -14400 0 -04} - {3275265600 -10800 1 -03} + {3277080000 -10800 1 -03} {3286148400 -14400 0 -04} - {3307320000 -10800 1 -03} + {3308529600 -10800 1 -03} {3317598000 -14400 0 -04} - {3338769600 -10800 1 -03} + {3339979200 -10800 1 -03} {3349047600 -14400 0 -04} - {3370219200 -10800 1 -03} + {3371428800 -10800 1 -03} {3381102000 -14400 0 -04} - {3401668800 -10800 1 -03} + {3403483200 -10800 1 -03} {3412551600 -14400 0 -04} - {3433118400 -10800 1 -03} + {3434932800 -10800 1 -03} {3444001200 -14400 0 -04} - {3464568000 -10800 1 -03} + {3466382400 -10800 1 -03} {3475450800 -14400 0 -04} - {3496622400 -10800 1 -03} + {3497832000 -10800 1 -03} {3506900400 -14400 0 -04} - {3528072000 -10800 1 -03} + {3529281600 -10800 1 -03} {3538350000 -14400 0 -04} - {3559521600 -10800 1 -03} + {3560731200 -10800 1 -03} {3570404400 -14400 0 -04} - {3590971200 -10800 1 -03} + {3592785600 -10800 1 -03} {3601854000 -14400 0 -04} - {3622420800 -10800 1 -03} + {3624235200 -10800 1 -03} {3633303600 -14400 0 -04} - {3654475200 -10800 1 -03} + {3655684800 -10800 1 -03} {3664753200 -14400 0 -04} - {3685924800 -10800 1 -03} + {3687134400 -10800 1 -03} {3696202800 -14400 0 -04} - {3717374400 -10800 1 -03} + {3718584000 -10800 1 -03} {3727652400 -14400 0 -04} - {3748824000 -10800 1 -03} + {3750638400 -10800 1 -03} {3759706800 -14400 0 -04} - {3780273600 -10800 1 -03} + {3782088000 -10800 1 -03} {3791156400 -14400 0 -04} - {3811723200 -10800 1 -03} + {3813537600 -10800 1 -03} {3822606000 -14400 0 -04} - {3843777600 -10800 1 -03} + {3844987200 -10800 1 -03} {3854055600 -14400 0 -04} - {3875227200 -10800 1 -03} + {3876436800 -10800 1 -03} {3885505200 -14400 0 -04} - {3906676800 -10800 1 -03} + {3907886400 -10800 1 -03} {3917559600 -14400 0 -04} - {3938126400 -10800 1 -03} + {3939940800 -10800 1 -03} {3949009200 -14400 0 -04} - {3969576000 -10800 1 -03} + {3971390400 -10800 1 -03} {3980458800 -14400 0 -04} - {4001630400 -10800 1 -03} + {4002840000 -10800 1 -03} {4011908400 -14400 0 -04} - {4033080000 -10800 1 -03} + {4034289600 -10800 1 -03} {4043358000 -14400 0 -04} - {4064529600 -10800 1 -03} + {4065739200 -10800 1 -03} {4074807600 -14400 0 -04} - {4095979200 -10800 1 -03} + {4097188800 -10800 1 -03} } diff --git a/library/tzdata/America/Cuiaba b/library/tzdata/America/Cuiaba index 57cd38c..69acddb 100644 --- a/library/tzdata/America/Cuiaba +++ b/library/tzdata/America/Cuiaba @@ -91,167 +91,167 @@ set TZData(:America/Cuiaba) { {1487473200 -14400 0 -04} {1508040000 -10800 1 -03} {1518922800 -14400 0 -04} - {1540094400 -10800 1 -03} + {1541304000 -10800 1 -03} {1550372400 -14400 0 -04} - {1571544000 -10800 1 -03} + {1572753600 -10800 1 -03} {1581822000 -14400 0 -04} - {1602993600 -10800 1 -03} + {1604203200 -10800 1 -03} {1613876400 -14400 0 -04} - {1634443200 -10800 1 -03} + {1636257600 -10800 1 -03} {1645326000 -14400 0 -04} - {1665892800 -10800 1 -03} + {1667707200 -10800 1 -03} {1677380400 -14400 0 -04} - {1697342400 -10800 1 -03} + {1699156800 -10800 1 -03} {1708225200 -14400 0 -04} - {1729396800 -10800 1 -03} + {1730606400 -10800 1 -03} {1739674800 -14400 0 -04} - {1760846400 -10800 1 -03} + {1762056000 -10800 1 -03} {1771729200 -14400 0 -04} - {1792296000 -10800 1 -03} + {1793505600 -10800 1 -03} {1803178800 -14400 0 -04} - {1823745600 -10800 1 -03} + {1825560000 -10800 1 -03} {1834628400 -14400 0 -04} - {1855195200 -10800 1 -03} + {1857009600 -10800 1 -03} {1866078000 -14400 0 -04} - {1887249600 -10800 1 -03} + {1888459200 -10800 1 -03} {1897527600 -14400 0 -04} - {1918699200 -10800 1 -03} + {1919908800 -10800 1 -03} {1928977200 -14400 0 -04} - {1950148800 -10800 1 -03} + {1951358400 -10800 1 -03} {1960426800 -14400 0 -04} - {1981598400 -10800 1 -03} + {1983412800 -10800 1 -03} {1992481200 -14400 0 -04} - {2013048000 -10800 1 -03} + {2014862400 -10800 1 -03} {2024535600 -14400 0 -04} - {2044497600 -10800 1 -03} + {2046312000 -10800 1 -03} {2055380400 -14400 0 -04} - {2076552000 -10800 1 -03} + {2077761600 -10800 1 -03} {2086830000 -14400 0 -04} - {2108001600 -10800 1 -03} + {2109211200 -10800 1 -03} {2118884400 -14400 0 -04} - {2139451200 -10800 1 -03} + {2140660800 -10800 1 -03} {2150334000 -14400 0 -04} - {2170900800 -10800 1 -03} + {2172715200 -10800 1 -03} {2181783600 -14400 0 -04} - {2202350400 -10800 1 -03} + {2204164800 -10800 1 -03} {2213233200 -14400 0 -04} - {2234404800 -10800 1 -03} + {2235614400 -10800 1 -03} {2244682800 -14400 0 -04} - {2265854400 -10800 1 -03} + {2267064000 -10800 1 -03} {2276132400 -14400 0 -04} - {2297304000 -10800 1 -03} + {2298513600 -10800 1 -03} {2307582000 -14400 0 -04} - {2328753600 -10800 1 -03} + {2329963200 -10800 1 -03} {2339636400 -14400 0 -04} - {2360203200 -10800 1 -03} + {2362017600 -10800 1 -03} {2371086000 -14400 0 -04} - {2391652800 -10800 1 -03} + {2393467200 -10800 1 -03} {2402535600 -14400 0 -04} - {2423707200 -10800 1 -03} + {2424916800 -10800 1 -03} {2433985200 -14400 0 -04} - {2455156800 -10800 1 -03} + {2456366400 -10800 1 -03} {2465434800 -14400 0 -04} - {2486606400 -10800 1 -03} + {2487816000 -10800 1 -03} {2497489200 -14400 0 -04} - {2518056000 -10800 1 -03} + {2519870400 -10800 1 -03} {2528938800 -14400 0 -04} - {2549505600 -10800 1 -03} + {2551320000 -10800 1 -03} {2560388400 -14400 0 -04} - {2580955200 -10800 1 -03} + {2582769600 -10800 1 -03} {2591838000 -14400 0 -04} - {2613009600 -10800 1 -03} + {2614219200 -10800 1 -03} {2623287600 -14400 0 -04} - {2644459200 -10800 1 -03} + {2645668800 -10800 1 -03} {2654737200 -14400 0 -04} - {2675908800 -10800 1 -03} + {2677118400 -10800 1 -03} {2686791600 -14400 0 -04} - {2707358400 -10800 1 -03} + {2709172800 -10800 1 -03} {2718241200 -14400 0 -04} - {2738808000 -10800 1 -03} + {2740622400 -10800 1 -03} {2749690800 -14400 0 -04} - {2770862400 -10800 1 -03} + {2772072000 -10800 1 -03} {2781140400 -14400 0 -04} - {2802312000 -10800 1 -03} + {2803521600 -10800 1 -03} {2812590000 -14400 0 -04} - {2833761600 -10800 1 -03} + {2834971200 -10800 1 -03} {2844039600 -14400 0 -04} - {2865211200 -10800 1 -03} + {2867025600 -10800 1 -03} {2876094000 -14400 0 -04} - {2896660800 -10800 1 -03} + {2898475200 -10800 1 -03} {2907543600 -14400 0 -04} - {2928110400 -10800 1 -03} + {2929924800 -10800 1 -03} {2938993200 -14400 0 -04} - {2960164800 -10800 1 -03} + {2961374400 -10800 1 -03} {2970442800 -14400 0 -04} - {2991614400 -10800 1 -03} + {2992824000 -10800 1 -03} {3001892400 -14400 0 -04} - {3023064000 -10800 1 -03} + {3024273600 -10800 1 -03} {3033946800 -14400 0 -04} - {3054513600 -10800 1 -03} + {3056328000 -10800 1 -03} {3065396400 -14400 0 -04} - {3085963200 -10800 1 -03} + {3087777600 -10800 1 -03} {3096846000 -14400 0 -04} - {3118017600 -10800 1 -03} + {3119227200 -10800 1 -03} {3128295600 -14400 0 -04} - {3149467200 -10800 1 -03} + {3150676800 -10800 1 -03} {3159745200 -14400 0 -04} - {3180916800 -10800 1 -03} + {3182126400 -10800 1 -03} {3191194800 -14400 0 -04} - {3212366400 -10800 1 -03} + {3213576000 -10800 1 -03} {3223249200 -14400 0 -04} - {3243816000 -10800 1 -03} + {3245630400 -10800 1 -03} {3254698800 -14400 0 -04} - {3275265600 -10800 1 -03} + {3277080000 -10800 1 -03} {3286148400 -14400 0 -04} - {3307320000 -10800 1 -03} + {3308529600 -10800 1 -03} {3317598000 -14400 0 -04} - {3338769600 -10800 1 -03} + {3339979200 -10800 1 -03} {3349047600 -14400 0 -04} - {3370219200 -10800 1 -03} + {3371428800 -10800 1 -03} {3381102000 -14400 0 -04} - {3401668800 -10800 1 -03} + {3403483200 -10800 1 -03} {3412551600 -14400 0 -04} - {3433118400 -10800 1 -03} + {3434932800 -10800 1 -03} {3444001200 -14400 0 -04} - {3464568000 -10800 1 -03} + {3466382400 -10800 1 -03} {3475450800 -14400 0 -04} - {3496622400 -10800 1 -03} + {3497832000 -10800 1 -03} {3506900400 -14400 0 -04} - {3528072000 -10800 1 -03} + {3529281600 -10800 1 -03} {3538350000 -14400 0 -04} - {3559521600 -10800 1 -03} + {3560731200 -10800 1 -03} {3570404400 -14400 0 -04} - {3590971200 -10800 1 -03} + {3592785600 -10800 1 -03} {3601854000 -14400 0 -04} - {3622420800 -10800 1 -03} + {3624235200 -10800 1 -03} {3633303600 -14400 0 -04} - {3654475200 -10800 1 -03} + {3655684800 -10800 1 -03} {3664753200 -14400 0 -04} - {3685924800 -10800 1 -03} + {3687134400 -10800 1 -03} {3696202800 -14400 0 -04} - {3717374400 -10800 1 -03} + {3718584000 -10800 1 -03} {3727652400 -14400 0 -04} - {3748824000 -10800 1 -03} + {3750638400 -10800 1 -03} {3759706800 -14400 0 -04} - {3780273600 -10800 1 -03} + {3782088000 -10800 1 -03} {3791156400 -14400 0 -04} - {3811723200 -10800 1 -03} + {3813537600 -10800 1 -03} {3822606000 -14400 0 -04} - {3843777600 -10800 1 -03} + {3844987200 -10800 1 -03} {3854055600 -14400 0 -04} - {3875227200 -10800 1 -03} + {3876436800 -10800 1 -03} {3885505200 -14400 0 -04} - {3906676800 -10800 1 -03} + {3907886400 -10800 1 -03} {3917559600 -14400 0 -04} - {3938126400 -10800 1 -03} + {3939940800 -10800 1 -03} {3949009200 -14400 0 -04} - {3969576000 -10800 1 -03} + {3971390400 -10800 1 -03} {3980458800 -14400 0 -04} - {4001630400 -10800 1 -03} + {4002840000 -10800 1 -03} {4011908400 -14400 0 -04} - {4033080000 -10800 1 -03} + {4034289600 -10800 1 -03} {4043358000 -14400 0 -04} - {4064529600 -10800 1 -03} + {4065739200 -10800 1 -03} {4074807600 -14400 0 -04} - {4095979200 -10800 1 -03} + {4097188800 -10800 1 -03} } diff --git a/library/tzdata/America/La_Paz b/library/tzdata/America/La_Paz index a245afd..ea2f711 100644 --- a/library/tzdata/America/La_Paz +++ b/library/tzdata/America/La_Paz @@ -3,6 +3,6 @@ set TZData(:America/La_Paz) { {-9223372036854775808 -16356 0 LMT} {-2524505244 -16356 0 CMT} - {-1205954844 -12756 1 BOST} + {-1205954844 -12756 1 BST} {-1192307244 -14400 0 -04} } diff --git a/library/tzdata/America/Sao_Paulo b/library/tzdata/America/Sao_Paulo index a61c638..93c524d 100644 --- a/library/tzdata/America/Sao_Paulo +++ b/library/tzdata/America/Sao_Paulo @@ -92,167 +92,167 @@ set TZData(:America/Sao_Paulo) { {1487469600 -10800 0 -03} {1508036400 -7200 1 -02} {1518919200 -10800 0 -03} - {1540090800 -7200 1 -02} + {1541300400 -7200 1 -02} {1550368800 -10800 0 -03} - {1571540400 -7200 1 -02} + {1572750000 -7200 1 -02} {1581818400 -10800 0 -03} - {1602990000 -7200 1 -02} + {1604199600 -7200 1 -02} {1613872800 -10800 0 -03} - {1634439600 -7200 1 -02} + {1636254000 -7200 1 -02} {1645322400 -10800 0 -03} - {1665889200 -7200 1 -02} + {1667703600 -7200 1 -02} {1677376800 -10800 0 -03} - {1697338800 -7200 1 -02} + {1699153200 -7200 1 -02} {1708221600 -10800 0 -03} - {1729393200 -7200 1 -02} + {1730602800 -7200 1 -02} {1739671200 -10800 0 -03} - {1760842800 -7200 1 -02} + {1762052400 -7200 1 -02} {1771725600 -10800 0 -03} - {1792292400 -7200 1 -02} + {1793502000 -7200 1 -02} {1803175200 -10800 0 -03} - {1823742000 -7200 1 -02} + {1825556400 -7200 1 -02} {1834624800 -10800 0 -03} - {1855191600 -7200 1 -02} + {1857006000 -7200 1 -02} {1866074400 -10800 0 -03} - {1887246000 -7200 1 -02} + {1888455600 -7200 1 -02} {1897524000 -10800 0 -03} - {1918695600 -7200 1 -02} + {1919905200 -7200 1 -02} {1928973600 -10800 0 -03} - {1950145200 -7200 1 -02} + {1951354800 -7200 1 -02} {1960423200 -10800 0 -03} - {1981594800 -7200 1 -02} + {1983409200 -7200 1 -02} {1992477600 -10800 0 -03} - {2013044400 -7200 1 -02} + {2014858800 -7200 1 -02} {2024532000 -10800 0 -03} - {2044494000 -7200 1 -02} + {2046308400 -7200 1 -02} {2055376800 -10800 0 -03} - {2076548400 -7200 1 -02} + {2077758000 -7200 1 -02} {2086826400 -10800 0 -03} - {2107998000 -7200 1 -02} + {2109207600 -7200 1 -02} {2118880800 -10800 0 -03} - {2139447600 -7200 1 -02} + {2140657200 -7200 1 -02} {2150330400 -10800 0 -03} - {2170897200 -7200 1 -02} + {2172711600 -7200 1 -02} {2181780000 -10800 0 -03} - {2202346800 -7200 1 -02} + {2204161200 -7200 1 -02} {2213229600 -10800 0 -03} - {2234401200 -7200 1 -02} + {2235610800 -7200 1 -02} {2244679200 -10800 0 -03} - {2265850800 -7200 1 -02} + {2267060400 -7200 1 -02} {2276128800 -10800 0 -03} - {2297300400 -7200 1 -02} + {2298510000 -7200 1 -02} {2307578400 -10800 0 -03} - {2328750000 -7200 1 -02} + {2329959600 -7200 1 -02} {2339632800 -10800 0 -03} - {2360199600 -7200 1 -02} + {2362014000 -7200 1 -02} {2371082400 -10800 0 -03} - {2391649200 -7200 1 -02} + {2393463600 -7200 1 -02} {2402532000 -10800 0 -03} - {2423703600 -7200 1 -02} + {2424913200 -7200 1 -02} {2433981600 -10800 0 -03} - {2455153200 -7200 1 -02} + {2456362800 -7200 1 -02} {2465431200 -10800 0 -03} - {2486602800 -7200 1 -02} + {2487812400 -7200 1 -02} {2497485600 -10800 0 -03} - {2518052400 -7200 1 -02} + {2519866800 -7200 1 -02} {2528935200 -10800 0 -03} - {2549502000 -7200 1 -02} + {2551316400 -7200 1 -02} {2560384800 -10800 0 -03} - {2580951600 -7200 1 -02} + {2582766000 -7200 1 -02} {2591834400 -10800 0 -03} - {2613006000 -7200 1 -02} + {2614215600 -7200 1 -02} {2623284000 -10800 0 -03} - {2644455600 -7200 1 -02} + {2645665200 -7200 1 -02} {2654733600 -10800 0 -03} - {2675905200 -7200 1 -02} + {2677114800 -7200 1 -02} {2686788000 -10800 0 -03} - {2707354800 -7200 1 -02} + {2709169200 -7200 1 -02} {2718237600 -10800 0 -03} - {2738804400 -7200 1 -02} + {2740618800 -7200 1 -02} {2749687200 -10800 0 -03} - {2770858800 -7200 1 -02} + {2772068400 -7200 1 -02} {2781136800 -10800 0 -03} - {2802308400 -7200 1 -02} + {2803518000 -7200 1 -02} {2812586400 -10800 0 -03} - {2833758000 -7200 1 -02} + {2834967600 -7200 1 -02} {2844036000 -10800 0 -03} - {2865207600 -7200 1 -02} + {2867022000 -7200 1 -02} {2876090400 -10800 0 -03} - {2896657200 -7200 1 -02} + {2898471600 -7200 1 -02} {2907540000 -10800 0 -03} - {2928106800 -7200 1 -02} + {2929921200 -7200 1 -02} {2938989600 -10800 0 -03} - {2960161200 -7200 1 -02} + {2961370800 -7200 1 -02} {2970439200 -10800 0 -03} - {2991610800 -7200 1 -02} + {2992820400 -7200 1 -02} {3001888800 -10800 0 -03} - {3023060400 -7200 1 -02} + {3024270000 -7200 1 -02} {3033943200 -10800 0 -03} - {3054510000 -7200 1 -02} + {3056324400 -7200 1 -02} {3065392800 -10800 0 -03} - {3085959600 -7200 1 -02} + {3087774000 -7200 1 -02} {3096842400 -10800 0 -03} - {3118014000 -7200 1 -02} + {3119223600 -7200 1 -02} {3128292000 -10800 0 -03} - {3149463600 -7200 1 -02} + {3150673200 -7200 1 -02} {3159741600 -10800 0 -03} - {3180913200 -7200 1 -02} + {3182122800 -7200 1 -02} {3191191200 -10800 0 -03} - {3212362800 -7200 1 -02} + {3213572400 -7200 1 -02} {3223245600 -10800 0 -03} - {3243812400 -7200 1 -02} + {3245626800 -7200 1 -02} {3254695200 -10800 0 -03} - {3275262000 -7200 1 -02} + {3277076400 -7200 1 -02} {3286144800 -10800 0 -03} - {3307316400 -7200 1 -02} + {3308526000 -7200 1 -02} {3317594400 -10800 0 -03} - {3338766000 -7200 1 -02} + {3339975600 -7200 1 -02} {3349044000 -10800 0 -03} - {3370215600 -7200 1 -02} + {3371425200 -7200 1 -02} {3381098400 -10800 0 -03} - {3401665200 -7200 1 -02} + {3403479600 -7200 1 -02} {3412548000 -10800 0 -03} - {3433114800 -7200 1 -02} + {3434929200 -7200 1 -02} {3443997600 -10800 0 -03} - {3464564400 -7200 1 -02} + {3466378800 -7200 1 -02} {3475447200 -10800 0 -03} - {3496618800 -7200 1 -02} + {3497828400 -7200 1 -02} {3506896800 -10800 0 -03} - {3528068400 -7200 1 -02} + {3529278000 -7200 1 -02} {3538346400 -10800 0 -03} - {3559518000 -7200 1 -02} + {3560727600 -7200 1 -02} {3570400800 -10800 0 -03} - {3590967600 -7200 1 -02} + {3592782000 -7200 1 -02} {3601850400 -10800 0 -03} - {3622417200 -7200 1 -02} + {3624231600 -7200 1 -02} {3633300000 -10800 0 -03} - {3654471600 -7200 1 -02} + {3655681200 -7200 1 -02} {3664749600 -10800 0 -03} - {3685921200 -7200 1 -02} + {3687130800 -7200 1 -02} {3696199200 -10800 0 -03} - {3717370800 -7200 1 -02} + {3718580400 -7200 1 -02} {3727648800 -10800 0 -03} - {3748820400 -7200 1 -02} + {3750634800 -7200 1 -02} {3759703200 -10800 0 -03} - {3780270000 -7200 1 -02} + {3782084400 -7200 1 -02} {3791152800 -10800 0 -03} - {3811719600 -7200 1 -02} + {3813534000 -7200 1 -02} {3822602400 -10800 0 -03} - {3843774000 -7200 1 -02} + {3844983600 -7200 1 -02} {3854052000 -10800 0 -03} - {3875223600 -7200 1 -02} + {3876433200 -7200 1 -02} {3885501600 -10800 0 -03} - {3906673200 -7200 1 -02} + {3907882800 -7200 1 -02} {3917556000 -10800 0 -03} - {3938122800 -7200 1 -02} + {3939937200 -7200 1 -02} {3949005600 -10800 0 -03} - {3969572400 -7200 1 -02} + {3971386800 -7200 1 -02} {3980455200 -10800 0 -03} - {4001626800 -7200 1 -02} + {4002836400 -7200 1 -02} {4011904800 -10800 0 -03} - {4033076400 -7200 1 -02} + {4034286000 -7200 1 -02} {4043354400 -10800 0 -03} - {4064526000 -7200 1 -02} + {4065735600 -7200 1 -02} {4074804000 -10800 0 -03} - {4095975600 -7200 1 -02} + {4097185200 -7200 1 -02} } diff --git a/library/tzdata/Asia/Tokyo b/library/tzdata/Asia/Tokyo index 10add1c..790df0a 100644 --- a/library/tzdata/Asia/Tokyo +++ b/library/tzdata/Asia/Tokyo @@ -3,12 +3,12 @@ set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} - {-683794800 36000 1 JDT} - {-672393600 32400 0 JST} - {-654764400 36000 1 JDT} - {-640944000 32400 0 JST} - {-620290800 36000 1 JDT} - {-609494400 32400 0 JST} - {-588841200 36000 1 JDT} - {-578044800 32400 0 JST} + {-683802000 36000 1 JDT} + {-672314400 32400 0 JST} + {-654771600 36000 1 JDT} + {-640864800 32400 0 JST} + {-620298000 36000 1 JDT} + {-609415200 32400 0 JST} + {-588848400 36000 1 JDT} + {-577965600 32400 0 JST} } -- cgit v0.12 From 98887219c2dcf8b1fd6debaf3c716f6a809d2a84 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 3 Feb 2018 18:15:06 +0000 Subject: Refine documentation for Tcl_NR* functions. --- doc/Eval.3 | 8 +- doc/NRE.3 | 260 ++++++++++++++++++++----------------------------------------- 2 files changed, 88 insertions(+), 180 deletions(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 191bace..e241794 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -176,10 +176,10 @@ it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . -If this flag is set, the script is processed at global level. This -means that it is evaluated in the global namespace and its variable -context consists of global variables only (it ignores any Tcl -procedures that are active). +If this flag is set, the script is evaluated in the global namespace instead of +the current namespace and its variable context consists of global variables +only (it ignores any Tcl procedures that are active). +.\" TODO: document TCL_EVAL_INVOKE and TCL_EVAL_NOERR. .SH "MISCELLANEOUS DETAILS" .PP diff --git a/doc/NRE.3 b/doc/NRE.3 index ff0d108..6078a53 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -1,5 +1,6 @@ .\" .\" Copyright (c) 2008 by Kevin B. Kenny. +.\" Copyright (c) 2018 by Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -38,43 +39,39 @@ void .SH ARGUMENTS .AS Tcl_CmdDeleteProc *interp in .AP Tcl_Interp *interp in -Interpreter in which to create or evaluate a command. +The relevant Interpreter. .AP char *cmdName in -Name of a new command to create. +Name of the command to create. .AP Tcl_ObjCmdProc *proc in -Implementation of a command that will be called whenever \fIcmdName\fR -is invoked as a command in the unoptimized way. +Called in order to evaluate a command. Is often just a small wrapper that uses +\fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves +in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) +(\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in -Implementation of a command that will be called whenever \fIcmdName\fR -is invoked and requested to conserve the C stack. +Called instead of \fIproc\fR when a trampoline is already in use. .AP ClientData clientData in -Arbitrary one-word value that will be passed to \fIproc\fR, \fInreProc\fR, -\fIdeleteProc\fR and \fIobjProc\fR. +Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR +and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out -Procedure to call before \fIcmdName\fR is deleted from the interpreter. -This procedure allows for command-specific cleanup. If \fIdeleteProc\fR -is \fBNULL\fR, then no procedure is called before the command is deleted. +Called before \fIcmdName\fR is deleted from the interpreter, allowing for +command-specific cleanup. May be NULL. .AP int objc in -Count of parameters provided to the implementation of a command. +Number of items in \fIobjv\fR. .AP Tcl_Obj **objv in -Pointer to an array of Tcl values. Each value holds the value of a -single word in the command to execute. +Words in the command. .AP Tcl_Obj *objPtr in -Pointer to a Tcl_Obj whose value is a script or expression to execute. +A script or expression to evaluate. .AP int flags in -ORed combination of flag bits that specify additional options. -\fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported. -.\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and -.\" TCL_EVAL_NOERR well enough to document them. +As described for \fITcl_EvalObjv\fR. +.PP .AP Tcl_Command cmd in -Token for a command that is to be used instead of the currently -executing command. +Token to use instead of one derived from the first word of \fIobjv\fR in order +to evaluate a command. .AP Tcl_Obj *resultPtr out -Pointer to an unshared Tcl_Obj where the result of expression -evaluation is written. +Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if +the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in -Pointer to a function that will be invoked when the command currently -executing in the interpreter designated by \fIinterp\fR completes. +A function to push. .AP ClientData data0 in .AP ClientData data1 in .AP ClientData data2 in @@ -84,98 +81,51 @@ to the function designated by \fIpostProcPtr\fR when it is invoked. .BE .SH DESCRIPTION .PP -This series of C functions provides an interface whereby commands that -are implemented in C can be evaluated, and invoke Tcl commands scripts -and scripts, without consuming space on the C stack. The non-recursive -evaluation is done by installing a \fItrampoline\fR, a small piece of -code that invokes a command or script, and then executes a series of -callbacks when the command or script returns. -.PP -The \fBTcl_NRCreateCommand\fR function creates a Tcl command in the -interpreter designated by \fIinterp\fR that is prepared to handle -nonrecursive evaluation with a trampoline. The \fIcmdName\fR argument -gives the name of the new command. If \fIcmdName\fR contains any -namespace qualifiers, then the new command is added to the specified -namespace; otherwise, it is added to the global namespace. \fIproc\fR -gives the procedure that will be called when the interpreter wishes to -evaluate the command in an unoptimized manner, and \fInreProc\fR is -the procedure that will be called when the interpreter wishes to -evaluate the command using a trampoline. \fIdeleteProc\fR is a -function that will be called before the command is deleted from the -interpreter. When any of the three functions is invoked, it is passed -the \fIclientData\fR parameter. -.PP -\fBTcl_NRCreateCommand\fR deletes any existing command -\fIname\fR already associated with the interpreter -(however see below for an exception where the existing command -is not deleted). -It returns a token that may be used to refer -to the command in subsequent calls to \fBTcl_GetCommandName\fR. -If \fBTcl_NRCreateCommand\fR is called for an interpreter that is in -the process of being deleted, then it does not create a new command, -does not delete any existing command of the same name, and returns NULL. -.PP -The \fIproc\fR and \fInreProc\fR function are expected to conform to -all the rules set forth for the \fIproc\fR argument to -\fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). -.PP -When a command that is written to cope with evaluation via trampoline -is invoked without a trampoline on the stack, it will usually respond -to the invocation by creating a trampoline and calling the -trampoline-enabled implementation of the same command. This call is done by -means of \fBTcl_NRCallObjProc\fR. In the call to -\fBTcl_NRCallObjProc\fR, the \fIinterp\fR, \fIclientData\fR, -\fIobjc\fR and \fIobjv\fR parameters should be the same ones that were -passed to \fIproc\fR. The \fInreProc\fR parameter should designate the -trampoline-enabled implementation of the command. -.PP -\fBTcl_NREvalObj\fR arranges for the script contained in \fIobjPtr\fR -to be evaluated in the interpreter designated by \fIinterp\fR after -the current command (which must be trampoline-enabled) returns. It is -the method by which a command may invoke a script without consuming -space on the C stack. Similarly, \fBTcl_NREvalObjv\fR arranges to -invoke a single Tcl command whose words have already been separated -and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the -words of the command to be evaluated when execution reaches the -trampoline. -.PP -\fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose -resolution is already known. The \fIcmd\fR parameter gives a -\fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or -\fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in -the trampoline; this command must match the word in \fIobjv[0]\fR. -The remaining arguments are as for \fBTcl_NREvalObjv\fR. -.PP -\fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR -all accept a \fIflags\fR parameter, which is an OR-ed-together set of -bits to control evaluation. At the present time, the only supported flag -available to callers is \fBTCL_EVAL_GLOBAL\fR. -.\" TODO: Again, this is a lie. Do we want to explain TCL_EVAL_INVOKE -.\" and TCL_EVAL_NOERR? -If the \fBTCL_EVAL_GLOBAL\fR flag is set, the script or command is -evaluated in the global namespace. If it is not set, it is evaluated -in the current namespace. -.PP -\fBTcl_NRExprObj\fR arranges for the expression contained in \fIobjPtr\fR -to be evaluated in the interpreter designated by \fIinterp\fR after -the current command (which must be trampoline-enabled) returns. It is -the method by which a command may evaluate a Tcl expression without consuming -space on the C stack. The argument \fIresultPtr\fR is a pointer to an -unshared Tcl_Obj where the result of expression evaluation is to be written. -If expression evaluation returns any code other than TCL_OK, the -\fIresultPtr\fR value is left untouched. -.PP -All of the routines return \fBTCL_OK\fR if command or expression invocation -has been scheduled successfully. If for any reason the scheduling cannot -be completed (for example, if the interpreter is unable to find -the requested command), they return \fBTCL_ERROR\fR with an -appropriate message left in the interpreter's result. -.PP -\fBTcl_NRAddCallback\fR arranges to have a C function called when the -current trampoline-enabled command in the Tcl interpreter designated -by \fIinterp\fR returns. The \fIpostProcPtr\fR argument is a pointer -to the callback function, which must have arguments and return value -consistent with the \fBTcl_NRPostProc\fR data type: +These functions provide an interface to the function stack that an interpreter +iterates through to evaluate commands. The routine behind a command is +implemented by an initial function and any additional functions that the +routine pushes onto the stack as it progresses. The interpreter itself pushes +functions onto the stack to react to the end of a routine and to exercise other +forms of control such as switching between in-progress stacks and the +evaluation of other scripts at additional levels without adding frames to the C +stack. To execute a routine, the initial function for the routine is called +and then a small bit of code called a \fItrampoline\fR iteratively takes +functions off the stack and calls them, using the value of the last call as the +value of the routine. +.PP +\fBTcl_NRCallObjProc\fR calls \fInreProc\fR using a new trampoline. +.PP +\fBTcl_NRCreateCommand\fR, an alternative to \fBTcl_CreateObjCommand\fR, +resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the +current namespace, creates a command by that name, and returns a token for the +command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. +Except for a few cases noted below any existing command by the same name is +first deleted. If \fIinterp\fR is in the process of being deleted +\fBTcl_NRCreateCommand\fR does not create any command, does not delete any +command, and returns NULL. +.PP +\fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but +consumes no space on the C stack. +.PP +\fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but +consumes no space on the C stack. +.PP +\fBTcl_NRCmdSwap\fR is like \fBTcl_NREvalObjv\fR, but uses \fIcmd\fR, a token +previously returned by \fBTcl_CreateObjCommand\fR or +\fBTcl_GetCommandFromObj\fR, instead of resolving the first word of \fIobjv\fR. +. The name of this command must be the same as \fIobjv[0]\fR. +.PP +\fBTcl_NRExprObj\fR pushes a function that evaluates \fIobjPtr\fR as an +expression in the same manner as \fBTcl_ExprObj\fR but without consuming space +on the C stack. +.PP +All of the functions return \fBTCL_OK\fR if the evaluation of the script, +command, or expression has been scheduled successfully. Otherwise (for example +if the command name cannot be resolved), they return \fBTCL_ERROR\fR and store +a message as the interpreter's result. +.PP +\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for +\fBTcl_NRPostProc\fR is: .PP .CS typedef int @@ -185,25 +135,13 @@ typedef int int \fIresult\fR); .CE .PP -When the trampoline invokes the callback function, the \fIdata\fR -parameter will point to an array containing the four one-word -quantities that were passed to \fBTcl_NRAddCallback\fR in the -\fIdata0\fR through \fIdata3\fR parameters. The Tcl interpreter will -be designated by the \fIinterp\fR parameter, and the \fIresult\fR -parameter will contain the result (\fBTCL_OK\fR, \fBTCL_ERROR\fR, -\fBTCL_RETURN\fR, \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR) that was -returned by the command evaluation. The callback function is expected, -in turn, either to return a \fIresult\fR to control further evaluation. -.PP -Multiple \fBTcl_NRAddCallback\fR invocations may request multiple -callbacks, which may be to the same or different callback -functions. If multiple callbacks are requested, they are executed in -last-in, first-out order, that is, the most recently requested -callback is executed first. +\fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR. +\fIresult\fR is the value returned by the previous function implementing part +the routine. .SH EXAMPLE .PP -The usual pattern for Tcl commands that invoke other Tcl commands -is something like: +The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C +stack, to evalute a script: .PP .CS int @@ -228,28 +166,17 @@ int \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP -To enable a command like this one for trampoline-based evaluation, -it must be split into three pieces: -.IP \(bu -A non-trampoline implementation, \fITheCmdNewObjProc\fR, -which will simply create a trampoline -and invoke the trampoline-based implementation. -.IP \(bu -A trampoline-enabled implementation, \fITheCmdNRObjProc\fR. This -function will perform the initialization, request that the trampoline -call the postprocessing routine after command evaluation, and finally, -request that the trampoline call the inner command. -.IP \(bu -A postprocessing routine, \fITheCmdPostProc\fR. This function will -perform the postprocessing formerly done after the return from the -inner command in \fITheCmdObjProc\fR. -.PP -The non-trampoline implementation is simple and stylized, containing -a single statement: +To avoid consuming space on the C stack, \fITheCmdOldObjProc\fR is renamed to +\fITheCmdNRObjProc\fR and the postprocessing step is split into a separate +function, \fITheCmdPostProc\fR, which is pushed onto the function stack. +\fITcl_EvalObjEx\fR is replaced with \fITcl_NREvalObj\fR, which uses a +trampoline instead of consuming space on the C stack. A new version of +\fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to +call \fITheCmdNRObjProc\fR: .PP .CS int -\fITheCmdNewObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -260,9 +187,6 @@ int } .CE .PP -The trampoline-enabled implementation requests postprocessing, -and returns to the trampoline requesting command evaluation. -.PP .CS int \fITheCmdNRObjProc\fR @@ -284,9 +208,6 @@ int } .CE .PP -The postprocessing procedure does whatever the original command did -upon return from the inner evaluation. -.PP .CS int \fITheCmdNRPostProc\fR( @@ -303,26 +224,13 @@ int } .CE .PP -If \fItheCommand\fR is a command that results in multiple commands or -scripts being evaluated, its postprocessing routine may schedule -additional postprocessing and then request another command evaluation -by means of \fBTcl_NREvalObj\fR or one of the other evaluation -routines. Looping and sequencing constructs may be implemented in this way. -.PP -Finally, to install a trampoline-enabled command in the interpreter, -\fBTcl_NRCreateCommand\fR is used in place of -\fBTcl_CreateObjCommand\fR. It accepts two command procedures instead -of one. The first is for use when no trampoline is yet on the stack, -and the second is for use when there is already a trampoline in place. +Any function comprising a routine can push other functions, making it possible +implement looping and sequencing constructs using the function stack. .PP -.CS -\fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, - TheCmdDeleteProc); -.CE .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT -Copyright (c) 2008 by Kevin B. Kenny +Copyright (c) 2008 by Kevin B. Kenny. +Copyright (c) 2018 by Nathan Coulter. -- cgit v0.12 From da7f77f96f74cf57e80421226d7bf1e93d776f58 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Feb 2018 13:33:21 +0000 Subject: Improved overflow prevention. --- generic/tclStringObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index ae75e44..8437555 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -140,8 +140,8 @@ GrowStringBuffer( objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - if (attempt >= 0) { + if (needed <= INT_MAX / 2) { + attempt = 2 * needed; ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { -- cgit v0.12 From 3be49723fced40ef581ccd12dbeb35b8cf346b12 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Feb 2018 13:41:26 +0000 Subject: Improved overflow prevention. --- generic/tclStringObj.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 8437555..c3a0192 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -190,8 +190,8 @@ GrowUnicodeBuffer( * Subsequent appends - apply the growth algorithm. */ - attempt = 2 * needed; - if (attempt >= 0 && attempt <= STRING_MAXCHARS) { + if (needed <= STRING_MAXCHARS / 2) { + attempt = 2 * needed; ptr = stringAttemptRealloc(stringPtr, attempt); } if (ptr == NULL) { -- cgit v0.12 From 836fa11775ae940ca572c7c330afbae5a7632d5b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Feb 2018 16:10:02 +0000 Subject: Revise TclStringRepeat() interface so that in place operations are done only by caller request. Establish a re-usable pattern. --- generic/tclCmdMZ.c | 9 +++++---- generic/tclInt.h | 15 +++++++++++++-- generic/tclStringObj.c | 31 +++++++++++++++---------------- 3 files changed, 33 insertions(+), 22 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1fc2d17..e0344ef 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2294,11 +2294,12 @@ StringReptCmd( return TCL_OK; } - if (TCL_OK != TclStringRepeat(interp, objv[1], count, &resultPtr)) { - return TCL_ERROR; + resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); + if (resultPtr) { + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + return TCL_ERROR; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index a3bd8ba..cee1d3a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3201,8 +3201,6 @@ MODULE_SCOPE int TclStringMatch(const char *str, int strLen, MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); -MODULE_SCOPE int TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - int count, Tcl_Obj **objPtrPtr); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); @@ -4008,6 +4006,19 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, struct CompileEnv *envPtr); /* + * Routines that provide the [string] ensemble functionality. Possible + * candidates for public interface. + */ + +MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, + int count, int flags); + +/* Flag values for the [string] ensemble functions. */ + +#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ +#define TCL_STRING_IN_PLACE (1<<1) + +/* * Functions defined in generic/tclVar.c and currently exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c3a0192..8bb76c1 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2708,23 +2708,24 @@ TclGetStringStorage( * Performs the [string repeat] function. * * Results: - * A standard Tcl result. + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. * * Side effects: - * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation - * of count copies of the value in objPtr. + * On error, when interp is not NULL, error information is left in it. * *--------------------------------------------------------------------------- */ -int +Tcl_Obj * TclStringRepeat( Tcl_Interp *interp, Tcl_Obj *objPtr, int count, - Tcl_Obj **objPtrPtr) + int flags) { Tcl_Obj *objResultPtr; + int inPlace = flags & TCL_STRING_IN_PLACE; int length = 0, unichar = 0, done = 1; int binary = TclIsPureByteArray(objPtr); @@ -2759,8 +2760,7 @@ TclStringRepeat( if (length == 0) { /* Any repeats of empty is empty. */ - *objPtrPtr = objPtr; - return TCL_OK; + return objPtr; } if (count > INT_MAX/length) { @@ -2769,13 +2769,13 @@ TclStringRepeat( "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } if (binary) { /* Efficiently produce a pure byte array result */ - objResultPtr = Tcl_IsShared(objPtr) ? Tcl_DuplicateObj(objPtr) - : objPtr; + objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? + Tcl_DuplicateObj(objPtr) : objPtr; Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ Tcl_SetByteArrayLength(objResultPtr, length); @@ -2788,7 +2788,7 @@ TclStringRepeat( (count - done) * length); } else if (unichar) { /* Efficiently produce a pure Tcl_UniChar array result */ - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); } else { TclInvalidateStringRep(objPtr); @@ -2803,7 +2803,7 @@ TclStringRepeat( (Tcl_WideUInt)STRING_SIZE(count*length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } Tcl_SetObjLength(objResultPtr, length); while (count - done > done) { @@ -2814,7 +2814,7 @@ TclStringRepeat( (count - done) * length); } else { /* Efficiently concatenate string reps */ - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); } else { TclFreeIntRep(objPtr); @@ -2827,7 +2827,7 @@ TclStringRepeat( count*length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } Tcl_SetObjLength(objResultPtr, length); while (count - done > done) { @@ -2837,8 +2837,7 @@ TclStringRepeat( Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), (count - done) * length); } - *objPtrPtr = objResultPtr; - return TCL_OK; + return objResultPtr; } /* -- cgit v0.12 From ca5e7c5b63ce1355c653763e82f8e75f7a38d333 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 5 Feb 2018 16:34:28 +0000 Subject: Revise the TclStringCat() interface to follow a common pattern. --- generic/tclCmdIL.c | 3 +-- generic/tclCmdMZ.c | 15 +++------------ generic/tclDictObj.c | 9 ++++++--- generic/tclExecute.c | 6 +++--- generic/tclInt.h | 5 ++--- generic/tclStringObj.c | 35 ++++++++++++++++------------------- 6 files changed, 31 insertions(+), 42 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 77b8434..fa32340 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2193,8 +2193,7 @@ Tcl_JoinObjCmd( (void) Tcl_GetStringFromObj(joinObjPtr, &length); if (length == 0) { - TclStringCatObjv(interp, /* inPlace */ 0, listLen, elemPtrs, - &resObjPtr); + resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { int i; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index e0344ef..f9e404b 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2847,7 +2847,6 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int code; Tcl_Obj *objResultPtr; if (objc < 2) { @@ -2857,23 +2856,15 @@ StringCatCmd( */ return TCL_OK; } - if (objc == 2) { - /* - * Other trivial case, single arg, just return it. - */ - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; - } - code = TclStringCatObjv(interp, /* inPlace */ 1, objc-1, objv+1, - &objResultPtr); + objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); - if (code == TCL_OK) { + if (objResultPtr) { Tcl_SetObjResult(interp, objResultPtr); return TCL_OK; } - return code; + return TCL_ERROR; } /* diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 3b983e3..a0f6491 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -2309,9 +2309,12 @@ DictAppendCmd( if (objc == 4) { appendObjPtr = objv[3]; - } else if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, - objc-3, objv+3, &appendObjPtr)) { - return TCL_ERROR; + } else { + appendObjPtr = TclStringCat(interp, objc-3, objv+3, + TCL_STRING_IN_PLACE); + if (appendObjPtr == NULL) { + return TCL_ERROR; + } } } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f2cda0c..a30ec89 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2682,9 +2682,9 @@ TEBCresume( case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); - - if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, - opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) { + objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + TCL_STRING_IN_PLACE); + if (objResultPtr == NULL) { TRACE_ERROR(interp); goto gotError; } diff --git a/generic/tclInt.h b/generic/tclInt.h index cee1d3a..6cb9955 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3189,9 +3189,6 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); -MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int inPlace, - int objc, Tcl_Obj *const objv[], - Tcl_Obj **objPtrPtr); MODULE_SCOPE int TclStringFind(Tcl_Obj *needle, Tcl_Obj *haystack, int start); MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, @@ -4010,6 +4007,8 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, * candidates for public interface. */ +MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 8bb76c1..46162ff 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2843,40 +2843,39 @@ TclStringRepeat( /* *--------------------------------------------------------------------------- * - * TclStringCatObjv -- + * TclStringCat -- * * Performs the [string cat] function. * * Results: - * A standard Tcl result. + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. * * Side effects: - * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation - * of all objc values in objv. + * On error, when interp is not NULL, error information is left in it. * *--------------------------------------------------------------------------- */ -int -TclStringCatObjv( +Tcl_Obj * +TclStringCat( Tcl_Interp *interp, - int inPlace, int objc, Tcl_Obj * const objv[], - Tcl_Obj **objPtrPtr) + int flags) { Tcl_Obj *objResultPtr, * const *ov; int oc, length = 0, binary = 1; int allowUniChar = 1, requestUniChar = 0; int first = objc - 1; /* Index of first value possibly not empty */ int last = 0; /* Index of last value possibly not empty */ + int inPlace = flags & TCL_STRING_IN_PLACE; /* assert ( objc >= 0 ) */ if (objc <= 1) { /* Only one or no objects; return first or empty */ - *objPtrPtr = objc ? objv[0] : Tcl_NewObj(); - return TCL_OK; + return objc ? objv[0] : Tcl_NewObj(); } /* assert ( objc >= 2 ) */ @@ -3053,8 +3052,7 @@ TclStringCatObjv( if (last <= first /*|| length == 0 */) { /* Only one non-empty value or zero length; return first */ /* NOTE: (length == 0) implies (last <= first) */ - *objPtrPtr = objv[first]; - return TCL_OK; + return objv[first]; } objv += first; objc = (last - first + 1); @@ -3108,7 +3106,7 @@ TclStringCatObjv( (Tcl_WideUInt)STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } dst = Tcl_GetUnicode(objResultPtr) + start; } else { @@ -3125,7 +3123,7 @@ TclStringCatObjv( (Tcl_WideUInt)STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } dst = Tcl_GetUnicode(objResultPtr); } @@ -3156,7 +3154,7 @@ TclStringCatObjv( length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } dst = Tcl_GetString(objResultPtr) + start; @@ -3172,7 +3170,7 @@ TclStringCatObjv( length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } dst = Tcl_GetString(objResultPtr); } @@ -3187,8 +3185,7 @@ TclStringCatObjv( } } } - *objPtrPtr = objResultPtr; - return TCL_OK; + return objResultPtr; overflow: if (interp) { @@ -3196,7 +3193,7 @@ TclStringCatObjv( "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return TCL_ERROR; + return NULL; } /* -- cgit v0.12 From 2567185fd23306471a28bd33da7ddea94b0b44bc Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 6 Feb 2018 11:16:51 +0000 Subject: Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a package require script that yields. --- generic/tclBasic.c | 4 +- generic/tclPkg.c | 436 +++++++++++++++++++++++++++++++++-------------------- tests/package.test | 12 ++ 3 files changed, 288 insertions(+), 164 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fa54551..366fd1f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -238,7 +238,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, 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, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, @@ -4480,6 +4480,8 @@ TclNRRunCallbacks( (void) Tcl_GetObjResult(interp); } + /* This is the trampoline. */ + while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ce00fbf..6c5b827 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -69,8 +69,14 @@ typedef struct Require { void * clientDataPtr; const char *name; Package *pkgPtr; + char *versionToProvide; } Require; +typedef struct RequireProcArgs { + const char *name; + void *clientDataPtr; +} RequireProcArgs; + /* * Prototypes for functions defined in this file: */ @@ -91,10 +97,15 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(ClientData clientData, Tcl_Interp *interp, - int reqc, Tcl_Obj *const reqv[]); -static int SelectPackage (Tcl_Interp *interp, Require *reqPtr, - int reqc, Tcl_Obj *const reqv[]); +static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. @@ -406,80 +417,116 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { + RequireProcArgs args; + args.name = name; + args.clientDataPtr = clientDataPtr; + return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); +} + +static int +TclNRPkgRequireProc( + ClientData clientData, + Tcl_Interp *interp, + int reqc, + Tcl_Obj *const reqv[]) { + RequireProcArgs *args = clientData; + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + return TCL_OK; +} + +static int +PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +{ + const char *name = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); - Require require; + Require *reqPtr; if (code != TCL_OK) { return code; } - require.clientDataPtr = clientDataPtr; - require.name = name; - require.pkgPtr = NULL; - return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv); + reqPtr = ckalloc(sizeof(Require)); + Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); + reqPtr->clientDataPtr = data[3]; + reqPtr->name = name; + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; } -int -PkgRequireCore( - ClientData clientData, - Tcl_Interp *interp, /* Interpreter in which package is now - * available. */ - int reqc, /* Requirements constraining the desired - * version. */ - Tcl_Obj *const reqv[] /* 0 means to use the latest version - * available. */ - ) -{ - int code, satisfies; +static int +PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; - Require *reqPtr = clientData; - char *script, *pkgVersionI; + char *script; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - void *clientDataPtr = reqPtr->clientDataPtr; - - reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - code = SelectPackage(interp, reqPtr, reqc, reqv); - if (code != TCL_OK) { - return code; - } - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); - - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return code; - } - Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ - reqPtr->pkgPtr = FindPackage(interp, name); - code = SelectPackage(interp, reqPtr, reqc, reqv); - if (code != TCL_OK) { - return code; - } - } - } + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL + ); + Tcl_DStringFree(&command); + } + return TCL_OK; + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } + return TCL_OK; +} +static int +PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", result)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + result = TCL_ERROR; + } + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return result; + } + Tcl_ResetResult(interp); + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + return TCL_OK; +} + +static int +PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]), satisfies; + Tcl_Obj **const reqv = data[2]; + char *pkgVersionI; + void *clientDataPtr = reqPtr->clientDataPtr; + const char *name = reqPtr->name /* Name of desired package. */; if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -517,13 +564,23 @@ PkgRequireCore( Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } + +static int +PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { + ckfree(data[0]); + return result; +} + -int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) { +static int +SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ - char *script; - int availStable, code, satisfies; + int availStable, satisfies; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; @@ -660,7 +717,9 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const bestPtr = bestStablePtr; } - if (bestPtr != NULL) { + if (bestPtr == NULL) { + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the @@ -669,105 +728,118 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const */ char *versionToProvide = bestPtr->version; - PkgFiles *pkgFiles; - PkgName *pkgName; - script = bestPtr->script; - - pkgPtr->clientData = versionToProvide; Tcl_Preserve(versionToProvide); - Tcl_Preserve(script); - pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = ckalloc(sizeof(PkgName) + strlen(name)); - pkgName->nextPtr = pkgFiles->names; - strcpy(pkgName->name, name); - pkgFiles->names = pkgName; + pkgPtr->clientData = versionToProvide; 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; - ckfree(pkgName); - Tcl_Release(script); + reqPtr->versionToProvide = versionToProvide; + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + } + return TCL_OK; +} + +static int +SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + char *versionToProvide = reqPtr->versionToProvide; - reqPtr->pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (reqPtr->pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); - } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, reqPtr->pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } - } - } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); + PkgFiles *pkgFiles; + PkgName *pkgName; + + pkgFiles = TclInitPkgFiles(interp); + /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ + pkgName = ckalloc(sizeof(PkgName) + strlen(name)); + pkgName->nextPtr = pkgFiles->names; + strcpy(pkgName->name, name); + pkgFiles->names = pkgName; + + /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ + pkgFiles->names = pkgName->nextPtr; + ckfree(pkgName); + reqPtr->pkgPtr = FindPackage(interp, name); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + if (reqPtr->pkgPtr->version == NULL) { + result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; - } + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, + NULL) != TCL_OK) { + result = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + result = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, reqPtr->pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } + } } - Tcl_Release(versionToProvide); + } else if (result != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(result); - if (code != TCL_OK) { - /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. - */ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + result = TCL_ERROR; + } - if (reqPtr->pkgPtr->version != NULL) { - ckfree(reqPtr->pkgPtr->version); - reqPtr->pkgPtr->version = NULL; - } - reqPtr->pkgPtr->clientData = NULL; - return code; + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); + + if (result != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } + reqPtr->pkgPtr->clientData = NULL; + return result; } + + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); return TCL_OK; } @@ -874,10 +946,19 @@ Tcl_PkgPresentEx( * *---------------------------------------------------------------------- */ +int +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv); +} /* ARGSUSED */ int -Tcl_PackageObjCmd( +TclNRPackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -894,7 +975,7 @@ Tcl_PackageObjCmd( PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, satisfies; + int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -903,6 +984,7 @@ Tcl_PackageObjCmd( const char *version; const char *argv2, *argv3, *argv4; char *iva = NULL, *ivb = NULL; + Tcl_Obj *objvListPtr, **newObjvPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -1148,7 +1230,6 @@ Tcl_PackageObjCmd( argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; - int res; if (objc != 5) { goto requireSyntax; @@ -1165,20 +1246,42 @@ Tcl_PackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); + Tcl_IncrRefCount(ov); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); + Tcl_IncrRefCount(objv[3]); - Tcl_IncrRefCount(ov); - res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - TclDecrRefCount(ov); - return res; + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_ListObjAppendElement(interp, objvListPtr, ov); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } else { + int i, newobjc = objc-3; + Tcl_Obj *const *newobjv = objv + 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_IncrRefCount(objv[2]); + for (i = 0; i < newobjc; i++) { - return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); + /* + * Tcl_Obj structures may have come from another interpreter, + * so duplicate them. + */ + + Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + } + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } break; case PKG_UNKNOWN: { @@ -1318,6 +1421,13 @@ Tcl_PackageObjCmd( } return TCL_OK; } + +static int +TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { + TclDecrRefCount((Tcl_Obj *)data[0]); + TclDecrRefCount((Tcl_Obj *)data[1]); + return result; +} /* *---------------------------------------------------------------------- diff --git a/tests/package.test b/tests/package.test index bb938b8..2843701 100644 --- a/tests/package.test +++ b/tests/package.test @@ -625,6 +625,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constrain package require t set x } -result {1.1} +test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { + package forget t +} -body { + coroutine coro1 apply {{} { + package ifneeded t 2.1 { + yield + package provide t 2.1 + } + package require t 2.1 + }} + list [catch {coro1} msg] $msg +} -match glob -result {0 2.1} test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { -- cgit v0.12 From 25fcbf685dbd09f24d7d45c8c6b90ed3c33eab17 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Feb 2018 17:26:40 +0000 Subject: Rename TclStringFind to TclStringFirst. Repair its operations on bytearrays. Stop trying to operate on utf-8 until we nail that down better. --- generic/tclCmdMZ.c | 10 +------- generic/tclExecute.c | 2 +- generic/tclInt.h | 4 ++-- generic/tclStringObj.c | 63 +++++++++++++++++++++++--------------------------- 4 files changed, 33 insertions(+), 46 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f9e404b..5d49d2a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1335,16 +1335,8 @@ StringFirstCmd( if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; } - - if (start < 0) { - start = 0; - } - if (start >= size) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - return TCL_OK; - } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFind(objv[1], + Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFirst(objv[1], objv[2], start))); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a30ec89..679b57a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5715,7 +5715,7 @@ TEBCresume( NEXT_INST_V(1, 3, 1); case INST_STR_FIND: - match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); + match = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 6cb9955..f288a3a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3189,8 +3189,6 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); -MODULE_SCOPE int TclStringFind(Tcl_Obj *needle, Tcl_Obj *haystack, - int start); MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, int last); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, @@ -4009,6 +4007,8 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); +MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, + int start); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 46162ff..bb72acd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3199,7 +3199,7 @@ TclStringCat( /* *--------------------------------------------------------------------------- * - * TclStringFind -- + * TclStringFirst -- * * Implements the [string first] operation. * @@ -3215,20 +3215,20 @@ TclStringCat( */ int -TclStringFind( +TclStringFirst( Tcl_Obj *needle, Tcl_Obj *haystack, int start) { int lh, ln = Tcl_GetCharLength(needle); + if (start < 0) { + start = 0; + } if (ln == 0) { - /* - * We don't find empty substrings. Bizarre! - * - * TODO: When we one day make this a true substring - * finder, change this to "return 0" - */ + /* We don't find empty substrings. Bizarre! + * Whenever this routine is turned into a proper substring + * finder, change to `return start` after limits imposed. */ return -1; } @@ -3236,51 +3236,46 @@ TclStringFind( unsigned char *end, *try, *bh; unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + /* Find bytes in bytes */ bh = Tcl_GetByteArrayFromObj(haystack, &lh); end = bh + lh; try = bh + start; while (try + ln <= end) { - try = memchr(try, bn[0], end - try); - + /* + * Look for the leading byte of the needle in the haystack + * starting at try and stopping when there's not enough room + * for the needle left. + */ + try = memchr(try, bn[0], (end + 1 - ln) - try); if (try == NULL) { + /* Leading byte not found -> needle cannot be found. */ return -1; } + /* Leading byte found, check rest of needle. */ if (0 == memcmp(try+1, bn+1, ln-1)) { + /* Checks! Return the successful index. */ return (try - bh); } + /* Rest of needle match failed; Iterate to continue search. */ try++; } return -1; } /* - * Check if we have two strings of single-byte characters. If we have, we - * can use strstr() to do the search. Note that we can sometimes have - * multibyte characters when the string could be minimally represented - * using single byte characters; we can't assume that a mismatch here - * means no match. + * TODO: It might be nice to support some cases where it is not + * necessary to shimmer to &tclStringType to compute the result, + * and instead operate just on the objPtr->bytes values directly. + * However, we also do not want the answer to change based on the + * code pathway, or if it does we want that to be for some values + * we explicitly decline to support. Getting there will involve + * locking down in practice more firmly just what encodings produce + * what supported results for the objPtr->bytes values. For now, + * do only the well-defined Tcl_UniChar array search. */ - lh = Tcl_GetCharLength(haystack); - if (haystack->bytes && (lh == haystack->length) && needle->bytes - && (ln == needle->length)) { - /* - * Both haystack and needle are all single-byte chars. - */ - - char *found = strstr(haystack->bytes + start, needle->bytes); - - if (found) { - return (found - haystack->bytes); - } else { - return -1; - } - } else { - /* - * Do the search on the unicode representation for simplicity. - */ - + { Tcl_UniChar *try, *end, *uh; Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); -- cgit v0.12 From 99ca63a80a648b2e65a9b54be78022e5cd161307 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Feb 2018 18:33:41 +0000 Subject: TclStringLast fixed. --- generic/tclCmdMZ.c | 8 -------- generic/tclStringObj.c | 48 ++++++++++-------------------------------------- 2 files changed, 10 insertions(+), 46 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 5d49d2a..03b254d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1380,14 +1380,6 @@ StringLastCmd( if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; } - - if (last < 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - return TCL_OK; - } - if (last >= size) { - last = size - 1; - } } Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1], objv[2], last))); diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index bb72acd..4481818 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3323,24 +3323,24 @@ TclStringLast( * We don't find empty substrings. Bizarre! * * TODO: When we one day make this a true substring - * finder, change this to "return 0" + * finder, change this to "return last", after limitation. */ return -1; } - if (ln > last + 1) { + lh = Tcl_GetCharLength(haystack); + if (last >= lh) { + last = lh - 1; + } + + if (last < ln - 1) { return -1; } if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { - unsigned char *try, *bh; + unsigned char *try, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); - bh = Tcl_GetByteArrayFromObj(haystack, &lh); - - if (last + 1 > lh) { - last = lh - 1; - } try = bh + last + 1 - ln; while (try >= bh) { if ((*try == bn[0]) @@ -3352,38 +3352,10 @@ TclStringLast( return -1; } - lh = Tcl_GetCharLength(haystack); - if (last + 1 > lh) { - last = lh - 1; - } - if (haystack->bytes && (lh == haystack->length)) { - /* haystack is all single-byte chars */ - - if (needle->bytes && (ln == needle->length)) { - /* needle is also all single-byte chars */ - - char *try = haystack->bytes + last + 1 - ln; - while (try >= haystack->bytes) { - if ((*try == needle->bytes[0]) - && (0 == memcmp(try+1, needle->bytes + 1, ln - 1))) { - return (try - haystack->bytes); - } - try--; - } - return -1; - } else { - /* - * Cannot find substring with a multi-byte char inside - * a string with no multi-byte chars. - */ - return -1; - } - } else { - Tcl_UniChar *try, *uh; + { + Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); - uh = Tcl_GetUnicodeFromObj(haystack, &lh); - try = uh + last + 1 - ln; while (try >= uh) { if ((*try == un[0]) -- cgit v0.12 From fde3c52d294c62edfd6aa2735c4244bd1b763b83 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 6 Feb 2018 19:10:45 +0000 Subject: Rework TclStringReverse to consistent standard form. --- generic/tclCmdMZ.c | 2 +- generic/tclInt.h | 6 +++--- generic/tclStringObj.c | 20 +++++++++++--------- 3 files changed, 15 insertions(+), 13 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 03b254d..ed4312e 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2382,7 +2382,7 @@ StringRevCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); + Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index f288a3a..f8149be 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3189,13 +3189,10 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); -MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - int last); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); -MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); @@ -4009,8 +4006,11 @@ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, int start); +MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, + int last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); +MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); /* Flag values for the [string] ensemble functions. */ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 4481818..9526f7e 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3371,14 +3371,14 @@ TclStringLast( /* *--------------------------------------------------------------------------- * - * TclStringObjReverse -- + * TclStringReverse -- * * Implements the [string reverse] operation. * * Results: - * An unshared Tcl value which is the [string reverse] of the argument - * supplied. When sharing rules permit, the returned value might be the - * argument with modifications done in place. + * A Tcl value which is the [string reverse] of the argument supplied. + * When sharing rules permit and the caller requests, the returned value + * might be the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. @@ -3409,17 +3409,19 @@ ReverseBytes( } Tcl_Obj * -TclStringObjReverse( - Tcl_Obj *objPtr) +TclStringReverse( + Tcl_Obj *objPtr, + int flags) { String *stringPtr; Tcl_UniChar ch = 0; + int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { int numBytes; unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); @@ -3433,7 +3435,7 @@ TclStringObjReverse( Tcl_UniChar *from = Tcl_GetUnicode(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { Tcl_UniChar *to; /* @@ -3462,7 +3464,7 @@ TclStringObjReverse( int numBytes = objPtr->length; char *to, *from = objPtr->bytes; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewObj(); Tcl_SetObjLength(objPtr, numBytes); } -- cgit v0.12 From 4f65558ad0db79e70b4629d6f96d7cdd09e656a3 Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 8 Feb 2018 14:02:15 +0000 Subject: win/nmakehlp.c: removed unneeded dependencies to shlwapi (the same is easily implemented by standard win-api) --- win/nmakehlp.c | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/win/nmakehlp.c b/win/nmakehlp.c index 025bb99..b759020 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -14,13 +14,8 @@ #define _CRT_SECURE_NO_DEPRECATE #include -#define NO_SHLWAPI_GDI -#define NO_SHLWAPI_STREAM -#define NO_SHLWAPI_REG -#include #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") -#pragma comment (lib, "shlwapi.lib") #include #include @@ -74,7 +69,7 @@ main( char msg[300]; DWORD dwWritten; int chars; - char *s; + const char *s; /* * Make sure children (cl.exe and link.exe) are kept quiet. @@ -688,6 +683,17 @@ SubstituteFile( return 0; } +BOOL FileExists(LPCTSTR szPath) +{ +#ifndef INVALID_FILE_ATTRIBUTES + #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) +#endif + DWORD pathAttr = GetFileAttributes(szPath); + return (pathAttr != INVALID_FILE_ATTRIBUTES && + !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); +} + + /* * QualifyPath -- * @@ -701,13 +707,8 @@ QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; - char szTmp[MAX_PATH + 1]; - char *p; - GetCurrentDirectory(MAX_PATH, szCwd); - while ((p = strchr(szPath, '/')) && *p) - *p = '\\'; - PathCombine(szTmp, szCwd, szPath); - PathCanonicalize(szCwd, szTmp); + + GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } @@ -765,7 +766,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath) strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); - if (PathFileExists(path)) { + if (FileExists(path)) { /* Found a match, print to stdout */ path[dirlen+1+sublen] = '\0'; QualifyPath(path); -- cgit v0.12 From e2877119cdc85c1a33f3d1e63035343cd4db118e Mon Sep 17 00:00:00 2001 From: sebres Date: Thu, 8 Feb 2018 14:41:06 +0000 Subject: fixes [9280abbaf57fca3eb40a89403d9d891853209bb6]: compare of `LLONG_MAX == LONG_MAX` does not possible in preprocessor (because LLONG_MAX could be complex expression), use `defined(TCL_WIDE_INT_IS_LONG)` instead of. --- generic/tclInt.h | 2 +- generic/tclObj.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index fdbe839..e5f5c74 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2453,7 +2453,7 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ -#if (LONG_MAX == LLONG_MAX) +#ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index 5f60d9d..8d4c492 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2764,7 +2764,7 @@ Tcl_GetLongFromObj( register long *longPtr) /* Place to store resulting long. */ { do { -#if (LONG_MAX == LLONG_MAX) +#ifdef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclIntType) { *longPtr = objPtr->internalRep.wideValue; return TCL_OK; @@ -2827,7 +2827,7 @@ Tcl_GetLongFromObj( return TCL_OK; } } -#if (LONG_MAX != LLONG_MAX) +#ifndef TCL_WIDE_INT_IS_LONG tooLarge: #endif if (interp != NULL) { -- cgit v0.12 From 0031252bf124749bd39e94427d50a954cb3bc762 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 9 Feb 2018 10:09:42 +0000 Subject: small code review: resolve conversion warnings (possible loss of data, signed/unsigned comparison) --- generic/tclDisassemble.c | 4 ++-- generic/tclExecute.c | 2 +- generic/tclGet.c | 2 +- generic/tclInt.h | 4 ++-- generic/tclUtil.c | 2 +- generic/tclVar.c | 4 ++-- 6 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 73b8fb9..7fe92ef 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -817,7 +817,7 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.wideValue; + int inst = (int)objPtr->internalRep.wideValue; char *s, buf[20]; int len; @@ -825,7 +825,7 @@ UpdateStringOfInstName( sprintf(buf, "inst_%d", inst); s = buf; } else { - s = (char *) tclInstructionTable[objPtr->internalRep.wideValue].name; + s = (char *) tclInstructionTable[inst].name; } len = strlen(s); objPtr->bytes = ckalloc(len + 1); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d36d363..22c6cb5 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6538,7 +6538,7 @@ TEBCresume( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.wideValue + 1; + iterNum = (int)valuePtr->internalRep.wideValue + 1; TclSetIntObj(valuePtr, iterNum); /* diff --git a/generic/tclGet.c b/generic/tclGet.c index 727db0a..2d611fa 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -142,7 +142,7 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.wideValue; + *boolPtr = (int)obj.internalRep.wideValue; } return code; } diff --git a/generic/tclInt.h b/generic/tclInt.h index e5f5c74..303bdcb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2471,13 +2471,13 @@ typedef struct List { (((objPtr)->typePtr == &tclIntType \ && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(UINT_MAX) \ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(UINT_MAX)) \ - ? ((*(intPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ (((objPtr)->typePtr == &tclIntType \ && (objPtr)->internalRep.wideValue >= INT_MIN \ && (objPtr)->internalRep.wideValue <= INT_MAX) \ - ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index b96208e..9557aac 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3585,7 +3585,7 @@ TclGetIntForIndex( * be converted to one, use it. */ - *indexPtr = endValue + objPtr->internalRep.wideValue; + *indexPtr = endValue + (int)objPtr->internalRep.wideValue; return TCL_OK; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 7c8bb73..9405fd5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -280,7 +280,7 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == (unsigned)!TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -289,7 +289,7 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == (unsigned)!TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { -- cgit v0.12 From 5765c1e39239c149fc739e8e48b3d554901318e7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 11 Feb 2018 19:19:46 +0000 Subject: Refine documentation for Tcl_NR* functions. --- doc/Eval.3 | 8 +- doc/NRE.3 | 260 ++++++++++++++++++++----------------------------------------- 2 files changed, 88 insertions(+), 180 deletions(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 191bace..e241794 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -176,10 +176,10 @@ it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . -If this flag is set, the script is processed at global level. This -means that it is evaluated in the global namespace and its variable -context consists of global variables only (it ignores any Tcl -procedures that are active). +If this flag is set, the script is evaluated in the global namespace instead of +the current namespace and its variable context consists of global variables +only (it ignores any Tcl procedures that are active). +.\" TODO: document TCL_EVAL_INVOKE and TCL_EVAL_NOERR. .SH "MISCELLANEOUS DETAILS" .PP diff --git a/doc/NRE.3 b/doc/NRE.3 index ff0d108..6078a53 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -1,5 +1,6 @@ .\" .\" Copyright (c) 2008 by Kevin B. Kenny. +.\" Copyright (c) 2018 by Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -38,43 +39,39 @@ void .SH ARGUMENTS .AS Tcl_CmdDeleteProc *interp in .AP Tcl_Interp *interp in -Interpreter in which to create or evaluate a command. +The relevant Interpreter. .AP char *cmdName in -Name of a new command to create. +Name of the command to create. .AP Tcl_ObjCmdProc *proc in -Implementation of a command that will be called whenever \fIcmdName\fR -is invoked as a command in the unoptimized way. +Called in order to evaluate a command. Is often just a small wrapper that uses +\fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves +in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) +(\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in -Implementation of a command that will be called whenever \fIcmdName\fR -is invoked and requested to conserve the C stack. +Called instead of \fIproc\fR when a trampoline is already in use. .AP ClientData clientData in -Arbitrary one-word value that will be passed to \fIproc\fR, \fInreProc\fR, -\fIdeleteProc\fR and \fIobjProc\fR. +Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR +and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out -Procedure to call before \fIcmdName\fR is deleted from the interpreter. -This procedure allows for command-specific cleanup. If \fIdeleteProc\fR -is \fBNULL\fR, then no procedure is called before the command is deleted. +Called before \fIcmdName\fR is deleted from the interpreter, allowing for +command-specific cleanup. May be NULL. .AP int objc in -Count of parameters provided to the implementation of a command. +Number of items in \fIobjv\fR. .AP Tcl_Obj **objv in -Pointer to an array of Tcl values. Each value holds the value of a -single word in the command to execute. +Words in the command. .AP Tcl_Obj *objPtr in -Pointer to a Tcl_Obj whose value is a script or expression to execute. +A script or expression to evaluate. .AP int flags in -ORed combination of flag bits that specify additional options. -\fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported. -.\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and -.\" TCL_EVAL_NOERR well enough to document them. +As described for \fITcl_EvalObjv\fR. +.PP .AP Tcl_Command cmd in -Token for a command that is to be used instead of the currently -executing command. +Token to use instead of one derived from the first word of \fIobjv\fR in order +to evaluate a command. .AP Tcl_Obj *resultPtr out -Pointer to an unshared Tcl_Obj where the result of expression -evaluation is written. +Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if +the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in -Pointer to a function that will be invoked when the command currently -executing in the interpreter designated by \fIinterp\fR completes. +A function to push. .AP ClientData data0 in .AP ClientData data1 in .AP ClientData data2 in @@ -84,98 +81,51 @@ to the function designated by \fIpostProcPtr\fR when it is invoked. .BE .SH DESCRIPTION .PP -This series of C functions provides an interface whereby commands that -are implemented in C can be evaluated, and invoke Tcl commands scripts -and scripts, without consuming space on the C stack. The non-recursive -evaluation is done by installing a \fItrampoline\fR, a small piece of -code that invokes a command or script, and then executes a series of -callbacks when the command or script returns. -.PP -The \fBTcl_NRCreateCommand\fR function creates a Tcl command in the -interpreter designated by \fIinterp\fR that is prepared to handle -nonrecursive evaluation with a trampoline. The \fIcmdName\fR argument -gives the name of the new command. If \fIcmdName\fR contains any -namespace qualifiers, then the new command is added to the specified -namespace; otherwise, it is added to the global namespace. \fIproc\fR -gives the procedure that will be called when the interpreter wishes to -evaluate the command in an unoptimized manner, and \fInreProc\fR is -the procedure that will be called when the interpreter wishes to -evaluate the command using a trampoline. \fIdeleteProc\fR is a -function that will be called before the command is deleted from the -interpreter. When any of the three functions is invoked, it is passed -the \fIclientData\fR parameter. -.PP -\fBTcl_NRCreateCommand\fR deletes any existing command -\fIname\fR already associated with the interpreter -(however see below for an exception where the existing command -is not deleted). -It returns a token that may be used to refer -to the command in subsequent calls to \fBTcl_GetCommandName\fR. -If \fBTcl_NRCreateCommand\fR is called for an interpreter that is in -the process of being deleted, then it does not create a new command, -does not delete any existing command of the same name, and returns NULL. -.PP -The \fIproc\fR and \fInreProc\fR function are expected to conform to -all the rules set forth for the \fIproc\fR argument to -\fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). -.PP -When a command that is written to cope with evaluation via trampoline -is invoked without a trampoline on the stack, it will usually respond -to the invocation by creating a trampoline and calling the -trampoline-enabled implementation of the same command. This call is done by -means of \fBTcl_NRCallObjProc\fR. In the call to -\fBTcl_NRCallObjProc\fR, the \fIinterp\fR, \fIclientData\fR, -\fIobjc\fR and \fIobjv\fR parameters should be the same ones that were -passed to \fIproc\fR. The \fInreProc\fR parameter should designate the -trampoline-enabled implementation of the command. -.PP -\fBTcl_NREvalObj\fR arranges for the script contained in \fIobjPtr\fR -to be evaluated in the interpreter designated by \fIinterp\fR after -the current command (which must be trampoline-enabled) returns. It is -the method by which a command may invoke a script without consuming -space on the C stack. Similarly, \fBTcl_NREvalObjv\fR arranges to -invoke a single Tcl command whose words have already been separated -and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the -words of the command to be evaluated when execution reaches the -trampoline. -.PP -\fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose -resolution is already known. The \fIcmd\fR parameter gives a -\fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or -\fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in -the trampoline; this command must match the word in \fIobjv[0]\fR. -The remaining arguments are as for \fBTcl_NREvalObjv\fR. -.PP -\fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR -all accept a \fIflags\fR parameter, which is an OR-ed-together set of -bits to control evaluation. At the present time, the only supported flag -available to callers is \fBTCL_EVAL_GLOBAL\fR. -.\" TODO: Again, this is a lie. Do we want to explain TCL_EVAL_INVOKE -.\" and TCL_EVAL_NOERR? -If the \fBTCL_EVAL_GLOBAL\fR flag is set, the script or command is -evaluated in the global namespace. If it is not set, it is evaluated -in the current namespace. -.PP -\fBTcl_NRExprObj\fR arranges for the expression contained in \fIobjPtr\fR -to be evaluated in the interpreter designated by \fIinterp\fR after -the current command (which must be trampoline-enabled) returns. It is -the method by which a command may evaluate a Tcl expression without consuming -space on the C stack. The argument \fIresultPtr\fR is a pointer to an -unshared Tcl_Obj where the result of expression evaluation is to be written. -If expression evaluation returns any code other than TCL_OK, the -\fIresultPtr\fR value is left untouched. -.PP -All of the routines return \fBTCL_OK\fR if command or expression invocation -has been scheduled successfully. If for any reason the scheduling cannot -be completed (for example, if the interpreter is unable to find -the requested command), they return \fBTCL_ERROR\fR with an -appropriate message left in the interpreter's result. -.PP -\fBTcl_NRAddCallback\fR arranges to have a C function called when the -current trampoline-enabled command in the Tcl interpreter designated -by \fIinterp\fR returns. The \fIpostProcPtr\fR argument is a pointer -to the callback function, which must have arguments and return value -consistent with the \fBTcl_NRPostProc\fR data type: +These functions provide an interface to the function stack that an interpreter +iterates through to evaluate commands. The routine behind a command is +implemented by an initial function and any additional functions that the +routine pushes onto the stack as it progresses. The interpreter itself pushes +functions onto the stack to react to the end of a routine and to exercise other +forms of control such as switching between in-progress stacks and the +evaluation of other scripts at additional levels without adding frames to the C +stack. To execute a routine, the initial function for the routine is called +and then a small bit of code called a \fItrampoline\fR iteratively takes +functions off the stack and calls them, using the value of the last call as the +value of the routine. +.PP +\fBTcl_NRCallObjProc\fR calls \fInreProc\fR using a new trampoline. +.PP +\fBTcl_NRCreateCommand\fR, an alternative to \fBTcl_CreateObjCommand\fR, +resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the +current namespace, creates a command by that name, and returns a token for the +command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. +Except for a few cases noted below any existing command by the same name is +first deleted. If \fIinterp\fR is in the process of being deleted +\fBTcl_NRCreateCommand\fR does not create any command, does not delete any +command, and returns NULL. +.PP +\fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but +consumes no space on the C stack. +.PP +\fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but +consumes no space on the C stack. +.PP +\fBTcl_NRCmdSwap\fR is like \fBTcl_NREvalObjv\fR, but uses \fIcmd\fR, a token +previously returned by \fBTcl_CreateObjCommand\fR or +\fBTcl_GetCommandFromObj\fR, instead of resolving the first word of \fIobjv\fR. +. The name of this command must be the same as \fIobjv[0]\fR. +.PP +\fBTcl_NRExprObj\fR pushes a function that evaluates \fIobjPtr\fR as an +expression in the same manner as \fBTcl_ExprObj\fR but without consuming space +on the C stack. +.PP +All of the functions return \fBTCL_OK\fR if the evaluation of the script, +command, or expression has been scheduled successfully. Otherwise (for example +if the command name cannot be resolved), they return \fBTCL_ERROR\fR and store +a message as the interpreter's result. +.PP +\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for +\fBTcl_NRPostProc\fR is: .PP .CS typedef int @@ -185,25 +135,13 @@ typedef int int \fIresult\fR); .CE .PP -When the trampoline invokes the callback function, the \fIdata\fR -parameter will point to an array containing the four one-word -quantities that were passed to \fBTcl_NRAddCallback\fR in the -\fIdata0\fR through \fIdata3\fR parameters. The Tcl interpreter will -be designated by the \fIinterp\fR parameter, and the \fIresult\fR -parameter will contain the result (\fBTCL_OK\fR, \fBTCL_ERROR\fR, -\fBTCL_RETURN\fR, \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR) that was -returned by the command evaluation. The callback function is expected, -in turn, either to return a \fIresult\fR to control further evaluation. -.PP -Multiple \fBTcl_NRAddCallback\fR invocations may request multiple -callbacks, which may be to the same or different callback -functions. If multiple callbacks are requested, they are executed in -last-in, first-out order, that is, the most recently requested -callback is executed first. +\fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR. +\fIresult\fR is the value returned by the previous function implementing part +the routine. .SH EXAMPLE .PP -The usual pattern for Tcl commands that invoke other Tcl commands -is something like: +The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C +stack, to evalute a script: .PP .CS int @@ -228,28 +166,17 @@ int \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP -To enable a command like this one for trampoline-based evaluation, -it must be split into three pieces: -.IP \(bu -A non-trampoline implementation, \fITheCmdNewObjProc\fR, -which will simply create a trampoline -and invoke the trampoline-based implementation. -.IP \(bu -A trampoline-enabled implementation, \fITheCmdNRObjProc\fR. This -function will perform the initialization, request that the trampoline -call the postprocessing routine after command evaluation, and finally, -request that the trampoline call the inner command. -.IP \(bu -A postprocessing routine, \fITheCmdPostProc\fR. This function will -perform the postprocessing formerly done after the return from the -inner command in \fITheCmdObjProc\fR. -.PP -The non-trampoline implementation is simple and stylized, containing -a single statement: +To avoid consuming space on the C stack, \fITheCmdOldObjProc\fR is renamed to +\fITheCmdNRObjProc\fR and the postprocessing step is split into a separate +function, \fITheCmdPostProc\fR, which is pushed onto the function stack. +\fITcl_EvalObjEx\fR is replaced with \fITcl_NREvalObj\fR, which uses a +trampoline instead of consuming space on the C stack. A new version of +\fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to +call \fITheCmdNRObjProc\fR: .PP .CS int -\fITheCmdNewObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -260,9 +187,6 @@ int } .CE .PP -The trampoline-enabled implementation requests postprocessing, -and returns to the trampoline requesting command evaluation. -.PP .CS int \fITheCmdNRObjProc\fR @@ -284,9 +208,6 @@ int } .CE .PP -The postprocessing procedure does whatever the original command did -upon return from the inner evaluation. -.PP .CS int \fITheCmdNRPostProc\fR( @@ -303,26 +224,13 @@ int } .CE .PP -If \fItheCommand\fR is a command that results in multiple commands or -scripts being evaluated, its postprocessing routine may schedule -additional postprocessing and then request another command evaluation -by means of \fBTcl_NREvalObj\fR or one of the other evaluation -routines. Looping and sequencing constructs may be implemented in this way. -.PP -Finally, to install a trampoline-enabled command in the interpreter, -\fBTcl_NRCreateCommand\fR is used in place of -\fBTcl_CreateObjCommand\fR. It accepts two command procedures instead -of one. The first is for use when no trampoline is yet on the stack, -and the second is for use when there is already a trampoline in place. +Any function comprising a routine can push other functions, making it possible +implement looping and sequencing constructs using the function stack. .PP -.CS -\fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, - TheCmdDeleteProc); -.CE .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT -Copyright (c) 2008 by Kevin B. Kenny +Copyright (c) 2008 by Kevin B. Kenny. +Copyright (c) 2018 by Nathan Coulter. -- cgit v0.12 From ad022e6d3b0857ae1266961eb07a1c3459d6e1cf Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 11 Feb 2018 19:29:08 +0000 Subject: Remove restriction on defining the class of a TclOO object not explicitly instantiated from ::oo::class. --- generic/tclOODefineCmds.c | 15 --------------- tests/oo.test | 4 ++-- 2 files changed, 2 insertions(+), 17 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e953dc0..47b34bb 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1077,7 +1077,6 @@ TclOODefineClassObjCmd( { Object *oPtr; Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); /* * Parse the context to get the object to operate on. @@ -1114,20 +1113,6 @@ TclOODefineClassObjCmd( return TCL_ERROR; } - /* - * Apply semantic checks. In particular, classes and non-classes are not - * interchangable (too complicated to do the conversion!) so we must - * produce an error if any attempt is made to swap from one to the other. - */ - - if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "may not change a %sclass object into a %sclass object", - (oPtr->classPtr==NULL ? "non-" : ""), - (oPtr->classPtr==NULL ? "" : "non-"))); - Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); - return TCL_ERROR; - } /* * Set the object's class. diff --git a/tests/oo.test b/tests/oo.test index 61a5e01..8850ea5 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1668,13 +1668,13 @@ test oo-13.2 {OO: changing an object's class} -body { oo::objdefine foo class oo::class } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a non-class object into a class object} +} -result {} test oo-13.3 {OO: changing an object's class} -body { oo::class create foo oo::objdefine foo class oo::object } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a class object into a non-class object} +} -result {} test oo-13.4 {OO: changing an object's class} -body { oo::class create foo { method m {} { -- cgit v0.12 From 568724e4687c000b9ec9e66512048d5c8d8174f7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 11 Feb 2018 19:35:27 +0000 Subject: Change the signature of PkgRequireCore in preparation to provide TclNRPackageObjCmd. --- generic/tclPkg.c | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6d826a9..6a246bb 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -69,7 +69,7 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, +static int PkgRequireCore(Tcl_Interp *interp, const char *name, int reqc, Tcl_Obj *const reqv[], void *clientDataPtr); @@ -299,7 +299,10 @@ Tcl_PkgRequireEx( */ if (version == NULL) { - result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { @@ -310,10 +313,12 @@ Tcl_PkgRequireEx( Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } TclDecrRefCount(ov); } - return result; } @@ -328,17 +333,14 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { - const char *result = - PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); - - if (result == NULL) { - return TCL_ERROR; + int code = CheckAllRequirements(interp, reqc, reqv); + if (code != TCL_OK) { + return code; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); - return TCL_OK; + return PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); } -static const char * +int PkgRequireCore( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -358,10 +360,6 @@ PkgRequireCore( char *script, *pkgVersionI; Tcl_DString command; - if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { - return NULL; - } - /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for @@ -387,7 +385,7 @@ PkgRequireCore( name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); - return NULL; + return TCL_ERROR; } /* @@ -598,7 +596,7 @@ PkgRequireCore( pkgPtr->version = NULL; } pkgPtr->clientData = NULL; - return NULL; + return code; } break; @@ -634,7 +632,7 @@ PkgRequireCore( if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); - return NULL; + return code; } Tcl_ResetResult(interp); } @@ -645,7 +643,7 @@ PkgRequireCore( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); - return NULL; + return TCL_ERROR; } /* @@ -666,7 +664,7 @@ PkgRequireCore( Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); - return NULL; + return TCL_ERROR; } } @@ -675,7 +673,8 @@ PkgRequireCore( *ptr = pkgPtr->clientData; } - return pkgPtr->version; + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + return TCL_OK; } /* -- cgit v0.12 From 4c79bcbe64fca55bf859f1fb9a78bf887d7c78dc Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 10:14:02 +0000 Subject: Preparation to provide TclNRPackageObjectCmd: Eliminate the loop in PkgRequireCore so that TclNRAddCallback can be added at the needed spots. --- generic/tclInt.h | 1 + generic/tclPkg.c | 525 ++++++++++++++++++++++++++++--------------------------- 2 files changed, 264 insertions(+), 262 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 4967cd3..ac67ebd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2750,6 +2750,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 6a246bb..b48e71b 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -72,6 +72,8 @@ static Package * FindPackage(Tcl_Interp *interp, const char *name); static int PkgRequireCore(Tcl_Interp *interp, const char *name, int reqc, Tcl_Obj *const reqv[], void *clientDataPtr); +static int SelectPackage (Tcl_Interp *interp, const char *name, + Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]); /* * Helper macros. @@ -351,329 +353,328 @@ PkgRequireCore( * available. */ void *clientDataPtr) { - Interp *iPtr = (Interp *) interp; Package *pkgPtr; - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion, *bestStableVersion; - /* Internal rep. of versions */ - int availStable, code, satisfies, pass; + int code, satisfies; char *script, *pkgVersionI; Tcl_DString command; + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } + if (pkgPtr->version == NULL) { + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); + + if ((code != TCL_OK) && (code != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", code)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + code = TCL_ERROR; + } + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return code; + } + Tcl_ResetResult(interp); + } + /* pkgPtr may now be invalid, so refresh it. */ + pkgPtr = FindPackage(interp, name); + code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } + } + } + + if (pkgPtr->version == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; + } + /* - * It can take up to three passes to find the package: one pass to run the - * "package unknown" script, one to run the "package ifneeded" script for - * a specific version, and a final pass to lookup the package loaded by - * the "package ifneeded" script. + * Ensure that the provided version meets the current requirements. */ - for (pass=1 ;; pass++) { - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version != NULL) { - break; - } + if (reqc != 0) { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - /* - * Check whether we're already attempting to load some version of this - * package (circular dependency detection). - */ + ckfree(pkgVersionI); - if (pkgPtr->clientData != NULL) { + if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "circular package dependency:" - " attempt to provide %s %s requires %s", - name, (char *) pkgPtr->clientData, name)); + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return TCL_ERROR; } + } - /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. - */ - - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; - bestStableVersion = NULL; + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { - /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. - */ + *ptr = pkgPtr->clientData; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + return TCL_OK; +} + +int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) { + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion, *bestStableVersion; + /* Internal rep. of versions */ + char *script; + int availStable, code, satisfies; + Interp *iPtr = (Interp *) interp; - continue; - } + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ - /* Check satisfaction of requirements before considering the current version further. */ - if (reqc > 0) { - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - ckfree(availVersion); - availVersion = NULL; - continue; - } - } + if (pkgPtr->clientData != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "circular package dependency:" + " attempt to provide %s %s requires %s", + name, (char *) pkgPtr->clientData, name)); + AddRequirementsToResult(interp, reqc, reqv); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + return TCL_ERROR; + } - if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. + */ - /* - * Note: Used internal reps in the comparison! - */ + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + bestStableVersion = NULL; - if (res > 0) { - /* - * The version of the package sought is better than the - * currently selected version. - */ - ckfree(bestVersion); - bestVersion = NULL; - goto newbest; - } - } else { - newbest: - /* We have found a version which is better than our max. */ + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { + /* + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ - bestPtr = availPtr; - CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); - } + continue; + } - if (!availStable) { + /* Check satisfaction of requirements before considering the current version further. */ + if (reqc > 0) { + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } + } - if (bestStablePtr != NULL) { - int res = CompareVersions(availVersion, bestStableVersion, NULL); + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ + if (res > 0) { /* - * Note: Used internal reps in the comparison! + * The version of the package sought is better than the + * currently selected version. */ - - if (res > 0) { - /* - * This stable version of the package sought is better - * than the currently selected stable version. - */ - ckfree(bestStableVersion); - bestStableVersion = NULL; - goto newstable; - } - } else { - newstable: - /* We have found a stable version which is better than our max stable. */ - bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + ckfree(bestVersion); + bestVersion = NULL; + goto newbest; } + } else { + newbest: + /* We have found a version which is better than our max. */ - ckfree(availVersion); - availVersion = NULL; - } /* end for */ - - /* - * Clean up memorized internal reps, if any. - */ - - if (bestVersion != NULL) { - ckfree(bestVersion); - bestVersion = NULL; + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); } - if (bestStableVersion != NULL) { - ckfree(bestStableVersion); - bestStableVersion = NULL; + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; } - /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. - */ + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); - if ((iPtr->packagePrefer == PKG_PREFER_STABLE) - && (bestStablePtr != NULL)) { - bestPtr = bestStablePtr; - } - - if (bestPtr != NULL) { /* - * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * Note: Used internal reps in the comparison! */ - char *versionToProvide = bestPtr->version; - script = bestPtr->script; - - pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); - Tcl_Preserve(versionToProvide); - code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release(script); - - pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); - } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } - } - } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; - } - - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); - - if (code != TCL_OK) { + if (res > 0) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This stable version of the package sought is better + * than the currently selected stable version. */ - - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; - } - pkgPtr->clientData = NULL; - return code; + ckfree(bestStableVersion); + bestStableVersion = NULL; + goto newstable; } - - break; - } - - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it (but only on the first pass; after that, we - * should not get here in the first place). - */ - - if (pass > 1) { - break; + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ + bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); + ckfree(availVersion); + availVersion = NULL; + } /* end for */ - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); + /* + * Clean up memorized internal reps, if any. + */ - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return code; - } - Tcl_ResetResult(interp); - } + if (bestVersion != NULL) { + ckfree(bestVersion); + bestVersion = NULL; } - if (pkgPtr->version == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* - * At this point we know that the package is present. Make sure that the - * provided version meets the current requirements. + * Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. */ - if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; + } - ckfree(pkgVersionI); + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + char *versionToProvide = bestPtr->version; + script = bestPtr->script; + + pkgPtr->clientData = versionToProvide; + Tcl_Preserve(script); + Tcl_Preserve(versionToProvide); + code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); + Tcl_Release(script); + + pkgPtr = FindPackage(interp, name); + if (code == TCL_OK) { + Tcl_ResetResult(interp); + if (pkgPtr->version == NULL) { + code = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { + code = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + code = TCL_ERROR; + } else { + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + code = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } + } + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); - if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + code = TCL_ERROR; } - } - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; + if (code == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); - *ptr = pkgPtr->clientData; + if (code != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; + return code; + } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); return TCL_OK; } -- cgit v0.12 From f4babdb0acc66d9d4eda61a094f12f99a24b8915 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 10:44:44 +0000 Subject: Adapt signature of PkgRequireCore to conform to Tcl_ObjCmdProc, and call it in Tcl_PkgRequireProc on an NRE trampoline via Tcl_NRCallObjProc. Additional callbacks still needed to fully NRE-enable [package require]. --- generic/tclPkg.c | 83 ++++++++++++++++++++++++++++++++------------------------ 1 file changed, 48 insertions(+), 35 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index b48e71b..ff8db13 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -49,6 +49,12 @@ typedef struct Package { const void *clientData; /* Client data. */ } Package; +typedef struct Require { + void * clientDataPtr; + const char *name; + Package *pkgPtr; +} Require; + /* * Prototypes for functions defined in this file: */ @@ -69,11 +75,10 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(Tcl_Interp *interp, const char *name, - int reqc, Tcl_Obj *const reqv[], - void *clientDataPtr); -static int SelectPackage (Tcl_Interp *interp, const char *name, - Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]); +static int PkgRequireCore(ClientData clientData, Tcl_Interp *interp, + int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage (Tcl_Interp *interp, Require *reqPtr, + int reqc, Tcl_Obj *const reqv[]); /* * Helper macros. @@ -336,35 +341,41 @@ Tcl_PkgRequireProc( void *clientDataPtr) { int code = CheckAllRequirements(interp, reqc, reqv); + Require require; if (code != TCL_OK) { return code; } - return PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + require.clientDataPtr = clientDataPtr; + require.name = name; + require.pkgPtr = NULL; + return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv); } int PkgRequireCore( + ClientData clientData, Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - const char *name, /* Name of desired package. */ int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *const reqv[], /* 0 means to use the latest version + Tcl_Obj *const reqv[] /* 0 means to use the latest version * available. */ - void *clientDataPtr) + ) { - Package *pkgPtr; int code, satisfies; - char *script, *pkgVersionI; Tcl_DString command; + Require *reqPtr = clientData; + char *script, *pkgVersionI; + const char *name = reqPtr->name /* Name of desired package. */; + void *clientDataPtr = reqPtr->clientDataPtr; - pkgPtr = FindPackage(interp, name); - if (pkgPtr->version == NULL) { - code = SelectPackage(interp, name, pkgPtr, reqc, reqv); + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + code = SelectPackage(interp, reqPtr, reqc, reqv); if (code != TCL_OK) { return code; } - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { /* * The package is not in the database. If there is a "package unknown" * command, invoke it. @@ -393,17 +404,17 @@ PkgRequireCore( return code; } Tcl_ResetResult(interp); - } - /* pkgPtr may now be invalid, so refresh it. */ - pkgPtr = FindPackage(interp, name); - code = SelectPackage(interp, name, pkgPtr, reqc, reqv); - if (code != TCL_OK) { - return code; + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + code = SelectPackage(interp, reqPtr, reqc, reqv); + if (code != TCL_OK) { + return code; + } } } } - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); @@ -416,7 +427,7 @@ PkgRequireCore( */ if (reqc != 0) { - CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); @@ -424,7 +435,7 @@ PkgRequireCore( if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", - name, pkgPtr->version)); + name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -435,18 +446,20 @@ PkgRequireCore( if (clientDataPtr) { const void **ptr = (const void **) clientDataPtr; - *ptr = pkgPtr->clientData; + *ptr = reqPtr->pkgPtr->clientData; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } -int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int reqc, Tcl_Obj *const reqv[]) { +int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ char *script; int availStable, code, satisfies; + const char *name = reqPtr->name; + Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; /* @@ -598,10 +611,10 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); Tcl_Release(script); - pkgPtr = FindPackage(interp, name); + reqPtr->pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { Tcl_ResetResult(interp); - if (pkgPtr->version == NULL) { + if (reqPtr->pkgPtr->version == NULL) { code = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" @@ -612,7 +625,7 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re } else { char *pvi, *vi; - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, NULL) != TCL_OK) { code = TCL_ERROR; } else if (CheckVersionAndConvert(interp, @@ -630,7 +643,7 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, - name, pkgPtr->version)); + name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -667,11 +680,11 @@ int SelectPackage (Tcl_Interp *interp, const char *name, Package *pkgPtr, int re * either. */ - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); - pkgPtr->version = NULL; + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } - pkgPtr->clientData = NULL; + reqPtr->pkgPtr->clientData = NULL; return code; } } -- cgit v0.12 From 1553090bc312c0691df9549983c1d25542c16ef5 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 12 Feb 2018 12:40:34 +0000 Subject: Add remaining wrapper to the NR functions, remaining calls to TCL_NRAddCallback, and a test for a package require script that yields. DGP: This checkin introduces a memleak, detected by test compExpr-7.1. --- generic/tclBasic.c | 4 +- generic/tclPkg.c | 408 +++++++++++++++++++++++++++++++++-------------------- tests/package.test | 12 ++ 3 files changed, 273 insertions(+), 151 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ddc828a..e2319d2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -234,7 +234,7 @@ static const CmdInfo builtInCmds[] = { {"lsearch", Tcl_LsearchObjCmd, 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, NULL, CMD_IS_SAFE}, + {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, @@ -4428,6 +4428,8 @@ TclNRRunCallbacks( (void) Tcl_GetObjResult(interp); } + /* This is the trampoline. */ + while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ff8db13..e956a40 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -53,8 +53,14 @@ typedef struct Require { void * clientDataPtr; const char *name; Package *pkgPtr; + char *versionToProvide; } Require; +typedef struct RequireProcArgs { + const char *name; + void *clientDataPtr; +} RequireProcArgs; + /* * Prototypes for functions defined in this file: */ @@ -75,10 +81,15 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(ClientData clientData, Tcl_Interp *interp, - int reqc, Tcl_Obj *const reqv[]); -static int SelectPackage (Tcl_Interp *interp, Require *reqPtr, - int reqc, Tcl_Obj *const reqv[]); +static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. @@ -340,80 +351,116 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { + RequireProcArgs args; + args.name = name; + args.clientDataPtr = clientDataPtr; + return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); +} + +static int +TclNRPkgRequireProc( + ClientData clientData, + Tcl_Interp *interp, + int reqc, + Tcl_Obj *const reqv[]) { + RequireProcArgs *args = clientData; + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + return TCL_OK; +} + +static int +PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +{ + const char *name = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); - Require require; + Require *reqPtr; if (code != TCL_OK) { return code; } - require.clientDataPtr = clientDataPtr; - require.name = name; - require.pkgPtr = NULL; - return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv); + reqPtr = ckalloc(sizeof(Require)); + Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); + reqPtr->clientDataPtr = data[3]; + reqPtr->name = name; + reqPtr->pkgPtr = FindPackage(interp, name); + if (reqPtr->pkgPtr->version == NULL) { + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; } -int -PkgRequireCore( - ClientData clientData, - Tcl_Interp *interp, /* Interpreter in which package is now - * available. */ - int reqc, /* Requirements constraining the desired - * version. */ - Tcl_Obj *const reqv[] /* 0 means to use the latest version - * available. */ - ) -{ - int code, satisfies; +static int +PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; - Require *reqPtr = clientData; - char *script, *pkgVersionI; + char *script; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - void *clientDataPtr = reqPtr->clientDataPtr; - - reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - code = SelectPackage(interp, reqPtr, reqc, reqv); - if (code != TCL_OK) { - return code; - } - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ - script = ((Interp *) interp)->packageUnknown; - if (script != NULL) { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&command); - - if ((code != TCL_OK) && (code != TCL_ERROR)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad return code: %d", code)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - code = TCL_ERROR; - } - if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, - "\n (\"package unknown\" script)"); - return code; - } - Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ - reqPtr->pkgPtr = FindPackage(interp, name); - code = SelectPackage(interp, reqPtr, reqc, reqv); - if (code != TCL_OK) { - return code; - } - } - } + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL + ); + Tcl_DStringFree(&command); + } + return TCL_OK; + } else { + Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } + return TCL_OK; +} + +static int +PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name /* Name of desired package. */; + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad return code: %d", result)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + result = TCL_ERROR; } + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return result; + } + Tcl_ResetResult(interp); + /* pkgPtr may now be invalid, so refresh it. */ + reqPtr->pkgPtr = FindPackage(interp, name); + Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + return TCL_OK; +} +static int +PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]), satisfies; + Tcl_Obj **const reqv = data[2]; + char *pkgVersionI; + void *clientDataPtr = reqPtr->clientDataPtr; + const char *name = reqPtr->name /* Name of desired package. */; if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -451,13 +498,23 @@ PkgRequireCore( Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } + +static int +PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { + ckfree(data[0]); + return result; +} + -int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) { +static int +SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ - char *script; - int availStable, code, satisfies; + int availStable, satisfies; + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; @@ -594,7 +651,9 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const bestPtr = bestStablePtr; } - if (bestPtr != NULL) { + if (bestPtr == NULL) { + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the @@ -603,91 +662,102 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const */ char *versionToProvide = bestPtr->version; - script = bestPtr->script; pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); Tcl_Preserve(versionToProvide); - code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release(script); + reqPtr->versionToProvide = versionToProvide; + Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + } + return TCL_OK; +} + +static int +SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { + Require *reqPtr = data[0]; + int reqc = PTR2INT(data[1]); + Tcl_Obj **const reqv = data[2]; + const char *name = reqPtr->name; + char *versionToProvide = reqPtr->versionToProvide; - reqPtr->pkgPtr = FindPackage(interp, name); - if (code == TCL_OK) { - Tcl_ResetResult(interp); - if (reqPtr->pkgPtr->version == NULL) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - NULL); + reqPtr->pkgPtr = FindPackage(interp, name); + if (result == TCL_OK) { + Tcl_ResetResult(interp); + if (reqPtr->pkgPtr->version == NULL) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " no version of package %s provided", + name, versionToProvide, name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", + NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, + NULL) != TCL_OK) { + result = TCL_ERROR; + } else if (CheckVersionAndConvert(interp, + versionToProvide, &vi, NULL) != TCL_OK) { + ckfree(pvi); + result = TCL_ERROR; } else { - char *pvi, *vi; - - if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, - NULL) != TCL_OK) { - code = TCL_ERROR; - } else if (CheckVersionAndConvert(interp, - versionToProvide, &vi, NULL) != TCL_OK) { - ckfree(pvi); - code = TCL_ERROR; - } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); - ckfree(vi); - if (res != 0) { - code = TCL_ERROR; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " package %s %s provided instead", - name, versionToProvide, - name, reqPtr->pkgPtr->version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", NULL); - } + int res = CompareVersions(pvi, vi, NULL); + + ckfree(pvi); + ckfree(vi); + if (res != 0) { + result = TCL_ERROR; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " package %s %s provided instead", + name, versionToProvide, + name, reqPtr->pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); } } - } else if (code != TCL_ERROR) { - Tcl_Obj *codePtr = Tcl_NewIntObj(code); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "attempt to provide package %s %s failed:" - " bad return code: %s", - name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); - code = TCL_ERROR; } + } else if (result != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(result); - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to provide package %s %s failed:" + " bad return code: %s", + name, versionToProvide, TclGetString(codePtr))); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + TclDecrRefCount(codePtr); + result = TCL_ERROR; + } - if (code != TCL_OK) { - /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. - * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. - */ + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); - if (reqPtr->pkgPtr->version != NULL) { - ckfree(reqPtr->pkgPtr->version); - reqPtr->pkgPtr->version = NULL; - } - reqPtr->pkgPtr->clientData = NULL; - return code; + if (result != TCL_OK) { + /* + * Take a non-TCL_OK code from the script as an indication the + * package wasn't loaded properly, so the package system + * should not remember an improper load. + * + * This is consistent with our returning NULL. If we're not + * willing to tell our caller we got a particular version, we + * shouldn't store that version for telling future callers + * either. + */ + + if (reqPtr->pkgPtr->version != NULL) { + ckfree(reqPtr->pkgPtr->version); + reqPtr->pkgPtr->version = NULL; } + reqPtr->pkgPtr->clientData = NULL; + return result; } + + Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); return TCL_OK; } @@ -794,10 +864,19 @@ Tcl_PkgPresentEx( * *---------------------------------------------------------------------- */ +int +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv); +} /* ARGSUSED */ int -Tcl_PackageObjCmd( +TclNRPackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -814,7 +893,7 @@ Tcl_PackageObjCmd( PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, satisfies; + int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -823,6 +902,7 @@ Tcl_PackageObjCmd( const char *version; const char *argv2, *argv3, *argv4; char *iva = NULL, *ivb = NULL; + Tcl_Obj *objvListPtr, **newObjvPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -1029,7 +1109,6 @@ Tcl_PackageObjCmd( argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; - int res; if (objc != 5) { goto requireSyntax; @@ -1046,20 +1125,42 @@ Tcl_PackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); + Tcl_IncrRefCount(ov); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); + Tcl_IncrRefCount(objv[3]); - Tcl_IncrRefCount(ov); - res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - TclDecrRefCount(ov); - return res; + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_ListObjAppendElement(interp, objvListPtr, ov); + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } else { + int i, newobjc = objc-3; + Tcl_Obj *const *newobjv = objv + 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } + objvListPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(objvListPtr); + Tcl_IncrRefCount(objv[2]); + for (i = 0; i < newobjc; i++) { + + /* + * Tcl_Obj structures may have come from another interpreter, + * so duplicate them. + */ - return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); + Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + } + Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); + Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); + Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + return TCL_OK; } break; case PKG_UNKNOWN: { @@ -1199,6 +1300,13 @@ Tcl_PackageObjCmd( } return TCL_OK; } + +static int +TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { + TclDecrRefCount((Tcl_Obj *)data[0]); + TclDecrRefCount((Tcl_Obj *)data[1]); + return result; +} /* *---------------------------------------------------------------------- diff --git a/tests/package.test b/tests/package.test index 74415ae..bc73003 100644 --- a/tests/package.test +++ b/tests/package.test @@ -608,6 +608,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} { package require t set x } {1.1} +test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { + package forget t +} -body { + coroutine coro1 apply {{} { + package ifneeded t 2.1 { + yield + package provide t 2.1 + } + package require t 2.1 + }} + list [catch {coro1} msg] $msg +} -match glob -result {0 2.1} test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { -- cgit v0.12 From 396c1a637c399fdb78e0d52ec4944859fa072e5c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Feb 2018 20:51:57 +0000 Subject: New test expr-32.7 for bignum modulus range. --- tests/expr.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index 5843b49..c49a9ff 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5838,6 +5838,9 @@ test expr-32.5 {Bug 1585704} { test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] +test expr-32.7 {bignum regression} { + expr {0%(1<<63)} +} 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 -- cgit v0.12 From 4a6163c6a6a7f6e85f28f753e303caaa99b83a31 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 13 Feb 2018 20:59:36 +0000 Subject: test expr-32.7 for bignum modulus range. FAILING for now. Error in TIP 484. --- tests/expr.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index 0b3620a..4fac8b1 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5799,6 +5799,9 @@ test expr-32.5 {Bug 1585704} { test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] +test expr-32.7 {bignum regression} { + expr {0%(1<<63)} +} 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 -- cgit v0.12 From ea6e8c9dcdd3f2e3fa35a81646981e384593aae0 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 10:46:08 +0000 Subject: Fix for issue 9fd5c629c1, TclOO - aborts when a trace on command deletion deletes the object's namespace. --- generic/tclBasic.c | 8 ++++---- generic/tclFileName.c | 2 +- generic/tclOO.c | 35 ++++++++++++++++++++++++++--------- generic/tclOOCall.c | 8 ++++---- generic/tclOOInt.h | 16 ++++++++-------- tests/oo.test | 12 ++++++++++++ 6 files changed, 55 insertions(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e2319d2..9720689 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3100,7 +3100,7 @@ Tcl_DeleteCommandFromToken( /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and - * delete procs may try to delete the command themsevles. This flag + * delete procs may try to delete the command themselves. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ @@ -7704,8 +7704,8 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * Take into consideration the thread this interp is running in order - * to insure different seeds in different threads (bug #416643) + * To ensure different seeds in different threads (bug #416643), + * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -9073,7 +9073,7 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* insure that the command is looked up in the correct namespace */ + /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 2136883..b566d7f 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1904,7 +1904,7 @@ TclGlob( } /* - * To process a [glob] invokation, this function may be called multiple + * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. diff --git a/generic/tclOO.c b/generic/tclOO.c index f236ac9..bae784a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -880,7 +880,7 @@ ObjectRenamedTrace( * 2950259] */ - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { Tcl_DeleteNamespace(oPtr->namespacePtr); } if (oPtr->classPtr) { @@ -1168,7 +1168,7 @@ ObjectNamespaceDeleted( Class *clsPtr = oPtr->classPtr, *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int i; + int deleteAlreadyInProgress = 0, i; /* * Instruct everyone to no longer use any allocated fields of the object. @@ -1178,6 +1178,14 @@ ObjectNamespaceDeleted( */ if (oPtr->command) { + if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + /* + * Namespace deletion must have been triggered by a trace on command + * deletion , meaning that + */ + deleteAlreadyInProgress = 1; + } + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } if (oPtr->myCommand) { @@ -1273,14 +1281,17 @@ ObjectNamespaceDeleted( if (clsPtr->subclasses.list) { ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; clsPtr->subclasses.num = 0; } if (clsPtr->instances.list) { ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; clsPtr->instances.num = 0; } if (clsPtr->mixinSubs.list) { ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; clsPtr->mixinSubs.num = 0; } @@ -1305,7 +1316,13 @@ ObjectNamespaceDeleted( * Delete the object structure itself. */ - DelRef(oPtr); + if (deleteAlreadyInProgress) { + oPtr->classPtr = NULL; + oPtr->namespacePtr = NULL; + } else { + DelRef(oPtr); + } + } /* @@ -2435,7 +2452,7 @@ Tcl_ObjectSetMetadata( * * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- * - * Main entry point for object invokations. The Public* and Private* + * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. @@ -2520,8 +2537,8 @@ TclOOInvokeObject( * * TclOOObjectCmdCore, FinalizeObjectCall -- * - * Main function for object invokations. Does call chain creation, - * management and invokation. The function FinalizeObjectCall exists to + * Main function for object invocations. Does call chain creation, + * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. * * ---------------------------------------------------------------------- @@ -2533,7 +2550,7 @@ TclOOObjectCmdCore( Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ - int flags, /* Whether this is an invokation through the + int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with @@ -2722,7 +2739,7 @@ Tcl_ObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2791,7 +2808,7 @@ TclNRObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 3e4f561..d4e1e34 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -233,7 +233,7 @@ FreeMethodNameRep( * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the - * invokation of a step along the chain can cause further steps along the + * invocation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * @@ -830,7 +830,7 @@ AddMethodToCallChain( * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of - * method invokations in the call chain; it just rearranges them. + * method invocations in the call chain; it just rearranges them. */ Class *declCls = callPtr->chain[i].filterDeclarer; @@ -935,7 +935,7 @@ IsStillValid( * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all - * method implementations to be called as part of a method invokation. + * method implementations to be called as part of a method invocation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- @@ -1517,7 +1517,7 @@ TclOORenderCallChain( /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For - * each triple, the first word is the type of invokation ("method" is + * each triple, the first word is the type of invocation ("method" is * normal, "unknown" is special because it adds the method name as an * extra argument when handled by some method types, and "filter" is * special because it's a filter method). The second word is the name of diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index b75ffdb..1eb787f 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -149,8 +149,8 @@ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path - * for object invokation and creation. */ - Tcl_Namespace *namespacePtr;/* This object's tame namespace. */ + * for object invocation and creation. */ + Tcl_Namespace *namespacePtr;/* This object's namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal @@ -162,12 +162,12 @@ typedef struct Object { /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ - struct Class *classPtr; /* All classes have this non-NULL; it points - * to the class structure. Everything else has - * this NULL. */ + struct Class *classPtr; /* This is non-NULL for all classes, and NULL + * for everything else. It points to the class + * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak - * references; this mechanism is there to + * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; int creationEpoch; /* Unique value to make comparisons of objects @@ -323,7 +323,7 @@ typedef struct Foundation { } Foundation; /* - * A call context structure is built when a method is called. They contain the + * A call context structure is built when a method is called. It contains the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. @@ -334,7 +334,7 @@ typedef struct Foundation { struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ - int isFilter; /* Whether this is a filter invokation. */ + int isFilter; /* Whether this is a filter invocation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; diff --git a/tests/oo.test b/tests/oo.test index 8850ea5..8face06 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1482,6 +1482,18 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done test oo-12.1 {OO: filters} { oo::class create Aclass -- cgit v0.12 From a7c17bc224dea481e831d6da7f924d8e064a5506 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 12:14:38 +0000 Subject: Fix bug 3c32a3f8bd, segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one of its instances. --- generic/tclOO.c | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index bae784a..8a852ff 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1006,8 +1006,18 @@ ReleaseClassContents( } for(j=0 ; jmixins.num ; j++) { Class *mixin = instancePtr->mixins.list[j]; + Class *nextMixin = NULL; if (mixin == clsPtr) { - instancePtr->mixins.list[j] = NULL; + if (j < instancePtr->mixins.num - 1) { + nextMixin = instancePtr->mixins.list[j+1]; + } + if (j == 0) { + instancePtr->mixins.num = 0; + instancePtr->mixins.list = NULL; + } else { + instancePtr->mixins.list[j-1] = nextMixin; + } + instancePtr->mixins.num -= 1; } } if (instancePtr != NULL && !IsRoot(instancePtr)) { @@ -1181,7 +1191,8 @@ ObjectNamespaceDeleted( if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { /* * Namespace deletion must have been triggered by a trace on command - * deletion , meaning that + * deletion , meaning that ObjectRenamedTrace() is eventually going + * to be called . */ deleteAlreadyInProgress = 1; } -- cgit v0.12 From c6eb0cc51d7c4feece753d3536454bf43d7785a3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 12:31:33 +0000 Subject: Unit test for issue 3c32a3f8bd, Segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one of its instances. --- tests/oo.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 8face06..0ae46f8 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1495,6 +1495,24 @@ test oo-11.5 {OO: cleanup} { return done } done +test oo-11.6 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + trace add command obj3 delete [list obj3 dying] + rename obj2 {} + + # No segmentation fault + return done +} done + test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject -- cgit v0.12 From 40e9ab2e654ef81e10d38260c765346aca33077e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 14 Feb 2018 12:52:06 +0000 Subject: More tests for bignum modules regressions. --- tests/expr.test | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/tests/expr.test b/tests/expr.test index c49a9ff..fd11870 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -5841,6 +5841,12 @@ test expr-32.6 {Bug 1585704} { test expr-32.7 {bignum regression} { expr {0%(1<<63)} } 0 +test expr-32.8 {bignum regression} { + expr {0%-(1<<63)} +} 0 +test expr-32.9 {bignum regression} { + expr {0%-(1+(1<<63))} +} 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 -- cgit v0.12 From 7d25e385a2b2816630b16fdfe293c0fddd5e33fe Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 13:00:28 +0000 Subject: Modify test oo-11.6 to not use [self], which is not avaiable until 8.7. --- tests/oo.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 0ae46f8..3829763 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1500,10 +1500,10 @@ test oo-11.6 { instances } { oo::class create obj1 - ::oo::define obj1 {self mixin [self]} + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} ::oo::copy obj1 obj2 - ::oo::objdefine obj2 {mixin [self]} + ::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]} ::oo::copy obj2 obj3 trace add command obj3 delete [list obj3 dying] @@ -3868,5 +3868,5 @@ cleanupTests return # Local Variables: -# mode: tcl +# MODE: Tcl # End: -- cgit v0.12 From 1e854210b71ecee27e16ad922e8f4bb312605114 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 13:37:27 +0000 Subject: Rewrite documentation in comments for brevity and clarity. --- generic/tclListObj.c | 593 +++++++++++++++++++++++++-------------------------- generic/tclObj.c | 31 +-- generic/tclUtil.c | 37 ++-- 3 files changed, 325 insertions(+), 336 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 3a1555d..0d37821 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -55,20 +55,22 @@ const Tcl_ObjType tclListType = { * * NewListIntRep -- * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. Flag value "p" indicates + * Creates a 'List' structure with space for 'objc' elements. 'objc' must + * be > 0. If 'objv' is not NULL, The list is initialized with first + * 'objc' values in that array. Otherwise the list is initialized to have + * 0 elements, with space to add 'objc' more. Flag value 'p' indicates * how to behave on failure. * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then if p=0, NULL is returned and otherwise the - * routine panics. + * Value * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * A new 'List' structure with refCount 0. If some failure + * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' + * is called if it is not. + * + * Effect + * + * The refCount of each value in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -132,22 +134,10 @@ NewListIntRep( /* *---------------------------------------------------------------------- * - * AttemptNewList -- - * - * Creates a list internal rep with space for objc elements. objc - * must be > 0. If objv!=NULL, initializes with the first objc values - * in that array. If objv==NULL, initalize list internal rep to have - * 0 elements, with space to add objc more. - * - * Results: - * A new List struct with refCount 0 is returned. If some failure - * prevents this then NULL is returned, and an error message is left - * in the interp result, unless interp is NULL. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * AttemptNewList -- * + * Like NewListIntRep, but additionally sets an error message on failure. + * *---------------------------------------------------------------------- */ @@ -179,23 +169,20 @@ AttemptNewList( * * Tcl_NewListObj -- * - * This function is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new list object from an - * (objc,objv) array: that is, each of the objc elements of the array - * referenced by objv is inserted as an element into a new Tcl object. + * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is + * defined, 'Tcl_DbNewListObj' is called instead. * - * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewListObj. + * Value * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The resulting new list object has ref count 0. + * A new list 'Tcl_Obj' to which is appended values from 'objv', or if + * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no + * elements. The string representation of the new 'Tcl_Obj' is set to + * NULL. The refCount of the list is 0. * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Effect + * + * The refCount of each elements in 'objv' is incremented as it is added + * to the list. * *---------------------------------------------------------------------- */ @@ -246,28 +233,14 @@ Tcl_NewListObj( /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- - * - * This function is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same - * as the Tcl_NewListObj function above except that it calls - * Tcl_DbCkalloc directly with the file name and line number from its - * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when - * reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this function just returns the - * result of calling Tcl_NewListObj. - * - * Results: - * A new list object is returned that is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The new list object has ref count 0. - * - * Side effects: - * The ref counts of the elements in objv are incremented since the - * resulting list now refers to them. + * Tcl_DbNewListObj -- + * + * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the + * file name and line number from its caller. This simplifies debugging + * since the [memory active] command will report the correct file + * name and line number when reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. * *---------------------------------------------------------------------- */ @@ -328,19 +301,8 @@ Tcl_DbNewListObj( * * Tcl_SetListObj -- * - * Modify an object to be a list containing each of the objc elements of - * the object array referenced by objv. - * - * Results: - * None. - * - * Side effects: - * The object is made a list object and is initialized from the object - * pointers in objv. If objc is less than or equal to zero, an empty - * object is returned. The new object's string representation is left - * NULL. The ref counts of the elements in objv are incremented since the - * list now refers to them. The object's old string and internal - * representations are freed and its type is set NULL. + * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of + * creating a new one. * *---------------------------------------------------------------------- */ @@ -384,18 +346,20 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Makes a "pure list" copy of a list 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. + * Creates a new 'Tcl_Obj' which is a pure copy of a list 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. + * + * Value * - * Results: - * Normally returns a pointer to a new Tcl_Obj, that contains the same - * list value as *listPtr does. The returned Tcl_Obj has a refCount of - * zero. If *listPtr does not hold a list, NULL is returned, and if - * interp is non-NULL, an error message is recorded there. + * The address of the new 'Tcl_Obj' which shares its internal + * representation with 'listPtr', and whose refCount is 0. If 'listPtr' + * is not actually a list, the value is NULL, and an error message is left + * in 'interp' if it is not NULL. * - * Side effects: - * None. + * Effect + * + * 'listPtr' is converted to a list if it isn't one already. * *---------------------------------------------------------------------- */ @@ -425,27 +389,30 @@ TclListObjCopy( * * Tcl_ListObjGetElements -- * - * This function returns an (objc,objv) array of the elements in a list - * object. + * Retreive the elements in a list 'Tcl_Obj'. + * + * Value + * + * TCL_OK + * + * A count of list elements is stored, 'objcPtr', And a pointer to the + * array of elements in the list is stored in 'objvPtr'. * - * 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 a 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 elements accessible via 'objvPtr' should be treated as readonly + * and the refCount for each object is _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. * - * 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. + * TCL_ERROR * - * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * 'listPtr' is converted to a list object if it isn't one already. * *---------------------------------------------------------------------- */ @@ -486,20 +453,27 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * This function appends the elements in the list value referenced by - * elemListPtr to the list value referenced by listPtr. + * Appends the elements of elemListPtr to those of listPtr. + * + * Value + * + * TCL_OK + * + * Success. * - * Results: - * The return value is normally TCL_OK. If listPtr or elemListPtr do not - * refer to list values, TCL_ERROR is returned and an error message is - * left in the interpreter's result if interp is not NULL. + * TCL_ERROR * - * Side effects: - * The reference counts of the elements in elemListPtr are incremented - * since the list now refers to them. listPtr and elemListPtr are - * converted, if necessary, to list objects. Also, appending the new - * elements may cause listObj's array of element pointers to grow. - * listPtr's old string representation, if any, is invalidated. + * 'listPtr' or 'elemListPtr' are not valid lists. An error + * message is left in the interpreter's result if 'interp' is not NULL. + * + * Effect + * + * The reference count of each element of 'elemListPtr' as it is added to + * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' + * if they are not already. Appending the new elements may cause the + * array of element pointers in 'listObj' to grow. If any objects are + * appended to 'listPtr'. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -538,24 +512,27 @@ Tcl_ListObjAppendList( * * Tcl_ListObjAppendElement -- * - * This function is a special purpose version of Tcl_ListObjAppendList: - * it appends a single object referenced by objPtr to the list object - * referenced by listPtr. If listPtr is not already a list object, an - * attempt will be made to convert it to one. - * - * Results: - * The return value is normally TCL_OK; in this case objPtr is added to - * the end of listPtr's list. If listPtr does not refer to a 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. - * - * Side effects: - * The ref count of objPtr is incremented since the list now refers to - * it. listPtr will be converted, if necessary, to a list object. Also, - * appending the new element may cause listObj's array of element - * pointers to grow. listPtr's old string representation, if any, is - * invalidated. + * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. + * + * Value + * + * TCL_OK + * + * 'objPtr' is appended to the elements of 'listPtr'. + * + * TCL_ERROR + * + * listPtr does not refer to a list object and the object can not be + * converted to one. An error message will be left in the + * interpreter's result if interp is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. + * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. + * Appending the new element may cause the the array of element pointers + * in 'listObj' to grow. Any preexisting string representation of + * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ @@ -706,23 +683,27 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * This function returns a pointer to the index'th object from the list - * referenced by listPtr. The first element has index 0. If index is - * negative or greater than or equal to the number of elements in the - * list, a NULL is returned. If listPtr is not a list object, an attempt - * will be made to convert it to a list. + * Retrieve a pointer to the element of 'listPtr' at 'index'. The index + * of the first element is 0. + * + * Value + * + * TCL_OK * - * Results: - * The return value is normally TCL_OK; in this case objPtrPtr is set to - * the Tcl_Obj pointer for the index'th list element or NULL if index is - * out of range. This object should be treated as readonly and its ref - * count is _not_ incremented; the caller must do that if it holds on to - * the reference. If listPtr does not refer to a list and can't be - * converted to one, TCL_ERROR is returned and an error message is left - * in the interpreter's result if interp is not NULL. + * A pointer to the element at 'index' is stored in 'objPtrPtr'. If + * 'index' is out of range, NULL is stored in 'objPtrPtr'. This + * object should be treated as readonly and its 'refCount' is _not_ + * incremented. The caller must do that if it holds on to the + * reference. + * + * TCL_ERROR * - * Side effects: - * listPtr will be converted, if necessary, to a list object. + * 'listPtr' is not a valid list. An an error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ @@ -764,19 +745,20 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * This function returns the number of elements in a list object. If the - * object is not already a list object, an attempt will be made to - * convert it to one. + * Retrieve the number of elements in a list. + * + * Value + * + * TCL_OK + * + * A count of list elements is stored at the address provided by + * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is + * converted. * - * Results: - * The return value is normally TCL_OK; in this case *intPtr will be set - * to the integer count of list elements. If listPtr does not refer to a - * 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. + * TCL_ERROR * - * Side effects: - * The possible conversion of the argument object to a list object. + * 'listPtr' is not a valid list. An error message will be left in + * the interpreter's result if 'interp' is not NULL. * *---------------------------------------------------------------------- */ @@ -812,35 +794,36 @@ Tcl_ListObjLength( * * Tcl_ListObjReplace -- * - * This function replaces zero or more elements of the list referenced by - * listPtr with the objects from an (objc,objv) array. The objc elements - * of the array referenced by objv replace the count elements in listPtr - * starting at first. - * - * If the argument first is zero or negative, it refers to the first - * element. If first is greater than or equal to the number of elements - * in the list, then no elements are deleted; the new elements are - * appended to the list. Count gives the number of elements to replace. - * If count is zero or negative then no elements are deleted; the new - * elements are simply inserted before first. - * - * The argument objv refers to an array of objc pointers to the new - * elements to be added to listPtr in place of those that were deleted. - * If objv is NULL, no new elements are added. If listPtr is not a list - * object, an attempt will be made to convert it to one. - * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and 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. - * - * Side effects: - * The ref counts of the objc elements in objv are incremented since the - * resulting list now refers to them. Similarly, the ref counts for - * replaced objects are decremented. listPtr is converted, if necessary, - * to a list object. listPtr's old string representation, if any, is - * freed. + * Replace values in a list. + * + * If 'first' is zero or negative, it refers to the first element. If + * 'first' outside the range of elements in the list, no elements are + * deleted. + * + * If 'count' is zero or negative no elements are deleted, and any new + * elements are inserted at the beginning of the list. + * + * Value + * + * TCL_OK + * + * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' + * starting at 'first'. If 'objc' 0, no new elements are added. + * + * TCL_ERROR + * + * 'listPtr' is not a valid list. An error message is left in the + * interpreter's result if 'interp' is not NULL. + * + * Effect + * + * If 'listPtr' is not of type 'tclListType', it is converted if possible. + * + * The 'refCount' of each element appended to the list is incremented. + * Similarly, the 'refCount' for each replaced element is decremented. + * + * If 'listPtr' is modified, any previous string representation is + * invalidated. * *---------------------------------------------------------------------- */ @@ -1098,22 +1081,19 @@ Tcl_ListObjReplace( * * TclLindexList -- * - * This procedure handles the 'lindex' command when objc==3. + * Implements the 'lindex' command when objc==3. * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures + * the argument format into required form while taking care to manage + * shimmering so as to tend to keep the most useful intreps + * and/or avoid the most expensive conversions. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLindexFlat. All it does is reconfigure the argument format into the - * form required by TclLindexFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or - * avoid the most expensive conversions. + * A pointer to the specified element, with its 'refCount' incremented, or + * NULL if an error occurred. + * + * Notes * *---------------------------------------------------------------------- */ @@ -1185,25 +1165,20 @@ TclLindexList( /* *---------------------------------------------------------------------- * - * TclLindexFlat -- + * TclLindexFlat -- + * + * The core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * This procedure is the core of the 'lindex' command, with all index - * arguments presented as a flat list. + * Value * - * Results: - * Returns a pointer to the object extracted, or NULL if an error - * occurred. The returned object already includes one reference count for - * the pointer returned. + * A pointer to the object extracted, with its 'refCount' incremented, or + * NULL if an error occurred. Thus, the calling code will usually do + * something like: * - * Side effects: - * None. + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * - * Notes: - * The reference count of the returned object includes one reference - * corresponding to the pointer returned. Thus, the calling code will - * usually do something like: - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1279,23 +1254,16 @@ TclLindexFlat( * * TclLsetList -- * - * Core of the 'lset' command when objc == 4. Objv[2] may be either a + * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * - * Results: - * Returns the new value of the list variable, or NULL if there was an - * error. The returned object includes one reference count for the - * pointer returned. + * Implemented entirely as a wrapper around 'TclLindexFlat', as described + * for 'TclLindexList'. * - * Side effects: - * None. + * Value * - * Notes: - * This procedure is implemented entirely as a wrapper around - * TclLsetFlat. All it does is reconfigure the argument format into the - * form required by TclLsetFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or - * avoid the most expensive conversions. + * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if + * there was an error. * *---------------------------------------------------------------------- */ @@ -1357,36 +1325,39 @@ TclLsetList( * * Core engine of the 'lset' command. * - * Results: - * Returns the new value of the list variable, or NULL if an error - * occurred. The returned object includes one reference count for the - * pointer returned. - * - * Side effects: - * On entry, the reference count of the variable value does not reflect - * any references held on the stack. The first action of this function is - * to determine whether the object is shared, and to duplicate it if it - * is. The reference count of the duplicate is incremented. At this - * point, the reference count will be 1 for either case, so that the - * object will appear to be unshared. - * - * If an error occurs, and the object has been duplicated, the reference - * count on the duplicate is decremented so that it is now 0: this - * dismisses any memory that was allocated by this function. - * - * If no error occurs, the reference count of the original object is - * incremented if the object has not been duplicated, and nothing is done - * to a reference count of the duplicate. Now the reference count of an - * unduplicated object is 2 (the returned pointer, plus the one stored in - * the variable). The reference count of a duplicate object is 1, - * reflecting that the returned pointer is the only active reference. The - * caller is expected to store the returned value back in the variable - * and decrement its reference count. (INST_STORE_* does exactly this.) - * - * Surgery is performed on the unshared list value to produce the result. - * TclLsetFlat maintains a linked list of Tcl_Obj's whose string + * Value + * + * The resulting list + * + * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not + * duplicated, its 'refCount' is incremented. The reference count of + * an unduplicated object is therefore 2 (one for the returned pointer + * and one for the variable that holds it). The reference count of a + * duplicate object is 1, reflecting that result is the only active + * reference. The caller is expected to store the result in the + * variable and decrement its reference count. (INST_STORE_* does + * exactly this.) + * + * NULL + * + * An error occurred. If 'listPtr' was duplicated, the reference + * count on the duplicate is decremented so that it is 0, causing any + * memory allocated by this function to be freed. + * + * + * Effect + * + * On entry, the reference count of 'listPtr' does not reflect any + * references held on the stack. The first action of this function is to + * determine whether 'listPtr' is shared and to create a duplicate + * unshared copy if it is. The reference count of the duplicate is + * incremented. At this point, the reference count is 1 in either case so + * that the object is considered unshared. + * + * The unshared list is altered directly to produce the result. + * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to TclLsetFlat, the + * two-pointer internal representation. On entry to 'TclLsetFlat', the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * @@ -1601,26 +1572,38 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value + * Set a single element of a list to a specified value. * - * Results: - * The return value is normally TCL_OK. If listPtr does not refer to a - * list object and cannot be converted to one, TCL_ERROR is returned and - * an error message will be left in the interpreter result if interp is - * not NULL. Similarly, if index designates an element outside the range - * [0..listLength-1], where listLength is the count of elements in the - * list object designated by listPtr, TCL_ERROR is returned and an error - * message is left in the interpreter result. + * It is the caller's responsibility to invalidate the string + * representation of the 'listPtr'. * - * Side effects: - * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts - * to convert it to a list with a non-shared internal rep. Decrements the - * ref count of the object at the specified index within the list, - * replaces with the object designated by valuePtr, and increments the - * ref count of the replacement object. + * Value + * + * TCL_OK + * + * Success. + * + * TCL_ERROR + * + * 'listPtr' does not refer to a list object and cannot be converted + * to one. An error message will be left in the interpreter result if + * interp is not NULL. + * + * TCL_ERROR + * + * An index designates an element outside the range [0..listLength-1], + * where 'listLength' is the count of elements in the list object + * designated by 'listPtr'. An error message is left in the + * interpreter result. + * + * Effect + * + * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If + * 'listPtr' is not already of type 'tclListType', it is converted and the + * internal representation is unshared. The 'refCount' of the element at + * 'index' is decremented and replaced in the list with the 'valuePtr', + * whose 'refCount' in turn is incremented. * - * It is the caller's responsibility to invalidate the string - * representation of the object. * *---------------------------------------------------------------------- */ @@ -1738,16 +1721,14 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with a list object's internal - * representation. + * Deallocate the storage associated with the internal representation of a + * a list object. * - * Results: - * None. + * Effect * - * Side effects: - * Frees listPtr's List* internal representation and sets listPtr's - * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts of all - * element objects, which may free them. + * The storage for the internal 'List' pointer of 'listPtr' is freed, the + * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' + * of each element of the list is decremented. * *---------------------------------------------------------------------- */ @@ -1776,14 +1757,12 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list Tcl_Obj to share the + * Initialize the internal representation of a list 'Tcl_Obj' to share the * internal representation of an existing list object. * - * Results: - * None. + * Effect * - * Side effects: - * The reference count of the List internal rep is incremented. + * The 'refCount' of the List internal rep is incremented. * *---------------------------------------------------------------------- */ @@ -1803,16 +1782,20 @@ DupListInternalRep( * * SetListFromAny -- * - * Attempt to generate a list internal form for the Tcl object "objPtr". + * Convert any object to a list. + * + * Value * - * Results: - * The return value is TCL_OK or TCL_ERROR. If an error occurs during - * conversion, an error message is left in the interpreter's result - * unless "interp" is NULL. + * TCL_OK + * + * Success. The internal representation of 'objPtr' is set, and the type + * of 'objPtr' is 'tclListType'. + * + * TCL_ERROR + * + * An error occured during conversion. An error message is left in the + * interpreter's result if 'interp' is not NULL. * - * Side effects: - * If no error occurs, a list is stored as "objPtr"s internal - * representation. * *---------------------------------------------------------------------- */ @@ -1937,18 +1920,16 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. Note: This - * function does not invalidate an existing old string rep so storage - * will be lost if this has not already been done. + * Update the string representation for a list object. + * + * Any previously-exising string representation is not invalidated, so + * storage is lost if this has not been taken care of. * - * Results: - * None. + * Effect * - * 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. + * The string representation of 'listPtr' is set to the resulting string. + * This string will be empty if the list has no elements. It is assumed + * that the list internal representation is not NULL. * *---------------------------------------------------------------------- */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 3bf5b8e..a75ecdd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2467,23 +2467,26 @@ Tcl_SetIntObj( * * Tcl_GetIntFromObj -- * - * Attempt to return an int from the Tcl object "objPtr". If the object - * is not already an int, an attempt will be made to convert it to one. + * Retrieve the integer value of 'objPtr'. * - * Integer and long integer objects share the same "integer" type - * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by an - * int. + * Value * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object can not be - * represented by an int, an error message is left in the interpreter's - * result unless "interp" is NULL. + * TCL_OK * - * Side effects: - * If the object is not already an int, the conversion will free any old - * internal representation. + * Success. + * + * TCL_ERROR + * + * An error occurred during conversion or the integral value can not + * be represented as an integer (it might be too large). An error + * message is left in the interpreter's result if 'interp' is not + * NULL. + * + * Effect + * + * 'objPtr' is converted to an integer if necessary if it is not one + * already. The conversion frees any previously-existing internal + * representation. * *---------------------------------------------------------------------- */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index feee9c5..396f992 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3530,22 +3530,27 @@ TclFormatInt( * * TclGetIntForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. - * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. - * - * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. - * + * Provides an integer corresponding to the list index held in a Tcl + * object. The string value 'objPtr' is expected have the format + * integer([+-]integer)? or end([+-]integer)?. + * + * Value + * TCL_OK + * + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. + * + * TCL_ERROR + * + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. + * + * Effect + * + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. + * *---------------------------------------------------------------------- */ -- cgit v0.12 From 5d5bd4cd5514c5e0361bb9762e8e560384d4e8a6 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 14 Feb 2018 14:05:04 +0000 Subject: Modify TclCreateProc to handle arbitrary argument names, not just ASCII. --- generic/tclExecute.c | 4 +-- generic/tclInt.h | 2 +- generic/tclProc.c | 96 +++++++++++++++++++++++----------------------------- 3 files changed, 45 insertions(+), 57 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 761a23e..93ed50b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1333,12 +1333,12 @@ TclStackAlloc( int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } diff --git a/generic/tclInt.h b/generic/tclInt.h index ac67ebd..71a55cc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4433,7 +4433,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index 5c68e17..9940f9d 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -393,13 +393,13 @@ TclCreateProc( Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { @@ -436,6 +436,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -473,12 +474,9 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -501,28 +499,28 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { int fieldCount, nameLength, valueLength; - const char **fieldValues; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -530,9 +528,10 @@ TclCreateProc( goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } @@ -541,33 +540,29 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { @@ -583,7 +578,7 @@ TclCreateProc( */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) @@ -591,7 +586,6 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -607,12 +601,13 @@ TclCreateProc( &tmpLength); if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -632,7 +627,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -640,19 +635,18 @@ TclCreateProc( procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -660,12 +654,9 @@ TclCreateProc( localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: @@ -686,9 +677,6 @@ TclCreateProc( } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } -- cgit v0.12