basis/cocoa/messages/messages.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data alien.strings
   4 arrays assocs classes.struct continuations combinators compiler
   5 core-graphics.types stack-checker kernel math namespaces make
   6 quotations sequences strings words cocoa.runtime cocoa.types io
   7 macros memoize io.encodings.utf8 effects layouts libc lexer init
   8 core-foundation fry generalizations specialized-arrays ;
   9 QUALIFIED-WITH: alien.c-types c
  10 IN: cocoa.messages
  11
  12 SPECIALIZED-ARRAY: void*
  13
  14 : make-sender ( method function -- quot )
  15     [ over first , f , , second , \ alien-invoke , ] [ ] make ;
  16
  17 : sender-stub ( method function -- word )
  18     [ "( sender-stub )" f <word> dup ] 2dip
  19     over first large-struct? [ "_stret" append ] when
  20     make-sender dup infer define-declared ;
  21
  22 SYMBOL: message-senders
  23 SYMBOL: super-message-senders
  24
  25 message-senders [ H{ } clone ] initialize
  26 super-message-senders [ H{ } clone ] initialize
  27
  28 : cache-stub ( method assoc function -- )
  29     '[ _ sender-stub ] cache drop ;
  30
  31 : cache-stubs ( method -- )
  32     [ super-message-senders get "objc_msgSendSuper" cache-stub ]
  33     [ message-senders get "objc_msgSend" cache-stub ]
  34     bi ;
  35
  36 : <super> ( receiver -- super )
  37     [ ] [ object_getClass class_getSuperclass ] bi
  38     objc-super <struct-boa> ;
  39
  40 TUPLE: selector name object ;
  41
  42 MEMO: <selector> ( name -- sel ) f \ selector boa ;
  43
  44 : selector ( selector -- alien )
  45     dup object>> expired? [
  46         dup name>> sel_registerName
  47         [ >>object drop ] keep
  48     ] [
  49         object>>
  50     ] if ;
  51
  52 SYMBOL: objc-methods
  53
  54 objc-methods [ H{ } clone ] initialize
  55
  56 : lookup-method ( selector -- method )
  57     dup objc-methods get at
  58     [ ] [ "No such method: " prepend throw ] ?if ;
  59
  60 MEMO: make-prepare-send ( selector method super? -- quot )
  61     [
  62         [ \ <super> , ] when
  63         swap <selector> , \ selector ,
  64     ] [ ] make
  65     swap second length 2 - '[ _ _ ndip ] ;
  66
  67 MACRO: (send) ( selector super? -- quot )
  68     [ dup lookup-method ] dip
  69     [ make-prepare-send ] 2keep
  70     super-message-senders message-senders ? get at
  71     1quotation append ;
  72
  73 : send ( receiver args... selector -- return... ) f (send) ; inline
  74
  75 : super-send ( receiver args... selector -- return... ) t (send) ; inline
  76
  77 ! Runtime introspection
  78 SYMBOL: class-init-hooks
  79
  80 class-init-hooks [ H{ } clone ] initialize
  81
  82 : (objc-class) ( name word -- class )
  83     2dup execute dup [ 2nip ] [
  84         drop over class-init-hooks get at [ call( -- ) ] when*
  85         2dup execute dup [ 2nip ] [
  86             2drop "No such class: " prepend throw
  87         ] if
  88     ] if ; inline
  89
  90 : objc-class ( string -- class )
  91     \ objc_getClass (objc-class) ;
  92
  93 : objc-protocol ( string -- class )
  94     \ objc_getProtocol (objc-class) ;
  95
  96 : objc-meta-class ( string -- class )
  97     \ objc_getMetaClass (objc-class) ;
  98
  99 SYMBOL: objc>alien-types
 100
 101 H{
 102     { "c" c:char }
 103     { "i" c:int }
 104     { "s" c:short }
 105     { "C" c:uchar }
 106     { "I" c:uint }
 107     { "S" c:ushort }
 108     { "f" c:float }
 109     { "d" c:double }
 110     { "B" c:bool }
 111     { "v" c:void }
 112     { "*" c:c-string }
 113     { "?" unknown_type }
 114     { "@" id }
 115     { "#" Class }
 116     { ":" SEL }
 117 }
 118 cell {
 119     { 4 [ H{
 120         { "l" c:long }
 121         { "q" c:longlong }
 122         { "L" c:ulong }
 123         { "Q" c:ulonglong }
 124     } ] }
 125     { 8 [ H{
 126         { "l" long32 }
 127         { "q" long }
 128         { "L" ulong32 }
 129         { "Q" ulong }
 130     } ] }
 131 } case
 132 assoc-union objc>alien-types set-global
 133
 134 SYMBOL: objc>struct-types
 135
 136 H{
 137     { "_NSPoint" NSPoint }
 138     { "NSPoint"  NSPoint }
 139     { "CGPoint"  NSPoint }
 140     { "_NSRect"  NSRect  }
 141     { "NSRect"   NSRect  }
 142     { "CGRect"   NSRect  }
 143     { "_NSSize"  NSSize  }
 144     { "NSSize"   NSSize  }
 145     { "CGSize"   NSSize  }
 146     { "_NSRange" NSRange }
 147     { "NSRange"  NSRange }
 148 } objc>struct-types set-global
 149
 150 ! The transpose of the above map
 151 SYMBOL: alien>objc-types
 152
 153 objc>alien-types get [ swap ] assoc-map
 154 ! A hack...
 155 cell {
 156     { 4 [ H{
 157         { NSPoint    "{_NSPoint=ff}" }
 158         { NSRect     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
 159         { NSSize     "{_NSSize=ff}" }
 160         { NSRange    "{_NSRange=II}" }
 161         { NSInteger  "i" }
 162         { NSUInteger "I" }
 163         { CGFloat    "f" }
 164     } ] }
 165     { 8 [ H{
 166         { NSPoint    "{CGPoint=dd}" }
 167         { NSRect     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
 168         { NSSize     "{CGSize=dd}" }
 169         { NSRange    "{_NSRange=QQ}" }
 170         { NSInteger  "q" }
 171         { NSUInteger "Q" }
 172         { CGFloat    "d" }
 173     } ] }
 174 } case
 175 assoc-union alien>objc-types set-global
 176
 177 : objc-struct-type ( i string -- ctype )
 178     [ CHAR: = ] 2keep index-from swap subseq
 179     objc>struct-types get at* [ drop void* ] unless ;
 180
 181 ERROR: no-objc-type name ;
 182
 183 : decode-type ( ch -- ctype )
 184     1string dup objc>alien-types get at
 185     [ ] [ no-objc-type ] ?if ;
 186
 187 : (parse-objc-type) ( i string -- ctype )
 188     [ [ 1 + ] dip ] [ nth ] 2bi {
 189         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
 190         { [ dup CHAR: ^ = ] [ 3drop void* ] }
 191         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
 192         { [ dup CHAR: [ = ] [ 3drop void* ] }
 193         [ 2nip decode-type ]
 194     } cond ;
 195
 196 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
 197
 198 : method-arg-type ( method i -- type )
 199     method_copyArgumentType
 200     [ utf8 alien>string parse-objc-type ] keep
 201     (free) ;
 202
 203 : method-arg-types ( method -- args )
 204     dup method_getNumberOfArguments iota
 205     [ method-arg-type ] with map ;
 206
 207 : method-return-type ( method -- ctype )
 208     method_copyReturnType
 209     [ utf8 alien>string parse-objc-type ] keep
 210     (free) ;
 211
 212 : register-objc-method ( method -- )
 213     dup method-return-type over method-arg-types 2array
 214     dup cache-stubs
 215     swap method_getName sel_getName
 216     objc-methods get set-at ;
 217
 218 : each-method-in-class ( class quot -- )
 219     [ { uint } [ class_copyMethodList ] [ ] with-out-parameters ] dip
 220     over 0 = [ 3drop ] [
 221         [ <direct-void*-array> ] dip
 222         [ each ] [ drop (free) ] 2bi
 223     ] if ; inline
 224
 225 : register-objc-methods ( class -- )
 226     [ register-objc-method ] each-method-in-class ;
 227
 228 : class-exists? ( string -- class ) objc_getClass >boolean ;
 229
 230 : define-objc-class-word ( quot name -- )
 231     [ class-init-hooks get set-at ]
 232     [
 233         [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
 234         (( -- class )) define-declared
 235     ] bi ;
 236
 237 : import-objc-class ( name quot -- )
 238     2dup swap define-objc-class-word
 239     over class-exists? [ drop ] [ call( -- ) ] if
 240     dup class-exists? [
 241         [ objc_getClass register-objc-methods ]
 242         [ objc_getMetaClass register-objc-methods ] bi
 243     ] [ drop ] if ;
 244
 245 : root-class ( class -- root )
 246     dup class_getSuperclass [ root-class ] [ ] ?if ;