From 6ebcfc5d2f1702ad1bac50a6aae8d78b72a5b4ae Mon Sep 17 00:00:00 2001 From: qrczak Date: Thu, 28 Dec 2000 10:34:56 +0000 Subject: [PATCH] [project @ 2000-12-28 10:34:56 by qrczak] Implemented #undef, #error, and #let (macros to be applied to the Haskell source, although using somewhat ugly stringified syntax). s/hs2c/hsc2hs/ Fixed some bugs (user-supplied --cc option, macros with parameters). --- ghc/docs/users_guide/utils.sgml | 37 +++++++++++++++++++++++++------- ghc/utils/hsc2hs/Main.hs | 45 +++++++++++++++++++++++++++++---------- ghc/utils/hsc2hs/hsc2hs.sh | 8 +++++++ ghc/utils/hsc2hs/template-hsc.h | 22 ++++++++++++++++++- 4 files changed, 92 insertions(+), 20 deletions(-) diff --git a/ghc/docs/users_guide/utils.sgml b/ghc/docs/users_guide/utils.sgml index 7aa4139..796ee90 100644 --- a/ghc/docs/users_guide/utils.sgml +++ b/ghc/docs/users_guide/utils.sgml @@ -98,13 +98,13 @@ tags: --> - + Writing Haskell interfaces to C code: - <command>hs2c</command> - hs2c + hsc2hs + hsc2hs - The hs2c command can be used to automate + The hsc2hs command can be used to automate some parts of the process of writing Haskell bindings to C code. It reads an almost-Haskell source with embedded special constructs, and outputs a real Haskell file with these constructs @@ -118,7 +118,7 @@ tags: two files are created when the #def construct is used. - Actually hs2c does not output the Haskell + Actually hsc2hs does not output the Haskell file directly. It creates a C program that includes the headers, gets automatically compiled and run. That program outputs the Haskell code. @@ -236,8 +236,8 @@ tags: #include "file.h" The specified file gets included into the C program, - the compiled Haskell file, and the C - header. <HsFFI.h> is included + the compiled Haskell file, and the C header. + <HsFFI.h> is included automatically. @@ -245,6 +245,7 @@ tags: #define name #define name value + #undef name Similar to #include. Note that #includes and @@ -254,6 +255,25 @@ tags: + #let name parameters = "definition" + + Defines a macro to be applied to the Haskell + source. Parameter names are comma-separated, not + inside parens. Such macro is invoked as other + #-constructs, starting with + #name. The definition will be + put in the C program inside parens as arguments of + printf. To refer to a parameter, + close the quote, put a parameter name and open the + quote again, to let C string literals concatenate. + Or use printf's format directives. + Values of arguments must be given as strings, unless the + macro stringifies them itself using the C preprocessor's + #parameter syntax. + + + + #option opt The specified Haskell compiler command-line option @@ -286,6 +306,7 @@ tags: #elif condition #else #endif + #error message Conditional compilation directives are passed unmodified to the C program, C file, and C header. Putting @@ -362,7 +383,7 @@ tags: #const, #type, #peek, #poke and #ptr are not hardwired into the - hs2c, but are defined in a C template that is + hsc2hs, but are defined in a C template that is included in the C program: template-hsc.h. Custom constructs and templates can be used too. Any #-construct with unknown key is expected to diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index edd780d..5ff8e44 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.2 2000/11/07 15:28:36 simonmar Exp $ +-- $Id: Main.hs,v 1.3 2000/12/28 10:34:56 qrczak Exp $ -- -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk) -- @@ -17,6 +17,7 @@ import Directory (removeFile) import Parsec import Monad (liftM, liftM2, when) import Char (ord, intToDigit, isSpace, isAlphaNum, toUpper) +import List (intersperse) data Flag = Help @@ -124,7 +125,7 @@ output flags name toks = let specials = [(key, arg) | Special key arg <- toks] - needsC = any (\(key, _) -> key=="def") specials + needsC = any (\(key, _) -> key == "def") specials needsH = needsC includeGuard = map fixChar outHName @@ -178,6 +179,9 @@ output flags name toks = let when needsH $ writeFile outHName $ "#ifndef "++includeGuard++"\n\ \#define "++includeGuard++"\n\ + \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ + \#include \n\ + \#endif\n\ \#include \n"++ concatMap outTokenH specials++ "#endif\n" @@ -195,52 +199,70 @@ outHeaderCProg :: [(String, String)] -> String outHeaderCProg = concatMap $ \(key, arg) -> case key of "include" -> "#include "++arg++"\n" "define" -> "#define "++arg++"\n" + "undef" -> "#undef "++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" - _ -> "" + "let" -> case break (== '=') arg of + (_, "") -> "" + (header, _:body) -> case break isSpace header of + (name, args) -> + "#define hsc_"++name++"("++dropWhile isSpace args++") \ + \printf ("++joinLines body++");\n" + _ -> "" + where + joinLines = concat . intersperse " \\\n" . lines outHeaderHs :: Maybe String -> [(String, String)] -> String outHeaderHs inH toks = + " hsc_begin_options();\n"++ concatMap outSpecial toks ++ includeH ++ " hsc_end_options();\n\n" where outSpecial (key, arg) = case key of "include" -> case inH of - Nothing -> out ("-#include "++arg) + Nothing -> outOption ("-#include "++arg) Just _ -> "" "define" -> case inH of - Nothing -> out ("-optc-D"++toOptD arg) - Just _ -> "" - "option" -> out arg + Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg) + _ -> "" + "option" -> outOption arg _ | conditional key -> "#"++key++" "++arg++"\n" _ -> "" + goodForOptD arg = case arg of + "" -> True + c:_ | isSpace c -> True + '(':_ -> False + _:s -> goodForOptD s 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" + Just name -> outOption ("-#include \""++name++"\"") + outOption 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" -> "" + "undef" -> "" "option" -> "" "def" -> "" _ | conditional key -> "#"++key++" "++arg++"\n" + "let" -> "" _ -> " 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 + "define" -> "#define " ++arg++"\n" + "undef" -> "#undef " ++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':' ':_ -> @@ -280,6 +302,7 @@ conditional "ifndef" = True conditional "elif" = True conditional "else" = True conditional "endif" = True +conditional "error" = True conditional _ = False showCString :: String -> String diff --git a/ghc/utils/hsc2hs/hsc2hs.sh b/ghc/utils/hsc2hs/hsc2hs.sh index ba1e64a..d757d11 100644 --- a/ghc/utils/hsc2hs/hsc2hs.sh +++ b/ghc/utils/hsc2hs/hsc2hs.sh @@ -1 +1,9 @@ + +for arg; do + case "$arg" in + (--cc=*) HSC2HS_EXTRA=;; + (--) break;; + esac +done + $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 index 265dd4d..43841f0 100644 --- a/ghc/utils/hsc2hs/template-hsc.h +++ b/ghc/utils/hsc2hs/template-hsc.h @@ -1,4 +1,8 @@ +#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409 +#include +#endif #include + #include #include #include @@ -7,7 +11,18 @@ #define offsetof(t, f) ((size_t) &((t *)0)->f) #endif -static int hsc_options_started = 0; +#if __GLASGOW_HASKELL__ +static int hsc_options_started; + +static void hsc_begin_options (void) +{ +#if __GLASGOW_HASKELL__ < 409 + printf ("{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d", __GLASGOW_HASKELL__); + hsc_options_started = 1; +#else + hsc_options_started = 0; +#endif +} static void hsc_option (const char *s) { @@ -23,6 +38,11 @@ static void hsc_end_options (void) { if (hsc_options_started) printf (" #-}\n"); } +#else +#define hsc_begin_options() +#define hsc_option(s) +#define hsc_end_options() +#endif #define hsc_const(x) \ if ((x) < 0) \ -- 1.7.10.4