Commit 7d4ce16a authored by sewardj's avatar sewardj

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

Add ccall tests.
parent 312ff677
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") }
-- !!! 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
-- !!! cc002 -- ccall with ambiguous result (should be defaulted to ())
module ShouldCompile where
a :: IO ()
a = do
_ccall_ a
return ()
-- !!! 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)
-- !!! 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 ())
-- !!! 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
-}
-- !!! 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
-- !!! cc007 -- foreign import with external name equal to Haskell name.
module ShouldCompile where
foreign import sine :: Double -> Double
-- !!! 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)
-- !!! cc009 -- foreign label returning newtype of Addr
module ShouldCompile where
import Addr
newtype Ptr a = Ptr Addr
foreign label foo :: Ptr Int
module ShouldCompile where
import Foreign
foreign import dynamic imp :: Addr -> Int
f1 a = imp a + 1
f2 a = imp a + 2
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("") }
-- !!! cc001 -- ccall with ambiguous argument
module Test where
f :: IO ()
f = _ccall_ foo (undefined ())
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 ())
-- !!! 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
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
-- !!! 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
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)'
-- !!! 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#
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#
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",
"", "") }
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 ()
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 ())
{-# 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment