[project @ 2001-06-26 14:11:05 by sewardj]

Add ccall tests.

testsuite/tests/ghc-regress/ccall/should_compile/all.T

+
+include ($confdir ++ "/../vanilla-test.T")
+
+-- Args to vtc are: extra compile flags
+
+-- Use this itsy helper fn to pass in an extra flag
+def myvtc($extra_comp_args)
+{
+   vtc(" -fglasgow-exts -package lang " ++ $extra_comp_args)
+}
+
+test "cc001" { myvtc("") }
+test "cc002" { myvtc("") }
+test "cc003" { myvtc("") }
+test "cc004" { myvtc("-fvia-C") }
+test "cc005" { myvtc("-fvia-C") }
+test "cc006" { myvtc("-fvia-C -fno-prune-tydecls") }
+test "cc007" { myvtc("") }
+test "cc008" { myvtc("") }
+test "cc009" { myvtc("") }
+test "cc010" { myvtc("-fvia-C") }

testsuite/tests/ghc-regress/ccall/should_compile/cc001.hs

+-- !!! cc001 -- ccall with standard boxed arguments and results
+
+module ShouldCompile where
+
+-- simple functions
+
+a :: IO Int
+a = _ccall_ a
+
+b :: Int -> IO Int
+b x = _ccall_ b x
+
+c :: Int -> Char -> Float -> Double -> IO Float
+c x1 x2 x3 x4 = _ccall_ c x1 x2 x3 x4
+
+-- simple monadic code
+
+d =	a		>>= \ x ->
+	b x		>>= \ y ->
+	c y 'f' 1.0 2.0
+
+
+	

testsuite/tests/ghc-regress/ccall/should_compile/cc002.hs

+-- !!! cc002 -- ccall with ambiguous result (should be defaulted to ())
+module ShouldCompile where
+
+a :: IO ()
+a = do
+ _ccall_ a
+ return ()
+
+	

testsuite/tests/ghc-regress/ccall/should_compile/cc003.hs

+-- !!! cc003 -- ccall with unresolved polymorphism (should fail)
+-- !!! not anymore (as of 0.29, result type will default to ())
+module ShouldCompile where
+
+fubar :: IO Int
+fubar = _ccall_ f >>_ccall_ b
+		     -- ^ result type of f "lost" (never gets generalised)

testsuite/tests/ghc-regress/ccall/should_compile/cc004.hs

+-- !!! cc004 -- foreign declarations
+module ShouldCompile where
+
+import Foreign
+import GlaExts
+import Int
+import Word
+
+-- importing functions
+
+foreign import stdcall "m" m_stdcall :: StablePtr a -> IO (StablePtr b)
+foreign import ccall   "m" unsafe m_ccall   :: ByteArray Int -> IO Int
+
+foreign import stdcall "Math" "sin" my_sin :: Double -> IO Double
+foreign import stdcall "Math" "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  :: Addr -> IO Int8
+foreign import stdcall dynamic d16 :: Addr -> IO Int16
+foreign import stdcall dynamic d32 :: Addr -> IO Int32
+foreign import stdcall dynamic d64 :: Addr -> IO Int64
+
+foreign import ccall "kitchen" unsafe 
+   sink :: ForeignObj 
+        -> ByteArray Int 
+	-> MutableByteArray Int RealWorld
+	-> Int
+	-> Int8
+	-> Int16
+	-> Int32
+	-> Int64
+	-> Word8
+	-> Word16
+	-> Word32
+	-> Word64
+	-> Float
+	-> Double
+	-> IO ()
+
+
+foreign import ccall dynamic unsafe
+  sink2 :: Addr
+        -> (ForeignObj 
+        -> ByteArray Int 
+	-> MutableByteArray Int RealWorld
+	-> Int
+	-> Int8
+	-> Int16
+	-> Int32
+	-> Word8
+	-> Word16
+	-> Word32
+	-> Float
+	-> Double
+	-> IO ())
+

testsuite/tests/ghc-regress/ccall/should_compile/cc005.hs

+-- !!! cc005 -- foreign export declarations
+module ShouldCompile (d8) where
+
+import Foreign
+import GlaExts
+import Int
+import Word
+
+foreign export ccall dynamic 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
+
+
+-}

testsuite/tests/ghc-regress/ccall/should_compile/cc006.hs

+-- !!! cc006 -- ccall with non-standard boxed arguments and results
+
+module ShouldCompile where
+
+import Foreign
+import CCall
+
+-- Test returning results
+
+a :: IO Int
+a = _ccall_ a
+
+b :: IO (StablePtr Int)
+b = _ccall_ b
+
+-- Test taking arguments
+
+c :: ForeignObj -> IO Int
+c x = _ccall_ c x
+
+d :: StablePtr Int -> IO Int
+d x = _ccall_ d x

testsuite/tests/ghc-regress/ccall/should_compile/cc007.hs

