X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=4bd328498e9504dfbff5e2f116417b877429e8c7;hb=ec2ccca277f5779f4699aa27f9628b5578c42924;hp=fdda9ddfb773483d29cd87abbd11dc757c1d846e;hpb=784411198acb82de85f15b524b661e549a692e4b;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index fdda9dd..4bd3284 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -1,5 +1,4 @@
 -----------------------------------------------------------------------------
--- $Id: SysTools.lhs,v 1.53 2001/08/16 14:43:59 rrt Exp $
 --
 -- (c) The University of Glasgow 2001
 --
@@ -76,12 +75,20 @@ import List		( isPrefixOf )
 import MarshalArray
 #endif
 
+-- This is a kludge for bootstrapping with 4.08.X.  Given that
+-- all distributed compilers >= 5.0 will be compiled with themselves.
+-- I don't think this kludge is a problem.  And we have to start
+-- building with >= 5.0 on Win32 anyway.
+#if __GLASGOW_HASKELL__ > 408
 -- use the line below when we can be sure of compiling with GHC >=
 -- 5.02, and remove the implementation of rawSystem at the end of this
 -- file
 import PrelIOBase -- this can be removed when SystemExts is used
 import CError     ( throwErrnoIfMinus1 ) -- as can this
 -- import SystemExts       ( rawSystem )
+#else
+import System		( system )
+#endif
 
 #include "HsVersions.h"
 
@@ -214,7 +221,7 @@ initSysTools minusB_args
 		-- NB: top_dir is assumed to be in standard Unix format '/' separated
 
 	; let installed, installed_bin :: FilePath -> FilePath
-              installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
+              installed_bin pgm   =  pgmPath top_dir pgm
 	      installed     file  =  pgmPath top_dir file
 	      inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
 
@@ -247,6 +254,34 @@ initSysTools minusB_args
 	      	     setTmpDir dir
 	      	     return ()
                  )
+#else
+	  -- On Win32, consult GetTempPath() for a temp dir.
+	  --  => it first tries TMP, TEMP, then finally the
+	  --   Windows directory(!). The directory is in short-path
+	  --   form and *does* have a trailing backslash.
+	; IO.try (do
+	        let len = (2048::Int)
+		buf  <- mallocArray len
+		ret  <- getTempPath len buf
+		tdir <-
+		  if ret == 0 then do
+		      -- failed, consult TEMP.
+ 	             destructArray len buf
+		     getEnv "TMP"
+		   else do
+		     s <- peekCString buf
+		     destructArray len buf
+		     return s
+		let
+	  	  -- strip the trailing backslash (awful, but 
+		  -- we only do this once).
+		  tmpdir =
+	            case last tdir of
+		      '/'  -> init tdir
+		      '\\' -> init tdir
+		      _   -> tdir
+		setTmpDir tmpdir
+		return ())
 #endif
 
 	-- Check that the package config exists
@@ -352,6 +387,10 @@ initSysTools minusB_args
 
 	; return ()
 	}
+
+#if defined(mingw32_TARGET_OS)
+foreign import stdcall "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
+#endif
 \end{code}
 
 setPgm is called when a command-line option like
@@ -436,16 +475,17 @@ between filepaths and 'other stuff'. [The reason being, of course, that
 this type gives us a handle on transforming filenames, and filenames only,
 to whatever format they're expected to be on a particular platform.]
 
-
 \begin{code}
 data Option
- = FileOption String
+ = FileOption -- an entry that _contains_ filename(s) / filepaths.
+              String  -- a non-filepath prefix that shouldn't be transformed (e.g., "/out=" 
+ 	      String  -- the filepath/filename portion
  | Option     String
  
 showOptions :: [Option] -> String
 showOptions ls = unwords (map (quote.showOpt) ls)
  where
-   showOpt (FileOption f) = dosifyPath f
+   showOpt (FileOption pre f) = pre ++ dosifyPath f
    showOpt (Option s)     = s
 
 #if defined(mingw32_TARGET_OS)
@@ -510,7 +550,7 @@ runMkDLL args = do p <- readIORef v_Pgm_MkDLL
 
 touch :: String -> String -> IO ()
 touch purpose arg =  do p <- readIORef v_Pgm_T
-			runSomething purpose p [FileOption arg]
+			runSomething purpose p [FileOption "" arg]
 
 copy :: String -> String -> String -> IO ()
 copy purpose from to = do
@@ -752,9 +792,6 @@ subst a b ls = map (\ x -> if x == a then b else x) ls
 slash		 :: String -> String -> String
 absPath, relPath :: [String] -> String
 
-isSlash '/'   = True
-isSlash other = False
-
 relPath [] = ""
 relPath xs = foldr1 slash xs
 
@@ -776,16 +813,16 @@ slash s1 s2 = s1 ++ ('/' : s2)
 
 #if defined(mingw32_TARGET_OS)
 getExecDir :: IO (Maybe String)
-getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
-		buf <- mallocArray (fromIntegral len)
+getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
+		buf <- mallocArray len
 		ret <- getModuleFileName nullAddr buf len
-		if ret == 0 then return Nothing
+		if ret == 0 then destructArray len buf >> return Nothing
 		            else do s <- peekCString buf
-				    destructArray (fromIntegral len) buf
+				    destructArray len buf
 				    return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
 
 
-foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
+foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int -> IO Int32
 #else
 getExecDir :: IO (Maybe String) = do return Nothing
 #endif
@@ -798,6 +835,7 @@ getProcessID = Posix.getProcessID
 #endif
 
 rawSystem :: String -> IO ExitCode
+#if __GLASGOW_HASKELL__ > 408
 rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
 rawSystem cmd =
   withCString cmd $ \s -> do
@@ -807,5 +845,9 @@ rawSystem cmd =
         n  -> return (ExitFailure n)
 
 foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int
+#else
+rawSystem = System.system
+#endif
+
 
 \end{code}