-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.10 2001/01/13 19:46:49 qrczak Exp $
+-- $Id: Main.hs,v 1.15 2001/02/05 18:01:39 rrt 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 Parsec
import ParsecError
import Monad (liftM, liftM2, when)
import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper)
import List (intersperse)
+import Exception (catchAllIO)
+#ifndef mingw32_TARGET_OS
+import Posix
+#endif
version :: String
version = "hsc2hs-0.64"
concatMap outTokenHs toks++
" return 0;\n}\n"
- compilerStatus <- system $
+ compilerStatus <- kludgedSystem $
compiler++
" -c"++
concat [" "++f | CompFlag f <- flags]++
_ -> return ()
removeFile cProgName
- linkerStatus <- system $
+ linkerStatus <- kludgedSystem $
linker++
concat [" "++f | LinkFlag f <- flags]++
" "++oProgName++
_ -> return ()
removeFile oProgName
- system (execProgName++" >"++outHsName)
+ kludgedSystem (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\
+ "#ifndef "++includeGuard++"\n\
+ \#define "++includeGuard++"\n\
+ \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
+ \#include <Rts.h>\n\
+ \#endif\n\
\#include <HsFFI.h>\n"++
concat ["#include "++n++"\n" | Include n <- flags]++
concatMap outTokenH specials++
outHeaderCProg :: [(SourcePos, String, String)] -> String
outHeaderCProg =
- concatMap $ \(pos, key, arg) -> outCLine pos ++ case key of
- "include" -> "#include "++arg++"\n"
- "define" -> "#define "++arg++"\n"
- "undef" -> "#undef "++arg++"\n"
+ concatMap $ \(pos, key, arg) -> case key of
+ "include" -> outCLine pos++"#include "++arg++"\n"
+ "define" -> outCLine pos++"#define "++arg++"\n"
+ "undef" -> outCLine pos++"#undef "++arg++"\n"
"def" -> case arg of
- 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
- 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
+ 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
+ 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
_ -> ""
- _ | conditional key -> "#"++key++" "++arg++"\n"
+ _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
"let" -> case break (== '=') arg of
(_, "") -> ""
(header, _:body) -> case break isSpace header of
(name, args) ->
- "#define hsc_"++name++"("++dropWhile isSpace args++") \
+ outCLine pos++
+ "#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
where
- outSpecial (pos, key, arg) = outCLine pos ++ case key of
+ outSpecial (pos, key, arg) = case key of
"include" -> case inH of
Nothing -> outOption ("-#include "++arg)
Just _ -> ""
"define" -> case inH of
Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
_ -> ""
- _ | conditional key -> "#"++key++" "++arg++"\n"
+ _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
_ -> ""
goodForOptD arg = case arg of
"" -> True
where
outText s = " fputs (\""++showCString s++"\", stdout);\n"
outTokenHs (Special pos key arg) =
- outCLine pos ++ case key of
+ case key of
"include" -> ""
"define" -> ""
"undef" -> ""
"def" -> ""
- _ | conditional key -> "#"++key++" "++arg++"\n"
+ _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
"let" -> ""
- _ -> " hsc_"++key++" ("++arg++");\n"
+ "enum" -> outCLine pos++outEnum arg
+ _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
+
+outEnum :: String -> String
+outEnum arg =
+ case break (== ',') arg of
+ (_, []) -> ""
+ (t, _:afterT) -> case break (== ',') afterT of
+ (f, afterF) -> let
+ enums [] = ""
+ enums (_:s) = case break (== ',') s of
+ (enum, rest) -> let
+ this = case break (== '=') $ dropWhile isSpace enum of
+ (name, []) ->
+ " hsc_enum ("++t++", "++f++", \
+ \hsc_haskellize (\""++name++"\"), "++
+ name++");\n"
+ (hsName, _:cName) ->
+ " hsc_enum ("++t++", "++f++", \
+ \printf (\"%s\", \""++hsName++"\"), "++
+ cName++");\n"
+ in this++enums rest
+ in enums afterF
outTokenH :: (SourcePos, String, String) -> String
outTokenH (pos, key, arg) =
- outCLine pos ++ case key of
- "include" -> "#include "++arg++"\n"
- "define" -> "#define " ++arg++"\n"
- "undef" -> "#undef " ++arg++"\n"
- "def" -> case arg of
+ case key of
+ "include" -> outCLine pos++"#include "++arg++"\n"
+ "define" -> outCLine pos++"#define " ++arg++"\n"
+ "undef" -> outCLine pos++"#undef " ++arg++"\n"
+ "def" -> outCLine pos++case arg of
'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"
- where header = takeWhile (\c -> c/='{' && c/='=') arg
- _ | conditional key -> "#"++key++" "++arg++"\n"
+ where header = takeWhile (\c -> c /= '{' && c /= '=') arg
+ _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
_ -> ""
outTokenC :: (SourcePos, String, String) -> String
outTokenC (pos, key, arg) =
- outCLine pos ++ case key of
+ case key of
"def" -> case arg of
's':'t':'r':'u':'c':'t':' ':_ -> ""
't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
'i':'n':'l':'i':'n':'e':' ':_ ->
- "#ifndef __GNUC__\n\
- \extern\n\
+ outCLine pos++
+ "#ifndef __GNUC__\n\
+ \extern\n\
\#endif\n"++
header++
- "\n#ifndef __GNUC__\n\
- \;\n\
+ "\n#ifndef __GNUC__\n\
+ \;\n\
\#else\n"++
body++
"\n#endif\n"
- _ -> arg++"\n"
- where (header, body) = span (\c -> c/='{' && c/='=') arg
- _ | conditional key -> "#"++key++" "++arg++"\n"
+ _ -> outCLine pos++arg++"\n"
+ where (header, body) = span (\c -> c /= '{' && c /= '=') arg
+ _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
_ -> ""
conditional :: String -> Bool
-conditional "if" = True
-conditional "ifdef" = True
-conditional "ifndef" = True
-conditional "elif" = True
-conditional "else" = True
-conditional "endif" = True
-conditional "error" = True
-conditional _ = False
+conditional "if" = True
+conditional "ifdef" = True
+conditional "ifndef" = True
+conditional "elif" = True
+conditional "else" = True
+conditional "endif" = True
+conditional "error" = True
+conditional "warning" = True
+conditional _ = False
sourceFileName :: SourcePos -> String
sourceFileName pos = fileName (sourceName pos)
outHsLine :: SourcePos -> String
outHsLine pos =
- " printf (\"{-# LINE %d \\\"%s\\\" #-}\\n\", "++
+ " hsc_line ("++
show (sourceLine pos + 1)++", \""++
showCString (sourceFileName pos)++"\");\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
+#else
+myGetProcessID :: IO Int
+myGetProcessID = Posix.getProcessID
+#endif
projects / ghc-hetmet.git / blobdiff