[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 (file)
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 (file)
index 0000000..4a584e4
--- /dev/null
+++ b/ghc/tests/concurrent/should_run/conc022.stdout
@@ -0,0 +1 @@
+Nothing