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