X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=f6f8ecb9ef5466c0f32851080b0bdac9ff28d8d6;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=e2cfbb75784e84b01056a342ef04db1a4bccf552;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index e2cfbb7..f6f8ecb 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fffi -cpp #-} ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.60 2004/08/13 13:11:21 simonmar Exp $ +-- $Id: Main.hs,v 1.69 2005/01/28 12:56:26 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,11 @@ -- -- 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 @@ -24,7 +28,7 @@ import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit 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,6 +38,14 @@ import CString #endif +#if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC) +import Compat.RawSystem ( rawSystem ) +#elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600 +import System.Cmd ( rawSystem ) +#else +rawSystem prog args = system (prog++" "++unwords args) +#endif + version :: String version = "hsc2hs version 0.66\n" @@ -104,12 +116,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 @@ -521,6 +537,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 @@ -553,6 +580,7 @@ output flags name toks = do [] -> locateGhc compiler [l] -> return l _ -> onlyOne "linker" +#endif writeFile cProgName $ concatMap outFlagHeaderCProg flags++ @@ -570,22 +598,24 @@ output flags name toks = do - 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 () @@ -618,6 +648,11 @@ output flags name toks = do -- NB. outHFile not outHName; works better when processed -- by gcc or mkdependC. +rawSystemL :: Bool -> String -> [String] -> IO ExitCode +rawSystemL flg prog args = do + when flg $ hPutStrLn stderr ("Executing: " ++ prog ++ concat (map (' ':) args)) + rawSystem prog args + systemL :: Bool -> String -> IO ExitCode systemL flg s = do when flg (hPutStrLn stderr ("Executing: " ++ s)) @@ -629,7 +664,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 _ = "" @@ -731,7 +766,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 _ = "" @@ -823,21 +858,29 @@ showCString = concatMap showCChar -- Cut and pasted from ghc/compiler/SysTools -- Convert paths foo/baz to foo\baz on Windows -dosifyPath :: String -> String +dosifyPath, unDosifyPath :: String -> String #if defined(mingw32_HOST_OS) dosifyPath xs = subst '/' '\\' xs - -unDosifyPath :: String -> String unDosifyPath xs = subst '\\' '/' xs subst :: Eq a => a -> a -> [a] -> [a] subst a b ls = map (\ x -> if x == a then b else x) ls +#else +dosifyPath xs = xs +unDosifyPath xs = xs +#endif 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 +#ifdef __HUGS__ +getExecDir cmd + = do + s <- getProgName + return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s))))) +#elif defined(mingw32_HOST_OS) getExecDir cmd = allocaArray len $ \buf -> do ret <- getModuleFileName nullPtr buf len @@ -852,8 +895,5 @@ foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else -dosifyPath xs = xs - -getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif