From 16514f272fb42af6e9c7674a9bd6c9dce369231f Mon Sep 17 00:00:00 2001 From: David Terei Date: Wed, 20 Jul 2011 11:09:03 -0700 Subject: Move tests from tests/ghc-regress/* to just tests/* --- testsuite/tests/ffi/should_compile/1357.hs | 5 + testsuite/tests/ffi/should_compile/1357.stderr | 3 + testsuite/tests/ffi/should_compile/3624.hs | 4 + testsuite/tests/ffi/should_compile/3742.hs | 12 +++ testsuite/tests/ffi/should_compile/Makefile | 3 + testsuite/tests/ffi/should_compile/all.T | 38 ++++++++ testsuite/tests/ffi/should_compile/cc001.hs | 21 ++++ testsuite/tests/ffi/should_compile/cc001.stderr | 0 testsuite/tests/ffi/should_compile/cc004.hs | 67 +++++++++++++ testsuite/tests/ffi/should_compile/cc005.hs | 108 +++++++++++++++++++++ testsuite/tests/ffi/should_compile/cc007.hs | 4 + testsuite/tests/ffi/should_compile/cc008.hs | 8 ++ testsuite/tests/ffi/should_compile/cc009.hs | 8 ++ testsuite/tests/ffi/should_compile/cc009_inc.h | 1 + testsuite/tests/ffi/should_compile/cc010.hs | 5 + testsuite/tests/ffi/should_compile/cc011.hs | 9 ++ .../tests/ffi/should_compile/cc011.stderr-hugs | 2 + testsuite/tests/ffi/should_compile/cc012.hs | 6 ++ testsuite/tests/ffi/should_compile/cc013.hs | 14 +++ testsuite/tests/ffi/should_compile/cc014.hs | 4 + testsuite/tests/ffi/should_compile/ffi-deriv1.hs | 23 +++++ 21 files changed, 345 insertions(+) create mode 100644 testsuite/tests/ffi/should_compile/1357.hs create mode 100644 testsuite/tests/ffi/should_compile/1357.stderr create mode 100644 testsuite/tests/ffi/should_compile/3624.hs create mode 100644 testsuite/tests/ffi/should_compile/3742.hs create mode 100644 testsuite/tests/ffi/should_compile/Makefile create mode 100644 testsuite/tests/ffi/should_compile/all.T create mode 100644 testsuite/tests/ffi/should_compile/cc001.hs create mode 100644 testsuite/tests/ffi/should_compile/cc001.stderr create mode 100644 testsuite/tests/ffi/should_compile/cc004.hs create mode 100644 testsuite/tests/ffi/should_compile/cc005.hs create mode 100644 testsuite/tests/ffi/should_compile/cc007.hs create mode 100644 testsuite/tests/ffi/should_compile/cc008.hs create mode 100644 testsuite/tests/ffi/should_compile/cc009.hs create mode 100644 testsuite/tests/ffi/should_compile/cc009_inc.h create mode 100644 testsuite/tests/ffi/should_compile/cc010.hs create mode 100644 testsuite/tests/ffi/should_compile/cc011.hs create mode 100644 testsuite/tests/ffi/should_compile/cc011.stderr-hugs create mode 100644 testsuite/tests/ffi/should_compile/cc012.hs create mode 100644 testsuite/tests/ffi/should_compile/cc013.hs create mode 100644 testsuite/tests/ffi/should_compile/cc014.hs create mode 100644 testsuite/tests/ffi/should_compile/ffi-deriv1.hs (limited to 'testsuite/tests/ffi/should_compile') diff --git a/testsuite/tests/ffi/should_compile/1357.hs b/testsuite/tests/ffi/should_compile/1357.hs new file mode 100644 index 0000000000..1f5479bc1c --- /dev/null +++ b/testsuite/tests/ffi/should_compile/1357.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module T where + +import Foreign +foreign import ccall "f" f :: FunPtr (Int -> IO ()) diff --git a/testsuite/tests/ffi/should_compile/1357.stderr b/testsuite/tests/ffi/should_compile/1357.stderr new file mode 100644 index 0000000000..cd1cb7031a --- /dev/null +++ b/testsuite/tests/ffi/should_compile/1357.stderr @@ -0,0 +1,3 @@ + +1357.hs:5:1: + Warning: possible missing & in foreign import of FunPtr diff --git a/testsuite/tests/ffi/should_compile/3624.hs b/testsuite/tests/ffi/should_compile/3624.hs new file mode 100644 index 0000000000..8f42efc055 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/3624.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Test where + +foreign import ccall "path/to/foo.h foo" foo :: Int -> IO Float diff --git a/testsuite/tests/ffi/should_compile/3742.hs b/testsuite/tests/ffi/should_compile/3742.hs new file mode 100644 index 0000000000..c16b6009eb --- /dev/null +++ b/testsuite/tests/ffi/should_compile/3742.hs @@ -0,0 +1,12 @@ +module ShouldCompile where + +import Foreign +import Foreign.C + +-- extra space before the function name: +foreign import ccall unsafe " g_get_application_name" + g_get_application_name :: (IO (Ptr CChar)) + +-- and after: +foreign import ccall unsafe "g_get_application_name " + g_get_application_name' :: (IO (Ptr CChar)) diff --git a/testsuite/tests/ffi/should_compile/Makefile b/testsuite/tests/ffi/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ffi/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ffi/should_compile/all.T b/testsuite/tests/ffi/should_compile/all.T new file mode 100644 index 0000000000..ff8bc64b5d --- /dev/null +++ b/testsuite/tests/ffi/should_compile/all.T @@ -0,0 +1,38 @@ + +def ffi( opts ): + opts.extra_hc_opts = '-XForeignFunctionInterface -optc-Wno-implicit' + +setTestOpts(ffi) + +test('cc001', normal, compile, ['']) + +# Non-static C call +# cc004 test also uses stdcall, so it only works on i386. +if config.platform.startswith('i386-'): + ways = expect_fail_for(['extcore','optextcore']) +else: + ways = expect_fail +test('cc004', ways, compile, ['']) + +# foreign label +test('cc005', expect_fail_for(['extcore','optextcore']), compile, ['']) + +# Missing: +# test('cc006', normal, compile, ['']) + +test('cc007', normal, compile, ['']) +# foreign label +test('cc008', expect_fail_for(['extcore','optextcore']), compile, ['']) +# foreign label +test('cc009', expect_fail_for(['extcore','optextcore']), compile, ['']) +# Non-static C call +test('cc010', expect_fail_for(['extcore','optextcore']), compile, ['']) +test('cc011', normal, compile, ['']) +test('cc012', normal, compile, ['']) +test('cc013', normal, compile, ['']) +test('cc014', normal, compile, ['']) +test('ffi-deriv1', normal, compile, ['']) + +test('1357', normal, compile, ['']) +test('3624', normal, compile, ['']) +test('3742', normal, compile, ['']) diff --git a/testsuite/tests/ffi/should_compile/cc001.hs b/testsuite/tests/ffi/should_compile/cc001.hs new file mode 100644 index 0000000000..cd7318d000 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc001.hs @@ -0,0 +1,21 @@ +-- !!! cc001 -- ccall with standard boxed arguments and results + +module ShouldCompile where + +-- simple functions + +foreign import ccall unsafe "a" a :: IO Int + +foreign import ccall unsafe "b" b :: Int -> IO Int + +foreign import ccall unsafe "c" + c :: Int -> Char -> Float -> Double -> IO Float + +-- simple monadic code + +d = a >>= \ x -> + b x >>= \ y -> + c y 'f' 1.0 2.0 + + + diff --git a/testsuite/tests/ffi/should_compile/cc001.stderr b/testsuite/tests/ffi/should_compile/cc001.stderr new file mode 100644 index 0000000000..e69de29bb2 diff --git a/testsuite/tests/ffi/should_compile/cc004.hs b/testsuite/tests/ffi/should_compile/cc004.hs new file mode 100644 index 0000000000..fb754223b2 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc004.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +-- !!! cc004 -- foreign declarations +module ShouldCompile where + +import Foreign +import GHC.Exts +import Data.Int +import Data.Word + +-- importing functions + +-- We can't import the same function using both stdcall and ccall +-- calling conventions in the same file when compiling via C (this is a +-- restriction in the C backend caused by the need to emit a prototype +-- for stdcall functions). +foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) +foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int + +-- We can't redefine the calling conventions of certain functions (those from +-- math.h). +foreign import stdcall "my_sin" my_sin :: Double -> IO Double +foreign import stdcall "my_cos" my_cos :: Double -> IO Double + +foreign import stdcall "m1" m8 :: IO Int8 +foreign import stdcall "m2" m16 :: IO Int16 +foreign import stdcall "m3" m32 :: IO Int32 +foreign import stdcall "m4" m64 :: IO Int64 + +foreign import stdcall "dynamic" d8 :: Ptr a -> IO Int8 +foreign import stdcall "dynamic" d16 :: Ptr a -> IO Int16 +foreign import stdcall "dynamic" d32 :: Ptr a -> IO Int32 +foreign import stdcall "dynamic" d64 :: Ptr a -> IO Int64 + +foreign import ccall unsafe "kitchen" + sink :: Ptr a + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO () + + +foreign import ccall unsafe "dynamic" + sink2 :: Ptr a + -> (Ptr b + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Word8 + -> Word16 + -> Word32 + -> Float + -> Double + -> IO ()) + diff --git a/testsuite/tests/ffi/should_compile/cc005.hs b/testsuite/tests/ffi/should_compile/cc005.hs new file mode 100644 index 0000000000..e057cfd233 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc005.hs @@ -0,0 +1,108 @@ +-- !!! cc005 -- foreign export declarations +module ShouldCompile (d8) where + +import Foreign.Ptr --import Foreign + --import GlaExts + --import Int + --import Word +type Addr = Ptr () +foreign import ccall "wrapper" d8 :: (Int -> IO ()) -> IO Addr + +-- exporting functions +{- +m_stdcall :: Int -> IO Int +m_stdcall x = return x + +x = putChar + +foreign export ccall "m1" doo :: Int -> IO Int + +doo :: Eq a => a -> IO Int +doo _ = return 2 + +foreign export ccall "listAppend" plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a]) + +plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a]) +plusplus x y = do + l1 <- deRefStablePtr x + l2 <- deRefStablePtr y + makeStablePtr (l1 ++ l2) + +foreign export ccall "m11" m_stdcall :: Int -> IO Int + +m_ccall :: Int -> Int -> IO Int +m_ccall x y = return (x-y) + +foreign export ccall "m2" m_ccall :: Int -> Int -> IO Int + +foreign export ccall "putcha" putChar :: Char -> IO () + +foreign export stdcall "Math" "sin" my_sin :: Double -> IO Double +foreign export stdcall "Math" "cos" my_cos :: Double -> IO Double + +my_sin = undefined +my_cos = undefined + +foreign export stdcall "m111" m8 :: IO Int8 +foreign export stdcall "m22" m16 :: IO Int16 +foreign export stdcall "m3" m32 :: IO Int32 +foreign export stdcall "m4" m64 :: IO Int64 + +m8 = undefined +m16 = undefined +m32 = undefined +m64 = undefined + +foreign export stdcall dynamic d8 :: (Addr -> IO Int8) -> IO Addr +foreign export stdcall dynamic d16 :: (Addr -> IO Int16) -> IO Addr +foreign export stdcall dynamic d32 :: (Addr -> IO Int32) -> IO Addr +foreign export stdcall dynamic d64 :: (Addr -> IO Int64) -> IO Addr + + +d8 = undefined +d16 = undefined +d32 = undefined +d64 = undefined + + +foreign export ccall "kitchen" + sink :: --ForeignObj +-- -> ByteArray Int +-- -> MutableByteArray Int RealWorld + Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO Int + +sink = undefined +sink2 = undefined + +foreign export ccall dynamic + sink2 :: (--ForeignObj +-- -> ByteArray Int +-- -> MutableByteArray Int RealWorld + StablePtr a + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO ()) + -> IO Addr + + +-} diff --git a/testsuite/tests/ffi/should_compile/cc007.hs b/testsuite/tests/ffi/should_compile/cc007.hs new file mode 100644 index 0000000000..99337cc37f --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc007.hs @@ -0,0 +1,4 @@ +-- !!! cc007 -- foreign import with external name equal to Haskell name. +module ShouldCompile where + +foreign import ccall sine :: Double -> Double diff --git a/testsuite/tests/ffi/should_compile/cc008.hs b/testsuite/tests/ffi/should_compile/cc008.hs new file mode 100644 index 0000000000..2dd0bc99eb --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc008.hs @@ -0,0 +1,8 @@ +-- !!! cc008 -- foreign export dynamic returning newtype of Addr +module ShouldCompile where + +import Foreign +type Addr = Ptr () +newtype NPtr a = NPtr Addr + +foreign import ccall "wrapper" mkFoo :: IO () -> IO (NPtr Int) diff --git a/testsuite/tests/ffi/should_compile/cc009.hs b/testsuite/tests/ffi/should_compile/cc009.hs new file mode 100644 index 0000000000..3ece3a9a24 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc009.hs @@ -0,0 +1,8 @@ +-- !!! cc009 -- foreign label returning newtype of Addr +module ShouldCompile where + +import Foreign +type Addr = Ptr () +newtype NPtr a = NPtr Addr + +foreign import ccall "&" foo :: NPtr Int diff --git a/testsuite/tests/ffi/should_compile/cc009_inc.h b/testsuite/tests/ffi/should_compile/cc009_inc.h new file mode 100644 index 0000000000..be2f5392f8 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc009_inc.h @@ -0,0 +1 @@ +extern void *foo; diff --git a/testsuite/tests/ffi/should_compile/cc010.hs b/testsuite/tests/ffi/should_compile/cc010.hs new file mode 100644 index 0000000000..dd34730d42 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc010.hs @@ -0,0 +1,5 @@ +module ShouldCompile where +import Foreign +foreign import ccall "dynamic" imp :: Ptr () -> Int +f1 a = imp a + 1 +f2 a = imp a + 2 diff --git a/testsuite/tests/ffi/should_compile/cc011.hs b/testsuite/tests/ffi/should_compile/cc011.hs new file mode 100644 index 0000000000..25cce84bd3 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc011.hs @@ -0,0 +1,9 @@ +module ShouldCompile where + +import Foreign + +-- !!! test that a recursive newtype can be used as an argument or result +-- type of a foreign import. + +newtype T = T (Ptr T) +foreign import ccall foo :: T -> IO T diff --git a/testsuite/tests/ffi/should_compile/cc011.stderr-hugs b/testsuite/tests/ffi/should_compile/cc011.stderr-hugs new file mode 100644 index 0000000000..d6f9e1788c --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc011.stderr-hugs @@ -0,0 +1,2 @@ +cc011.c: In function `hugsprim_foo_0': +cc011.c:16: warning: assignment makes pointer from integer without a cast diff --git a/testsuite/tests/ffi/should_compile/cc012.hs b/testsuite/tests/ffi/should_compile/cc012.hs new file mode 100644 index 0000000000..288f9acd02 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc012.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- !!! test that infix operators can be exported with foreign export, +-- and that we can export something which isn't defined in this module. +module ShouldCompile where +foreign export ccall "plusInt" (+) :: Int -> Int -> Int + diff --git a/testsuite/tests/ffi/should_compile/cc013.hs b/testsuite/tests/ffi/should_compile/cc013.hs new file mode 100644 index 0000000000..09dd2ef2ef --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc013.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- !!! test that exporting the same thing multiple times works. +module ShouldCompile where + +import Data.Int + +foreign export ccall "addByte" (+) :: Int8 -> Int8 -> Int8 +foreign export ccall "addInt" (+) :: Int16 -> Int16 -> Int16 +foreign export ccall "addLong" (+) :: Int32 -> Int32 -> Int32 + +foreign export ccall "divByte" div :: Int8 -> Int8 -> Int8 +foreign export ccall "divInt" div :: Int16 -> Int16 -> Int16 +foreign export ccall "divLong" div :: Int32 -> Int32 -> Int32 + diff --git a/testsuite/tests/ffi/should_compile/cc014.hs b/testsuite/tests/ffi/should_compile/cc014.hs new file mode 100644 index 0000000000..bbf2d765ed --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc014.hs @@ -0,0 +1,4 @@ +module Blah ( foo ) where +import Foreign.Ptr ( FunPtr ) +type Bar = Int -> Double -> Double -> Double -> IO () +foreign import ccall unsafe "dynamic" foo :: FunPtr Bar -> Bar diff --git a/testsuite/tests/ffi/should_compile/ffi-deriv1.hs b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs new file mode 100644 index 0000000000..94d0df2fa4 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- Tests newtype unwrapping for the IO monad itself +-- Notice the RenderM monad, which is used in the +-- type of the callback function + +module ShouldCompile where + +import Foreign.Ptr +newtype RenderM a = RenderM (IO a) deriving (Functor, Monad) + +type RenderCallback = Int -> Int -> RenderM () + +foreign import ccall duma_onRender :: FunPtr RenderCallback -> RenderM () + +foreign import ccall "wrapper" mkRenderCallback + :: RenderCallback -> RenderM (FunPtr RenderCallback) + +onRender :: RenderCallback -> RenderM () +onRender f = mkRenderCallback f >>= duma_onRender + + + -- cgit v1.2.1