Reorganisation of the source tree

[ghc-hetmet.git] / compiler / ilxGen / tests / test17.hs

diff --git a/compiler/ilxGen/tests/test17.hs b/compiler/ilxGen/tests/test17.hs
new file mode 100644 (file)
index 0000000..5e551b2
--- /dev/null
+++ b/compiler/ilxGen/tests/test17.hs
@@ -0,0 +1,44 @@
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module Test17 where
+
+import PrelGHC
+import PrelBase
+
+data Exception = IOException IOError | OtherExc
+
+data IOError 
+ = IOError 
+     String      
+
+tthrow :: Exception -> a
+
+tthrow exception = raise# exception
+ccatchException (IO m) k =  IO (\s -> catch# m (\ex -> unIO (k ex)) s)
+
+
+ccatch           :: IO a -> (IOError -> IO a) -> IO a 
+ccatch m k     =  ccatchException m handler
+  where handler (IOException err) = k err
+       handler other             = tthrow other
+
+ccatchNonIO      :: IO a -> (Exception -> IO a) -> IO a 
+ccatchNonIO m k        =  ccatchException m handler
+  where handler (IOException err) = ioError err
+       handler other             = k other
+
+newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
+
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
+unIO (IO a) = a
+
+ioError         :: IOError -> IO a 
+ioError err    =  IO (\s -> tthrow (IOException err) s)
+
+
+
+blockAsyncExceptions :: IO a -> IO a
+blockAsyncExceptions (IO io) = IO (blockAsyncExceptions# io)
+
+unblockAsyncExceptions :: IO a -> IO a
+unblockAsyncExceptions (IO io) = IO (unblockAsyncExceptions# io)