[project @ 2004-08-12 12:12:54 by simonmar]

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

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index 52e6911..b032553 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.57 2004/06/27 20:41:07 panne Exp $
+-- $Id: Main.hs,v 1.59 2004/08/12 12:12:54 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.
 --
 -- Program for converting .hsc files to .hs files, by converting the
 -- file into a C program which is run to generate the Haskell source.

@@ -19,7 +19,7 @@ import GetOpt
 
 import System        (getProgName, getArgs, ExitCode(..), exitWith, system)
 import Directory     (removeFile,doesFileExist)
 
 import System        (getProgName, getArgs, ExitCode(..), exitWith, system)
 import Directory     (removeFile,doesFileExist)

-import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
+import Monad         (MonadPlus(..), liftM, liftM2, when)

 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 import IO            (hPutStr, hPutStrLn, stderr)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse, isSuffixOf)
 import IO            (hPutStr, hPutStrLn, stderr)

@@ -563,7 +563,10 @@ output flags name toks = do
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
     
         concatMap outTokenHs toks++
         "    return 0;\n}\n"
     

-    unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
+    -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
+    -- so we use something slightly more complicated.   :-P
+    when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
+       exitWith ExitSuccess

 
 
     
 
 
     

@@ -595,17 +598,16 @@ output flags name toks = do
         _                 -> return ()
     
     when needsH $ writeFile outHName $
         _                 -> 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"
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"

@@ -646,8 +648,8 @@ outHeaderCProg (pos, key, arg) = case key of
         (header, _:body) -> case break isSpace header of
             (name, args) ->
                 outCLine pos++
         (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
     _ -> ""
    where
     joinLines = concat . intersperse " \\\n" . lines

@@ -655,11 +657,11 @@ outHeaderCProg (pos, key, arg) = case key of
 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 outHeaderHs flags inH toks =
     "#if " ++
 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++"\"")
     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
         Just f  -> outOption ("-#include \""++f++"\"")

@@ -717,12 +719,12 @@ outEnum arg =
                     (enum, rest) -> let
                         this = case break (== '=') $ dropWhile isSpace enum of
                             (name, []) ->
                     (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) ->
                                 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
                                 cName++");\n"
                         in this++enums rest
                 in enums afterF

@@ -743,9 +745,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':' ':_ ->
             '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
                 arg++"\n"
             _ -> "extern "++header++";\n"
           where header = takeWhile (\c -> c /= '{' && c /= '=') arg

@@ -762,13 +764,13 @@ outTokenC (pos, key, arg) =
                case span (\c -> c /= '{' && c /= '=') arg' of
                (header, body) ->
                    outCLine pos++
                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++
                    header++

-                   "\n#ifndef __GNUC__\n\ 
-                   \;\n\ 
-                   \#else\n"++
+                   "\n#ifndef __GNUC__\n" ++
+                   ";\n" ++
+                   "#else\n"++

                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"
                    body++
                    "\n#endif\n"
             _ -> outCLine pos++arg++"\n"