[project @ 2004-02-02 10:07:37 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / SysTools.lhs

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index 8c4607a..0908f2c 100644 (file)
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -19,6 +19,7 @@ module SysTools (
        setPgms,
        setPgma,
        setPgml,
+       setPgmDLL,
 #ifdef ILX
        setPgmI,
        setPgmi,
@@ -68,7 +69,7 @@ import DriverPhases     ( isHaskellUserSrcFilename )
 import Config
 import Outputable
 import Panic           ( GhcException(..) )
-import Util            ( global, notNull )
+import Util            ( global, notNull, toArgs )
 import CmdLineOpts     ( dynFlag, verbosity )
 
 import EXCEPTION       ( throwDyn )
@@ -81,7 +82,7 @@ import IO             ( try, catch,
                          openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
                          stderr )
 import Directory       ( doesFileExist, removeFile )
-import List             ( intersperse, partition )
+import List             ( partition )
 
 #include "../includes/config.h"
 
@@ -104,7 +105,7 @@ import Foreign
 import CString         ( CString, peekCString )
 #endif
 
-#if __GLASGOW_HASKELL__ < 601
+#if __GLASGOW_HASKELL__ < 603
 import Foreign         ( withMany, withArray0, nullPtr, Ptr )
 import CForeign                ( CString, withCString, throwErrnoIfMinus1 )
 #else
@@ -434,6 +435,7 @@ setPgmm = writeIORef v_Pgm_m
 setPgms = writeIORef v_Pgm_s
 setPgma = writeIORef v_Pgm_a
 setPgml = writeIORef v_Pgm_l
+setPgmDLL = writeIORef v_Pgm_MkDLL
 #ifdef ILX
 setPgmI = writeIORef v_Pgm_I
 setPgmi = writeIORef v_Pgm_i
@@ -727,8 +729,14 @@ runSomething :: String             -- For -v message
 
 runSomething phase_name pgm args = do
   let real_args = filter notNull (map showOpt args)
-  traceCmd phase_name (concat (intersperse " " (pgm:real_args))) $ do
-  exit_code <- rawSystem pgm real_args
+    -- Don't assume that 'pgm' contains the program path only,
+    -- but split it up and shift any arguments over to the arg vector.
+  let (real_pgm, argv) =
+        case toArgs pgm of
+         []     -> (pgm, real_args) -- let rawSystem be the bearer of bad news..
+         (x:xs) -> (x, xs ++ real_args)
+  traceCmd phase_name (unwords (pgm:real_args)) $ do
+  exit_code <- rawSystem real_pgm argv
   if (exit_code /= ExitSuccess)
        then throwDyn (PhaseFailed phase_name exit_code)
        else return ()
@@ -756,10 +764,19 @@ traceCmd phase_name cmd_line action
 
 -- -----------------------------------------------------------------------------
 -- rawSystem: run an external command
+--
+-- In GHC 6.2.1 there's a correct implementation of rawSystem in the
+-- library System.Cmd.  If we are compiling with an earlier version of
+-- GHC than this, we'd better have a copy of the correct implementation
+-- right here.
+
+-- If you ever alter this code, you must alter 
+--     libraries/base/System/Cmd.hs
+-- at the same time!  There are also exensive comments in System.Cmd
+-- thare are not repeated here -- go look!
 
-#if __GLASGOW_HASKELL__ < 601
 
--- This code is copied from System.Cmd on GHC 6.1.
+#if __GLASGOW_HASKELL__ < 603
 
 rawSystem :: FilePath -> [String] -> IO ExitCode
 
@@ -783,10 +800,9 @@ foreign import ccall "rawSystem" unsafe
 -- a single string.  Command-line parsing is done by the executable
 -- itself.
 rawSystem cmd args = do
-  let cmdline = {-translate-} cmd ++ concat (map ((' ':) . translate) args)
-       -- Urk, don't quote/escape the command name on Windows, because the
-       -- compiler is exceedingly naughty and sometimes uses 'perl "..."' 
-       -- as the command name.
+       -- NOTE: 'cmd' is assumed to contain the application to run _only_,
+       -- as it'll be quoted surrounded in quotes here.
+  let cmdline = translate cmd ++ concat (map ((' ':) . translate) args)
   withCString cmdline $ \pcmdline -> do
     status <- throwErrnoIfMinus1 "rawSystem" (c_rawSystem pcmdline)
     case status of
@@ -794,9 +810,15 @@ rawSystem cmd args = do
        n  -> return (ExitFailure n)
 
 translate :: String -> String
+-- Returns a string wrapped in double-quotes
+-- If the input string starts with double-quote, don't touch it
+-- If not, wrap it in double-quotes and double any backslashes
+--     foo\baz    -->  "foo\\baz"
+--     "foo\baz"  -->  "foo\baz"
+
+translate str@('"':_) = str -- already escaped.
 translate str = '"' : foldr escape "\"" str
   where escape '"'  str = '\\' : '"'  : str
-       escape '\\' str = '\\' : '\\' : str
        escape c    str = c : str
 
 foreign import ccall "rawSystem" unsafe