Update bounds on `process`
[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 (zipFromList input)
196
197 where
198 loop (End _) = return ()
199 loop (Zipper z@ZCursor {zCursor=Special _ key _}) =
200 case key of
201 _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do
202 condHolds <- checkConditional z
203 if condHolds
204 then loop (zNext z)
205 else loop =<< (either testFail' return (skipFalseConditional (zNext z)))
206 "endif" -> loop (zNext z)
207 _ -> do
208 outputSpecial output z
209 loop (zNext z)
210 loop (Zipper z@ZCursor {zCursor=Text pos txt}) = do
211 outputText output pos txt
212 loop (zNext z)
213
214 outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad ()
215 outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line) key value}) =
216 case key of
217 "const" -> outputConst value show
218 "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")")
219 "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")")
220 "peek" -> outputConst ("offsetof(" ++ value ++ ")")
221 (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")")
222 "poke" -> outputConst ("offsetof(" ++ value ++ ")")
223 (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")")
224 "ptr" -> outputConst ("offsetof(" ++ value ++ ")")
225 (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")")
226 "type" -> computeType z >>= output
227 "enum" -> computeEnum z >>= output
228 "error" -> testFail pos ("#error " ++ value)
229 "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value)
230 "include" -> return ()
231 "define" -> return ()
232 "undef" -> return ()
233 _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode")
234 where outputConst value' formatter = computeConst z value' >>= (output . formatter)
235 outputSpecial _ _ = error "outputSpecial's argument isn't a Special"
236
237 outputText :: (String -> TestMonad ()) -> SourcePos -> String -> TestMonad ()
238 outputText output (SourcePos file line) txt =
239 case break (=='\n') txt of
240 (noNewlines, []) -> output noNewlines
241 (firstLine, _:restOfLines) ->
242 output (firstLine ++ "\n" ++
243 "{-# LINE " ++ show (line+1) ++ " \"" ++ file ++ "\" #-}\n" ++
244 restOfLines)
245
246 -- Bleh, messy. For each test we're compiling, we have a specific line of
247 -- code that may cause compiler errors -- that's the test we want to perform.
248 -- However, we *really* don't want any other kinds of compiler errors sneaking
249 -- in (which might be e.g. due to the user's syntax errors) or we'll make the
250 -- wrong conclusions on our tests.
251 --
252 -- So before we compile any of the tests, take a pass over the whole file and
253 -- generate a .c file which should fail if there are any syntax errors in what
254 -- the user gaves us. Hopefully, then the only reason our later compilations
255 -- might fail is the particular reason we want.
256 --
257 -- Another approach would be to try to parse the stdout of GCC and diagnose
258 -- whether the error is the one we want. That's tricky because of localization
259 -- etc. etc., though it would be less nerve-wracking. FYI it's not the approach
260 -- that autoconf went with.
261 checkValidity :: [Token] -> TestMonad ()
262 checkValidity input = do
263 config <- testGetConfig
264 flags <- testGetFlags
265 let test = outTemplateHeaderCProg (cTemplate config) ++
266 concatMap outFlagHeaderCProg flags ++
267 concatMap (uncurry outValidityCheck) (zip input [0..])
268 testLog ("checking for compilation errors") $ do
269 success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do
270 liftTestIO $ writeBinaryFile cFile test
271 compiler <- testGetCompiler
272 runCompiler compiler
273 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
274 Nothing
275 when (not success) $ testFail' "compilation failed"
276 testLog' "compilation is error-free"
277
278 outValidityCheck :: Token -> Int -> String
279 outValidityCheck s@(Special pos key value) uniq =
280 case key of
281 "const" -> checkValidConst value
282 "offset" -> checkValidConst ("offsetof(" ++ value ++ ")")
283 "size" -> checkValidConst ("sizeof(" ++ value ++ ")")
284 "peek" -> checkValidConst ("offsetof(" ++ value ++ ")")
285 "poke" -> checkValidConst ("offsetof(" ++ value ++ ")")
286 "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")")
287 "type" -> checkValidType
288 "enum" -> checkValidEnum
289 _ -> outHeaderCProg' s
290 where
291 checkValidConst value' = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n";
292 checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ " (void)(" ++ value ++ ")1;\n}\n";
293 checkValidEnum =
294 case parseEnum value of
295 Nothing -> ""
296 Just (_,_,enums) ->
297 "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++
298 concatMap (\(_,cName) -> validConstTest cName) enums ++
299 "}\n"
300
301 -- we want this to fail if the value is syntactically invalid or isn't a constant
302 validConstTest value' = outCLine pos ++ " {\n static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n (void)test_array;\n }\n";
303
304 outValidityCheck (Text _ _) _ = ""
305
306 -- Skips over some #if or other conditional that we found to be false.
307 -- I.e. the argument should be a zipper whose cursor is one past the #if,
308 -- and returns a zipper whose cursor points at the next item which
309 -- could possibly be compiled.
310 skipFalseConditional :: Zipper Token -> Either String (Zipper Token)
311 skipFalseConditional (End _) = Left "unterminated endif"
312 skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) =
313 case key of
314 "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
315 "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
316 "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z)
317 "elif" -> Right $ Zipper z
318 "else" -> Right $ Zipper z
319 "endif" -> Right $ zNext z
320 _ -> skipFalseConditional (zNext z)
321 skipFalseConditional (Zipper z) = skipFalseConditional (zNext z)
322
323 -- Skips over an #if all the way to the #endif
324 skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token)
325 skipFullConditional _ (End _) = Left "unterminated endif"
326 skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) =
327 case key of
328 "if" -> skipFullConditional (nest+1) (zNext z)
329 "ifdef" -> skipFullConditional (nest+1) (zNext z)
330 "ifndef" -> skipFullConditional (nest+1) (zNext z)
331 "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z)
332 "endif" | otherwise -> Right $ zNext z
333 _ -> skipFullConditional nest (zNext z)
334 skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z)
335
336 data IntegerConstant = Signed Integer |
337 Unsigned Integer deriving (Show)
338 -- Prints an syntatically valid integer in C
339 cShowInteger :: IntegerConstant -> String
340 cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)"
341 -- Trick to avoid overflowing large integer constants
342 -- http://www.hardtoc.com/archives/119
343 cShowInteger (Signed x) = show x
344 cShowInteger (Unsigned x) = show x ++ "u"
345
346 data IntegerComparison = GreaterOrEqual IntegerConstant |
347 LessOrEqual IntegerConstant
348 instance Show IntegerComparison where
349 showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c
350 showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c
351
352 cShowCmpTest :: IntegerComparison -> String
353 cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x
354 cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x
355
356 -- The cursor should point at #{const SOME_VALUE} or something like that.
357 -- Determines the value of SOME_VALUE using binary search; this
358 -- is a trick which is cribbed from autoconf's AC_COMPUTE_INT.
359 computeConst :: ZCursor Token -> String -> TestMonad Integer
360 computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = do
361 testLogAtPos pos ("computing " ++ value) $ do
362 nonNegative <- compareConst z (GreaterOrEqual (Signed 0))
363 integral <- checkValueIsIntegral z nonNegative
364 when (not integral) $ testFail pos $ value ++ " is not an integer"
365 (lower,upper) <- bracketBounds z nonNegative
366 int <- binarySearch z nonNegative lower upper
367 testLog' $ "result: " ++ show int
368 return int
369 where -- replace the Special's value with the provided value; e.g. the special
370 -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)".
371 z = zOrig {zCursor=specialSetValue value (zCursor zOrig)}
372 specialSetValue v (Special p k _) = Special p k v
373 specialSetValue _ _ = error "computeConst argument isn't a Special"
374 computeConst _ _ = error "computeConst argument isn't a Special"
375
376 -- Binary search, once we've bracketed the integer.
377 binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer
378 binarySearch _ _ l u | l == u = return l
379 binarySearch z nonNegative l u = do
380 let mid :: Integer
381 mid = (l+u+1) `div` 2
382 inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid)
383 let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1))
384 assert (l < mid && mid <= u && -- l < mid <= u
385 l <= l' && l' <= u' && u' <= u && -- l <= l' <= u' <= u
386 u'-l' < u-l) -- |u' - l'| < |u - l|
387 (binarySearch z nonNegative l' u')
388
389 -- Establishes bounds on the unknown integer. By searching increasingly
390 -- large powers of 2, it'll bracket an integer x by lower & upper
391 -- such that lower <= x <= upper.
392 --
393 -- Assumes 2's complement integers.
394 bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer)
395 bracketBounds z nonNegative = do
396 let -- test against integers 2**x-1 when positive, and 2**x when negative,
397 -- to avoid generating constants that'd overflow the machine's integers.
398 -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1).
399 -- If we're comparing against all 2**x-1, we'll stop our search
400 -- before we ever overflow int.
401 powersOfTwo = iterate (\a -> 2*a) 1
402 positiveBounds = map pred powersOfTwo
403 negativeBounds = map negate powersOfTwo
404
405 -- Test each element of the bounds list until we find one that exceeds
406 -- the integer.
407 loop cmp inner (maybeOuter:bounds') = do
408 outerBounded <- compareConst z (cmp maybeOuter)
409 if outerBounded
410 then return (inner,maybeOuter)
411 else loop cmp maybeOuter bounds'
412 loop _ _ _ = error "bracketBounds: infinite list exhausted"
413
414 if nonNegative
415 then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds
416 return (inner+1,outer)
417 else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds
418 return (outer,inner-1)
419
420 -- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize
421 haskellize :: String -> String
422 haskellize [] = []
423 haskellize (firstLetter:next) = toLower firstLetter : loop False next
424 where loop _ [] = []
425 loop _ ('_':as) = loop True as
426 loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as
427
428 -- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types &
429 -- constructors will be mangled by the C preprocessor. This mimics the same
430 -- mangling.
431 stringify :: String -> String
432 -- Spec: stringify = unwords . words
433 stringify = go False . dropWhile isSpace
434 where
435 go _haveSpace [] = []
436 go haveSpace (x:xs)
437 | isSpace x = go True xs
438 | otherwise = if haveSpace
439 then ' ' : x : go False xs
440 else x : go False xs
441
442 computeEnum :: ZCursor Token -> TestMonad String
443 computeEnum z@(ZCursor (Special _ _ enumText) _ _) =
444 case parseEnum enumText of
445 Nothing -> return ""
446 Just (enumType,constructor,enums) ->
447 concatM enums $ \(maybeHsName, cName) -> do
448 constValue <- computeConst z cName
449 let hsName = fromMaybe (haskellize cName) maybeHsName
450 return $
451 hsName ++ " :: " ++ stringify enumType ++ "\n" ++
452 hsName ++ " = " ++ stringify constructor ++ " " ++ showsPrec 11 constValue "\n"
453 where concatM l = liftM concat . forM l
454 computeEnum _ = error "computeEnum argument isn't a Special"
455
456 -- Implementation of #{type}, using computeConst
457 computeType :: ZCursor Token -> TestMonad String
458 computeType z@(ZCursor (Special pos _ value) _ _) = do
459 testLogAtPos pos ("computing type of " ++ value) $ do
460 integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do
461 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4"
462 testLog' $ "result: " ++ (if success then "integer" else "floating")
463 return success
464 typeRet <- if integral
465 then do
466 signed <- testLog ("checking if type " ++ value ++ " is signed") $ do
467 success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0"
468 testLog' $ "result: " ++ (if success then "signed" else "unsigned")
469 return success
470 size <- computeConst z ("sizeof(" ++ value ++ ")")
471 return $ (if signed then "Int" else "Word") ++ (show (size * 8))
472 else do
473 let checkSize test = testLog ("checking if " ++ test) $ do
474 success <- runCompileBooleanTest z test
475 testLog' $ "result: " ++ show success
476 return success
477 ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)")
478 if ldouble
479 then return "LDouble"
480 else do
481 double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)")
482 if double
483 then return "Double"
484 else return "Float"
485 testLog' $ "result: " ++ typeRet
486 return typeRet
487 computeType _ = error "computeType argument isn't a Special"
488
489 outHeaderCProg' :: Token -> String
490 outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value)
491 outHeaderCProg' _ = ""
492
493 -- Checks if an #if/#ifdef etc. etc. is true by inserting a #error
494 -- and seeing if the compile fails.
495 checkConditional :: ZCursor Token -> TestMonad Bool
496 checkConditional (ZCursor s@(Special pos key value) above below) = do
497 config <- testGetConfig
498 flags <- testGetFlags
499 let test = outTemplateHeaderCProg (cTemplate config) ++
500 (concatMap outFlagHeaderCProg flags) ++
501 (concatMap outHeaderCProg' above) ++
502 outHeaderCProg' s ++ "#error T\n" ++
503 (concatMap outHeaderCProg' below)
504 testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do
505 condTrue <- not `fmap` runCompileTest test
506 testLog' $ "result: " ++ show condTrue
507 return condTrue
508 checkConditional _ = error "checkConditional argument isn't a Special"
509
510 -- Make sure the value we're trying to binary search isn't floating point.
511 checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool
512 checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do
513 let intType = if nonNegative then "unsigned long long" else "long long"
514 testLog ("checking if " ++ value ++ " is an integer") $ do
515 success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")"
516 testLog' $ "result: " ++ (if success then "integer" else "floating")
517 return success
518 checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special"
519
520 compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool
521 compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do
522 testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do
523 success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest
524 testLog' $ "result: " ++ show success
525 return success
526 compareConst _ _ = error "compareConst argument isn't a Special"
527
528 -- Given a compile-time constant with boolean type, this extracts the
529 -- value of the constant by compiling a .c file only.
530 --
531 -- The trick comes from autoconf: use the fact that the compiler must
532 -- perform constant arithmetic for computation of array dimensions, and
533 -- will generate an error if the array has negative size.
534 runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool
535 runCompileBooleanTest (ZCursor s above below) booleanTest = do
536 config <- testGetConfig
537 flags <- testGetFlags
538 let test = -- all the surrounding code
539 outTemplateHeaderCProg (cTemplate config) ++
540 (concatMap outFlagHeaderCProg flags) ++
541 (concatMap outHeaderCProg' above) ++
542 outHeaderCProg' s ++
543 -- the test
544 "int _hsc2hs_test() {\n" ++
545 " static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++
546 " return test_array[0];\n" ++
547 "}\n" ++
548 (concatMap outHeaderCProg' below)
549 runCompileTest test
550
551 runCompileTest :: String -> TestMonad Bool
552 runCompileTest testStr = do
553 makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do
554 liftTestIO $ writeBinaryFile cFile testStr
555 flags <- testGetFlags
556 compiler <- testGetCompiler
557 runCompiler compiler
558 (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags])
559 (Just stdout)
560
561 runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool
562 runCompiler prog args mStdoutFile = do
563 let cmdLine = showCommandForUser prog args
564 testLog ("executing: " ++ cmdLine) $ liftTestIO $ do
565 mHOut <- case mStdoutFile of
566 Nothing -> return Nothing
567 Just stdoutFile -> liftM Just $ openFile stdoutFile WriteMode
568 process <- runProcess prog args Nothing Nothing Nothing mHOut mHOut
569 case mHOut of
570 Just hOut -> hClose hOut
571 Nothing -> return ()
572 exitStatus <- waitForProcess process
573 return $ case exitStatus of
574 ExitSuccess -> True
575 ExitFailure _ -> False
576
577 -- The main driver for cross-compilation mode
578 outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO ()
579 outputCross config outName outDir outBase inName toks =
580 runTestMonad $ do
581 file <- liftTestIO $ openFile outName WriteMode
582 (diagnose inName (liftTestIO . hPutStr file) toks
583 `testFinally` (liftTestIO $ hClose file))
584 `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors
585 where
586 tmenv = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config)
587 runTestMonad x = runTest x tmenv 0 >>= (handleError . fst)
588
589 handleError (Left e) = die (e++"\n")
590 handleError (Right ()) = return ()