[hoc-cvs] hoc/HOC/HOC ID.hs,1.8,1.9 MsgSend.hs,1.6,1.7 NewlyAllocated.hs,1.3,1.4 Super.hs,1.1,1.2

[Wolfgang T. <wth...@us...>]

Update of /cvsroot/hoc/hoc/HOC/HOC
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14092/HOC/HOC

Modified Files:
	ID.hs MsgSend.hs NewlyAllocated.hs Super.hs 
Log Message:
Make struct return values work.


Index: MsgSend.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/MsgSend.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- MsgSend.hs	25 Jul 2005 03:59:25 -0000	1.6
+++ MsgSend.hs	27 Jul 2005 02:36:09 -0000	1.7
@@ -1,10 +1,8 @@
 {-# OPTIONS -cpp #-}
 module HOC.MsgSend(
         objSendMessageWithRetval,
-        objSendMessageWithStructRetval,
         objSendMessageWithoutRetval,
         superSendMessageWithRetval,
-        superSendMessageWithStructRetval,
         superSendMessageWithoutRetval
     ) where
 
@@ -14,6 +12,7 @@
 import HOC.Invocation
 
 import Foreign
+import Control.Monad.Fix(mfix)
 
 objSendMessageWithRetval
 	:: ObjCArgument a b
@@ -21,12 +20,6 @@
     -> Ptr (Ptr ())
     -> IO a
 
-objSendMessageWithStructRetval
-	:: ObjCArgument a b
-    => FFICif
-    -> Ptr (Ptr ())
-    -> IO a
-
 objSendMessageWithoutRetval
 	:: FFICif
     -> Ptr (Ptr ())
@@ -38,12 +31,6 @@
     -> Ptr (Ptr ())
     -> IO a
 
-superSendMessageWithStructRetval
-	:: ObjCArgument a b
-    => FFICif
-    -> Ptr (Ptr ())
-    -> IO a
-
 superSendMessageWithoutRetval
 	:: FFICif
     -> Ptr (Ptr ())
@@ -61,9 +48,6 @@
     imp <- objc_msg_lookup target selector
     callWithRetval cif imp args
 
-objSendMessageWithStructRetval cif args =
-    objSendMessageWithRetval cif args
-
 objSendMessageWithoutRetval cif args = do
     target <- peekElemOff args 0 >>= peek . castPtr
     selector <- peekElemOff args 1 >>= peek . castPtr
@@ -74,31 +58,37 @@
 
 #else
 
+	-- the type signatures are essentially bogus
+	-- the return value is not necessarily (), and might even be a struct.
+	-- we only call them via libffi, so we couldn't care less.
 foreign import ccall "MsgSend.h &objc_msgSend"
     objc_msgSendPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ())
 foreign import ccall "MsgSend.h &objc_msgSend_stret"
-    objc_msgSend_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ())
+    objc_msgSend_stretPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ())
 
 foreign import ccall "MsgSend.h &objc_msgSendSuper"
     objc_msgSendSuperPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ())
 foreign import ccall "MsgSend.h &objc_msgSendSuper_stret"
-    objc_msgSendSuper_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ())
+    objc_msgSendSuper_stretPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ())
 
-objSendMessageWithRetval cif args =
-    callWithRetval cif objc_msgSendPtr args
+withMarshalledDummy :: ObjCArgument a b => (b -> IO a) -> IO a
+withMarshalledDummy action = action undefined
 
-objSendMessageWithStructRetval cif args =
-    callWithRetval cif objc_msgSend_stretPtr args
+objSendMessageWithRetval cif args =
+	withMarshalledDummy $ \dummy ->
+	callWithRetval cif (if isStructType dummy
+							then objc_msgSend_stretPtr
+							else objc_msgSendPtr) args    	 
 
 objSendMessageWithoutRetval cif args =
     callWithoutRetval cif objc_msgSendPtr args
 
 
 superSendMessageWithRetval cif args =
-    callWithRetval cif objc_msgSendSuperPtr args
-
-superSendMessageWithStructRetval cif args =
-    callWithRetval cif objc_msgSendSuper_stretPtr args
+	withMarshalledDummy $ \dummy ->
+	callWithRetval cif (if isStructType dummy
+							then objc_msgSendSuper_stretPtr
+							else objc_msgSendSuperPtr) args    	 
 
 superSendMessageWithoutRetval cif args =
     callWithoutRetval cif objc_msgSendSuperPtr args

Index: NewlyAllocated.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/NewlyAllocated.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- NewlyAllocated.hs	25 Jul 2005 03:59:25 -0000	1.3
+++ NewlyAllocated.hs	27 Jul 2005 02:36:09 -0000	1.4
@@ -37,5 +37,4 @@
     isNil (NewlyAllocated p) = p == nullPtr
 
     sendMessageWithRetval _ = objSendMessageWithRetval
-    sendMessageWithStructRetval _ = objSendMessageWithStructRetval
     sendMessageWithoutRetval _ = objSendMessageWithoutRetval

Index: Super.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/Super.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Super.hs	25 Jul 2005 03:59:25 -0000	1.1
+++ Super.hs	27 Jul 2005 02:36:09 -0000	1.2
@@ -51,5 +51,4 @@
     isNil (SuperTarget x) = isNil x
     
     sendMessageWithRetval _ = superSendMessageWithRetval
-    sendMessageWithStructRetval _ = superSendMessageWithStructRetval
     sendMessageWithoutRetval _ = superSendMessageWithoutRetval

Index: ID.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/ID.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- ID.hs	25 Jul 2005 03:59:25 -0000	1.8
+++ ID.hs	27 Jul 2005 02:36:09 -0000	1.9
@@ -39,12 +39,6 @@
                           -> Ptr (Ptr ())
                           -> IO ret
 
-    sendMessageWithStructRetval :: ObjCArgument ret b
-                                => a
-                                -> FFICif
-                                -> Ptr (Ptr ())
-                                -> IO ret
-
     sendMessageWithoutRetval :: a
                              -> FFICif
                              -> Ptr (Ptr ())
@@ -58,7 +52,6 @@
     isNil x = x == nil
     
     sendMessageWithRetval _ = objSendMessageWithRetval
-    sendMessageWithStructRetval _ = objSendMessageWithStructRetval
     sendMessageWithoutRetval _ = objSendMessageWithoutRetval
 
 instance Object (ID a) where