[project @ 2000-04-14 15:28:24 by rrt]

[ghc-hetmet.git] / ghc / lib / std / PrelException.lhs

diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs
index 1f317aa..d30a4f3 100644 (file)
--- a/ghc/lib/std/PrelException.lhs
+++ b/ghc/lib/std/PrelException.lhs
@@ -1,5 +1,5 @@
 % -----------------------------------------------------------------------------
-% $Id: PrelException.lhs,v 1.15 2000/04/10 13:18:13 simonpj Exp $
+% $Id: PrelException.lhs,v 1.19 2000/04/14 15:28:24 rrt Exp $
 %
 % (c) The GRAP/AQUA Project, Glasgow University, 1998
 %
@@ -12,6 +12,7 @@ Exceptions and exception-handling functions.
 #ifndef __HUGS__
 module PrelException where
 
+import PrelList
 import PrelBase
 import PrelMaybe
 import PrelShow
@@ -32,6 +33,7 @@ import PrelGHC
 data Exception
   = IOException        IOError         -- IO exceptions (from 'ioError')
   | ArithException     ArithException  -- Arithmetic exceptions
+  | ArrayException     ArrayException  -- Array-related exceptions
   | ErrorCall          String          -- Calls to 'error'
   | NoMethodError       String         -- A non-existent method was invoked
   | PatternMatchFail   String          -- A pattern match failed
@@ -60,6 +62,10 @@ data AsyncException
   | ThreadKilled
   deriving (Eq, Ord)
 
+data ArrayException
+  = IndexOutOfBounds   String          -- out-of-range array access
+  | UndefinedElement   String          -- evaluating an undefined element
+
 stackOverflow, heapOverflow :: Exception -- for the RTS
 stackOverflow = AsyncException StackOverflow
 heapOverflow  = AsyncException HeapOverflow
@@ -76,9 +82,20 @@ instance Show AsyncException where
   showsPrec _ HeapOverflow    = showString "heap overflow"
   showsPrec _ ThreadKilled    = showString "thread killed"
 
+instance Show ArrayException where
+  showsPrec _ (IndexOutOfBounds s)
+       = showString "array index out of range"
+       . (if not (null s) then showString ": " . showString s
+                          else id)
+  showsPrec _ (UndefinedElement s)
+       = showString "undefined array element"
+       . (if not (null s) then showString ": " . showString s
+                          else id)
+
 instance Show Exception where
   showsPrec _ (IOException err)                 = shows err
   showsPrec _ (ArithException err)       = shows err
+  showsPrec _ (ArrayException err)       = shows err
   showsPrec _ (ErrorCall err)           = showString err
   showsPrec _ (NoMethodError err)        = showString err
   showsPrec _ (PatternMatchFail err)     = showString err
@@ -94,7 +111,6 @@ instance Show Exception where
   showsPrec _ (NonTermination)           = showString "<<loop>>"
 \end{code}
 
-
 %*********************************************************
 %*                                                     *
 \subsection{Primitive catch and throw}
@@ -195,3 +211,26 @@ ioError err        =  IO $ \s -> throw (IOException err) s
        -- the exception when applied to a world
 \end{code}
 
+%*********************************************************
+%*                                                     *
+\subsection{Controlling asynchronous exception delivery}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+#ifndef __HUGS__
+blockAsyncExceptions :: IO a -> IO a
+blockAsyncExceptions (IO io) = IO $ blockAsyncExceptions# io
+
+unblockAsyncExceptions :: IO a -> IO a
+unblockAsyncExceptions (IO io) = IO $ unblockAsyncExceptions# io
+#else
+-- Not implemented yet in Hugs.
+blockAsyncExceptions :: IO a -> IO a
+blockAsyncExceptions (IO io) = IO io
+
+unblockAsyncExceptions :: IO a -> IO a
+unblockAsyncExceptions (IO io) = IO io
+#endif
+\end{code}
+