X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FDriverUtil.hs;h=210acdbd56cd85201ff511796692dbec5f66a9ca;hb=74a7a2645c2399155a11503e0d558f921d0c7f36;hp=e1311fe1f3b865c07bee8037e9c2ba900b660631;hpb=7752abc1008b633fdc7a0b9f283ceca40747b609;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index e1311fe..210acdb 100644
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.15 2000/12/12 14:35:08 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.23 2001/06/02 09:45:51 qrczak Exp $
 --
 -- Utils for the driver
 --
@@ -20,13 +20,17 @@ import Exception
 import Dynamic
 import RegexString
 
+import Directory	( getDirectoryContents )
 import IO
 import System
-import Directory ( removeFile )
 import List
 import Char
 import Monad
 
+#ifndef mingw32_TARGET_OS
+import Posix
+#endif
+
 -----------------------------------------------------------------------------
 -- Errors
 
@@ -60,12 +64,24 @@ getOptionsFromSource file
 		   | prefixMatch "#" l -> look h
 		   | prefixMatch "{-# LINE" l -> look h   -- -}
 		   | Just (opts:_) <- matchRegex optionRegex l
-			-> return (words opts)
+			-> do rest <- look h
+                              return (words opts ++ rest)
 		   | otherwise -> return []
 
 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
 
 -----------------------------------------------------------------------------
+-- A version of getDirectoryContents that is non-fatal if the
+-- directory doesn't exist.
+
+softGetDirectoryContents d
+   = IO.catch (getDirectoryContents d)
+	  (\_ -> do hPutStr stderr 
+		          ("WARNING: error while reading directory " ++ d)
+		    return []
+	  )
+
+-----------------------------------------------------------------------------
 -- Utils
 
 unknownFlagErr :: String -> a
@@ -92,7 +108,13 @@ handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 handleDyn = flip catchDyn
 
 handle :: (Exception -> IO a) -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 501
 handle = flip Exception.catchAllIO
+#else
+handle h f = f `Exception.catch` \e -> case e of
+    ExitException _ -> throw e
+    _               -> h e
+#endif
 
 split :: Char -> String -> [String]
 split c s = case rest of
@@ -113,6 +135,9 @@ addNoDups var x = do
 splitFilename :: String -> (String,String)
 splitFilename f = split_longest_prefix f '.'
 
+getFileSuffix :: String -> String
+getFileSuffix f = drop_longest_prefix f '.'
+
 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 splitFilename3 :: String -> (String,String,String)
 splitFilename3 str
@@ -161,22 +186,55 @@ remove_spaces :: String -> String
 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 
 
--- system that works feasibly under Windows (i.e. passes the command line to sh,
--- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
-kludgedSystem cmd phase_name
- = do
-#ifndef mingw32_TARGET_OS
-   exit_code <- system cmd `catchAllIO` 
-		   (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+ghcToolDir :: String
+prependToolDir :: String -> IO String
+#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
+ghcToolDir = unsafePerformIO $ do
+		bs <- getEnv "GHC_TOOLDIR" `IO.catch` (\ _ -> return "")
+		case bs of
+		  "" -> return bs
+		  ls -> 
+		    let
+		     term = last ls
+		     bs' 
+		      | term `elem` ['/', '\\'] = bs
+		      | otherwise = bs ++ ['/']
+		    in
+		    return bs'
+
+prependToolDir x = return (dosifyPath (ghcToolDir ++ x))
+#else
+ghcToolDir = ""
+prependToolDir x = return x
+#endif
+
+appendInstallDir :: String -> IO String
+appendInstallDir cmd = 
+  case ghcToolDir of
+    "" -> return cmd
+    _  -> return (unwords [cmd, '-':'B':ghcToolDir])
+
+-- convert filepath into MSDOS form.
+dosifyPath :: String -> String
+#if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
+dosifyPath stuff = subst '/' '\\' real_stuff
+ where
+   -- fully convince myself that /cygdrive/ prefixes cannot
+   -- really appear here.
+  cygdrive_prefix = "/cygdrive/"
+
+  real_stuff
+    | "/cygdrive/" `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
+    | otherwise = stuff
+   
+  subst a b ls = map (\ x -> if x == a then b else x) ls
+#else
+dosifyPath x = x
+#endif
+
+#ifdef mingw32_TARGET_OS
+foreign import "_getpid" myGetProcessID :: IO Int 
 #else
-   pid <- myGetProcessID
-   let tmp = "/tmp/sh" ++ show pid
-   h <- openFile tmp WriteMode
-   hPutStrLn h cmd
-   hClose h
-   exit_code <- system ("sh - " ++ tmp) `catchAllIO` 
-		   (\_ -> removeFile tmp >>
-                          throwDyn (PhaseFailed phase_name (ExitFailure 1)))
-   removeFile tmp
+myGetProcessID :: IO Int
+myGetProcessID = Posix.getProcessID
 #endif
-   return exit_code