[project @ 1998-01-27 18:39:01 by sof]

[ghc-hetmet.git] / ghc / lib / ghc / GHCerr.lhs

diff --git a/ghc/lib/ghc/GHCerr.lhs b/ghc/lib/ghc/GHCerr.lhs
index ee5643b..578fcac 100644 (file)
--- a/ghc/lib/ghc/GHCerr.lhs
+++ b/ghc/lib/ghc/GHCerr.lhs
@@ -13,12 +13,31 @@ with what the typechecker figures out.
 
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
-module GHCerr where
+module GHCerr 
+
+       (
+         irrefutPatError
+       , noMethodBindingError
+       , nonExhaustiveGuardsError
+       , patError
+       , recConError
+       , recUpdError               -- :: String -> a
+
+       , absentErr, parError       -- :: a
+       , seqError                  -- :: a
+
+       , error                    -- :: String -> a
+       , ioError                  -- :: String -> a
+       , assert__                 -- :: String -> Bool -> a -> a
+       ) where
 
 --import Prelude
 import PrelBase
+import IOBase
+import Addr
+import Foreign  ( StablePtr, deRefStablePtr )
 import PrelList ( span )
-import Error
+
 
 ---------------------------------------------------------------
 -- HACK: Magic unfoldings not implemented for unboxed lists
@@ -32,33 +51,100 @@ augment = error "GHCbase.augment"
 --build g      = g (:) []
 \end{code}
 
+%*********************************************************
+%*                                                     *
+\subsection{Error-ish functions}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+errorIO :: IO () -> a
+
+errorIO (IO io)
+  = case (errorIO# io) of
+      _ -> bottom
+  where
+    bottom = bottom -- Never evaluated
+
+ioError :: String -> a
+ioError s = error__ ( \ x -> _ccall_ IOErrorHdrHook x ) s
+
+-- error stops execution and displays an error message
+error :: String -> a
+error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
+
+error__ :: (Addr{-FILE *-} -> IO ()) -> 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)
+           )
+#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
+           )
+#endif {- !parallel -}
+  where
+    sTDERR = (``stderr'' :: Addr)
+\end{code}
+
+%*********************************************************
+%*                                                      *
+\subsection{Compiler generated errors + local utils}
+%*                                                      *
+%*********************************************************
 
 Used for compiler-generated error message;
 encoding saves bytes of string junk.
 
 \begin{code}
-absentErr, parError :: a
+absentErr, parError, seqError :: a
 
 absentErr = error "Oops! The program has entered an `absent' argument!\n"
 parError  = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
+seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
+
 \end{code}
 
 \begin{code}
 irrefutPatError
- , noDefaultMethodError
- , noExplicitMethodError
+ , noMethodBindingError
+ --, noExplicitMethodError
  , nonExhaustiveGuardsError
  , patError
  , recConError
  , recUpdError :: String -> a
 
-noDefaultMethodError     s = error ("noDefaultMethodError:"++s)
-noExplicitMethodError    s = error ("No default method for class operation "++s)
+--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")
+
+
+assert__ :: String -> Bool -> a -> a
+assert__ str pred v 
+  | pred      = v
+  | otherwise = error (untangle str "Assertion failed")
+
 \end{code}