Add regression test case for old issue #493
authorKevin Buhr <buhr@asaurus.net>
Tue, 7 May 2019 00:24:31 +0000 (19:24 -0500)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Fri, 10 May 2019 20:51:11 +0000 (16:51 -0400)
testsuite/.gitignore
testsuite/tests/ffi/should_run/T493.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/T493.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/T493_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/all.T

index d9fa58d..737c9f2 100644 (file)
@@ -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 (file)
index 0000000..d0f70c1
--- /dev/null
@@ -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 (file)
index 0000000..ef363a6
--- /dev/null
@@ -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 (file)
index 0000000..0cfa864
--- /dev/null
@@ -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);
+}
index d780fb8..69b0f30 100644 (file)
@@ -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'])