[hoc-cvs] [hoc commit] r377 - in trunk/hoc: . HOC HOC/HOC HOC_cbits InterfaceGenerator2 Tests

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

Author: wol...@gm...
Date: Sun Dec 21 13:42:00 2008
New Revision: 377

Added:
    trunk/hoc/HOC_cbits/Ivars.h   (contents, props changed)
    trunk/hoc/HOC_cbits/Ivars.m
    trunk/hoc/HOC_cbits/Methods.h   (contents, props changed)
    trunk/hoc/HOC_cbits/Methods.m
Modified:
    trunk/hoc/HOC.cabal
    trunk/hoc/HOC/HOC.hs
    trunk/hoc/HOC/HOC/Base.hs
    trunk/hoc/HOC/HOC/Class.hs
    trunk/hoc/HOC/HOC/DeclareClass.hs
    trunk/hoc/HOC/HOC/ExportClass.hs
    trunk/hoc/HOC/HOC/NewClass.hs
    trunk/hoc/HOC_cbits/Class.h
    trunk/hoc/HOC_cbits/Class.m
    trunk/hoc/HOC_cbits/Exceptions.m
    trunk/hoc/HOC_cbits/GetNewHaskellData.m
    trunk/hoc/HOC_cbits/NewClass.h
    trunk/hoc/HOC_cbits/NewClass.m
    trunk/hoc/InterfaceGenerator2/Output.hs
    trunk/hoc/Setup.hs
    trunk/hoc/Tests/TestFoundation.hs

Log:
Merge Objective-C 2.0 branch

Big thanks to James Cook for doing all the work.


Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal	(original)
+++ trunk/hoc/HOC.cabal	Sun Dec 21 13:42:00 2008
@@ -14,6 +14,9 @@
      description: build test cases
      default: False

+Flag ObjC2
+    description: build for Objective-C 2.0
+
  Library
      build-depends: base, template-haskell, unix

@@ -54,13 +57,18 @@
      hs-source-dirs: HOC

      extra-libraries: objc, ffi
+    c-sources: HOC_cbits.o
      if os(darwin)
+        include-dirs: /usr/include/ffi
          frameworks: Foundation
          cpp-options: -DMACOSX
      else
          -- paths are inserted by Setup.hs
          extra-libraries: gnustep-base
          cpp-options: -DGNUSTEP
+
+    if flag(ObjC2)
+        cpp-options: -D__OBJC2__=1


  Executable hoc-ifgen

Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs	(original)
+++ trunk/hoc/HOC/HOC.hs	Sun Dec 21 13:42:00 2008
@@ -4,6 +4,7 @@
          nil,
          Object(..),
          Class,
+        MetaClass,
          ClassAndObject,
          ClassObject,
          classObject,

Modified: trunk/hoc/HOC/HOC/Base.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Base.hs	(original)
+++ trunk/hoc/HOC/HOC/Base.hs	Sun Dec 21 13:42:00 2008
@@ -20,6 +20,10 @@

  --

+foreign import ccall "stdlib.h &free"
+    freePtr :: FunPtr (Ptr a -> IO ())
+
+--

  foreign import ccall "MemoryManagement.h retainObject"
      retainObject :: Ptr ObjCObject -> IO ()

Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs	(original)
+++ trunk/hoc/HOC/HOC/Class.hs	Sun Dec 21 13:42:00 2008
@@ -11,15 +11,13 @@
  import Foreign
  import Foreign.C.String

-
  data Class_ a
  type Class a = ID (Class_ a)
-
+type MetaClass a = Class (Class_ a)


  unsafeGetClassObject :: String -> Class a

-
  foreign import ccall unsafe "Class.h getClassByName"
      c_getClassByName :: CString -> IO (Ptr ObjCObject)

@@ -30,6 +28,16 @@
      getClassByName name >>= importImmortal


