[project @ 2001-09-10 12:53:21 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 596e6f2..4bd3284 100644 (file)
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -221,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
 
@@ -254,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
@@ -359,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
@@ -760,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
 
@@ -784,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