+-- !!! cc007 -- foreign import with external name equal to Haskell name.
+module ShouldCompile where
+
+foreign import sine :: Double -> Double

testsuite/tests/ghc-regress/ccall/should_compile/cc008.hs

+-- !!! cc008 -- foreign export dynamic returning newtype of Addr
+module ShouldCompile where
+
+import Addr
+
+newtype Ptr a = Ptr Addr
+
+foreign export dynamic mkFoo :: IO () -> IO (Ptr Int)

testsuite/tests/ghc-regress/ccall/should_compile/cc009.hs

+-- !!! cc009 -- foreign label returning newtype of Addr
+module ShouldCompile where
+
+import Addr
+
+newtype Ptr a = Ptr Addr
+
+foreign label foo :: Ptr Int

testsuite/tests/ghc-regress/ccall/should_compile/cc010.hs

+module ShouldCompile where
+import Foreign
+foreign import dynamic imp :: Addr -> Int
+f1 a = imp a + 1
+f2 a = imp a + 2

testsuite/tests/ghc-regress/ccall/should_fail/all.T

+
+include ($confdir ++ "/../vanilla-test.T")
+
+-- Args to vtf are: extra compile flags
+
+def myvtf ( $args )
+{
+   vtf ( " -package lang " ++ $args)
+}
+
+test "cc001" { myvtf("") }
+test "cc002" { myvtf("") }
+test "cc004" { myvtf("") }
+test "cc005" { myvtf("") }

testsuite/tests/ghc-regress/ccall/should_fail/cc001.hs

+-- !!! cc001 -- ccall with ambiguous argument
+module Test where
+
+f :: IO ()
+f = _ccall_ foo (undefined ())

testsuite/tests/ghc-regress/ccall/should_fail/cc001.stderr

+
+cc001.hs:5:
+    Ambiguous type variable(s) `t'
+	in the constraint `PrelGHC.CCallable t'
+    arising from an argument in the _ccall_ to `foo', namely `(undefined ())' at cc001.hs:5
+    in the definition of function `f': _ccall_ foo (undefined ())

testsuite/tests/ghc-regress/ccall/should_fail/cc002.hs

+-- !!! cc002 -- ccall with non-standard boxed arguments and results
+
+module Test where
+
+import Foreign
+
+-- Test returning results
+
+a :: IO ForeignObj
+a = _ccall_ a
+
+b :: IO (StablePtr Double)
+b = _ccall_ b
+
+-- Test taking arguments
+
+c :: ForeignObj -> IO Int
+c x = _ccall_ c x
+
+d :: StablePtr Int -> IO Int
+d x = _ccall_ d x

testsuite/tests/ghc-regress/ccall/should_fail/cc002.stderr

+
+cc002.hs:10:
+    No instance for `PrelGHC.CReturnable ForeignObj'
+    arising from the result of the _ccall_ to `a' at cc002.hs:10
+    in the definition of function `a': _ccall_ a

testsuite/tests/ghc-regress/ccall/should_fail/cc004.hs

+-- !!! cc004 -- ccall with synonyms, polymorphic type variables and user type variables.
+module Test where
+
+-- Since I messed up the handling of polymorphism originally, I'll
+-- explicitly test code with UserSysTyVar (ie an explicit polymorphic
+-- signature)
+
+foo = _ccall_ f	`thenADR` \ a -> return (a + 1)
+ where 
+   thenADR :: IO a -> (a -> IO b) -> IO b
+   thenADR = (>>=)
+
+-- and with a PolySysTyVar (ie no explicit signature)
+
+bar = _ccall_ f	`thenADR` \ a -> return (a + 1)
+ where 
+   -- thenADR :: IO a -> (a -> IO b) -> IO b
+   thenADR = (>>=)
+
+-- and with a type synonym
+
+type INT = Int
+barfu :: IO INT
+barfu = _ccall_ b

testsuite/tests/ghc-regress/ccall/should_fail/cc004.stderr

+
+Cannot generalise these overloadings (in a _ccall_):
+    PrelGHC.CReturnable a arising from the result of the _ccall_ to `f' at cc004.hs:8
+
+Cannot generalise these overloadings (in a _ccall_):
+    PrelGHC.CReturnable a arising from the result of the _ccall_ to `f' at cc004.hs:15
+
+cc004.hs:8:
+    Ambiguous type variable(s) `a'
+	in the constraint `PrelGHC.CReturnable a'
+    arising from the result of the _ccall_ to `f' at cc004.hs:8
+    In the first argument of `thenADR', namely `_ccall_ f'
+    in the definition of function `foo':
+	(_ccall_ f) `thenADR` (\ a -> return (a + 1))
+
+cc004.hs:8:
+    Ambiguous type variable(s) `a' in the constraint `Num a'
+    arising from the literal `1' at cc004.hs:8
+    In the second argument of `(+)', namely `1'
+    In the first argument of `return', namely `(a + 1)'
+
+cc004.hs:15:
+    Ambiguous type variable(s) `a'
+	in the constraint `PrelGHC.CReturnable a'
+    arising from the result of the _ccall_ to `f' at cc004.hs:15
+    In the first argument of `thenADR', namely `_ccall_ f'
+    in the definition of function `bar':
+	(_ccall_ f) `thenADR` (\ a -> return (a + 1))
+
+cc004.hs:15:
+    Ambiguous type variable(s) `a' in the constraint `Num a'
+    arising from the literal `1' at cc004.hs:15
+    In the second argument of `(+)', namely `1'
+    In the first argument of `return', namely `(a + 1)'

