-----------------------------------------------------------------------------
--- $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)
--
--
-- 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"
| Linker String
| CompFlag String
| LinkFlag String
+ | Keep
| Include String
include :: String -> Flag
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"]
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"
[c] -> return c
_ -> onlyOne "compiler"
linker <- case [l | Linker l <- flags] of
- [] -> return "gcc"
+ [] -> return defaultCompiler
[l] -> return l
_ -> onlyOne "linker"
concatMap outTokenHs toks++
" return 0;\n}\n"
- compilerStatus <- kludgedSystem $
+ compilerStatus <- system $
compiler++
" -c"++
concat [" "++f | CompFlag f <- flags]++
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++
_ -> 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 <Rts.h>\n\
- \#endif\n\
- \#include <HsFFI.h>\n"++
+ "#ifndef "++includeGuard++"\n\
+ \#define "++includeGuard++"\n\
+ \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
+ \#include <Rts.h>\n\
+ \#endif\n\
+ \#include <HsFFI.h>\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"
(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
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
(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
'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"
'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"
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
projects / ghc-hetmet.git / blobdiff