basis/cocoa/messages/messages.factor

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