From: sof <unknown>
Date: Fri, 14 Aug 1998 12:54:09 +0000 (+0000)
Subject: [project @ 1998-08-14 12:54:08 by sof]
X-Git-Tag: Approx_2487_patches~371
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e79425252ce15ab54f5cbbe7d3ec93ed5f4b1846;p=ghc-hetmet.git

[project @ 1998-08-14 12:54:08 by sof]
Avoid using stdio for dumping error strings
---

diff --git a/ghc/lib/std/PrelErr.hi-boot b/ghc/lib/std/PrelErr.hi-boot
index 6290349..07bbcbb 100644
--- a/ghc/lib/std/PrelErr.hi-boot
+++ b/ghc/lib/std/PrelErr.hi-boot
@@ -9,4 +9,4 @@
  
 _interface_ PrelErr 1
 _exports_
-PrelErr error;
+PrelErr error parError;
diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs
index 0a431f0..42cca98 100644
--- a/ghc/lib/std/PrelErr.lhs
+++ b/ghc/lib/std/PrelErr.lhs
@@ -32,11 +32,13 @@ module PrelErr
        , assertError		   -- :: String -> Bool -> a -> a
        ) where
 
---import Prelude
 import PrelBase
-import PrelIOBase
+import PrelIOBase   ( IO(..), catch )
+import PrelHandle
 import PrelAddr
 import PrelList     ( span )
+import PrelPack     ( packString )
+import PrelArr      ( ByteArray(..) )
 
 #ifndef __PARALLEL_HASKELL__
 import PrelForeign  ( StablePtr, deRefStablePtr )
@@ -70,40 +72,53 @@ errorIO (IO io)
     bottom = bottom -- Never evaluated
 
 ioError :: String -> a
-ioError s = error__ ( \ x -> _ccall_ IOErrorHdrHook x ) s
+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 = error__ ``&ErrorHdrHook'' s
 
-error__ :: (Addr{-FILE *-} -> IO ()) -> String -> a
+-- 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 (msg_hdr sTDERR{-msg hdr-}	>>
-	     _ccall_ fflush sTDERR	>>
-	     fputs sTDERR s		>>
-	     _ccall_ fflush sTDERR	>>
-	     _ccall_ stg_exit (1::Int)
-	    )
+  = errorIO (do
+     (hFlush stdout) `catch` (\ _ -> 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) `catch` (\ _ -> 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}
 
 %*********************************************************
@@ -139,11 +154,10 @@ irrefutPatError
 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")
 recSelError 		 s = error (untangle s "Missing field in record selection:")
 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")
-
+patError 		 s = patError__ (untangle s "Non-exhaustive patterns in")
 
 assertError :: String -> Bool -> a -> a
 assertError str pred v 
@@ -177,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)
-