cvs commit: hugs98/src HsFFI.h builtin.c connect.h ffi.c static.c

[Alastair Reid]

reid        2002/06/17 14:46:48 PDT

  Modified files:
    src                  HsFFI.h builtin.c connect.h ffi.c 
                         static.c 
  Log:
  Made dynamic and wrapper forms work.
  
  This is my current test program:
  
  import Foreign
  import Exception
  import Prelude hiding (read)
  
  tests = do
  
    putStrLn "\nTesting sin==mysin (should return lots of Trues)"
    print (testSin sin mysin)
  
    putStrLn "\nTesting errno"
    err <- peek errno
    putStrLn $ "errno == " ++ show err
  
    putStrLn "\nTesting puts (and withString)"
    withString0 "Test successful" puts
  
    putStrLn "\nTesting peekArray0"
    s <- withString0 "Test successful" (peekArray0 '\0')
    putStr s
  
    putStrLn "\nTesting open, read and close"
    s <- testRead "test.hs" 200
    putStrLn s
  
    putStrLn "\nTesting open, write and close"
    testWrite "/tmp/test_write" "Test successful"
  
    putStrLn "\nTesting sin==dynamic_sin (should return lots of Trues)"
    print (testSin sin (dyn_sin sin_addr))
  
    putStrLn "\nTesting sin==IO wrapped_sin (should return lots of Trues)"
    sin_addr2 <- wrapIO (return . sin)
    print (testSin sin (unsafePerformIO . (dyn_sinIO sin_addr2)))
    freeHaskellFunPtr sin_addr2
  
    putStrLn "\nTesting sin==Id wrapped_sin (should return lots of Trues)"
    sin_addr3 <- wrapId sin
    print (testSin sin (dyn_sin sin_addr3))
    freeHaskellFunPtr sin_addr3
  
    putStrLn "\nTesting exit"
    exit 3
  
  testSin f g = [ (f x == g x) | x <- [0,0.01 .. 1] ]
  
  foreign import ccall "sin" mysin :: Double -> Double
  foreign import ccall "dynamic" dyn_sin :: FunPtr (Double -> Double) -> (Double -> Double)
  foreign import ccall "dynamic" dyn_sinIO :: FunPtr (Double -> IO Double) -> (Double -> IO Double)
  foreign import ccall "&sin" sin_addr :: FunPtr (Double -> Double)
  foreign import ccall "wrapper" wrapId :: (Double -> Double) -> IO (FunPtr (Double -> Double))
  foreign import ccall "wrapper" wrapIO :: (Double -> IO Double) -> IO (FunPtr (Double -> IO Double))
  
  foreign import ccall safe "static stdlib.h &errno" errno :: Ptr Int
  
  withString s  = bracket (newArray s)       free
  withString0 s = bracket (newArray0 '\0' s) free
  withBuffer sz m = do
    b <- mallocArray sz
    sz' <- m b
    s <- peekArray sz' b
    free b
    return s
  
  foreign import ccall puts :: Ptr Char -> IO Int
  
  foreign import ccall "open" open'  :: Ptr Char -> Int -> IO Int
  foreign import ccall "open" open2' :: Ptr Char -> Int -> Int -> IO Int
  foreign import ccall "creat" creat' :: Ptr Char -> Int -> IO Int
  foreign import ccall        close :: Int -> IO Int
  foreign import ccall "read" read' :: Int -> Ptr Char -> Int -> IO Int
  foreign import ccall "write" write' :: Int -> Ptr Char -> Int -> IO Int
  
  creat s m   = withString0 s $ \s' -> unix "creat" $ creat' s' m
  open s m    = withString0 s $ \s' -> unix "open"  $ open' s' m
  open2 s m n = withString0 s $ \s' -> unix "open2" $ open2' s' m n
  write fd s  = withString0 s $ \s' -> unix "write" $ write' fd s' (length s)
  read  fd sz = withBuffer sz $ \s' -> unix "read"  $ read' fd s' sz
  
  unix s m = do
    x <- m
    if x < 0
     then do
       err <- peek errno
       ioError $ userError $ s ++ ": " ++ show (x,err)
     else return x
  
  testRead fn sz = bracket (open fn 0) close (flip read sz)
  testWrite fn s = bracket (open2 fn (512+64+1) 511) close (flip write s)
  
  foreign import ccall exit :: Int -> IO ()
  
  -- Various bits of rubbish.
  -- foreign import ccall "static stdlib.h exit" (***) :: Ptr Char -> Ptr Char -> IO Int
  --
  -- foreign import ccall safe "static stdlib.h printf" (+++) :: Ptr Char -> Ptr Char -> IO Int
  -- foreign import ccall safe "static stdlib.h &errno" illegal_foo :: Ptr Int
  --
  -- foreign import ccall safe "wrapper" illegal_bar :: Char -> IO (FunPtr Char)
  -- foreign import ccall safe "dynamic" illegal_baz :: FunPtr Char -> Char
  
  -- foreign export ccall "id_charstar" id :: Ptr Char -> Ptr Char
  
  Revision  Changes    Path
  1.4       +8 -3      hugs98/src/HsFFI.h
  1.26      +30 -5     hugs98/src/builtin.c
  1.38      +3 -3      hugs98/src/connect.h
  1.10      +36 -11    hugs98/src/ffi.c
  1.72      +20 -4     hugs98/src/static.c