X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelErr.lhs;h=ecc38466670ebeb4ca1e6e04c2fbaf07fa281a16;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=ca905a6ef62e481f6a2045b2fd79e6c60052bcca;hpb=100e0301ae10ffef747e6883eed0e4dfeb2de736;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs
index ca905a6..ecc3846 100644
--- a/ghc/lib/std/PrelErr.lhs
+++ b/ghc/lib/std/PrelErr.lhs
@@ -14,12 +14,12 @@ with what the typechecker figures out.
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
 module PrelErr 
-
        (
          irrefutPatError
        , noMethodBindingError
        , nonExhaustiveGuardsError
        , patError
+       , recSelError
        , recConError
        , recUpdError               -- :: String -> a
 
@@ -27,15 +27,17 @@ module PrelErr
        , seqError                  -- :: a
 
        , error		           -- :: String -> a
-       , ioError	           -- :: String -> a
-       , assert__		   -- :: String -> Bool -> a -> a
+       , assertError		   -- :: String -> Bool -> a -> a
        ) where
 
---import Prelude
 import PrelBase
-import PrelIOBase
+import PrelIOBase   ( IO(..) )
+--import PrelHandle   ( catch )
 import PrelAddr
 import PrelList     ( span )
+import PrelException
+import PrelPack     ( packString )
+import PrelArr      ( ByteArray(..) )
 
 #ifndef __PARALLEL_HASKELL__
 import PrelForeign  ( StablePtr, deRefStablePtr )
@@ -60,6 +62,7 @@ augment = error "GHCbase.augment"
 %*********************************************************
 
 \begin{code}
+{-
 errorIO :: IO () -> a
 
 errorIO (IO io)
@@ -67,42 +70,57 @@ errorIO (IO io)
       _ -> bottom
   where
     bottom = bottom -- Never evaluated
-
-ioError :: String -> a
-ioError s = error__ ( \ x -> _ccall_ IOErrorHdrHook x ) s
+-}
+--ioError :: String -> a
+--ioError s = error__ ``&IOErrorHdrHook'' s 
 
 -- error stops execution and displays an error message
 error :: String -> a
-error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
+error s = throw (ErrorCall s)
+--error s = error__ ``&ErrorHdrHook'' s
+{-
+-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
+-- but the former does exactly the same as the latter, so I nuked it.
+--		SLPJ Jan 97
+--
+-- Hmm..distinguishing between these two kinds of error is quite useful in the
+-- compiler sources, printing out a more verbose msg in the case of patter
+-- matching failure.
+-- So I've reinstated patError to invoke its own message function hook again.
+--    SOF 8/98
+patError__ x = error__ ``&PatErrorHdrHook'' x
 
-error__ :: (Addr{-FILE *-} -> IO ()) -> String -> a
+error__ :: Addr{-C function pointer to hook-} -> String -> a
 
 error__ msg_hdr s
 #ifdef __PARALLEL_HASKELL__
-  = errorIO (msg_hdr sTDERR{-msg hdr-}	>>
-	     _ccall_ fflush sTDERR	>>
-	     fputs sTDERR s		>>
-	     _ccall_ fflush sTDERR	>>
-	     _ccall_ stg_exit (1::Int)
-	    )
+  = errorIO (do
+     (hFlush stdout) `catchException` (\ _ -> return ())
+     let bs@(ByteArray (_,len) _) = packString s
+     _ccall_ writeErrString__ msg_hdr bs len
+     _ccall_ stg_exit (1::Int)
+    )
 #else
-  = errorIO (msg_hdr sTDERR{-msg hdr-}	>>
-	     _ccall_ fflush sTDERR	>>
-	     fputs sTDERR s		>>
-	     _ccall_ fflush sTDERR	>>
-	     _ccall_ getErrorHandler	>>= \ errorHandler ->
-	     if errorHandler == (-1::Int) then
-		_ccall_ stg_exit (1::Int)
-	     else
-		_casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
-						>>= \ osptr ->
-		_ccall_ decrementErrorCount     >>= \ () ->
-		deRefStablePtr osptr            >>= \ oact ->
-		oact
-	    )
+  = errorIO ( do
+      (hFlush stdout) `catchException` (\ _ -> return ())
+	    -- Note: there's potential for trouble here in a
+	    -- a concurrent setting if an error is flagged after the
+	    -- lock on the stdout handle. (I don't see a possibility
+	    -- of this occurring with the current impl, but still.)
+      let bs@(ByteArray (_,len) _) = packString s
+      _ccall_ writeErrString__ msg_hdr bs len
+      errorHandler <- _ccall_ getErrorHandler
+      if errorHandler == (-1::Int) then
+	 _ccall_ stg_exit (1::Int)
+       else do
+	osptr <- _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
+	_ccall_ decrementErrorCount
+	oact  <- deRefStablePtr osptr
+	oact
+   )
+
 #endif {- !parallel -}
-  where
-    sTDERR = (``stderr'' :: Addr)
+-}
 \end{code}
 
 %*********************************************************
@@ -126,24 +144,23 @@ seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
 \begin{code}
 irrefutPatError
    , noMethodBindingError
- --, noExplicitMethodError
    , nonExhaustiveGuardsError
    , patError
+   , recSelError
    , recConError
    , recUpdError :: String -> a
 
---noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
---noExplicitMethodError    s = error ("No default method for class operation "++s)
-noMethodBindingError     s = error (untangle s "No instance nor default method for class operation")
-irrefutPatError		 s = error (untangle s "Irrefutable pattern failed for pattern")
-nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
-patError 		 s = error (untangle s "Non-exhaustive patterns in")
-recConError 		 s = error (untangle s "Missing field in record construction:")
-recUpdError 		 s = error (untangle s "Record to doesn't contain field(s) to be updated")
+noMethodBindingError     s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
+irrefutPatError		 s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
+patError 		 s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+recSelError 		 s = throw (RecSelError (untangle s "Missing field in record selection:"))
+recConError 		 s = throw (RecConError (untangle s "Missing field in record construction:"))
+recUpdError 		 s = throw (RecUpdError (untangle s "Record to doesn't contain field(s) to be updated"))
 
 
-assert__ :: String -> Bool -> a -> a
-assert__ str pred v 
+assertError :: String -> Bool -> a -> a
+assertError str pred v 
   | pred      = v
   | otherwise = error (untangle str "Assertion failed")
 
@@ -174,9 +191,3 @@ untangle coded message
 	}
     not_bar c = c /= '|'
 \end{code}
-
--- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
--- but the former does exactly the same as the latter, so I nuked it.
---		SLPJ Jan 97
--- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
-