Menu
▾
▴
hoc-cvs — CVS commit log messages
You can subscribe to this list here.
| 2004 |
Jan
|
Feb
|
Mar
|
Apr
|
May
(127) |
Jun
(1) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(6) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2005 |
Jan
|
Feb
|
Mar
(35) |
Apr
(23) |
May
|
Jun
(1) |
Jul
(48) |
Aug
(23) |
Sep
(10) |
Oct
(4) |
Nov
|
Dec
|
| 2006 |
Jan
|
Feb
|
Mar
(27) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
(7) |
Dec
|
| 2007 |
Jan
|
Feb
(16) |
Mar
(2) |
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2008 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
(19) |
Oct
(25) |
Nov
(8) |
Dec
(25) |
| 2009 |
Jan
(6) |
Feb
(1) |
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(25) |
Sep
(2) |
Oct
|
Nov
|
Dec
|
| 2010 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
(3) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: <cod...@go...> - 2008-12-08 20:35:35
|
Author: jam...@us...
Date: Mon Dec 8 12:12:08 2008
New Revision: 366
Modified:
branches/objc2/hoc/HOC/HOC/Super.hs
branches/objc2/hoc/HOC_cbits/Class.h
branches/objc2/hoc/HOC_cbits/Class.m
branches/objc2/hoc/HOC_cbits/Exceptions.m
branches/objc2/hoc/HOC_cbits/GetNewHaskellData.m
branches/objc2/hoc/HOC_cbits/Ivars.h
branches/objc2/hoc/HOC_cbits/Ivars.m
branches/objc2/hoc/HOC_cbits/Methods.h
branches/objc2/hoc/HOC_cbits/Methods.m
branches/objc2/hoc/HOC_cbits/NewClass.m
Log:
Big ugly patch implementing Objective C 2.0 runtime support. Seems to be
working, passes all tests, etc.
I intend to clean it up a bit still, especially in the vicinity of
NewClass.m
Modified: branches/objc2/hoc/HOC/HOC/Super.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Super.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Super.hs Mon Dec 8 12:12:08 2008
@@ -1,5 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
- UndecidableInstances, FlexibleInstances #-}
+ UndecidableInstances, FlexibleInstances,
+ ForeignFunctionInterface #-}
module HOC.Super(
SuperClass, SuperTarget, Super(super), withExportedSuper
) where
@@ -54,8 +55,8 @@
=> Super (ID sub) (SuperTarget super) where
super obj = SuperTarget (fromID $ toID obj)
-getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr
()))
- peekElemOff cls 1
+foreign import ccall "Class.h getSuperClassForObject"
+ getSuperClassForObject :: Ptr ObjCObject -> IO (Ptr ())
instance MessageTarget a => MessageTarget (SuperTarget a) where
isNil (SuperTarget x) = isNil x
Modified: branches/objc2/hoc/HOC_cbits/Class.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Class.h (original)
+++ branches/objc2/hoc/HOC_cbits/Class.h Mon Dec 8 12:12:08 2008
@@ -1,3 +1,4 @@
#include <objc/objc.h>
id getClassByName(const char* name);
+Class getSuperClassForObject(id self);
\ No newline at end of file
Modified: branches/objc2/hoc/HOC_cbits/Class.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Class.m (original)
+++ branches/objc2/hoc/HOC_cbits/Class.m Mon Dec 8 12:12:08 2008
@@ -13,3 +13,14 @@
return objc_getClass(name);
#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: branches/objc2/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Exceptions.m (original)
+++ branches/objc2/hoc/HOC_cbits/Exceptions.m Mon Dec 8 12:12:08 2008
@@ -26,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
}
Modified: branches/objc2/hoc/HOC_cbits/GetNewHaskellData.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/GetNewHaskellData.m (original)
+++ branches/objc2/hoc/HOC_cbits/GetNewHaskellData.m Mon Dec 8 12:12:08
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);
Modified: branches/objc2/hoc/HOC_cbits/Ivars.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Ivars.h (original)
+++ branches/objc2/hoc/HOC_cbits/Ivars.h Mon Dec 8 12:12:08 2008
@@ -28,8 +28,12 @@
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
Modified: branches/objc2/hoc/HOC_cbits/Ivars.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Ivars.m (original)
+++ branches/objc2/hoc/HOC_cbits/Ivars.m Mon Dec 8 12:12:08 2008
@@ -33,8 +33,10 @@
list->ivar_list[i].ivar_alignment = alignment;
}
+#ifndef __OBJC2__
+
/* Used to be makeIvarList in NewClass.m */
-struct objc_ivar_list * makeIndexedIvarList(int n)
+static struct objc_ivar_list * makeIndexedIvarList(int n)
{
struct objc_ivar_list *list =
calloc(1, sizeof(struct objc_ivar_list)
@@ -44,7 +46,7 @@
}
/* Used to be setIvarInList in NewClass.m */
-void setIvarInIndexedList(
+static void setIvarInIndexedList(
struct objc_ivar_list *list,
int i,
char *name,
@@ -88,3 +90,4 @@
return outList;
}
+#endif // ifndef __OBJC2__
\ No newline at end of file
Modified: branches/objc2/hoc/HOC_cbits/Methods.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Methods.h (original)
+++ branches/objc2/hoc/HOC_cbits/Methods.h Mon Dec 8 12:12:08 2008
@@ -50,4 +50,8 @@
haskellIMP imp
);
-struct objc_method_list * convertMethodList(struct hoc_method_list * list);
\ No newline at end of file
+#ifndef __OBJC2__
+
+struct objc_method_list * convertMethodList(struct hoc_method_list * list);
+
+#endif
\ No newline at end of file
Modified: branches/objc2/hoc/HOC_cbits/Methods.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Methods.m (original)
+++ branches/objc2/hoc/HOC_cbits/Methods.m Mon Dec 8 12:12:08 2008
@@ -26,7 +26,7 @@
{
struct hoc_method_list *list =
calloc(1, sizeof(struct hoc_method_list)
- + (n-1) * sizeof(struct objc_method));
+ + (n-1) * sizeof(struct hoc_method));
list->method_count = n;
return list;
}
@@ -56,6 +56,8 @@
list->method_list[i].method_imp = imp;
}
+#ifndef __OBJC2__
+
/* Was previously makeMethodList */
static struct objc_method_list * makeObjcMethodList(int n)
{
@@ -97,4 +99,6 @@
}
return newList;
-}
\ No newline at end of file
+}
+
+#endif // ifndef __OBJC2__
\ No newline at end of file
Modified: branches/objc2/hoc/HOC_cbits/NewClass.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.m (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.m Mon Dec 8 12:12:08 2008
@@ -20,6 +20,8 @@
else
return getClassByName((const char*) class->super_class);
+#elif defined(__OBJC2__)
+ return class_getSuperclass(class);
#else
return class->super_class;
#endif
@@ -33,16 +35,14 @@
{
struct objc_class * meta_class;
struct objc_class * new_class;
- struct objc_class * root_class;
- int instance_size;
assert(objc_lookUpClass(name) == nil);
- for(root_class = super_class;
- root_class->super_class != nil;
- root_class = getSuper(root_class))
- ;
-
+ /* Allocate the class and metaclass */
+#ifdef __OBJC2__
+ new_class = objc_allocateClassPair(super_class, name, 0);
+ meta_class = object_getClass(new_class);
+#else
new_class = calloc( 2, sizeof(struct objc_class) );
meta_class = &new_class[1];
@@ -52,14 +52,34 @@
new_class->name = name;
meta_class->name = name;
+#endif
- new_class->ivars = buildIndexedIvarList(
- ivars,
- super_class->instance_size,
- &instance_size);
-
- new_class->instance_size = super_class->instance_size + instance_size;
+ /* Add instance variables to the class */
+#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
+ {
+ 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
+ /* Add methods and class methods */
#ifdef GNUSTEP
new_class->super_class = (void*)(super_class->name);
meta_class->super_class = (void*)(super_class->isa->name);
@@ -84,20 +104,46 @@
class_add_method_list(new_class, convertMethodList(methods));
class_add_method_list(meta_class, convertMethodList(class_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);
+ }
+
+ for (i = 0; i < class_methods->method_count; i++)
+ {
+ struct hoc_method * m = &class_methods->method_list[i];
+ class_addMethod(meta_class, m->method_name, m->method_imp,
m->method_types);
+ }
+
+ 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, convertMethodList(methods));
- class_addMethods(meta_class, convertMethodList(class_methods));
+ {
+ struct objc_class * root_class;
+ for(root_class = super_class;
+ root_class->super_class != nil;
+ root_class = getSuper(root_class))
+ ;
+
+ 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, convertMethodList(methods));
+ class_addMethods(meta_class, convertMethodList(class_methods));
+ }
#endif
+
}
|
|
From: <cod...@go...> - 2008-12-08 18:36:53
|
Author: jam...@us...
Date: Mon Dec 8 10:36:18 2008
New Revision: 365
Modified:
branches/objc2/hoc/HOC.cabal
Log:
Fixed something I missed in the previous patch to the build system.
HOC_cbits.o is now properly packaged into the final libHSHOC*.a
Modified: branches/objc2/hoc/HOC.cabal
==============================================================================
--- branches/objc2/hoc/HOC.cabal (original)
+++ branches/objc2/hoc/HOC.cabal Mon Dec 8 10:36:18 2008
@@ -58,6 +58,7 @@
hs-source-dirs: HOC
extra-libraries: objc, ffi
+ c-sources: HOC_cbits.o
if os(darwin)
include-dirs: /usr/include/ffi
frameworks: Foundation
@@ -68,7 +69,7 @@
cpp-options: -DGNUSTEP
if flag(ObjC2)
- cpp-options: -D__OBJC2__
+ cpp-options: -D__OBJC2__=1
Executable hoc-ifgen
|
|
From: <cod...@go...> - 2008-12-08 17:25:00
|
Author: jam...@us...
Date: Mon Dec 8 09:22:06 2008
New Revision: 364
Modified:
branches/objc2/hoc/HOC.cabal
branches/objc2/hoc/Setup.hs
Log:
Added a cabal flag "ObjC2" and rewrote a bit of Setup.hs to use a build
hook rather than a prebuild hook for building the c bits.
The changes to Setup.hs allow us to actually use the preprocessor options
specified in the cabal file, so that the option triggered by the ObjC2 flag
can actually have an effect.
Modified: branches/objc2/hoc/HOC.cabal
==============================================================================
--- branches/objc2/hoc/HOC.cabal (original)
+++ branches/objc2/hoc/HOC.cabal Mon Dec 8 09:22:06 2008
@@ -14,6 +14,10 @@
description: build test cases
default: False
+Flag ObjC2
+ description: build for Objective-C 2.0
+ default: False
+
Library
build-depends: base, template-haskell, unix
@@ -55,12 +59,16 @@
extra-libraries: objc, ffi
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__
Executable hoc-ifgen
Modified: branches/objc2/hoc/Setup.hs
==============================================================================
--- branches/objc2/hoc/Setup.hs (original)
+++ branches/objc2/hoc/Setup.hs Mon Dec 8 09:22:06 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,18 @@
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
+
backquote :: String -> IO String
backquote cmd = do
(inp,out,err,pid) <- runInteractiveCommand cmd
@@ -52,48 +63,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
- (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"])
+ 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)
+ }
+
+ 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
|
|
From: <cod...@go...> - 2008-12-07 14:21:51
|
Author: jam...@us...
Date: Sun Dec 7 05:59:55 2008
New Revision: 363
Modified:
branches/objc2/hoc/HOC/HOC/NewClass.hs
Log:
Renamed new "raw" ffi functions (created for handling IvarList and
MethodList types as ForeignPtrs) in NewClass.hs to be more consistent with
previously-existing ones.
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Sun Dec 7 05:59:55 2008
@@ -31,7 +31,7 @@
newtype IvarList = IvarList (ForeignPtr IvarList)
foreign import ccall "NewClass.h newClass"
- c_newClass :: Ptr ObjCObject -> CString
+ rawNewClass :: Ptr ObjCObject -> CString
-> Ptr IvarList
-> Ptr MethodList -> Ptr MethodList
-> IO ()
@@ -44,7 +44,7 @@
withForeignPtr ivars $ \ivars ->
withForeignPtr ms $ \ms ->
withForeignPtr cms $ \cms -> do
- c_newClass sc name ivars ms cms
+ rawNewClass sc name ivars ms cms
foreign import ccall "NewClass.h makeMethodList"
rawMakeMethodList :: Int -> IO (Ptr MethodList)
@@ -56,14 +56,14 @@
foreign import ccall "NewClass.h makeIvarList"
- c_makeIvarList :: Int -> IO (Ptr IvarList)
+ rawMakeIvarList :: Int -> IO (Ptr IvarList)
foreign import ccall "NewClass.h setIvarInList"
- c_setIvarInList :: Ptr IvarList -> Int
+ rawSetIvarInList :: Ptr IvarList -> Int
-> CString -> CString -> CSize -> Word8 -> IO ()
makeIvarList :: Int -> IO IvarList
makeIvarList n = do
- ivars <- c_makeIvarList n
+ ivars <- rawMakeIvarList n
ivars <- newForeignPtr freePtr ivars
return (IvarList ivars)
@@ -71,7 +71,7 @@
-> CString -> CString -> CSize -> Word8 -> IO ()
setIvarInList (IvarList ivars) n name ty sz align =
withForeignPtr ivars $ \ivars -> do
- c_setIvarInList ivars n name ty sz align
+ rawSetIvarInList ivars n name ty sz align
makeMethodList :: Int -> IO MethodList
makeMethodList n = do
|
|
From: <cod...@go...> - 2008-12-06 12:31:36
|
Author: jam...@us...
Date: Sat Dec 6 04:27:17 2008
New Revision: 362
Modified:
branches/objc2/hoc/HOC/HOC/NewClass.hs
Log:
Removed now-unneeded defaultIvarSize definition and export from NewClass.hs
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Sat Dec 6 04:27:17 2008
@@ -9,7 +9,6 @@
setIvarInList,
setMethodInList,
makeDefaultIvarList,
- defaultIvarSize,
setHaskellRetainMethod,
setHaskellReleaseMethod,
setHaskellDataMethod
@@ -94,8 +93,6 @@
(fromIntegral $ sizeOf nullPtr)
(fromIntegral $ alignment nullPtr)
return list
-
-defaultIvarSize = 4 :: Int
retainSelector = getSelectorForName "retain"
retainCif = getCifForSelector (undefined :: ID () -> IO (ID ()))
|
|
From: <cod...@go...> - 2008-12-06 12:27:39
|
Author: jam...@us...
Date: Sat Dec 6 04:26:46 2008
New Revision: 361
Modified:
branches/objc2/hoc/HOC_cbits/NewClass.m
Log:
Cleaned up NewClass.m a bit after recent changes in objc2 branch
Modified: branches/objc2/hoc/HOC_cbits/NewClass.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.m (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.m Sat Dec 6 04:26:46 2008
@@ -34,7 +34,7 @@
struct objc_class * meta_class;
struct objc_class * new_class;
struct objc_class * root_class;
- int i;
+ int instance_size;
assert(objc_lookUpClass(name) == nil);
@@ -56,9 +56,9 @@
new_class->ivars = buildIndexedIvarList(
ivars,
super_class->instance_size,
- &new_class->instance_size);
+ &instance_size);
- new_class->instance_size += super_class->instance_size;
+ new_class->instance_size = super_class->instance_size + instance_size;
#ifdef GNUSTEP
new_class->super_class = (void*)(super_class->name);
|
|
From: <cod...@go...> - 2008-12-06 12:05:34
|
Author: jam...@us...
Date: Sat Dec 6 04:04:52 2008
New Revision: 360
Modified:
branches/objc2/hoc/HOC/HOC/NewClass.hs
branches/objc2/hoc/HOC_cbits/Exceptions.m
branches/objc2/hoc/HOC_cbits/Methods.h
branches/objc2/hoc/HOC_cbits/Methods.m
branches/objc2/hoc/HOC_cbits/NewClass.h
branches/objc2/hoc/HOC_cbits/NewClass.m
Log:
Confined all usage of objc_method_list and objc_method structs to Methods.h
and Methods.m in cbits.
On the Haskell side, MethodList is now a ForeignPtr rather than a Ptr.
Small changes were made to properly
handle that as well.
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Sat Dec 6 04:04:52 2008
@@ -28,27 +28,29 @@
type IMP = FFICif -> Ptr () -> Ptr (Ptr ()) -> IO (Ptr ObjCObject)
foreign import ccall "wrapper" wrapIMP :: IMP -> IO (FunPtr IMP)
-newtype MethodList = MethodList (Ptr MethodList)
+newtype MethodList = MethodList (ForeignPtr MethodList)
newtype IvarList = IvarList (ForeignPtr IvarList)
foreign import ccall "NewClass.h newClass"
c_newClass :: Ptr ObjCObject -> CString
-> Ptr IvarList
- -> MethodList -> MethodList
+ -> Ptr MethodList -> Ptr MethodList
-> IO ()
newClass :: Ptr ObjCObject -> CString
-> IvarList
-> MethodList -> MethodList
-> IO ()
-newClass sc name (IvarList ivars) ms cms =
- withForeignPtr ivars $ \ivars -> do
- c_newClass sc name ivars ms cms
+newClass sc name (IvarList ivars) (MethodList ms) (MethodList cms) =
+ withForeignPtr ivars $ \ivars ->
+ withForeignPtr ms $ \ms ->
+ withForeignPtr cms $ \cms -> do
+ c_newClass 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 ()
@@ -72,10 +74,17 @@
withForeignPtr ivars $ \ivars -> do
c_setIvarInList ivars n name ty sz align
-setMethodInList methodList idx sel typ cif imp = do
- typC <- newCString typ
- thunk <- wrapIMP imp
- rawSetMethodInList methodList idx sel typC cif thunk
+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
@@ -98,33 +107,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: branches/objc2/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Exceptions.m (original)
+++ branches/objc2/hoc/HOC_cbits/Exceptions.m Sat Dec 6 04:04:52 2008
@@ -40,20 +40,14 @@
{
if(!excWrapperInited)
{
- struct objc_method_list *methods = makeMethodList(1);
- struct objc_method_list *class_methods = makeMethodList(0);
+ 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, hsExceptionIvarName, "^v", sizeof(void *),
IVAR_PTR_ALIGN);
Modified: branches/objc2/hoc/HOC_cbits/Methods.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Methods.h (original)
+++ branches/objc2/hoc/HOC_cbits/Methods.h Sat Dec 6 04:04:52 2008
@@ -18,12 +18,36 @@
void **args
);
-struct objc_method_list * makeMethodList(int n);
+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 objc_method_list *list,
+ struct hoc_method_list *list,
int i,
SEL sel,
char *types, /* never deallocate this */
ffi_cif *cif, /* never deallocate this */
haskellIMP imp
);
+
+struct objc_method_list * convertMethodList(struct hoc_method_list * list);
\ No newline at end of file
Modified: branches/objc2/hoc/HOC_cbits/Methods.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Methods.m (original)
+++ branches/objc2/hoc/HOC_cbits/Methods.m Sat Dec 6 04:04:52 2008
@@ -22,23 +22,58 @@
return closure;
}
-struct objc_method_list * makeMethodList(int n)
+struct hoc_method_list * makeMethodList(int n)
{
- struct objc_method_list *list =
- calloc(1, sizeof(struct objc_method_list)
+ struct hoc_method_list *list =
+ calloc(1, sizeof(struct hoc_method_list)
+ (n-1) * sizeof(struct objc_method));
list->method_count = n;
return list;
}
void setMethodInList(
- struct objc_method_list *list,
+ 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;
+}
+
+/* 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);
@@ -46,5 +81,20 @@
list->method_list[i].method_name = sel;
#endif
list->method_list[i].method_types = types;
- list->method_list[i].method_imp = (IMP) newIMP(cif, imp);
+ 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;
+}
\ No newline at end of file
Modified: branches/objc2/hoc/HOC_cbits/NewClass.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.h (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.h Sat Dec 6 04:04:52 2008
@@ -5,10 +5,11 @@
#endif
struct hoc_ivar_list;
+struct hoc_method_list;
void newClass(struct objc_class * super_class,
const char * name, /* never
deallocate this */
struct hoc_ivar_list *ivars,
- struct objc_method_list *methods, /* never deallocate this */
- struct objc_method_list *class_methods); /* never deallocate this */
+ struct hoc_method_list *methods,
+ struct hoc_method_list *class_methods);
Modified: branches/objc2/hoc/HOC_cbits/NewClass.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.m (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.m Sat Dec 6 04:04:52 2008
@@ -3,6 +3,7 @@
#include <assert.h>
#include "Class.h"
#include "Ivars.h"
+#include "Methods.h"
#include "NewClass.h"
#ifdef GNUSTEP
@@ -27,8 +28,8 @@
void newClass(struct objc_class * super_class,
const char * name,
struct hoc_ivar_list *ivars,
- struct objc_method_list *methods,
- struct objc_method_list *class_methods)
+ struct hoc_method_list *methods,
+ struct hoc_method_list *class_methods)
{
struct objc_class * meta_class;
struct objc_class * new_class;
@@ -81,8 +82,8 @@
__objc_resolve_class_links();
}
- class_add_method_list(new_class, methods);
- class_add_method_list(meta_class, class_methods);
+ class_add_method_list(new_class, convertMethodList(methods));
+ class_add_method_list(meta_class, convertMethodList(class_methods));
#else
new_class->methodLists = calloc( 1, sizeof(struct objc_method_list *) );
meta_class->methodLists = calloc( 1, sizeof(struct objc_method_list *) );
@@ -95,8 +96,8 @@
objc_addClass( new_class );
- class_addMethods(new_class, methods);
- class_addMethods(meta_class, class_methods);
+ class_addMethods(new_class, convertMethodList(methods));
+ class_addMethods(meta_class, convertMethodList(class_methods));
#endif
}
|
|
From: <cod...@go...> - 2008-12-06 03:04:12
|
Author: jam...@us...
Date: Fri Dec 5 19:03:30 2008
New Revision: 359
Added:
branches/objc2/hoc/HOC_cbits/Methods.h
branches/objc2/hoc/HOC_cbits/Methods.m
Modified:
branches/objc2/hoc/HOC_cbits/Exceptions.m
branches/objc2/hoc/HOC_cbits/NewClass.h
branches/objc2/hoc/HOC_cbits/NewClass.m
Log:
Extracted existing method-related code to new files "Methods.m"
and "Methods.h" in HOC_cbits.
Modified: branches/objc2/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Exceptions.m (original)
+++ branches/objc2/hoc/HOC_cbits/Exceptions.m Fri Dec 5 19:03:30 2008
@@ -2,6 +2,7 @@
#include "NewClass.h"
#include "Class.h"
#include "Ivars.h"
+#include "Methods.h"
#include "Selector.h"
#include "Marshalling.h"
#include "HsFFI.h"
Added: branches/objc2/hoc/HOC_cbits/Methods.h
==============================================================================
--- (empty file)
+++ branches/objc2/hoc/HOC_cbits/Methods.h Fri Dec 5 19:03:30 2008
@@ -0,0 +1,29 @@
+#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 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
+ );
Added: branches/objc2/hoc/HOC_cbits/Methods.m
==============================================================================
--- (empty file)
+++ branches/objc2/hoc/HOC_cbits/Methods.m Fri Dec 5 19:03:30 2008
@@ -0,0 +1,50 @@
+#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 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;
+}
+
+void setMethodInList(
+ struct objc_method_list *list,
+ int i,
+ SEL sel,
+ char *types,
+ ffi_cif *cif,
+ haskellIMP 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) newIMP(cif, imp);
+}
Modified: branches/objc2/hoc/HOC_cbits/NewClass.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.h (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.h Fri Dec 5 19:03:30 2008
@@ -4,14 +4,6 @@
#include <objc/objc-runtime.h>
#endif
-#include <ffi.h>
-
-#ifdef __OBJC__
-@class NSException;
-#else
-typedef void NSException;
-#endif
-
struct hoc_ivar_list;
void newClass(struct objc_class * super_class,
@@ -20,18 +12,3 @@
struct objc_method_list *methods, /* never deallocate this */
struct objc_method_list *class_methods); /* never deallocate this */
-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
- );
Modified: branches/objc2/hoc/HOC_cbits/NewClass.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.m (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.m Fri Dec 5 19:03:30 2008
@@ -4,7 +4,6 @@
#include "Class.h"
#include "Ivars.h"
#include "NewClass.h"
-#include "Statistics.h"
#ifdef GNUSTEP
#define isa class_pointer
@@ -101,46 +100,3 @@
#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 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;
-}
-
-void setMethodInList(
- struct objc_method_list *list,
- int i,
- SEL sel,
- char *types,
- ffi_cif *cif,
- haskellIMP 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) newIMP(cif, imp);
-}
|
|
From: <cod...@go...> - 2008-12-05 22:40:48
|
Author: jam...@us...
Date: Fri Dec 5 13:29:52 2008
New Revision: 358
Added:
branches/objc2/hoc/HOC_cbits/Ivars.h
branches/objc2/hoc/HOC_cbits/Ivars.m
Modified:
branches/objc2/hoc/HOC/HOC/ExportClass.hs
branches/objc2/hoc/HOC/HOC/NewClass.hs
branches/objc2/hoc/HOC_cbits/Exceptions.m
branches/objc2/hoc/HOC_cbits/NewClass.h
branches/objc2/hoc/HOC_cbits/NewClass.m
Log:
Rough cut at separation of ivar lists in HOC from objc_ivar and
objc_ivar_list structs.
Modified: branches/objc2/hoc/HOC/HOC/ExportClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/ExportClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/ExportClass.hs Fri Dec 5 13:29:52 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: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Fri Dec 5 13:29:52 2008
@@ -22,20 +22,29 @@
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 IvarList = IvarList (ForeignPtr IvarList)
foreign import ccall "NewClass.h newClass"
- newClass :: Ptr ObjCObject -> CString
- -> Int -> IvarList
+ c_newClass :: Ptr ObjCObject -> CString
+ -> Ptr IvarList
-> MethodList -> MethodList
-> IO ()
+newClass :: Ptr ObjCObject -> CString
+ -> IvarList
+ -> MethodList -> MethodList
+ -> IO ()
+newClass sc name (IvarList ivars) ms cms =
+ withForeignPtr ivars $ \ivars -> do
+ c_newClass sc name ivars ms cms
+
foreign import ccall "NewClass.h makeMethodList"
makeMethodList :: Int -> IO MethodList
foreign import ccall "NewClass.h setMethodInList"
@@ -46,10 +55,22 @@
foreign import ccall "NewClass.h makeIvarList"
- makeIvarList :: Int -> IO IvarList
+ c_makeIvarList :: Int -> IO (Ptr IvarList)
foreign import ccall "NewClass.h setIvarInList"
- setIvarInList :: IvarList -> Int
- -> CString -> CString -> Int -> IO ()
+ c_setIvarInList :: Ptr IvarList -> Int
+ -> CString -> CString -> CSize -> Word8 -> IO ()
+
+makeIvarList :: Int -> IO IvarList
+makeIvarList n = do
+ ivars <- c_makeIvarList 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
+ c_setIvarInList ivars n name ty sz align
setMethodInList methodList idx sel typ cif imp = do
typC <- newCString typ
@@ -60,7 +81,9 @@
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
Modified: branches/objc2/hoc/HOC_cbits/Exceptions.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/Exceptions.m (original)
+++ branches/objc2/hoc/HOC_cbits/Exceptions.m Fri Dec 5 13:29:52 2008
@@ -1,10 +1,14 @@
#include <objc/objc.h>
#include "NewClass.h"
#include "Class.h"
+#include "Ivars.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;
@@ -37,7 +41,8 @@
{
struct objc_method_list *methods = makeMethodList(1);
struct objc_method_list *class_methods = makeMethodList(0);
- struct objc_ivar_list *ivars = makeIvarList(1);
+ struct hoc_ivar_list *ivars = makeIvarList(1);
+ struct objc_ivar *stablePtrIvar;
selDealloc = getSelectorForName("dealloc");
@@ -49,16 +54,17 @@
methods->method_list[0].method_types = "v@:";
methods->method_list[0].method_imp = (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);
+ #warning TODO - ivar_getOffset needs backport or workaround for
fact that offsets are no longer in the list
+ stablePtrOffset = ivar_getOffset(stablePtrIvar);
selExceptionWithNameReasonUserInfo =
getSelectorForName("exceptionWithName:reason:userInfo:");
Added: branches/objc2/hoc/HOC_cbits/Ivars.h
==============================================================================
--- (empty file)
+++ branches/objc2/hoc/HOC_cbits/Ivars.h Fri Dec 5 13:29:52 2008
@@ -0,0 +1,35 @@
+#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
+ );
+
+struct objc_ivar_list * buildIndexedIvarList(
+ struct hoc_ivar_list *list,
+ int start_offset,
+ int *instance_size /* out */
+ );
Added: branches/objc2/hoc/HOC_cbits/Ivars.m
==============================================================================
--- (empty file)
+++ branches/objc2/hoc/HOC_cbits/Ivars.m Fri Dec 5 13:29:52 2008
@@ -0,0 +1,90 @@
+#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;
+}
+
+/* Used to be makeIvarList in NewClass.m */
+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 */
+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;
+}
+
+#warning TODO - proofread buildIndexedIvarList
+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;
+}
+
Modified: branches/objc2/hoc/HOC_cbits/NewClass.h
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.h (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.h Fri Dec 5 13:29:52 2008
@@ -12,10 +12,11 @@
typedef void NSException;
#endif
+struct hoc_ivar_list;
+
void newClass(struct objc_class * super_class,
const char * name, /* never
deallocate this */
- int instance_size,
- struct objc_ivar_list *ivars, /* never deallocate this */
+ struct hoc_ivar_list *ivars,
struct objc_method_list *methods, /* never deallocate this */
struct objc_method_list *class_methods); /* never deallocate this */
@@ -33,13 +34,4 @@
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: branches/objc2/hoc/HOC_cbits/NewClass.m
==============================================================================
--- branches/objc2/hoc/HOC_cbits/NewClass.m (original)
+++ branches/objc2/hoc/HOC_cbits/NewClass.m Fri Dec 5 13:29:52 2008
@@ -2,6 +2,7 @@
#include <Foundation/NSException.h>
#include <assert.h>
#include "Class.h"
+#include "Ivars.h"
#include "NewClass.h"
#include "Statistics.h"
@@ -26,8 +27,7 @@
void newClass(struct objc_class * super_class,
const char * name,
- int instance_size,
- struct objc_ivar_list *ivars,
+ struct hoc_ivar_list *ivars,
struct objc_method_list *methods,
struct objc_method_list *class_methods)
{
@@ -53,12 +53,13 @@
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;
-
+ new_class->ivars = buildIndexedIvarList(
+ ivars,
+ super_class->instance_size,
+ &new_class->instance_size);
+
+ new_class->instance_size += super_class->instance_size;
+
#ifdef GNUSTEP
new_class->super_class = (void*)(super_class->name);
meta_class->super_class = (void*)(super_class->isa->name);
@@ -142,26 +143,4 @@
#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)
-{
- struct objc_ivar_list *list =
- calloc(1, sizeof(struct objc_ivar_list)
- + (n-1) * sizeof(struct objc_ivar));
- list->ivar_count = n;
- return list;
-}
-
-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;
}
|
|
From: <cod...@go...> - 2008-12-05 21:27:45
|
Author: jam...@us...
Date: Fri Dec 5 13:27:11 2008
New Revision: 357
Modified:
branches/objc2/hoc/HOC/HOC/Base.hs
Log:
Added a foreign import for "free" as freePtr :: FunPtr (Ptr a -> IO ())
Will be used in a ForeignPtr finalizer.
Modified: branches/objc2/hoc/HOC/HOC/Base.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Base.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Base.hs Fri Dec 5 13:27:11 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 ()
|
|
From: <cod...@go...> - 2008-12-05 20:48:31
|
Author: jam...@us...
Date: Fri Dec 5 12:44:44 2008
New Revision: 356
Added:
branches/objc2/hoc/
- copied from r355, /trunk/hoc/
Log:
Creating branch of HOC directory for experimentation with Objective C 2.0
runtime support and other changes in support of that transition.
|
|
From: <cod...@go...> - 2008-12-05 20:44:30
|
Author: jam...@us...
Date: Fri Dec 5 12:43:35 2008
New Revision: 355
Added:
branches/objc2/
Log:
Creating new branch for experimental Objective C 2.0 runtime support.
|
|
From: <cod...@go...> - 2008-11-04 22:39:11
|
Author: wol...@gm...
Date: Tue Nov 4 14:35:50 2008
New Revision: 354
Modified:
trunk/hoc/Tests/MiniFoundation.hs
trunk/hoc/Tests/TestFFI.hs
Log:
more missing {-# LANGUAGE #-} pragmas
Modified: trunk/hoc/Tests/MiniFoundation.hs
==============================================================================
--- trunk/hoc/Tests/MiniFoundation.hs (original)
+++ trunk/hoc/Tests/MiniFoundation.hs Tue Nov 4 14:35:50 2008
@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell, StandaloneDeriving, MultiParamTypeClasses,
+ TypeSynonymInstances, FlexibleInstances, RankNTypes #-}
module MiniFoundation where
import HOC
Modified: trunk/hoc/Tests/TestFFI.hs
==============================================================================
--- trunk/hoc/Tests/TestFFI.hs (original)
+++ trunk/hoc/Tests/TestFFI.hs Tue Nov 4 14:35:50 2008
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ForeignFunctionInterface, RankNTypes #-}
module TestFFI where
import HOC.FFICallInterface
|
|
From: <cod...@go...> - 2008-11-04 22:35:10
|
Author: wol...@gm...
Date: Tue Nov 4 14:34:03 2008
New Revision: 353
Modified:
trunk/hoc/HOC.cabal
trunk/hoc/Setup.hs
Log:
Try to figure out GNUstep paths
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Tue Nov 4 14:34:03 2008
@@ -58,7 +58,7 @@
frameworks: Foundation
cpp-options: -DMACOSX
else
- extra-lib-dirs: /usr/lib/gcc/i486-linux-gnu/4.1.3/,
/usr/lib/GNUstep/System/Library/Libraries
+ -- paths are inserted by Setup.hs
extra-libraries: gnustep-base
cpp-options: -DGNUSTEP
@@ -89,6 +89,5 @@
frameworks: Foundation
cpp-options: -DMACOSX
else
- extra-lib-dirs: /usr/lib/gcc/i486-linux-gnu/4.1.3/,
/usr/lib/GNUstep/System/Library/Libraries
extra-libraries: gnustep-base
cpp-options: -DGNUSTEP
Modified: trunk/hoc/Setup.hs
==============================================================================
--- trunk/hoc/Setup.hs (original)
+++ trunk/hoc/Setup.hs Tue Nov 4 14:34:03 2008
@@ -15,18 +15,31 @@
confHook = customConfig,
preBuild = customPreBuild
}
-
-gnustepPaths :: IO (String, String)
-gnustepPaths = do
- (inp,out,err,pid) <- runInteractiveCommand "gcc
--print-libgcc-file-name"
+
+backquote :: String -> IO String
+backquote cmd = do
+ (inp,out,err,pid) <- runInteractiveCommand cmd
hClose inp
- libgcc <- hGetContents out
+ text <- hGetContents out
waitForProcess pid
hClose err
+ return $ init text ++ let c = last text in if c == '\n' then [] else
[c]
+
+gnustepPaths :: IO (String, String, String)
+gnustepPaths = do
+ libgcc <- backquote "gcc --print-libgcc-file-name"
+ headersAndLibraries <- backquote
+ "opentool /bin/sh -c \
+ \'. $GNUSTEP_MAKEFILES/filesystem.sh \
+ \; echo $GNUSTEP_SYSTEM_HEADERS ; echo
$GNUSTEP_SYSTEM_LIBRARIES'"
+
let gcclibdir = takeDirectory libgcc
- sysroot <- getEnv "GNUSTEP_SYSTEM_ROOT"
- return (gcclibdir, sysroot)
+ let system_headers : system_libs : _ = lines headersAndLibraries
+ -- sysroot <- getEnv "GNUSTEP_SYSTEM_ROOT"
+ -- let system_headers = gnustepsysroot </> "Library/Headers"
+ -- system_libs = gnustepsysroot </> "Library/Libraries"
+ return (gcclibdir, system_libs, system_headers)
customConfig :: (Either GenericPackageDescription PackageDescription,
HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo
customConfig pdbi cf = do
@@ -34,8 +47,8 @@
if System.Info.os == "darwin"
then return()
else do
- (gcclibdir, gnustepsysroot) <- gnustepPaths
- writeFile "HOC.buildinfo" $ "extra-lib-dirs: " ++ gcclibdir
++ ", " ++ gnustepsysroot </> "Library/Headers" ++ "\n"
+ (gcclibdir, system_libs, system_headers) <- gnustepPaths
+ writeFile "HOC.buildinfo" $ "extra-lib-dirs: " ++ gcclibdir
++ ", " ++ system_libs ++ "\n"
return lbi
@@ -49,11 +62,12 @@
then do
return ("-I/usr/include/ffi -DMACOSX", [], ["-framework
Foundation"])
else do
- (gcclibdir, sysroot) <- gnustepPaths
- return ("-I$GNUSTEP_SYSTEM_ROOT/Library/Headers -DGNUSTEP",
- ["-L" ++ gcclibdir, "-L" ++ sysroot
</> "Library/Libraries"],
+ (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"])
-
+
exitCode <- system $ "gcc -r -nostdlib -I`ghc --print-libdir`/include "
++ cflags ++ " HOC_cbits/*.m -o dist/build/HOC_cbits.o"
|
|
From: <cod...@go...> - 2008-11-01 13:13:07
|
Author: wol...@gm...
Date: Sat Nov 1 06:12:45 2008
New Revision: 352
Modified:
trunk/hoc/HOC/HOC/CEnum.hs
trunk/hoc/HOC/HOC/DeclareClass.hs
trunk/hoc/HOC/HOC/Selectors.hs
Log:
some more missing {-# LANGUAGE #-} pragmas
Modified: trunk/hoc/HOC/HOC/CEnum.hs
==============================================================================
--- trunk/hoc/HOC/HOC/CEnum.hs (original)
+++ trunk/hoc/HOC/HOC/CEnum.hs Sat Nov 1 06:12:45 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell, RankNTypes #-}
module HOC.CEnum(CEnum(fromCEnum, toCEnum), declareCEnum,
declareAnonymousCEnum)
where
Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs Sat Nov 1 06:12:45 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
module HOC.DeclareClass(declareClass) where
import HOC.Base
Modified: trunk/hoc/HOC/HOC/Selectors.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Selectors.hs (original)
+++ trunk/hoc/HOC/HOC/Selectors.hs Sat Nov 1 06:12:45 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
module HOC.Selectors where
import HOC.TH
|
|
From: <cod...@go...> - 2008-11-01 12:14:08
|
Author: wol...@gm...
Date: Sat Nov 1 04:35:14 2008
New Revision: 351
Added:
trunk/hoc/Tests/MiniFoundation.hs
Modified:
trunk/hoc/Tests/Test.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
change TestFoundation to run as past of hoc-test (without relying on
generated interfaces)
Added: trunk/hoc/Tests/MiniFoundation.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/MiniFoundation.hs Sat Nov 1 04:35:14 2008
@@ -0,0 +1,131 @@
+{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}
+module MiniFoundation where
+
+import HOC
+import HOC.Exception ( WrappedNSException(..) )
+
+import Foreign.C.Types
+import Control.Exception ( catchDyn )
+import System.IO.Unsafe ( unsafePerformIO )
+
+$(declareClass "NSObject" "ID")
+$(declareClass "NSString" "NSObject")
+$(declareClass "NSException" "NSObject")
+$(declareClass "NSValue" "NSObject")
+$(declareClass "NSNumber" "NSValue")
+$(declareClass "NSArray" "NSObject")
+$(declareClass "NSMutableArray" "NSArray")
+$(declareClass "NSDictionary" "NSObject")
+
+$(declareCStructWithTag "NSPoint" (Prelude.Just "_NSPoint") [[t| Float |
],[t| Float |]])
+$(declareCStructWithTag "NSSize" (Prelude.Just "_NSSize") [[t| Float |
],[t| Float |]])
+$(declareCStructWithTag "NSRect" (Prelude.Just "_NSRect") [[t| NSPoint |
],[t| NSSize |]])
+
+-- NSObject selectors
+$(declareSelector "description" [t| IO (NSString ()) |])
+$(declareSelector "init" [t| IO Inited |])
+$(declareSelector "alloc" [t| IO Allocated |])
+
+instance Has_init (NSObject a)
+instance Has_description (NSObject a)
+instance Has_alloc (NSObjectClass a)
+
+-- NSString selectors
+$(declareRenamedSelector "length" "nslength" [t| IO CUInt |])
+$(declareSelector "initWithContentsOfFile:" [t| forall a . NSString a ->
IO Inited |])
+
+instance Has_nslength (NSString a)
+instance Has_initWithContentsOfFile (NSString a)
+
+-- NSValue selectors
+
+$(declareSelector "initWithChar:" [t| CChar -> IO Inited |])
+$(declareSelector "initWithShort:" [t| CShort -> IO Inited |])
+$(declareSelector "initWithInt:" [t| CInt -> IO Inited |])
+$(declareSelector "initWithLongLong:" [t| CLLong -> IO Inited |])
+$(declareSelector "initWithFloat:" [t| Float -> IO Inited |])
+$(declareSelector "initWithDouble:" [t| Double -> IO Inited |])
+$(declareSelector "initWithBool:" [t| Bool -> IO Inited |])
+
+$(declareSelector "numberWithInt:" [t| CInt -> IO (NSNumber ()) |])
+
+$(declareSelector "charValue" [t| IO CChar |])
+$(declareSelector "shortValue" [t| IO CShort |])
+$(declareSelector "longLongValue" [t| IO CLLong |])
+$(declareSelector "boolValue" [t| IO Bool |])
+$(declareSelector "floatValue" [t| IO Float |])
+$(declareSelector "doubleValue" [t| IO Float |])
+$(declareSelector "intValue" [t| IO CInt |])
+
+$(declareSelector "valueWithPoint:" [t| NSPoint -> IO (NSValue ()) |])
+$(declareSelector "valueWithSize:" [t| NSSize -> IO (NSValue ()) |])
+$(declareSelector "valueWithRect:" [t| NSRect -> IO (NSValue ()) |])
+$(declareSelector "pointValue" [t| IO NSPoint |])
+$(declareSelector "sizeValue" [t| IO NSSize |])
+$(declareSelector "rectValue" [t| IO NSRect |])
+
+instance Has_initWithChar (NSNumber a)
+instance Has_initWithShort (NSNumber a)
+instance Has_initWithInt (NSNumber a)
+instance Has_initWithLongLong (NSNumber a)
+instance Has_initWithFloat (NSNumber a)
+instance Has_initWithDouble (NSNumber a)
+instance Has_initWithBool (NSNumber a)
+
+instance Has_numberWithInt (NSNumberClass a)
+
+instance Has_charValue (NSNumber a)
+instance Has_shortValue (NSNumber a)
+instance Has_intValue (NSNumber a)
+instance Has_longLongValue (NSNumber a)
+instance Has_floatValue (NSNumber a)
+instance Has_doubleValue (NSNumber a)
+instance Has_boolValue (NSNumber a)
+
+instance Has_valueWithPoint (NSValueClass a)
+instance Has_valueWithSize (NSValueClass a)
+instance Has_valueWithRect (NSValueClass a)
+instance Has_pointValue (NSValue a)
+instance Has_sizeValue (NSValue a)
+instance Has_rectValue (NSValue a)
+
+$(declareExternFun "NSStringFromSize" [t| NSSize -> IO (NSString ()) |])
+
+-- NSException
+
+$(declareRenamedSelector "exceptionWithName:reason:userInfo:"
+ "exceptionWithNameReasonUserInfo"
+ [t| forall t1 t2 t3 . NSString t1 -> NSString t2 -> NSDictionary t3 ->
IO (NSException ()) |])
+$(declareSelector "name" [t| IO (NSString ()) |])
+$(declareSelector "raise" [t| IO () |])
+
+instance Has_exceptionWithNameReasonUserInfo (NSExceptionClass a)
+instance Has_name (NSException a)
+instance Has_raise (NSException a)
+
+$(declareExternConst "NSParseErrorException" [t| NSString () |])
+
+
+catchNS :: IO a -> (NSException () -> IO a) -> IO a
+
+catchNS action handler
+ = action `catchDyn` \(WrappedNSException exc) -> handler (castObject
exc)
+
+-- NSMutableArray
+
+$(declareSelector "addObject:" [t| forall t1 . ID t1 -> IO () |])
+
+instance Has_addObject (NSMutableArray a)
+
+deriving instance Show NSRect
+deriving instance Show NSPoint
+deriving instance Show NSSize
+
+haskellString :: NSString a -> IO String
+nsString :: String -> IO (NSString ())
+haskellString nsstr = withExportedArgument nsstr importArgument
+nsString nsstr = withExportedArgument nsstr importArgument
+toNSString :: String -> NSString ()
+toNSString = unsafePerformIO . nsString
+fromNSString :: NSString () -> String
+fromNSString = unsafePerformIO . haskellString
Modified: trunk/hoc/Tests/Test.hs
==============================================================================
--- trunk/hoc/Tests/Test.hs (original)
+++ trunk/hoc/Tests/Test.hs Sat Nov 1 04:35:14 2008
@@ -2,10 +2,14 @@
import qualified TestFFI
import qualified TestPreprocessor
+import qualified TestFoundation
import Test.HUnit
-main = runTestTT $ test [
+import HOC.Base( withAutoreleasePool )
+
+main = withAutoreleasePool $ runTestTT $ test [
TestFFI.tests,
- TestPreprocessor.tests
+ TestPreprocessor.tests,
+ TestFoundation.tests
]
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Sat Nov 1 04:35:14 2008
@@ -1,20 +1,23 @@
{-# OPTIONS -fth -fglasgow-exts #-}
-module Main where
+module TestFoundation where
+
+import HOC
import Test.HUnit
import Prelude hiding(init)
-import Foundation hiding(test)
-import Foundation.NSObject(init)
+-- import Foundation hiding(test)
+-- import Foundation.NSObject(init)
+
+import Foreign.C.Types
import System.Mem ( performGC )
import Control.Concurrent ( threadDelay )
import Control.Monad ( when )
-import Control.Exception ( try, finally )
+import Control.Exception ( try, finally, catchDyn )
import qualified System.Info( os )
-deriving instance Show NSRect
-deriving instance Show NSPoint
-deriving instance Show NSSize
+
+import MiniFoundation
-- garbage collect and make really sure that finalizers have time to
run
performGCAndWait targetCount time maxRepeat = do
@@ -36,6 +39,7 @@
assertNoLeaks action = assertLeaks 0 action
+
$(declareClass "HaskellObjectWithOutlet" "NSObject")
$(declareSelector "otherObject" [t| IO (ID ()) |])
@@ -151,7 +155,7 @@
actual @?= zhongwen
),
"length" ~: (assertNoLeaks $ do
- actual <- nsString zhongwen >>= Foundation.length
+ actual <- nsString zhongwen >>= nslength
actual @?= 2
),
"nsString-haskellString-fermata" ~: (assertNoLeaks $ do
@@ -159,11 +163,17 @@
actual @?= fermata
),
"length-fermata" ~: (assertNoLeaks $ do
- actual <- nsString fermata >>= Foundation.length
+ actual <- nsString fermata >>= nslength
actual @?= 2 -- yes, 2. NSString uses UTF-16.
)
]
],
+ "initializeClasses" ~: do
+ initializeClass_HaskellObjectWithOutlet
+ initializeClass_HaskellObjectWithDescription
+ initializeClass_HaskellObjectWithIVar
+ initializeClass_ExceptionThrower,
+
"HaskellObjectWithOutlet" ~: test [
"alloc-init" ~: (assertNoLeaks $ do
_HaskellObjectWithOutlet # alloc >>= init >> return ()
@@ -196,14 +206,14 @@
],
"Memory" ~: test [
"NSMutableArray-Circle" ~: (assertNoLeaks $ do
- array1 <- _NSMutableArray # alloc >>=
Foundation.NSObject.init
- array2 <- _NSMutableArray # alloc >>=
Foundation.NSObject.init
+ array1 <- _NSMutableArray # alloc >>= init
+ array2 <- _NSMutableArray # alloc >>= init
array1 # addObject array2
array2 # addObject array1
),
"NSMutableArray-Circle-with-Haskell" ~: (assertLeaks 2 $ do
hobj <- _HaskellObjectWithOutlet # alloc >>= init
- array <- _NSMutableArray # alloc >>=
Foundation.NSObject.init
+ array <- _NSMutableArray # alloc >>= init
array # addObject hobj
hobj # setOtherObject array
),
@@ -283,11 +293,3 @@
]
]
-go = withAutoreleasePool $ runTestTT tests
-
-main = do
- initializeClass_HaskellObjectWithOutlet
- initializeClass_HaskellObjectWithDescription
- initializeClass_HaskellObjectWithIVar
- initializeClass_ExceptionThrower
- go
|
|
From: <cod...@go...> - 2008-11-01 12:05:42
|
Author: wol...@gm...
Date: Sat Nov 1 04:30:59 2008
New Revision: 349
Modified:
trunk/hoc/HOC.cabal
Log:
don't enable language extensions globally
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Sat Nov 1 04:30:59 2008
@@ -52,11 +52,6 @@
HOC.CStruct
hs-source-dirs: HOC
- extensions: MagicHash, TemplateHaskell,
- ForeignFunctionInterface, GeneralizedNewtypeDeriving,
- EmptyDataDecls, MultiParamTypeClasses,
FunctionalDependencies,
- ScopedTypeVariables, RecursiveDo, FlexibleContexts,
- FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable
extra-libraries: objc, ffi
if os(darwin)
@@ -88,14 +83,7 @@
if !flag(Tests)
buildable: False
-
- extensions: MagicHash, TemplateHaskell,
- ForeignFunctionInterface, GeneralizedNewtypeDeriving,
- EmptyDataDecls, MultiParamTypeClasses,
FunctionalDependencies,
- ScopedTypeVariables, RecursiveDo, FlexibleContexts,
- FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable
-
-
+
extra-libraries: objc, ffi
if os(darwin)
frameworks: Foundation
|
|
From: <cod...@go...> - 2008-11-01 11:57:47
|
Author: wol...@gm...
Date: Sat Nov 1 04:33:08 2008
New Revision: 350
Modified:
trunk/hoc/HOC/HOC/Invocation.hs
Log:
add missing {-# LANGUAGE #-} pragma
Modified: trunk/hoc/HOC/HOC/Invocation.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Invocation.hs (original)
+++ trunk/hoc/HOC/HOC/Invocation.hs Sat Nov 1 04:33:08 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
module HOC.Invocation where
import Foreign
|
|
From: <cod...@go...> - 2008-11-01 11:29:29
|
Author: wol...@gm...
Date: Sat Nov 1 04:27:26 2008
New Revision: 348
Modified:
trunk/hoc/Bindings/AdditionalCode/AppKit/NSApplication.hs
trunk/hoc/HOC/HOC/Arguments.hs
trunk/hoc/HOC/HOC/Base.hs
trunk/hoc/HOC/HOC/CannedCIFs.hs
trunk/hoc/HOC/HOC/Class.hs
trunk/hoc/HOC/HOC/DeclareSelector.hs
trunk/hoc/HOC/HOC/Dyld.hs
trunk/hoc/HOC/HOC/Exception.hs
trunk/hoc/HOC/HOC/ExportClass.hs
trunk/hoc/HOC/HOC/ExternConstants.hs
trunk/hoc/HOC/HOC/ExternFunctions.hs
trunk/hoc/HOC/HOC/FFICallInterface.hs
trunk/hoc/HOC/HOC/ID.hs
trunk/hoc/HOC/HOC/MessageTarget.hs
trunk/hoc/HOC/HOC/MsgSend.hs
trunk/hoc/HOC/HOC/NewClass.hs
trunk/hoc/HOC/HOC/NewlyAllocated.hs
trunk/hoc/HOC/HOC/SelectorMarshaller.hs
trunk/hoc/HOC/HOC/StdArgumentTypes.hs
trunk/hoc/HOC/HOC/Super.hs
trunk/hoc/HOC/HOC/TH.hs
trunk/hoc/HOC/HOC/Utilities.hs
trunk/hoc/InterfaceGenerator/Enums.hs
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
trunk/hoc/Tests/TestPreprocessor.hs
Log:
Cleanup whitespace (remove tabs)
Use {-# LANGUAGE #-} in individual files instead of
gobally enabling tons of extensions
Modified: trunk/hoc/Bindings/AdditionalCode/AppKit/NSApplication.hs
==============================================================================
--- trunk/hoc/Bindings/AdditionalCode/AppKit/NSApplication.hs (original)
+++ trunk/hoc/Bindings/AdditionalCode/AppKit/NSApplication.hs Sat Nov 1
04:27:26 2008
@@ -8,12 +8,12 @@
-- CUT HERE
foreign import ccall "NSApplicationMain" c_nsApplicationMain
- :: CInt -> Ptr CString -> IO CInt
+ :: CInt -> Ptr CString -> IO CInt
nsApplicationMain2 prog args =
- withMany withCString (prog : args) $ \argvPtrs ->
- withArray0 nullPtr argvPtrs $ \argvBuf ->
- c_nsApplicationMain (1 + (fromIntegral $ length args)) argvBuf
+ withMany withCString (prog : args) $ \argvPtrs ->
+ withArray0 nullPtr argvPtrs $ \argvBuf ->
+ c_nsApplicationMain (1 + (fromIntegral $ length args)) argvBuf
nsApplicationMain_ = do
prog <- getProgName
Modified: trunk/hoc/HOC/HOC/Arguments.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Arguments.hs (original)
+++ trunk/hoc/HOC/HOC/Arguments.hs Sat Nov 1 04:27:26 2008
@@ -1,4 +1,6 @@
-{-# OPTIONS -fallow-undecidable-instances #-}
+{-# LANGUAGE TemplateHaskell, EmptyDataDecls,
+ MultiParamTypeClasses, FunctionalDependencies,
+ UndecidableInstances, ScopedTypeVariables #-}
module HOC.Arguments where
import HOC.Base
Modified: trunk/hoc/HOC/HOC/Base.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Base.hs (original)
+++ trunk/hoc/HOC/HOC/Base.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls,
GeneralizedNewtypeDeriving #-}
module HOC.Base where
import Foreign
@@ -37,24 +38,3 @@
--
data ObjCObject
-
-{-
-newtype ID a = ID (ForeignPtr ObjCObject)
-
-{- moved to Arguments.hs
-class Object a where
- toID :: a -> ID ()
-
-instance Object (ID a) where
- toID (ID a) = ID a
--}
-
-castObject (ID a) = ID a
-
-instance Eq (ID a) where
- (ID a) == (ID b) = a == b
--}
-
---
-
-
Modified: trunk/hoc/HOC/HOC/CannedCIFs.hs
==============================================================================
--- trunk/hoc/HOC/HOC/CannedCIFs.hs (original)
+++ trunk/hoc/HOC/HOC/CannedCIFs.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
module HOC.CannedCIFs where
import HOC.Base ( SEL )
Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs (original)
+++ trunk/hoc/HOC/HOC/Class.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,6 @@
+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls,
+ MultiParamTypeClasses, FunctionalDependencies,
+ TypeSynonymInstances #-}
module HOC.Class where
import HOC.Base
@@ -18,13 +21,13 @@
foreign import ccall unsafe "Class.h getClassByName"
- c_getClassByName :: CString -> IO (Ptr ObjCObject)
-
+ c_getClassByName :: CString -> IO (Ptr ObjCObject)
+
getClassByName name = withCString name c_getClassByName
-
+
{-# NOINLINE unsafeGetClassObject #-} -- called from generated code, save
space
unsafeGetClassObject name = unsafePerformIO $
- getClassByName name >>= importImmortal
+ getClassByName name >>= importImmortal
Modified: trunk/hoc/HOC/HOC/DeclareSelector.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareSelector.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareSelector.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell, EmptyDataDecls #-}
module HOC.DeclareSelector where
import HOC.Base
@@ -248,8 +249,8 @@
-- $(infoName) = ...
valD (varP $ mkName $ infoName) (normalB
[|
- let n = $(stringE name)
- in $(selInfoMaker) n
+ let n = $(stringE name)
+ in $(selInfoMaker) n
$(if haskellName == name
then [|n|]
else stringE
haskellName)
@@ -280,7 +281,7 @@
else valD (varP $ mkName haskellName) (normalB [|
$(varE $
marshallerName nArgs isUnit
`fromSameModuleAs_v`
- 'marshallersUpTo
+ 'marshallersUpTo
)
$(varE $ mkName infoName)
|]) []
Modified: trunk/hoc/HOC/HOC/Dyld.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Dyld.hs (original)
+++ trunk/hoc/HOC/HOC/Dyld.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash #-}
module HOC.Dyld(
lookupSymbol,
lookupSymbol#
Modified: trunk/hoc/HOC/HOC/Exception.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Exception.hs (original)
+++ trunk/hoc/HOC/HOC/Exception.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
module HOC.Exception where
import Data.Typeable
Modified: trunk/hoc/HOC/HOC/ExportClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/ExportClass.hs (original)
+++ trunk/hoc/HOC/HOC/ExportClass.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses,
FunctionalDependencies #-}
module HOC.ExportClass where
import Foreign
@@ -60,11 +61,11 @@
exportClass :: String -- ^ Name of class you're exporting,
e.g. "MyDocument"
-> String -- ^ A prefix for function names which are methods
- -- belonging to this class, e.g. "md_"
- -> [ClassMember] -- ^ A list of class members, such as outlets
- -- and instance variables
- -> Q [Dec] -- ^ A Haskell declaration, which can be spliced in
- -- with Template Haskell's $(...) syntax
+ -- belonging to this class, e.g. "md_"
+ -> [ClassMember] -- ^ A list of class members, such as outlets
+ -- and instance variables
+ -> Q [Dec] -- ^ A Haskell declaration, which can be spliced in
+ -- with Template Haskell's $(...) syntax
exportClass name prefix members = sequence $ [
sigD (mkName exportFunName) [t| IO () |],
valD (varP $ mkName exportFunName)
Modified: trunk/hoc/HOC/HOC/ExternConstants.hs
==============================================================================
--- trunk/hoc/HOC/HOC/ExternConstants.hs (original)
+++ trunk/hoc/HOC/HOC/ExternConstants.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell, MagicHash #-}
module HOC.ExternConstants(declareExternConst) where
import HOC.TH
@@ -10,20 +11,20 @@
declareExternConst :: String -> TypeQ -> Q [Dec]
declareExternConst name typ
- = sequence [
- sigD n typ,
- valD (varP n) (normalB expr) []
- ]
- where
- n = mkName $ nameToLowercase name
- expr = [| getGlobalVar $(stringE name) |]
+ = sequence [
+ sigD n typ,
+ valD (varP n) (normalB expr) []
+ ]
+ where
+ n = mkName $ nameToLowercase name
+ expr = [| getGlobalVar $(stringE name) |]
getGlobalVar name = unsafePerformIO $
- lookupSymbol name
- >>= peek . castFunPtrToPtr
- >>= importArgument
+ lookupSymbol name
+ >>= peek . castFunPtrToPtr
+ >>= importArgument
getGlobalVar# name# = unsafePerformIO $
- lookupSymbol# name#
- >>= peek . castFunPtrToPtr
- >>= importArgument
\ No newline at end of file
+ lookupSymbol# name#
+ >>= peek . castFunPtrToPtr
+ >>= importArgument
\ No newline at end of file
Modified: trunk/hoc/HOC/HOC/ExternFunctions.hs
==============================================================================
--- trunk/hoc/HOC/HOC/ExternFunctions.hs (original)
+++ trunk/hoc/HOC/HOC/ExternFunctions.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
module HOC.ExternFunctions(declareExternFun) where
import HOC.TH
Modified: trunk/hoc/HOC/HOC/FFICallInterface.hs
==============================================================================
--- trunk/hoc/HOC/HOC/FFICallInterface.hs (original)
+++ trunk/hoc/HOC/HOC/FFICallInterface.hs Sat Nov 1 04:27:26 2008
@@ -1,11 +1,12 @@
+{-# LANGUAGE ForeignFunctionInterface, FlexibleContexts,
GeneralizedNewtypeDeriving #-}
module HOC.FFICallInterface(
- FFICif,
- FFIType,
- FFITypeable(..),
- ffiPrepCif,
- makeStructType,
- cifIsStret
- ) where
+ FFICif,
+ FFIType,
+ FFITypeable(..),
+ ffiPrepCif,
+ makeStructType,
+ cifIsStret
+ ) where
import Foreign.C.Types
import Foreign
@@ -73,11 +74,11 @@
foreign import ccall unsafe cifIsStret :: FFICif -> IO CInt
promotedPeek p
- = peek (castPtr p :: Ptr CLong) >>= return . fromIntegral
- where
- size = sizeOf (pointee p)
- pointee :: Ptr p -> p
- pointee = undefined
+ = peek (castPtr p :: Ptr CLong) >>= return . fromIntegral
+ where
+ size = sizeOf (pointee p)
+ pointee :: Ptr p -> p
+ pointee = undefined
promotedAlloca f = alloca (\intPtr -> f $ castPtr (intPtr :: Ptr CLong))
@@ -104,7 +105,7 @@
instance FFITypeable Int32 where
makeFFIType _ = return ffi_type_sint32
- peekRetval = promotedPeek -- only takes effect on 64-bit
+ peekRetval = promotedPeek -- only takes effect on 64-bit
allocaRetval = promotedAlloca
instance FFITypeable Int64 where
@@ -125,7 +126,7 @@
instance FFITypeable Word32 where
makeFFIType _ = return ffi_type_uint32
- peekRetval = promotedPeek -- only takes effect on 64-bit
+ peekRetval = promotedPeek -- only takes effect on 64-bit
allocaRetval = promotedAlloca
instance FFITypeable Word64 where
Modified: trunk/hoc/HOC/HOC/ID.hs
==============================================================================
--- trunk/hoc/HOC/HOC/ID.hs (original)
+++ trunk/hoc/HOC/HOC/ID.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,5 @@
+{-# LANGUAGE ForeignFunctionInterface, RecursiveDo,
+ MultiParamTypeClasses, FlexibleInstances #-}
module HOC.ID where
import HOC.Base
Modified: trunk/hoc/HOC/HOC/MessageTarget.hs
==============================================================================
--- trunk/hoc/HOC/HOC/MessageTarget.hs (original)
+++ trunk/hoc/HOC/HOC/MessageTarget.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
module HOC.MessageTarget where
import HOC.Base
Modified: trunk/hoc/HOC/HOC/MsgSend.hs
==============================================================================
--- trunk/hoc/HOC/HOC/MsgSend.hs (original)
+++ trunk/hoc/HOC/HOC/MsgSend.hs Sat Nov 1 04:27:26 2008
@@ -1,4 +1,4 @@
-{-# OPTIONS -cpp #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module HOC.MsgSend(
objSendMessageWithRetval,
objSendMessageWithoutRetval,
@@ -15,24 +15,24 @@
import Control.Monad.Fix(mfix)
objSendMessageWithRetval
- :: ObjCArgument a b
+ :: ObjCArgument a b
=> FFICif
-> Ptr (Ptr ())
-> IO a
objSendMessageWithoutRetval
- :: FFICif
+ :: FFICif
-> Ptr (Ptr ())
-> IO ()
superSendMessageWithRetval
- :: ObjCArgument a b
+ :: ObjCArgument a b
=> FFICif
-> Ptr (Ptr ())
-> IO a
superSendMessageWithoutRetval
- :: FFICif
+ :: FFICif
-> Ptr (Ptr ())
-> IO ()
@@ -65,9 +65,9 @@
#else
- -- the type signatures are essentially bogus
- -- the return value is not necessarily (), and might even be a struct.
- -- we only call them via libffi, so we couldn't care less.
+ -- the type signatures are essentially bogus
+ -- the return value is not necessarily (), and might even be a struct.
+ -- we only call them via libffi, so we couldn't care less.
foreign import ccall "MsgSend.h &objc_msgSend"
objc_msgSendPtr :: FunPtr (Ptr ObjCObject -> SEL -> IO ())
foreign import ccall "MsgSend.h &objc_msgSend_stret"
@@ -82,22 +82,22 @@
withMarshalledDummy action = action undefined
objSendMessageWithRetval cif args =
- withMarshalledDummy $ \dummy ->
- cifIsStret cif >>= \isStret ->
- callWithRetval cif (if isStret /= 0
+ withMarshalledDummy $ \dummy ->
+ cifIsStret cif >>= \isStret ->
+ callWithRetval cif (if isStret /= 0
then objc_msgSend_stretPtr
- else objc_msgSendPtr) args
+ else objc_msgSendPtr) args
objSendMessageWithoutRetval cif args =
callWithoutRetval cif objc_msgSendPtr args
superSendMessageWithRetval cif args =
- withMarshalledDummy $ \dummy ->
- cifIsStret cif >>= \isStret ->
- callWithRetval cif (if isStret /= 0
+ withMarshalledDummy $ \dummy ->
+ cifIsStret cif >>= \isStret ->
+ callWithRetval cif (if isStret /= 0
then objc_msgSendSuper_stretPtr
- else objc_msgSendSuperPtr) args
+ else objc_msgSendSuperPtr) args
superSendMessageWithoutRetval cif args =
callWithoutRetval cif objc_msgSendSuperPtr args
Modified: trunk/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewClass.hs (original)
+++ trunk/hoc/HOC/HOC/NewClass.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
module HOC.NewClass(
IMP,
MethodList,
Modified: trunk/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewlyAllocated.hs (original)
+++ trunk/hoc/HOC/HOC/NewlyAllocated.hs Sat Nov 1 04:27:26 2008
@@ -1,4 +1,4 @@
-{-# OPTIONS -fallow-undecidable-instances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
UndecidableInstances #-}
module HOC.NewlyAllocated where
{-
Modified: trunk/hoc/HOC/HOC/SelectorMarshaller.hs
==============================================================================
--- trunk/hoc/HOC/HOC/SelectorMarshaller.hs (original)
+++ trunk/hoc/HOC/HOC/SelectorMarshaller.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE MagicHash, TemplateHaskell #-}
module HOC.SelectorMarshaller(
SelectorInfo(..),
mkSelectorInfo,
@@ -19,7 +20,7 @@
import Foreign ( withArray, Ptr, nullPtr )
import System.IO.Unsafe ( unsafePerformIO )
-import GHC.Base ( unpackCString# )
+import GHC.Base ( unpackCString# )
import HOC.TH
@@ -33,38 +34,38 @@
{-# NOINLINE mkSelectorInfo #-}
mkSelectorInfo objCName hsName cif
- = SelectorInfo objCName hsName cif (getSelectorForName objCName) False
+ = SelectorInfo objCName hsName cif (getSelectorForName objCName) False
{-# NOINLINE mkSelectorInfo# #-}
mkSelectorInfo# objCName# hsName# cif
- -- NOTE: Don't call mkSelectorInfo here, the rule would apply!
- = SelectorInfo objCName hsName cif (getSelectorForName objCName) False
- where
- objCName = unpackCString# objCName#
- hsName = unpackCString# hsName#
+ -- NOTE: Don't call mkSelectorInfo here, the rule would apply!
+ = SelectorInfo objCName hsName cif (getSelectorForName objCName) False
+ where
+ objCName = unpackCString# objCName#
+ hsName = unpackCString# hsName#
{-# RULES
"litstr" forall s1 s2 cif.
- mkSelectorInfo (unpackCString# s1) (unpackCString# s2) cif
- = mkSelectorInfo# s1 s2 cif
+ mkSelectorInfo (unpackCString# s1) (unpackCString# s2) cif
+ = mkSelectorInfo# s1 s2 cif
#-}
{-# NOINLINE mkSelectorInfoRetained #-}
mkSelectorInfoRetained objCName hsName cif
- = SelectorInfo objCName hsName cif (getSelectorForName objCName) True
+ = SelectorInfo objCName hsName cif (getSelectorForName objCName) True
{-# NOINLINE mkSelectorInfoRetained# #-}
mkSelectorInfoRetained# objCName# hsName# cif
- -- NOTE: Don't call mkSelectorInfo here, the rule would apply!
- = SelectorInfo objCName hsName cif (getSelectorForName objCName) True
- where
- objCName = unpackCString# objCName#
- hsName = unpackCString# hsName#
+ -- NOTE: Don't call mkSelectorInfo here, the rule would apply!
+ = SelectorInfo objCName hsName cif (getSelectorForName objCName) True
+ where
+ objCName = unpackCString# objCName#
+ hsName = unpackCString# hsName#
{-# RULES
"litstr" forall s1 s2 cif.
- mkSelectorInfoRetained (unpackCString# s1) (unpackCString# s2) cif
- = mkSelectorInfoRetained# s1 s2 cif
+ mkSelectorInfoRetained (unpackCString# s1) (unpackCString# s2) cif
+ = mkSelectorInfoRetained# s1 s2 cif
#-}
@@ -105,13 +106,13 @@
$(lamE [varP $ mkName "args"] e) |]
invoke | isUnit = [| sendMessageWithoutRetval $(targetVar)
- (selectorInfoCif $(infoVar))
+ (selectorInfoCif
$(infoVar))
$(argsVar)|]
| otherwise = [| sendMessageWithRetval $(targetVar)
- (selectorInfoCif $(infoVar))
+ (selectorInfoCif
$(infoVar))
$(argsVar)|]
where argsVar = varE $ mkName "args"
- targetVar = varE $ mkName "target"
+ targetVar = varE $ mkName "target"
purify e | isPure = [| unsafePerformIO $(e) |]
| otherwise = e
Modified: trunk/hoc/HOC/HOC/StdArgumentTypes.hs
==============================================================================
--- trunk/hoc/HOC/HOC/StdArgumentTypes.hs (original)
+++ trunk/hoc/HOC/HOC/StdArgumentTypes.hs Sat Nov 1 04:27:26 2008
@@ -1,4 +1,7 @@
-{-# OPTIONS -fallow-undecidable-instances #-}
+{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface,
+ MultiParamTypeClasses, UndecidableInstances,
+ TypeSynonymInstances, FlexibleInstances,
+ ScopedTypeVariables #-}
module HOC.StdArgumentTypes where
import HOC.Base
@@ -83,6 +86,6 @@
autoreleaseObject nsstr
return nsstr
importArgument arg = nsStringToUTF8 arg >>= peekArray0 0
- >>= return . utf8ToUnicode
+ >>= return . utf8ToUnicode
objCTypeString _ = "*"
Modified: trunk/hoc/HOC/HOC/Super.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Super.hs (original)
+++ trunk/hoc/HOC/HOC/Super.hs Sat Nov 1 04:27:26 2008
@@ -1,4 +1,5 @@
-{-# OPTIONS -fallow-undecidable-instances #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
+ UndecidableInstances, FlexibleInstances #-}
module HOC.Super(
SuperClass, SuperTarget, Super(super), withExportedSuper
) where
Modified: trunk/hoc/HOC/HOC/TH.hs
==============================================================================
--- trunk/hoc/HOC/HOC/TH.hs (original)
+++ trunk/hoc/HOC/HOC/TH.hs Sat Nov 1 04:27:26 2008
@@ -41,6 +41,6 @@
fromSameModule :: NameSpace -> String -> Name -> Name
fromSameModule ns s n
= Name (mkOccName s) $
- case n of
- Name _ (NameG _ pkg mod) -> NameG ns pkg mod
- Name _ other -> other
+ case n of
+ Name _ (NameG _ pkg mod) -> NameG ns pkg mod
+ Name _ other -> other
Modified: trunk/hoc/HOC/HOC/Utilities.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Utilities.hs (original)
+++ trunk/hoc/HOC/HOC/Utilities.hs Sat Nov 1 04:27:26 2008
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
module HOC.Utilities where
import HOC.Base
Modified: trunk/hoc/InterfaceGenerator/Enums.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator/Enums.hs (original)
+++ trunk/hoc/InterfaceGenerator/Enums.hs Sat Nov 1 04:27:26 2008
@@ -69,15 +69,15 @@
(map (nameToLowercase . fst) constants)
pprEnumType (EnumType name constants) =
- char '$' <> parens (
- declare
- <+> brackets (
- hcat $ punctuate comma $ map pprAssoc constants
- )
- )
- where
- declare = case name of
- Just cname -> text "declareCEnum" <+> doubleQuotes (text cname)
- Nothing -> text "declareAnonymousCEnum"
- pprAssoc (n, v)
- = parens (doubleQuotes (text n) <> comma <+> integer v)
+ char '$' <> parens (
+ declare
+ <+> brackets (
+ hcat $ punctuate comma $ map pprAssoc constants
+ )
+ )
+ where
+ declare = case name of
+ Just cname -> text "declareCEnum" <+> doubleQuotes (text cname)
+ Nothing -> text "declareAnonymousCEnum"
+ pprAssoc (n, v)
+ = parens (doubleQuotes (text n) <> comma <+> integer v)
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Sat Nov 1 04:27:26 2008
@@ -70,10 +70,10 @@
return (get >>= return . maybe 0 id . Map.lookup x)
optable = [ [Infix (op "*" (*)) AssocLeft,
- Infix (op "/" div) AssocLeft],
- [Infix (op "+" (+)) AssocLeft,
- Infix (op "-" (-)) AssocLeft],
- [Infix (bop "<" (<)) AssocLeft,
+ Infix (op "/" div) AssocLeft],
+ [Infix (op "+" (+)) AssocLeft,
+ Infix (op "-" (-)) AssocLeft],
+ [Infix (bop "<" (<)) AssocLeft,
Infix (bop "<=" (<=)) AssocLeft,
Infix (bop "==" (==)) AssocLeft,
Infix (bop "!=" (/=)) AssocLeft,
Modified: trunk/hoc/Tests/TestPreprocessor.hs
==============================================================================
--- trunk/hoc/Tests/TestPreprocessor.hs (original)
+++ trunk/hoc/Tests/TestPreprocessor.hs Sat Nov 1 04:27:26 2008
@@ -10,132 +10,132 @@
a ==> b = rstrip (preprocess "test" a) ~?= rstrip b
success a = (filter interesting $ lines $ preprocess "test" a) ~?=
["success"]
- where
- interesting ('/' : '/' : _ ) = False
- interesting other | all isSpace other = False
- | otherwise = True
+ where
+ interesting ('/' : '/' : _ ) = False
+ interesting other | all isSpace other = False
+ | otherwise = True
tests = "TestPreprocessor" ~: test [
- "empty" ~: "" ==> "",
-
- "plainLines" ~:
- let txt = "asfljkaslf\nasjfhaslkhf\naskfhaskjf\n"
- in txt ==> txt,
-
- "comment1" ~:
- "/* abc */\ndef\n/*ghi*/\n" ==> "/* abc */\ndef\n/*ghi*/\n",
- "comment2" ~:
- "/* abc\ndef */\nghi\n" ==> "/* abc*/\n/*def */\nghi\n",
-
- "ifthenelse1" ~:
- "#include <foo>\n\
- \blah\n\
- \foo bar\n\
- \#if 42\n\
- \baz\n\
- \#else\n\
- \quux\n\
- \#endif\n"
- ==>
- "//#include <foo>\n\
- \blah\n\
- \foo bar\n\
- \//#if 1\n\
- \baz\n\
- \//#else\n\
- \//T quux\n\
- \//#endif",
-
- "elif1" ~: success
- "#if 1\n\
- \success\n\
- \#elif 1\n\
- \failure2\n\
- \#else\n\
- \failure3\n\
- \#endif",
-
- "elif2" ~: success
- "#if 0\n\
- \failure1\n\
- \#elif 1\n\
- \success\n\
- \#else\n\
- \failure2\n\
- \#endif",
+ "empty" ~: "" ==> "",
+
+ "plainLines" ~:
+ let txt = "asfljkaslf\nasjfhaslkhf\naskfhaskjf\n"
+ in txt ==> txt,
+
+ "comment1" ~:
+ "/* abc */\ndef\n/*ghi*/\n" ==> "/* abc */\ndef\n/*ghi*/\n",
+ "comment2" ~:
+ "/* abc\ndef */\nghi\n" ==> "/* abc*/\n/*def */\nghi\n",
+
+ "ifthenelse1" ~:
+ "#include <foo>\n\
+ \blah\n\
+ \foo bar\n\
+ \#if 42\n\
+ \baz\n\
+ \#else\n\
+ \quux\n\
+ \#endif\n"
+ ==>
+ "//#include <foo>\n\
+ \blah\n\
+ \foo bar\n\
+ \//#if 1\n\
+ \baz\n\
+ \//#else\n\
+ \//T quux\n\
+ \//#endif",
+
+ "elif1" ~: success
+ "#if 1\n\
+ \success\n\
+ \#elif 1\n\
+ \failure2\n\
+ \#else\n\
+ \failure3\n\
+ \#endif",
+
+ "elif2" ~: success
+ "#if 0\n\
+ \failure1\n\
+ \#elif 1\n\
+ \success\n\
+ \#else\n\
+ \failure2\n\
+ \#endif",
- "elif3" ~: success
- "#if 0\n\
- \failure1\n\
- \#elif 0\n\
- \failure2\n\
- \#else\n\
- \success\n\
- \#endif",
-
- "elif4" ~: success
- "#if 6 * 9 == 42\n\
- \No, that is not the question.\n\
- \#elif 2 + 2 == 5\n\
- \We love Big Brother!\n\
- \#else\n\
- \success\n\
- \#endif",
-
- "elif5" ~: success
- "#if 6 * 7 == 42\n\
- \success\n\
- \#elif 2 + 2 == 5\n\
- \We love Big Brother!\n\
- \#else\n\
- \wrong, too.\n\
- \#endif",
+ "elif3" ~: success
+ "#if 0\n\
+ \failure1\n\
+ \#elif 0\n\
+ \failure2\n\
+ \#else\n\
+ \success\n\
+ \#endif",
+
+ "elif4" ~: success
+ "#if 6 * 9 == 42\n\
+ \No, that is not the question.\n\
+ \#elif 2 + 2 == 5\n\
+ \We love Big Brother!\n\
+ \#else\n\
+ \success\n\
+ \#endif",
+
+ "elif5" ~: success
+ "#if 6 * 7 == 42\n\
+ \success\n\
+ \#elif 2 + 2 == 5\n\
+ \We love Big Brother!\n\
+ \#else\n\
+ \wrong, too.\n\
+ \#endif",
- "elif6" ~: success
- "#if 6 * 9 == 42\n\
- \no.\n\
- \#elif MAC_OS_X_VERSION_10_5 == 1050\n\
- \success\n\
- \#else\n\
- \wrong, too.\n\
- \#endif",
-
- "nest1" ~: success
- "#if 1\n\
- \#if 1\n\
- \success\n\
- \#else\n\
- \failure1\n\
- \#endif\n\
- \#else\n\
- \failure2\n\
- \#if 1\n\
- \failure3\n\
- \#else\n\
- \failure4\n\
- \#endif\n\
- \failure5\n\
- \#endif",
+ "elif6" ~: success
+ "#if 6 * 9 == 42\n\
+ \no.\n\
+ \#elif MAC_OS_X_VERSION_10_5 == 1050\n\
+ \success\n\
+ \#else\n\
+ \wrong, too.\n\
+ \#endif",
+
+ "nest1" ~: success
+ "#if 1\n\
+ \#if 1\n\
+ \success\n\
+ \#else\n\
+ \failure1\n\
+ \#endif\n\
+ \#else\n\
+ \failure2\n\
+ \#if 1\n\
+ \failure3\n\
+ \#else\n\
+ \failure4\n\
+ \#endif\n\
+ \failure5\n\
+ \#endif",
- "nest2" ~: success
- "#if 0\n\
- \failure0\n\
- \#if 1\n\
- \failure1\n\
- \#else\n\
- \failure2\n\
- \#endif\n\
- \failure3\n\
- \#else\n\
- \#if 0\n\
- \failure4\n\
- \#else\n\
- \success\n\
- \#endif\n\
- \#endif",
-
- "defineBackslash" ~: success
- "#define FOO bar\n\\\
- \ baz\n\
- \success"
- ]
+ "nest2" ~: success
+ "#if 0\n\
+ \failure0\n\
+ \#if 1\n\
+ \failure1\n\
+ \#else\n\
+ \failure2\n\
+ \#endif\n\
+ \failure3\n\
+ \#else\n\
+ \#if 0\n\
+ \failure4\n\
+ \#else\n\
+ \success\n\
+ \#endif\n\
+ \#endif",
+
+ "defineBackslash" ~: success
+ "#define FOO bar\\\n\
+ \ baz\n\
+ \success"
+ ]
|
|
From: <cod...@go...> - 2008-11-01 11:13:30
|
Author: wol...@gm...
Date: Sat Nov 1 04:12:40 2008
New Revision: 347
Modified:
trunk/hoc/InterfaceGenerator2/Entities.hs
Log:
whitespace cleanup
Modified: trunk/hoc/InterfaceGenerator2/Entities.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Entities.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Entities.hs Sat Nov 1 04:12:40 2008
@@ -81,7 +81,7 @@
eAlternateHaskellNames :: [ByteString],
eInfo :: EntityInfo,
eModule :: Module,
- eSrcPos :: SrcPos
+ eSrcPos :: SrcPos
}
deriving ( Read, Show, Typeable, Data )
|
|
From: <cod...@go...> - 2008-10-29 22:55:02
|
Author: wol...@gm...
Date: Wed Oct 29 15:54:06 2008
New Revision: 346
Added:
trunk/hoc/Tests/Test.hs
trunk/hoc/Tests/TestFFI.hs
trunk/hoc/Tests/TestPreprocessor.hs
Modified:
trunk/hoc/HOC.cabal
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
trunk/hoc/Setup.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
Build some unit tests for both the core library and the interface generator
from the
main HOC.cabal file.
Enable them using
runhaskell Setup.hs configure -f Tests
Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal (original)
+++ trunk/hoc/HOC.cabal Wed Oct 29 15:54:06 2008
@@ -10,6 +10,10 @@
description: write HOC interface generator files in binary format
(requires binary package)
+Flag Tests
+ description: build test cases
+ default: False
+
Library
build-depends: base, template-haskell, unix
@@ -73,3 +77,30 @@
if flag(BinaryInterfaces)
build-depends: binary >= 0.2
cpp-options: -DBINARY_INTERFACES
+
+Executable hoc-test
+ main-is: Test.hs
+ hs-source-dirs: HOC, InterfaceGenerator2, Tests
+
+ cpp-options: -DTEST
+
+ build-depends: HUnit
+
+ if !flag(Tests)
+ buildable: False
+
+ extensions: MagicHash, TemplateHaskell,
+ ForeignFunctionInterface, GeneralizedNewtypeDeriving,
+ EmptyDataDecls, MultiParamTypeClasses,
FunctionalDependencies,
+ ScopedTypeVariables, RecursiveDo, FlexibleContexts,
+ FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable
+
+
+ extra-libraries: objc, ffi
+ if os(darwin)
+ frameworks: Foundation
+ cpp-options: -DMACOSX
+ else
+ extra-lib-dirs: /usr/lib/gcc/i486-linux-gnu/4.1.3/,
/usr/lib/GNUstep/System/Library/Libraries
+ extra-libraries: gnustep-base
+ cpp-options: -DGNUSTEP
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Wed Oct 29 15:54:06 2008
@@ -44,7 +44,7 @@
<|> (reserved cpp "ifndef" >> definedMacroCondition >>= \e -> return $
If (negateExpr e))
<|> (reserved cpp "endif" >> return Endif)
<|> (reserved cpp "else" >> return Else)
- <|> (plainLine >>= \p -> return $ Text ("//# " ++ p))
+ <|> (plainLine >>= \p -> return $ Text ("//#" ++ p))
definedMacroCondition = do
macro <- identifier cpp
@@ -69,7 +69,11 @@
<|> do x <- identifier cpp
return (get >>= return . maybe 0 id . Map.lookup x)
- optable = [ [Infix (bop "<" (<)) AssocLeft,
+ optable = [ [Infix (op "*" (*)) AssocLeft,
+ Infix (op "/" div) AssocLeft],
+ [Infix (op "+" (+)) AssocLeft,
+ Infix (op "-" (-)) AssocLeft],
+ [Infix (bop "<" (<)) AssocLeft,
Infix (bop "<=" (<=)) AssocLeft,
Infix (bop "==" (==)) AssocLeft,
Infix (bop "!=" (/=)) AssocLeft,
@@ -157,29 +161,7 @@
(l2 : ls') -> (l ++ '\n' : l2) : ls'
ls' -> ls'
| otherwise = l : handleBackslashes ls
-
-preprocess fn f = execute fn $ parseDirectives f
-{-
-test = putStrLn $ execute "test" $ parseDirectives
- "#include <foo>\n\
- \blah\n\
- \foo bar\n\
- \#if 1\n\
- \baz\n\
- \#else\n\
- \quux\n\
- \#endif\n"
-
-test2 fn = do
--- f <- readFile
$ "/System/Library/Frameworks/Foundation.framework/Versions/C/Headers/" ++
fn
- f <- readFile $ "/usr/lib/GNUstep/System/Library/Headers/" ++ fn
- putStrLn $ execute fn $ parseDirectives f
-
+preprocess :: String -> String -> String
+preprocess fn f = execute fn $ parseDirectives f
-test3 fn = do
- f <- readFile
$ "/System/Library/Frameworks/Foundation.framework/Versions/C/Headers/" ++
fn
- -- putStrLn $
- putStrLn fn
- print $ length $ execute fn $ parseDirectives f
--}
Modified: trunk/hoc/Setup.hs
==============================================================================
--- trunk/hoc/Setup.hs (original)
+++ trunk/hoc/Setup.hs Wed Oct 29 15:54:06 2008
@@ -62,6 +62,7 @@
_ -> 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" ]
@@ -71,6 +72,14 @@
++ 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, [])
+ return (Just buildInfo, [("hoc-test", buildInfo2)])
Added: trunk/hoc/Tests/Test.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/Test.hs Wed Oct 29 15:54:06 2008
@@ -0,0 +1,11 @@
+module Main where
+
+import qualified TestFFI
+import qualified TestPreprocessor
+
+import Test.HUnit
+
+main = runTestTT $ test [
+ TestFFI.tests,
+ TestPreprocessor.tests
+ ]
Added: trunk/hoc/Tests/TestFFI.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/TestFFI.hs Wed Oct 29 15:54:06 2008
@@ -0,0 +1,88 @@
+{-# LANGUAGE RankNTypes #-}
+module TestFFI where
+
+import HOC.FFICallInterface
+import HOC.Invocation
+
+
+import Foreign
+import Foreign.C
+import Data.Int
+import Test.HUnit
+
+import HOC.Arguments
+import HOC.StdArgumentTypes
+
+foreign import ccall "ffi.h ffi_call"
+ ffi_call :: FFICif -> FunPtr a -> Ptr b -> Ptr (Ptr ()) -> IO Int
+
+
+fficallDirectly cif fp args
+ = allocaRetval $ \ret -> do
+ ffi_call cif fp ret args
+ peekRetval ret
+
+type Invoker = forall a b c d.
+ (ObjCArgument a a, ObjCArgument b b) =>
+ FFICif -> FunPtr (a -> b) -> Ptr (Ptr ()) -> IO b
+
+testArgAndResult :: (Num a, Num b, ObjCArgument a a, ObjCArgument b b)
+ => Invoker -> FunPtr (a -> b) -> IO ()
+
+
+testArgAndResult invoker fp
+ = do
+ fixTypes fp theArg theResult
+
+ argType <- makeFFIType theArg
+ retType <- makeFFIType theResult
+ cif <- ffiPrepCif retType [argType]
+ x <- with theArg $ \arg -> withArray [arg] $ \args -> invoker cif
fp (castPtr args)
+ x @?= theResult
+ return ()
+ where
+ theArg = 23
+ theResult = 19
+
+ fixTypes :: FunPtr (a -> b) -> a -> b -> IO ()
+ fixTypes f a b = return ()
+
+
+
+subtractFrom42 x = 42 - x
+
+foreign export ccall "funIntToInt" subtractFrom42 :: CInt -> CInt
+foreign import ccall "&funIntToInt" funIntToInt :: FunPtr (CInt -> CInt)
+
+foreign export ccall "funCharToChar" subtractFrom42 :: CChar -> CChar
+foreign import ccall "&funCharToChar" funCharToChar :: FunPtr (CChar ->
CChar)
+
+foreign export ccall "funFloatToFloat" subtractFrom42 :: CFloat -> CFloat
+foreign import ccall "&funFloatToFloat" funFloatToFloat :: FunPtr (CFloat
-> CFloat)
+
+foreign export ccall "funDoubleToDouble" subtractFrom42 :: CDouble ->
CDouble
+foreign import ccall "&funDoubleToDouble" funDoubleToDouble :: FunPtr
(CDouble -> CDouble)
+
+foreign export ccall "funLLongToLLong" subtractFrom42 :: CLLong -> CLLong
+foreign import ccall "&funLLongToLLong" funLLongToLLong :: FunPtr (CLLong
-> CLLong)
+
+testArgsAndResults :: Invoker -> Test
+
+
+testArgsAndResults invoker
+ = test [
+ testArgAndResult invoker funIntToInt,
+ testArgAndResult invoker funCharToChar,
+ testArgAndResult invoker funLLongToLLong,
+ testArgAndResult invoker funFloatToFloat,
+ testArgAndResult invoker funDoubleToDouble
+ ]
+
+tests = "TestFFI" ~: test [
+ "peekRetval" ~: test $ with (42 :: Int) $ \p -> do
+ ret <- peekRetval (castPtr p :: Ptr CChar)
+ ret @?= (42 :: CChar)
+ ,
+ "Plain FFI" ~: testArgsAndResults fficallDirectly,
+ "callWithRetval" ~: testArgsAndResults callWithRetval
+ ]
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Wed Oct 29 15:54:06 2008
@@ -12,6 +12,10 @@
import Control.Exception ( try, finally )
import qualified System.Info( os )
+deriving instance Show NSRect
+deriving instance Show NSPoint
+deriving instance Show NSSize
+
-- garbage collect and make really sure that finalizers have time to
run
performGCAndWait targetCount time maxRepeat = do
performGC
Added: trunk/hoc/Tests/TestPreprocessor.hs
==============================================================================
--- (empty file)
+++ trunk/hoc/Tests/TestPreprocessor.hs Wed Oct 29 15:54:06 2008
@@ -0,0 +1,141 @@
+module TestPreprocessor where
+
+import Preprocessor
+
+import Test.HUnit
+import Data.Char
+
+rstrip = reverse . dropWhile isSpace . reverse
+
+a ==> b = rstrip (preprocess "test" a) ~?= rstrip b
+
+success a = (filter interesting $ lines $ preprocess "test" a) ~?=
["success"]
+ where
+ interesting ('/' : '/' : _ ) = False
+ interesting other | all isSpace other = False
+ | otherwise = True
+
+tests = "TestPreprocessor" ~: test [
+ "empty" ~: "" ==> "",
+
+ "plainLines" ~:
+ let txt = "asfljkaslf\nasjfhaslkhf\naskfhaskjf\n"
+ in txt ==> txt,
+
+ "comment1" ~:
+ "/* abc */\ndef\n/*ghi*/\n" ==> "/* abc */\ndef\n/*ghi*/\n",
+ "comment2" ~:
+ "/* abc\ndef */\nghi\n" ==> "/* abc*/\n/*def */\nghi\n",
+
+ "ifthenelse1" ~:
+ "#include <foo>\n\
+ \blah\n\
+ \foo bar\n\
+ \#if 42\n\
+ \baz\n\
+ \#else\n\
+ \quux\n\
+ \#endif\n"
+ ==>
+ "//#include <foo>\n\
+ \blah\n\
+ \foo bar\n\
+ \//#if 1\n\
+ \baz\n\
+ \//#else\n\
+ \//T quux\n\
+ \//#endif",
+
+ "elif1" ~: success
+ "#if 1\n\
+ \success\n\
+ \#elif 1\n\
+ \failure2\n\
+ \#else\n\
+ \failure3\n\
+ \#endif",
+
+ "elif2" ~: success
+ "#if 0\n\
+ \failure1\n\
+ \#elif 1\n\
+ \success\n\
+ \#else\n\
+ \failure2\n\
+ \#endif",
+
+ "elif3" ~: success
+ "#if 0\n\
+ \failure1\n\
+ \#elif 0\n\
+ \failure2\n\
+ \#else\n\
+ \success\n\
+ \#endif",
+
+ "elif4" ~: success
+ "#if 6 * 9 == 42\n\
+ \No, that is not the question.\n\
+ \#elif 2 + 2 == 5\n\
+ \We love Big Brother!\n\
+ \#else\n\
+ \success\n\
+ \#endif",
+
+ "elif5" ~: success
+ "#if 6 * 7 == 42\n\
+ \success\n\
+ \#elif 2 + 2 == 5\n\
+ \We love Big Brother!\n\
+ \#else\n\
+ \wrong, too.\n\
+ \#endif",
+
+ "elif6" ~: success
+ "#if 6 * 9 == 42\n\
+ \no.\n\
+ \#elif MAC_OS_X_VERSION_10_5 == 1050\n\
+ \success\n\
+ \#else\n\
+ \wrong, too.\n\
+ \#endif",
+
+ "nest1" ~: success
+ "#if 1\n\
+ \#if 1\n\
+ \success\n\
+ \#else\n\
+ \failure1\n\
+ \#endif\n\
+ \#else\n\
+ \failure2\n\
+ \#if 1\n\
+ \failure3\n\
+ \#else\n\
+ \failure4\n\
+ \#endif\n\
+ \failure5\n\
+ \#endif",
+
+ "nest2" ~: success
+ "#if 0\n\
+ \failure0\n\
+ \#if 1\n\
+ \failure1\n\
+ \#else\n\
+ \failure2\n\
+ \#endif\n\
+ \failure3\n\
+ \#else\n\
+ \#if 0\n\
+ \failure4\n\
+ \#else\n\
+ \success\n\
+ \#endif\n\
+ \#endif",
+
+ "defineBackslash" ~: success
+ "#define FOO bar\n\\\
+ \ baz\n\
+ \success"
+ ]
|
|
From: <cod...@go...> - 2008-10-29 11:08:10
|
Author: grddev
Date: Wed Oct 29 04:07:25 2008
New Revision: 345
Modified:
trunk/hoc/InterfaceGenerator2/Parser.hs
Log:
Assume CGFloat=float to fix build on 10.5.5
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Wed Oct 29 04:07:25 2008
@@ -256,7 +256,9 @@
typ <- identifier objc
if typ `elem` ["char","short","int","float","double"]
then return typ
- else fail "not a built-in type"
+ else if typ == "CGFloat"
+ then return "float" -- NOTE: Assumes 32 bit...
+ else fail "not a built-in type"
id_type = do
reserved objc "id"
|
|
From: <cod...@go...> - 2008-10-25 21:16:10
|
Author: wol...@gm...
Date: Sat Oct 25 14:15:21 2008
New Revision: 344
Modified:
trunk/hoc/InterfaceGenerator2/Main.hs
Log:
don't forget to add the progress reporter for the renaming phase
to the list of progress bars
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Sat Oct 25 14:15:21 2008
@@ -157,8 +157,9 @@
[initialProgress,
resolveProgress,
typeProgress, zapProgress,
expandProgress,
combineProgress,
- eliminateProgress,
outputProgress,
- masterProgress, exportProgress]
+ renameProgress,
eliminateProgress,
+ outputProgress, masterProgress,
+ exportProgress]
headers <- fmap concat $ flip mapM (oHeaderDirectories options) $
\hd -> case hd of
|
|
From: <cod...@go...> - 2008-10-25 20:25:07
|
Author: wol...@gm...
Date: Sat Oct 25 13:24:01 2008
New Revision: 343
Modified:
trunk/hoc/InterfaceGenerator2/Parser.hs
trunk/hoc/InterfaceGenerator2/Preprocessor.hs
Log:
Improve GNUstep compatibility (doesn't work currently)
Modified: trunk/hoc/InterfaceGenerator2/Parser.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Parser.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Parser.hs Sat Oct 25 13:24:01 2008
@@ -350,17 +350,14 @@
firstVar <- one_var t
let single_declaration_end = do
- availability
semi objc
return [firstVar]
multiple_declaration_end = do
comma objc
moreVars <- commaSep objc (one_var t)
- availability
semi objc
return $ firstVar : moreVars
function_definition = do
- availability
skipBlock
return []
@@ -368,6 +365,8 @@
where
one_var t = do
(n, typeOperators) <- id_declarator
+ availability
+ optional initializer
return $ case typeOperators t of
CTFunction retval args varargs
-> ExternFun (Selector n retval args varargs)
@@ -377,12 +376,17 @@
carbon_extern_api = (reserved objc "EXTERN_API" <|> reserved
objc "EXTERN_API_C")
>> parens objc simple_type
+initializer = do
+ symbol objc "="
+ (const_int_expr >> return ()) <|> (skipBlock >> return ())
+ return ()
+
extern_keyword =
reserved objc "extern"
- <|> definedKeyword (\x -> "EXTERN" `isSuffixOf` x || "EXPORT"
`isSuffixOf` x)
+ <|> definedKeyword (\x -> "EXTERN" `isSuffixOf` x || "EXPORT"
`isSuffixOf` x || "_SCOPE" `isSuffixOf` x)
inline_keyword =
- reserved objc "inline" <|> definedKeyword ("_INLINE" `isSuffixOf`)
+ reserved objc "inline" <|> definedKeyword ("INLINE" `isSuffixOf`)
storage_class = extern_keyword <|> inline_keyword <|> reserved
objc "static"
Modified: trunk/hoc/InterfaceGenerator2/Preprocessor.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Preprocessor.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Preprocessor.hs Sat Oct 25 13:24:01 2008
@@ -59,6 +59,9 @@
return (return i)
<|> do reserved cpp "defined"
parens cpp definedMacroCondition
+ <|> do reserved cpp "OS_API_VERSION"
+ parens cpp (identifier cpp >> comma cpp >> identifier
cpp)
+ return (return 1)
<|> do reservedOp cpp "!"
x <- basic
return (x >>= return . (\xx -> if xx /= 0 then 0 else
1))
@@ -179,4 +182,4 @@
-- putStrLn $
putStrLn fn
print $ length $ execute fn $ parseDirectives f
--}
\ No newline at end of file
+-}
|
|
From: <cod...@go...> - 2008-10-25 16:13:55
|
Author: wol...@gm...
Date: Sat Oct 25 09:13:38 2008
New Revision: 342
Modified:
trunk/hoc/InterfaceGenerator2/Main.hs
trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs
Log:
Cleanup & activate RenameClashingIdentifiers phase
Modified: trunk/hoc/InterfaceGenerator2/Main.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Main.hs (original)
+++ trunk/hoc/InterfaceGenerator2/Main.hs Sat Oct 25 09:13:38 2008
@@ -35,6 +35,7 @@
import ResolveAndZap
import ShuffleInstances
import DuplicateEntities
+import RenameClashingIdentifiers
import DependenceGraphs
import Output
@@ -145,6 +146,8 @@
zapProgress <- mkProgress "Zapping unconvertable entities"
expandProgress <- mkProgress "Filling in additional instance
declarations"
combineProgress <- mkProgress "Combining duplicate entities"
+ renameProgress <- mkProgress "Resolving name conflicts"
+
eliminateProgress <- mkProgress "Eliminating redundant instances"
outputProgress <- mkProgress "Writing binding modules"
masterProgress <- mkProgress $ "Writing " ++ frameworkName
++ ".hs"
@@ -198,7 +201,8 @@
(zappedEntities, zapMessages) = runMessages $
zapAndReportFailedTypes zapProgress typedEntities
expandedEntities = monitor expandProgress $
expandProtocolRequirements zappedEntities
combinedEntities = monitor combineProgress $
combineDulicateEntities expandedEntities
- finalEntities = eliminateSubclassInstances eliminateProgress
combinedEntities
+ renamedEntities = monitor renameProgress $
renameClashingIdentifiers $ combinedEntities
+ finalEntities = eliminateSubclassInstances eliminateProgress
renamedEntities
do
let packageName = "HOC-" ++ frameworkName
Modified: trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs (original)
+++ trunk/hoc/InterfaceGenerator2/RenameClashingIdentifiers.hs Sat Oct 25
09:13:38 2008
@@ -4,63 +4,11 @@
import qualified Data.Map as Map
import Data.List( sort, sortBy, groupBy, nub )
-import Debug.Trace
import Data.ByteString.Char8(ByteString)
import qualified Data.ByteString.Char8 as BS
renameClashingIdentifiers :: EntityPile -> EntityPile
-{-data Namespace = SelectorNamespace
- | UnimportantNamespace
- deriving (Ord, Eq, Show)
-
-getNamespace (SelectorEntity _) = SelectorNamespace
-getNamespace _ = UnimportantNamespace
--}
-
-{-
-renameClashingIdentifiers ep
- = ep { epEntities = Map.fromList $
- concat $
- map resolveClash $
- groupedByModuleAndName }
- where
- groupedByModuleAndName
- = Map.toList $ Map.fromListWith (++) $
- [ ( (eModule entity, eHaskellName entity{-, getNamespace $
eInfo entity-} ),
- [(entityID, entity)] )
- | (entityID, entity) <- Map.toList $ epEntities ep ]
-
-
- resolveClash ( _, [x] ) = [x]
- resolveClash ( (mod, name{-, UnimportantNamespace-} ), entities )
- = entities
- resolveClash ( (mod, name{-, namespace-} ), entities )
- | BS.null name = entities
- resolveClash ( (mod, name{-, namespace-}), entities )
- = trace (show (mod,name, map (show . eName . snd) entities)) $
- case possibleCombos of
- (combo : _)
- -> trace (show combo) $
- zipWith renameEntity entities combo
- where
- names = map possibleNamesForEntity entities
-
- possibleNamesFor (LocalID _, e)
- = eHaskellName e : eAlternateHaskellNames e
- ++ [ eHaskellName e `BS.append` BS.pack ("_" ++ show
i) | i <- [1..] ]
- possibleNamesFor (_, e)
- = [eHaskellName e]
-
- possibleCombos = filter checkCombo $ nameCombinations names
-
- checkCombo = all ((==1) . length) . group . sort
-
- renameEntity (entityID, entity) newName
- = (entityID, entity { eHaskellName = newName })
--}
-
-
renameClashingIdentifiers ep
= ep { epEntities = Map.fromList $
concatMap handleName $
@@ -100,25 +48,17 @@
filter ( (> 1) . length ) $
map nub $
map (map snd) $ groupByFst $ sort $
- --map fst $ (\x -> if BS.unpack hName == "action"
then trace (show x) x else x) $
- [ (eModule e, index) --, (eid, e))
+ [ (eModule e, index)
| (index, entities) <- zip [0..] groupedEntities,
(_, (eid, e)) <- entities ]
checkCombo newNames
= all checkClash clashes
where
- checkClash clash =
- trace (show (clash, newNames)) $ nub
toBeTested == toBeTested
+ checkClash clash = nub toBeTested == toBeTested
where toBeTested = extract clash newNames
extract indices xs = map (xs!!) indices
- {-extract [] i0 _ = []
- extract (index : indices) i0 xs
- = (xs !! (index - i0))
- : extract indices
- (index + 1)
- (drop (index - i0 + 1) xs)-}
renameEntity (entityID, entity) newName
= (entityID, entity { eHaskellName = newName })
@@ -145,4 +85,3 @@
return (chosenName : moreChosenNames)
--- (e1_n1 | e1_n2 | e1_n3) & (e2_n1 | e2_n2) & (!e1_n1 | !e2_n1) & (!e1_n2
| !e2_n2)
\ No newline at end of file
|
