Attachment "align_string_is_and_tcl_mathfunc.txt" to
ticket [2581150fff]
added by
decosterjos
2009-02-13 00:02:55.
? align_string_is_and_tcl_mathfunc.txt
? li.tcl
? string_is_bignum.txt
? string_is_bignum_tip.txt
? string_is_entier.txt
? string_is_entier_tip.txt
? unix/dltest.marker
? unix/pkgs
? unix/t.tcl
Index: doc/mathfunc.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/mathfunc.n,v
retrieving revision 1.22
diff -w -u -r1.22 mathfunc.n
--- doc/mathfunc.n 29 Jun 2008 22:28:24 -0000 1.22
+++ doc/mathfunc.n 12 Feb 2009 17:00:13 -0000
@@ -55,6 +55,8 @@
.br
\fB::tcl::mathfunc::log10\fR \fIarg\fR
.br
+\fB::tcl::mathfunc::long\fR \fIarg\fR
+.br
\fB::tcl::mathfunc::max\fR \fIarg\fR ?\fIarg\fR ...?
.br
\fB::tcl::mathfunc::min\fR \fIarg\fR ?\fIarg\fR ...?
@@ -99,10 +101,10 @@
\fBatan2\fR \fBbool\fR \fBceil\fR \fBcos\fR
\fBcosh\fR \fBdouble\fR \fBentier\fR \fBexp\fR
\fBfloor\fR \fBfmod\fR \fBhypot\fR \fBint\fR
-\fBisqrt\fR \fBlog\fR \fBlog10\fR \fBmax\fR
-\fBmin\fR \fBpow\fR \fBrand\fR \fBround\fR
-\fBsin\fR \fBsinh\fR \fBsqrt\fR \fBsrand\fR
-\fBtan\fR \fBtanh\fR \fBwide\fR
+\fBisqrt\fR \fBlog\fR \fBlog10\fR \fBlong\fR
+\fBmax\fR \fBmin\fR \fBpow\fR \fBrand\fR
+\fBround\fR \fBsin\fR \fBsinh\fR \fBsqrt\fR
+\fBsrand\fR \fBtan\fR \fBtanh\fR \fBwide\fR
.DE
.PP
In addition to these predefined functions, applications may
@@ -225,6 +227,12 @@
Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a
positive value.
.TP
+\fBlong \fIarg\fR
+.
+The argument may be any numeric value. The integer part of \fIarg\fR
+is determined, and then the low order bits of that integer value up
+to the machine long word size are returned as an integer value.
+.TP
\fBmax \fIarg\fB \fI...\fR
.
Accepts one or more numeric arguments. Returns the one argument
Index: doc/string.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/string.n,v
retrieving revision 1.45
diff -w -u -r1.45 string.n
--- doc/string.n 17 Oct 2008 10:22:25 -0000 1.45
+++ doc/string.n 12 Feb 2009 17:00:13 -0000
@@ -147,6 +147,9 @@
.IP \fBascii\fR 12
Any character with a value less than \eu0080 (those that are in the
7\-bit ascii range).
+.IP \fBentier\fR 12
+Any of the valid string formats for an integer value in Tcl, with optional
+surrounding whitespace.
.IP \fBboolean\fR 12
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 12
@@ -173,6 +176,10 @@
will contain the index of the
.QW element
where the list parsing fails, or \-1 if this cannot be determined.
+.IP \fBlong\fR 12
+Any of the valid string formats for a long integer value in Tcl,
+with optional surrounding whitespace. In case of under/overflow in
+the value, 0 is returned and the \fIvarname\fR will contain \-1.
.IP \fBlower\fR 12
Any Unicode lower case alphabet character.
.IP \fBprint\fR 12
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.385
diff -w -u -r1.385 tclBasic.c
--- generic/tclBasic.c 3 Feb 2009 23:34:33 -0000 1.385
+++ generic/tclBasic.c 12 Feb 2009 17:00:18 -0000
@@ -88,6 +88,8 @@
int argc, Tcl_Obj *const *objv);
static int ExprIsqrtFunc(ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *const *objv);
+static int ExprLongFunc(ClientData clientData, Tcl_Interp *interp,
+ int argc, Tcl_Obj *const *objv);
static int ExprRandFunc(ClientData clientData, Tcl_Interp *interp,
int argc, Tcl_Obj *const *objv);
static int ExprRoundFunc(ClientData clientData, Tcl_Interp *interp,
@@ -283,6 +285,7 @@
{ "isqrt", ExprIsqrtFunc, NULL },
{ "log", ExprUnaryFunc, (ClientData) log },
{ "log10", ExprUnaryFunc, (ClientData) log10 },
+ { "long", ExprLongFunc, NULL },
{ "pow", ExprBinaryFunc, (ClientData) pow },
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
@@ -7357,13 +7360,45 @@
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
+ int iResult;
+ Tcl_Obj *objPtr;
+ if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ objPtr = Tcl_GetObjResult(interp);
+ if (Tcl_GetIntFromObj(NULL, objPtr, &iResult) != TCL_OK) {
+ /*
+ * Truncate the bignum; keep only bits in long range.
+ */
+
+ mp_int big;
+
+ Tcl_GetBignumFromObj(NULL, objPtr, &big);
+ mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
+ objPtr = Tcl_NewBignumObj(&big);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetIntFromObj(NULL, objPtr, &iResult);
+ Tcl_DecrRefCount(objPtr);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(iResult));
+ return TCL_OK;
+}
+
+static int
+ExprLongFunc(
+ ClientData clientData, /* Ignored. */
+ Tcl_Interp *interp, /* The interpreter in which to execute the
+ * function. */
+ int objc, /* Actual parameter count. */
+ Tcl_Obj *const *objv) /* Actual parameter vector. */
+{
long iResult;
Tcl_Obj *objPtr;
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
- if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
+ if (Tcl_GetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
/*
* Truncate the bignum; keep only bits in long range.
*/
Index: generic/tclCmdMZ.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdMZ.c,v
retrieving revision 1.179
diff -w -u -r1.179 tclCmdMZ.c
--- generic/tclCmdMZ.c 5 Feb 2009 22:12:44 -0000 1.179
+++ generic/tclCmdMZ.c 12 Feb 2009 17:00:19 -0000
@@ -19,6 +19,7 @@
*/
#include "tclInt.h"
+#include "tommath.h"
#include "tclRegexp.h"
static int UniCharIsAscii(int character);
@@ -1406,6 +1407,8 @@
int i, failat = 0, result = 1, strict = 0, index, length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
+ long l;
+ mp_int big;
static const char *const isOptions[] = {
"alnum", "alpha", "ascii", "control",
@@ -1413,14 +1416,15 @@
"graph", "integer", "list", "lower",
"print", "punct", "space", "true",
"upper", "wideinteger", "wordchar", "xdigit",
- NULL
+ "entier", "long", NULL
};
enum isOptions {
STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER,
STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE,
- STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT
+ STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT,
+ STR_IS_ENTIER,STR_IS_LONG
};
if (objc < 3 || objc > 6) {
@@ -1531,6 +1535,16 @@
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
+ case STR_IS_ENTIER:
+ if (TCL_OK == Tcl_GetBignumFromObj(NULL, objPtr, &big)) {
+ break;
+ }
+ goto failedIntParse;
+ case STR_IS_LONG:
+ if (TCL_OK == Tcl_GetLongFromObj(NULL, objPtr, &l)) {
+ break;
+ }
+ goto failedIntParse;
case STR_IS_INT:
if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) {
break;
Index: tests/expr.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/expr.test,v
retrieving revision 1.74
diff -w -u -r1.74 expr.test
--- tests/expr.test 6 Jan 2009 15:24:49 -0000 1.74
+++ tests/expr.test 12 Feb 2009 17:00:26 -0000
@@ -6821,6 +6821,34 @@
expr {-0x8000000000000001 >> 0x8000000000000000}
} -1
+test expr-49.1 {long} {
+ expr long(0)
+} 0
+test expr-49.2 {long} {
+ expr long(0.5)
+} 0
+test expr-49.3 {long} {
+ expr long(1.0)
+} 1
+test expr-49.4 {long} {
+ expr long(1.5)
+} 1
+test expr-49.5 {long} {
+ expr long(2.0)
+} 2
+test expr-49.6 {long} {
+ expr long(1e+4)
+} 10000
+test expr-49.7 {long} {
+ list [catch {expr long(Inf)} result] $result
+} {1 {integer value too large to represent}}
+test expr-49.8 {long} ieeeFloatingPoint {
+ list [catch {expr {long($ieeeValues(NaN))}} result] $result
+} {1 {floating point value is Not a Number}}
+test expr-49.9 {long} ieeeFloatingPoint {
+ list [catch {expr {long($ieeeValues(-NaN))}} result] $result
+} {1 {floating point value is Not a Number}}
+
# cleanup
if {[info exists a]} {
unset a
Index: tests/info.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/info.test,v
retrieving revision 1.63
diff -w -u -r1.63 info.test
--- tests/info.test 14 Oct 2008 16:48:11 -0000 1.63
+++ tests/info.test 12 Feb 2009 17:00:27 -0000
@@ -653,7 +653,7 @@
namespace delete x
} -result {}
-set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide}
+set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 long max min pow rand round sin sinh sqrt srand tan tanh wide}
# Check whether the extra testing functions are defined...
if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} {
set functions "T1 T2 T3 $functions" ;# A lazy way of prepending!
Index: tests/string.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/string.test,v
retrieving revision 1.76
diff -w -u -r1.76 string.test
--- tests/string.test 14 Oct 2008 18:49:47 -0000 1.76
+++ tests/string.test 12 Feb 2009 17:00:28 -0000
@@ -296,6 +296,22 @@
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
+ while {int($int) > 0} { set int [expr {int(1) << [incr exp]}] }
+ return [expr {$int-1}]
+}
+proc largest_long {} {
+ # This will give us what the largest valid long on this machine is,
+ # so we can test for overflow properly below on >32 bit systems
+ set int 1
+ set exp 7; # assume we get at least 8 bits
+ while {long($int) > 0} { set int [expr {long(1) << [incr exp]}] }
+ return [expr {$int-1}]
+}
+proc largest_wide {} {
+ # This will give us what the largest valid wide on this machine is,
+ # so we can test for overflow properly below on >32 bit systems
+ set int 1
+ set exp 7; # assume we get at least 8 bits
while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] }
return [expr {$int-1}]
}
@@ -314,10 +330,10 @@
} {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
test string-6.5 {string is, class check} {
list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, xdigit, entier, or long}}
test string-6.6 {string is, ambiguous class} {
list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, xdigit, entier, or long}}
test string-6.7 {string is alpha, all ok} {
string is alpha -strict -failindex var abc
} 1
@@ -642,7 +658,7 @@
list [string is wideinteger -fail var 123abc] $var
} {0 3}
test string-6.102 {string is wideinteger, false on overflow} {
- list [string is wideinteger -fail var +[largest_int]0] $var
+ list [string is wideinteger -fail var +[largest_wide]0] $var
} {0 -1}
test string-6.103 {string is wideinteger, false} {
list [string is wideinteger -fail var [expr double(1)]] $var
@@ -676,8 +692,118 @@
test string-6.109 {string is double, Bug 1360532} {
string is double 1\u00a0
} 0
+test string-6.110 {string is entier, true} {
+ string is entier +1234567890
+} 1
+test string-6.111 {string is entier, true on type} {
+ string is entier [expr wide(50.0)]
+} 1
+test string-6.112 {string is entier, true} {
+ string is entier [list -10]
+} 1
+test string-6.113 {string is entier, true as hex} {
+ string is entier 0xabcdef
+} 1
+test string-6.114 {string is entier, true as octal} {
+ string is entier 0123456
+} 1
+test string-6.115 {string is entier, true with whitespace} {
+ string is entier " \n1234\v"
+} 1
+test string-6.116 {string is entier, false} {
+ list [string is entier -fail var 123abc] $var
+} {0 3}
+test string-6.117 {string is entier, false} {
+ list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var
+} {0 84}
+test string-6.118 {string is entier, false} {
+ list [string is entier -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.119 {string is entier, false} {
+ list [string is entier -fail var " "] $var
+} {0 0}
+test string-6.120 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.121.1 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.122 {string is entier, false on bad hex} {
+ list [string is entier -fail var 0X345XYZ] $var
+} {0 5}
+test string-6.123 {string is entier, bad integers} {
+ # SF bug #634856
+ set result ""
+ set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
+ foreach num $numbers {
+ lappend result [string is entier -strict $num]
+ }
+ set result
+} {1 1 0 0 0 1 0 0}
+test string-6.124 {string is entier, true} {
+ string is entier +1234567890123456789012345678901234567890
+} 1
+test string-6.125 {string is entier, true} {
+ string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]
+} 1
+test string-6.126 {string is entier, true as hex} {
+ string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef
+} 1
+test string-6.127 {string is entier, true as octal} {
+ string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456
+} 1
+test string-6.128 {string is entier, true with whitespace} {
+ string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"
+} 1
+test string-6.129 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.129.1 {string is entier, false on bad octal} {
+ list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.130 {string is entier, false on bad hex} {
+ list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var
+} {0 88}
+test string-6.131 {string is long, true} {
+ string is long +1234567890
+} 1
+test string-6.132 {string is long, true on type} {
+ string is long [expr long(50.0)]
+} 1
+test string-6.133 {string is long, true} {
+ string is long [list -10]
+} 1
+test string-6.134 {string is long, true as hex} {
+ string is long 0xabcdef
+} 1
+test string-6.135 {string is long, true as octal} {
+ string is long 012345
+} 1
+test string-6.136 {string is long, true with whitespace} {
+ string is long " \n1234\v"
+} 1
+test string-6.137 {string is long, false} {
+ list [string is long -fail var 123abc] $var
+} {0 3}
+test string-6.138 {string is long, false on overflow} {
+ list [string is long -fail var +[largest_long]0] $var
+} {0 -1}
+test string-6.139 {string is long, false} {
+ list [string is long -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.140 {string is long, false} {
+ list [string is long -fail var " "] $var
+} {0 0}
+test string-6.141 {string is long, false on bad octal} {
+ list [string is long -fail var 0o36963] $var
+} {0 4}
+test string-6.141.1 {string is long, false on bad octal} {
+ list [string is integer -fail var 0o36963] $var
+} {0 4}
catch {rename largest_int {}}
+catch {rename largest_long {}}
+catch {rename largest_wide {}}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
