X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=e2cfbb75784e84b01056a342ef04db1a4bccf552;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=ae40cf4888f4b082fbb9ec849b42541b2e5ffe98;hpb=5cb4bb13a817c44cdc4369c7f82949d9490d69a0;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index ae40cf4..e2cfbb7 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,7 +1,7 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# OPTIONS -fffi -cpp #-} ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.50 2004/02/07 16:37:06 panne Exp $ +-- $Id: Main.hs,v 1.60 2004/08/13 13:11:21 simonmar 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. @@ -11,7 +11,7 @@ -- -- See the documentation in the Users' Guide for more details. -#if __GLASGOW_HASKELL__ >= 504 +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 import System.Console.GetOpt #else import GetOpt @@ -19,14 +19,14 @@ import GetOpt import System (getProgName, getArgs, ExitCode(..), exitWith, system) 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) #if defined(mingw32_HOST_OS) import Foreign -#if __GLASGOW_HASKELL__ >= 504 +#if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 import Foreign.C.String #else import CString @@ -478,14 +478,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 @@ -494,12 +495,17 @@ output flags name toks = do let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" - progName = outDir++outBase++"_hsc_make" ++ EXEEXT + progName = outDir++outBase++"_hsc_make" +#if defined(mingw32_HOST_OS) +-- 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 = dosifyPath ("./" ++ progName) @@ -515,7 +521,8 @@ output flags name toks = do fixChar c | isAlphaNum c = toUpper c | otherwise = '_' - -- try locating GHC..on Win32, look in the vicinity of hsc2hs. + -- 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 @@ -527,6 +534,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 @@ -546,7 +563,10 @@ 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 @@ -578,17 +598,16 @@ output flags name toks = do _ -> 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" @@ -629,20 +648,20 @@ 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++"\"") @@ -700,12 +719,12 @@ 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 @@ -726,12 +745,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" _ -> "" @@ -745,13 +764,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" @@ -829,7 +848,7 @@ getExecDir cmd where len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32. -foreign import stdcall "GetModuleFileNameA" unsafe +foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else