[hoc-cvs] hoc/HOC/HOC Super.hs,NONE,1.1 DeclareClass.hs,1.3,1.4 DeclareSelector.hs,1.7,1.8 ID.hs,1.7,1.8 MsgSend.hs,1.5,1.6 NewlyAllocated.hs,1.2,1.3 SelectorMarshaller.hs,1.7,1.8

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

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

Modified Files:
	DeclareClass.hs DeclareSelector.hs ID.hs MsgSend.hs 
	NewlyAllocated.hs SelectorMarshaller.hs 
Added Files:
	Super.hs 
Log Message:
Implement sending messages to super.
Objective-C: [super foo];
Haskell:     super self # foo


Index: SelectorMarshaller.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- SelectorMarshaller.hs	6 Dec 2004 03:46:51 -0000	1.7
+++ SelectorMarshaller.hs	25 Jul 2005 03:59:25 -0000	1.8
@@ -64,11 +64,14 @@
         collectArgs e = [| withArray $(listE (map varE marshalledArguments))
                                      $(lamE [varP $ mkName "args"] e) |]
 
-        invoke | isUnit = [| sendMessageWithoutRetval (selectorInfoCif $(infoVar))
+        invoke | isUnit = [| sendMessageWithoutRetval $(targetVar)
+        										      (selectorInfoCif $(infoVar))
                                                       $(argsVar)|]
-               | otherwise = [| sendMessageWithRetval (selectorInfoCif $(infoVar))
+               | otherwise = [| sendMessageWithRetval $(targetVar)
+               										  (selectorInfoCif $(infoVar))
                                                       $(argsVar)|]
             where argsVar = varE $ mkName "args"
+            	  targetVar = varE $ mkName "target"
 
         purify e | isPure = [| unsafePerformIO $(e) |]
                  | otherwise = e

Index: DeclareClass.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareClass.hs,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- DeclareClass.hs	23 Jul 2005 06:26:17 -0000	1.3
+++ DeclareClass.hs	25 Jul 2005 03:59:25 -0000	1.4
@@ -3,6 +3,7 @@
 import HOC.Base
 import HOC.Arguments
 import HOC.Class
+import HOC.Super
 
 import HOC.TH
 
@@ -34,7 +35,10 @@
             (normalB [| unsafeGetClassObject $(stringE name) |]) [],         
 
         -- $(superName) = "super"
-        valD (return $ VarP (mkName superName)) (normalB $ stringE super) []
+        valD (return $ VarP (mkName superName)) (normalB $ stringE super) [],
+        
+        -- instance SuperClass (name ()) (super ())
+        instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT` superType) []
     ]
     where
         phantomName = name ++ "_"
@@ -44,3 +48,6 @@
                            | otherwise = super ++ "Class"
         classObjectName = "_" ++ name
         superName = "super_" ++ name
+
+        clsType   = conT (mkName name)  `appT` [t| () |]
+        superType = conT (mkName super) `appT` [t| () |]

Index: MsgSend.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/MsgSend.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- MsgSend.hs	13 May 2004 11:08:34 -0000	1.5
+++ MsgSend.hs	25 Jul 2005 03:59:25 -0000	1.6
@@ -1,8 +1,11 @@
-{-# OPTIONS -cpp -fvia-C #-}
+{-# OPTIONS -cpp #-}
 module HOC.MsgSend(
-        sendMessageWithRetval,
-        sendMessageWithStructRetval,
-        sendMessageWithoutRetval
+        objSendMessageWithRetval,
+        objSendMessageWithStructRetval,
+        objSendMessageWithoutRetval,
+        superSendMessageWithRetval,
+        superSendMessageWithStructRetval,
+        superSendMessageWithoutRetval
     ) where
 
 import HOC.Base
@@ -12,17 +15,39 @@
 
 import Foreign
 
-sendMessageWithRetval :: ObjCArgument a b
-                      => FFICif
-                      -> Ptr (Ptr ())
-                      -> IO a
-sendMessageWithStructRetval :: ObjCArgument a b
-                            => FFICif
-                            -> Ptr (Ptr ())
-                            -> IO a
-sendMessageWithoutRetval :: FFICif
-                         -> Ptr (Ptr ())
-                         -> IO ()
+objSendMessageWithRetval
+	:: ObjCArgument a b
+    => FFICif
+    -> Ptr (Ptr ())
+    -> IO a
+
+objSendMessageWithStructRetval
+	:: ObjCArgument a b
+    => FFICif
+    -> Ptr (Ptr ())
+    -> IO a
+
+objSendMessageWithoutRetval
+	:: FFICif
+    -> Ptr (Ptr ())
+    -> IO ()
+
+superSendMessageWithRetval
+	:: ObjCArgument a b
+    => FFICif
+    -> Ptr (Ptr ())
+    -> IO a
+
+superSendMessageWithStructRetval
+	:: ObjCArgument a b
+    => FFICif
+    -> Ptr (Ptr ())
+    -> IO a
+
+superSendMessageWithoutRetval
+	:: FFICif
+    -> Ptr (Ptr ())
+    -> IO ()
 
 #ifdef GNUSTEP
 
@@ -30,21 +55,23 @@
     objc_msg_lookup :: Ptr ObjCObject -> SEL -> IO (FunPtr ())
     
     
-sendMessageWithRetval cif args = do
+objSendMessageWithRetval cif args = do
     target <- peekElemOff args 0 >>= peek . castPtr
     selector <- peekElemOff args 1 >>= peek . castPtr
     imp <- objc_msg_lookup target selector
     callWithRetval cif imp args
 
-sendMessageWithStructRetval cif args =
-    sendMessageWithRetval cif args
+objSendMessageWithStructRetval cif args =
+    objSendMessageWithRetval cif args
 
-sendMessageWithoutRetval cif args = do
+objSendMessageWithoutRetval cif args = do
     target <- peekElemOff args 0 >>= peek . castPtr
     selector <- peekElemOff args 1 >>= peek . castPtr
     imp <- objc_msg_lookup target selector
     callWithoutRetval cif imp args
 
+#error GNUSTEP unimplemented: send message to super
+
 #else
 
 foreign import ccall "MsgSend.h &objc_msgSend"
@@ -52,13 +79,28 @@
 foreign import ccall "MsgSend.h &objc_msgSend_stret"
     objc_msgSend_stretPtr :: FunPtr (Ptr a -> Ptr ObjCObject -> SEL -> IO ())
 
-sendMessageWithRetval cif args =
+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 ())
+
+objSendMessageWithRetval cif args =
     callWithRetval cif objc_msgSendPtr args
 
-sendMessageWithStructRetval cif args =
+objSendMessageWithStructRetval cif args =
     callWithRetval cif objc_msgSend_stretPtr args
 
-sendMessageWithoutRetval cif 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
+
+superSendMessageWithoutRetval cif args =
+    callWithoutRetval cif objc_msgSendSuperPtr args
+
 #endif

Index: ID.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/ID.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- ID.hs	6 Apr 2004 12:31:18 -0000	1.7
+++ ID.hs	25 Jul 2005 03:59:25 -0000	1.8
@@ -3,6 +3,7 @@
 import HOC.Base
 import HOC.Arguments
 import HOC.FFICallInterface(FFICif)
+import HOC.MsgSend
 
 import Control.Concurrent.MVar
 import Control.Exception(evaluate,assert)
@@ -32,13 +33,34 @@
 class ObjCArgument a (Ptr ObjCObject) => MessageTarget a where
     isNil :: a -> Bool
     
+    sendMessageWithRetval :: ObjCArgument ret b
+                          => a
+                          -> FFICif
+                          -> Ptr (Ptr ())
+                          -> IO ret
+
+    sendMessageWithStructRetval :: ObjCArgument ret b
+                                => a
+                                -> FFICif
+                                -> Ptr (Ptr ())
+                                -> IO ret
+
+    sendMessageWithoutRetval :: a
+                             -> FFICif
+                             -> Ptr (Ptr ())
+                             -> IO ()
+
 class MessageTarget a => Object a where
     toID :: a -> ID ()
     fromID :: ID () -> a
 
 instance MessageTarget (ID a) where
     isNil x = x == nil
-        
+    
+    sendMessageWithRetval _ = objSendMessageWithRetval
+    sendMessageWithStructRetval _ = objSendMessageWithStructRetval
+    sendMessageWithoutRetval _ = objSendMessageWithoutRetval
+
 instance Object (ID a) where
     toID (ID a) = ID a
     toID Nil = Nil
@@ -267,11 +289,9 @@
 
 getHaskellDataForID (ID (HSO _ dat)) = dat
 
-releaseExtraReference obj = do
-    case toID obj of
-        ID (HSO ptr _) -> releaseObject ptr
-        Nil -> return ()
-    return obj
+releaseExtraReference obj
+    = withExportedArgument obj (\ptr -> when (ptr /= nullPtr) (releaseObject ptr))
+      >> return obj
 
 objectMapStatistics =
     alloca $ \pAllocated ->

Index: DeclareSelector.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- DeclareSelector.hs	23 Jul 2005 06:26:17 -0000	1.7
+++ DeclareSelector.hs	25 Jul 2005 03:59:25 -0000	1.8
@@ -11,6 +11,7 @@
 import HOC.StdArgumentTypes
 import HOC.ID
 import HOC.NewlyAllocated(NewlyAllocated)
+import HOC.Super
 
 import Data.Char(isUpper, toLower, toUpper)
 import Data.Maybe(fromMaybe)
@@ -155,9 +156,14 @@
                     (return $ makeImpType typeSig),
                 
                 -- class Object a => $(className) a
-                classD (cxt [conT (mkName "Object") `appT` varT (mkName "a")])
+                classD (cxt [conT ''MessageTarget `appT` varT (mkName "a")])
                     (mkName className) [mkName "a"] [] [],
                 
+                -- instance $(className) a => $(className) (SuperTarget a)
+                instanceD (cxt [conT (mkName className) `appT` varT (mkName "a")])
+                    (conT (mkName className) `appT` (conT ''SuperTarget `appT` varT (mkName "a")))
+                    [],
+                
                 sigD (mkName haskellName) $ return doctoredTypeSig,
                 
                 if nArgs > marshallersUpTo || resultRetained

Index: NewlyAllocated.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/NewlyAllocated.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- NewlyAllocated.hs	6 Apr 2004 12:31:18 -0000	1.2
+++ NewlyAllocated.hs	25 Jul 2005 03:59:25 -0000	1.3
@@ -14,6 +14,7 @@
 import HOC.Base         ( ObjCObject )
 import HOC.Arguments    ( ObjCArgument(..) )
 import HOC.ID           ( Object(..), MessageTarget(..) )
+import HOC.MsgSend
 
 import Foreign.Ptr      ( Ptr, nullPtr )
 import System.IO.Unsafe ( unsafePerformIO )
@@ -34,3 +35,7 @@
     
 instance MessageTarget (NewlyAllocated a) where
     isNil (NewlyAllocated p) = p == nullPtr
+
+    sendMessageWithRetval _ = objSendMessageWithRetval
+    sendMessageWithStructRetval _ = objSendMessageWithStructRetval
+    sendMessageWithoutRetval _ = objSendMessageWithoutRetval

--- NEW FILE: Super.hs ---
module HOC.Super(
        SuperClass, SuperTarget, super
    ) where

import HOC.Base
import HOC.Arguments
import HOC.ID
import HOC.MsgSend

import Foreign

{-
    Messages to super.
        [super foo]
    is written as
        super self # foo
-}

class SuperClass sub super | sub -> super

data SuperTarget a = SuperTarget a

super :: (Object sub, Object super, SuperClass sub super)
      => sub -> SuperTarget super

--- 

pokeSuper objcSuper obj cls
    = pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls

instance MessageTarget a
        => ObjCArgument (SuperTarget a) (Ptr ObjCObject) where

    withExportedArgument (SuperTarget obj) action =
        withExportedArgument obj $ \p ->
        getSuperClassForObject p >>= \cls ->
        allocaBytes (sizeOf p + sizeOf cls) $ \sptr ->
        pokeSuper sptr p cls >> action sptr
        
    exportArgument _ = fail "HOC.Super: exportArgument"
    importArgument _ = fail "HOC.Super: importArgument"

    objCTypeString _ = "@"      -- well, close enough.

super obj = SuperTarget (fromID $ toID obj)

getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr ()))
                                peekElemOff cls 1

instance MessageTarget a => MessageTarget (SuperTarget a) where
    isNil (SuperTarget x) = isNil x
    
    sendMessageWithRetval _ = superSendMessageWithRetval
    sendMessageWithStructRetval _ = superSendMessageWithStructRetval
    sendMessageWithoutRetval _ = superSendMessageWithoutRetval