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