[project @ 2005-01-06 14:55:02 by malcolm]

[ghc-hetmet.git] / ghc / utils / hsc2hs / Main.hs

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index e60ea92..c2dfc20 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,7 +1,7 @@
-{-# OPTIONS -fffi #-}
+{-# OPTIONS -fffi -cpp #-}
 
 ------------------------------------------------------------------------
--- $Id: Main.hs,v 1.58 2004/06/29 17:14:01 panne Exp $
+-- $Id: Main.hs,v 1.66 2005/01/06 14:55:02 malcolm 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.
@@ -34,6 +34,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"
 
@@ -570,22 +578,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 ()
@@ -598,17 +608,16 @@ output flags name toks = do
         _                 -> return ()
     
     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\ 
-        \#if __NHC__\n\ 
-        \#undef HsChar\n\ 
-        \#define HsChar int\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" ++
+        "#if __NHC__\n" ++
+        "#undef HsChar\n" ++
+        "#define HsChar int\n" ++
+        "#endif\n" ++
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"
@@ -619,6 +628,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))
@@ -649,8 +663,8 @@ outHeaderCProg (pos, key, arg) = case key of
         (header, _:body) -> case break isSpace header of
             (name, args) ->
                 outCLine pos++
-                "#define hsc_"++name++"("++dropWhile isSpace args++") \ 
-                \printf ("++joinLines body++");\n"
+                "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
+                "printf ("++joinLines body++");\n"
     _ -> ""
    where
     joinLines = concat . intersperse " \\\n" . lines
@@ -658,11 +672,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\ 
-    \#endif\n"++
+    "__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
         Just f  -> outOption ("-#include \""++f++"\"")
@@ -720,12 +734,12 @@ outEnum arg =
                     (enum, rest) -> let
                         this = case break (== '=') $ dropWhile isSpace enum of
                             (name, []) ->
-                                "    hsc_enum ("++t++", "++f++", \ 
-                                \hsc_haskellize (\""++name++"\"), "++
+                                "    hsc_enum ("++t++", "++f++", " ++
+                                "hsc_haskellize (\""++name++"\"), "++
                                 name++");\n"
                             (hsName, _:cName) ->
-                                "    hsc_enum ("++t++", "++f++", \ 
-                                \printf (\"%s\", \""++hsName++"\"), "++
+                                "    hsc_enum ("++t++", "++f++", " ++
+                                "printf (\"%s\", \""++hsName++"\"), "++
                                 cName++");\n"
                         in this++enums rest
                 in enums afterF
@@ -746,9 +760,9 @@ 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\ 
-                \#endif\n"++
+                "#ifdef __GNUC__\n" ++
+                "extern\n" ++
+                "#endif\n"++
                 arg++"\n"
             _ -> "extern "++header++";\n"
           where header = takeWhile (\c -> c /= '{' && c /= '=') arg
@@ -765,13 +779,13 @@ outTokenC (pos, key, arg) =
                case span (\c -> c /= '{' && c /= '=') arg' of
                (header, body) ->
                    outCLine pos++
-                   "#ifndef __GNUC__\n\ 
-                   \extern inline\n\ 
-                   \#endif\n"++
+                   "#ifndef __GNUC__\n" ++
+                   "extern inline\n" ++
+                   "#endif\n"++
                    header++
-                   "\n#ifndef __GNUC__\n\ 
-                   \;\n\ 
-                   \#else\n"++
+                   "\n#ifndef __GNUC__\n" ++
+                   ";\n" ++
+                   "#else\n"++
                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"