summaryrefslogtreecommitdiffstats
path: root/tests/async.test
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2003-11-16 00:49:20 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2003-11-16 00:49:20 (GMT)
commit10ef733f12d8356c8149674542195b702741fb57 (patch)
tree0ca93a479ec4c1eb68a2482ff755d5591112baeb /tests/async.test
parentecebf970f39a0b05f31b112c01c6d5b41434eed9 (diff)
downloadtcl-10ef733f12d8356c8149674542195b702741fb57.zip
tcl-10ef733f12d8356c8149674542195b702741fb57.tar.gz
tcl-10ef733f12d8356c8149674542195b702741fb57.tar.bz2
Miguel Sofer's patch (with small revisions) to make sure the bytecode engine
checks for async events fairly frequently. [Bug 746722]
Diffstat (limited to 'tests/async.test')
-rw-r--r--tests/async.test80
1 files changed, 68 insertions, 12 deletions
diff --git a/tests/async.test b/tests/async.test
index af63413..863be98 100644
--- a/tests/async.test
+++ b/tests/async.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: async.test,v 1.6 2003/07/24 16:05:24 dgp Exp $
+# RCS: @(#) $Id: async.test,v 1.7 2003/11/16 00:49:20 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -25,6 +25,10 @@ if {[info commands testasync] == {}} {
return
}
+tcltest::testConstraint threaded [expr {
+ [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded)
+}]
+
proc async1 {result code} {
global aresult acode
set aresult $result
@@ -146,19 +150,71 @@ test async-3.1 {deleting handlers} {
list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
} {3 del2 {0 0 0 del1 del2}}
+proc nothing {} {
+ # empty proc
+}
+proc hang1 {handle} {
+ global aresult
+ set aresult {Async event not delivered}
+ testasync marklater $handle
+ for {set i 0} {
+ $i < 2500000 && $aresult eq "Async event not delivered"
+ } {incr i} {
+ nothing
+ }
+ return $aresult
+}
+proc hang2 {handle} {
+ global aresult
+ set aresult {Async event not delivered}
+ testasync marklater $handle
+ for {set i 0} {
+ $i < 2500000 && $aresult eq "Async event not delivered"
+ } {incr i} {}
+ return $aresult
+}
+proc hang3 {handle} [concat {
+ global aresult
+ set aresult {Async event not delivered}
+ testasync marklater $handle
+ set i 0
+} [string repeat {;incr i;} 1500000] {
+ return $aresult
+}]
+
+test async-4.1 {async interrupting bytecode sequence} -constraints {
+ threaded
+} -setup {
+ set hm [testasync create async3]
+} -body {
+ hang1 $hm
+} -result {test pattern} -cleanup {
+ testasync delete $hm
+}
+test async-4.2 {async interrupting straight bytecode sequence} -constraints {
+ threaded
+} -setup {
+ set hm [testasync create async3]
+} -body {
+ hang2 $hm
+} -result {test pattern} -cleanup {
+ testasync delete $hm
+}
+test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
+ threaded
+} -setup {
+ set hm [testasync create async3]
+} -body {
+ hang3 $hm
+} -result {test pattern} -cleanup {
+ testasync delete $hm
+}
+
# cleanup
testasync delete
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
+# Local Variables:
+# mode: tcl
+# End: