X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fhsc2hs%2FMain.hs;h=6a18f838ed37a3bfe23537facb67948ad8f4baa3;hb=be3fac8d49252e1136c3702e02a731635233b3c4;hp=51faa506ac3d4101d6bb6fe0c58274346414dc3a;hpb=eea44bbb5baa7212f120ab96c8e9822a925dc2d4;p=ghc-hetmet.git diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index 51faa50..6a18f83 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.16 2001/02/05 22:02:18 qrczak Exp $ +-- $Id: Main.hs,v 1.22 2001/02/22 22:39:56 qrczak Exp $ -- -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk) -- @@ -11,18 +11,15 @@ -- -- See the documentation in the Users' Guide for more details. -#include "../../includes/config.h" - import GetOpt -import System (getProgName, getArgs, ExitCode(..), system, exitWith, exitFailure) -import Directory (removeFile) -import IO (openFile, hClose, hPutStrLn, IOMode(..)) +import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure) +import KludgedSystem (system, defaultCompiler) +import Directory (removeFile) import Parsec import ParsecError -import Monad (liftM, liftM2, when) -import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper) -import List (intersperse) -import Exception (catchAllIO) +import Monad (liftM, liftM2, when) +import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper) +import List (intersperse) version :: String version = "hsc2hs-0.64" @@ -35,6 +32,7 @@ data Flag | Linker String | CompFlag String | LinkFlag String + | Keep | Include String include :: String -> Flag @@ -45,13 +43,14 @@ include s = Include ("\""++s++"\"") options :: [OptDescr Flag] options = [ Option "t" ["template"] (ReqArg Template "FILE") "template file", - Option "" ["cc"] (ReqArg Compiler "PROG") "C compiler to use", - Option "" ["ld"] (ReqArg Linker "PROG") "linker to use", - Option "" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler", + Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use", + Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use", + Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler", Option "I" [] (ReqArg (CompFlag . ("-I"++)) "DIR") "passed to the C compiler", - Option "" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker", - Option "" ["include"] (ReqArg include "FILE") "as if placed in the source", + Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker", + Option "" ["keep"] (NoArg Keep) "don't delete *.hs_make.c", + Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source", Option "" ["help"] (NoArg Help) "display this help and exit", Option "" ["version"] (NoArg Version) "output version information and exit"] @@ -188,9 +187,9 @@ output flags name toks = let baseName = case reverse name of 'c':base -> reverse base _ -> name++".hs" - cProgName = baseName++"c_make_hs.c" - oProgName = baseName++"c_make_hs.o" - progName = baseName++"c_make_hs" + cProgName = baseName++"_make.c" + oProgName = baseName++"_make.o" + progName = baseName++"_make" outHsName = baseName outHName = baseName++".h" outCName = baseName++".c" @@ -216,7 +215,7 @@ output flags name toks = let [c] -> return c _ -> onlyOne "compiler" linker <- case [l | Linker l <- flags] of - [] -> return "gcc" + [] -> return defaultCompiler [l] -> return l _ -> onlyOne "linker" @@ -230,7 +229,7 @@ output flags name toks = let concatMap outTokenHs toks++ " return 0;\n}\n" - compilerStatus <- kludgedSystem $ + compilerStatus <- system $ compiler++ " -c"++ concat [" "++f | CompFlag f <- flags]++ @@ -239,9 +238,9 @@ output flags name toks = let case compilerStatus of e@(ExitFailure _) -> exitWith e _ -> return () - removeFile cProgName + when (null [() | Keep <- flags]) $ removeFile cProgName - linkerStatus <- kludgedSystem $ + linkerStatus <- system $ linker++ concat [" "++f | LinkFlag f <- flags]++ " "++oProgName++ @@ -251,16 +250,20 @@ output flags name toks = let _ -> return () removeFile oProgName - kludgedSystem (execProgName++" >"++outHsName) + system (execProgName++" >"++outHsName) removeFile progName when needsH $ writeFile outHName $ - "#ifndef "++includeGuard++"\n\ - \#define "++includeGuard++"\n\ - \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ - \#include \n\ - \#endif\n\ - \#include \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"++ concat ["#include "++n++"\n" | Include n <- flags]++ concatMap outTokenH specials++ "#endif\n" @@ -290,7 +293,7 @@ outHeaderCProg = (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 @@ -298,9 +301,9 @@ outHeaderCProg = 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"++ includeH++ concatMap outSpecial toks @@ -362,11 +365,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 @@ -382,8 +385,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" @@ -399,12 +402,12 @@ outTokenC (pos, key, arg) = 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" 'i':'n':'l':'i':'n':'e':' ':_ -> outCLine pos++ - "#ifndef __GNUC__\n\ - \extern\n\ + "#ifndef __GNUC__\n\ + \extern\n\ \#endif\n"++ header++ - "\n#ifndef __GNUC__\n\ - \;\n\ + "\n#ifndef __GNUC__\n\ + \;\n\ \#else\n"++ body++ "\n#endif\n" @@ -461,27 +464,3 @@ showCString = concatMap showCChar intToDigit (ord c `quot` 64), intToDigit (ord c `quot` 8 `mod` 8), intToDigit (ord c `mod` 8)] - --- system that works feasibly under Windows (i.e. passes the command line to sh, --- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE) -kludgedSystem cmd - = do -#ifndef mingw32_TARGET_OS - exit_code <- system cmd `catchAllIO` - (\_ -> exitFailure) -#else - pid <- myGetProcessID - let tmp = "/tmp/sh" ++ show pid - h <- openFile tmp WriteMode - hPutStrLn h cmd - hClose h - exit_code <- system ("sh - " ++ tmp) `catchAllIO` - (\_ -> removeFile tmp >> - exitFailure) - removeFile tmp -#endif - return exit_code - -#ifdef mingw32_TARGET_OS -foreign import "_getpid" myGetProcessID :: IO Int -#endif