X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=6f73313d09a2bf3c1ba179cd491544d9d860d06a;hb=d2fcb5a672c1670ed06910e90bcfbab344aa5c27;hp=f9138cdf2e0b126bad36de3771a72f66351ac744;hpb=c447b9e272c0b2cfc3a15cc890e40daf7a500b8d;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index f9138cd..6f73313 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -278,30 +278,21 @@ initSysTools minusB_args
 	  -- 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.
+	  --   form.
 	; IO.try (do
 	        let len = (2048::Int)
 		buf  <- mallocArray len
 		ret  <- getTempPath len buf
 		tdir <-
 		  if ret == 0 then do
-		      -- failed, consult TEMP.
+		      -- failed, consult TMPDIR.
  	             free buf
-		     getEnv "TMP"
+		     getEnv "TMPDIR"
 		   else do
 		     s <- peekCString buf
 		     free 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 ())
+		setTmpDir tdir)
 #endif
 
 	-- Check that the package config exists
@@ -627,7 +618,36 @@ GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
 \end{code}
 
 \begin{code}
-setTmpDir dir = writeIORef v_TmpDir dir
+setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
+    where
+#if !defined(mingw32_HOST_OS)
+     canonicalise p = normalisePath p
+#else
+	-- Canonicalisation of temp path under win32 is a bit more
+	-- involved: (a) strip trailing slash, 
+	-- 	     (b) normalise slashes
+	--	     (c) just in case, if there is a prefix /cygdrive/x/, change to x:
+	-- 
+     canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
+
+        -- if we're operating under cygwin, and TMP/TEMP is of
+	-- the form "/cygdrive/drive/path", translate this to
+	-- "drive:/path" (as GHC isn't a cygwin app and doesn't
+	-- understand /cygdrive paths.)
+     xltCygdrive path
+      | "/cygdrive/" `isPrefixOf` path = 
+	  case drop (length "/cygdrive/") path of
+	    drive:xs@('/':_) -> drive:':':xs
+	    _ -> path
+      | otherwise = path
+
+        -- strip the trailing backslash (awful, but we only do this once).
+     removeTrailingSlash path = 
+       case last path of
+         '/'  -> init path
+         '\\' -> init path
+         _    -> path
+#endif
 
 cleanTempFiles :: Int -> IO ()
 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
@@ -745,7 +765,7 @@ rawSystem cmd args =
             0  -> return ExitSuccess
             n  -> return (ExitFailure n)
 
-foreign import ccall unsafe "rawSystem"
+foreign import ccall "rawSystem" unsafe
   c_rawSystem :: CString -> Ptr CString -> IO Int
 
 #else
@@ -770,7 +790,7 @@ translate str = '"' : foldr escape "\"" str
 	escape '\\' str = '\\' : '\\' : str
 	escape c    str = c : str
 
-foreign import ccall unsafe "rawSystem"
+foreign import ccall "rawSystem" unsafe
   c_rawSystem :: CString -> IO Int
 
 #endif