hoc-cvs — CVS commit log messages

[hoc-cvs] hoc/HOC/HOC Unicode.hs,NONE,1.1 StdArgumentTypes.hs,1.4,1.5

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

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

Modified Files:
	StdArgumentTypes.hs 
Added Files:
	Unicode.hs 
Log Message:
Support arbitrary unicode for NSString <-> String conversions


--- NEW FILE: Unicode.hs ---
--------------------------------------------------------------------------------
--
--  This module has been copied from the HXML Toolbox library:
--    http://www.fh-wedel.de/~si/HXmlToolbox/
--  and is subject to the following terms:
--
--  The MIT License
--
--  Copyright (c) 2002 Uwe Schmidt, Martin Schmidt
--
--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"),
--  to deal in the Software without restriction, including without limitation
--  the rights to use, copy, modify, merge, publish, distribute, sublicense,
--  and/or sell copies of the Software, and to permit persons to whom the
--  Software is furnished to do so, subject to the following conditions:
--
--  The above copyright notice and this permission notice shall be included in
--  all copies or substantial portions of the Software.
--
--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
--  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
--  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
--  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
--  DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
--  OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
--  OR OTHER DEALINGS IN THE SOFTWARE.
--
--------------------------------------------------------------------------------

--  Modified, May 2004, Graham Klyne:
--
--  - Added generic UTF-to-Unicode conversion function
--  - Return a null Unicode character when an invalid UTF-8 sequence is encountered

--  Modified, March 2006, Wolfgang Thaller;
--
--  - Brutally cut down for inclusion in HOC
--    all we need is Unicode <-> UTF8 conversion.
--  - Use String for unicode and [Word8] for utf-8,
--    because that's The Way It Should Be (according to me).


module HOC.Unicode
    (
     -- * Unicode Type declarations
     UTF8Char,
     UTF8String,

      -- * Unicode and UTF-8 conversions
      utf8ToUnicode,
      unicodeToUtf8
    )
where

import Data.Char( toUpper )
import Data.Word( Word8 )

-- ------------------------------------------------------------

-- | Unicode is represented as the Char type
--   Precondition for this is the support of Unicode character range
--   in the compiler (e.g. ghc but not hugs)
type Unicode    = Char

-- | the type for Unicode strings
type UString    = [Unicode]

type UTF8Char   = Word8

type UTF8String = [UTF8Char]

maxCharValue = fromEnum ('\x10FFFF')

-- ------------------------------------------------------------
--
-- Unicode predicates

-- |
-- test for leading multibyte UTF-8 character

isLeadingMultiByteChar  :: UTF8Char -> Bool
isLeadingMultiByteChar  c
    = c >= 0xC0 && c <= 0xFD

-- |
-- test for following multibyte UTF-8 character

isFollowingMultiByteChar        :: UTF8Char -> Bool
isFollowingMultiByteChar        c
    = c >= 0x80 && c < 0xC0

-- |
-- compute the number of following bytes and the mask bits of a leading UTF-8 multibyte char

isNByteChar     :: UTF8Char -> (Int, Int, Int)
isNByteChar c
    | c >= 0xc0 && c <= 0xdf = (1, 0xC0, 0x00000080)
    | c >= 0xe0 && c <= 0xef = (2, 0xE0, 0x00000800)
    | c >= 0xf0 && c <= 0xf7 = (3, 0xF0, 0x00010000)
    | c >= 0xf8 && c <= 0xfb = (4, 0xF8, 0x00200000)
    | c >= 0xfc && c <= 0xfd = (5, 0xFC, 0x04000000)
    | otherwise = (0,fromIntegral c,0)

-- ------------------------------------------------------------

-- |
-- conversion of a UTF-8 encoded string into a sequence of unicode values.
-- precondition: the string is a valid UTF-8 encoded string

utf8ToUnicode           :: UTF8String -> String
utf8ToUnicode (c : cs)
    | c < 0x80
        = toEnum (fromIntegral c) : utf8ToUnicode cs
    | isLeadingMultiByteChar c
      &&
      resAsInt <= maxCharValue
      &&
      l1 == length cs0
        = toEnum resAsInt
          : utf8ToUnicode cs1
    | otherwise
        = toEnum 0 : utf8ToUnicode cs1
          where
          (l1, mask, _min)      = isNByteChar c
          (cs0, cs1)            = splitAt l1 cs

          resAsInt              :: Int
          resAsInt              = utf8ToU (fromIntegral c - mask) cs0

          utf8ToU i []      = i
          utf8ToU i (c1:l)
              | isFollowingMultiByteChar c1
                  = utf8ToU (i * 0x40 + (fromIntegral c1 - 0x80)) l
              | otherwise
                  = 0 -- error ("utf8ToUnicode: illegal UTF-8 multibyte character " ++ show (c : cs0) )

utf8ToUnicode []
    = []

-- ------------------------------------------------------------

-- |
-- conversion from Unicode strings (UString) to UTF8 encoded strings.

unicodeToUtf8           :: String -> UTF8String
unicodeToUtf8           = concatMap unicodeCharToUtf8

-- |
-- conversion from Char to a UTF8 encoded string.

unicodeCharToUtf8       :: Char -> UTF8String
unicodeCharToUtf8 c
    | i >= 0          && i <= 0x0000007F        -- 1 byte UTF8 (7 bits)
        = [ fromIntegral i ]
    | i >= 0x00000080 && i <= 0x000007FF        -- 2 byte UTF8 (5 + 6 bits)
        = [ fromIntegral (0xC0 + i `div` 0x40)
          , fromIntegral (0x80 + i                  `mod` 0x40)
          ]
    | i >= 0x00000800 && i <= 0x0000FFFF        -- 3 byte UTF8 (4 + 6 + 6 bits)
        = [ fromIntegral (0xE0 +  i `div`   0x1000)
          , fromIntegral (0x80 + (i `div`     0x40) `mod` 0x40)
          , fromIntegral (0x80 +  i                 `mod` 0x40)
          ]
    | i >= 0x00010000 && i <= 0x001FFFFF        -- 4 byte UTF8 (3 + 6 + 6 + 6 bits)
        = [ fromIntegral (0xF0 +  i `div`    0x40000)
          , fromIntegral (0x80 + (i `div`     0x1000) `mod` 0x40)
          , fromIntegral (0x80 + (i `div`       0x40) `mod` 0x40)
          , fromIntegral (0x80 +  i                   `mod` 0x40)
          ]
    | i >= 0x00200000 && i <= 0x03FFFFFF        -- 5 byte UTF8 (2 + 6 + 6 + 6 + 6 bits)
        = [ fromIntegral (0xF8 +  i `div`  0x1000000)
          , fromIntegral (0x80 + (i `div`    0x40000) `mod` 0x40)
          , fromIntegral (0x80 + (i `div`     0x1000) `mod` 0x40)
          , fromIntegral (0x80 + (i `div`       0x40) `mod` 0x40)
          , fromIntegral (0x80 +  i                   `mod` 0x40)
          ]
    | i >= 0x04000000 && i <= 0x7FFFFFFF        -- 6 byte UTF8 (1 + 6 + 6 + 6 + 6 + 6 bits)
        = [ fromIntegral (0xFC +  i `div` 0x40000000)
          , fromIntegral (0x80 + (i `div`  0x1000000) `mod` 0x40)
          , fromIntegral (0x80 + (i `div`    0x40000) `mod` 0x40)
          , fromIntegral (0x80 + (i `div`     0x1000) `mod` 0x40)
          , fromIntegral (0x80 + (i `div`       0x40) `mod` 0x40)
          , fromIntegral (0x80 +  i                   `mod` 0x40)
          ]
    | otherwise                                 -- other values not supported
        = error ("unicodeCharToUtf8: illegal integer argument " ++ show i)
    where
    i = fromEnum c


