diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclExecute.c | 33 | ||||
| -rw-r--r-- | tests/expr.test | 73 |
3 files changed, 103 insertions, 11 deletions
@@ -1,3 +1,11 @@ +2005-08-29 Kevin Kenny <kennykb@acm.org> + + * generic/tclBasic.c (ExprMathFunc): Restored "round away from + * tests/expr.test (expr-39.*): zero" behaviour to the + "round" function. Added + test cases for the behavior, including the awkward case of a + number whose fractional part is 1/2-1/2ulp. [Bug 1275043] + 2005-08-25 Donal K. Fellows <donal.k.fellows@man.ac.uk> * generic/tclListObj.c (UpdateStringOfList): Stop uncontrolled and diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 82aaf62..5161b17 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.94.2.13 2005/08/05 19:19:11 kennykb Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.14 2005/08/29 16:37:42 kennykb Exp $ */ #include "tclInt.h" @@ -5462,7 +5462,7 @@ ExprRoundFunc(interp, eePtr, clientData) Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Tcl_Obj *valuePtr, *resPtr; - double d; + double d, f, i; int result; /* @@ -5488,22 +5488,35 @@ ExprRoundFunc(interp, eePtr, clientData) result = TCL_OK; resPtr = valuePtr; } else { + + /* + * Round the number to the nearest integer. I'd like to use round(), + * but it's C99 (or BSD), and not yet universal. + */ + d = valuePtr->internalRep.doubleValue; + f = modf(d, &i); if (d < 0.0) { - if (d <= Tcl_WideAsDouble(LLONG_MIN)-0.5) { + if (f <= -0.5) { + i += -1.0; + } + if (i <= Tcl_WideAsDouble(LLONG_MIN)) { goto tooLarge; - } else if (d <= (((double) (long) LONG_MIN) - 0.5)) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d - 0.5)); + } else if (d <= (double) LONG_MIN) { + resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); } else { - resPtr = Tcl_NewLongObj((long) (d - 0.5)); + resPtr = Tcl_NewLongObj((long) i); } } else { - if (d >= Tcl_WideAsDouble(LLONG_MAX)+0.5) { + if (f >= 0.5) { + i += 1.0; + } + if (i >= Tcl_WideAsDouble(LLONG_MAX)) { goto tooLarge; - } else if (d >= (((double) LONG_MAX + 0.5))) { - resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(d + 0.5)); + } else if (i >= (double) LONG_MAX) { + resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); } else { - resPtr = Tcl_NewLongObj((long) (d + 0.5)); + resPtr = Tcl_NewLongObj((long) i); } } } diff --git a/tests/expr.test b/tests/expr.test index b3707b8..af9b55c 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr.test,v 1.17.2.5 2005/08/05 19:19:14 kennykb Exp $ +# RCS: @(#) $Id: expr.test,v 1.17.2.6 2005/08/29 16:37:45 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -827,6 +827,77 @@ test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} { expr {abs(int(-2147483648))} } 2147483648 +test expr-39.1 {round() rounds to +-infinity} { + expr round(0.5) +} 1 +test expr-39.2 {round() rounds to +-infinity} { + expr round(1.5) +} 2 +test expr-39.3 {round() rounds to +-infinity} { + expr round(-0.5) +} -1 +test expr-39.4 {round() rounds to +-infinity} { + expr round(-1.5) +} -2 +test expr-39.5 {round() overflow} { + list [catch {expr round(9.2233720368547758e+018)} result] $result +} {1 {integer value too large to represent}} +test expr-39.6 {round() overflow} { + list [catch {expr round(-9.2233720368547758e+018)} result] $result +} {1 {integer value too large to represent}} +test expr-39.7 {round() bad value} { + set x trash + list [catch {expr {round($x)}} result] $result +} {1 {argument to math function didn't have numeric value}} +test expr-39.8 {round() already an integer} { + set x 123456789012 + incr x + expr round($x) +} 123456789013 +test expr-39.9 {round() boundary case - 1/2 - 1 ulp} { + set x 0.25 + set bit 0.125 + while 1 { + set newx [expr {$x + $bit}] + if { $newx == $x || $newx == 0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} 0 +test expr-39.10 {round() boundary case - 1/2 + 1 ulp} { + set x 0.75 + set bit 0.125 + while 1 { + set newx [expr { $x - $bit }] + if { $newx == $x || $newx == 0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} 1 +test expr-39.11 {round() boundary case - -1/2 - 1 ulp} { + set x -0.75 + set bit 0.125 + while 1 { + set newx [expr { $x + $bit }] + if { $newx == $x || $newx == -0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} -1 +test expr-39.10 {round() boundary case - -1/2 + 1 ulp} { + set x -0.25 + set bit 0.125 + while 1 { + set newx [expr { $x - $bit }] + if { $newx == $x || $newx == -0.5 } break + set x $newx + set bit [expr { $bit / 2.0 }] + } + expr {round($x)} +} 0 # cleanup if {[info exists a]} { |