[project @ 2001-08-03 07:44:47 by sof]

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

diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
index 42b412a..b37bb1e 100644 (file)
--- a/ghc/utils/hsc2hs/Main.hs
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -1,5 +1,5 @@
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------

--- $Id: Main.hs,v 1.27 2001/03/29 00:01:18 qrczak Exp $
+-- $Id: Main.hs,v 1.32 2001/07/24 05:49:32 ken 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.

@@ -11,7 +11,7 @@
 
 import GetOpt
 import System        (getProgName, getArgs, ExitCode(..), exitWith, exitFailure)
 
 import GetOpt
 import System        (getProgName, getArgs, ExitCode(..), exitWith, exitFailure)

-import KludgedSystem (system, defaultCompiler)
+import KludgedSystem

 import Directory     (removeFile)
 import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
 import Directory     (removeFile)
 import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)

@@ -30,12 +30,19 @@ data Flag
     | LinkFlag  String
     | NoCompile
     | Include   String
     | LinkFlag  String
     | NoCompile
     | Include   String

+    | Define    String (Maybe String)
+    | Output    String

 
 include :: String -> Flag
 include s@('\"':_) = Include s
 include s@('<' :_) = Include s
 include s          = Include ("\""++s++"\"")
 
 
 include :: String -> Flag
 include s@('\"':_) = Include s
 include s@('<' :_) = Include s
 include s          = Include ("\""++s++"\"")
 