Index: StdArgumentTypes.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/StdArgumentTypes.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- StdArgumentTypes.hs	26 Jul 2005 01:27:44 -0000	1.4
+++ StdArgumentTypes.hs	17 Mar 2006 05:32:04 -0000	1.5
@@ -1,3 +1,4 @@
+{-# OPTIONS -fallow-undecidable-instances #-}
 module HOC.StdArgumentTypes where
 
 import HOC.Base
@@ -10,6 +11,8 @@
 import Foreign.C.Types
 import Foreign.C.String
 
+import HOC.Unicode
+
 -- Objective C
 
 -- ID: already defined 
@@ -63,19 +66,23 @@
 
 -- String
 
+
 foreign import ccall safe "Marshalling.h nsStringToUTF8"
-    nsStringToUTF8 :: Ptr ObjCObject -> IO CString
+    nsStringToUTF8 :: Ptr ObjCObject -> IO (Ptr Word8)
 
 foreign import ccall unsafe "Marshalling.h utf8ToNSString"
-    utf8ToNSString :: CString -> IO (Ptr ObjCObject)
+    utf8ToNSString :: Ptr Word8 -> IO (Ptr ObjCObject)
+
+withUTF8String str = withArray0 0 (unicodeToUtf8 str)
 
 instance ObjCArgument String (Ptr ObjCObject) where
     withExportedArgument arg action =
-        bracket (withCString arg utf8ToNSString) releaseObject action
+        bracket (withUTF8String arg utf8ToNSString) releaseObject action
     exportArgument arg = do
-        nsstr <- withCString arg utf8ToNSString
+        nsstr <- withUTF8String arg utf8ToNSString
         autoreleaseObject nsstr
         return nsstr
-    importArgument arg = nsStringToUTF8 arg >>= peekCString
-    
+    importArgument arg = nsStringToUTF8 arg >>= peekArray0 0
+    					 >>= return . utf8ToUnicode
+   
     objCTypeString _ = "*"

[hoc-cvs] hoc/Tests TestFoundation.hs,1.7,1.8

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

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

Modified Files:
	TestFoundation.hs 
Log Message:
Support arbitrary unicode for NSString <-> String conversions


Index: TestFoundation.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/Tests/TestFoundation.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- TestFoundation.hs	5 Oct 2005 02:23:19 -0000	1.7
+++ TestFoundation.hs	17 Mar 2006 05:32:04 -0000	1.8
@@ -134,7 +134,28 @@
                 actual_ns <- _NSString # alloc >>= initWithContentsOfFile
                                                     (toNSString "TestFoundation.hs")
                 fromNSString actual_ns @?= expected
-            )
+            ),
+            "Unicode" ~:
+                let zhongwen = "\x4E2D\x6587" -- "Chinese" in Chinese
+                    fermata = "\x1D110"       -- Fermata (Musical Symbol)
+                in test [
+                    "nsString-haskellString" ~: (assertNoLeaks $ do
+                        actual <- nsString zhongwen >>= haskellString
+                        actual @?= zhongwen
+                    ),
+                    "length" ~: (assertNoLeaks $ do
+                        actual <- nsString zhongwen >>= Foundation.length
+                        actual @?= 2
+                    ),
+                    "nsString-haskellString-fermata" ~: (assertNoLeaks $ do
+                        actual <- nsString fermata >>= haskellString
+                        actual @?= fermata
+                    ),
+                    "length-fermata" ~: (assertNoLeaks $ do
+                        actual <- nsString fermata >>= Foundation.length
+                        actual @?= 2 -- yes, 2. NSString uses UTF-16.
+                    )
+            ]
         ],
         "HaskellObjectWithOutlet" ~: test [
             "alloc-init" ~: (assertNoLeaks $ do
@@ -203,6 +224,11 @@
             fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
         ),
         "structs" ~: test [
+            "pointArg" ~: (do
+                let point = NSPoint 6.42 7.42
+                result <- _NSValue # valueWithPoint point
+                return ()
+            ),
             "point" ~: (do
                 let point = NSPoint 6.42 7.42
                 result <- _NSValue # valueWithPoint point >>= pointValue

[hoc-cvs] hoc/HOC HOC.conf.in,1.4,1.5

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

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

Modified Files:
	HOC.conf.in 
Log Message:
Support arbitrary unicode for NSString <-> String conversions


Index: HOC.conf.in
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC.conf.in,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- HOC.conf.in	27 Sep 2005 11:55:22 -0000	1.4
+++ HOC.conf.in	17 Mar 2006 05:32:04 -0000	1.5
@@ -27,7 +27,8 @@
     HOC.Dyld,
     HOC.ExternConstants,
     HOC.Exception,
-    HOC.ExternFunctions
+    HOC.ExternFunctions,
+    HOC.Unicode
 
 hs-libraries:       "HOC", "HOC_cbits"
 depends:            base, template-haskell

[hoc-cvs] hoc/HOC_cbits Exceptions.m,1.1,1.2

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

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

Modified Files:
	Exceptions.m 
Log Message:
Set the "reason" value for HaskellExceptions


Index: Exceptions.m
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC_cbits/Exceptions.m,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Exceptions.m	27 Sep 2005 11:55:22 -0000	1.1
+++ Exceptions.m	17 Mar 2006 05:27:08 -0000	1.2
@@ -64,7 +64,7 @@
     initExceptionWrapper();
 
     cexc = objc_msgSend(clsHOCHaskellException, selExceptionWithNameReasonUserInfo,
-                        utf8ToNSString("HaskellException"), nil, nil);
+                        utf8ToNSString("HaskellException"), utf8ToNSString(name), nil);
     
     * (HsStablePtr*) (((char*)cexc) + stablePtrOffset) = hexc;
     

[hoc-cvs] hoc/InterfaceGenerator Headers.hs,1.6,1.7

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

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

Modified Files:
	Headers.hs 
Log Message:
A small hack: drop the "#else" part of "#if"s.. (but don't bother to check
the condition or to get it right for nested #ifs).
This helps dealing with things like

#if MAC_OS_X_VERSION_MAX_ALLOWED >= MAC_OS_X_VERSION_10_3
@interface NSLayoutManager : NSObject <NSCoding, NSGlyphStorage> {
#else
@interface NSLayoutManager : NSObject <NSCoding> {
#endif

until now, we just dropped the preprocessor directives, leaving BOTH
alternatives, leading to a parse error later
(symptom: class NSLayoutManager was absent)




Index: Headers.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Headers.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- Headers.hs	3 Aug 2005 01:52:03 -0000	1.6
+++ Headers.hs	17 Mar 2006 05:25:51 -0000	1.7
@@ -17,6 +17,7 @@
 
 stripPreprocessor = unlines . stripPP . lines
     where
+        stripPP (('#':'e':'l':'s':'e':_) : xs) = "" : dropElseHack xs
         stripPP (x@('#':_) : xs) = dropPreprocessorLine x xs
         stripPP (x : xs) = x : stripPP xs
         stripPP [] = []
@@ -24,6 +25,10 @@
             | last x == '\\' = "" : dropPreprocessorLine (head xs) (tail xs)
             | otherwise = "" : stripPP xs
 
+        dropElseHack (('#':'e':'n':'d':'i':'f':_) : xs) = "" : stripPP xs
+        dropElseHack (x : xs) = "" : dropElseHack xs
+        dropElseHack [] = []
+
 findImports = mapMaybe checkImport . lines
     where
         checkImport line

[hoc-cvs] hoc/HOC HOC.hs,1.12,1.13

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

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

Modified Files:
	HOC.hs 
Log Message:
Add utility function
withExportedArray :: (HOC.Arguments.ObjCArgument a b)
                  => [a] -> (GHC.Ptr.Ptr b -> IO c) -> IO c



Index: HOC.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- HOC.hs	27 Sep 2005 11:55:22 -0000	1.12
+++ HOC.hs	17 Mar 2006 04:57:36 -0000	1.13
@@ -7,6 +7,7 @@
         ClassAndObject,
         ( # ), ( #* ),
         ObjCArgument(..),
+        withExportedArray,
         castObject,
         declareClass,
         declareSelector,

[hoc-cvs] hoc/HOC/HOC Arguments.hs,1.5,1.6

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

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

Modified Files:
	Arguments.hs 
Log Message:
Add utility function
withExportedArray :: (HOC.Arguments.ObjCArgument a b)
                  => [a] -> (GHC.Ptr.Ptr b -> IO c) -> IO c



Index: Arguments.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- Arguments.hs	27 Sep 2005 11:55:22 -0000	1.5
+++ Arguments.hs	17 Mar 2006 04:57:37 -0000	1.6
@@ -1,3 +1,4 @@
+{-# OPTIONS -fallow-undecidable-instances #-}
 module HOC.Arguments where
 
 import HOC.Base
@@ -6,6 +7,7 @@
 import Foreign.Storable
 import Foreign.ForeignPtr
 import Foreign.Ptr
+import Foreign.Marshal.Array
 import System.IO.Unsafe(unsafePerformIO)
 
 import HOC.TH
@@ -27,6 +29,15 @@
         importArgument = return 
 -}
 
+withExportedArray :: ObjCArgument a b => [a] -> (Ptr b -> IO c) -> IO c
+withExportedArray l a = withExportedList l $ \l' -> withArray l' a
+    where
+        withExportedList [] a = a []
+        withExportedList (x:xs) a
+            = withExportedArgument x $
+              \x' -> withExportedList xs $
+              \xs' -> a (x':xs')
+
 declareStorableObjCArgument :: TypeQ -> String -> Q [Dec]
 
 {- This is what we'd like to do.

[hoc-cvs] hoc/HOC_cbits FFICallInterface.h,1.3,1.4 FFICallInterface.m,1.3,1.4

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

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

Modified Files:
	FFICallInterface.h FFICallInterface.m 
Log Message:
Deal with structure returns in a way that works for x86, too.


Index: FFICallInterface.h
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC_cbits/FFICallInterface.h,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- FFICallInterface.h	27 Feb 2004 12:21:34 -0000	1.3
+++ FFICallInterface.h	17 Mar 2006 04:54:45 -0000	1.4
@@ -3,3 +3,5 @@
 ffi_cif * allocCif();
 ffi_abi defaultABI();
 ffi_type * allocStructType(ffi_type **elements);
+
+int cifIsStret(ffi_cif *cif);

Index: FFICallInterface.m
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC_cbits/FFICallInterface.m,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- FFICallInterface.m	12 May 2004 02:22:43 -0000	1.3
+++ FFICallInterface.m	17 Mar 2006 04:54:45 -0000	1.4
@@ -1,5 +1,5 @@
 #include "FFICallInterface.h"
-
+#include <stdlib.h>
 
 ffi_cif * allocCif()
 {
@@ -20,3 +20,20 @@
     
     return theStruct;
 }
+
+int cifIsStret(ffi_cif *cif)
+{
+    if(cif->rtype->type == FFI_TYPE_STRUCT)
+    {
+#ifdef __i386__
+            // on Darwin/x86, structs 8 bytes and smaller are returned
+            // in registers, and we have to use objc_msgSend and not
+            // objc_msgSend_stret.
+        return cif->rtype->size > 8;
+#else
+        return 1;
+#endif
+    }
+    else
+        return 0;
+}

[hoc-cvs] hoc/HOC/HOC FFICallInterface.hs,1.2,1.3 MsgSend.hs,1.8,1.9

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

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

Modified Files:
	FFICallInterface.hs MsgSend.hs 
Log Message:
Deal with structure returns in a way that works for x86, too.


Index: FFICallInterface.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/FFICallInterface.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- FFICallInterface.hs	27 Feb 2004 12:21:34 -0000	1.2
+++ FFICallInterface.hs	17 Mar 2006 04:54:45 -0000	1.3
@@ -52,6 +52,8 @@
     members <- newArray0 (FFIType nullPtr) members
     allocStructType members
 
+foreign import ccall unsafe cifIsStret :: FFICif -> IO CInt
+
 -- typeable instances
     
 instance FFITypeable () where

Index: MsgSend.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/MsgSend.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- MsgSend.hs	3 Aug 2005 00:32:37 -0000	1.8
+++ MsgSend.hs	17 Mar 2006 04:54:45 -0000	1.9
@@ -83,7 +83,8 @@
 
 objSendMessageWithRetval cif args =
 	withMarshalledDummy $ \dummy ->
-	callWithRetval cif (if isStructType dummy
+	cifIsStret cif >>= \isStret ->
+	callWithRetval cif (if isStret /= 0
                                 then objc_msgSend_stretPtr
                                 else objc_msgSendPtr) args    	 
 
@@ -93,7 +94,8 @@
 
 superSendMessageWithRetval cif args =
 	withMarshalledDummy $ \dummy ->
-	callWithRetval cif (if isStructType dummy
+	cifIsStret cif >>= \isStret ->
+	callWithRetval cif (if isStret /= 0
                                 then objc_msgSendSuper_stretPtr
                                 else objc_msgSendSuperPtr) args    	 
 

[hoc-cvs] hoc/HOC_cbits Makefile.in,1.9,1.10

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

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

Modified Files:
	Makefile.in 
Log Message:
Use updated libffi.


Index: Makefile.in
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC_cbits/Makefile.in,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- Makefile.in	27 Sep 2005 12:22:42 -0000	1.9
+++ Makefile.in	17 Mar 2006 04:52:34 -0000	1.10
@@ -11,6 +11,13 @@
 	NewClass.m \
 	RetainedHaskellPart.m \
 	Marshalling.m \
+	../libffi-src/src/types.c \
+	../libffi-src/src/prep_cif.c \
+	../libffi-src/src/x86/ffi_darwin.c \
+	../libffi-src/src/x86/darwin.S \
+	../libffi-src/src/powerpc/ffi_darwin.c \
+	../libffi-src/src/powerpc/darwin.S \
+	../libffi-src/src/powerpc/darwin_closure.S \
 	Exceptions.m \
 	$(NULL)
 
@@ -20,10 +27,13 @@
 	Makefile.in \
 	$(wildcard *.h) \
 	$(NULL)
-	
-OBJS = $(SRCS:%.m=%.o)
 
-CFLAGS += -g -I../libffi-src/build/include
+OBJS_tmp1 = $(SRCS:%.c=%.o)	
+OBJS_tmp2 = $(OBJS_tmp1:%.S=%.o)	
+OBJS = $(OBJS_tmp2:%.m=%.o)
+
+CFLAGS += -g -I../libffi-src/include -fno-common -DMACOSX
+ASFLAGS += -I../libffi-src/include -DMACOSX
 
 all: libHOC_cbits.a HOC_cbits.o
 
@@ -37,14 +47,12 @@
 	fi
 
 libHOC_cbits.a: $(OBJS)
-	cp ../libffi-src/build/.libs/libffi.a libHOC_cbits.a
-	ar qs libHOC_cbits.a $(OBJS)
+	$(MAKE_STATIC_LIB) libHOC_cbits.a $(OBJS)
 
 libHOC_cbits_dyn.dylib: libHOC_cbits.a
 	export MACOSX_DEPLOYMENT_TARGET=10.3 && \
 	 libtool \
 	 -dynamic \
-	 -read_only_relocs suppress \
 	 -undefined dynamic_lookup \
 	 -o $@ \
 	 $<

[hoc-cvs] hoc Makefile.in,1.11,1.12 configure.ac,1.14,1.15

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

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

Modified Files:
	Makefile.in configure.ac 
Log Message:
Use updated libffi.


Index: Makefile.in
===================================================================
RCS file: /cvsroot/hoc/hoc/Makefile.in,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- Makefile.in	30 Jul 2005 12:04:17 -0000	1.11
+++ Makefile.in	17 Mar 2006 04:52:34 -0000	1.12
@@ -37,7 +37,7 @@
 
 installer_package_root = $(shell pwd)/installer-package/root
 
-all: libffi-src/build/src/raw_api.o hoc-all
+all: hoc-all
 
 dist:
 	-test -d "$(dist_dir)" && rm -rf "$(dist_dir)"

Index: configure.ac
===================================================================
RCS file: /cvsroot/hoc/hoc/configure.ac,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- configure.ac	18 Apr 2005 01:39:37 -0000	1.14
+++ configure.ac	17 Mar 2006 04:52:34 -0000	1.15
@@ -185,19 +185,5 @@
 
 AC_OUTPUT
 
-
-#
-# Configure libffi-src/
-#
-
-(cd libffi-src;
- mkdir -p build && cd build;
- if ! test -f config.status; then
-   echo "configuring in libffi-src...";
-   ../configure --disable-shared --enable-static;
- fi
-)
-
-
 # Modeline for vi(m) - vi:expandtab
 

[hoc-cvs] libffi/src/x86 ffi_darwin.c,1.1.1.1,1.2

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

Update of /cvsroot/hoc/libffi/src/x86
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31454/src/x86

Modified Files:
	ffi_darwin.c 
Log Message:
Fix 16-byte alignment for darwin/x86.


Index: ffi_darwin.c
===================================================================
RCS file: /cvsroot/hoc/libffi/src/x86/ffi_darwin.c,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- ffi_darwin.c	17 Mar 2006 03:47:57 -0000	1.1.1.1
+++ ffi_darwin.c	17 Mar 2006 04:20:33 -0000	1.2
@@ -168,7 +168,7 @@
     }
 
   /* Darwin: The stack needs to be aligned to a multiple of 16 bytes */
-  cif->bytes = (cif->bytes + 15) & ~0xF;
+  cif->bytes = ((cif->bytes + 8 + 15) & ~0xF) - 8;
 
   return FFI_OK;
 }

[hoc-cvs] hoc/HOC/HOC DeclareSelector.hs,1.11,1.12

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

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

Modified Files:
	DeclareSelector.hs 
Log Message:
combine foralls at top-level of type
(i.e. avoid types like "forall a. Foo a => forall b. Bar b => a -> b")


Index: DeclareSelector.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- DeclareSelector.hs	26 Jul 2005 05:25:42 -0000	1.11
+++ DeclareSelector.hs	12 Mar 2006 18:49:41 -0000	1.12
@@ -96,9 +96,17 @@
                 (ArrowT `AppT` arg) `AppT` replaceResult new rest
             replaceResult new result = new
 
+            liftForalls (ForallT names cxt ty)
+                = case liftForalls ty of
+                    ForallT names' cxt' ty'
+                        -> ForallT (names ++ names') (cxt ++ cxt') ty'
+                    ty' -> ForallT names cxt ty'
+            liftForalls other = other
+			
             doctorType ty className = 
                     (
                         retained,
+                        liftForalls $
                         (if needInstance
                             then ForallT (map mkName ["target", "inst"])
                                 [ConT (mkName className) `AppT` VarT (mkName "target"),

[hoc-cvs] hoc/Bindings binding-script.txt,1.10,1.11

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

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

Modified Files:
	binding-script.txt 
Log Message:
add NSTimeInterval type


Index: binding-script.txt
===================================================================
RCS file: /cvsroot/hoc/hoc/Bindings/binding-script.txt,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- binding-script.txt	5 Oct 2005 03:14:39 -0000	1.10
+++ binding-script.txt	12 Mar 2006 18:46:11 -0000	1.11
@@ -67,6 +67,8 @@
 type NSRectPointer Foundation.NSGeometry;
 type NSRangePointer Foundation.NSRange;
 
+type NSTimeInterval Foundation.NSDate;
+
 -- GNUstep specifics:
 rename rawMimeData: rawMimeData_;
 rename setContent:type: setContentAndType;

[hoc-cvs] hoc/Bindings/AdditionalCode/Foundation NSDate.hs,NONE,1.1

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

Update of /cvsroot/hoc/hoc/Bindings/AdditionalCode/Foundation
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27084/Bindings/AdditionalCode/Foundation

Added Files:
	NSDate.hs 
Log Message:
add NSTimeInterval type


--- NEW FILE: NSDate.hs ---
-- above NSDate
-- CUT HERE
-- below NSDate
-- CUT HERE
-- above NSDate.Forward

--X NSTimeInterval


-- CUT HERE

-- below NSDate.Forward

type NSTimeInterval = Double

[hoc-cvs] hoc/Bindings/AdditionalCode/Foundation NSException.hs,NONE,1.1

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

Update of /cvsroot/hoc/hoc/Bindings/AdditionalCode/Foundation
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30858/Foundation

Added Files:
	NSException.hs 
Log Message:
Add NSException.hs (in AdditionalCode) that should have been committed along with the
"monster commit" in September.
It exports the catchNS function for catching NSExceptions.


--- NEW FILE: NSException.hs ---
--X catchNS

import Control.Exception    ( catchDyn )
import HOC.Exception        ( WrappedNSException(..) )
-- CUT HERE

catchNS :: IO a -> (NSException () -> IO a) -> IO a

catchNS action handler
    = action `catchDyn` \(WrappedNSException exc) -> handler (castObject exc)

[hoc-cvs] hoc/Bindings/AdditionalCode/Foundation NSGeometry.hs,1.2,1.3 NSRange.hs,1.1,1.2

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

Update of /cvsroot/hoc/hoc/Bindings/AdditionalCode/Foundation
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8803/Bindings/AdditionalCode/Foundation

Modified Files:
	NSGeometry.hs NSRange.hs 
Log Message:
Recognize the pointer typedefs for the usual struct types
(NSRangePointer, etc.).  This lets ifgen handle the methods of
NSAttributedString, for instance.

Patch contributed by Matthew Morgan <mat...@gm...>


Index: NSGeometry.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/Bindings/AdditionalCode/Foundation/NSGeometry.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- NSGeometry.hs	27 Sep 2005 11:55:22 -0000	1.2
+++ NSGeometry.hs	5 Oct 2005 03:14:39 -0000	1.3
@@ -6,6 +6,9 @@
 --X NSPoint(..)
 --X NSSize(..)
 --X NSRect(..)
+--X NSPointPointer
+--X NSRectPointer
+--X NSSizePointer
 --X nsMaxX
 --X nsMaxY
 --X nsMidX
@@ -26,6 +29,10 @@
 data NSSize = NSSize Float Float    deriving(Read, Show, Eq)
 data NSRect = NSRect NSPoint NSSize deriving(Read, Show, Eq)
 
+type NSPointPointer = Ptr NSPoint
+type NSSizePointer  = Ptr NSSize
+type NSRectPointer  = Ptr NSRect
+
 {-
 -- They're imported automatically now.
 nsZeroPoint = NSPoint 0 0

Index: NSRange.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/Bindings/AdditionalCode/Foundation/NSRange.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- NSRange.hs	30 Sep 2005 06:09:18 -0000	1.1
+++ NSRange.hs	5 Oct 2005 03:14:39 -0000	1.2
@@ -4,6 +4,7 @@
 -- CUT HERE
 -- above NSRange.Forward
 --X NSRange(..)
+--X NSRangePointer
 --X nsMaxRange
 --X nsLocationInRange
 --X nsNotFound
@@ -17,6 +18,8 @@
 
 data NSRange = NSRange CUInt CUInt  deriving(Read, Show, Eq)
 
+type NSRangePointer = Ptr NSRange
+
 nsMaxRange (NSRange loc len) = loc + len
 nsLocationInRange x (NSRange loc len) = x >= loc && x < loc+len
 nsNotFound = 0x7fffffff :: CUInt

[hoc-cvs] hoc/Bindings binding-script.txt,1.9,1.10

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

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

Modified Files:
	binding-script.txt 
Log Message:
Recognize the pointer typedefs for the usual struct types
(NSRangePointer, etc.).  This lets ifgen handle the methods of
NSAttributedString, for instance.

Patch contributed by Matthew Morgan <mat...@gm...>


Index: binding-script.txt
===================================================================
RCS file: /cvsroot/hoc/hoc/Bindings/binding-script.txt,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- binding-script.txt	30 Sep 2005 06:09:18 -0000	1.9
+++ binding-script.txt	5 Oct 2005 03:14:39 -0000	1.10
@@ -62,6 +62,11 @@
 type NSRect Foundation.NSGeometry;
 type NSRange Foundation.NSRange;
 
+type NSPointPointer Foundation.NSGeometry;
+type NSSizePointer Foundation.NSGeometry;
+type NSRectPointer Foundation.NSGeometry;
+type NSRangePointer Foundation.NSRange;
+
 -- GNUstep specifics:
 rename rawMimeData: rawMimeData_;
 rename setContent:type: setContentAndType;

[hoc-cvs] hoc/InterfaceGenerator BindingScript.hs,1.8,1.9 CTypeToHaskell.hs,1.7,1.8 Enums.hs,1.4,1.5 ExportModule.hs,1.8,1.9 Main.hs,1.7,1.8 PrepareDeclarations.hs,1.13,1.14

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

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

Modified Files:
	BindingScript.hs CTypeToHaskell.hs Enums.hs ExportModule.hs 
	Main.hs PrepareDeclarations.hs 
Log Message:
Use Data.Map instead of Data.FiniteMap.

Patch contributed by David Christensen <dw...@dw...>.


Index: PrepareDeclarations.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/PrepareDeclarations.hs,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- PrepareDeclarations.hs	27 Sep 2005 11:55:22 -0000	1.13
+++ PrepareDeclarations.hs	5 Oct 2005 02:55:49 -0000	1.14
@@ -12,6 +12,7 @@
 import CTypeToHaskell
 import Headers(HeaderInfo(..), ModuleName)
 import Enums
+import Data.List (foldl')
 
 import HOC.NameCaseChange
 import HOC.SelectorNameMangling(mangleSelectorName)
@@ -19,7 +20,7 @@
 import Control.Monad(when)
 import Data.Set(Set, mkSet, setToList, union, minusSet, unionManySets,
                 emptySet, elementOf)
-import Data.FiniteMap
+import qualified Data.Map as Map
 import qualified Data.HashTable as HashTable
 import Data.Maybe(maybeToList, fromMaybe, mapMaybe)
 import Data.List(partition,isPrefixOf)
@@ -30,9 +31,9 @@
         pdCleanClassInfoHash :: HashTable.HashTable String ClassInfo, {- used read only -}
         pdAllInstanceSels :: [(ClassInfo, [(MangledSelector, SelectorLocation)])],
         pdAllClassSels :: [(ClassInfo, [(MangledSelector, SelectorLocation)])],
-        pdEnumTypeDefinitions :: FiniteMap ModuleName [EnumType],
-        pdExternVarDeclarations :: FiniteMap ModuleName [(HType, String, String)],
-        pdExternFunDeclarations :: FiniteMap ModuleName [MangledSelector],
+        pdEnumTypeDefinitions :: Map.Map ModuleName [EnumType],
+        pdExternVarDeclarations :: Map.Map ModuleName [(HType, String, String)],
+        pdExternFunDeclarations :: Map.Map ModuleName [MangledSelector],
         pdTypeEnvironment :: TypeEnvironment
     }
 
@@ -49,10 +50,10 @@
         ciProtocols :: Set String,
         ciNewProtocols :: Set String,
         ciDefinedIn :: ModuleName,
-        ciInstanceMethods :: FiniteMap Selector SelectorLocation,
-        ciClassMethods :: FiniteMap Selector SelectorLocation,
-        ciNewInstanceMethods :: FiniteMap Selector SelectorLocation,
-        ciNewClassMethods :: FiniteMap Selector SelectorLocation
+        ciInstanceMethods :: Map.Map Selector SelectorLocation,
+        ciClassMethods :: Map.Map Selector SelectorLocation,
+        ciNewInstanceMethods :: Map.Map Selector SelectorLocation,
+        ciNewClassMethods :: Map.Map Selector SelectorLocation
     }
     deriving(Show)
     
@@ -63,9 +64,9 @@
         ciSuper = fmap nameToUppercase super,
         ciProtocols = mkSet (map nameToUppercase protocols),
         ciDefinedIn = moduleName,
-        ciInstanceMethods = listToFM [ (sel, SelectorLocation moduleName moduleName)
+        ciInstanceMethods = Map.fromList [ (sel, SelectorLocation moduleName moduleName)
                                      | InstanceMethod sel <- methods ],
-        ciClassMethods = listToFM [ (sel, SelectorLocation moduleName moduleName)
+        ciClassMethods = Map.fromList [ (sel, SelectorLocation moduleName moduleName)
                                   | ClassMethod sel <- methods ],
         ciNewProtocols = error "ciNewProtocols 1",
         ciNewInstanceMethods = error "ciNewInstanceMethods 1",
@@ -78,9 +79,9 @@
         ciSuper = Nothing,
         ciProtocols = mkSet (map nameToUppercase protocols),
         ciDefinedIn = moduleName,
-        ciInstanceMethods = listToFM [ (sel, SelectorLocation moduleName cantHappen)
+        ciInstanceMethods = Map.fromList [ (sel, SelectorLocation moduleName cantHappen)
                                      | InstanceMethod sel <- methods ],
-        ciClassMethods = listToFM [ (sel, SelectorLocation moduleName cantHappen)
+        ciClassMethods = Map.fromList [ (sel, SelectorLocation moduleName cantHappen)
                                   | ClassMethod sel <- methods ],
         ciNewProtocols = error "ciNewProtocols 2",
         ciNewInstanceMethods = error "ciNewInstanceMethods 2",
@@ -162,35 +163,35 @@
 cleanClassInfo' info mbSuperInfo protocolInfos
     | ciProtocol info =
         info {
-            ciInstanceMethods = foldl1 plusFM $
+            ciInstanceMethods = foldl1 (flip Map.union) $
                                 map ciInstanceMethods $
                                 info : protocolInfos,
-            ciClassMethods = foldl1 plusFM $
+            ciClassMethods = foldl1 (flip Map.union) $
                              map ciClassMethods $
                              info : protocolInfos,
             ciNewInstanceMethods =
-                ciInstanceMethods info `minusFM`
+                ciInstanceMethods info `Map.difference`
                 (unionProtocols ciInstanceMethods),
             ciNewClassMethods =
-                ciClassMethods info `minusFM`
+                ciClassMethods info `Map.difference`
                 (unionProtocols ciClassMethods),
             ciProtocols = ciProtocols info `union` protocolsAdoptedByAdoptedProtocols,
             ciNewProtocols = ciProtocols info `minusSet` protocolsAdoptedByAdoptedProtocols
         }
     | otherwise =
         info {
-            ciInstanceMethods = foldl1 plusFM $
+            ciInstanceMethods = foldl1 (flip Map.union) $
                                 map ciInstanceMethods $
                                 info : (maybeToList mbSuperInfo) ++ protocolInfos,
-            ciClassMethods = foldl1 plusFM $
+            ciClassMethods = foldl1 (flip Map.union) $
                              map ciClassMethods $
                              info : (maybeToList mbSuperInfo) ++ protocolInfos,
-            ciNewInstanceMethods = (ciInstanceMethods info `plusFM_proto`
+            ciNewInstanceMethods = (ciInstanceMethods info `add_protocol`
                                        (unionProtocols ciInstanceMethods))
-                                   `minusFM` super ciInstanceMethods,
-            ciNewClassMethods = (ciClassMethods info `plusFM_proto`
+                                   `Map.difference` super ciInstanceMethods,
+            ciNewClassMethods = (ciClassMethods info `add_protocol`
                                     (unionProtocols ciClassMethods))
-                                `minusFM` super ciClassMethods,
+                                `Map.difference` super ciClassMethods,
             ciProtocols = ciProtocols info
                           `union` protocolsAdoptedByAdoptedProtocols
                           `union` protocolsAdoptedBySuper,
@@ -201,10 +202,10 @@
         where
             super extract = case mbSuperInfo of
                 Just superInfo -> extract superInfo
-                Nothing -> emptyFM
-            unionProtocols extract = foldl plusFM emptyFM $
+                Nothing -> Map.empty
+            unionProtocols extract = foldl (flip Map.union) Map.empty $
                                      map extract protocolInfos
-            plusFM_proto cls proto = plusFM_C (\(SelectorLocation _ inst)
+            add_protocol cls proto = Map.unionWith (\(SelectorLocation _ inst)
                                                 (SelectorLocation def _)
                                               -> SelectorLocation def {-inst-} (ciDefinedIn info))
                                       -- * All selectors that are part of a protocol
@@ -214,8 +215,8 @@
                                       -- Otherwise, the context for the protocol instance declaration
                                       -- won't be available when the protocol is adopted.
                                               cls
-                                              (mapFM (\sel (SelectorLocation def _)
-                                                     -> SelectorLocation def (ciDefinedIn info))
+                                              (Map.map (\(SelectorLocation def _)
+                                                     -> (SelectorLocation def (ciDefinedIn info)))
                                                      proto)
             protocolsAdoptedByAdoptedProtocols = unionManySets $
                                       map ciProtocols $
@@ -242,7 +243,7 @@
                      | (mod, SelectorList (Interface name _ _) _) <- allDecls ]
         (enumNamesAndLocations, enumDefinitions) = extractEnums bindingScript modules
         
-        typeEnv = TypeEnvironment $ listToFM $
+        typeEnv = TypeEnvironment $ Map.fromList $
                   classNames ++ [ (name, (PlainTypeName, mod))
                                 | (name, mod) <- enumNamesAndLocations
                                                  ++ bsAdditionalTypes bindingScript ]
@@ -285,18 +286,18 @@
                             }
                   funDecl _ = Nothing
                   
-        extractDecls f = listToFM $
+        extractDecls f = Map.fromList $
                          map (\(HeaderInfo mod _ decls) -> (mod, mapMaybe f decls)) $ 
                          modules
     
         mangleSelectors factory clsName sels =
             mapMaybe (\(sel, location) -> do {- Maybe -}
                     let name = selName sel
-                        mapped = lookupFM (soNameMappings selectorOptions) name
+                        mapped = Map.lookup name (soNameMappings selectorOptions)
                         mangled = case mapped of
                                     Just x -> x
                                     Nothing -> mangleSelectorName name
-                        replacement = lookupFM (soChangedSelectors selectorOptions) name
+                        replacement = Map.lookup name (soChangedSelectors selectorOptions)
                         sel' = case replacement of
                             Just x -> x
                             Nothing -> sel
@@ -320,7 +321,7 @@
                             msMangled = mangled,
                             msType = typ
                         }, location)
-                ) $ fmToList sels
+                ) $ Map.toList sels
             where
                 selectorOptions = getSelectorOptions bindingScript clsName
     
@@ -334,3 +335,6 @@
                  pdExternFunDeclarations = externFunDeclarations,
                  pdTypeEnvironment = typeEnv
              }
+
+addListToFM_C c m kvs = foldl' add m kvs
+  where add m' (k,v) = Map.insertWith (flip c) k v m'

Index: Enums.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Enums.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- Enums.hs	29 Jul 2005 03:39:44 -0000	1.4
+++ Enums.hs	5 Oct 2005 02:55:49 -0000	1.5
@@ -13,12 +13,12 @@
 
 import Data.Char        ( toUpper )
 import Data.Maybe       ( mapMaybe )
-import Data.FiniteMap   ( FiniteMap, listToFM )
+import qualified Data.Map as Map   ( Map, fromList )
 import Data.Set         ( Set, mkSet, elementOf )
 import Text.PrettyPrint.HughesPJ
 import Debug.Trace
 
-extractEnums :: BindingScript -> [HeaderInfo] -> ([(String, ModuleName)], FiniteMap ModuleName [EnumType])
+extractEnums :: BindingScript -> [HeaderInfo] -> ([(String, ModuleName)], Map.Map ModuleName [EnumType])
 
 data EnumType = EnumType (Maybe String) [(String, Integer)] deriving(Show)
 
@@ -26,7 +26,7 @@
 
 extractEnums bs headers =
         ( [ (name, mod) | (mod, types) <- enums, Just name <- map enumName types ]
-        , listToFM enums
+        , Map.fromList enums
         )
     where enums = [ (moduleName, mapMaybe (filterEnumType bs . extractEnumType) decls)
                   | HeaderInfo moduleName _ decls <- headers ]

Index: ExportModule.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/ExportModule.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- ExportModule.hs	27 Sep 2005 11:55:22 -0000	1.8
+++ ExportModule.hs	5 Oct 2005 02:55:49 -0000	1.9
@@ -18,7 +18,7 @@
 import qualified Data.HashTable as HashTable
 import Data.List(nub, partition, isPrefixOf)
 import Data.Maybe(fromMaybe, catMaybes, mapMaybe, maybeToList, isNothing)
-import Data.FiniteMap(lookupFM, lookupWithDefaultFM)
+import qualified Data.Map as Map (lookup, findWithDefault) 
 import Text.PrettyPrint.HughesPJ
 
 getModuleDependencies :: PreparedDeclarations -> ModuleName -> IO [ModuleName]
@@ -187,8 +187,8 @@
                                   | proto <- setToList $ ciNewProtocols ci]
                                 | ci <- definedClassInfos, not (ciProtocol ci) ]
                                 
-        varDeclarations = lookupWithDefaultFM allVarDeclarations [] moduleName
-        funDeclarations = lookupWithDefaultFM allFunDeclarations [] moduleName
+        varDeclarations = Map.findWithDefault [] moduleName allVarDeclarations
+        funDeclarations = Map.findWithDefault [] moduleName allFunDeclarations
             
     let mentionedTypeNames = nub $
             concatMap (mentionedTypes.msType) (selDefinitions ++ funDeclarations)
@@ -231,7 +231,7 @@
                                      <- additionalCodeAboveForward
                                         ++ additionalCodeBelowForward ]
 
-    let enumDefinitions = fromMaybe [] $ lookupFM allEnumDefinitions moduleName
+    let enumDefinitions = fromMaybe [] $ Map.lookup moduleName allEnumDefinitions
 
     let anythingGoingOn = not $ and [null methodInstances,
                                      null exportedClasses,

Index: Main.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/Main.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- Main.hs	27 Sep 2005 11:55:22 -0000	1.7
+++ Main.hs	5 Oct 2005 02:55:49 -0000	1.8
@@ -2,7 +2,7 @@
 
 import Control.Exception(evaluate)
 
-import Data.FiniteMap
+import qualified Data.Map as Map
 import qualified Data.HashTable as HashTable
 import Data.List(isPrefixOf,isSuffixOf,partition)
 import Data.Maybe(fromMaybe,mapMaybe,isJust,isNothing,catMaybes,maybeToList)
@@ -24,7 +24,7 @@
 
 
 writeMasterModule masterModuleName realModuleNames selNamesList = do
-    let conflictingDecls = listToFM $
+    let conflictingDecls = Map.fromList $
                            map (\(mod,sels) -> (mod, concatMap idsForSel sels)) $
                            groupByFirst $
                            concatMap (\(selName,(cnt,exporters)) ->
@@ -33,7 +33,7 @@
                                                else []
                                      ) $
                            selNamesList
-        hidingClause mod = case lookupFM conflictingDecls mod of
+        hidingClause mod = case Map.lookup mod conflictingDecls of
             Just decls -> text "hiding" <+> parens (sep $ punctuate comma $ map text $ decls)
             Nothing -> empty
         

Index: CTypeToHaskell.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/CTypeToHaskell.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- CTypeToHaskell.hs	27 Sep 2005 11:55:22 -0000	1.7
+++ CTypeToHaskell.hs	5 Oct 2005 02:55:49 -0000	1.8
@@ -20,7 +20,7 @@
 import HOC.NameCaseChange
 
 import Control.Monad(when)
-import Data.FiniteMap
+import qualified Data.Map as Map
 import Data.Maybe(mapMaybe)
 import Text.PrettyPrint
 
@@ -29,24 +29,24 @@
 data TypeNameKind = ClassTypeName | PlainTypeName
     deriving (Show)
 
-newtype TypeEnvironment = TypeEnvironment (FiniteMap String (TypeNameKind, ModuleName))
+newtype TypeEnvironment = TypeEnvironment (Map.Map String (TypeNameKind, ModuleName))
     -- (Set String) -- known classes
     -- (Set String) -- other known types
 
 isClassType (TypeEnvironment env) name =
-    case lookupFM env (nameToUppercase name) of
+    case Map.lookup (nameToUppercase name) env of
         Just (ClassTypeName, _) -> True
         _                       -> False
 isPlainType (TypeEnvironment env) name =
-    case lookupFM env (nameToUppercase name) of
+    case Map.lookup (nameToUppercase name) env of
         Just (PlainTypeName, _) -> True
         _                       -> False
         
 typeDefinedIn (TypeEnvironment env) name =
-    case lookupFM env (nameToUppercase name) of
+    case Map.lookup (nameToUppercase name) env of
         Just (_, loc) -> loc
 
-lookupTypeEnv (TypeEnvironment env) name = lookupFM env name
+lookupTypeEnv (TypeEnvironment env) name = Map.lookup name env
 
 data HTypeTerm = Con String | HTypeTerm :$ HTypeTerm | Var String
     deriving(Eq,Ord)

Index: BindingScript.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/InterfaceGenerator/BindingScript.hs,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- BindingScript.hs	31 Mar 2005 15:30:19 -0000	1.8
+++ BindingScript.hs	5 Oct 2005 02:55:49 -0000	1.9
@@ -12,8 +12,8 @@
 import qualified Parser(selector)
 
 import Control.Monad(when)
-import Data.FiniteMap
-import Data.Set hiding (map, null)
+import qualified Data.Map as Map
+import Data.Set(Set, union, mkSet, setToList)
 import Data.List(intersperse)
 
 import Text.ParserCombinators.Parsec.Language(haskellStyle)
@@ -25,29 +25,29 @@
         bsHiddenEnums :: Set String,
         bsTopLevelOptions :: SelectorOptions,
         bsAdditionalTypes :: [(String, String)],
-        bsClassSpecificOptions :: FiniteMap String SelectorOptions
+        bsClassSpecificOptions :: Map.Map String SelectorOptions
     }
     
 data SelectorOptions = SelectorOptions {
-        soNameMappings :: FiniteMap String String,
+        soNameMappings :: Map.Map String String,
         soCovariantSelectors :: Set String,
         soHiddenSelectors :: Set String,
-        soChangedSelectors :: FiniteMap String Selector
+        soChangedSelectors :: Map.Map String Selector
     }
     
 getSelectorOptions :: BindingScript -> String -> SelectorOptions
 
 getSelectorOptions bindingScript clsName =
-        case lookupFM (bsClassSpecificOptions bindingScript) clsName of
+        case Map.lookup clsName (bsClassSpecificOptions bindingScript) of
             Just opt -> SelectorOptions {
-                            soNameMappings = soNameMappings top
-                                    `plusFM` soNameMappings opt,
-                            soCovariantSelectors = soCovariantSelectors top
-                                           `union` soCovariantSelectors opt,
-                            soHiddenSelectors = soHiddenSelectors top
-                                        `union` soHiddenSelectors opt,
-                            soChangedSelectors = soChangedSelectors top
-                                        `plusFM` soChangedSelectors opt
+                            soNameMappings = soNameMappings opt
+                                    `Map.union` soNameMappings top,
+                            soCovariantSelectors = soCovariantSelectors opt
+                                           `union` soCovariantSelectors top,
+                            soHiddenSelectors = soHiddenSelectors opt
+                                        `union` soHiddenSelectors top,
+                            soChangedSelectors = soChangedSelectors opt
+                                        `Map.union` soChangedSelectors top
                         }
             Nothing -> top
     where
@@ -78,12 +78,12 @@
 
 extractSelectorOptions statements =
     SelectorOptions {
-            soNameMappings = listToFM [ (objc, haskell)
+            soNameMappings = Map.fromList [ (objc, haskell)
                                       | Rename objc haskell <- statements ],
             soCovariantSelectors = mkSet $ [ ident 
                                            | Covariant ident <- statements ],
             soHiddenSelectors = mkSet $ [ ident | Hide ident <- statements ],
-            soChangedSelectors = listToFM [ (selName sel, sel)
+            soChangedSelectors = Map.fromList [ (selName sel, sel)
                                           | ReplaceSelector sel <- statements ]
     }
 
@@ -144,7 +144,7 @@
             bsHiddenEnums = mkSet [ ident | HideEnum ident <- statements ],
             bsTopLevelOptions = extractSelectorOptions statements,
             bsAdditionalTypes = [ (typ, mod) | Type typ mod <- statements ],
-            bsClassSpecificOptions = listToFM [ (cls, opt)
+            bsClassSpecificOptions = Map.fromList [ (cls, opt)
                                               | ClassSpecific cls opt <- statements ]
         }
 

[hoc-cvs] hoc/Tests TestFoundation.hs,1.6,1.7

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

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

Modified Files:
	TestFoundation.hs 
Log Message:
Add a test for non-outlet instance variables.


Index: TestFoundation.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/Tests/TestFoundation.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- TestFoundation.hs	27 Sep 2005 11:55:22 -0000	1.6
+++ TestFoundation.hs	5 Oct 2005 02:23:19 -0000	1.7
@@ -44,7 +44,6 @@
         Outlet "otherObject" [t| ID () |]
     ])
 
-
 $(declareClass "HaskellObjectWithDescription" "NSObject")
 
 $(exportClass "HaskellObjectWithDescription" "ho2_" [
@@ -56,6 +55,13 @@
         superDesc <- fmap fromNSString $ super self # description
         return $ toNSString $ head (words superDesc) ++ " TEST>"
 
+$(declareClass "HaskellObjectWithIVar" "HaskellObjectWithOutlet")
+
+$(exportClass "HaskellObjectWithIVar" "ho3_" [
+        InstanceVariable "magicNumber" [t| Integer |] [| 0 |]
+    ])
+
+
 $(declareClass "ExceptionThrower" "NSObject")
 
 instance Has_throwHaskellException (ExceptionThrower a)
@@ -142,6 +148,24 @@
                 when (num /= num') $ assert "Different Object returned."
             )
         ],
+        "HaskellObjectWithIVar" ~: test [
+            "alloc-init" ~: (assertNoLeaks $ do
+                _HaskellObjectWithIVar # alloc >>= init >> return ()
+            ),
+            "set-get-superclass" ~: (assertNoLeaks $ do
+                num <- _NSNumber # alloc >>= initWithInt 42
+                hobj <- _HaskellObjectWithIVar # alloc >>= init
+                hobj # setOtherObject num
+                num' <- hobj # otherObject >>= return . castObject
+                when (num /= num') $ assert "Different Object returned."
+            ),
+            "set-get" ~: (assertNoLeaks $ do
+                hobj <- _HaskellObjectWithIVar # alloc >>= init
+                hobj # setIVar _magicNumber 42
+                answer <- hobj # getIVar _magicNumber
+                when (answer /= 42) $ assert "Different Value returned."
+            )
+        ],
         "Memory" ~: test [
             "NSMutableArray-Circle" ~: (assertNoLeaks $ do
                 array1 <- _NSMutableArray # alloc >>= Foundation.NSObject.init
@@ -231,5 +255,6 @@
 main = do
     initializeClass_HaskellObjectWithOutlet
     initializeClass_HaskellObjectWithDescription
+    initializeClass_HaskellObjectWithIVar
     initializeClass_ExceptionThrower
     go

[hoc-cvs] hoc/Bindings/AdditionalCode/Foundation NSRange.hs,NONE,1.1

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

Update of /cvsroot/hoc/hoc/Bindings/AdditionalCode/Foundation
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23176/AdditionalCode/Foundation

Added Files:
	NSRange.hs 
Log Message:
Add support for NSRange.
Contributed by Matthew Morgan <mat...@gm...>


--- NEW FILE: NSRange.hs ---
-- above NSRange
-- CUT HERE
-- below NSRange
-- CUT HERE
-- above NSRange.Forward
--X NSRange(..)
--X nsMaxRange
--X nsLocationInRange
--X nsNotFound

import HOC.FFICallInterface
import HOC.Arguments
import Foreign
import Foreign.C.Types
-- CUT HERE
-- below NSRange.Forward

data NSRange = NSRange CUInt CUInt  deriving(Read, Show, Eq)

nsMaxRange (NSRange loc len) = loc + len
nsLocationInRange x (NSRange loc len) = x >= loc && x < loc+len
nsNotFound = 0x7fffffff :: CUInt

instance Storable NSRange where
    alignment _ = alignment (undefined :: CUInt)
    sizeOf _ = 2 * sizeOf (undefined :: CUInt)
    peek p = do loc <- peekElemOff (castPtr p) 0
                len <- peekElemOff (castPtr p) 1
                return (NSRange loc len)
    poke p (NSRange loc len) = do pokeElemOff (castPtr p) 0 loc
                                  pokeElemOff (castPtr p) 1 len


instance FFITypeable NSRange where
    makeFFIType _ = do cuint <- makeFFIType (undefined :: CUInt)
                       makeStructType [cuint, cuint]
    isStructType _ = True

$(declareStorableObjCArgument [t| NSRange |] "{_NSRange=II}")

[hoc-cvs] hoc/Bindings binding-script.txt,1.8,1.9

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

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

Modified Files:
	binding-script.txt 
Log Message:
Add support for NSRange.
Contributed by Matthew Morgan <mat...@gm...>


Index: binding-script.txt
===================================================================
RCS file: /cvsroot/hoc/hoc/Bindings/binding-script.txt,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- binding-script.txt	5 Apr 2004 00:04:46 -0000	1.8
+++ binding-script.txt	30 Sep 2005 06:09:18 -0000	1.9
@@ -60,6 +60,7 @@
 type NSPoint Foundation.NSGeometry;
 type NSSize Foundation.NSGeometry;
 type NSRect Foundation.NSGeometry;
+type NSRange Foundation.NSRange;
 
 -- GNUstep specifics:
 rename rawMimeData: rawMimeData_;

[hoc-cvs] hoc/HOC_cbits Invocation.m,1.1.1.1,1.2 Makefile.in,1.8,1.9

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

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

Modified Files:
	Invocation.m Makefile.in 
Log Message:
Missing bits from the previous monster commit: remove logging for exceptions,
and add Exception.m to the Makefile.


Index: Makefile.in
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC_cbits/Makefile.in,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- Makefile.in	3 Aug 2005 18:02:43 -0000	1.8
+++ Makefile.in	27 Sep 2005 12:22:42 -0000	1.9
@@ -11,6 +11,7 @@
 	NewClass.m \
 	RetainedHaskellPart.m \
 	Marshalling.m \
+	Exceptions.m \
 	$(NULL)
 
 dist_srcdir = HOC_cbits

Index: Invocation.m
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC_cbits/Invocation.m,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Invocation.m	27 Oct 2003 16:48:12 -0000	1.1.1.1
+++ Invocation.m	27 Sep 2005 12:22:41 -0000	1.2
@@ -11,7 +11,6 @@
 	NS_DURING
 		ffi_call(cif, fn, rvalue, avalue);
 	NS_HANDLER
-	    NSLog(@"exception: %@", localException);
 		return localException;
 	NS_ENDHANDLER
 	return nil;

[hoc-cvs] hoc/Tests Selectors.hs,NONE,1.1 TestFoundation.hs,1.5,1.6

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

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

Modified Files:
	TestFoundation.hs 
Added Files:
	Selectors.hs 
Log Message:
A monster commit, brought to you by the Greater Toronto Airport Authority
and Czech Airlines.

HOC now supports:

* Marshalling of exceptions
    NSExceptions get marshalled into Haskell exceptions that can be caught
    using Foundation.NSException.catchNS.
    Haskell exceptions get wrapped in a (private) subclass of NSException
    and marshalled back if they re-enter Haskell land.

* importing of extern constants
    $(declareExternConst "NSDeviceRGBColorSpace" [t| NSString () |])

* importing of global functions (e.g. NSRectFill) using HOC marshalling:
    $(declareExternFun "NSRectFill" [t| NSRect -> IO () |])

* ifgen generates constant & function declarations automatically from
  Foundation and AppKit headers.



Index: TestFoundation.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/Tests/TestFoundation.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- TestFoundation.hs	27 Jul 2005 02:36:09 -0000	1.5
+++ TestFoundation.hs	27 Sep 2005 11:55:22 -0000	1.6
@@ -10,6 +10,7 @@
 import Control.Monad        ( when )
 import Control.Exception    ( try, finally )
 
+import Selectors
 
       -- garbage collect and make really sure that finalizers have time to run
 performGCAndWait targetCount time maxRepeat = do
@@ -47,13 +48,30 @@
 $(declareClass "HaskellObjectWithDescription" "NSObject")
 
 $(exportClass "HaskellObjectWithDescription" "ho2_" [
-		InstanceMethod info_description
+        InstanceMethod info_description
     ])
-
+    
 ho2_description self
-	= do
-		superDesc <- fmap fromNSString $ super self # description
-		return $ toNSString $ head (words superDesc) ++ " TEST>"
+    = do
+        superDesc <- fmap fromNSString $ super self # description
+        return $ toNSString $ head (words superDesc) ++ " TEST>"
+
+$(declareClass "ExceptionThrower" "NSObject")
+
+instance Has_throwHaskellException (ExceptionThrower a)
+instance Has_throwNSException (ExceptionThrower a)
+
+$(exportClass "ExceptionThrower" "et_" [
+        InstanceMethod info_throwHaskellException,
+        InstanceMethod info_throwNSException
+    ])
+
+et_throwHaskellException self = fail "Test Exception"
+et_throwNSException self = _NSException # exceptionWithNameReasonUserInfo
+                                        (toNSString "FooBar")
+                                        (toNSString "baz")
+                                        nil
+                            >>= raise
 
 tests = test [
         "NSNumber" ~: test [
@@ -156,26 +174,55 @@
             )            
         ],
         "Super" ~: (assertNoLeaks $ do
-        	hobj <- _HaskellObjectWithDescription # alloc >>= init
-        	str <- hobj # description
-        	fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
+            hobj <- _HaskellObjectWithDescription # alloc >>= init
+            str <- hobj # description
+            fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
         ),
         "structs" ~: test [
-        	"point" ~: (do
-        		let point = NSPoint 6.42 7.42
-        		result <- _NSValue # valueWithPoint point >>= pointValue
-        		result @?= point
-        	),
-        	"size" ~: (do
-        		let size = NSSize 6.42 7.42
-        		result <- _NSValue # valueWithSize size >>= sizeValue
-        		result @?= size
-        	),
-			"rect" ~: (do
-        		let rect = NSRect (NSPoint 1 2) (NSSize 3 4)
-        		result <- _NSValue # valueWithRect rect >>= rectValue
-        		result @?= rect
-        	)
+            "point" ~: (do
+                let point = NSPoint 6.42 7.42
+                result <- _NSValue # valueWithPoint point >>= pointValue
+                result @?= point
+            ),
+            "size" ~: (do
+                let size = NSSize 6.42 7.42
+                result <- _NSValue # valueWithSize size >>= sizeValue
+                result @?= size
+            ),
+            "rect" ~: (do
+                let rect = NSRect (NSPoint 1 2) (NSSize 3 4)
+                result <- _NSValue # valueWithRect rect >>= rectValue
+                result @?= rect
+            )
+        ],
+        "externConstant" ~: (
+            fromNSString nsParseErrorException @?= "NSParseErrorException"
+        ),
+        "externFunction" ~: (do
+            result <- nsStringFromPoint (NSPoint 42 23)
+            fromNSString result @?= "{42, 23}"
+        ),
+        "exceptions" ~: test [
+            "CtoH" ~: (do
+                exc1 <- _NSException # exceptionWithNameReasonUserInfo
+                                        (toNSString "FooBar")
+                                        (toNSString "baz")
+                                        nil
+                result <- (exc1 # raise >> return "No Exception")
+                        `catchNS` \e -> e # name >>= return . fromNSString 
+                result @?= "FooBar"
+            ),
+            "HtoCtoH" ~: (do
+                obj <- _ExceptionThrower # alloc >>= init
+                result <- try (obj # throwHaskellException)
+                show result @?= "Left user error (Test Exception)"
+            ),
+            "CtoHtoCtoH" ~: (do
+                obj <- _ExceptionThrower # alloc >>= init
+                result <- (obj # throwNSException >> return "No Exception")
+                        `catchNS` \e -> e # name >>= return . fromNSString 
+                result @?= "FooBar"
+            )
         ]
     ]
 
@@ -184,4 +231,5 @@
 main = do
     initializeClass_HaskellObjectWithOutlet
     initializeClass_HaskellObjectWithDescription
+    initializeClass_ExceptionThrower
     go

--- NEW FILE: Selectors.hs ---
module Selectors where

import HOC

$(declareSelector "throwHaskellException" [t| IO () |])
$(declareSelector "throwNSException" [t| IO () |])

[hoc-cvs] hoc/HOC HOC.conf.in,1.3,1.4 HOC.hs,1.11,1.12

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

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

Modified Files:
	HOC.conf.in HOC.hs 
Log Message:
A monster commit, brought to you by the Greater Toronto Airport Authority
and Czech Airlines.

HOC now supports:

* Marshalling of exceptions
    NSExceptions get marshalled into Haskell exceptions that can be caught
    using Foundation.NSException.catchNS.
    Haskell exceptions get wrapped in a (private) subclass of NSException
    and marshalled back if they re-enter Haskell land.

* importing of extern constants
    $(declareExternConst "NSDeviceRGBColorSpace" [t| NSString () |])

* importing of global functions (e.g. NSRectFill) using HOC marshalling:
    $(declareExternFun "NSRectFill" [t| NSRect -> IO () |])

* ifgen generates constant & function declarations automatically from
  Foundation and AppKit headers.



Index: HOC.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC.hs,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- HOC.hs	30 Jul 2005 02:41:53 -0000	1.11
+++ HOC.hs	27 Sep 2005 11:55:22 -0000	1.12
@@ -41,6 +41,9 @@
         declareCEnum,
         declareAnonymousCEnum,
         
+        declareExternConst,
+        declareExternFun,
+        
         -- debugging & statistics:
         
         objectMapStatistics
@@ -61,3 +64,5 @@
 import HOC.NewlyAllocated
 import HOC.Super
 import HOC.CEnum
+import HOC.ExternConstants
+import HOC.ExternFunctions

Index: HOC.conf.in
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC.conf.in,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- HOC.conf.in	29 Jul 2005 03:39:43 -0000	1.3
+++ HOC.conf.in	27 Sep 2005 11:55:22 -0000	1.4
@@ -23,7 +23,11 @@
     HOC.NewClass,
     HOC.Super,
     HOC.CEnum,
-    HOC.NameCaseChange
+    HOC.NameCaseChange,
+    HOC.Dyld,
+    HOC.ExternConstants,
+    HOC.Exception,
+    HOC.ExternFunctions
 
 hs-libraries:       "HOC", "HOC_cbits"
 depends:            base, template-haskell