Drop Paths_hsc2hs module from ghc.mk
[hsc2hs.git] / CrossCodegen.hs
1 {-# LANGUAGE NoMonomorphismRestriction #-}
2
3 module CrossCodegen where
4
5 {-
6 A special cross-compilation mode for hsc2hs, which generates a .hs
7 file without needing to run the executables that the C compiler
8 outputs.
9
10 Instead, it uses the output of compilations only -- specifically,
11 whether compilation fails. This is the same trick that autoconf uses
12 when cross compiling; if you want to know if sizeof(int) <= 4, then try
13 compiling:
14
15 > int x() {
16 > static int ary[1 - 2*(sizeof(int) <= 4)];
17 > }
18
19 and see if it fails. If you want to know sizeof(int), then
20 repeatedly apply this kind of test with differing values, using
21 binary search.
22 -}
23
24 import Prelude hiding (concatMap)
25 import System.IO (hPutStr, openFile, IOMode(..), hClose)
26 import System.Directory (removeFile)
27 import Data.Char (toLower,toUpper,isSpace)
28 import Control.Exception (assert, onException)
29 import Control.Monad (when, liftM, forM, ap)
30 import Control.Applicative as AP (Applicative(..))
31 import Data.Foldable (concatMap)
32 import Data.Maybe (fromMaybe)
33 import qualified Data.Sequence as S
34 import Data.Sequence ((|>),ViewL(..))
35 import System.Exit ( ExitCode(..) )
36 import System.Process
37
38 import C
39 import Common
40 import Flags
41 import HSCParser
42
43 -- A monad over IO for performing tests; keeps the commandline flags
44 -- and a state counter for unique filename generation.
45 -- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO))
46 newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) }
47
48 instance Functor TestMonad where
49 fmap = liftM
50
51 instance Applicative TestMonad where
52 pure a = TestMonad (\_ c -> pure (Right a, c))
53 (<*>) = ap
54
55 instance Monad TestMonad where
56 return = AP.pure
57 x >>= fn = TestMonad (\e c -> (runTest x e c) >>=
58 (\(a,c') -> either (\err -> return (Left err, c'))
59 (\result -> runTest (fn result) e c')
60 a))
61
62 data TestMonadEnv = TestMonadEnv {
63 testIsVerbose_ :: Bool,
64 testLogNestCount_ :: Int,
65 testKeepFiles_ :: Bool,
66 testGetBaseName_ :: FilePath,
67 testGetFlags_ :: [Flag],
68 testGetConfig_ :: Config,
69 testGetCompiler_ :: FilePath
70 }
71
72 testAsk :: TestMonad TestMonadEnv
73 testAsk = TestMonad (\e c -> return (Right e, c))
74
75 testIsVerbose :: TestMonad Bool
76 testIsVerbose = testIsVerbose_ `fmap` testAsk
77
78 testGetCompiler :: TestMonad FilePath
79 testGetCompiler = testGetCompiler_ `fmap` testAsk
80
81 testKeepFiles :: TestMonad Bool
82 testKeepFiles = testKeepFiles_ `fmap` testAsk
83
84 testGetFlags :: TestMonad [Flag]
85 testGetFlags = testGetFlags_ `fmap` testAsk
86
87 testGetConfig :: TestMonad Config
88 testGetConfig = testGetConfig_ `fmap` testAsk
89
90 testGetBaseName :: TestMonad FilePath
91 testGetBaseName = testGetBaseName_ `fmap` testAsk
92
93 testIncCount :: TestMonad Int
94 testIncCount = TestMonad (\_ c -> let next=succ c
95 in next `seq` return (Right c, next))
96 testFail' :: String -> TestMonad a
97 testFail' s = TestMonad (\_ c -> return (Left s, c))
98
99 testFail :: SourcePos -> String -> TestMonad a
100 testFail (SourcePos file line _) s = testFail' (file ++ ":" ++ show line ++ " " ++ s)
101
102 -- liftIO for TestMonad
103 liftTestIO :: IO a -> TestMonad a
104 liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c))
105
106 -- finally for TestMonad
107 testFinally :: TestMonad a -> TestMonad b -> TestMonad a
108 testFinally action cleanup = do r <- action `testOnException` cleanup
109 _ <- cleanup
110 return r
111
112 -- onException for TestMonad. This rolls back the state on an
113 -- IO exception, which isn't great but shouldn't matter for now
114 -- since only the test count is stored there.
115 testOnException :: TestMonad a -> TestMonad b -> TestMonad a
116 testOnException action cleanup = TestMonad (\e c -> runTest action e c
117 `onException` runTest cleanup e c >>= \(actionResult,c') ->
118 case actionResult of
119 Left _ -> do (_,c'') <- runTest cleanup e c'
120 return (actionResult,c'')
121 Right _ -> return (actionResult,c'))
122
123 -- prints the string to stdout if verbose mode is enabled.
124 -- Maintains a nesting count and pads with spaces so that:
125 -- testLog "a" $
126 -- testLog "b" $ return ()
127 -- will print
128 -- a
129 -- b
130 testLog :: String -> TestMonad a -> TestMonad a
131 testLog s a = TestMonad (\e c -> do let verbose = testIsVerbose_ e
132 nestCount = testLogNestCount_ e
133 when verbose $ putStrLn $ (concat $ replicate nestCount " ") ++ s
134 runTest a (e { testLogNestCount_ = nestCount+1 }) c)
135
136 testLog' :: String -> TestMonad ()
137 testLog' s = testLog s (return ())
138
139 testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a
140 testLogAtPos (SourcePos file line _) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a
141
142 -- Given a list of file suffixes, will generate a list of filenames
143 -- which are all unique and have the given suffixes. On exit from this
144 -- action, all those files will be removed (unless keepFiles is active)
145 makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a
146 makeTest fileSuffixes fn = do
147 c <- testIncCount
148 fileBase <- testGetBaseName
149 keepFiles <- testKeepFiles
150 let files = zipWith (++) (repeat (fileBase ++ show c)) fileSuffixes
151 testFinally (fn files)
152 (when (not keepFiles)
153 (mapM_ removeOrIgnore files))
154 where
155 removeOrIgnore f = liftTestIO (catchIO (removeFile f) (const $ return ()))
156 -- Convert from lists to tuples (to avoid "incomplete pattern" warnings in the callers)
157 makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a
158 makeTest2 (a,b) fn = makeTest [a,b] helper
159 where helper [a',b'] = fn (a',b')
160 helper _ = error "makeTest: internal error"
161 makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a
162 makeTest3 (a,b,c) fn = makeTest [a,b,c] helper
163 where helper [a',b',c'] = fn (a',b',c')
164 helper _ = error "makeTest: internal error"
165
166 -- A Zipper over lists. Unlike ListZipper, this separates at the type level
167 -- a list which may have a currently focused item (Zipper a) from
168 -- a list which _definitely_ has a focused item (ZCursor a), so
169 -- that zNext can be total.
170 data Zipper a = End { zEnd :: S.Seq a }
171 | Zipper (ZCursor a)
172
173 data ZCursor a = ZCursor { zCursor :: a,
174 zAbove :: S.Seq a, -- elements prior to the cursor
175 -- in regular order (not reversed!)
176 zBelow :: S.Seq a -- elements after the cursor
177 }
178
179 zipFromList :: [a] -> Zipper a
180 zipFromList [] = End S.empty
181 zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls))
182
183 zNext :: ZCursor a -> Zipper a
184 zNext (ZCursor c above below) =
185 case S.viewl below of
186 S.EmptyL -> End (above |> c)
187 c' :< below' -> Zipper (ZCursor c' (above |> c) below')
188
189 -- Generates the .hs file from the .hsc file, by looping over each
190 -- Special element and calling outputSpecial to find out what it needs.
191 diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad ()
192 diagnose inputFilename output input = do
193 checkValidity input
194 output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n")
195 loop (True, True) (zipFromList input)
196
197 where
198 loop _ (End _) = return ()
199 loop state@(lineSync, colSync)
200 (Zipper z@ZCursor {zCursor=Special _ key _}) =
201 case key of
202 _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do
203 condHolds <- checkConditional z
204 if condHolds
205 then loop state (zNext z)
206 else loop state =<< either testFail' return
207 (skipFalseConditional (zNext z))
208 "endif" -> loop state (zNext z)
209 _ -> do
210 sync <- outputSpecial output z
211 loop (lineSync && sync, colSync && sync) (zNext z)
212 loop state (Zipper z@ZCursor {zCursor=Text pos txt}) = do
213 state' <- outputText state output pos txt
214 loop state' (zNext z)
215
216 outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad Bool
217 outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line _) key value}) =
218 case key of
219 "const" -> outputConst value show >> return False
220 "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
221 "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") >> return False
222 "alignment" -> outputConst (alignment value)
223 (\i -> "(" ++ show i ++ ")") >> return False
224 "peek" -> outputConst ("offsetof(" ++ value ++ ")")
225 (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") >> return False
226 "poke" -> outputConst ("offsetof(" ++ value ++ ")")
227 (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") >> return False
228 "ptr" -> outputConst ("offsetof(" ++ value ++ ")")
229 (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") >> return False
230 "type" -> computeType z >>= output >> return False
231 "enum" -> computeEnum z >>= output >> return False
232 "error" -> testFail pos ("#error " ++ value)
233 "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value) >> return True
234 "include" -> return True
235 "define" -> return True
236 "undef" -> return True
237 _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode")
238 where outputConst value' formatter = computeConst z value' >>= (output . formatter)
239 outputSpecial _ _ = error "outputSpecial's argument isn't a Special"
240
241 outputText :: (Bool, Bool) -> (String -> TestMonad ()) -> SourcePos -> String
242 -> TestMonad (Bool, Bool)
243 outputText state output pos txt = do
244 enableCol <- fmap cColumn testGetConfig
245 let outCol col | enableCol = "{-# COLUMN " ++ show col ++ " #-}"
246 | otherwise = ""
247 let outLine (SourcePos file line _) = "{-# LINE " ++ show (line + 1) ++
248 " \"" ++ file ++ "\" #-}\n"
249 let (s, state') = outTextHs state pos txt id outLine outCol
250 output s
251 return state'
252
253 -- Bleh, messy. For each test we're compiling, we have a specific line of
254 -- code that may cause compiler errors -- that's the test we want to perform.
255 -- However, we *really* don't want any other kinds of compiler errors sneaking
256 -- in (which might be e.g. due to the user's syntax errors) or we'll make the
257 -- wrong conclusions on our tests.
258 --
259 -- So before we compile any of the tests, take a pass over the whole file and
260 -- generate a .c file which should fail if there are any syntax errors in what
261 -- the user gaves us. Hopefully, then the only reason our later compilations
262 -- might fail is the particular reason we want.
263 --
264 -- Another approach would be to try to parse the stdout of GCC and diagnose
265 -- whether the error is the one we want. That's tricky because of localization
266 -- etc. etc., though it would be less nerve-wracking. FYI it's not the approach
267 -- that autoconf went with.
268 checkValidity :: [Token] -> TestMonad ()
269 checkValidity input = do
270 config <- testGetConfig
271 flags <- testGetFlags
272 let test = outTemplateHeaderCProg (cTemplate config) ++
273 concatMap outFlagHeaderCProg flags ++
274 concatMap (uncurry outValidityCheck) (zip input [0..])
275 testLog ("checking for compilation errors") $ do
276 success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do
277 liftTestIO $ writeBinaryFile cFile test
278 compiler <- testGetCompiler
279 runCompiler compiler
280 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
281 Nothing
282 when (not success) $ testFail' "compilation failed"
283 testLog' "compilation is error-free"
284
285 outValidityCheck :: Token -> Int -> String
286 outValidityCheck s@(Special pos key value) uniq =
287 case key of
288 "const" -> checkValidConst value
289 "offset" -> checkValidConst ("offsetof(" ++ value ++ ")")
290 "size" -> checkValidConst ("sizeof(" ++ value ++ ")")
291 "alignment" -> checkValidConst (alignment value)
292 "peek" -> checkValidConst ("offsetof(" ++ value ++ ")")
293 "poke" -> checkValidConst ("offsetof(" ++ value ++ ")")
294 "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")")
295 "type" -> checkValidType
296 "enum" -> checkValidEnum
297 _ -> outHeaderCProg' s
298 where
299 checkValidConst value' = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n";
300 checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ " (void)(" ++ value ++ ")1;\n}\n";
301 checkValidEnum =
302 case parseEnum value of
303 Nothing -> ""
304 Just (_,_,enums) ->
305 "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++
306 concatMap (\(_,cName) -> validConstTest cName) enums ++
307 "}\n"
308
309 -- we want this to fail if the value is syntactically invalid or isn't a constant
310 validConstTest value' = outCLine pos ++ " {\n static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n (void)test_array;\n }\n";
311
312 outValidityCheck (Text _ _) _ = ""
313
314 -- Skips over some #if or other conditional that we found to be false.
315 -- I.e. the argument should be a zipper whose cursor is one past the #if,
316 -- and returns a zipper whose cursor points at the next item which
317 -- could possibly be compiled.
318 skipFalseConditional :: Zipper Token -> Either String (Zipper Token)
319 skipFalseConditional (End _) = Left "unterminated endif"
320 skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) =
321 case key of
322 "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
323 "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
324 "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
325 "elif" -> Right $ Zipper z
326 "else" -> Right $ Zipper z
327 "endif" -> Right $ zNext z
328 _ -> skipFalseConditional (zNext z)
329 skipFalseConditional (Zipper z) = skipFalseConditional (zNext z)
330
331 -- Skips over an #if all the way to the #endif
332 skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token)
333 skipFullConditional _ (End _) = Left "unterminated endif"
334 skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) =
335 case key of
336 "if" -> skipFullConditional (nest+1) (zNext z)
337 "ifdef" -> skipFullConditional (nest+1) (zNext z)
338 "ifndef" -> skipFullConditional (nest+1) (zNext z)
339 "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z)
340 "endif" | otherwise -> Right $ zNext z
341 _ -> skipFullConditional nest (zNext z)
342 skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z)
343
344 data IntegerConstant = Signed Integer |
345 Unsigned Integer deriving (Show)
346 -- Prints an syntatically valid integer in C
347 cShowInteger :: IntegerConstant -> String
348 cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)"
349 -- Trick to avoid overflowing large integer constants
350 -- http://www.hardtoc.com/archives/119
351 cShowInteger (Signed x) = show x
352 cShowInteger (Unsigned x) = show x ++ "u"
353
354 data IntegerComparison = GreaterOrEqual IntegerConstant |
355 LessOrEqual IntegerConstant
356 instance Show IntegerComparison where
357 showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c
358 showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c
359
360 cShowCmpTest :: IntegerComparison -> String
361 cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x
362 cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x
363
364 -- The cursor should point at #{const SOME_VALUE} or something like that.
365 -- Determines the value of SOME_VALUE using binary search; this
366 -- is a trick which is cribbed from autoconf's AC_COMPUTE_INT.
367 computeConst :: ZCursor Token -> String -> TestMonad Integer
368 computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = do
369 testLogAtPos pos ("computing " ++ value) $ do
370 nonNegative <- compareConst z (GreaterOrEqual (Signed 0))
371 integral <- checkValueIsIntegral z nonNegative
372 when (not integral) $ testFail pos $ value ++ " is not an integer"
373 (lower,upper) <- bracketBounds z nonNegative
374 int <- binarySearch z nonNegative lower upper
375 testLog' $ "result: " ++ show int
376 return int
377 where -- replace the Special's value with the provided value; e.g. the special
378 -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)".
379 z = zOrig {zCursor=specialSetValue value (zCursor zOrig)}
380 specialSetValue v (Special p k _) = Special p k v
381 specialSetValue _ _ = error "computeConst argument isn't a Special"
382 computeConst _ _ = error "computeConst argument isn't a Special"
383
384 -- Binary search, once we've bracketed the integer.
385 binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer
386 binarySearch _ _ l u | l == u = return l
387 binarySearch z nonNegative l u = do
388 let mid :: Integer
389 mid = (l+u+1) `div` 2
390 inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid)
391 let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1))
392 assert (l < mid && mid <= u && -- l < mid <= u
393 l <= l' && l' <= u' && u' <= u && -- l <= l' <= u' <= u
394 u'-l' < u-l) -- |u' - l'| < |u - l|
395 (binarySearch z nonNegative l' u')
396
397 -- Establishes bounds on the unknown integer. By searching increasingly
398 -- large powers of 2, it'll bracket an integer x by lower & upper
399 -- such that lower <= x <= upper.
400 --
401 -- Assumes 2's complement integers.
402 bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer)
403 bracketBounds z nonNegative = do
404 let -- test against integers 2**x-1 when positive, and 2**x when negative,
405 -- to avoid generating constants that'd overflow the machine's integers.
406 -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1).
407 -- If we're comparing against all 2**x-1, we'll stop our search
408 -- before we ever overflow int.
409 powersOfTwo = iterate (\a -> 2*a) 1
410 positiveBounds = map pred powersOfTwo
411 negativeBounds = map negate powersOfTwo
412
413 -- Test each element of the bounds list until we find one that exceeds
414 -- the integer.
415 loop cmp inner (maybeOuter:bounds') = do
416 outerBounded <- compareConst z (cmp maybeOuter)
417 if outerBounded
418 then return (inner,maybeOuter)
419 else loop cmp maybeOuter bounds'
420 loop _ _ _ = error "bracketBounds: infinite list exhausted"
421
422 if nonNegative
423 then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds
424 return (inner+1,outer)
425 else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds
426 return (outer,inner-1)
427
428 -- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize
429 haskellize :: String -> String
430 haskellize [] = []
431 haskellize (firstLetter:next) = toLower firstLetter : loop False next
432 where loop _ [] = []
433 loop _ ('_':as) = loop True as
434 loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as
435
436 -- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types &
437 -- constructors will be mangled by the C preprocessor. This mimics the same
438 -- mangling.
439 stringify :: String -> String
440 -- Spec: stringify = unwords . words
441 stringify = go False . dropWhile isSpace
442 where
443 go _haveSpace [] = []
444 go haveSpace (x:xs)
445 | isSpace x = go True xs
446 | otherwise = if haveSpace
447 then ' ' : x : go False xs
448 else x : go False xs
449
450 -- For #{alignment} codegen; mimic's template-hsc.h's hsc_alignment
451 alignment :: String -> String
452 alignment t = "offsetof(struct {char x__; " ++ t ++ " (y__); }, y__)"
453
454 computeEnum :: ZCursor Token -> TestMonad String
455 computeEnum z@(ZCursor (Special _ _ enumText) _ _) =
456 case parseEnum enumText of
457 Nothing -> return ""
458 Just (enumType,constructor,enums) ->
459 concatM enums $ \(maybeHsName, cName) -> do
460 constValue <- computeConst z cName
461 let hsName = fromMaybe (haskellize cName) maybeHsName
462 return $
463 hsName ++ " :: " ++ stringify enumType ++ "\n" ++
464 hsName ++ " = " ++ stringify constructor ++ " " ++ showsPrec 11 constValue "\n"
465 where concatM l = liftM concat . forM l
466 computeEnum _ = error "computeEnum argument isn't a Special"
467
468 -- Implementation of #{type}, using computeConst
469 computeType :: ZCursor Token -> TestMonad String
470 computeType z@(ZCursor (Special pos _ value) _ _) = do
471 testLogAtPos pos ("computing type of " ++ value) $ do
472 integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do
473 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4"
474 testLog' $ "result: " ++ (if success then "integer" else "floating")
475 return success
476 typeRet <- if integral
477 then do
478 signed <- testLog ("checking if type " ++ value ++ " is signed") $ do
479 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0"
480 testLog' $ "result: " ++ (if success then "signed" else "unsigned")
481 return success
482 size <- computeConst z ("sizeof(" ++ value ++ ")")
483 return $ (if signed then "Int" else "Word") ++ (show (size * 8))
484 else do
485 let checkSize test = testLog ("checking if " ++ test) $ do
486 success <- runCompileBooleanTest z test
487 testLog' $ "result: " ++ show success
488 return success
489 ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)")
490 if ldouble
491 then return "LDouble"
492 else do
493 double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)")
494 if double
495 then return "Double"
496 else return "Float"
497 testLog' $ "result: " ++ typeRet
498 return typeRet
499 computeType _ = error "computeType argument isn't a Special"
500
501 outHeaderCProg' :: Token -> String
502 outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value)
503 outHeaderCProg' _ = ""
504
505 -- Checks if an #if/#ifdef etc. etc. is true by inserting a #error
506 -- and seeing if the compile fails.
507 checkConditional :: ZCursor Token -> TestMonad Bool
508 checkConditional (ZCursor s@(Special pos key value) above below) = do
509 config <- testGetConfig
510 flags <- testGetFlags
511 let test = outTemplateHeaderCProg (cTemplate config) ++
512 (concatMap outFlagHeaderCProg flags) ++
513 (concatMap outHeaderCProg' above) ++
514 outHeaderCProg' s ++ "#error T\n" ++
515 (concatMap outHeaderCProg' below)
516 testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do
517 condTrue <- not `fmap` runCompileTest test
518 testLog' $ "result: " ++ show condTrue
519 return condTrue
520 checkConditional _ = error "checkConditional argument isn't a Special"
521
522 -- Make sure the value we're trying to binary search isn't floating point.
523 checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool
524 checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do
525 let intType = if nonNegative then "unsigned long long" else "long long"
526 testLog ("checking if " ++ value ++ " is an integer") $ do
527 success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")"
528 testLog' $ "result: " ++ (if success then "integer" else "floating")
529 return success
530 checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special"
531
532 compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool
533 compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do
534 testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do
535 success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest
536 testLog' $ "result: " ++ show success
537 return success
538 compareConst _ _ = error "compareConst argument isn't a Special"
539
540 -- Given a compile-time constant with boolean type, this extracts the
541 -- value of the constant by compiling a .c file only.
542 --
543 -- The trick comes from autoconf: use the fact that the compiler must
544 -- perform constant arithmetic for computation of array dimensions, and
545 -- will generate an error if the array has negative size.
546 runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool
547 runCompileBooleanTest (ZCursor s above below) booleanTest = do
548 config <- testGetConfig
549 flags <- testGetFlags
550 let test = -- all the surrounding code
551 outTemplateHeaderCProg (cTemplate config) ++
552 (concatMap outFlagHeaderCProg flags) ++
553 (concatMap outHeaderCProg' above) ++
554 outHeaderCProg' s ++
555 -- the test
556 "int _hsc2hs_test() {\n" ++
557 " static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++
558 " return test_array[0];\n" ++
559 "}\n" ++
560 (concatMap outHeaderCProg' below)
561 runCompileTest test
562
563 runCompileTest :: String -> TestMonad Bool
564 runCompileTest testStr = do
565 makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do
566 liftTestIO $ writeBinaryFile cFile testStr
567 flags <- testGetFlags
568 compiler <- testGetCompiler
569 runCompiler compiler
570 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
571 (Just stdout)
572
573 runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
574 runCompiler prog args mStdoutFile = do
575 let cmdLine = showCommandForUser prog args
576 testLog ("executing: " ++ cmdLine) $ liftTestIO $ do
577 mHOut <- case mStdoutFile of
578 Nothing -> return Nothing
579 Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode
580 process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut
581 case mHOut of
582 Just hOut -> hClose hOut
583 Nothing -> return ()
584 exitStatus <- waitForProcess process
585 return $ case exitStatus of
586 ExitSuccess -> True
587 ExitFailure _ -> False
588
589 -- The main driver for cross-compilation mode
590 outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO ()
591 outputCross config outName outDir outBase inName toks =
592 runTestMonad $ do
593 file <- liftTestIO $ openFile outName WriteMode
594 (diagnose inName (liftTestIO . hPutStr file) toks
595 `testFinally` (liftTestIO $ hClose file))
596 `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
597 where
598 tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
599 runTestMonad x = runTest x tmenv 0 >>= (handleError . fst)
600
601 handleError (Left e) = die (e++"\n")
602 handleError (Right ()) = return ()