[project @ 2000-11-07 15:28:36 by simonmar]

add hsc2hs, missed in the merge

ghc/utils/hsc2hs/Main.hs

+-----------------------------------------------------------------------------
+-- $Id: Main.hs,v 1.2 2000/11/07 15:28:36 simonmar Exp $
+--
+-- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk)
+--
+-- Program for converting .hsc files to .hs files, by converting the
+-- file into a C program which is run to generate the Haskell source.
+-- Certain items known only to the C compiler can then be used in
+-- the Haskell module; for example #defined constants, byte offsets
+-- within structures, etc.
+--
+-- See the documentation in the Users' Guide for more details.
+
+import GetOpt
+import System    (getProgName, getArgs, ExitCode(..), system, exitWith, exitFailure)
+import Directory (removeFile)
+import Parsec
+import Monad     (liftM, liftM2, when)
+import Char      (ord, intToDigit, isSpace, isAlphaNum, toUpper)
+
+data Flag
+    = Help
+    | Template String
+    | Compiler String
+    | Linker String
+    | CompFlag String
+    | LinkFlag String
+
+options :: [OptDescr Flag]
+options = [
+    Option "t" ["template"] (ReqArg Template "FILE") "template file",
+    Option ""  ["cc"]       (ReqArg Compiler "PROG") "C compiler to use",
+    Option ""  ["ld"]       (ReqArg Linker   "PROG") "linker to use",
+    Option ""  ["cflag"]    (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
+    Option ""  ["lflag"]    (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
+    Option ""  ["help"]     (NoArg  Help)            "display this help and exit"]
+
+main :: IO ()
+main = do
+    prog <- getProgName
+    let header = "Usage: "++prog++" [OPTIONS...] INPUT.hsc [...]"
+    args <- getArgs
+    case getOpt Permute options args of
+        (flags, _, _) | any isHelp flags -> putStrLn (usageInfo header options)
+            where isHelp Help = True; isHelp _ = False
+        (_,     [],    [])   -> putStrLn (prog++": No input files")
+        (flags, files, [])   -> mapM_ (processFile flags) files
+        (_,     _,     errs) -> do
+            mapM_ putStrLn errs
+            putStrLn (usageInfo header options)
+            exitFailure
+
+processFile :: [Flag] -> String -> IO ()
+processFile flags name = do
+    parsed <- parseFromFile parser name
+    case parsed of
+        Left err -> print err
+        Right toks -> output flags name toks
+
+data Token
+    = Text String
+    | Special String String
+
+parser :: Parser [Token]
+parser = many (text <|> special)
+
+text :: Parser Token
+text = liftM Text $ many1 $ satisfy (/= '#') <|> try (string "##" >> return '#')
+
+special :: Parser Token
+special = do
+    char '#'
+    skipMany (oneOf " \t")
+    key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
+        <?> "hsc directive"
+    skipMany (oneOf " \t")
+    arg <- argument pzero
+    return (Special key arg)
+
+argument :: Parser String -> Parser String
+argument eol = liftM concat $ many
+    (   many1 (noneOf "\n\"\'()/[\\]{}")
+    <|> eol
+    <|> (do char '\"'; a <- cString '\''; char '\"'; return ("\""++a++"\""))
+    <|> (do char '\''; a <- cString '\"'; char '\''; return ("\'"++a++"\'"))
+    <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
+    <|> (do try (string "/*"); comment; return " ")
+    <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
+    <|> string "/"
+    <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
+    <|> (do char '\\'; a <- anyChar; return ['\\',a])
+    <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
+    <?> "C expression")
+    where nested = argument (string "\n")
+
+comment :: Parser ()
+comment = (do skipMany1 (noneOf "*"); comment)
+      <|> (do try (string "*/"); return ())
+      <|> (do char '*'; comment)
+      <?> "C comment"
+
+cString :: Char -> Parser String
+cString otherQuote = liftM concat $ many
+    (   many1 (noneOf "\n\\\'\"")
+    <|> string [otherQuote]
+    <|> (do char '\\'; a <- anyChar; return ['\\',a])
+    <?> "C character or string")
+
+output :: [Flag] -> String -> [Token] -> IO ()
+output flags name toks = let
+    baseName = case reverse name of
+        'c':base -> reverse base
+        _        -> name++".hs"
+    cProgName = baseName++"c_make_hs.c"
+    oProgName = baseName++"c_make_hs.o"
+    progName  = baseName++"c_make_hs"
+    outHsName = baseName
+    outHName  = baseName++".h"
+    outCName  = baseName++".c"
+    
+    execProgName = case progName of
+        '/':_ -> progName
+        _     -> "./"++progName
+    
+    specials = [(key, arg) | Special key arg <- toks]
+    
+    needsC = any (\(key, _) -> key=="def") specials
+    needsH = needsC
+    
+    includeGuard = map fixChar outHName
+        where
+        fixChar c | isAlphaNum c = toUpper c
+                  | otherwise    = '_'
+    
+    in do
+    
+    compiler <- case [c | Compiler c <- flags] of
+        []  -> return "ghc"
+        [c] -> return c
+        _   -> onlyOne "compiler"
+    linker <- case [l | Linker l <- flags] of
+        []  -> return "gcc"
+        [l] -> return l
+        _   -> onlyOne "linker"
+        
+    writeFile cProgName $
+        concat ["#include \""++t++"\"\n" | Template t <- flags] ++
+        outHeaderCProg specials ++
+        "\nint main (void)\n{\n" ++
+        outHeaderHs (if needsH then Just outHName else Nothing) specials ++
+        concatMap outTokenHs toks ++
+        "    return 0;\n}\n"
+    
+    compilerStatus <- system $
+        compiler++
+        " -c"++
+        concat [" "++f | CompFlag f <- flags]++
+        " "++cProgName++
+        " -o "++oProgName
+    case compilerStatus of
+        e@(ExitFailure _) -> exitWith e
+        _                 -> return ()
+    removeFile cProgName
+    
+    linkerStatus <- system $
+        linker++
+        concat [" "++f | LinkFlag f <- flags]++
+        " "++oProgName++
+        " -o "++progName
+    case linkerStatus of
+        e@(ExitFailure _) -> exitWith e
+        _                 -> return ()
+    removeFile oProgName
+    
+    system (execProgName++" >"++outHsName)
+    removeFile progName
+    
+    when needsH $ writeFile outHName $
+        "#ifndef "++includeGuard++"\n\
+        \#define "++includeGuard++"\n\
+        \#include <HsFFI.h>\n"++
+        concatMap outTokenH specials++
+        "#endif\n"
+    
+    when needsC $ writeFile outCName $
+        "#include \""++outHName++"\"\n"++
+        concatMap outTokenC specials
+
+onlyOne :: String -> IO a
+onlyOne what = do
+    putStrLn ("Only one "++what++" may be specified")
+    exitFailure
+
+outHeaderCProg :: [(String, String)] -> String
+outHeaderCProg = concatMap $ \(key, arg) -> case key of
+    "include"           -> "#include "++arg++"\n"
+    "define"            -> "#define "++arg++"\n"
+    "def"               -> case arg of
+        's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
+        't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
+        _ -> ""
+    _ | conditional key -> "#"++key++" "++arg++"\n"
+    _                   -> ""
+
+outHeaderHs :: Maybe String -> [(String, String)] -> String
+outHeaderHs inH toks =
+    concatMap outSpecial toks ++
+    includeH ++
+    "    hsc_end_options();\n\n"
+    where
+    outSpecial (key, arg) = case key of
+        "include" -> case inH of
+            Nothing -> out ("-#include "++arg)
+            Just _  -> ""
+        "define" -> case inH of
+            Nothing -> out ("-optc-D"++toOptD arg)
+            Just _  -> ""
+        "option" -> out arg
+        _ | conditional key -> "#"++key++" "++arg++"\n"
+        _ -> ""
+    toOptD arg = case break isSpace arg of
+        (name, "")      -> name
+        (name, _:value) -> name++'=':dropWhile isSpace value
+    includeH = case inH of
+        Nothing   -> ""
+        Just name -> out ("-#include \""++name++"\"")
+    out s = "    hsc_option (\""++showCString s++"\");\n"
+
+outTokenHs :: Token -> String
+outTokenHs (Text s) = "    fputs (\""++showCString s++"\", stdout);\n"
+outTokenHs (Special key arg) = case key of
+    "include"           -> ""
+    "define"            -> ""
+    "option"            -> ""
+    "def"               -> ""
+    _ | conditional key -> "#"++key++" "++arg++"\n"
+    _                   -> "    hsc_"++key++" ("++arg++");\n"
+
+outTokenH :: (String, String) -> String
+outTokenH (key, arg) = case key of
+    "include" -> "#include "++arg++"\n"
+    "define" -> "#define " ++arg++"\n"
+    "def" -> 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\
+            \#endif\n"++
+            arg++"\n"
+        _ -> "extern "++header++";\n"
+        where header = takeWhile (\c -> c/='{' && c/='=') arg
+    _ | conditional key -> "#"++key++" "++arg++"\n"
+    _ -> ""
+
+outTokenC :: (String, String) -> String
+outTokenC (key, arg) = 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\
+            \#endif\n"++
+            header++
+            "\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"
+    _ -> ""
+
+conditional :: String -> Bool
+conditional "if"     = True
+conditional "ifdef"  = True
+conditional "ifndef" = True
+conditional "elif"   = True
+conditional "else"   = True
+conditional "endif"  = True
+conditional _        = False
+
+showCString :: String -> String
+showCString = concatMap showCChar
+    where
+    showCChar '\"' = "\\\""
+    showCChar '\'' = "\\\'"
+    showCChar '?'  = "\\?"
+    showCChar '\\' = "\\\\"
+    showCChar c | c >= ' ' && c <= '~' = [c]
+    showCChar '\a' = "\\a"
+    showCChar '\b' = "\\b"
+    showCChar '\f' = "\\f"
+    showCChar '\n' = "\\n\"\n           \""
+    showCChar '\r' = "\\r"
+    showCChar '\t' = "\\t"
+    showCChar '\v' = "\\v"
+    showCChar c    = ['\\',
+                      intToDigit (ord c `quot` 64),
+                      intToDigit (ord c `quot` 8 `mod` 8),
+                      intToDigit (ord c          `mod` 8)]

ghc/utils/hsc2hs/Makefile

+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.2 2000/11/07 15:28:36 simonmar Exp $
+
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+CURRENT_DIR=ghc/utils/hsc2hs
+
+INSTALLING=1
+
+HS_PROG           = hsc2hs-bin
+SRC_HC_OPTS      += -syslib util -syslib text
+
+INSTALLED_SCRIPT_PROG  = hsc2hs
+INPLACE_SCRIPT_PROG    = hsc2hs-inplace
+
+ifeq "$(INSTALLING)" "1"
+TOP_PWD 	:= $(prefix)
+SCRIPT_PROG 	=  $(INSTALLED_SCRIPT_PROG)
+else
+TOP_PWD 	:= $(FPTOOLS_TOP_ABS)
+SCRIPT_PROG 	=  $(INPLACE_SCRIPT_PROG)
+endif
+
+ifeq "$(INSTALLING)" "1"
+ifeq "$(BIN_DIST)"   "1"
+HSC2HS_DIR=$$\"\"libdir
+HSC2HS_EXTRA=
+else
+HSC2HS_DIR=$(libdir)
+HSC2HS_EXTRA=
+endif # BIN_DIST
+else
+HSC2HS_DIR=$(FPTOOLS_TOP_ABS)/$(CURRENT_DIR)
+HSC2HS_EXTRA=--cc=$(FPTOOLS_TOP_ABS)/$(CURRENT_DIR)/$(GHC_INPLACE)
+endif
+
+$(SCRIPT_PROG) : Makefile
+
+SCRIPT_SUBST_VARS = HSC2HS_DIR HS_PROG HSC2HS_EXTRA
+
+SCRIPT_OBJS=hsc2hs.sh
+INTERP=$(SHELL)
+
+INSTALL_SCRIPTS  += $(SCRIPT_PROG)
+INSTALL_LIBEXECS += $(HS_PROG)
+
+override datadir=$(libdir)
+INSTALL_DATAS += template-hsc.h
+
+# don't recurse on 'make install'
+#
+ifeq "$(INSTALLING)" "1"
+all clean veryclean maintainer-clean ::
+	$(MAKE) INSTALLING=0 BIN_DIST=0 $(MFLAGS) $@
+endif
+
+include $(TOP)/mk/target.mk

ghc/utils/hsc2hs/hsc2hs.sh

+$HSC2HS_DIR/$HS_PROG -t $HSC2HS_DIR/template-hsc.h $HSC2HS_EXTRA "$@" 

ghc/utils/hsc2hs/template-hsc.h

+#include <HsFFI.h>
+#include <stddef.h>
+#include <string.h>
+#include <stdio.h>
+
+#ifndef offsetof
+#define offsetof(t, f) ((size_t) &((t *)0)->f)
+#endif
+
+static int hsc_options_started = 0;
+
+static void hsc_option (const char *s)
+{
+    if (!hsc_options_started)
+    {
+        printf ("{-# OPTIONS");
+        hsc_options_started = 1;
+    }
+    printf (" %s", s);
+}
+
+static void hsc_end_options (void)
+{
+    if (hsc_options_started) printf (" #-}\n");
+}
+
+#define hsc_const(x)                        \
+    if ((x) < 0)                            \
+        printf ("%ld", (long)(x));          \
+    else                                    \
+        printf ("%lu", (unsigned long)(x));
+
+#define hsc_const_str(x)                                          \
+    {                                                             \
+        const char *s = (x);                                      \
+        printf ("\"");                                            \
+        while (*s != '\0')                                        \
+        {                                                         \
+            if (*s == '"' || *s == '\\')                          \
+                printf ("\\%c", *s);                              \
+            else if (*s >= 0x20 && *s <= 0x7E)                    \
+                printf ("%c", *s);                                \
+            else                                                  \
+                printf ("\\%d%s",                                 \
+                        (unsigned char) *s,                       \
+                        s[1] >= '0' && s[1] <= '9' ? "\\&" : ""); \
+            s++;                                                  \
+        }                                                         \
+        printf ("\"");                                            \
+    }
+
+#define hsc_type(t)                                         \
+    if ((t)(int)(t)1.4 == (t)1.4)                           \
+        printf ("%s%d",                                     \
+                (t)(-1) < (t)0 ? "Int" : "Word",            \
+                sizeof (t) * 8);                            \
+    else                                                    \
+        printf ("%s",                                       \
+                sizeof (t) >  sizeof (double) ? "LDouble" : \
+                sizeof (t) == sizeof (double) ? "Double"  : \
+                "Float");
+
+#define hsc_peek(t, f) \
+    printf ("(\\hsc_ptr -> peekByteOff hsc_ptr %ld)", (long) offsetof (t, f));
+
+#define hsc_poke(t, f) \
+    printf ("(\\hsc_ptr -> pokeByteOff hsc_ptr %ld)", (long) offsetof (t, f));
+
+#define hsc_ptr(t, f) \
+    printf ("(\\hsc_ptr -> hsc_ptr `plusPtr` %ld)", (long) offsetof (t, f));
+