From: simonmar <unknown>
Date: Wed, 10 May 2000 12:51:03 +0000 (+0000)
Subject: [project @ 2000-05-10 12:51:03 by simonmar]
X-Git-Tag: Approximately_9120_patches~4528
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dad163737534b2fc85b333382134f77e71283c2a;hp=72577aafd28453a6977f6a85186c157a864d9fad;p=ghc-hetmet.git

[project @ 2000-05-10 12:51:03 by simonmar]
Add tryTakeMVar test.
---

diff --git a/ghc/tests/concurrent/should_run/conc022.hs b/ghc/tests/concurrent/should_run/conc022.hs
new file mode 100644
index 0000000..7e84e83
--- /dev/null
+++ b/ghc/tests/concurrent/should_run/conc022.hs
@@ -0,0 +1,46 @@
+-- !!! test tryTakeMVar
+
+import Concurrent
+import Exception
+import IO
+
+import PrelIOBase
+import PrelConc
+import PrelGHC
+
+main = do
+  m <- newEmptyMVar
+  r <- timeout 5 (tryTakeMVar m) (putStrLn "timed out!" >> return Nothing)
+  print (r :: Maybe Int)
+
+
+timeout
+   :: Int	-- secs
+   -> IO a	-- action to run
+   -> IO a	-- action to run on timeout
+   -> IO a
+
+timeout secs action on_timeout 
+  = do
+    threadid <- myThreadId
+    timeout <- forkIOIgnoreExceptions (
+			    do threadDelay (secs * 1000000)
+			       raiseInThread threadid (ErrorCall "__timeout")
+			  )
+    ( do result <- action
+	 killThread timeout
+	 return result
+      ) 
+      `catchAllIO`
+      ( \exception -> case exception of
+		       ErrorCall "__timeout" -> on_timeout		       
+		       _other                -> do
+						killThread timeout
+						throw exception )
+
+forkIOIgnoreExceptions :: IO () -> IO ThreadId
+forkIOIgnoreExceptions action = IO $ \ s -> 
+   case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ where
+  action_plus = catchAllIO action (\_ -> return ())
+
diff --git a/ghc/tests/concurrent/should_run/conc022.stdout b/ghc/tests/concurrent/should_run/conc022.stdout
new file mode 100644
index 0000000..4a584e4
--- /dev/null
+++ b/ghc/tests/concurrent/should_run/conc022.stdout
@@ -0,0 +1 @@
+Nothing