diff options
Diffstat (limited to 'testsuite')
| -rw-r--r-- | testsuite/.gitignore | 1 | ||||
| -rw-r--r-- | testsuite/tests/ffi/should_run/T493.hs | 41 | ||||
| -rw-r--r-- | testsuite/tests/ffi/should_run/T493.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/ffi/should_run/T493_c.c | 16 | ||||
| -rw-r--r-- | testsuite/tests/ffi/should_run/all.T | 2 |
5 files changed, 62 insertions, 0 deletions
diff --git a/testsuite/.gitignore b/testsuite/.gitignore index d9fa58dbdb..737c9f2385 100644 --- a/testsuite/.gitignore +++ b/testsuite/.gitignore @@ -694,6 +694,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk /tests/ffi/should_run/Capi_Ctype_002 /tests/ffi/should_run/Capi_Ctype_A_001.hs /tests/ffi/should_run/Capi_Ctype_A_002.hs +/tests/ffi/should_run/T493 /tests/ffi/should_run/T1288 /tests/ffi/should_run/T1679 /tests/ffi/should_run/T2276 diff --git a/testsuite/tests/ffi/should_run/T493.hs b/testsuite/tests/ffi/should_run/T493.hs new file mode 100644 index 0000000000..d0f70c1eb7 --- /dev/null +++ b/testsuite/tests/ffi/should_run/T493.hs @@ -0,0 +1,41 @@ +import Foreign +import Foreign.C + +-- These newtypes... +newtype MyFunPtr a = MyFunPtr { getFunPtr :: FunPtr a } +newtype MyPtr a = MyPtr (Ptr a) +newtype MyIO a = MyIO { runIO :: IO a } +-- should be supported by... + +-- foreign import dynamics +foreign import ccall "dynamic" + mkFun1 :: MyFunPtr (CInt -> CInt) -> (CInt -> CInt) +foreign import ccall "dynamic" + mkFun2 :: MyPtr (Int32 -> Int32) -> (CInt -> CInt) + +-- and foreign import wrappers. +foreign import ccall "wrapper" + mkWrap1 :: (CInt -> CInt) -> MyIO (MyFunPtr (CInt -> CInt)) +foreign import ccall "wrapper" + mkWrap2 :: (CInt -> CInt) -> MyIO (MyPtr (Int32 -> Int32)) + +-- We'll need a dynamic function point to export +foreign import ccall "getDbl" getDbl :: IO (MyFunPtr (CInt -> CInt)) +-- and a Haskell function to export +half :: CInt -> CInt +half = (`div` 2) +-- and a C function to pass it to. +foreign import ccall "apply" apply1 :: MyFunPtr (CInt -> CInt) -> Int -> Int +foreign import ccall "apply" apply2 :: MyPtr (Int32 -> Int32) -> Int -> Int + +main :: IO () +main = do + + dbl <- getDbl + let dbl1 = mkFun1 dbl + dbl2 = mkFun2 $ MyPtr $ castFunPtrToPtr $ getFunPtr dbl + print (dbl1 21, dbl2 21) + + half1 <- runIO $ mkWrap1 half + half2 <- runIO $ mkWrap2 half + print (apply1 half1 84, apply2 half2 84) diff --git a/testsuite/tests/ffi/should_run/T493.stdout b/testsuite/tests/ffi/should_run/T493.stdout new file mode 100644 index 0000000000..ef363a6b80 --- /dev/null +++ b/testsuite/tests/ffi/should_run/T493.stdout @@ -0,0 +1,2 @@ +(42,42) +(42,42) diff --git a/testsuite/tests/ffi/should_run/T493_c.c b/testsuite/tests/ffi/should_run/T493_c.c new file mode 100644 index 0000000000..0cfa8648fa --- /dev/null +++ b/testsuite/tests/ffi/should_run/T493_c.c @@ -0,0 +1,16 @@ +typedef int (*intfun_p)(int); + +int dbl(int x) +{ + return x*2; +} + +intfun_p getDbl(void) +{ + return dbl; +} + +int apply(intfun_p f, int x) +{ + return f(x); +} diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index d780fb809d..69b0f30c2c 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -198,3 +198,5 @@ test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c' test('PrimFFIInt16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt16_c.c']) test('PrimFFIWord16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord16_c.c']) + +test('T493', [], compile_and_run, ['T493_c.c']) |