From dad163737534b2fc85b333382134f77e71283c2a Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Wed, 10 May 2000 12:51:03 +0000
Subject: [PATCH] [project @ 2000-05-10 12:51:03 by simonmar] Add tryTakeMVar
 test.

---
 ghc/tests/concurrent/should_run/conc022.hs     |   46 ++++++++++++++++++++++++
 ghc/tests/concurrent/should_run/conc022.stdout |    1 +
 2 files changed, 47 insertions(+)
 create mode 100644 ghc/tests/concurrent/should_run/conc022.hs
 create mode 100644 ghc/tests/concurrent/should_run/conc022.stdout

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
-- 
1.7.10.4