X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=ee30d09ad455df6865790eb5dbc295662bd238fd;hb=c63aaee42e3e95276861121286eefce511cd1343;hp=b888f3344c08d7f3d5bb756de44c7f3cf92cbb51;hpb=3b4e398466c0a8b037e112d40bb20b77a9b42bf0;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index b888f33..ee30d09 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,5 @@ ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.29 2001/03/29 17:56:18 qrczak Exp $ +-- $Id: Main.hs,v 1.41 2002/10/27 10:38:33 mthomas 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. @@ -9,14 +9,41 @@ -- -- See the documentation in the Users' Guide for more details. +#if __GLASGOW_HASKELL__ >= 504 +import System.Console.GetOpt +#else import GetOpt -import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure) -import KludgedSystem (system, defaultCompiler) +#endif + +import Config +import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure, system) import Directory (removeFile) import Monad (MonadPlus(..), liftM, liftM2, when, unless) import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord) import List (intersperse) +#include "../../includes/config.h" + +#ifdef mingw32_HOST_OS +-- import Win32DLL +import Foreign.C.String (CString, peekCString) +import Foreign.C.Types +import Foreign.Ptr (nullPtr) +import Foreign.Marshal.Alloc (mallocBytes, free) + +foreign import stdcall "GetModuleHandle" c_GetModuleHandle :: CString -> IO CUInt +foreign import stdcall "GetModuleFileName" c_GetModuleFilename :: CUInt -> CString -> CUInt -> IO CUInt + +ourName :: IO String +ourName = do h <- c_GetModuleHandle nullPtr + cstr <- mallocBytes cstr_len + rv <- c_GetModuleFilename h cstr (CUInt (fromIntegral cstr_len)) + str <- peekCString cstr + free cstr + return str + where cstr_len = 512 +#endif + version :: String version = "hsc2hs-0.65" @@ -52,19 +79,26 @@ options = [ Option "I" [] (ReqArg (CompFlag . ("-I"++)) "DIR") "passed to the C compiler", Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker", - Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c", Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source", Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source", Option "o" ["output"] (ReqArg Output "FILE") "name of main output file", Option "" ["help"] (NoArg Help) "display this help and exit", - Option "" ["version"] (NoArg Version) "output version information and exit"] + Option "" ["version"] (NoArg Version) "output version information and exit", + Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"] main :: IO () main = do prog <- getProgName let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]" args <- getArgs - case getOpt Permute options args of + let opts@(flags, files, errs) = getOpt Permute options args +#ifdef mingw32_HOST_OS + n <- ourName + let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h" + let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags + let opts = (fflags, files, errs) +#endif + case opts of (flags, _, _) | any isHelp flags -> putStrLn (usageInfo header options) | any isVersion flags -> putStrLn version @@ -79,14 +113,25 @@ main = do exitFailure processFile :: [Flag] -> String -> IO () -processFile flags name = do - s <- readFile name - case parser of - Parser p -> case p (SourcePos name 1) s of - Success _ _ _ toks -> output flags name toks - Failure (SourcePos name' line) msg -> do - putStrLn (name'++":"++show line++": "++msg) - exitFailure +processFile flags name + = do let file_name = dosifyPath name + s <- readFile file_name + case parser of + Parser p -> case p (SourcePos file_name 1) s of + Success _ _ _ toks -> output flags file_name toks + Failure (SourcePos name' line) msg -> do + putStrLn (name'++":"++show line++": "++msg) + exitFailure + +------------------------------------------------------------------------ +-- Convert paths foo/baz to foo\baz on Windows + +#if defined(mingw32_HOST_OS) +subst a b ls = map (\ x -> if x == a then b else x) ls +dosifyPath xs = subst '/' '\\' xs +#else +dosifyPath xs = xs +#endif ------------------------------------------------------------------------ -- A deterministic parser which remembers the text which has been parsed. @@ -430,12 +475,13 @@ output flags name toks = do let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" - progName = outDir++outBase++"_hsc_make" - outHName = outDir++outBase++"_hsc.h" + progName = outDir++outBase++"_hsc_make" ++ progNameSuffix + outHFile = outBase++"_hsc.h" + outHName = outDir++outHFile outCName = outDir++outBase++"_hsc.c" - + let execProgName - | null outDir = "./"++progName + | null outDir = '.':pathSep:progName | otherwise = progName let specials = [(pos, key, arg) | Special pos key arg <- toks] @@ -454,7 +500,7 @@ output flags name toks = do _ -> onlyOne "compiler" linker <- case [l | Linker l <- flags] of - [] -> return defaultCompiler + [] -> return cGCC [l] -> return l _ -> onlyOne "linker" @@ -490,27 +536,33 @@ output flags name toks = do _ -> return () removeFile oProgName - system (execProgName++" >"++outName) + progStatus <- system (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\ + "#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" when needsC $ writeFile outCName $ - "#include \""++outHName++"\"\n"++ + "#include \""++outHFile++"\"\n"++ concatMap outTokenC specials + -- NB. outHFile not outHName; works better when processed + -- by gcc or mkdependC. onlyOne :: String -> IO a onlyOne what = do @@ -539,7 +591,7 @@ outHeaderCProg (pos, key, arg) = case key of (header, _:body) -> case break isSpace header of (name, args) -> outCLine pos++ - "#define hsc_"++name++"("++dropWhile isSpace args++") \ + "#define hsc_"++name++"("++dropWhile isSpace args++") \ \printf ("++joinLines body++");\n" _ -> "" where @@ -547,9 +599,11 @@ outHeaderCProg (pos, key, arg) = case key of 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\ + "#if " ++ + "__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 @@ -608,11 +662,11 @@ outEnum arg = (enum, rest) -> let this = case break (== '=') $ dropWhile isSpace enum of (name, []) -> - " hsc_enum ("++t++", "++f++", \ + " hsc_enum ("++t++", "++f++", \ \hsc_haskellize (\""++name++"\"), "++ name++");\n" (hsName, _:cName) -> - " hsc_enum ("++t++", "++f++", \ + " hsc_enum ("++t++", "++f++", \ \printf (\"%s\", \""++hsName++"\"), "++ cName++");\n" in this++enums rest @@ -634,8 +688,8 @@ 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\ + "#ifdef __GNUC__\n\ + \extern\n\ \#endif\n"++ arg++"\n" _ -> "extern "++header++";\n" @@ -649,19 +703,20 @@ outTokenC (pos, key, arg) = "def" -> case arg of 's':'t':'r':'u':'c':'t':' ':_ -> "" 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" - 'i':'n':'l':'i':'n':'e':' ':_ -> - outCLine pos++ - "#ifndef __GNUC__\n\ - \extern\n\ - \#endif\n"++ - header++ - "\n#ifndef __GNUC__\n\ - \;\n\ - \#else\n"++ - body++ - "\n#endif\n" + 'i':'n':'l':'i':'n':'e':' ':arg' -> + case span (\c -> c /= '{' && c /= '=') arg' of + (header, body) -> + outCLine pos++ + "#ifndef __GNUC__\n\ + \extern inline\n\ + \#endif\n"++ + header++ + "\n#ifndef __GNUC__\n\ + \;\n\ + \#else\n"++ + body++ + "\n#endif\n" _ -> outCLine pos++arg++"\n" - where (header, body) = span (\c -> c /= '{' && c /= '=') arg _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" _ -> "" @@ -704,3 +759,4 @@ showCString = concatMap showCChar intToDigit (ord c `quot` 64), intToDigit (ord c `quot` 8 `mod` 8), intToDigit (ord c `mod` 8)] +