Menu
▾
▴
[hoc-cvs] [hoc commit] r377 - in trunk/hoc: . HOC HOC/HOC HOC_cbits InterfaceGenerator2 Tests
|
From: <cod...@go...> - 2008-12-21 22:06:32
|
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 [
|
