[hoc-cvs] [hoc commit] r340 - trunk/hoc/HOC/HOC

[<cod...@go...>]

Author: wol...@gm...
Date: Sun Oct 19 13:57:37 2008
New Revision: 340

Modified:
    trunk/hoc/HOC/HOC/FFICallInterface.hs
    trunk/hoc/HOC/HOC/Invocation.hs

Log:
libffi returns small integral return values promoted to long.
Deal with it.


Modified: trunk/hoc/HOC/HOC/FFICallInterface.hs
==============================================================================
--- trunk/hoc/HOC/HOC/FFICallInterface.hs	(original)
+++ trunk/hoc/HOC/HOC/FFICallInterface.hs	Sun Oct 19 13:57:37 2008
@@ -1,4 +1,11 @@
-module HOC.FFICallInterface where
+module HOC.FFICallInterface(
+		FFICif,
+		FFIType,
+		FFITypeable(..),
+		ffiPrepCif,
+		makeStructType,
+		cifIsStret
+	) where

  import Foreign.C.Types
  import Foreign
@@ -15,6 +22,17 @@
      isStructType :: a -> Bool

      isStructType _ = False
+
+    -- Integral return values of size < sizeof(long) require special  
treatment
+    -- in libffi; they are returned as long. For these types, the following
+    -- gives us a chance to replace alloca & peek with a version that  
undoes
+    -- the promotion.
+
+    peekRetval :: Storable a => Ptr a -> IO a
+    allocaRetval :: Storable a => (Ptr a -> IO b) -> IO b
+
+    peekRetval = peek
+    allocaRetval = alloca

  foreign import ccall "ffi.h &ffi_type_void"       ffi_type_void :: FFIType
  foreign import ccall "ffi.h &ffi_type_uint8"      ffi_type_uint8:: FFIType
@@ -54,6 +72,15 @@

  foreign import ccall unsafe cifIsStret :: FFICif -> IO CInt

+promotedPeek p
+	= peek (castPtr p :: Ptr CLong) >>= return . fromIntegral
+	where
+		size = sizeOf (pointee p)
+		pointee :: Ptr p -> p
+		pointee = undefined
+
+promotedAlloca f = alloca (\intPtr -> f $ castPtr (intPtr :: Ptr CLong))
+
  -- typeable instances

  instance FFITypeable () where
@@ -64,19 +91,43 @@

  instance FFITypeable Int8 where
      makeFFIType _ = return ffi_type_sint8
+
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
+
  instance FFITypeable Int16 where
      makeFFIType _ = return ffi_type_sint16
+
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
+
  instance FFITypeable Int32 where
      makeFFIType _ = return ffi_type_sint32
+
+    peekRetval = promotedPeek		-- only takes effect on 64-bit
+    allocaRetval = promotedAlloca
+
  instance FFITypeable Int64 where
      makeFFIType _ = return ffi_type_sint64

  instance FFITypeable Word8 where
      makeFFIType _ = return ffi_type_uint8
+
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
+
  instance FFITypeable Word16 where
      makeFFIType _ = return ffi_type_uint16
+
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
+
  instance FFITypeable Word32 where
      makeFFIType _ = return ffi_type_uint32
+
+    peekRetval = promotedPeek		-- only takes effect on 64-bit
+    allocaRetval = promotedAlloca
+
  instance FFITypeable Word64 where
      makeFFIType _ = return ffi_type_uint64

@@ -101,20 +152,34 @@

  instance FFITypeable CChar where
      makeFFIType _ = return ffi_type_sint8
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
  instance FFITypeable CUChar where
      makeFFIType _ = return ffi_type_uint8
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
  instance FFITypeable CSChar where
      makeFFIType _ = return ffi_type_sint8
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca

  instance FFITypeable CShort where
      makeFFIType _ = return ffi_type_sint16
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
  instance FFITypeable CUShort where
      makeFFIType _ = return ffi_type_uint16
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca

  instance FFITypeable CInt where
      makeFFIType _ = return ffi_type_sint32
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca
  instance FFITypeable CUInt where
      makeFFIType _ = return ffi_type_uint32
+    peekRetval = promotedPeek
+    allocaRetval = promotedAlloca

  instance FFITypeable CLong where
      makeFFIType _ = return ffi_type_sint32

Modified: trunk/hoc/HOC/HOC/Invocation.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Invocation.hs	(original)
+++ trunk/hoc/HOC/HOC/Invocation.hs	Sun Oct 19 13:57:37 2008
@@ -38,9 +38,9 @@
                 -> IO b

  callWithRetval cif fun args = do
-    alloca $ \retptr ->
+    allocaRetval $ \retptr ->
          callWithException cif fun retptr args
-        >> peek retptr >>= importArgument
+        >> peekRetval retptr >>= importArgument


  setMarshalledRetval :: ObjCArgument a b => Bool -> Ptr () -> a -> IO ()