[project @ 2001-07-03 11:14:33 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / Main.hs

diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 2336b4e..bf34a74 100644 (file)
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.72 2001/06/15 08:29:58 simonpj Exp $
+-- $Id: Main.hs,v 1.79 2001/07/03 11:14:33 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -33,25 +33,25 @@ import DriverPipeline       ( GhcMode(..), doLink, doMkDLL, genPipeline,
                          getGhcMode, pipeLoop, v_GhcMode
                        )
 import DriverState     ( buildCoreToDo, buildStgToDo, defaultHscLang,
-                         findBuildTag, getPackageInfo, unregFlags, v_Cmdline_libraries,
-                         v_Keep_tmp_files, v_Ld_inputs, v_OptLevel, v_Output_file,
-                         v_Output_hi, v_Package_details, v_Ways
+                         findBuildTag, getPackageInfo, unregFlags, 
+                         v_Cmdline_libraries, v_Keep_tmp_files, v_Ld_inputs,
+                         v_OptLevel, v_Output_file, v_Output_hi, 
+                         v_Package_details, v_Ways, getPackageExtraGhcOpts
                        )
-import DriverFlags     ( dynFlag, buildStaticHscOpts, dynamic_flags, processArgs, static_flags)
+import DriverFlags     ( dynFlag, buildStaticHscOpts, dynamic_flags,
+                         processArgs, static_flags)
 
 import DriverMkDepend  ( beginMkDependHS, endMkDependHS )
 import DriverPhases    ( Phase(Hsc, HCc), haskellish_src_file, objish_file )
 
-import DriverUtil      ( add, handle, handleDyn, later, splitFilename, unknownFlagErr, my_prefix_match )
-import CmdLineOpts     ( dynFlag,
-                         DynFlags(verbosity, stgToDo, hscOutName, hscLang, coreToDo),
-                         HscLang(HscInterpreted, HscC), 
-                         defaultDynFlags, restoreDynFlags, saveDynFlags, setDynFlags, 
-                         v_Static_hsc_opts
+import DriverUtil      ( add, handle, handleDyn, later, splitFilename,
+                         unknownFlagErr )
+import CmdLineOpts     ( dynFlag, defaultDynFlags, restoreDynFlags,
+                         saveDynFlags, setDynFlags, 
+                         DynFlags(..), HscLang(..), v_Static_hsc_opts
                        )
 
 import Outputable
-import ErrUtils                ( dumpIfSet )
 import Util
 import Panic           ( GhcException(..), panic )
 
@@ -59,19 +59,25 @@ import Panic                ( GhcException(..), panic )
 import IO
 import Directory       ( doesFileExist )
 import IOExts          ( readIORef, writeIORef )
-import Exception       ( throwDyn, Exception(DynException) )
+import Exception       ( throwDyn, Exception(..) )
 import System          ( getArgs, exitWith, ExitCode(..) )
+import Monad
+import List
+import Maybe
 
 #ifndef mingw32_TARGET_OS
-import Concurrent      ( myThreadId, throwTo )
+import Concurrent      ( myThreadId )
+#if __GLASGOW_HASKELL__ < 500
+import Exception        ( raiseInThread )
+#define throwTo  raiseInThread
+#else
+import Exception       ( throwTo )
+#endif
+
 import Posix           ( Handler(Catch), installHandler, sigINT, sigQUIT )
 import Dynamic         ( toDyn )
 #endif
 
-import Monad
-import List
-import Maybe
-
 
 -----------------------------------------------------------------------------
 -- Changes:
@@ -105,8 +111,12 @@ import Maybe
 
 main =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
-  handle (\exception -> do hPutStr stderr (show (Panic (show exception)))
-                          exitWith (ExitFailure 1)
+  handle (\exception -> do
+          case exception of
+               -- an IO exception probably isn't our fault, so don't panic
+               IOException _ ->  hPutStr stderr (show exception)
+               _other        ->  hPutStr stderr (show (Panic (show exception)))
+          exitWith (ExitFailure 1)
          ) $ do
 
   -- all error messages are propagated as exceptions
@@ -176,7 +186,9 @@ main =
    way_opts <- findBuildTag
    let unreg_opts | cGhcUnregisterised == "YES" = unregFlags
                  | otherwise = []
-   way_non_static <- processArgs static_flags (unreg_opts ++ way_opts) []
+   pkg_extra_opts <- getPackageExtraGhcOpts
+   extra_non_static <- processArgs static_flags 
+                          (unreg_opts ++ way_opts ++ pkg_extra_opts) []
 
        -- give the static flags to hsc
    static_opts <- buildStaticHscOpts
@@ -213,7 +225,7 @@ main =
                                })
 
        -- the rest of the arguments are "dynamic"
-   srcs <- processArgs dynamic_flags (way_non_static ++ non_static) []
+   srcs <- processArgs dynamic_flags (extra_non_static ++ non_static) []
 
        -- save the "initial DynFlags" away
    saveDynFlags
@@ -305,10 +317,10 @@ beginMake fileish_args
 
        case mods of
         []    -> throwDyn (UsageError "no input files")
-        [mod] -> do state <- cmInit Batch
-                    cmLoadModule state mod
+        mod   -> do state <- cmInit Batch
+                    (_, ok, _) <- cmLoadModule state mods
+                    when (not ok) (exitWith (ExitFailure 1))
                     return ()
-        _     -> throwDyn (UsageError "only one module allowed with --make")
 
 
 beginInteractive :: [String] -> IO ()
@@ -322,9 +334,5 @@ beginInteractive fileish_args
           libs = map Left objs ++ map Right minus_ls
 
        state <- cmInit Interactive
-       case mods of
-         []    -> interactiveUI state Nothing    libs
-         [mod] -> interactiveUI state (Just mod) libs
-         _     -> throwDyn (UsageError 
-                             "only one module allowed with --interactive")
+       interactiveUI state mods libs
 #endif