testsuite/tests/ghc-regress/ccall/should_fail/cc005.hs

+-- !!! illegal types in foreign export delarations
+
+module ShouldFail where
+
+import PrelGHC
+
+foreign export foo :: Int# -> IO ()
+foo i | i ==# 0# = return ()
+
+foreign export bar :: Int -> Int#
+bar _ = 42#

testsuite/tests/ghc-regress/ccall/should_fail/cc005.stderr

+
+cc005.hs:7:
+    Unacceptable argument type in foreign declaration: Int#
+    When checking declaration:
+	foreign export _ccall "foo" foo :: Int# -> IO ()
+
+cc005.hs:10:
+    Unacceptable result type in foreign declaration: Int#
+    When checking declaration:
+	foreign export _ccall "bar" bar :: Int -> Int#

testsuite/tests/ghc-regress/ccall/should_run/all.T

+
+include ($confdir ++ "/../vanilla-test.T")
+
+-- Args to vt are: extra compile flags
+--                 extra run flags
+--                 expected process return value, if not zero
+
+test "callback" { vt("-fglasgow-exts -package lang -fvia-C callback_stub.o", 
+                     "", "") }
+test "fed001"   { vt("-fglasgow-exts -package lang", 
+                     "", "") }
+test "ffi001"   { vt("-fglasgow-exts -package lang", 
+                     "", "") }

testsuite/tests/ghc-regress/ccall/should_run/callback.hs

+module Main (main, hputc) where
+
+import IO
+
+main = _casm_GC_ ``rts_evalIO(
+			rts_apply(
+		  	  &Main_hputc_closure,
+		  	  rts_mkChar('x')
+			  ),
+		        NULL
+	     	   );'' :: IO ()
+
+hputc :: Char -> IO ()
+hputc c = hPutChar stdout c >> hPutChar stdout '\n'
+
+foreign export hputc :: Char -> IO ()

testsuite/tests/ghc-regress/ccall/should_run/callback.stdout

+x

testsuite/tests/ghc-regress/ccall/should_run/fed001.hs

+import Foreign
+import Monad
+import Addr
+
+newtype XPtr a = XPtr Addr
+unXPtr (XPtr (A# x)) = x
+
+type CInt  = Int32
+type CSize = Word32
+
+foreign export dynamic 
+   mkComparator :: (XPtr Int -> XPtr Int -> IO CInt) 
+		-> IO (XPtr (XPtr Int -> XPtr Int -> IO CInt))
+
+foreign import 
+   qsort :: Ptr Int -> CSize -> CSize -> XPtr (XPtr Int -> XPtr Int -> IO CInt) 
+	 -> IO ()
+
+compareInts :: XPtr Int -> XPtr Int -> IO CInt
+compareInts a1 a2 = do
+   i1 <- peek (Ptr (unXPtr a1))
+   i2 <- peek (Ptr (unXPtr a2))
+   return (fromIntegral (i1 - i2 :: Int))
+
+main :: IO ()
+main = do
+   let values = [ 12, 56, 90, 34, 78 ] :: [Int]
+       n      = length values
+   buf <- mallocArray n
+   zipWithM_ (pokeElemOff buf) [ 0 .. ] values
+   c <- mkComparator compareInts
+   qsort buf (fromIntegral n) (fromIntegral (sizeOf (head values))) c
+   mapM (peekElemOff buf) [ 0 .. n-1 ] >>= (print :: [Int] -> IO ())

testsuite/tests/ghc-regress/ccall/should_run/fed001.stdout

+[12,34,56,78,90]

testsuite/tests/ghc-regress/ccall/should_run/ffi001.hs

+{-# OPTIONS -fglasgow-exts #-}
+
+-- !!! A simple FFI test
+
+-- This one provoked a bogus renamer error in 4.08.1:
+--	panic: tcLookupGlobalValue: <THIS>.PrelIOBase.returnIO{-0B,s-}
+-- (the error was actually in DsMonad.dsLookupGlobalValue!)
+
+module Main where
+
+import Foreign
+
+foreign export ccall "gccd" mygcd :: Int -> Int -> Int 
+
+main = putStrLn "No bug"
+
+mygcd a b = if (a==b) then a 
+	    else if (a<b) then mygcd a (b-a)
+	    else mygcd (a-b) a

testsuite/tests/ghc-regress/ccall/should_run/ffi001.stdout

+No bug