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