+define :: String -> Flag
+define s = case break (== '=') s of
+    (name, [])      -> Define name Nothing
+    (name, _:value) -> Define name (Just value)
+

 options :: [OptDescr Flag]
 options = [
     Option "t" ["template"]   (ReqArg Template   "FILE") "template file",
 options :: [OptDescr Flag]
 options = [
     Option "t" ["template"]   (ReqArg Template   "FILE") "template file",

@@ -45,10 +52,12 @@ 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 HsMake*.c",

     Option "i" ["include"]    (ReqArg include    "FILE") "as if placed in the source",
     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 ""  ["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
 
 main :: IO ()
 main = do

@@ -402,48 +411,56 @@ splitExt name =
             (restBase, restExt) = splitExt rest
 
 output :: [Flag] -> String -> [Token] -> IO ()
             (restBase, restExt) = splitExt rest
 
 output :: [Flag] -> String -> [Token] -> IO ()

-output flags name toks = let
-    (dir,  file) = splitName name
-    (base, ext)  = splitExt  file
-    cProgName    = dir++"HsMake"++base++".c"
-    oProgName    = dir++"HsMake"++base++".o"
-    progName     = dir++"HsMake"++base
-    outHsName
-        | not (null ext) && last ext == 'c' = dir++base++init ext
-        | ext == ".hs"                      = dir++base++"_out.hs"
-        | otherwise                         = dir++base++".hs"
-    outHName     = dir++"Hs"++base++".h"
-    outCName     = dir++"Hs"++base++".c"
+output flags name toks = do

     
     

-    execProgName
-        | null dir  = "./"++progName
-        | otherwise = progName
+    (outName, outDir, outBase) <- case [f | Output f <- flags] of
+        []
+            | not (null ext) &&
+              last ext == 'c'   -> return (dir++base++init ext,  dir, base)
+            | ext == ".hs"      -> return (dir++base++"_out.hs", dir, base)
+            | otherwise         -> return (dir++base++".hs",     dir, base)
+            where
+            (dir,  file) = splitName name
+            (base, ext)  = splitExt  file
+        [f] -> let
+            (dir,  file) = splitName f
+            (base, _)    = splitExt file
+            in return (f, dir, base)
+        _ -> onlyOne "output file"

     
     

-    specials = [(pos, key, arg) | Special pos key arg <- toks]
+    let cProgName    = outDir++outBase++"_hsc_make.c"
+        oProgName    = outDir++outBase++"_hsc_make.o"
+        progName     = outDir++outBase++"_hsc_make" ++ progNameSuffix
+        outHName     = outDir++outBase++"_hsc.h"
+        outCName     = outDir++outBase++"_hsc.c"
+
+    let execProgName
+            | null outDir = "./"++progName
+            | otherwise   = progName

     
     

-    needsC = any (\(_, key, _) -> key == "def") specials
-    needsH = needsC
+    let specials = [(pos, key, arg) | Special pos key arg <- toks]

     
     

-    includeGuard = map fixChar outHName
-        where
-        fixChar c | isAlphaNum c = toUpper c
-                  | otherwise    = '_'
+    let needsC = any (\(_, key, _) -> key == "def") specials
+        needsH = needsC

     
     

-    in do
+    let includeGuard = map fixChar outHName
+            where
+            fixChar c | isAlphaNum c = toUpper c
+                      | otherwise    = '_'

     
     compiler <- case [c | Compiler c <- flags] of
         []  -> return "ghc"
         [c] -> return c
         _   -> onlyOne "compiler"
     
     compiler <- case [c | Compiler c <- flags] of
         []  -> return "ghc"
         [c] -> return c
         _   -> onlyOne "compiler"

+    

     linker <- case [l | Linker l <- flags] of
         []  -> return defaultCompiler
         [l] -> return l
         _   -> onlyOne "linker"
     
     writeFile cProgName $
     linker <- case [l | Linker l <- flags] of
         []  -> return defaultCompiler
         [l] -> return l
         _   -> onlyOne "linker"
     
     writeFile cProgName $

-        concat ["#include \""++t++"\"\n" | Template t <- flags]++
-        concat ["#include "++f++"\n"     | Include  f <- flags]++
-        outHeaderCProg specials++
+        concatMap outFlagHeaderCProg flags++
+        concatMap outHeaderCProg specials++

         "\nint main (void)\n{\n"++
         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
         outHsLine (SourcePos name 0)++
         "\nint main (void)\n{\n"++
         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
         outHsLine (SourcePos name 0)++

@@ -473,7 +490,7 @@ output flags name toks = let
         _                 -> return ()
     removeFile oProgName
     
         _                 -> return ()
     removeFile oProgName
     

-    system (execProgName++" >"++outHsName)
+    system (execProgName++" >"++outName)

     removeFile progName
     
     when needsH $ writeFile outHName $
     removeFile progName
     
     when needsH $ writeFile outHName $

@@ -487,7 +504,7 @@ output flags name toks = let
         \#undef HsChar\n\
         \#define HsChar int\n\
         \#endif\n"++
         \#undef HsChar\n\
         \#define HsChar int\n\
         \#endif\n"++

-        concat ["#include "++n++"\n" | Include n <- flags]++
+        concatMap outFlagH flags++

         concatMap outTokenH specials++
         "#endif\n"
     
         concatMap outTokenH specials++
         "#endif\n"
     

@@ -500,25 +517,31 @@ onlyOne what = do
     putStrLn ("Only one "++what++" may be specified")
     exitFailure
 
     putStrLn ("Only one "++what++" may be specified")
     exitFailure
 

-outHeaderCProg :: [(SourcePos, String, String)] -> String
-outHeaderCProg =
-    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':' ':_ -> outCLine pos++arg++"\n"
-            't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
-            _ -> ""
-        _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
-        "let"               -> case break (== '=') arg of
-            (_,      "")     -> ""
-            (header, _:body) -> case break isSpace header of
-                (name, args) ->
-                    outCLine pos++
-                    "#define hsc_"++name++"("++dropWhile isSpace args++") \
-                    \printf ("++joinLines body++");\n"
+outFlagHeaderCProg :: Flag -> String
+outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
+outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
+outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
+outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
+outFlagHeaderCProg _                     = ""
+
+outHeaderCProg :: (SourcePos, String, String) -> String
+outHeaderCProg (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':' ':_ -> outCLine pos++arg++"\n"
+        't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"

         _ -> ""
         _ -> ""

+    _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
+    "let"               -> case break (== '=') arg of
+        (_,      "")     -> ""
+        (header, _:body) -> case break isSpace header of
+            (name, args) ->
+                outCLine pos++
+                "#define hsc_"++name++"("++dropWhile isSpace args++") \
+                \printf ("++joinLines body++");\n"
+    _ -> ""

     where
     joinLines = concat . intersperse " \\\n" . lines
 
     where
     joinLines = concat . intersperse " \\\n" . lines
 

@@ -528,18 +551,20 @@ outHeaderHs flags inH toks =
     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
     \__GLASGOW_HASKELL__);\n\
     \#endif\n"++
     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
     \__GLASGOW_HASKELL__);\n\
     \#endif\n"++

-    includeH++
-    concatMap outSpecial toks
+    case inH of
+        Nothing -> concatMap outFlag flags++concatMap outSpecial toks
+        Just f  -> outOption ("-#include \""++f++"\"")

     where
     where

+    outFlag (Include f)          = outOption ("-#include "++f)
+    outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
+    outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
+    outFlag _                    = ""

     outSpecial (pos, key, arg) = 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 -> outCLine pos++"#"++key++" "++arg++"\n"
-        _ -> ""
+        "include"                  -> outOption ("-#include "++arg)
+        "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
+                 | otherwise       -> ""
+        _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
+        _                          -> ""

     goodForOptD arg = case arg of
         ""              -> True
         c:_ | isSpace c -> True
     goodForOptD arg = case arg of
         ""              -> True
         c:_ | isSpace c -> True

@@ -548,11 +573,6 @@ outHeaderHs flags inH toks =
     toOptD arg = case break isSpace arg of
         (name, "")      -> name
         (name, _:value) -> name++'=':dropWhile isSpace value
     toOptD arg = case break isSpace arg of
         (name, "")      -> name
         (name, _:value) -> name++'=':dropWhile isSpace value

-    includeH = concat [
-        outOption ("-#include "++name++"")
-        | name <- case inH of
-            Nothing   -> [name | Include name <- flags]
-            Just name -> ["\""++name++"\""]]

     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
                   showCString s++"\");\n"
 
     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
                   showCString s++"\");\n"
 

@@ -598,6 +618,12 @@ outEnum arg =
                         in this++enums rest
                 in enums afterF
 
                         in this++enums rest
                 in enums afterF
 

+outFlagH :: Flag -> String
+outFlagH (Include  f)          = "#include "++f++"\n"
+outFlagH (Define   n Nothing)  = "#define "++n++"\n"
+outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
+outFlagH _                     = ""
+

 outTokenH :: (SourcePos, String, String) -> String
 outTokenH (pos, key, arg) =
     case key of
 outTokenH :: (SourcePos, String, String) -> String
 outTokenH (pos, key, arg) =
     case key of

@@ -623,19 +649,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"
         _ -> ""