9c17441954b15850dd99136cae354294d380020c
[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 withCString "Test successful" puts
24
25 putStrLn "\nTesting peekArray0"
26 s <- withCString "Test successful" (peekArray0 (castCharToCChar '\0'))
27 putStr (map castCCharToChar s)
28
29 -- disabled due to use of non-portable constants in arguments to open:
30
31 -- putStrLn "\nTesting open, read and close"
32 -- s <- testRead "ffi005.hs" 200
33 -- putStrLn (map castCCharToChar s)
34
35 -- putStrLn "\nTesting open, write and close"
36 -- testWrite "/tmp/test_write" "Test successful"
37
38 putStrLn "\nTesting sin==dynamic_sin (should return lots of Trues)"
39 print (testSin sin (dyn_sin sin_addr))
40
41 putStrLn "\nTesting sin==IO wrapped_sin (should return lots of Trues)"
42 sin_addr2 <- wrapIO (return . sin)
43 print (testSin sin (unsafePerformIO . (dyn_sinIO sin_addr2)))
44 freeHaskellFunPtr sin_addr2
45
46 putStrLn "\nTesting sin==Id wrapped_sin (should return lots of Trues)"
47 sin_addr3 <- wrapId sin
48 print (testSin sin (dyn_sin sin_addr3))
49 freeHaskellFunPtr sin_addr3
50
51 putStrLn "\nTesting exit"
52 hFlush stdout
53 exit 3
54
55 testSin f g = [ (f x == g x) | x <- [0,0.01 .. 1] ]
56
57 foreign import ccall "sin" mysin :: CDouble -> CDouble
58 foreign import ccall "dynamic" dyn_sin :: FunPtr (CDouble -> CDouble) -> (CDouble -> CDouble)
59 foreign import ccall "dynamic" dyn_sinIO :: FunPtr (CDouble -> IO CDouble) -> (CDouble -> IO CDouble)
60 foreign import ccall "&sin" sin_addr :: FunPtr (CDouble -> CDouble)
61 foreign import ccall "wrapper" wrapId :: (CDouble -> CDouble) -> IO (FunPtr (CDouble -> CDouble))
62 foreign import ccall "wrapper" wrapIO :: (CDouble -> IO CDouble) -> IO (FunPtr (CDouble -> IO CDouble))
63
64 -- foreign import ccall safe "static stdlib.h &errno" errno :: Ptr CInt
65
66 withBuffer sz m = do
67 b <- mallocArray sz
68 sz' <- m b
69 s <- peekArray sz' b
70 free b
71 return s
72
73 foreign import ccall puts :: CString -> IO CInt
74
75 -- foreign import ccall "open" open' :: CString -> CInt -> IO CInt
76 -- foreign import ccall "open" open2' :: CString -> CInt -> CInt -> IO CInt
77 -- foreign import ccall "creat" creat' :: CString -> CInt -> IO CInt
78 -- foreign import ccall close :: CInt -> IO CInt
79 -- foreign import ccall "read" read' :: CInt -> CString -> CInt -> IO CInt
80 -- foreign import ccall "write" write' :: CInt -> CString -> CInt -> IO CInt
81
82 -- creat s m = withCString s $ \s' -> unix "creat" $ creat' s' m
83 -- open s m = withCString s $ \s' -> unix "open" $ open' s' m
84 -- open2 s m n = withCString s $ \s' -> unix "open2" $ open2' s' m n
85 -- write fd s = withCString s $ \s' -> unix "write" $ write' fd s' (fromIntegral (length s))
86 -- read fd sz = withBuffer sz $ \s' -> unix "read" $ read' fd s' (fromIntegral sz)
87
88 -- unix s m = do
89 -- x <- m
90 -- if x < 0
91 -- then do
92 -- err <- peek errno
93 -- ioError $ userError $ s ++ ": " ++ show (x,err)
94 -- else return (fromIntegral x)
95
96 -- testRead fn sz = bracket (open fn 0) close (flip read sz)
97 -- testWrite fn s = bracket (open2 fn (512+64+1) 511) close (flip write s)
98
99 foreign import ccall exit :: Int -> IO ()
100
101 -- Various bits of rubbish.
102 -- foreign import ccall "static stdlib.h exit" (***) :: CString -> CString -> IO Int
103 --
104 -- foreign import ccall safe "static stdlib.h printf" (+++) :: CString -> CString -> IO Int
105 -- foreign import ccall safe "static stdlib.h &errno" illegal_foo :: Ptr Int
106 --
107 -- foreign import ccall safe "wrapper" illegal_bar :: Char -> IO (FunCString)
108 -- foreign import ccall safe "dynamic" illegal_baz :: FunCString -> Char
109
110 -- foreign export ccall "id_charstar" id :: CString -> CString
111