projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2002-10-27 10:38:32 by mthomas]
[ghc-hetmet.git] / ghc / utils / hsc2hs / Main.hs
diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index b888f33..ee30d09 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,5 +1,5 @@
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
--- $Id: Main.hs,v 1.29 2001/03/29 17:56:18 qrczak Exp $
+-- $Id: Main.hs,v 1.41 2002/10/27 10:38:33 mthomas 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.
@@ -9,14 +9,41 @@
 --
 -- See the documentation in the Users' Guide for more details.
 
 --
 -- See the documentation in the Users' Guide for more details.
 
+#if __GLASGOW_HASKELL__ >= 504
+import System.Console.GetOpt
+#else
 import GetOpt
 import GetOpt
-import System        (getProgName, getArgs, ExitCode(..), exitWith, exitFailure)
-import KludgedSystem (system, defaultCompiler)
+#endif
+
+import Config
+import System        (getProgName, getArgs, ExitCode(..), exitWith, exitFailure, system)
 import Directory     (removeFile)
 import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse)
 
 import Directory     (removeFile)
 import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import List          (intersperse)
 
+#include "../../includes/config.h"
+
+#ifdef mingw32_HOST_OS
+-- import Win32DLL
+import Foreign.C.String (CString, peekCString)
+import Foreign.C.Types
+import Foreign.Ptr (nullPtr)
+import Foreign.Marshal.Alloc (mallocBytes, free)
+
+foreign import stdcall "GetModuleHandle" c_GetModuleHandle :: CString -> IO CUInt
+foreign import stdcall "GetModuleFileName" c_GetModuleFilename :: CUInt -> CString -> CUInt -> IO CUInt
+
+ourName :: IO String
+ourName = do h <- c_GetModuleHandle nullPtr
+            cstr <- mallocBytes cstr_len
+            rv <- c_GetModuleFilename h cstr (CUInt (fromIntegral cstr_len))
+            str <- peekCString cstr
+            free cstr
+            return str
+    where cstr_len = 512
+#endif
+
 version :: String
 version = "hsc2hs-0.65"
 
 version :: String
 version = "hsc2hs-0.65"
 
