X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelErr.lhs;h=53daf0314bf5d1a88ec1c0bc2c640cb7734bfa75;hb=99a7c45faea79d98928bd5e02b7c60b4eba3cae9;hp=a96044ce792c030d884d86327d941f1c65b63b34;hpb=0d65c1627fcb0aa951c6457c879fdd7626e83a62;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs
index a96044c..53daf03 100644
--- a/ghc/lib/std/PrelErr.lhs
+++ b/ghc/lib/std/PrelErr.lhs
@@ -1,5 +1,7 @@
+% -----------------------------------------------------------------------------
+% $Id: PrelErr.lhs,v 1.21 2001/07/24 16:09:48 simonpj Exp $
 %
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The University of Glasgow, 1994-2000
 %
 
 \section[PrelErr]{Module @PrelErr@}
@@ -26,34 +28,16 @@ module PrelErr
        , absentErr, parError       -- :: a
        , seqError                  -- :: a
 
+       , errorCString		   -- :: Addr# -> a	-- Arg is a ptr to C string 
        , error		           -- :: String -> a
        , assertError		   -- :: String -> Bool -> a -> a
        
+       , undefined		   -- :: a
        ) where
 
 import PrelBase
-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 )
-#endif
-
----------------------------------------------------------------
--- HACK: Magic unfoldings not implemented for unboxed lists
---	 Need to define a "build" to avoid undefined symbol
--- in this module to avoid .hi proliferation.
-
---{-# GENERATE_SPECS build a #-}
---build 		:: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
---build g 	= g (:) []
---build   = error "GHCbase.build"
---augment = error "GHCbase.augment"
 \end{code}
 
 %*********************************************************
@@ -63,65 +47,19 @@ import PrelForeign  ( StablePtr, deRefStablePtr )
 %*********************************************************
 
 \begin{code}
-{-
-errorIO :: IO () -> a
-
-errorIO (IO io)
-  = case (errorIO# io) of
-      _ -> bottom
-  where
-    bottom = bottom -- Never evaluated
--}
---ioError :: String -> a
---ioError s = error__ ``&IOErrorHdrHook'' s 
-
 -- error stops execution and displays an error message
 error :: String -> a
 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{-C function pointer to hook-} -> String -> a
-
-error__ msg_hdr s
-#ifdef __PARALLEL_HASKELL__
-  = 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 ( 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 -}
--}
+
+errorCString :: Addr# -> a
+errorCString s = error (unpackCString# s)
+
+-- It is expected that compilers will recognize this and insert error
+-- messages which are more appropriate to the context in which undefined 
+-- appears. 
+
+undefined :: a
+undefined =  error "Prelude.undefined"
 \end{code}
 
 %*********************************************************
@@ -153,17 +91,17 @@ irrefutPatError
 
 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"))
+nonExhaustiveGuardsError s = throw (PatternMatchFail (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"))
+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 doesn't contain field(s) to be updated"))
 
 
 assertError :: String -> Bool -> a -> a
 assertError str pred v 
   | pred      = v
-  | otherwise = error (untangle str "Assertion failed")
+  | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
 
 \end{code}