From f48ba11a99ebce67b72a122d264515a5b19dc1df Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Tue, 7 Nov 2000 15:28:36 +0000
Subject: [PATCH] [project @ 2000-11-07 15:28:36 by simonmar] add hsc2hs,
missed in the merge
---
ghc/utils/hsc2hs/Main.hs | 303 ++++++++++++++++++++++++++++++++
ghc/utils/hsc2hs/Makefile | 58 ++++++
ghc/utils/hsc2hs/hsc2hs.sh | 1 +
ghc/utils/hsc2hs/template-hsc.h | 71 ++++++++
4 files changed, 433 insertions(+)
create mode 100644 ghc/utils/hsc2hs/Main.hs
create mode 100644 ghc/utils/hsc2hs/Makefile
create mode 100644 ghc/utils/hsc2hs/hsc2hs.sh
create mode 100644 ghc/utils/hsc2hs/template-hsc.h
diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs
new file mode 100644
index 000000000000..edd780d7d3a2
--- /dev/null
+++ b/ghc/utils/hsc2hs/Main.hs
@@ -0,0 +1,303 @@
+-----------------------------------------------------------------------------
+-- $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)]
diff --git a/ghc/utils/hsc2hs/Makefile b/ghc/utils/hsc2hs/Makefile
new file mode 100644
index 000000000000..9a06547f4354
--- /dev/null
+++ b/ghc/utils/hsc2hs/Makefile
@@ -0,0 +1,58 @@
+# -----------------------------------------------------------------------------
+# $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
diff --git a/ghc/utils/hsc2hs/hsc2hs.sh b/ghc/utils/hsc2hs/hsc2hs.sh
new file mode 100644
index 000000000000..ba1e64a00af1
--- /dev/null
+++ b/ghc/utils/hsc2hs/hsc2hs.sh
@@ -0,0 +1 @@
+$HSC2HS_DIR/$HS_PROG -t $HSC2HS_DIR/template-hsc.h $HSC2HS_EXTRA "$@"
diff --git a/ghc/utils/hsc2hs/template-hsc.h b/ghc/utils/hsc2hs/template-hsc.h
new file mode 100644
index 000000000000..265dd4d7d504
--- /dev/null
+++ b/ghc/utils/hsc2hs/template-hsc.h
@@ -0,0 +1,71 @@
+#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));
+
--
GitLab