Bump version to 0.68.2 and prepare for release
[hsc2hs.git] / DirectCodegen.hs
1 {-# LANGUAGE CPP #-}
2 module DirectCodegen where
3
4 {-
5 The standard mode for hsc2hs: generates a C file which is
6 compiled and run; the output of that program is the .hs file.
7 -}
8
9 import Data.Char ( isAlphaNum, toUpper )
10 import Data.Foldable ( foldl' )
11 import Control.Monad ( when, forM_ )
12
13 import System.Exit ( ExitCode(..), exitWith )
14 import System.FilePath ( normalise )
15
16 import C
17 import Common
18 import Flags
19 import HSCParser
20 import UtilsCodegen
21
22 outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
23 outputDirect config outName outDir outBase name toks = do
24
25 let beVerbose = cVerbose config
26 flags = cFlags config
27 enableCol = cColumn config
28 cProgName = outDir++outBase++"_hsc_make.c"
29 oProgName = outDir++outBase++"_hsc_make.o"
30 progName = outDir++outBase++"_hsc_make"
31 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
32 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
33 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
34 ++ ".exe"
35 #endif
36 outHFile = outBase++"_hsc.h"
37 outHName = outDir++outHFile
38 outCName = outDir++outBase++"_hsc.c"
39
40 let execProgName
41 | null outDir = normalise ("./" ++ progName)
42 | otherwise = progName
43
44 let specials = [(pos, key, arg) | Special pos key arg <- toks]
45
46 let needsC = any (\(_, key, _) -> key == "def") specials
47 needsH = needsC
48 possiblyRemove = if cKeepFiles config
49 then flip const
50 else finallyRemove
51
52 let includeGuard = map fixChar outHName
53 where
54 fixChar c | isAlphaNum c = toUpper c
55 | otherwise = '_'
56
57 when (cCrossSafe config) $
58 forM_ specials (\ (SourcePos file line _,key,_) ->
59 when (not $ key `elem` ["const","offset","size","alignment","peek","poke","ptr",
60 "type","enum","error","warning","include","define","undef",
61 "if","ifdef","ifndef", "elif","else","endif"]) $
62 die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation"))
63
64 writeBinaryFile cProgName $
65 outTemplateHeaderCProg (cTemplate config)++
66 concatMap outFlagHeaderCProg flags++
67 concatMap outHeaderCProg specials++
68 "\nint main (void)\n{\n"++
69 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
70 outHsLine (SourcePos name 0 1)++
71 fst (foldl' (outTokenHs enableCol) (id, (True, True)) toks) ""++
72 " return 0;\n}\n"
73
74 when (cNoCompile config) $ exitWith ExitSuccess
75
76 rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config)
77 ( ["-c"]
78 ++ [cProgName]
79 ++ ["-o", oProgName]
80 ++ [f | CompFlag f <- flags]
81 )
82 possiblyRemove cProgName $
83 withUtilsObject config outDir outBase $ \oUtilsName -> do
84
85 rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config)
86 ( [oProgName, oUtilsName]
87 ++ ["-o", progName]
88 ++ [f | LinkFlag f <- flags]
89 )
90 possiblyRemove oProgName $ do
91
92 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
93 possiblyRemove progName $ do
94
95 when needsH $ writeBinaryFile outHName $
96 "#ifndef "++includeGuard++"\n" ++
97 "#define "++includeGuard++"\n" ++
98 "#include <HsFFI.h>\n" ++
99 "#if __NHC__\n" ++
100 "#undef HsChar\n" ++
101 "#define HsChar int\n" ++
102 "#endif\n" ++
103 concatMap outFlagH flags++
104 concatMap outTokenH specials++
105 "#endif\n"
106
107 when needsC $ writeBinaryFile outCName $
108 "#include \""++outHFile++"\"\n"++
109 concatMap outTokenC specials
110 -- NB. outHFile not outHName; works better when processed
111 -- by gcc or mkdependC.