From: Ian Lynagh <igloo@earth.li>
Date: Wed, 20 May 2009 17:53:58 +0000 (+0000)
Subject: Add wrappers around fcntl
X-Git-Tag: 2009-06-25~35
X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=commitdiff_plain;h=a4d271497da4479239a3fbbeb860e819b5fb0a29

Add wrappers around fcntl
We need to do this as it has a (, ...) type, which we aren't allowed to
directly call with the FFI.
---

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 5bbdf9c..fbac648 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -424,13 +424,13 @@ foreign import ccall unsafe "HsBase.h getpid"
    c_getpid :: IO CPid
 
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_read"
    c_fcntl_read  :: CInt -> CInt -> IO CInt
 
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_write"
    c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt
 
-foreign import ccall unsafe "HsBase.h fcntl"
+foreign import ccall unsafe "HsBase.h fcntl_lock"
    c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt
 
 foreign import ccall unsafe "HsBase.h fork"
diff --git a/include/HsBase.h b/include/HsBase.h
index 9bbbdc8..b749c58 100644
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -765,5 +765,19 @@ INLINE intptr_t  __hscore_to_intptr   (void *p)     { return (intptr_t)p; }
 void errorBelch2(const char*s, char *t);
 void debugBelch2(const char*s, char *t);
 
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
+
+INLINE int fcntl_read(int fd, int cmd) {
+    fcntl(fd, cmd);
+}
+INLINE int fcntl_write(int fd, int cmd, long arg) {
+    fcntl(fd, cmd, arg);
+}
+INLINE int fcntl_lock(int fd, int cmd, struct flock *lock) {
+    fcntl(fd, cmd, lock);
+}
+
+#endif
+
 #endif /* __HSBASE_H__ */