Comments only

[ghc-hetmet.git] / utils / hsc2hs / Main.hs

diff --git a/utils/hsc2hs/Main.hs b/utils/hsc2hs/Main.hs
index 9f202fd..75ea57b 100644 (file)
--- a/utils/hsc2hs/Main.hs
+++ b/utils/hsc2hs/Main.hs
@@ -13,7 +13,7 @@
 #include "../../includes/ghcconfig.h"
 #endif
 
 #include "../../includes/ghcconfig.h"
 #endif
 

-#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
+#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114

 import System.Console.GetOpt
 #else
 import GetOpt
 import System.Console.GetOpt
 #else
 import GetOpt

@@ -24,9 +24,9 @@ import Directory     (removeFile,doesFileExist)
 import Monad         (MonadPlus(..), liftM, liftM2, when)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 import Monad         (MonadPlus(..), liftM, liftM2, when)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)

-import IO            (hPutStr, hPutStrLn, stderr)
+import IO            (hPutStr, hPutStrLn, stderr, bracket_)

 
 

-#if defined(mingw32_HOST_OS) && !__HUGS__
+#if defined(mingw32_HOST_OS)

 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String
 import Foreign
 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
 import Foreign.C.String

@@ -44,14 +44,14 @@ import System.IO                ( openFile, IOMode(..), hClose )
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 import Compat.RawSystem        ( rawSystem )
 #define HAVE_rawSystem
 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
 import Compat.RawSystem        ( rawSystem )
 #define HAVE_rawSystem

-#elif __HUGS__ || __NHC__ >= 117
+#elif __NHC__ >= 117

 import System.Cmd              ( rawSystem )
 #define HAVE_rawSystem
 #endif
 
 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
 -- we need system
 import System.Cmd              ( rawSystem )
 #define HAVE_rawSystem
 #endif
 
 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
 -- we need system

-#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
+#if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600

 import System.Cmd              ( system )
 #else
 import System                   ( system )
 import System.Cmd              ( system )
 #else
 import System                   ( system )

@@ -132,11 +132,7 @@ main = do
     flags_w_tpl <- if any template_flag flags then
                        return flags
                   else
     flags_w_tpl <- if any template_flag flags then
                        return flags
                   else

-#ifdef __HUGS__
-                       do mb_path <- getExecDir "/Main.hs"
-#else

                        do mb_path <- getExecDir "/bin/hsc2hs.exe"
                        do mb_path <- getExecDir "/bin/hsc2hs.exe"

-#endif

                           add_opt <-
                            case mb_path of
                              Nothing   -> return id
                           add_opt <-
                            case mb_path of
                              Nothing   -> return id

@@ -548,17 +544,6 @@ output flags name toks = do
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 
             fixChar c | isAlphaNum c = toUpper c
                       | otherwise    = '_'
 

-#ifdef __HUGS__
-    compiler <- case [c | Compiler c <- flags] of
-        []  -> return "gcc"
-        [c] -> return c
-        _   -> onlyOne "compiler"
-
-    linker <- case [l | Linker l <- flags] of
-        []  -> return compiler
-        [l] -> return l
-        _   -> onlyOne "linker"
-#else

         -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
        -- Returns a native-format path
         locateGhc def = do
         -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
        -- Returns a native-format path
         locateGhc def = do

@@ -591,7 +576,6 @@ output flags name toks = do
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"
         []  -> locateGhc compiler
         [l] -> return l
         _   -> onlyOne "linker"

-#endif

 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++
 
     writeFile cProgName $
         concatMap outFlagHeaderCProg flags++

@@ -613,17 +597,17 @@ output flags name toks = do
         ++ [cProgName]
         ++ ["-o", oProgName]
        )
         ++ [cProgName]
         ++ ["-o", oProgName]
        )

-    removeFile cProgName
+    finallyRemove cProgName $ do

 
     rawSystemL ("linking " ++ oProgName) beVerbose linker
         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )
 
     rawSystemL ("linking " ++ oProgName) beVerbose linker
         (  [f | LinkFlag f <- flags]
         ++ [oProgName]
         ++ ["-o", progName]
        )

-    removeFile oProgName
+    finallyRemove oProgName $ do

 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
 
     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName

-    removeFile progName
+    finallyRemove progName $ do

 
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++
 
     when needsH $ writeFile outHName $
         "#ifndef "++includeGuard++"\n" ++

@@ -675,6 +659,19 @@ rawSystemWithStdOutL action flg prog args outFile = do
     ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
     _             -> return ()
 
     ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
     _             -> return ()
 

+
+-- delay the cleanup of generated files until the end; attempts to
+-- get around intermittent failure to delete files which has
+-- just been exec'ed by a sub-process (Win32 only.)
+finallyRemove :: FilePath -> IO a -> IO a
+finallyRemove fp act = 
+  bracket_ (return fp)
+           (const $ noisyRemove fp)
+           act
+ where
+  noisyRemove fpath =
+    catch (removeFile fpath)
+          (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))

 onlyOne :: String -> IO a
 onlyOne what = die ("Only one "++what++" may be specified\n")
 
 onlyOne :: String -> IO a
 onlyOne what = die ("Only one "++what++" may be specified\n")
 

@@ -909,9 +906,7 @@ getExecDir cmd =
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)

-#if defined(__HUGS__)
-getExecPath = liftM Just getProgName
-#elif defined(mingw32_HOST_OS)
+#if defined(mingw32_HOST_OS)

 getExecPath =
      allocaArray len $ \buf -> do
          ret <- getModuleFileName nullPtr buf len
 getExecPath =
      allocaArray len $ \buf -> do
          ret <- getModuleFileName nullPtr buf len