@@ -52,19 +79,26 @@ options = [
     Option "I" []             (ReqArg (CompFlag . ("-I"++))
                                                  "DIR")  "passed to the C compiler",
     Option "L" ["lflag"]      (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
     Option "I" []             (ReqArg (CompFlag . ("-I"++))
                                                  "DIR")  "passed to the C compiler",
     Option "L" ["lflag"]      (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
-    Option ""  ["no-compile"] (NoArg  NoCompile)         "stop after writing *_hsc_make.c",
     Option "i" ["include"]    (ReqArg include    "FILE") "as if placed in the source",
     Option "D" ["define"]     (ReqArg define "NAME[=VALUE]") "as if placed in the source",
     Option "o" ["output"]     (ReqArg Output     "FILE") "name of main output file",
     Option ""  ["help"]       (NoArg  Help)              "display this help and exit",
     Option "i" ["include"]    (ReqArg include    "FILE") "as if placed in the source",
     Option "D" ["define"]     (ReqArg define "NAME[=VALUE]") "as if placed in the source",
     Option "o" ["output"]     (ReqArg Output     "FILE") "name of main output file",
     Option ""  ["help"]       (NoArg  Help)              "display this help and exit",
-    Option ""  ["version"]    (NoArg  Version)           "output version information and exit"]
+    Option ""  ["version"]    (NoArg  Version)           "output version information and exit",
+    Option ""  ["no-compile"] (NoArg  NoCompile)         "stop after writing *_hsc_make.c"]
 
 main :: IO ()
 main = do
     prog <- getProgName
     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
     args <- getArgs
 
 main :: IO ()
 main = do
     prog <- getProgName
     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
     args <- getArgs
-    case getOpt Permute options args of
+    let opts@(flags, files, errs) = getOpt Permute options args
+#ifdef mingw32_HOST_OS
+    n <- ourName
+    let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h"
+    let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags
+    let opts = (fflags, files, errs)
+#endif
+    case opts of
         (flags, _, _)
             | any isHelp    flags -> putStrLn (usageInfo header options)
             | any isVersion flags -> putStrLn version
         (flags, _, _)
             | any isHelp    flags -> putStrLn (usageInfo header options)
             | any isVersion flags -> putStrLn version
@@ -79,14 +113,25 @@ main = do
             exitFailure
 
 processFile :: [Flag] -> String -> IO ()
             exitFailure
 
 processFile :: [Flag] -> String -> IO ()
-processFile flags name = do
-    s <- readFile name
-    case parser of
-        Parser p -> case p (SourcePos name 1) s of
-            Success _ _ _ toks -> output flags name toks
-            Failure (SourcePos name' line) msg -> do
-                putStrLn (name'++":"++show line++": "++msg)
-                exitFailure
+processFile flags name 
+  = do let file_name = dosifyPath name
+       s <- readFile file_name
+       case parser of
+          Parser p -> case p (SourcePos file_name 1) s of
+              Success _ _ _ toks -> output flags file_name toks
+              Failure (SourcePos name' line) msg -> do
+                  putStrLn (name'++":"++show line++": "++msg)
+                  exitFailure
+
+------------------------------------------------------------------------
+-- Convert paths foo/baz to foo\baz on Windows
+
+#if defined(mingw32_HOST_OS)
+subst a b ls = map (\ x -> if x == a then b else x) ls
+dosifyPath xs = subst '/' '\\' xs
+#else
+dosifyPath xs = xs
+#endif
 
 ------------------------------------------------------------------------
 -- A deterministic parser which remembers the text which has been parsed.
 
 ------------------------------------------------------------------------
 -- A deterministic parser which remembers the text which has been parsed.
@@ -430,12 +475,13 @@ output flags name toks = do
     
     let cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
     
     let cProgName    = outDir++outBase++"_hsc_make.c"
         oProgName    = outDir++outBase++"_hsc_make.o"
-        progName     = outDir++outBase++"_hsc_make"
-        outHName     = outDir++outBase++"_hsc.h"
+        progName     = outDir++outBase++"_hsc_make" ++ progNameSuffix
+       outHFile     = outBase++"_hsc.h"
+        outHName     = outDir++outHFile
         outCName     = outDir++outBase++"_hsc.c"
         outCName     = outDir++outBase++"_hsc.c"
-    
+
     let execProgName
     let execProgName
-            | null outDir = "./"++progName
+            | null outDir = '.':pathSep:progName
             | otherwise   = progName
     
     let specials = [(pos, key, arg) | Special pos key arg <- toks]
             | otherwise   = progName
     
     let specials = [(pos, key, arg) | Special pos key arg <- toks]
@@ -454,7 +500,7 @@ output flags name toks = do
         _   -> onlyOne "compiler"
     
     linker <- case [l | Linker l <- flags] of
         _   -> onlyOne "compiler"
     
     linker <- case [l | Linker l <- flags] of
-        []  -> return defaultCompiler
+        []  -> return cGCC
         [l] -> return l
         _   -> onlyOne "linker"
     
         [l] -> return l
         _   -> onlyOne "linker"
     
@@ -490,27 +536,33 @@ output flags name toks = do
         _                 -> return ()
     removeFile oProgName
     
         _                 -> return ()
     removeFile oProgName
     
-    system (execProgName++" >"++outName)
+    progStatus <- system (execProgName++" >"++outName)
     removeFile progName
     removeFile progName
+    case progStatus of
+        e@(ExitFailure _) -> exitWith e
+        _                 -> return ()
     
     when needsH $ writeFile outHName $
     
     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\
+        "#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"
     
     when needsC $ writeFile outCName $
         \#endif\n"++
         concatMap outFlagH flags++
         concatMap outTokenH specials++
         "#endif\n"
     
     when needsC $ writeFile outCName $
-        "#include \""++outHName++"\"\n"++
+        "#include \""++outHFile++"\"\n"++
         concatMap outTokenC specials
         concatMap outTokenC specials
+       -- NB. outHFile not outHName; works better when processed
+       -- by gcc or mkdependC.
 
 onlyOne :: String -> IO a
 onlyOne what = do
 
 onlyOne :: String -> IO a
 onlyOne what = do
@@ -539,7 +591,7 @@ 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++") \
+                "#define hsc_"++name++"("++dropWhile isSpace args++") \ 
                 \printf ("++joinLines body++");\n"
     _ -> ""
     where
                 \printf ("++joinLines body++");\n"
     _ -> ""
     where
@@ -547,9 +599,11 @@ outHeaderCProg (pos, key, arg) = case key of
 
 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 outHeaderHs flags inH toks =
 
 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"++
     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
     \#endif\n"++
     case inH of
         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
@@ -608,11 +662,11 @@ 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_enum ("++t++", "++f++", \ 
                                 \hsc_haskellize (\""++name++"\"), "++
                                 name++");\n"
                             (hsName, _:cName) ->
                                 \hsc_haskellize (\""++name++"\"), "++
                                 name++");\n"
                             (hsName, _:cName) ->
-                                "    hsc_enum ("++t++", "++f++", \
+                                "    hsc_enum ("++t++", "++f++", \ 
                                 \printf (\"%s\", \""++hsName++"\"), "++
                                 cName++");\n"
                         in this++enums rest
                                 \printf (\"%s\", \""++hsName++"\"), "++
                                 cName++");\n"
                         in this++enums rest
@@ -634,8 +688,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':' ':_ ->
             '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"
                 \#endif\n"++
                 arg++"\n"
             _ -> "extern "++header++";\n"
@@ -649,19 +703,20 @@ outTokenC (pos, key, arg) =
         "def" -> case arg of
             's':'t':'r':'u':'c':'t':' ':_ -> ""
             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
         "def" -> case arg of
             's':'t':'r':'u':'c':'t':' ':_ -> ""
             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
-            'i':'n':'l':'i':'n':'e':' ':_ ->
-                outCLine pos++
-                "#ifndef __GNUC__\n\
-                \extern\n\
-                \#endif\n"++
-                header++
-                "\n#ifndef __GNUC__\n\
-                \;\n\
-                \#else\n"++
-                body++
-                "\n#endif\n"
+            'i':'n':'l':'i':'n':'e':' ':arg' ->
+               case span (\c -> c /= '{' && c /= '=') arg' of
+               (header, body) ->
+                   outCLine pos++
+                   "#ifndef __GNUC__\n\ 
+                   \extern inline\n\ 
+                   \#endif\n"++
+                   header++
+                   "\n#ifndef __GNUC__\n\ 
+                   \;\n\ 
+                   \#else\n"++
+                   body++
+                   "\n#endif\n"
             _ -> outCLine pos++arg++"\n"
             _ -> outCLine pos++arg++"\n"
-            where (header, body) = span (\c -> c /= '{' && c /= '=') arg
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 
         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
         _ -> ""
 
@@ -704,3 +759,4 @@ showCString = concatMap showCChar
                       intToDigit (ord c `quot` 64),
                       intToDigit (ord c `quot` 8 `mod` 8),
                       intToDigit (ord c          `mod` 8)]
                       intToDigit (ord c `quot` 64),
                       intToDigit (ord c `quot` 8 `mod` 8),
                       intToDigit (ord c          `mod` 8)]
+
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)