From: Thomas Schilling <nominolo@googlemail.com>
Date: Sun, 14 Sep 2008 16:26:44 +0000 (+0000)
Subject: Return parser errors and warnings instead of dying.
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=7b2ac617ee9e54ee4e4c413a13085d9bda548d14

Return parser errors and warnings instead of dying.
---

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index b83a07e..9d83e2f 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -53,6 +53,7 @@ import FastString
 import Panic
 import Constants
 import Outputable
+import Bag              ( emptyBag, unitBag )
 
 import Control.Monad
 import Data.Array
@@ -1092,7 +1093,7 @@ initEnv = listToUFM [
     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
   ]
 
-parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
+parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe Cmm)
 parseCmmFile dflags filename = do
   showPass dflags "ParseCmm"
   buf <- hGetStringBuffer filename
@@ -1102,14 +1103,17 @@ parseCmmFile dflags filename = do
 		-- reset the lex_state: the Lexer monad leaves some stuff
 		-- in there we don't want.
   case unP cmmParse init_state of
-    PFailed span err -> do printError span err; return Nothing
+    PFailed span err -> do
+        let msg = mkPlainErrMsg span err
+        return ((emptyBag, unitBag msg), Nothing)
     POk pst code -> do
-	cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
-	let ms = getMessages pst
-	printErrorsAndWarnings dflags ms
-        when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
-        dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
-	return (Just cmm)
+        cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
+        let ms = getMessages pst
+        if (errorsFound dflags ms)
+         then return (ms, Nothing)
+         else do
+           dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
+           return (ms, Just cmm)
   where
 	no_module = panic "parseCmmFile: no module"
 }