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 , f , \ 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 [ ] [ 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 MACRO:: (?send) ( effect selector super? -- quot )
  90     selector dup ?lookup-method effect or super?
  91     [ make-prepare-send ] 2keep
  92     super-message-senders message-senders ? get at
  93     [ 1quotation append ] [ effect selector sender-stub 1quotation append ] if* ;
  94
  95 : ?send ( receiver args... selector effect -- return... ) f (?send) ; inline
  96
  97 : super-send ( receiver args... selector -- return... ) t (send) ; inline
  98
  99 ! Runtime introspection
 100 SYMBOL: class-init-hooks
 101
 102 class-init-hooks [ H{ } clone ] initialize
 103
 104 : (objc-class) ( name word -- class )
 105     2dup execute [ 2nip ] [
 106         over class-init-hooks get at [ call( -- ) ] when*
 107         2dup execute [ 2nip ] [
 108             drop "No such class: " prepend throw
 109         ] if*
 110     ] if* ; inline
 111
 112 : objc-class ( string -- class )
 113     \ objc_getClass (objc-class) ;
 114
 115 : objc-protocol ( string -- class )
 116     \ objc_getProtocol (objc-class) ;
 117
 118 : objc-meta-class ( string -- class )
 119     \ objc_getMetaClass (objc-class) ;
 120
 121 SYMBOL: objc>alien-types
 122
 123 H{
 124     { "c" c:char }
 125     { "i" c:int }
 126     { "s" c:short }
 127     { "C" c:uchar }
 128     { "I" c:uint }
 129     { "S" c:ushort }
 130     { "f" c:float }
 131     { "d" c:double }
 132     { "B" c:bool }
 133     { "v" c:void }
 134     { "*" c:void* }
 135     { "?" unknown_type }
 136     { "@" id }
 137     { "#" Class }
 138     { ":" SEL }
 139 }
 140 cell {
 141     { 4 [ H{
 142         { "l" c:long }
 143         { "q" c:longlong }
 144         { "L" c:ulong }
 145         { "Q" c:ulonglong }
 146     } ] }
 147     { 8 [ H{
 148         { "l" long32 }
 149         { "q" long }
 150         { "L" ulong32 }
 151         { "Q" ulong }
 152     } ] }
 153 } case
 154 assoc-union objc>alien-types set-global
 155
 156 SYMBOL: objc>struct-types
 157
 158 H{
 159     { "_NSPoint" NSPoint }
 160     { "NSPoint"  NSPoint }
 161     { "CGPoint"  NSPoint }
 162     { "_NSRect"  NSRect  }
 163     { "NSRect"   NSRect  }
 164     { "CGRect"   NSRect  }
 165     { "_NSSize"  NSSize  }
 166     { "NSSize"   NSSize  }
 167     { "CGSize"   NSSize  }
 168     { "_NSRange" NSRange }
 169     { "NSRange"  NSRange }
 170 } objc>struct-types set-global
 171
 172 ! The transpose of the above map
 173 SYMBOL: alien>objc-types
 174
 175 objc>alien-types get [ swap ] assoc-map
 176 ! A hack...
 177 cell {
 178     { 4 [ H{
 179         { NSPoint    "{_NSPoint=ff}" }
 180         { NSRect     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
 181         { NSSize     "{_NSSize=ff}" }
 182         { NSRange    "{_NSRange=II}" }
 183         { NSInteger  "i" }
 184         { NSUInteger "I" }
 185         { CGFloat    "f" }
 186     } ] }
 187     { 8 [ H{
 188         { NSPoint    "{CGPoint=dd}" }
 189         { NSRect     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
 190         { NSSize     "{CGSize=dd}" }
 191         { NSRange    "{_NSRange=QQ}" }
 192         { NSInteger  "q" }
 193         { NSUInteger "Q" }
 194         { CGFloat    "d" }
 195     } ] }
 196 } case
 197 assoc-union alien>objc-types set-global
 198
 199 : objc-struct-type ( i string -- ctype )
 200     [ CHAR: = ] 2keep index-from swap subseq
 201     objc>struct-types get at* [ drop void* ] unless ;
 202
 203 ERROR: no-objc-type name ;
 204
 205 : decode-type ( ch -- ctype )
 206     1string dup objc>alien-types get at
 207     [ ] [ no-objc-type ] ?if ;
 208
 209 : (parse-objc-type) ( i string -- ctype )
 210     [ [ 1 + ] dip ] [ nth ] 2bi {
 211         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
 212         { [ dup CHAR: ^ = ] [ 3drop void* ] }
 213         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
 214         { [ dup CHAR: [ = ] [ 3drop void* ] }
 215         [ 2nip decode-type ]
 216     } cond ;
 217
 218 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
 219
 220 : method-arg-type ( method i -- type )
 221     method_copyArgumentType
 222     [ utf8 alien>string parse-objc-type ] keep
 223     (free) ;
 224
 225 : method-arg-types ( method -- args )
 226     dup method_getNumberOfArguments <iota>
 227     [ method-arg-type ] with map ;
 228
 229 : method-return-type ( method -- ctype )
 230     method_copyReturnType
 231     [ utf8 alien>string parse-objc-type ] keep
 232     (free) ;
 233
 234 : method-name ( method -- name )
 235     method_getName sel_getName ;
 236
 237 : register-objc-method ( method -- )
 238     [ method-name ]
 239     [ [ method-return-type ] [ method-arg-types ] bi 2array ] bi
 240     [ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
 241
 242 : each-method-in-class ( class quot -- )
 243     [ { uint } [ class_copyMethodList ] with-out-parameters ] dip
 244     over 0 = [ 3drop ] [
 245         [ void* <c-direct-array> ] dip
 246         [ each ] [ drop (free) ] 2bi
 247     ] if ; inline
 248
 249 : register-objc-methods ( class -- )
 250     [ register-objc-method ] each-method-in-class ;
 251
 252 : class-exists? ( string -- class ) objc_getClass >boolean ;
 253
 254 : define-objc-class-word ( quot name -- )
 255     [ class-init-hooks get set-at ]
 256     [
 257         [ "cocoa.classes" create-word ] [ '[ _ objc-class ] ] bi
 258         ( -- class ) define-declared
 259     ] bi ;
 260
 261 : import-objc-class ( name quot -- )
 262     2dup swap define-objc-class-word
 263     over class-exists? [ drop ] [ call( -- ) ] if
 264     dup class-exists? [
 265         [ objc_getClass register-objc-methods ]
 266         [ objc_getMetaClass register-objc-methods ] bi
 267     ] [ drop ] if ;
 268
 269 : root-class ( class -- root )
 270     dup class_getSuperclass [ root-class ] [ ] ?if ;