X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FSysTools.lhs;h=1ed190c57b2e945e7d0f5470a87f392f24c918a4;hb=5e3f005d3012472e422d4ffd7dca5c21a80fca80;hp=fee219f462f20c766855a475cfbdc3786de01c99;hpb=7362ac37db0f07335e0bbc9d83189e5a4859fb3f;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index fee219f..1ed190c 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -19,6 +19,7 @@ module SysTools (
 
 	-- Interface to system tools
 	runUnlit, runCpp, runCc, -- [Option] -> IO ()
+	runPp,                   -- [Option] -> IO ()
 	runMangle, runSplit,	 -- [Option] -> IO ()
 	runAs, runLink,		 -- [Option] -> IO ()
 	runMkDLL,
@@ -53,10 +54,15 @@ import DriverUtil
 import Config
 import Outputable
 import Panic		( progName, GhcException(..) )
-import Util		( global )
+import Util		( global, dropList )
 import CmdLineOpts	( dynFlag, verbosity )
 
-import Exception	( throwDyn, catchAllIO )
+import Exception	( throwDyn )
+#if __GLASGOW_HASKELL__ > 408
+import qualified Exception ( catch )
+#else
+import Exception        ( catchAllIO )
+#endif
 import IO
 import Directory	( doesFileExist, removeFile )
 import IOExts		( IORef, readIORef, writeIORef )
@@ -90,8 +96,16 @@ import CError     ( throwErrnoIfMinus1 ) -- as can this
 import System		( system )
 #endif
 
+
 #include "HsVersions.h"
 
+-- Make catch work on older GHCs
+#if __GLASGOW_HASKELL__ > 408
+myCatch = Exception.catch
+#else
+myCatch = catchAllIO
+#endif
+
 \end{code}
 
 
@@ -169,6 +183,7 @@ All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
 \begin{code}
 GLOBAL_VAR(v_Pgm_L,   	error "pgm_L",   String)	-- unlit
 GLOBAL_VAR(v_Pgm_P,   	error "pgm_P",   String)	-- cpp
+GLOBAL_VAR(v_Pgm_F,   	error "pgm_F",   String)	-- pp
 GLOBAL_VAR(v_Pgm_c,   	error "pgm_c",   String)	-- gcc
 GLOBAL_VAR(v_Pgm_m,   	error "pgm_m",   String)	-- asm code mangler
 GLOBAL_VAR(v_Pgm_s,   	error "pgm_s",   String)	-- asm code splitter
@@ -221,7 +236,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
 
@@ -277,6 +292,7 @@ initSysTools minusB_args
 		  -- we only do this once).
 		  tmpdir =
 	            case last tdir of
+		      '/'  -> init tdir
 		      '\\' -> init tdir
 		      _   -> tdir
 		setTmpDir tmpdir
@@ -371,6 +387,7 @@ initSysTools minusB_args
 
 	; writeIORef v_Pgm_L   	 	   unlit_path
 	; writeIORef v_Pgm_P   	 	   cpp_path
+	; writeIORef v_Pgm_F               ""
 	; writeIORef v_Pgm_c   	 	   gcc_path
 	; writeIORef v_Pgm_m   	 	   mangle_path
 	; writeIORef v_Pgm_s   	 	   split_path
@@ -402,6 +419,7 @@ setPgm :: String -> IO ()
 -- So the first character says which program to override
 
 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
+setPgm ('F' : pgm) = writeIORef v_Pgm_F pgm
 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
@@ -500,7 +518,7 @@ showOptions ls = unwords (map (quote.showOpt) ls)
 %************************************************************************
 %*									*
 \subsection{Running an external program}
-n%*									*
+%*									*
 %************************************************************************
 
 
@@ -513,6 +531,10 @@ runCpp :: [Option] -> IO ()
 runCpp args =   do p <- readIORef v_Pgm_P
 		   runSomething "C pre-processor" p args
 
+runPp :: [Option] -> IO ()
+runPp args =   do p <- readIORef v_Pgm_F
+		  runSomething "Haskell pre-processor" p args
+
 runCc :: [Option] -> IO ()
 runCc args =   do p <- readIORef v_Pgm_c
 	          runSomething "C Compiler" p args
@@ -640,7 +662,7 @@ removeTmpFiles verb fs
 	     ("Deleting: " ++ unwords fs)
 	     (mapM_ rm fs)
   where
-    rm f = removeFile f `catchAllIO` 
+    rm f = removeFile f `myCatch` 
 		(\_ignored -> 
 		    when (verb >= 2) $
 		      hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
@@ -707,7 +729,7 @@ traceCmd phase_name cmd_line action
 	; unless n $ do {
 
 	   -- And run it!
-	; action `catchAllIO` handle_exn verb
+	; action `myCatch` handle_exn verb
 	}}
   where
     handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
@@ -767,7 +789,7 @@ dosifyPath stuff
   cygdrive_prefix = "/cygdrive/"
 
   real_stuff
-    | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
+    | cygdrive_prefix `isPrefixOf` stuff = dropList cygdrive_prefix stuff
     | otherwise = stuff
    
 #else
@@ -818,7 +840,7 @@ getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
 		if ret == 0 then destructArray len buf >> return Nothing
 		            else do s <- peekCString buf
 				    destructArray len buf
-				    return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
+				    return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
 
 
 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int -> IO Int32