X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=4b39e4a7bb5c8fe8070c08b228bae3480360fd18;hb=95c7525626b8802ec21036a82037e933caf0b17f;hp=b93728b0e0a7efb2a9d6dae23777f9cff6c5c0be;hpb=de3edc0771a914d641fa9f3d22e27cb321e0625c;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index b93728b..4b39e4a 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,8 +1,6 @@ {-# OPTIONS -fffi -cpp #-} ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.64 2005/01/06 10:44:14 malcolm Exp $ --- -- Program for converting .hsc files to .hs files, by converting the -- file into a C program which is run to generate the Haskell source. -- Certain items known only to the C compiler can then be used in @@ -11,20 +9,24 @@ -- -- See the documentation in the Users' Guide for more details. -#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 +#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) +#include "../../includes/ghcconfig.h" +#endif + +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__ import System.Console.GetOpt #else import GetOpt #endif -import System (getProgName, getArgs, ExitCode(..), exitWith, system) +import System (getProgName, getArgs, ExitCode(..), exitWith) import Directory (removeFile,doesFileExist) import Monad (MonadPlus(..), liftM, liftM2, when) import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord) import List (intersperse, isSuffixOf) import IO (hPutStr, hPutStrLn, stderr) -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) && !__HUGS__ import Foreign #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 import Foreign.C.String @@ -34,12 +36,27 @@ import CString #endif -#if __GLASGOW_HASKELL__ >= 603 +#if __GLASGOW_HASKELL__ >= 604 +import System.Process ( runProcess, waitForProcess ) +import System.IO ( openFile, IOMode(..), hClose ) +#define HAVE_runProcess +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) import Compat.RawSystem ( rawSystem ) -#elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600 +#define HAVE_rawSystem +#elif __HUGS__ || __NHC__ >= 117 import System.Cmd ( rawSystem ) +#define HAVE_rawSystem +#endif + +#if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem) +-- we need system +#if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600 +import System.Cmd ( system ) #else -rawSystem prog args = system (prog++" "++unwords args) +import System ( system ) +#endif #endif version :: String @@ -112,12 +129,16 @@ main = do -- If there is no Template flag explicitly specified, try -- to find one by looking near the executable. This only - -- works on Win32 (getExecDir). On Unix, there's a wrapper + -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper -- script which specifies an explicit template flag. flags_w_tpl <- if any template_flag flags then return flags else +#ifdef __HUGS__ + do mb_path <- getExecDir "/Main.hs" +#else do mb_path <- getExecDir "/bin/hsc2hs.exe" +#endif add_opt <- case mb_path of Nothing -> return id @@ -504,7 +525,7 @@ output flags name toks = do let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" progName = outDir++outBase++"_hsc_make" -#if defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor -- via GHC has changed a few times, so this seems to be the only way... :-P * * * ++ ".exe" @@ -529,6 +550,17 @@ output flags name toks = do fixChar c | isAlphaNum c = toUpper c | otherwise = '_' +#ifdef __HUGS__ + compiler <- case [c | Compiler c <- flags] of + [] -> return "gcc" + [c] -> return c + _ -> onlyOne "compiler" + + linker <- case [l | Linker l <- flags] of + [] -> return compiler + [l] -> return l + _ -> onlyOne "linker" +#else -- Try locating GHC..on Win32, look in the vicinity of hsc2hs. -- Returns a native-format path locateGhc def = do @@ -561,6 +593,7 @@ output flags name toks = do [] -> locateGhc compiler [l] -> return l _ -> onlyOne "linker" +#endif writeFile cProgName $ concatMap outFlagHeaderCProg flags++ @@ -601,7 +634,7 @@ output flags name toks = do _ -> return () removeFile oProgName - progStatus <- systemL beVerbose (execProgName++" >"++outName) + progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName removeFile progName case progStatus of e@(ExitFailure _) -> exitWith e @@ -628,15 +661,29 @@ output flags name toks = do -- NB. outHFile not outHName; works better when processed -- by gcc or mkdependC. -rawSystemL :: Bool -> String -> [String] -> IO ExitCode +rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode rawSystemL flg prog args = do - when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args)) + let cmdLine = prog++" "++unwords args + when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) +#ifndef HAVE_rawSystem + system cmdLine +#else rawSystem prog args +#endif -systemL :: Bool -> String -> IO ExitCode -systemL flg s = do - when flg (hPutStrLn stderr ("Executing: " ++ s)) - system s +rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode +rawSystemWithStdOutL flg prog args outFile = do + let cmdLine = prog++" "++unwords args++" >"++outFile + when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) +#ifndef HAVE_runProcess + system cmdLine +#else + hOut <- openFile outFile WriteMode + process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing + res <- waitForProcess process + hClose hOut + return res +#endif onlyOne :: String -> IO a onlyOne what = die ("Only one "++what++" may be specified\n") @@ -644,7 +691,7 @@ onlyOne what = die ("Only one "++what++" may be specified\n") outFlagHeaderCProg :: Flag -> String outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n" outFlagHeaderCProg (Include f) = "#include "++f++"\n" -outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n" +outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n" outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n" outFlagHeaderCProg _ = "" @@ -679,14 +726,14 @@ outHeaderHs flags inH toks = "#endif\n"++ case inH of Nothing -> concatMap outFlag flags++concatMap outSpecial toks - Just f -> outOption ("-#include \""++f++"\"") + Just f -> outInclude ("\""++f++"\"") where - outFlag (Include f) = outOption ("-#include "++f) + outFlag (Include f) = outInclude f outFlag (Define n Nothing) = outOption ("-optc-D"++n) outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v) outFlag _ = "" outSpecial (pos, key, arg) = case key of - "include" -> outOption ("-#include "++arg) + "include" -> outInclude arg "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg) | otherwise -> "" _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" @@ -699,8 +746,22 @@ outHeaderHs flags inH toks = toOptD arg = case break isSpace arg of (name, "") -> name (name, _:value) -> name++'=':dropWhile isSpace value - outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++ - showCString s++"\");\n" + outOption s = + "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ + " printf (\"{-# OPTIONS %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#else\n"++ + " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#endif\n" + outInclude s = + "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ + " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#else\n"++ + " printf (\"{-# INCLUDE %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#endif\n" outTokenHs :: Token -> String outTokenHs (Text pos txt) = @@ -746,7 +807,7 @@ outEnum arg = outFlagH :: Flag -> String outFlagH (Include f) = "#include "++f++"\n" -outFlagH (Define n Nothing) = "#define "++n++"\n" +outFlagH (Define n Nothing) = "#define "++n++" 1\n" outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n" outFlagH _ = "" @@ -810,7 +871,7 @@ outCLine (SourcePos name line) = outHsLine :: SourcePos -> String outHsLine (SourcePos name line) = " hsc_line ("++show (line + 1)++", \""++ - showCString (snd (splitName name))++"\");\n" + showCString name++"\");\n" showCString :: String -> String showCString = concatMap showCChar @@ -835,40 +896,43 @@ showCString = concatMap showCChar ----------------------------------------- --- Cut and pasted from ghc/compiler/SysTools +-- Modified version from ghc/compiler/SysTools -- Convert paths foo/baz to foo\baz on Windows -dosifyPath :: String -> String -#if defined(mingw32_HOST_OS) -dosifyPath xs = subst '/' '\\' xs - -unDosifyPath :: String -> String -unDosifyPath xs = subst '\\' '/' xs +subst :: Char -> Char -> String -> String +#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) +subst a b = map (\x -> if x == a then b else x) +#else +subst _ _ = id +#endif -subst :: Eq a => a -> a -> [a] -> [a] -subst a b ls = map (\ x -> if x == a then b else x) ls +dosifyPath :: String -> String +dosifyPath = subst '/' '\\' -getExecDir :: String -> IO (Maybe String) -- (getExecDir cmd) returns the directory in which the current -- executable, which should be called 'cmd', is running -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd, -- you'll get "/a/b/c" back as the result -getExecDir cmd - = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else do s <- peekCString buf - return (Just (reverse (drop (length cmd) - (reverse (unDosifyPath s))))) - where - len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. +getExecDir :: String -> IO (Maybe String) +getExecDir cmd = + getExecPath >>= maybe (return Nothing) removeCmdSuffix + where unDosifyPath = subst '\\' '/' + initN n = reverse . drop n . reverse + removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath + +getExecPath :: IO (Maybe String) +#if defined(__HUGS__) +getExecPath = liftM Just getProgName +#elif defined(mingw32_HOST_OS) +getExecPath = + allocaArray len $ \buf -> do + ret <- getModuleFileName nullPtr buf len + if ret == 0 then return Nothing + else liftM Just $ peekCString buf + where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 - + getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -dosifyPath xs = xs - -getExecDir :: String -> IO (Maybe String) -getExecDir _ = return Nothing +getExecPath = return Nothing #endif