+unsafeGetMetaclassForClass :: Class a -> MetaClass a
+
+foreign import ccall unsafe "Class.h getClassForObject"
+    c_getClassForObject :: Ptr ObjCObject -> IO (Ptr ObjCObject)
+
+getClassForObject obj = withExportedArgument obj c_getClassForObject
+
+{-# NOINLINE unsafeGetMetaclassForClass #-}
+unsafeGetMetaclassForClass obj = unsafePerformIO $
+    getClassForObject obj >>= importImmortal


  class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a

Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs	(original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs	Sun Dec 21 13:42:00 2008
@@ -31,6 +31,12 @@
                  `appT` (conT (mkName phantomName)
                          `appT` varT (mkName "a"))),

+        -- type $(metaMetaClassName) a = $(superMetaMetaClassName)  
($(phantomName) a)
+        tySynD (mkName metaMetaClassName) [mkName "a"]
+            (conT (mkName superMetaMetaClassName)
+                `appT` (conT (mkName phantomName)
+                        `appT` varT (mkName "a"))),
+
          -- $(classObjectName) :: $(metaClassName) ()
          sigD (mkName classObjectName) (conT (mkName metaClassName)
                                              `appT` [t| () |]),
@@ -39,6 +45,11 @@
          valD (return $ VarP (mkName classObjectName))
              (normalB [| unsafeGetClassObject $(stringE name) |]) [],

+        -- $(metaClassObjectName) = unsafeGetMetaclassForClass  
$(classObjectName)
+        valD (return $ VarP (mkName metaClassObjectName))
+            (normalB [| unsafeGetMetaclassForClass $(varE (mkName  
classObjectName)) |]) [],
+
+        -- $(superName) :: String
          sigD (mkName superName) [t| String |],

          -- $(superName) = "super"
@@ -47,20 +58,35 @@
          -- instance SuperClass (name ()) (super ())
          instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`  
superType) [],

+        -- instance SuperClass (clsName ()) (superClsName ())
+        instanceD (cxt []) (conT ''SuperClass `appT` metaClsType `appT`  
superMetaType) [],
+
          -- instance ClassObject (metaClsName ())
          --  where classObject = classObject
          instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
-            [funD 'classObject [clause [] (normalB $ varE (mkName  
classObjectName)) []]]
+            [funD 'classObject [clause [] (normalB $ varE (mkName  
classObjectName)) []]],
+
+        -- instance ClassObject metaMetaCls
+        --  where classObject = unsafeGetMetaclassForClass classObject
+        --  {- metaclass object, to support super calls in class methods -}
+        instanceD (cxt []) (conT ''ClassObject `appT` metaMetaClsType)
+            [funD 'classObject [clause [] (normalB $ varE (mkName  
metaClassObjectName)) []]]
      ]
      where
          phantomName = name ++ "_"
          metaClassName = name ++ "Class"
+        metaMetaClassName = name ++ "MetaClass"
          metaPhantomName = metaClassName ++ "_"
          superMetaClassName | super == "ID" = "Class"
                             | otherwise = super ++ "Class"
+        superMetaMetaClassName | super == "ID" = "MetaClass"
+                               | otherwise = super ++ "MetaClass"
          classObjectName = "_" ++ name
+        metaClassObjectName = "_" ++ metaClassName
          superName = "super_" ++ name

+        metaMetaClsType = conT (mkName metaMetaClassName) `appT` [t| () |]
          metaClsType = conT (mkName metaClassName) `appT` [t| () |]
          clsType   = conT (mkName name)  `appT` [t| () |]
          superType = conT (mkName super) `appT` [t| () |]
+        superMetaType = conT (mkName superMetaClassName) `appT` [t| () |]

Modified: trunk/hoc/HOC/HOC/ExportClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/ExportClass.hs	(original)
+++ trunk/hoc/HOC/HOC/ExportClass.hs	Sun Dec 21 13:42:00 2008
@@ -138,7 +138,7 @@
                  $(fillMethodList False 3 [|imethods|] instanceMethods)
                  $(fillMethodList True 0 [|cmethods|] classMethods)
                  clsname <- newCString name
-                newClass super clsname defaultIvarSize ivars imethods  
cmethods
+                newClass super clsname ivars imethods cmethods
          |]
      where
          typedInitIvars = [|initializeInstanceVariables|]

Modified: trunk/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewClass.hs	(original)
+++ trunk/hoc/HOC/HOC/NewClass.hs	Sun Dec 21 13:42:00 2008
@@ -9,7 +9,6 @@
          setIvarInList,
          setMethodInList,
          makeDefaultIvarList,
-        defaultIvarSize,
          setHaskellRetainMethod,
          setHaskellReleaseMethod,
          setHaskellDataMethod
@@ -22,49 +21,79 @@
  import HOC.Class

  import Foreign.C.String
+import Foreign.C.Types
  import Foreign

  type IMP = FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr ObjCObject)
  foreign import ccall "wrapper" wrapIMP :: IMP -> IO (FunPtr IMP)

-newtype MethodList = MethodList (Ptr MethodList)
-newtype IvarList = IvarList (Ptr IvarList)
+newtype MethodList = MethodList (ForeignPtr MethodList)
+newtype IvarList = IvarList (ForeignPtr IvarList)

  foreign import ccall "NewClass.h newClass"
-    newClass :: Ptr ObjCObject -> CString
-             -> Int -> IvarList
+    rawNewClass :: Ptr ObjCObject -> CString
+             -> Ptr IvarList
+             -> Ptr MethodList -> Ptr MethodList
+             -> IO ()
+
+newClass :: Ptr ObjCObject -> CString
+             -> IvarList
               -> MethodList -> MethodList
               -> IO ()
+newClass sc name (IvarList ivars) (MethodList ms) (MethodList cms) =
+    withForeignPtr ivars $ \ivars ->
+        withForeignPtr ms $ \ms ->
+            withForeignPtr cms $ \cms -> do
+                rawNewClass sc name ivars ms cms

  foreign import ccall "NewClass.h makeMethodList"
-    makeMethodList :: Int -> IO MethodList
+    rawMakeMethodList :: Int -> IO (Ptr MethodList)
  foreign import ccall "NewClass.h setMethodInList"
-    rawSetMethodInList :: MethodList -> Int
+    rawSetMethodInList :: Ptr MethodList -> Int
                      -> SEL -> CString
                      -> FFICif -> FunPtr IMP
                      -> IO ()


  foreign import ccall "NewClass.h makeIvarList"
-    makeIvarList :: Int -> IO IvarList
+    rawMakeIvarList :: Int -> IO (Ptr IvarList)
  foreign import ccall "NewClass.h setIvarInList"
-    setIvarInList :: IvarList -> Int
-                  -> CString -> CString -> Int -> IO ()
+    rawSetIvarInList :: Ptr IvarList -> Int
+                  -> CString -> CString -> CSize -> Word8 -> IO ()

-setMethodInList methodList idx sel typ cif imp = do
-    typC <- newCString typ
-    thunk <- wrapIMP imp
-    rawSetMethodInList methodList idx sel typC cif thunk
+makeIvarList :: Int -> IO IvarList
+makeIvarList n = do
+    ivars <- rawMakeIvarList n
+    ivars <- newForeignPtr freePtr ivars
+    return (IvarList ivars)
+
+setIvarInList:: IvarList -> Int
+                  -> CString -> CString -> CSize -> Word8 -> IO ()
+setIvarInList (IvarList ivars) n name ty sz align =
+    withForeignPtr ivars $ \ivars -> do
+        rawSetIvarInList ivars n name ty sz align
+
+makeMethodList :: Int -> IO MethodList
+makeMethodList n = do
+    methods <- rawMakeMethodList n
+    methods <- newForeignPtr freePtr methods
+    return (MethodList methods)
+
+setMethodInList (MethodList methodList) idx sel typ cif imp =
+    withForeignPtr methodList $ \methodList -> do
+        typC <- newCString typ
+        thunk <- wrapIMP imp
+        rawSetMethodInList methodList idx sel typC cif thunk

  makeDefaultIvarList = do
      list <- makeIvarList 1
      name <- newCString "__retained_haskell_part__"
      typ <- newCString "^v"
-    setIvarInList list 0 name typ 0
+    setIvarInList list 0 name typ
+        (fromIntegral $ sizeOf nullPtr)
+        (fromIntegral $ alignment nullPtr)
      return list

-defaultIvarSize = 4 :: Int
-
  retainSelector = getSelectorForName "retain"
  retainCif = getCifForSelector (undefined :: ID () -> IO (ID ()))

@@ -75,33 +104,11 @@
  getHaskellDataCif = getCifForSelector (undefined :: Class () -> ID () ->  
IO (ID ()))
                                                  -- actually  -> IO (Ptr  
()) ...

-setHaskellRetainMethod methodList idx = do
-    typC <- newCString "@@:"
-    thunk <- wrapIMP haskellObject_retain_IMP
-    rawSetMethodInList methodList
-                       idx
-                       retainSelector
-                       typC
-                       retainCif
-                       thunk
+setHaskellRetainMethod methodList idx =
+    setMethodInList methodList idx retainSelector "@@:" retainCif  
haskellObject_retain_IMP

-setHaskellReleaseMethod methodList idx = do
-    typC <- newCString "v@:"
-    thunk <- wrapIMP haskellObject_release_IMP
-    rawSetMethodInList methodList
-                       idx
-                       releaseSelector
-                       typC
-                       releaseCif
-                       thunk
-
-setHaskellDataMethod methodList idx super mbDat = do
-    typC <- newCString "^v@:#"
-    thunk <- wrapIMP (getHaskellData_IMP super mbDat)
-    rawSetMethodInList methodList
-                       idx
-                       getHaskellDataSelector
-                       typC
-                       getHaskellDataCif
-                       thunk
+setHaskellReleaseMethod methodList idx =
+    setMethodInList methodList idx releaseSelector "v@:" releaseCif  
haskellObject_release_IMP

+setHaskellDataMethod methodList idx super mbDat =
+    setMethodInList methodList idx getHaskellDataSelector "^v@:#"  
getHaskellDataCif (getHaskellData_IMP super mbDat)

Modified: trunk/hoc/HOC_cbits/Class.h
==============================================================================
--- trunk/hoc/HOC_cbits/Class.h	(original)
+++ trunk/hoc/HOC_cbits/Class.h	Sun Dec 21 13:42:00 2008
@@ -1,3 +1,9 @@
  #include <objc/objc.h>

  id getClassByName(const char* name);
+
+Class getSuperclassForClass(Class class);
+Class getRootClassForClass(Class super_class);
+
+Class getClassForObject(id self);
+Class getSuperClassForObject(id self);
\ No newline at end of file

Modified: trunk/hoc/HOC_cbits/Class.m
==============================================================================
--- trunk/hoc/HOC_cbits/Class.m	(original)
+++ trunk/hoc/HOC_cbits/Class.m	Sun Dec 21 13:42:00 2008
@@ -13,3 +13,50 @@
  	return objc_getClass(name);
  #endif
  }
+
+Class getSuperclassForClass(Class class)
+{
+#ifdef GNUSTEP
+    if(CLS_ISRESOLV(class))
+        return class->super_class;
+    else
+        return getClassByName((const char*) class->super_class);
+
+#elif defined(__OBJC2__)
+    return class_getSuperclass(class);
+#else
+    return class->super_class;
+#endif
+}
+
+Class getRootClassForClass(Class super_class)
+{
+    Class root_class;
+
+    for(root_class = super_class;
+    getSuperclassForClass(root_class) != nil;
+    root_class = getSuperclassForClass(root_class))
+    ;
+
+    return root_class;
+}
+
+Class getClassForObject(id object)
+{
+#ifdef __OBJC2__
+    return object_getClass(object);
+#else
+    return object->isa;
+#endif
+}
+
+Class getSuperClassForObject(id self)
+{
+#ifdef GNUSTEP
+    return self->class_pointer->super_class;
+#elif defined(__OBJC2__)
+    return class_getSuperclass(object_getClass(self));
+#else
+    return self->isa->super_class;
+#endif
+}
\ No newline at end of file

Modified: trunk/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- trunk/hoc/HOC_cbits/Exceptions.m	(original)
+++ trunk/hoc/HOC_cbits/Exceptions.m	Sun Dec 21 13:42:00 2008
@@ -1,10 +1,15 @@
  #include <objc/objc.h>
  #include "NewClass.h"
  #include "Class.h"
+#include "Ivars.h"
+#include "Methods.h"
  #include "Selector.h"
  #include "Marshalling.h"
  #include "HsFFI.h"

+#define hsExceptionClassName "HOCHaskellException"
+#define hsExceptionIvarName "_haskellException"
+
  static BOOL excWrapperInited = NO;
  static int stablePtrOffset;
  static id clsHOCHaskellException;
@@ -21,12 +26,18 @@

  #if GNUSTEP
      super.self = self;
-    super.class = self->class_pointer->super_class;
+    super.class = getSuperClassForObject(self);

      (*objc_msg_lookup_super(&super, selDealloc))(self, selDealloc);
  #else
      super.receiver = self;
-    super.class = self->isa->super_class;
+
+#   ifdef __OBJC2__
+        super.super_class = getSuperClassForObject(self);
+#   else
+        super.class = getSuperClassForObject(self);
+#   endif
+
      objc_msgSendSuper(&super, selDealloc);
  #endif
  }
@@ -35,30 +46,29 @@
  {
      if(!excWrapperInited)
      {
-        struct objc_method_list *methods = makeMethodList(1);
-        struct objc_method_list *class_methods = makeMethodList(0);
-        struct objc_ivar_list *ivars = makeIvarList(1);
+        struct hoc_method_list *methods = makeMethodList(1);
+        struct hoc_method_list *class_methods = makeMethodList(0);
+        struct hoc_ivar_list *ivars = makeIvarList(1);
+        struct objc_ivar *stablePtrIvar;

          selDealloc = getSelectorForName("dealloc");

-#ifdef GNUSTEP
-        methods->method_list[0].method_name = (SEL)"dealloc";
-#else
-        methods->method_list[0].method_name = selDealloc;
-#endif
-        methods->method_list[0].method_types = "v@:";
-        methods->method_list[0].method_imp = (IMP) &exc_dealloc;
+        setMethodInListWithIMP(methods, 0, selDealloc, "v@:", (IMP)  
&exc_dealloc);

-        setIvarInList(ivars, 0, "_haskellExecption", "^v", 0);
+        setIvarInList(ivars, 0, hsExceptionIvarName, "^v", sizeof(void *),  
IVAR_PTR_ALIGN);

          newClass(getClassByName("NSException"),
-                "HOCHaskellException",
-                sizeof(void*),
+                hsExceptionClassName,
                  ivars, methods, class_methods);

          clsHOCHaskellException = getClassByName("HOCHaskellException");

-        stablePtrOffset = ivars->ivar_list[0].ivar_offset;
+        stablePtrIvar = class_getInstanceVariable(clsHOCHaskellException,  
hsExceptionIvarName);
+#ifdef __OBJC2__
+        stablePtrOffset = ivar_getOffset(stablePtrIvar);
+#else
+        stablePtrOffset = stablePtrIvar->ivar_offset;
+#endif

          selExceptionWithNameReasonUserInfo =  
getSelectorForName("exceptionWithName:reason:userInfo:");


Modified: trunk/hoc/HOC_cbits/GetNewHaskellData.m
==============================================================================
--- trunk/hoc/HOC_cbits/GetNewHaskellData.m	(original)
+++ trunk/hoc/HOC_cbits/GetNewHaskellData.m	Sun Dec 21 13:42:00 2008
@@ -47,7 +47,13 @@
  #endif

      if(m)
+    {
+#ifdef __OBJC2__
+        imp = method_getImplementation(m);
+#else
          imp = m->method_imp;
+#endif
+    }

      if(imp)
          return (*(getHaskellDataIMP)imp)(obj, selGetHaskellData);

Added: trunk/hoc/HOC_cbits/Ivars.h
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Ivars.h	Sun Dec 21 13:42:00 2008
@@ -0,0 +1,39 @@
+#include <stdlib.h>
+#include <stdint.h>
+
+struct hoc_ivar {
+    char *ivar_name;
+    char *ivar_types;
+    size_t ivar_size;
+    uint8_t ivar_alignment;
+};
+
+#define IVAR_PTR_ALIGN              ((uint8_t) sizeof(void *))
+
+struct hoc_ivar_list {
+    int ivar_count;
+
+    /* variable length structure */
+    struct hoc_ivar ivar_list[1];
+};
+
+struct hoc_ivar_list * makeIvarList(int n);
+
+void setIvarInList(
+        struct hoc_ivar_list *list,
+        int i,
+        char *name,     /* never deallocate this */
+        char *types,    /* never deallocate this */
+        size_t size,
+        uint8_t alignment
+    );
+
+#ifndef __OBJC2__
+
+struct objc_ivar_list * buildIndexedIvarList(
+        struct hoc_ivar_list *list,
+        int start_offset,
+        int *instance_size      /* out */
+    );
+
+#endif
\ No newline at end of file

Added: trunk/hoc/HOC_cbits/Ivars.m
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Ivars.m	Sun Dec 21 13:42:00 2008
@@ -0,0 +1,92 @@
+#ifdef GNUSTEP
+#include <objc/objc-api.h>
+#else
+#include <objc/objc-runtime.h>
+#endif
+
+#include <stdlib.h>
+#include <assert.h>
+
+#include "Ivars.h"
+
+struct hoc_ivar_list * makeIvarList(int n)
+{
+    struct hoc_ivar_list *list =
+        calloc(1, sizeof(struct hoc_ivar_list)
+                  + (n-1) * sizeof(struct hoc_ivar));
+    list->ivar_count = n;
+    return list;
+}
+
+void setIvarInList(
+        struct hoc_ivar_list *list,
+        int i,
+        char *name,
+        char *types,
+        size_t size,
+        uint8_t alignment
+    )
+{
+    list->ivar_list[i].ivar_name      = name;
+    list->ivar_list[i].ivar_types     = types;
+    list->ivar_list[i].ivar_size      = size;
+    list->ivar_list[i].ivar_alignment = alignment;
+}
+
+#ifndef __OBJC2__
+
+/* Used to be makeIvarList in NewClass.m */
+static struct objc_ivar_list * makeIndexedIvarList(int n)
+{
+    struct objc_ivar_list *list =
+        calloc(1, sizeof(struct objc_ivar_list)
+                  + (n-1) * sizeof(struct objc_ivar));
+    list->ivar_count = n;
+    return list;
+}
+
+/* Used to be setIvarInList in NewClass.m */
+static void setIvarInIndexedList(
+        struct objc_ivar_list *list,
+        int i,
+        char *name,
+        char *type,
+        int offset
+    )
+{
+    list->ivar_list[i].ivar_name = name;
+    list->ivar_list[i].ivar_type = type;
+    list->ivar_list[i].ivar_offset = offset;
+}
+
+struct objc_ivar_list * buildIndexedIvarList(
+        struct hoc_ivar_list *list,
+        int start_offset,
+        int *instance_size      /* out */
+    )
+{
+    struct objc_ivar_list * outList =  
makeIndexedIvarList(list->ivar_count);
+    int offset = start_offset;
+    int i;
+
+    for (i = 0; i < list->ivar_count; i++)
+    {
+        struct hoc_ivar *ivar = &list->ivar_list[i];
+
+        int align = ivar->ivar_alignment;
+        int alignmask = align - 1;
+
+        assert((align & alignmask) == 0);
+        if ((offset & alignmask) != 0)
+            offset = (offset & ~alignmask) + align;
+
+        setIvarInIndexedList(outList, i, ivar->ivar_name,  
ivar->ivar_types, offset);
+
+        offset += ivar->ivar_size;
+    }
+
+    *instance_size = offset - start_offset;
+    return outList;
+}
+
+#endif // ifndef __OBJC2__
\ No newline at end of file

Added: trunk/hoc/HOC_cbits/Methods.h
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Methods.h	Sun Dec 21 13:42:00 2008
@@ -0,0 +1,57 @@
+#ifdef GNUSTEP
+#include <objc/objc-api.h>
+#else
+#include <objc/objc-runtime.h>
+#endif
+
+#include <ffi.h>
+
+#ifdef __OBJC__
+@class NSException;
+#else
+typedef void NSException;
+#endif
+
+typedef NSException *(*haskellIMP)(
+                        ffi_cif *cif,
+                        void * ret,
+                        void **args
+                    );
+
+struct hoc_method {
+    SEL method_name;
+    char *method_types;
+    IMP method_imp;
+};
+
+struct hoc_method_list {
+    int method_count;
+
+    /* variable length structure */
+    struct hoc_method method_list[1];
+};
+
+struct hoc_method_list * makeMethodList(int n);
+
+void setMethodInListWithIMP(
+        struct hoc_method_list *list,
+        int i,
+        SEL sel,
+        char *types,    /* never deallocate this */
+        IMP imp         /* never deallocate this */
+    );
+
+void setMethodInList(
+        struct hoc_method_list *list,
+        int i,
+        SEL sel,
+        char *types,    /* never deallocate this */
+        ffi_cif *cif,   /* never deallocate this */
+        haskellIMP imp
+    );
+
+#ifndef __OBJC2__
+
+struct objc_method_list * convertMethodList(struct hoc_method_list * list);
+
+#endif
\ No newline at end of file

Added: trunk/hoc/HOC_cbits/Methods.m
==============================================================================
--- (empty file)
+++ trunk/hoc/HOC_cbits/Methods.m	Sun Dec 21 13:42:00 2008
@@ -0,0 +1,104 @@
+#include <stdlib.h>
+#include "Methods.h"
+#include "Statistics.h"
+
+#ifdef __OBJC__
+#import <Foundation/NSException.h>
+#endif
+
+static void objcIMP(ffi_cif *cif, void * ret, void **args, void *userData)
+{
+    recordHOCEvent(kHOCAboutToEnterHaskell, args);
+    NSException *e = (*(haskellIMP)userData)(cif, ret, args);
+    recordHOCEvent(kHOCLeftHaskell, args);
+    if(e != nil)
+        [e raise];
+}
+
+static ffi_closure *newIMP(ffi_cif *cif, haskellIMP imp)
+{
+    ffi_closure *closure = (ffi_closure*) calloc(1, sizeof(ffi_closure));
+    ffi_prep_closure(closure, cif, &objcIMP, (void*) imp);
+    return closure;
+}
+
+struct hoc_method_list * makeMethodList(int n)
+{
+    struct hoc_method_list *list =
+        calloc(1, sizeof(struct hoc_method_list)
+                  + (n-1) * sizeof(struct hoc_method));
+    list->method_count = n;
+    return list;
+}
+
+void setMethodInList(
+        struct hoc_method_list *list,
+        int i,
+        SEL sel,
+        char *types,
+        ffi_cif *cif,
+        haskellIMP imp
+    )
+{
+    setMethodInListWithIMP(list, i, sel, types, (IMP) newIMP(cif, imp) );
+}
+
+void setMethodInListWithIMP(
+        struct hoc_method_list *list,
+        int i,
+        SEL sel,
+        char *types,
+        IMP imp
+    )
+{
+    list->method_list[i].method_name = sel;
+    list->method_list[i].method_types = types;
+    list->method_list[i].method_imp = imp;
+}
+
+#ifndef __OBJC2__
+
+/* Was previously makeMethodList */
+static struct objc_method_list * makeObjcMethodList(int n)
+{
+    struct objc_method_list *list =
+        calloc(1, sizeof(struct objc_method_list)
+                  + (n-1) * sizeof(struct objc_method));
+    list->method_count = n;
+    return list;
+}
+
+/* Was previously setMethodInList */
+static void setObjCMethodInList(
+        struct objc_method_list *list,
+        int i,
+        SEL sel,
+        char *types,
+        IMP imp
+    )
+{
+#ifdef GNUSTEP
+    list->method_list[i].method_name = (SEL) sel_get_name(sel);
+#else
+    list->method_list[i].method_name = sel;
+#endif
+    list->method_list[i].method_types = types;
+    list->method_list[i].method_imp = imp;
+}
+
+struct objc_method_list *
+convertMethodList(struct hoc_method_list * list) {
+    struct objc_method_list * newList =  
makeObjcMethodList(list->method_count);
+    int i;
+
+    for(i = 0; i < list->method_count; i++)
+    {
+        struct hoc_method * method = &list->method_list[i];
+
+        setObjCMethodInList(newList, i, method->method_name,  
method->method_types, method->method_imp);
+    }
+
+    return newList;
+}
+
+#endif // ifndef __OBJC2__
\ No newline at end of file

Modified: trunk/hoc/HOC_cbits/NewClass.h
==============================================================================
--- trunk/hoc/HOC_cbits/NewClass.h	(original)
+++ trunk/hoc/HOC_cbits/NewClass.h	Sun Dec 21 13:42:00 2008
@@ -4,42 +4,12 @@
  #include <objc/objc-runtime.h>
  #endif

-#include <ffi.h>
+struct hoc_ivar_list;
+struct hoc_method_list;

-#ifdef __OBJC__
-@class NSException;
-#else
-typedef void NSException;
-#endif
-
-void newClass(struct objc_class * super_class,
+void newClass(Class super_class,
                  const char * name,                          /* never  
deallocate this */
-				int instance_size,
-				struct objc_ivar_list *ivars,               /* never deallocate this */
-				struct objc_method_list *methods,           /* never deallocate this */
-				struct objc_method_list *class_methods);    /* never deallocate this */
+				struct hoc_ivar_list *ivars,
+				struct hoc_method_list *methods,
+				struct hoc_method_list *class_methods);
  				
-typedef NSException *(*haskellIMP)(
-                        ffi_cif *cif,
-                        void * ret,
-                        void **args
-                    );
-
-struct objc_method_list * makeMethodList(int n);
-void setMethodInList(
-        struct objc_method_list *list,
-        int i,
-        SEL sel,
-        char *types,    /* never deallocate this */
-        ffi_cif *cif,   /* never deallocate this */
-        haskellIMP imp
-    );
-
-struct objc_ivar_list * makeIvarList(int n);
-void setIvarInList(
-        struct objc_ivar_list *list,
-        int i,
-        char *name,     /* never deallocate this */
-        char *type,     /* never deallocate this */
-        int offset
-    );

Modified: trunk/hoc/HOC_cbits/NewClass.m
==============================================================================
--- trunk/hoc/HOC_cbits/NewClass.m	(original)
+++ trunk/hoc/HOC_cbits/NewClass.m	Sun Dec 21 13:42:00 2008
@@ -2,8 +2,9 @@
  #include <Foundation/NSException.h>
  #include <assert.h>
  #include "Class.h"
+#include "Ivars.h"
+#include "Methods.h"
  #include "NewClass.h"
-#include "Statistics.h"

  #ifdef GNUSTEP
  #define isa class_pointer
@@ -11,157 +12,133 @@
  #define CLS_META _CLS_META
  #endif

-static struct objc_class * getSuper(struct objc_class *class)
-{
-#ifdef GNUSTEP
-    if(CLS_ISRESOLV(class))
-        return class->super_class;
-    else
-        return getClassByName((const char*) class->super_class);
-
+static Class allocateClassPair(Class super_class, const char * name) {
+#ifdef __OBJC2__
+    return objc_allocateClassPair(super_class, name, 0);
  #else
-    return class->super_class;
+    Class new_class = calloc( 2, sizeof(struct objc_class) );
+    Class meta_class = &new_class[1];
+	Class root_class = getRootClassForClass(super_class);
+
+    new_class->isa      = meta_class;
+    new_class->info     = CLS_CLASS;
+    meta_class->info    = CLS_META;
+
+    new_class->name = name;
+    meta_class->name = name;
+
+#   ifdef GNUSTEP
+        new_class->super_class = (void*)(super_class->name);
+        meta_class->super_class = (void*)(super_class->isa->name);
+#   else
+        new_class->super_class  = super_class;
+        meta_class->super_class = super_class->isa;
+        meta_class->isa         = (void *)root_class->isa;
+#   endif
+
+    return new_class;
  #endif
  }

-void newClass(struct objc_class * super_class,
-                const char * name,
-				int instance_size,
-				struct objc_ivar_list *ivars,
-				struct objc_method_list *methods,
-				struct objc_method_list *class_methods)
-{
-	struct objc_class * meta_class;
-	struct objc_class * new_class;
-	struct objc_class * root_class;
-	int i;
-	
-	assert(objc_lookUpClass(name) == nil);
-	
-	for(root_class = super_class;
-		root_class->super_class != nil;
-		root_class = getSuper(root_class))
-		;
-		
-	new_class = calloc( 2, sizeof(struct objc_class) );
-	meta_class = &new_class[1];
-	
-	new_class->isa      = meta_class;
-	new_class->info     = CLS_CLASS;
-	meta_class->info    = CLS_META;
-
-	new_class->name = name;
-	meta_class->name = name;
-	
-	new_class->instance_size = super_class->instance_size + instance_size;
-	for(i=0; i<ivars->ivar_count; i++)
-		ivars->ivar_list[i].ivar_offset += super_class->instance_size;
-		
-	new_class->ivars = ivars;
-
+static void registerClassPair(Class new_class) {
  #ifdef GNUSTEP
-	new_class->super_class = (void*)(super_class->name);
-    meta_class->super_class = (void*)(super_class->isa->name);
-	
-    {
-    	Module_t module = calloc(1, sizeof(Module));
-        Symtab_t symtab = calloc(1, sizeof(Symtab) + sizeof(void*) /* two  
defs pointers */);
-        extern void __objc_exec_class (Module_t module);
-        extern void __objc_resolve_class_links ();
-
-        module->version = 8;	
-        module->size = sizeof(Module);
-        module->name = strdup(name);
-        module->symtab = symtab;
-        symtab->cls_def_cnt = 1;
-        symtab->defs[0] = new_class;
-        symtab->defs[1] = NULL;
-
-        __objc_exec_class (module);
-        __objc_resolve_class_links();
-    }
+    Module_t module = calloc(1, sizeof(Module));
+    Symtab_t symtab = calloc(1, sizeof(Symtab) + sizeof(void*) /* two defs  
pointers */);
+    extern void __objc_exec_class (Module_t module);
+    extern void __objc_resolve_class_links ();
+
+    module->version = 8;	
+    module->size = sizeof(Module);
+    module->name = strdup(name);
+    module->symtab = symtab;
+    symtab->cls_def_cnt = 1;
+    symtab->defs[0] = new_class;
+    symtab->defs[1] = NULL;

-    class_add_method_list(new_class, methods);
-    class_add_method_list(meta_class, class_methods);
+    __objc_exec_class (module);
+    __objc_resolve_class_links();
+#elif defined(__OBJC2__)
+    objc_registerClassPair(new_class);
  #else
-	new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *) );
-	meta_class->methodLists = calloc( 1, sizeof(struct objc_method_list *) );
-    new_class->methodLists[0] = (struct objc_method_list*) -1;
-    meta_class->methodLists[0] = (struct objc_method_list*) -1;
-
-	new_class->super_class  = super_class;
-	meta_class->super_class = super_class->isa;
-	meta_class->isa         = (void *)root_class->isa;
-	
-	objc_addClass( new_class );
-	
-	class_addMethods(new_class, methods);
-	class_addMethods(meta_class, class_methods);
+    objc_addClass( new_class );
  #endif
  }

-
-static void objcIMP(ffi_cif *cif, void * ret, void **args, void *userData)
-{
-    recordHOCEvent(kHOCAboutToEnterHaskell, args);
-    NSException *e = (*(haskellIMP)userData)(cif, ret, args);
-    recordHOCEvent(kHOCLeftHaskell, args);
-    if(e != nil)
-        [e raise];
-}
-
-static ffi_closure *newIMP(ffi_cif *cif, haskellIMP imp)
+static void addIvarsToClass(Class new_class, struct hoc_ivar_list *ivars)
  {
-    ffi_closure *closure = (ffi_closure*) calloc(1, sizeof(ffi_closure));
-    ffi_prep_closure(closure, cif, &objcIMP, (void*) imp);
-    return closure;
-}
-
-struct objc_method_list * makeMethodList(int n)
-{
-    struct objc_method_list *list =
-        calloc(1, sizeof(struct objc_method_list)
-                  + (n-1) * sizeof(struct objc_method));
-    list->method_count = n;
-    return list;
+#ifdef __OBJC2__
+    int i;
+
+    for (i = 0; i < ivars->ivar_count; i++)
+    {
+        struct hoc_ivar *ivar = &ivars->ivar_list[i];
+        class_addIvar(new_class, ivar->ivar_name,
+            ivar->ivar_size, ivar->ivar_alignment, ivar->ivar_types);
+    }
+#else
+    Class super_class = getSuperclassForClass(new_class);
+
+    int instance_size;
+    new_class->ivars = buildIndexedIvarList(
+                                ivars,
+                                super_class->instance_size,
+                                &instance_size);
+
+    new_class->instance_size = super_class->instance_size + instance_size;
+#endif
  }

-void setMethodInList(
-        struct objc_method_list *list,
-        int i,
-        SEL sel,
-        char *types,
-        ffi_cif *cif,
-        haskellIMP imp
-    )
+static void addMethodsToClass(Class new_class, struct hoc_method_list  
*methods)
  {
  #ifdef GNUSTEP
-    list->method_list[i].method_name = (SEL) sel_get_name(sel);
+    class_add_method_list(new_class, convertMethodList(methods));
+#elif defined(__OBJC2__)
+    int i;
+    for (i = 0; i < methods->method_count; i++)
+    {
+        struct hoc_method * m = &methods->method_list[i];
+        class_addMethod(new_class, m->method_name, m->method_imp,  
m->method_types);
+    }
  #else
-    list->method_list[i].method_name = sel;
+    new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *)  
);
+    new_class->methodLists[0] = (struct objc_method_list*) -1;
+
+    class_addMethods(new_class, convertMethodList(methods));
  #endif
-    list->method_list[i].method_types = types;
-    list->method_list[i].method_imp = (IMP) newIMP(cif, imp);
  }

-struct objc_ivar_list * makeIvarList(int n)
+void newClass(Class super_class,
+                const char * name,
+                struct hoc_ivar_list *ivars,
+                struct hoc_method_list *methods,
+                struct hoc_method_list *class_methods)
  {
-    struct objc_ivar_list *list =
-        calloc(1, sizeof(struct objc_ivar_list)
-                  + (n-1) * sizeof(struct objc_ivar));
-    list->ivar_count = n;
-    return list;
-}
+	Class meta_class;
+	Class new_class;
+	
+	assert(objc_lookUpClass(name) == nil);
+	
+	/* Allocate the class and metaclass */
+    new_class = allocateClassPair(super_class, name);
+    meta_class = getClassForObject(new_class);
+	
+	/* Add instance variables to the class */
+    addIvarsToClass(new_class, ivars);
+
+    /* Add methods and class methods */
+    /* I don't know whether order actually matters here in the non-objc2  
cases,
+       so I'm leaving it as it was. */
+#ifdef __OBJC2__
+    addMethodsToClass(new_class, methods);
+    addMethodsToClass(meta_class, class_methods);
+
+    registerClassPair(new_class);
+#else
+    registerClassPair(new_class);
+
+    addMethodsToClass(new_class, methods);
+    addMethodsToClass(meta_class, class_methods);
+#endif

-void setIvarInList(
-        struct objc_ivar_list *list,
-        int i,
-        char *name,
-        char *type,
-        int offset
-    )
-{
-    list->ivar_list[i].ivar_name = name;
-    list->ivar_list[i].ivar_type = type;
-    list->ivar_list[i].ivar_offset = offset;
  }
+

Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs	Sun Dec 21 13:42:00 2008
@@ -25,6 +25,7 @@
          ClassEntity _ ->
              [eHaskellName e, '_' `BS.cons` eHaskellName e,
               eHaskellName e `BS.append` BS.pack "Class",
+             eHaskellName e `BS.append` BS.pack "MetaClass",
               BS.pack "super_" `BS.append` eHaskellName e,
               eHaskellName e `BS.snoc` '_' ]
          EnumEntity complete values ->
@@ -56,11 +57,13 @@
          LocalModule m
              -> text "import {-# SOURCE #-}" <+> textBS m
                  <+> parens (textBS (eHaskellName e) <> comma
-                            <+> textBS (eHaskellName e) <> text "Class")
+                            <+> textBS (eHaskellName e) <> text "Class" <>  
comma
+                            <+> textBS (eHaskellName e) <>  
text "MetaClass")
          FrameworkModule f m
              -> text "import" <+> textBS m
                  <+> parens (textBS (eHaskellName e) <> comma
-                            <+> textBS (eHaskellName e) <> text "Class")
+                            <+> textBS (eHaskellName e) <> text "Class" <>  
comma
+                            <+> textBS (eHaskellName e) <>  
text "MetaClass")

  pprHsBoot entityPile modName entities
      = text "module" <+> textBS modName <+> text "where" $+$
@@ -78,6 +81,9 @@
                          <+> parens (textBS name <> char '_' <+> char 'a')  
$+$
                      text "type" <+> textBS name <> text "Class" <+>  
char 'a' <+> equals
                          <+> text (maybe "Class" ( (++ "Class") .  
BS.unpack . eHaskellName ) mbSuper)
+                        <+> parens (textBS name <> char '_' <+> char 'a')  
$+$
+                    text "type" <+> textBS name <> text "MetaClass" <+>  
char 'a' <+> equals
+                        <+> text (maybe "MetaClass" ( (++ "MetaClass") .  
BS.unpack . eHaskellName ) mbSuper)
                          <+> parens (textBS name <> char '_' <+> char 'a')

                    | (name, mbSuper) <- classes0 ]

Modified: trunk/hoc/Setup.hs
==============================================================================
--- trunk/hoc/Setup.hs	(original)
+++ trunk/hoc/Setup.hs	Sun Dec 21 13:42:00 2008
@@ -1,6 +1,8 @@
  import Distribution.Simple
  import Distribution.PackageDescription
+import Distribution.Simple.Build
  import Distribution.Simple.Setup
+import Distribution.Simple.PreProcess
  import Distribution.Simple.Configure
  import Distribution.Simple.LocalBuildInfo
  import System.Cmd( system )
@@ -13,9 +15,46 @@

  main = defaultMainWithHooks $ simpleUserHooks {
          confHook = customConfig,
-        preBuild = customPreBuild
+        buildHook = customBuild
      }
+
+-- You probably don't need to change this, but if you do beware that
+-- it will not be sanitized for the shell.
+cbitsObjectFile = "dist/build/HOC_cbits.o"
+
+needsCBitsWhileBuilding :: Executable -> Bool
+needsCBitsWhileBuilding e
+        | exeName e == "hoc-test"       = True
+        | otherwise                     = False
+
+objc2_flagName = FlagName "objc2"
+
+setObjC2Flag :: ConfigFlags -> IO ConfigFlags
+setObjC2Flag cf
+    -- if the flag is set on the command line, do nothing
+    | lookup (objc2_flagName) (configConfigurationsFlags cf) /= Nothing
+    = return cf
+
+    -- if we're not on darwin, assume false
+    | System.Info.os /= "darwin"
+    = return $ addFlag objc2_flagName False cf
+
+    -- otherwise make an educated guess
+    | otherwise
+    = do
+        value <- objC2Available
+        return $ addFlag objc2_flagName value cf

+    where addFlag flag value cf = cf { configConfigurationsFlags =
+                (flag,value) : configConfigurationsFlags cf }
+
+objC2Available :: IO Bool
+objC2Available
+    | System.Info.os /= "darwin"    = return False
+    | otherwise = do
+        result <- system "grep -qR /usr/include/objc -e  
objc_allocateClassPair"
+        return (result == ExitSuccess)
+
  backquote :: String -> IO String
  backquote cmd = do
      (inp,out,err,pid) <- runInteractiveCommand cmd
@@ -43,6 +82,8 @@

  customConfig :: (Either GenericPackageDescription PackageDescription,  
HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo
  customConfig pdbi cf = do
+    cf <- setObjC2Flag cf
+
      lbi <- configure pdbi cf
      if System.Info.os == "darwin"
          then return()
@@ -52,48 +93,56 @@

      return lbi

-customPreBuild :: Args -> BuildFlags -> IO HookedBuildInfo
-customPreBuild args buildFlags = do
-    putStrLn "Compiling HOC_cbits..."
-    system "mkdir -p dist/build/"
+customBuild :: PackageDescription -> LocalBuildInfo -> UserHooks ->  
BuildFlags -> IO ()
+customBuild pd lbi hooks buildFlags = do
+    let Just libInfo = library pd
+
+    extraFlags <- buildCBits (libBuildInfo libInfo)
+
+    let hooked_pd = pd
+                { library = Just $ libInfo
+                        { libBuildInfo = addCompilerFlags extraFlags
+                                                (libBuildInfo libInfo)
+                        }
+                , executables = alterExecutable needsCBitsWhileBuilding
+                        (\exe -> exe {buildInfo = addCompilerFlags  
extraFlags (buildInfo exe)})
+                        (executables pd)
+                }

-    (cflags, paths, extralibs) <-
-        if System.Info.os == "darwin"
-            then do
-                return ("-I/usr/include/ffi -DMACOSX", [], ["-framework  
Foundation"])
-            else do
-                (gcclibdir, system_libs, system_headers) <- gnustepPaths
-                ffi_cflags <- backquote "pkg-config libffi --cflags"
-                return ("-I" ++ system_headers ++ " -DGNUSTEP" ++ " " ++  
ffi_cflags,
-                        ["-L" ++ gcclibdir, "-L" ++ system_libs],
-                        ["-lgnustep-base"])
+    build hooked_pd lbi buildFlags knownSuffixHandlers

+-- |Build HOC_cbits.o using the flags specified in the configuration
+-- stage, and return a list of flags to add to support usage of
+-- template-haskell while compiling (for both the library and the
+-- hoc-test executable)
+buildCBits :: BuildInfo -> IO [(CompilerFlavor, [String])]
+buildCBits buildInfo = do
+    putStrLn "Compiling HOC_cbits..."
+    system ("mkdir -p " ++ takeDirectory cbitsObjectFile)
+
+    let cflags = cppOptions buildInfo ++ ccOptions buildInfo
+                ++ ["-I" ++ dir | dir <- includeDirs buildInfo]
+        extraGHCflags = [cbitsObjectFile]
+                ++ ["-l" ++ lib | lib <- extraLibs buildInfo]
+                ++ ["-framework " ++ fw | fw <- frameworks buildInfo]
+
      exitCode <- system $ "gcc -r -nostdlib -I`ghc --print-libdir`/include "
-                    ++ cflags ++ " HOC_cbits/*.m -o dist/build/HOC_cbits.o"
-
+                    ++ unwords cflags
+                    ++ " HOC_cbits/*.m -o " ++ cbitsObjectFile
+
      case exitCode of
          ExitSuccess -> return ()
          _ -> fail "Failed in C compilation."

-    -- system "cp dist/build/HOC_cbits.o dist/build/HOC_cbits.dyn_o"
-    system "cp dist/build/HOC_cbits.o dist/build/hoc-test/hoc-test-tmp/"
-
-    let buildInfo = emptyBuildInfo {
-            options = [ (GHC, ["dist/build/HOC_cbits.o" ]
-                              ++ paths ++
-                              ["-lobjc",
-                               "-lffi"]
-                              ++ extralibs) ],
-            cSources = ["HOC_cbits.o"]
-        }
-        buildInfo2 = emptyBuildInfo {
-            options = [ (GHC,  
["dist/build/hoc-test/hoc-test-tmp/HOC_cbits.o" ]
-                              ++ paths ++
-                              ["-lobjc",
-                               "-lffi"]
-                              ++ extralibs) ]{-,
-            cSources = ["HOC_cbits.o"]-}
-        }
-
-    return (Just buildInfo, [("hoc-test", buildInfo2)])
+    return [(GHC, extraGHCflags)]
+
+-- TODO: check whether it's OK for the options field to have multiple
+-- entries for the same "compiler flavor"
+addCompilerFlags :: [(CompilerFlavor,[String])] -> BuildInfo -> BuildInfo
+addCompilerFlags flags buildInfo = buildInfo {
+        options = flags ++ options buildInfo
+    }

+alterExecutable :: (Executable -> Bool) -> (Executable -> Executable)
+        -> [Executable] -> [Executable]
+alterExecutable p f exes = [if p exe then f exe else exe | exe <- exes]
\ No newline at end of file

Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs	(original)
+++ trunk/hoc/Tests/TestFoundation.hs	Sun Dec 21 13:42:00 2008
@@ -94,16 +94,19 @@

  $(declareClass "HaskellObjectCountingInvocations" "NSObject")
  $(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
-        InstanceMethod 'countInvocationsUpto
+        InstanceMethod 'countInvocationsUpto,
+        ClassMethod 'countInvocationsUpto
      ])

  instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocationsClass a)

  hoci_1_countInvocationsUpto start limit self = return (start + 1)

   
$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
  $(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
-        InstanceMethod 'countInvocationsUpto
+        InstanceMethod 'countInvocationsUpto,
+        ClassMethod 'countInvocationsUpto
      ])

  hoci_2_countInvocationsUpto start limit self
@@ -268,7 +271,7 @@
                  str <- hobj # description
                  fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
              ),
-            "chaining" ~: test [
+            "instanceChaining" ~: test [
                  "base" ~: (assertNoLeaks $ do
                      hobj <- _HaskellObjectCountingInvocations # alloc >>=  
init
                      count <- hobj # countInvocationsUpto 0 100
@@ -284,6 +287,22 @@
                      count <- hobj # countInvocationsUpto 0 100
                      count @?= 2
                  )
+
+            ],
+            "classChaining" ~: test [
+                "base" ~: (assertNoLeaks $ do
+                    count <- _HaskellObjectCountingInvocations #  
countInvocationsUpto 0 100
+                    count @?= 1
+                ),
+                "subclass" ~: (assertNoLeaks $ do
+                    count <- _HaskellObjectUsingSuper #  
countInvocationsUpto 0 100
+                    count @?= 2
+                ),
+                "subsubclass" ~: (assertNoLeaks $ do
+                    count <- _HaskellSubclassOfObjectUsingSuper #  
countInvocationsUpto 0 100
+                    count @?= 2
+                )
+
              ]
          ],
          "structs" ~: test [