diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/binary.test | 30 | ||||
| -rw-r--r-- | tests/execute.test | 145 | ||||
| -rw-r--r-- | tests/format.test | 19 | ||||
| -rw-r--r-- | tests/get.test | 12 | ||||
| -rw-r--r-- | tests/info.test | 6 | ||||
| -rw-r--r-- | tests/io.test | 34 | ||||
| -rw-r--r-- | tests/link.test | 232 | ||||
| -rw-r--r-- | tests/platform.test | 24 | ||||
| -rw-r--r-- | tests/safe.test | 16 | ||||
| -rw-r--r-- | tests/scan.test | 11 | ||||
| -rw-r--r-- | tests/string.test | 4 |
11 files changed, 354 insertions, 179 deletions
diff --git a/tests/binary.test b/tests/binary.test index 6e8b64a..b01ae3c 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -10,14 +10,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: binary.test,v 1.8 2000/05/26 08:50:34 hobbs Exp $ +# RCS: @(#) $Id: binary.test,v 1.9 2002/02/15 14:28:49 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -test binary-2.1 {DupByteArrayInternalRep} { +test binary-0.1 {DupByteArrayInternalRep} { set hdr [binary format cc 0 0316] set buf hellomatt @@ -1460,6 +1460,32 @@ test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} {} { set result } {bad option "": must be format or scan} +# Wide int (guaranteed at least 64-bit) handling +test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} { + binary format w 7810179016327718216 +} HelloTcl +test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { + binary format W 7810179016327718216 +} lcTolleH + +test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan HelloTcl W x + set x +} 5216694956358656876 +test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan lcTolleH w x + set x +} 5216694956358656876 + +test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} { + binary scan [binary format sws 16450 -1 19521] c* x + set x +} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76} +test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} { + binary scan [binary format sWs 16450 0x7fffffff 19521] c* x + set x +} {66 64 0 0 0 0 127 -1 -1 -1 65 76} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/execute.test b/tests/execute.test index e82ac57..c59292a 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: execute.test,v 1.9 2001/02/23 21:41:01 msofer Exp $ +# RCS: @(#) $Id: execute.test,v 1.10 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -33,6 +33,9 @@ set ::tcltest::testConstraints(testobj) \ && [info commands teststringobj] != {} \ && [info commands testobj] != {}}] +set ::tcltest::testConstraints(longIs32bit) \ + [expr {int(0x80000000) < 0}] + # Tests for the omnibus TclExecuteByteCode function: # INST_DONE not tested @@ -589,6 +592,127 @@ test execute-6.2 {Evaluate an expression in a variable; compile the first time, set res "[a $w]:[a $w]" } {15:15} +test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { + set x 0x100000000 + expr {$x && 1} +} 1 +test execute-7.1 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { + expr {0x100000000 && 1} +} 1 +test execute-7.2 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { + expr {1 && 0x100000000} +} 1 +test execute-7.3 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { + expr {wide(0x100000000) && 1} +} 1 +test execute-7.4 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { + expr {1 && wide(0x100000000)} +} 1 +test execute-7.5 {Wide int handling in INST_EQ} {longIs32bit} { + expr {4 == (wide(1)+wide(3))} +} 1 +test execute-7.6 {Wide int handling in INST_EQ and [incr]} {longIs32bit} { + set x 399999999999 + expr {400000000000 == [incr x]} +} 1 +# wide ints have more bits of precision than doubles, but we convert anyway +test execute-7.7 {Wide int handling in INST_EQ and [incr]} {longIs32bit} { + set x [expr {wide(1)<<62}] + set y [expr {$x+1}] + expr {double($x) == double($y)} +} 1 +test execute-7.8 {Wide int conversions can change sign} {longIs32bit} { + set x 0x80000000 + expr {int($x) < wide($x)} +} 1 +test execute-7.9 {Wide int handling in INST_MOD} {longIs32bit} { + expr {(wide(1)<<60) % ((wide(47)<<45)-1)} +} 316659348800185 +test execute-7.10 {Wide int handling in INST_MOD} {longIs32bit} { + expr {((wide(1)<<60)-1) % 0x400000000} +} 17179869183 +test execute-7.11 {Wide int handling in INST_LSHIFT} {longIs32bit} { + expr wide(42)<<30 +} 45097156608 +test execute-7.12 {Wide int handling in INST_LSHIFT} {longIs32bit} { + expr 12345678901<<3 +} 98765431208 +test execute-7.13 {Wide int handling in INST_RSHIFT} {longIs32bit} { + expr 0x543210febcda9876>>7 +} 47397893236700464 +test execute-7.14 {Wide int handling in INST_RSHIFT} {longIs32bit} { + expr 0x9876543210febcda>>7 +} -58286587177206407 +test execute-7.15 {Wide int handling in INST_BITOR} {longIs32bit} { + expr 0x9876543210febcda | 0x543210febcda9876 +} -2560765885044310786 +test execute-7.16 {Wide int handling in INST_BITXOR} {longIs32bit} { + expr 0x9876543210febcda ^ 0x543210febcda9876 +} -3727778945703861076 +test execute-7.17 {Wide int handling in INST_BITAND} {longIs32bit} { + expr 0x9876543210febcda & 0x543210febcda9876 +} 1167013060659550290 +test execute-7.18 {Wide int handling in INST_ADD} {longIs32bit} { + expr wide(0x7fffffff)+wide(0x7fffffff) +} 4294967294 +test execute-7.19 {Wide int handling in INST_ADD} {longIs32bit} { + expr 0x7fffffff+wide(0x7fffffff) +} 4294967294 +test execute-7.20 {Wide int handling in INST_ADD} {longIs32bit} { + expr wide(0x7fffffff)+0x7fffffff +} 4294967294 +test execute-7.21 {Wide int handling in INST_ADD} {longIs32bit} { + expr double(0x7fffffff)+wide(0x7fffffff) +} 4294967294.0 +test execute-7.22 {Wide int handling in INST_ADD} {longIs32bit} { + expr wide(0x7fffffff)+double(0x7fffffff) +} 4294967294.0 +test execute-7.23 {Wide int handling in INST_SUB} {longIs32bit} { + expr 0x123456789a-0x20406080a +} 69530054800 +test execute-7.24 {Wide int handling in INST_MULT} {longIs32bit} { + expr 0x123456789a*193 +} 15090186251290 +test execute-7.25 {Wide int handling in INST_DIV} {longIs32bit} { + expr 0x123456789a/193 +} 405116546 +test execute-7.26 {Wide int handling in INST_UPLUS} {longIs32bit} { + set x 0x123456871234568 + expr {+ $x} +} 81985533099853160 +test execute-7.27 {Wide int handling in INST_UMINUS} {longIs32bit} { + set x 0x123456871234568 + expr {- $x} +} -81985533099853160 +test execute-7.28 {Wide int handling in INST_LNOT} {longIs32bit} { + set x 0x123456871234568 + expr {! $x} +} 0 +test execute-7.29 {Wide int handling in INST_BITNOT} {longIs32bit} { + set x 0x123456871234568 + expr {~ $x} +} -81985533099853161 +test execute-7.30 {Wide int handling in function call} {longIs32bit} { + set x 0x12345687123456 + incr x + expr {sin($x) == sin(double($x))} +} 1 +test execute-7.31 {Wide int handling in abs()} {longIs32bit} { + set x 0xa23456871234568 + incr x + set y 0x123456871234568 + concat [expr {abs($x)}] [expr {abs($y)}] +} {730503879441204585 81985533099853160} +test execute-7.32 {Wide int handling} {longIs32bit} { + expr {1024 * 1024 * 1024 * 1024} +} 0 +test execute-7.33 {Wide int handling} {longIs32bit} { + expr {0x1 * 1024 * 1024 * 1024 * 1024} +} 0 +test execute-7.34 {Wide int handling} {longIs32bit} { + expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} +} 1099511627776 + # cleanup catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename foo ""} @@ -600,22 +724,3 @@ catch {unset y} catch {unset msg} ::tcltest::cleanupTests return - - - - - - - - - - - - - - - - - - - diff --git a/tests/format.test b/tests/format.test index 67a4086..b7990b3 100644 --- a/tests/format.test +++ b/tests/format.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: format.test,v 1.9 2001/08/23 13:57:08 dkf Exp $ +# RCS: @(#) $Id: format.test,v 1.10 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -481,12 +481,27 @@ for {set i 0} {$i < 290} {incr i} { append b $a } for {set i 290} {$i < 400} {incr i} { - test format-15.[expr $i -290] {testing MAX_FLOAT_SIZE} { + test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" } +set ::tcltest::testConstraints(64bitInts) \ + [expr {0x80000000 > 0}] +set ::tcltest::testConstraints(wideIntExpressions) \ + [expr {wide(0x80000000) != int(0x80000000)}] + +test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} { + list [catch {format %d 7810179016327718216} msg] $msg +} {1 {integer value too large to represent}} +test format-17.2 {testing %ld with wide} {64bitInts} { + format %ld 7810179016327718216 +} 7810179016327718216 +test format-17.3 {testing %ld with non-wide} {64bitInts} { + format %ld 42 +} 42 + # cleanup catch {unset a} catch {unset b} diff --git a/tests/get.test b/tests/get.test index 946e4c6..a2efcea 100644 --- a/tests/get.test +++ b/tests/get.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: get.test,v 1.5 2000/04/10 17:18:59 ericm Exp $ +# RCS: @(#) $Id: get.test,v 1.6 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -45,7 +45,7 @@ test get-1.6 {Tcl_GetInt procedure} { # The following tests are non-portable because they depend on # word size. -if {0x80000000 > 0} { +if {wide(0x80000000) > wide(0)} { test get-1.7 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 18446744073709551616} msg] $msg $errorCode @@ -63,19 +63,19 @@ if {0x80000000 > 0} { list [catch {incr x -18446744073709551614} msg] $msg } {0 2} } else { - test get-1.7 {Tcl_GetInt procedure} { + test get-1.11 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} - test get-1.8 {Tcl_GetInt procedure} { + test get-1.12 {Tcl_GetInt procedure} { set x 0 list [catch {incr x 4294967294} msg] $msg } {0 -2} - test get-1.9 {Tcl_GetInt procedure} { + test get-1.13 {Tcl_GetInt procedure} { set x 0 list [catch {incr x +4294967294} msg] $msg } {0 -2} - test get-1.10 {Tcl_GetInt procedure} { + test get-1.14 {Tcl_GetInt procedure} { set x 0 list [catch {incr x -4294967294} msg] $msg } {0 2} diff --git a/tests/info.test b/tests/info.test index b82f7e6..9ed73b2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -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: info.test,v 1.17 2001/05/30 08:57:06 dkf Exp $ +# RCS: @(#) $Id: info.test,v 1.18 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -593,9 +593,9 @@ test info-19.5 {info vars with temporary variables} { # Check whether the extra testing functions are defined... if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { - set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh} + set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide} } else { - set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh} + set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide} } test info-20.1 {info functions option} {info functions sin} sin test info-20.2 {info functions option} {lsort [info functions]} $functions diff --git a/tests/io.test b/tests/io.test index 5cb1ccf..6c8cf79 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.25 2002/02/01 21:19:03 andreas_kupries Exp $ +# RCS: @(#) $Id: io.test,v 1.26 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -21,6 +21,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { tcltest::testConstraint testchannel [string equal testchannel [info commands testchannel]] +# You need a *very* special environment to do some tests. In +# particular, many file systems do not support large-files... +tcltest::testConstraint largefileSupport 0 + ::tcltest::saveState removeFile test1 @@ -3811,12 +3815,12 @@ test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set z [read $f1 1000000] close $f1 set x ok - set l [string length $z]] - set z [file size longfile]] + set l [string length $z] + set z [file size longfile] if {$z != $l} { set x broken } - set x + set x } ok test io-32.9 {Tcl_Read, read to end of file} { set f1 [open longfile r] @@ -4317,6 +4321,28 @@ test io-34.20 {Tcl_Tell combined with writing} { close $f set l } {29 39 40 447} +test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { + removeFile test3 + set f [open test3 w] + fconfigure $f -encoding binary + set l "" + lappend l [tell $f] + puts -nonewline $f abcdef + lappend l [tell $f] + flush $f + lappend l [tell $f] + # 4GB offset! + seek $f 0x100000000 + lappend l [tell $f] + puts -nonewline $f abcdef + lappend l [tell $f] + close $f + lappend l [file size $f] + # truncate... + close [open test3 w] + lappend l [file size $f] + set l +} {0 6 6 4294967296 4294967302 4294967302 0} # Test Tcl_Eof diff --git a/tests/link.test b/tests/link.test index f64711a..ae06584 100644 --- a/tests/link.test +++ b/tests/link.test @@ -11,246 +11,252 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: link.test,v 1.5 2000/04/10 17:19:01 ericm Exp $ +# RCS: @(#) $Id: link.test,v 1.6 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testlink] == {}} { - puts "This application hasn't been compiled with the \"testlink\"" - puts "command, so I can't test Tcl_LinkVar et al." - ::tcltest::cleanupTests - return -} +set ::tcltest::testConstraints(testlink) \ + [expr {[info commands testlink] != {}}] foreach i {int real bool string} { catch {unset $i} } -test link-1.1 {reading C variables from Tcl} { +test link-1.1 {reading C variables from Tcl} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 - list $int $real $bool $string -} {43 1.23 1 NULL} -test link-1.2 {reading C variables from Tcl} { + testlink set 43 1.23 4 - 12341234 + testlink create 1 1 1 1 1 + list $int $real $bool $string $wide +} {43 1.23 1 NULL 12341234} +test link-1.2 {reading C variables from Tcl} {testlink} { testlink delete - testlink create 1 1 1 1 - testlink set -3 2 0 "A long string with spaces" - list $int $real $bool $string $int $real $bool $string -} {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}} + testlink create 1 1 1 1 1 + testlink set -3 2 0 "A long string with spaces" 43214321 + list $int $real $bool $string $wide $int $real $bool $string $wide +} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321} -test link-2.1 {writing C variables from Tcl} { +test link-2.1 {writing C variables from Tcl} {testlink} { testlink delete - testlink set 43 1.21 4 - - testlink create 1 1 1 1 + testlink set 43 1.21 4 - 56785678 + testlink create 1 1 1 1 1 set int "00721" set real -10.5 set bool true set string abcdef - concat [testlink get] $int $real $bool $string -} {465 -10.5 1 abcdef 00721 -10.5 true abcdef} -test link-2.2 {writing bad values into variables} { + set wide 135135 + concat [testlink get] $int $real $bool $string $wide +} {465 -10.5 1 abcdef 135135 00721 -10.5 true abcdef 135135} +test link-2.2 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 list [catch {set int 09a} msg] $msg $int } {1 {can't set "int": variable must have integer value} 43} -test link-2.3 {writing bad values into variables} { +test link-2.3 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 list [catch {set real 1.x3} msg] $msg $real } {1 {can't set "real": variable must have real value} 1.23} -test link-2.4 {writing bad values into variables} { +test link-2.4 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 list [catch {set bool gorp} msg] $msg $bool } {1 {can't set "bool": variable must have boolean value} 1} +test link-2.5 {writing bad values into variables} {testlink} { + testlink delete + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 + list [catch {set wide gorp} msg] $msg $bool +} {1 {can't set "wide": variable must have integer value} 1} -test link-3.1 {read-only variables} { +test link-3.1 {read-only variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 0 1 1 0 + testlink set 43 1.23 4 - 56785678 + testlink create 0 1 1 0 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ - [catch {set string "new value"} msg] $msg $string -} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL} -test link-3.2 {read-only variables} { + [catch {set string "new value"} msg] $msg $string \ + [catch {set wide 12341234} msg] $msg $wide +} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678} +test link-3.2 {read-only variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 0 0 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 0 0 1 1 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ - [catch {set string "new value"} msg] $msg $string -} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}} + [catch {set string "new value"} msg] $msg $string\ + [catch {set wide 12341234} msg] $msg $wide +} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234} -test link-4.1 {unsetting linked variables} { +test link-4.1 {unsetting linked variables} {testlink} { testlink delete - testlink set -6 -2.5 0 stringValue - testlink create 1 1 1 1 - unset int real bool string + testlink set -6 -2.5 0 stringValue 13579 + testlink create 1 1 1 1 1 + unset int real bool string wide list [catch {set int} msg] $msg [catch {set real} msg] $msg \ - [catch {set bool} msg] $msg [catch {set string} msg] $msg -} {0 -6 0 -2.5 0 0 0 stringValue} -test link-4.2 {unsetting linked variables} { + [catch {set bool} msg] $msg [catch {set string} msg] $msg \ + [catch {set wide} msg] $msg +} {0 -6 0 -2.5 0 0 0 stringValue 0 13579} +test link-4.2 {unsetting linked variables} {testlink} { testlink delete - testlink set -6 -2.1 0 stringValue - testlink create 1 1 1 1 - unset int real bool string + testlink set -6 -2.1 0 stringValue 97531 + testlink create 1 1 1 1 1 + unset int real bool string wide set int 102 set real 16 set bool true set string newValue + set wide 333555 testlink get -} {102 16.0 1 newValue} +} {102 16.0 1 newValue 333555} -test link-5.1 {unlinking variables} { +test link-5.1 {unlinking variables} {testlink} { testlink delete - testlink set -6 -2.25 0 stringValue + testlink set -6 -2.25 0 stringValue 13579 testlink delete set int xx1 set real qrst set bool bogus set string 12345 + set wide 875421 testlink get -} {-6 -2.25 0 stringValue} -test link-5.2 {unlinking variables} { +} {-6 -2.25 0 stringValue 13579} +test link-5.2 {unlinking variables} {testlink} { testlink delete - testlink set -6 -2.25 0 stringValue - testlink create 1 1 1 1 + testlink set -6 -2.25 0 stringValue 97531 + testlink create 1 1 1 1 1 testlink delete - testlink set 25 14.7 7 - - list $int $real $bool $string -} {-6 -2.25 0 stringValue} + testlink set 25 14.7 7 - 999999 + list $int $real $bool $string $wide +} {-6 -2.25 0 stringValue 97531} -test link-6.1 {errors in setting up link} { +test link-6.1 {errors in setting up link} {testlink} { testlink delete catch {unset int} set int(44) 1 - list [catch {testlink create 1 1 1 1} msg] $msg + list [catch {testlink create 1 1 1 1 1} msg] $msg } {1 {can't set "int": variable is array}} catch {unset int} -test link-7.1 {access to linked variables via upvar} { +test link-7.1 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y unset y } testlink delete - testlink create 1 0 0 0 - testlink set 14 {} {} {} + testlink create 1 0 0 0 0 + testlink set 14 {} {} {} {} x list [catch {set int} msg] $msg } {0 14} -test link-7.2 {access to linked variables via upvar} { +test link-7.2 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y return [set y] } testlink delete - testlink create 1 0 0 0 - testlink set 0 {} {} {} + testlink create 1 0 0 0 0 + testlink set 0 {} {} {} {} set int - testlink set 23 {} {} {} + testlink set 23 {} {} {} {} x list [x] $int } {23 23} -test link-7.3 {access to linked variables via upvar} { +test link-7.3 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y 44 } testlink delete - testlink create 0 0 0 0 - testlink set 11 {} {} {} + testlink create 0 0 0 0 0 + testlink set 11 {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": linked variable is read-only} 11} -test link-7.4 {access to linked variables via upvar} { +test link-7.4 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y abc } testlink delete - testlink create 1 1 1 1 - testlink set -4 {} {} {} + testlink create 1 1 1 1 1 + testlink set -4 {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": variable must have integer value} -4} -test link-7.5 {access to linked variables via upvar} { +test link-7.5 {access to linked variables via upvar} {testlink} { proc x {} { upvar real y set y abc } testlink delete - testlink create 1 1 1 1 - testlink set -4 16.75 {} {} + testlink create 1 1 1 1 1 + testlink set -4 16.75 {} {} {} list [catch x msg] $msg $real } {1 {can't set "y": variable must have real value} 16.75} -test link-7.6 {access to linked variables via upvar} { +test link-7.6 {access to linked variables via upvar} {testlink} { proc x {} { upvar bool y set y abc } testlink delete - testlink create 1 1 1 1 - testlink set -4 16.3 1 {} + testlink create 1 1 1 1 1 + testlink set -4 16.3 1 {} {} list [catch x msg] $msg $bool } {1 {can't set "y": variable must have boolean value} 1} +test link-7.7 {access to linked variables via upvar} {testlink} { + proc x {} { + upvar wide y + set y abc + } + testlink delete + testlink create 1 1 1 1 1 + testlink set -4 16.3 1 {} 778899 + list [catch x msg] $msg $wide +} {1 {can't set "y": variable must have integer value} 778899} -test link-8.1 {Tcl_UpdateLinkedVar procedure} { +test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { - global x int real bool string - lappend x $args $int $real $bool $string + global x int real bool string wide + lappend x $args $int $real $bool $string $wide } set x {} - testlink create 1 1 1 1 - testlink set 14 -2.0 0 xyzzy + testlink create 1 1 1 1 1 + testlink set 14 -2.0 0 xyzzy 995511 trace var int w x - testlink update 32 4.0 3 abcd + testlink update 32 4.0 3 abcd 113355 trace vdelete int w x set x -} {{int {} w} 32 -2.0 0 xyzzy} -test link-8.2 {Tcl_UpdateLinkedVar procedure} { +} {{int {} w} 32 -2.0 0 xyzzy 995511} +test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { - global x int real bool string - lappend x $args $int $real $bool $string + global x int real bool string wide + lappend x $args $int $real $bool $string $wide } set x {} - testlink create 1 1 1 1 - testlink set 14 -2.0 0 xyzzy + testlink create 1 1 1 1 1 + testlink set 14 -2.0 0 xyzzy 995511 testlink delete trace var int w x - testlink update 32 4.0 6 abcd + testlink update 32 4.0 6 abcd 113355 trace vdelete int w x set x } {} -test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { - testlink create 0 0 0 0 - list [catch {testlink update 47 {} {} {}} msg] $msg $int +test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { + testlink create 0 0 0 0 0 + list [catch {testlink update 47 {} {} {} {}} msg] $msg $int } {0 {} 47} -testlink set 0 0 0 - -testlink delete -foreach i {int real bool string} { +catch {testlink set 0 0 0 - 0} +catch {testlink delete} +foreach i {int real bool string wide} { catch {unset $i} } # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - diff --git a/tests/platform.test b/tests/platform.test index 9c7dec5..19001ee 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -23,19 +23,19 @@ test platform-1.1 {TclpSetVariables: tcl_platform} { set result [i eval {lsort [array names tcl_platform]}] interp delete i set result -} {byteOrder machine os osVersion platform user} +} {byteOrder machine os osVersion platform user wordSize} + +# Test assumes twos-complement arithmetic, which is true of virtually +# everything these days. Note that this does *not* use wide(), and +# this is intentional since that could make Tcl's numbers wider than +# the machine-integer on some platforms... +test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { + set result [expr {1 << (8 * $tcl_platform(wordSize) - 1)}] + # Result must be the largest bit in a machine word, which this checks + # without assuming how wide the word really is + list [expr {$result < 0}] [expr {$result ^ ($result - 1)}] +} {1 -1} # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - diff --git a/tests/safe.test b/tests/safe.test index 2eb6788..1642d8e 100644 --- a/tests/safe.test +++ b/tests/safe.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: safe.test,v 1.10 2000/11/17 11:06:54 dkf Exp $ +# RCS: @(#) $Id: safe.test,v 1.11 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -185,7 +185,7 @@ test safe-6.3 {test safe interpreters knowledge of the world} { set r [lreplace $r $threaded $threaded] } set r -} {byteOrder platform} +} {byteOrder platform wordSize} # more test should be added to check that hostname, nameofexecutable, # aren't leaking infos, but they still do... @@ -518,15 +518,3 @@ test safe-11.8 {testing safe encoding} { # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - diff --git a/tests/scan.test b/tests/scan.test index d3d8c96..2bfa49a 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -11,13 +11,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: scan.test,v 1.12 2002/02/07 01:50:46 hobbs Exp $ +# RCS: @(#) $Id: scan.test,v 1.13 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +set ::tcltest::testConstraints(64bitInts) \ + [expr {0x80000000 > 0}] + test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} @@ -416,6 +419,12 @@ test scan-5.11 {integer scanning} {nonPortable} { [expr {$b == -16 || $b == 0x7fffffff}] } {2 4294967280 1} +test scan-5.12 {integer scanning} {64bitInts} { + set a {}; set b {}; set c {} + list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \ + %ld,%lx,%lo a b c] $a $b $c +} {3 7810179016327718216 7810179016327718216 7810179016327718216} + test scan-6.1 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d diff --git a/tests/string.test b/tests/string.test index c66390f..8cc5e00 100644 --- a/tests/string.test +++ b/tests/string.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: string.test,v 1.32 2002/02/07 00:51:55 hobbs Exp $ +# RCS: @(#) $Id: string.test,v 1.33 2002/02/15 14:28:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -274,7 +274,7 @@ proc largest_int {} { # 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 > 0} { set int [expr {1 << [incr exp]}] } + while {$int > 0} { set int [expr {wide(1) << [incr exp]}] } return [expr {$int-1}] } |