summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2002-02-15 14:28:47 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2002-02-15 14:28:47 (GMT)
commit66a15c6f8be47c3acbdddffadc67f50dec8a56e6 (patch)
treeedaf81ee6d40edeacc9f3e2093ddcb2ba302c620 /tests
parent2827a2692798a7a0ec46e684a4ccc83afb39859e (diff)
downloadtcl-66a15c6f8be47c3acbdddffadc67f50dec8a56e6.zip
tcl-66a15c6f8be47c3acbdddffadc67f50dec8a56e6.tar.gz
tcl-66a15c6f8be47c3acbdddffadc67f50dec8a56e6.tar.bz2
TIP#72 implementation. See ChangeLog for details.
This version builds clean on Solaris/SPARC, with GCC and CC, both with and without threads and both in 32-bit and 64-bit mode.
Diffstat (limited to 'tests')
-rw-r--r--tests/binary.test30
-rw-r--r--tests/execute.test145
-rw-r--r--tests/format.test19
-rw-r--r--tests/get.test12
-rw-r--r--tests/info.test6
-rw-r--r--tests/io.test34
-rw-r--r--tests/link.test232
-rw-r--r--tests/platform.test24
-rw-r--r--tests/safe.test16
-rw-r--r--tests/scan.test11
-rw-r--r--tests/string.test4
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}]
}