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