[project @ 2001-07-04 15:43:38 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 ebafe83..5d59167 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.73 2001/06/18 08:56:09 simonpj Exp $
+-- $Id: Main.hs,v 1.80 2001/07/04 15:43:38 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -33,23 +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, defaultDynFlags, restoreDynFlags, saveDynFlags, setDynFlags, 
-                         DynFlags(..), HscLang(..), 
-                         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 )
 
@@ -57,20 +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 )
+#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:
@@ -104,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
@@ -149,12 +160,6 @@ main =
    (flags2, mode, stop_flag) <- getGhcMode argv'
    writeIORef v_GhcMode mode
 
-       -- Show the GHCi banner?
-#  ifdef GHCI
-   when (mode == DoInteractive) $
-      hPutStrLn stdout ghciWelcomeMsg
-#  endif
-
        -- process all the other arguments, and get the source files
    non_static <- processArgs static_flags flags2 []
 
@@ -175,7 +180,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
@@ -212,7 +219,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
@@ -220,9 +227,15 @@ main =
        -- complain about any unknown flags
    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 
-       -- Display details of the configuration in verbose mode
    verb <- dynFlag verbosity
 
+       -- Show the GHCi banner
+#  ifdef GHCI
+   when (mode == DoInteractive && verb >= 1) $
+      hPutStrLn stdout ghciWelcomeMsg
+#  endif
+
+       -- Display details of the configuration in verbose mode
    when (verb >= 2) 
        (do hPutStr stderr "Glasgow Haskell Compiler, Version "
            hPutStr stderr cProjectVersion
@@ -304,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 ()
@@ -321,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