basis/cocoa/messages/messages.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov.
   2 ! See https://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 continuations core-graphics.types destructors
   6 generalizations io io.encodings.utf8 kernel layouts libc make math
   7 math.parser namespaces sequences sets specialized-arrays
   8 splitting 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 boa ;
  44
  45 TUPLE: selector-tuple name object ;
  46
  47 : selector-name ( name -- name' )
  48     CHAR: . over index [ 0 > [ "." split1 nip ] when ] when* ;
  49
  50 MEMO: <selector> ( name -- sel )
  51     selector-name f selector-tuple boa ;
  52
  53 : selector ( selector -- alien )
  54     dup object>> expired? [
  55         dup name>> sel_registerName
  56         [ >>object drop ] keep
  57     ] [
  58         object>>
  59     ] if ;
  60
  61 : lookup-selector ( name -- alien )
  62     <selector> selector ;
  63
  64 SYMBOL: objc-methods
  65
  66 objc-methods [ H{ } clone ] initialize
  67
  68 ERROR: no-objc-method name ;
  69
  70 : ?lookup-objc-method ( name -- signature/f )
  71     objc-methods get at ;
  72
  73 : lookup-objc-method ( name -- signature )
  74     [ ?lookup-objc-method ] [ no-objc-method ] ?unless ;
  75
  76 MEMO: make-prepare-send ( selector signature super? -- quot )
  77     [
  78         [ \ <super> , ] when swap <selector> , \ selector ,
  79     ] [ ] make swap second length 2 - '[ _ _ ndip ] ;
  80
  81 MACRO: (send) ( signature selector super? -- quot )
  82     swapd [ make-prepare-send ] 2keep
  83     super-message-senders message-senders ? get at suffix ;
  84
  85 : send ( receiver args... signature selector -- return... ) f (send) ; inline
  86
  87 : super-send ( receiver args... signature selector -- return... ) t (send) ; inline
  88
  89 ! Runtime introspection
  90 SYMBOL: class-init-hooks
  91
  92 class-init-hooks [ H{ } clone ] initialize
  93
  94 : (objc-class) ( name word -- class )
  95     2dup execute [ 2nip ] [
  96         over class-init-hooks get at [ call( -- ) ] when*
  97         2dup execute [ 2nip ] [
  98             drop "No such class: " prepend throw
  99         ] if*
 100     ] if* ; inline
 101
 102 : objc-class ( string -- class )
 103     \ objc_getClass (objc-class) ;
 104
 105 : objc-protocol ( string -- class )
 106     \ objc_getProtocol (objc-class) ;
 107
 108 : objc-meta-class ( string -- class )
 109     \ objc_getMetaClass (objc-class) ;
 110
 111 SYMBOL: objc>alien-types
 112
 113 H{
 114     { "c" c:char }
 115     { "i" c:int }
 116     { "s" c:short }
 117     { "C" c:uchar }
 118     { "I" c:uint }
 119     { "S" c:ushort }
 120     { "f" c:float }
 121     { "d" c:double }
 122     { "B" c:bool }
 123     { "v" c:void }
 124     { "*" c:void* }
 125     { "?" unknown_type }
 126     { "@" id }
 127     { "#" Class }
 128     { ":" SEL }
 129     { "(" c:void* }
 130 }
 131 cell {
 132     { 4 [ H{
 133         { "l" c:long }
 134         { "q" c:longlong }
 135         { "L" c:ulong }
 136         { "Q" c:ulonglong }
 137     } ] }
 138     { 8 [ H{
 139         { "l" long32 }
 140         { "q" long }
 141         { "L" ulong32 }
 142         { "Q" ulong }
 143     } ] }
 144 } case
 145 assoc-union objc>alien-types set-global
 146
 147 SYMBOL: objc>struct-types
 148
 149 H{
 150     { "_NSPoint" NSPoint }
 151     { "NSPoint"  NSPoint }
 152     { "CGPoint"  NSPoint }
 153     { "_NSRect"  NSRect  }
 154     { "NSRect"   NSRect  }
 155     { "CGRect"   NSRect  }
 156     { "_NSSize"  NSSize  }
 157     { "NSSize"   NSSize  }
 158     { "CGSize"   NSSize  }
 159     { "_NSRange" NSRange }
 160     { "NSRange"  NSRange }
 161 } objc>struct-types set-global
 162
 163 ! The transpose of the above map
 164 SYMBOL: alien>objc-types
 165
 166 objc>alien-types get [ swap ] assoc-map
 167 ! A hack...
 168 cell {
 169     { 4 [ H{
 170         { NSPoint    "{_NSPoint=ff}" }
 171         { NSRect     "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
 172         { NSSize     "{_NSSize=ff}" }
 173         { NSRange    "{_NSRange=II}" }
 174         { NSInteger  "i" }
 175         { NSUInteger "I" }
 176         { CGFloat    "f" }
 177     } ] }
 178     { 8 [ H{
 179         { NSPoint    "{CGPoint=dd}" }
 180         { NSRect     "{CGRect={CGPoint=dd}{CGSize=dd}}" }
 181         { NSSize     "{CGSize=dd}" }
 182         { NSRange    "{_NSRange=QQ}" }
 183         { NSInteger  "q" }
 184         { NSUInteger "Q" }
 185         { CGFloat    "d" }
 186     } ] }
 187 } case
 188 assoc-union alien>objc-types set-global
 189
 190 : objc-struct-type ( i string -- ctype )
 191     [ CHAR: = ] 2keep index-from swap subseq
 192     objc>struct-types get at* [ drop void* ] unless ;
 193
 194 ERROR: no-objc-type name ;
 195
 196 : decode-type ( ch -- ctype )
 197     1string
 198     [ objc>alien-types get at ] [ no-objc-type ] ?unless ;
 199
 200 : (parse-objc-type) ( i string -- ctype )
 201     [ [ 1 + ] dip ] [ nth ] 2bi {
 202         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
 203         { [ dup CHAR: ^ = ] [ 3drop void* ] }
 204         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
 205         { [ dup CHAR: [ = ] [ 3drop void* ] }
 206         [ 2nip decode-type ]
 207     } cond ;
 208
 209 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
 210
 211 : method-arg-type ( method i -- type )
 212     method_copyArgumentType
 213     [ utf8 alien>string parse-objc-type ] keep
 214     (free) ;
 215
 216 : method-arg-types ( method -- args )
 217     dup method_getNumberOfArguments <iota>
 218     [ method-arg-type ] with map ;
 219
 220 : method-return-type ( method -- ctype )
 221     method_copyReturnType [ utf8 alien>string ] [ (free) ] bi ;
 222
 223 : method-return-type-parsed ( method -- ctype/f )
 224     method-return-type
 225     [ parse-objc-type ] [ 2drop f ] recover ;
 226
 227 : method-signature ( method -- signature )
 228     [ method-return-type-parsed ] [ method-arg-types ] bi 2array ;
 229
 230 : method-name ( method -- name )
 231     method_getName sel_getName ;
 232
 233 : warn-unknown-objc-method ( classname method-name method -- )
 234     '[
 235         _ write bl
 236         _ "`" dup surround write bl
 237         "has unknown method-return-type:" write bl
 238         _ method-return-type print
 239     ] with-output>error ;
 240
 241 :: register-objc-method ( classname method -- )
 242     method method-signature :> signature
 243     method method-name :> name
 244     classname "." name 3append :> fullname
 245     signature first [
 246         signature cache-stubs
 247         signature name objc-methods get set-at
 248         signature fullname objc-methods get set-at
 249     ] [
 250         classname name method warn-unknown-objc-method
 251     ] if ;
 252
 253 : method-collisions ( -- collisions )
 254     objc-methods get >alist
 255     [ first CHAR: . swap member? ] filter
 256     [ first "." split1 nip ] collect-by
 257     [ values members length 1 > ] filter-values ;
 258
 259 : method-count ( class -- c-direct-array )
 260     0 uint <ref> [ class_copyMethodList (free) ] keep uint deref ;
 261
 262 : each-method-in-class ( class quot: ( classname method -- ) -- )
 263     [
 264         [ class_getName ] keep
 265         0 uint <ref> [ class_copyMethodList ] keep uint deref
 266     ] dip over 0 = [ 4drop ] [
 267         [ void* <c-direct-array> ] dip
 268         [ with each ] [ drop (free) ] 2bi
 269     ] if ; inline
 270
 271 : register-objc-methods ( class -- )
 272     [ register-objc-method ] each-method-in-class ;
 273
 274 : class-exists? ( string -- class ) objc_getClass >boolean ;
 275
 276 : define-objc-class-word ( quot name -- )
 277     [ class-init-hooks get set-at ]
 278     [
 279         [ "cocoa.classes" create-word ] [ '[ _ objc-class ] ] bi
 280         ( -- class ) define-declared
 281     ] bi ;
 282
 283 : import-objc-class ( name quot -- )
 284     2dup swap define-objc-class-word
 285     over class-exists? [ drop ] [ call( -- ) ] if
 286     dup class-exists? [
 287         [ objc_getClass register-objc-methods ]
 288         [ objc_getMetaClass register-objc-methods ] bi
 289     ] [ drop ] if ;
 290
 291 : root-class ( class -- root )
 292     [ class_getSuperclass ] [ root-class ] ?when ;
 293
 294 : objc-class-names ( -- seq )
 295     [
 296         f 0 objc_getClassList
 297         [ Class heap-size * malloc &free ] keep
 298         dupd objc_getClassList void* <c-direct-array>
 299         [ class_getName ] { } map-as
 300     ] with-destructors ;