From: rrt <unknown>
Date: Mon, 11 Dec 2000 12:30:58 +0000 (+0000)
Subject: [project @ 2000-12-11 12:30:58 by rrt]
X-Git-Tag: Approximately_9120_patches~3144
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d983b29afdef9a867a283ef7434e0e2bf773ae38;p=ghc-hetmet.git

[project @ 2000-12-11 12:30:58 by rrt]
Use kludgedSystem instead of system to work sanely (AFATIP) on Windows.
---

diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index 2c08406..924f29b 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.31 2000/12/11 12:15:15 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.32 2000/12/11 12:30:58 rrt Exp $
 --
 -- Driver flags
 --
@@ -533,21 +533,9 @@ runSomething phase_name cmd
    unless n $ do 
 
    -- and run it!
-#ifndef mingw32_TARGET_OS
-   exit_code <- system cmd `catchAllIO` 
-		   (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
-#else
-   tmp <- newTempName "sh"
-   h <- openFile tmp WriteMode
-   hPutStrLn h cmd
-   hClose h
-   exit_code <- system ("sh - " ++ tmp) `catchAllIO` 
-		   (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
-   removeFile tmp
-#endif
+   exit_code <- kludgedSystem cmd phase_name
 
    if exit_code /= ExitSuccess
 	then throwDyn (PhaseFailed phase_name exit_code)
 	else do when (verb >= 3) (putStr "\n")
 	        return ()
-
diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 764be3f..4301d86 100644
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.11 2000/11/20 16:28:29 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.12 2000/12/11 12:30:58 rrt Exp $
 --
 -- Utils for the driver
 --
@@ -9,9 +9,11 @@
 
 module DriverUtil where
 
+#include "../includes/config.h"
 #include "HsVersions.h"
 
 import Util
+import TmpFiles ( newTempName )
 
 import IOExts
 import Exception
@@ -20,6 +22,7 @@ import RegexString
 
 import IO
 import System
+import Directory ( removeFile )
 import List
 import Char
 import Monad
@@ -181,3 +184,21 @@ newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 
 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)))
+#else
+   tmp <- newTempName "sh"
+   h <- openFile tmp WriteMode
+   hPutStrLn h cmd
+   hClose h
+   exit_code <- system ("sh - " ++ tmp) `catchAllIO` 
+		   (\_ -> throwDyn (PhaseFailed phase_name (ExitFailure 1)))
+   removeFile tmp
+#endif
+   return exit_code
diff --git a/ghc/compiler/main/PackageMaintenance.hs b/ghc/compiler/main/PackageMaintenance.hs
index ebfb68f..7efc6bc 100644
--- a/ghc/compiler/main/PackageMaintenance.hs
+++ b/ghc/compiler/main/PackageMaintenance.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: PackageMaintenance.hs,v 1.3 2000/10/26 16:21:02 sewardj Exp $
+-- $Id: PackageMaintenance.hs,v 1.4 2000/12/11 12:30:58 rrt Exp $
 --
 -- GHC Driver program
 --
@@ -78,7 +78,7 @@ maybeRestoreOldConfig conf_file io
         hPutStr stdout "\nWARNING: an error was encountered while the new \n\ 
         	       \configuration was being written.  Attempting to \n\ 
         	       \restore the old configuration... "
-        system ("cp " ++ conf_file ++ ".old " ++ conf_file)
+        kludgedSystem "Restoring old configuration" ("cp " ++ conf_file ++ ".old " ++ conf_file)
         hPutStrLn stdout "done."
 	throw e
     )
@@ -98,7 +98,7 @@ savePackageConfig conf_file = do
     -- mv rather than cp because we've already done an hGetContents
     -- on this file so we won't be able to open it for writing
     -- unless we move the old one out of the way...
-  system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
+  kludgedSystem "Saving package configuration" ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
   hPutStrLn stdout "done."
 
 -----------------------------------------------------------------------------
diff --git a/ghc/compiler/main/TmpFiles.hs b/ghc/compiler/main/TmpFiles.hs
index b0c19d8..872719e 100644
--- a/ghc/compiler/main/TmpFiles.hs
+++ b/ghc/compiler/main/TmpFiles.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: TmpFiles.hs,v 1.11 2000/12/07 08:20:46 simonpj Exp $
+-- $Id: TmpFiles.hs,v 1.12 2000/12/11 12:30:58 rrt Exp $
 --
 -- Temporary file management
 --
@@ -19,6 +19,7 @@ module TmpFiles (
 -- main
 import Config
 import Util
+import DriverUtil ( kludgedSystem )
 
 -- hslibs
 import Exception
@@ -51,7 +52,7 @@ cleanTempFiles verbose = do
 
   let blowAway f =
 	   (do  when verbose (hPutStrLn stderr ("Removing: " ++ f))
-		if '*' `elem` f then system ("rm -f " ++ f) >> return ()
+		if '*' `elem` f then kludgedSystem ("rm -f " ++ f) "Cleaning temp files" >> return ()
 			        else removeFile f)
 	    `catchAllIO`
 	   (\_ -> when verbose (hPutStrLn stderr