Commit f48ba11a authored by simonmar's avatar simonmar
Browse files

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

add hsc2hs, missed in the merge
parent bca9dd54
-----------------------------------------------------------------------------
-- $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)]
# -----------------------------------------------------------------------------
# $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
$HSC2HS_DIR/$HS_PROG -t $HSC2HS_DIR/template-hsc.h $HSC2HS_EXTRA "$@"
#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));
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment