Updating code to use with-out-parameters

[factor.git] / basis / cocoa / messages / messages.factor

diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
old mode 100755 (executable)
new mode 100644 (file)
index 7342451..029b3f4
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -1,13 +1,16 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.strings arrays assocs
-classes.struct continuations combinators compiler compiler.alien
-stack-checker kernel math namespaces make quotations sequences
-strings words cocoa.runtime io macros memoize io.encodings.utf8
-effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays.alien ;
+USING: accessors alien alien.c-types alien.data alien.strings
+arrays assocs classes.struct continuations combinators compiler
+core-graphics.types stack-checker kernel math namespaces make
+quotations sequences strings words cocoa.runtime cocoa.types io
+macros memoize io.encodings.utf8 effects layouts libc lexer init
+core-foundation fry generalizations specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
 IN: cocoa.messages
 
+SPECIALIZED-ARRAY: void*
+
 : make-sender ( method function -- quot )
     [ over first , f , , second , \ alien-invoke , ] [ ] make ;
 
@@ -96,75 +99,84 @@ class-init-hooks [ H{ } clone ] initialize
 SYMBOL: objc>alien-types
 
 H{
-    { "c" "char" }
-    { "i" "int" }
-    { "s" "short" }
-    { "C" "uchar" }
-    { "I" "uint" }
-    { "S" "ushort" }
-    { "f" "float" }
-    { "d" "double" }
-    { "B" "bool" }
-    { "v" "void" }
-    { "*" "char*" }
-    { "?" "unknown_type" }
-    { "@" "id" }
-    { "#" "Class" }
-    { ":" "SEL" }
+    { "c" c:char }
+    { "i" c:int }
+    { "s" c:short }
+    { "C" c:uchar }
+    { "I" c:uint }
+    { "S" c:ushort }
+    { "f" c:float }
+    { "d" c:double }
+    { "B" c:bool }
+    { "v" c:void }
+    { "*" c:c-string }
+    { "?" unknown_type }
+    { "@" id }
+    { "#" Class }
+    { ":" SEL }
 }
-"ptrdiff_t" heap-size {
+cell {
     { 4 [ H{
-        { "l" "long" }
-        { "q" "longlong" }
-        { "L" "ulong" }
-        { "Q" "ulonglong" }
+        { "l" c:long }
+        { "q" c:longlong }
+        { "L" c:ulong }
+        { "Q" c:ulonglong }
     } ] }
     { 8 [ H{
-        { "l" "long32" }
-        { "q" "long" }
-        { "L" "ulong32" }
-        { "Q" "ulong" }
+        { "l" long32 }
+        { "q" long }
+        { "L" ulong32 }
+        { "Q" ulong }
     } ] }
 } case
 assoc-union objc>alien-types set-global
 
+SYMBOL: objc>struct-types
+
+H{
+    { "_NSPoint" NSPoint }
+    { "NSPoint"  NSPoint }
+    { "CGPoint"  NSPoint }
+    { "_NSRect"  NSRect  }
+    { "NSRect"   NSRect  }
+    { "CGRect"   NSRect  }
+    { "_NSSize"  NSSize  }
+    { "NSSize"   NSSize  }
+    { "CGSize"   NSSize  }
+    { "_NSRange" NSRange }
+    { "NSRange"  NSRange }
+} objc>struct-types set-global
+
 ! The transpose of the above map
 SYMBOL: alien>objc-types
 
 objc>alien-types get [ swap ] assoc-map
 ! A hack...
-"ptrdiff_t" heap-size {
+cell {
     { 4 [ H{
-        { "NSPoint"    "{_NSPoint=ff}" }
-        { "NSRect"     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
-        { "NSSize"     "{_NSSize=ff}" }
-        { "NSRange"    "{_NSRange=II}" }
-        { "NSInteger"  "i" }
-        { "NSUInteger" "I" }
-        { "CGFloat"    "f" }
+        { NSPoint    "{_NSPoint=ff}" }
+        { NSRect     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+        { NSSize     "{_NSSize=ff}" }
+        { NSRange    "{_NSRange=II}" }
+        { NSInteger  "i" }
+        { NSUInteger "I" }
+        { CGFloat    "f" }
     } ] }
     { 8 [ H{
-        { "NSPoint"    "{CGPoint=dd}" }
-        { "NSRect"     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
-        { "NSSize"     "{CGSize=dd}" }
-        { "NSRange"    "{_NSRange=QQ}" }
-        { "NSInteger"  "q" }
-        { "NSUInteger" "Q" }
-        { "CGFloat"    "d" }
+        { NSPoint    "{CGPoint=dd}" }
+        { NSRect     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+        { NSSize     "{CGSize=dd}" }
+        { NSRange    "{_NSRange=QQ}" }
+        { NSInteger  "q" }
+        { NSUInteger "Q" }
+        { CGFloat    "d" }
     } ] }
 } case
 assoc-union alien>objc-types set-global
 
-: internal-cocoa-type? ( c-type -- ? )
-    [ "?" = ] [ first CHAR: _ = ] bi or ;
-
-: warn-c-type ( c-type -- )
-    dup internal-cocoa-type?
-    [ drop ] [ "Warning: no such C type: " write print ] if ;
-
 : objc-struct-type ( i string -- ctype )
     [ CHAR: = ] 2keep index-from swap subseq
-    dup c-types get key? [ warn-c-type "void*" ] unless ;
+    objc>struct-types get at* [ drop void* ] unless ;
 
 ERROR: no-objc-type name ;
 
@@ -175,9 +187,9 @@ ERROR: no-objc-type name ;
 : (parse-objc-type) ( i string -- ctype )
     [ [ 1 + ] dip ] [ nth ] 2bi {
         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
-        { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
+        { [ dup CHAR: ^ = ] [ 3drop void* ] }
         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
-        { [ dup CHAR: [ = ] [ 3drop "void*" ] }
+        { [ dup CHAR: [ = ] [ 3drop void* ] }
         [ 2nip decode-type ]
     } cond ;
 
@@ -189,7 +201,7 @@ ERROR: no-objc-type name ;
     (free) ;
 
 : method-arg-types ( method -- args )
-    dup method_getNumberOfArguments
+    dup method_getNumberOfArguments iota
     [ method-arg-type ] with map ;
 
 : method-return-type ( method -- ctype )
@@ -204,7 +216,7 @@ ERROR: no-objc-type name ;
     objc-methods get set-at ;
 
 : each-method-in-class ( class quot -- )
-    [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
+    [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
     over 0 = [ 3drop ] [
         [ <direct-void*-array> ] dip
         [ each ] [ drop (free) ] 2bi
@@ -223,9 +235,12 @@ ERROR: no-objc-type name ;
     ] bi ;
 
 : import-objc-class ( name quot -- )
-    over define-objc-class-word
-    [ objc-class register-objc-methods ]
-    [ objc-meta-class register-objc-methods ] bi ;
+    2dup swap define-objc-class-word
+    over class-exists? [ drop ] [ call( -- ) ] if
+    dup class-exists? [
+        [ objc_getClass register-objc-methods ]
+        [ objc_getMetaClass register-objc-methods ] bi
+    ] [ drop ] if ;
 
 : root-class ( class -- root )
     dup class_getSuperclass [ root-class ] [ ] ?if ;