X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=4b39e4a7bb5c8fe8070c08b228bae3480360fd18;hb=95c7525626b8802ec21036a82037e933caf0b17f;hp=f90a89c0db47b0765d4f4c213a018abea1c7f2d6;hpb=ca9945d0b186f0062e58786aa472f7ee3339ba9a;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index f90a89c..4b39e4a 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,8 +1,6 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fffi -cpp #-} ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.49 2003/10/01 16:45:10 sof 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,26 +9,26 @@ -- -- See the documentation in the Users' Guide for more details. -#if __GLASGOW_HASKELL__ >= 504 +#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 Config -import System (getProgName, getArgs, ExitCode(..), exitWith, system) +import System (getProgName, getArgs, ExitCode(..), exitWith) import Directory (removeFile,doesFileExist) -import Monad (MonadPlus(..), liftM, liftM2, when, unless) +import Monad (MonadPlus(..), liftM, liftM2, when) import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord) import List (intersperse, isSuffixOf) import IO (hPutStr, hPutStrLn, stderr) -#include "../../includes/config.h" - -#ifdef mingw32_HOST_OS +#if defined(mingw32_HOST_OS) && !__HUGS__ import Foreign - -#if __GLASGOW_HASKELL__ >= 504 +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 import Foreign.C.String #else import CString @@ -38,9 +36,31 @@ import CString #endif +#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 ) +#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 +import System ( system ) +#endif +#endif version :: String -version = "hsc2hs version 0.65\n" +version = "hsc2hs version 0.66\n" data Flag = Help @@ -56,6 +76,7 @@ data Flag | Output String | Verbose +template_flag :: Flag -> Bool template_flag (Template _) = True template_flag _ = False @@ -108,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 @@ -131,8 +156,8 @@ main = do where isHelp Help = True; isHelp _ = False isVersion Version = True; isVersion _ = False - (files@(_:_), []) -> mapM_ (processFile flags_w_tpl) files - (_, errs) -> die (concat errs ++ usageInfo header options) + ((_:_), []) -> mapM_ (processFile flags_w_tpl) files + (_, _ ) -> die (concat errs ++ usageInfo header options) getProgramName :: IO String getProgramName = liftM (`withoutSuffix` "-bin") getProgName @@ -482,14 +507,15 @@ output :: [Flag] -> String -> [Token] -> IO () output flags name toks = do (outName, outDir, outBase) <- case [f | Output f <- flags] of - [] - | not (null ext) && - last ext == 'c' -> return (dir++base++init ext, dir, base) - | ext == ".hs" -> return (dir++base++"_out.hs", dir, base) - | otherwise -> return (dir++base++".hs", dir, base) - where - (dir, file) = splitName name - (base, ext) = splitExt file + [] -> if not (null ext) && last ext == 'c' + then return (dir++base++init ext, dir, base) + else + if ext == ".hs" + then return (dir++base++"_out.hs", dir, base) + else return (dir++base++".hs", dir, base) + where + (dir, file) = splitName name + (base, ext) = splitExt file [f] -> let (dir, file) = splitName f (base, _) = splitExt file @@ -498,15 +524,20 @@ output flags name toks = do let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" - progName = outDir++outBase++"_hsc_make" ++ progNameSuffix + progName = outDir++outBase++"_hsc_make" +#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" +#endif outHFile = outBase++"_hsc.h" outHName = outDir++outHFile outCName = outDir++outBase++"_hsc.c" - beVerbose = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags + beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags let execProgName - | null outDir = '.':pathSep:progName + | null outDir = dosifyPath ("./" ++ progName) | otherwise = progName let specials = [(pos, key, arg) | Special pos key arg <- toks] @@ -519,7 +550,19 @@ output flags name toks = do fixChar c | isAlphaNum c = toUpper c | otherwise = '_' - -- try locating GHC..on Win32, look in the vicinity of hsc2hs. +#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 mb <- getExecDir "bin/hsc2hs.exe" case mb of @@ -531,6 +574,16 @@ output flags name toks = do then return ghc_path else return def + -- On a Win32 installation we execute the hsc2hs binary directly, + -- with no --cc flags, so we'll call locateGhc here, which will + -- succeed, via getExecDir. + -- + -- On a Unix installation, we'll run the wrapper script hsc2hs.sh + -- (called plain hsc2hs in the installed tree), which will pass + -- a suitable C compiler via --cc + -- + -- The in-place installation always uses the wrapper script, + -- (called hsc2hs-inplace, generated from hsc2hs.sh) compiler <- case [c | Compiler c <- flags] of [] -> locateGhc "ghc" [c] -> return c @@ -540,6 +593,7 @@ output flags name toks = do [] -> locateGhc compiler [l] -> return l _ -> onlyOne "linker" +#endif writeFile cProgName $ concatMap outFlagHeaderCProg flags++ @@ -550,49 +604,53 @@ output flags name toks = do concatMap outTokenHs toks++ " return 0;\n}\n" - unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess + -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code, + -- so we use something slightly more complicated. :-P + when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $ + exitWith ExitSuccess - compilerStatus <- systemL beVerbose $ - compiler++ - " -c"++ - concat [" "++f | CompFlag f <- flags]++ - " "++cProgName++ - " -o "++oProgName + compilerStatus <- rawSystemL beVerbose compiler + ( ["-c"] + ++ [f | CompFlag f <- flags] + ++ [cProgName] + ++ ["-o", oProgName] + ) + case compilerStatus of e@(ExitFailure _) -> exitWith e _ -> return () removeFile cProgName - linkerStatus <- systemL beVerbose $ - linker++ - concat [" "++f | LinkFlag f <- flags]++ - " "++oProgName++ - " -o "++progName + linkerStatus <- rawSystemL beVerbose linker + ( [f | LinkFlag f <- flags] + ++ [oProgName] + ++ ["-o", progName] + ) + case linkerStatus of e@(ExitFailure _) -> exitWith e _ -> return () removeFile oProgName - progStatus <- systemL beVerbose (execProgName++" >"++outName) + progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName removeFile progName case progStatus of e@(ExitFailure _) -> exitWith e _ -> return () when needsH $ writeFile outHName $ - "#ifndef "++includeGuard++"\n\ - \#define "++includeGuard++"\n\ - \#if " ++ - "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ - \#include \n\ - \#endif\n\ - \#include \n\ - \#if __NHC__\n\ - \#undef HsChar\n\ - \#define HsChar int\n\ - \#endif\n"++ + "#ifndef "++includeGuard++"\n" ++ + "#define "++includeGuard++"\n" ++ + "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ + "#include \n" ++ + "#endif\n" ++ + "#include \n" ++ + "#if __NHC__\n" ++ + "#undef HsChar\n" ++ + "#define HsChar int\n" ++ + "#endif\n" ++ concatMap outFlagH flags++ concatMap outTokenH specials++ "#endif\n" @@ -603,10 +661,29 @@ output flags name toks = do -- NB. outHFile not outHName; works better when processed -- by gcc or mkdependC. -systemL :: Bool -> String -> IO ExitCode -systemL flg s = do - when flg (hPutStrLn stderr ("Executing: " ++ s)) - system s +rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode +rawSystemL flg prog args = do + let cmdLine = prog++" "++unwords args + when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) +#ifndef HAVE_rawSystem + system cmdLine +#else + rawSystem prog args +#endif + +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") @@ -614,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 _ = "" @@ -633,30 +710,30 @@ outHeaderCProg (pos, key, arg) = case key of (header, _:body) -> case break isSpace header of (name, args) -> outCLine pos++ - "#define hsc_"++name++"("++dropWhile isSpace args++") \ - \printf ("++joinLines body++");\n" + "#define hsc_"++name++"("++dropWhile isSpace args++") " ++ + "printf ("++joinLines body++");\n" _ -> "" - where + where joinLines = concat . intersperse " \\\n" . lines outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String outHeaderHs flags inH toks = "#if " ++ - "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ - \ printf (\"{-# OPTIONS -optc-D" ++ - "__GLASGOW_HASKELL__=%d #-}\\n\", \ - \__GLASGOW_HASKELL__);\n\ - \#endif\n"++ + "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ + " printf (\"{-# OPTIONS -optc-D" ++ + "__GLASGOW_HASKELL__=%d #-}\\n\", " ++ + "__GLASGOW_HASKELL__);\n" ++ + "#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" @@ -669,13 +746,27 @@ 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 text) = - case break (== '\n') text of - (all, []) -> outText all +outTokenHs (Text pos txt) = + case break (== '\n') txt of + (allTxt, []) -> outText allTxt (first, _:rest) -> outText (first++"\n")++ outHsLine pos++ @@ -704,19 +795,19 @@ outEnum arg = (enum, rest) -> let this = case break (== '=') $ dropWhile isSpace enum of (name, []) -> - " hsc_enum ("++t++", "++f++", \ - \hsc_haskellize (\""++name++"\"), "++ + " hsc_enum ("++t++", "++f++", " ++ + "hsc_haskellize (\""++name++"\"), "++ name++");\n" (hsName, _:cName) -> - " hsc_enum ("++t++", "++f++", \ - \printf (\"%s\", \""++hsName++"\"), "++ + " hsc_enum ("++t++", "++f++", " ++ + "printf (\"%s\", \""++hsName++"\"), "++ cName++");\n" in this++enums rest in enums afterF 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 _ = "" @@ -730,12 +821,12 @@ outTokenH (pos, key, arg) = 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" 'i':'n':'l':'i':'n':'e':' ':_ -> - "#ifdef __GNUC__\n\ - \extern\n\ - \#endif\n"++ + "#ifdef __GNUC__\n" ++ + "extern\n" ++ + "#endif\n"++ arg++"\n" _ -> "extern "++header++";\n" - where header = takeWhile (\c -> c /= '{' && c /= '=') arg + where header = takeWhile (\c -> c /= '{' && c /= '=') arg _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" _ -> "" @@ -749,13 +840,13 @@ outTokenC (pos, key, arg) = case span (\c -> c /= '{' && c /= '=') arg' of (header, body) -> outCLine pos++ - "#ifndef __GNUC__\n\ - \extern inline\n\ - \#endif\n"++ + "#ifndef __GNUC__\n" ++ + "extern inline\n" ++ + "#endif\n"++ header++ - "\n#ifndef __GNUC__\n\ - \;\n\ - \#else\n"++ + "\n#ifndef __GNUC__\n" ++ + ";\n" ++ + "#else\n"++ body++ "\n#endif\n" _ -> outCLine pos++arg++"\n" @@ -780,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 @@ -805,36 +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 +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 -#if defined(mingw32_HOST_OS) -subst a b ls = map (\ x -> if x == a then b else x) ls -unDosifyPath xs = subst '\\' '/' xs -dosifyPath xs = subst '/' '\\' xs +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. - -foreign import stdcall "GetModuleFileNameA" unsafe - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 - +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 #else -dosifyPath xs = xs - -getExecDir :: String -> IO (Maybe String) -getExecDir s = do return Nothing +getExecPath = return Nothing #endif