testsuite: Ensure that ffi005 output order is predictable
[ghc.git] / testsuite / tests / ffi / should_run / ffi005.hs
1 -- !!! test for foreign import dynamic/wrapper, originally by Alastair Reid,
2 -- with a few changes to get it to run on GHC by Simon Marlow.
3
4 import Foreign hiding ( unsafePerformIO )
5 import Foreign.C
6 import Control.Exception
7 import System.IO.Unsafe
8 import Prelude hiding (read)
9 import System.IO (hFlush, stdout)
10
11 main = do
12
13 putStrLn "\nTesting sin==mysin (should return lots of Trues)"
14 print (testSin sin mysin)
15
16 -- disabled because errno is not necessarily a label these days
17
18 -- putStrLn "\nTesting errno"
19 -- err <- peek errno
20 -- putStrLn $ "errno == " ++ show err
21
22 putStrLn "\nTesting puts (and withString)"
23 hFlush stdout
24 withCString "Test puts successful" puts
25 flushStdout -- Flush the libc output buffer
26
27 putStrLn "\nTesting peekArray0"
28 s <- withCString "Test peekArray0 successful" (peekArray0 (castCharToCChar '\0'))
29 putStr (map castCCharToChar s)
30
31 -- disabled due to use of non-portable constants in arguments to open:
32
33 -- putStrLn "\nTesting open, read and close"
34 -- s <- testRead "ffi005.hs" 200
35 -- putStrLn (map castCCharToChar s)
36
37 -- putStrLn "\nTesting open, write and close"
38 -- testWrite "/tmp/test_write" "Test successful"
39
40 putStrLn "\nTesting sin==dynamic_sin (should return lots of Trues)"
41 print (testSin sin (dyn_sin sin_addr))
42
43 putStrLn "\nTesting sin==IO wrapped_sin (should return lots of Trues)"
44 sin_addr2 <- wrapIO (return . sin)
45 print (testSin sin (unsafePerformIO . (dyn_sinIO sin_addr2)))
46 freeHaskellFunPtr sin_addr2
47
48 putStrLn "\nTesting sin==Id wrapped_sin (should return lots of Trues)"
49 sin_addr3 <- wrapId sin
50 print (testSin sin (dyn_sin sin_addr3))
51 freeHaskellFunPtr sin_addr3
52
53 putStrLn "\nTesting exit"
54 hFlush stdout
55 exit 3
56
57 testSin f g = [ (f x == g x) | x <- [0,0.01 .. 1] ]
58
59 foreign import ccall "sin" mysin :: CDouble -> CDouble
60 foreign import ccall "dynamic" dyn_sin :: FunPtr (CDouble -> CDouble) -> (CDouble -> CDouble)
61 foreign import ccall "dynamic" dyn_sinIO :: FunPtr (CDouble -> IO CDouble) -> (CDouble -> IO CDouble)
62 foreign import ccall "&sin" sin_addr :: FunPtr (CDouble -> CDouble)
63 foreign import ccall "wrapper" wrapId :: (CDouble -> CDouble) -> IO (FunPtr (CDouble -> CDouble))
64 foreign import ccall "wrapper" wrapIO :: (CDouble -> IO CDouble) -> IO (FunPtr (CDouble -> IO CDouble))
65
66 -- foreign import ccall safe "static stdlib.h &errno" errno :: Ptr CInt
67
68 withBuffer sz m = do
69 b <- mallocArray sz
70 sz' <- m b
71 s <- peekArray sz' b
72 free b
73 return s
74
75 foreign import ccall puts :: CString -> IO CInt
76 foreign import ccall "flush_stdout" flushStdout :: IO ()
77
78 -- foreign import ccall "open" open' :: CString -> CInt -> IO CInt
79 -- foreign import ccall "open" open2' :: CString -> CInt -> CInt -> IO CInt
80 -- foreign import ccall "creat" creat' :: CString -> CInt -> IO CInt
81 -- foreign import ccall close :: CInt -> IO CInt
82 -- foreign import ccall "read" read' :: CInt -> CString -> CInt -> IO CInt
83 -- foreign import ccall "write" write' :: CInt -> CString -> CInt -> IO CInt
84
85 -- creat s m = withCString s $ \s' -> unix "creat" $ creat' s' m
86 -- open s m = withCString s $ \s' -> unix "open" $ open' s' m
87 -- open2 s m n = withCString s $ \s' -> unix "open2" $ open2' s' m n
88 -- write fd s = withCString s $ \s' -> unix "write" $ write' fd s' (fromIntegral (length s))
89 -- read fd sz = withBuffer sz $ \s' -> unix "read" $ read' fd s' (fromIntegral sz)
90
91 -- unix s m = do
92 -- x <- m
93 -- if x < 0
94 -- then do
95 -- err <- peek errno
96 -- ioError $ userError $ s ++ ": " ++ show (x,err)
97 -- else return (fromIntegral x)
98
99 -- testRead fn sz = bracket (open fn 0) close (flip read sz)
100 -- testWrite fn s = bracket (open2 fn (512+64+1) 511) close (flip write s)
101
102 foreign import ccall exit :: Int -> IO ()
103
104 -- Various bits of rubbish.
105 -- foreign import ccall "static stdlib.h exit" (***) :: CString -> CString -> IO Int
106 --
107 -- foreign import ccall safe "static stdlib.h printf" (+++) :: CString -> CString -> IO Int
108 -- foreign import ccall safe "static stdlib.h &errno" illegal_foo :: Ptr Int
109 --
110 -- foreign import ccall safe "wrapper" illegal_bar :: Char -> IO (FunCString)
111 -- foreign import ccall safe "dynamic" illegal_baz :: FunCString -> Char
112
113 -- foreign export ccall "id_charstar" id :: CString -> CString
114