basis/cocoa/messages/messages.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.strings arrays assocs
   4 combinators compiler kernel math namespaces make parser
   5 prettyprint prettyprint.sections quotations sequences strings
   6 words cocoa.runtime io macros memoize debugger
   7 io.encodings.ascii effects compiler.generator libc libc.private
   8 parser lexer init core-foundation ;
   9 IN: cocoa.messages
  10
  11 : make-sender ( method function -- quot )
  12     [ over first , f , , second , \ alien-invoke , ] [ ] make ;
  13
  14 : sender-stub-name ( method function -- string )
  15     [ % "_" % unparse % ] "" make ;
  16
  17 : sender-stub ( method function -- word )
  18     [ sender-stub-name f <word> dup ] 2keep
  19     over first large-struct? [ "_stret" append ] when
  20     make-sender define ;
  21
  22 SYMBOL: message-senders
  23 SYMBOL: super-message-senders
  24
  25 message-senders global [ H{ } assoc-like ] change-at
  26 super-message-senders global [ H{ } assoc-like ] change-at
  27
  28 : cache-stub ( method function hash -- )
  29     [
  30         over get [ 2drop ] [ over >r sender-stub r> set ] if
  31     ] bind ;
  32
  33 : cache-stubs ( method -- )
  34     dup
  35     "objc_msgSendSuper" super-message-senders get cache-stub
  36     "objc_msgSend" message-senders get cache-stub ;
  37
  38 : <super> ( receiver -- super )
  39     "objc-super" <c-object> [
  40         >r dup object_getClass class_getSuperclass r>
  41         set-objc-super-class
  42     ] keep
  43     [ set-objc-super-receiver ] keep ;
  44
  45 TUPLE: selector name object ;
  46
  47 MEMO: <selector> ( name -- sel ) f \ selector 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 SYMBOL: objc-methods
  58
  59 objc-methods global [ H{ } assoc-like ] change-at
  60
  61 : lookup-method ( selector -- method )
  62     dup objc-methods get at
  63     [ ] [ "No such method: " prepend throw ] ?if ;
  64
  65 : make-dip ( quot n -- quot' )
  66     dup
  67     \ >r <repetition> >quotation -rot
  68     \ r> <repetition> >quotation 3append ;
  69
  70 MEMO: make-prepare-send ( selector method super? -- quot )
  71     [
  72         [ \ <super> , ] when
  73         swap <selector> , \ selector ,
  74     ] [ ] make
  75     swap second length 2 - make-dip ;
  76
  77 MACRO: (send) ( selector super? -- quot )
  78     >r dup lookup-method r>
  79     [ make-prepare-send ] 2keep
  80     super-message-senders message-senders ? get at
  81     [ slip execute ] 2curry ;
  82
  83 : send ( receiver args... selector -- return... ) f (send) ; inline
  84
  85 \ send soft "break-after" set-word-prop
  86
  87 : super-send ( receiver args... selector -- return... ) t (send) ; inline
  88
  89 \ super-send soft "break-after" set-word-prop
  90
  91 ! Runtime introspection
  92 : (objc-class) ( string word -- class )
  93     dupd execute
  94     [ ] [ "No such class: " prepend throw ] ?if ; inline
  95
  96 : objc-class ( string -- class )
  97     \ objc_getClass (objc-class) ;
  98
  99 : objc-protocol ( string -- class )
 100     \ objc_getProtocol (objc-class) ;
 101
 102 : objc-meta-class ( string -- class )
 103     \ objc_getMetaClass (objc-class) ;
 104
 105 SYMBOL: objc>alien-types
 106
 107 H{
 108     { "c" "char" }
 109     { "i" "int" }
 110     { "s" "short" }
 111     { "l" "long" }
 112     { "q" "longlong" }
 113     { "C" "uchar" }
 114     { "I" "uint" }
 115     { "S" "ushort" }
 116     { "L" "ulong" }
 117     { "Q" "ulonglong" }
 118     { "f" "float" }
 119     { "d" "double" }
 120     { "B" "bool" }
 121     { "v" "void" }
 122     { "*" "char*" }
 123     { "@" "id" }
 124     { "#" "id" }
 125     { ":" "SEL" }
 126 } objc>alien-types set-global
 127
 128 ! The transpose of the above map
 129 SYMBOL: alien>objc-types
 130
 131 objc>alien-types get [ swap ] assoc-map
 132 ! A hack...
 133 "ptrdiff_t" heap-size {
 134     { 4 [ H{
 135         { "NSPoint" "{_NSPoint=ff}" }
 136         { "NSRect" "{_NSRect=ffff}" }
 137         { "NSSize" "{_NSSize=ff}" }
 138         { "NSRange" "{_NSRange=II}" }
 139     } ] }
 140     { 8 [ H{
 141         { "NSPoint" "{_NSPoint=dd}" }
 142         { "NSRect" "{_NSRect=dddd}" }
 143         { "NSSize" "{_NSSize=dd}" }
 144         { "NSRange" "{_NSRange=QQ}" }
 145     } ] }
 146 } case
 147 assoc-union alien>objc-types set-global
 148
 149 : objc-struct-type ( i string -- ctype )
 150     2dup CHAR: = -rot index-from swap subseq
 151     dup c-types get key? [
 152         "Warning: no such C type: " write dup print
 153         drop "void*"
 154     ] unless ;
 155
 156 : (parse-objc-type) ( i string -- ctype )
 157     2dup nth >r >r 1+ r> r> {
 158         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
 159         { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
 160         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
 161         { [ dup CHAR: [ = ] [ 3drop "void*" ] }
 162         [ 2nip 1string objc>alien-types get at ]
 163     } cond ;
 164
 165 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
 166
 167 : method-arg-type ( method i -- type )
 168     method_copyArgumentType
 169     [ ascii alien>string parse-objc-type ] keep
 170     (free) ;
 171
 172 : method-arg-types ( method -- args )
 173     dup method_getNumberOfArguments
 174     [ method-arg-type ] with map ;
 175
 176 : method-return-type ( method -- ctype )
 177     method_copyReturnType
 178     [ ascii alien>string parse-objc-type ] keep
 179     (free) ;
 180
 181 : register-objc-method ( method -- )
 182     dup method-return-type over method-arg-types 2array
 183     dup cache-stubs
 184     swap method_getName sel_getName
 185     objc-methods get set-at ;
 186
 187 : (register-objc-methods) ( methods count -- methods )
 188     over [ void*-nth register-objc-method ] curry each ;
 189
 190 : register-objc-methods ( class -- )
 191     0 <uint> [ class_copyMethodList ] keep *uint
 192     (register-objc-methods) (free) ;
 193
 194 : class-exists? ( string -- class ) objc_getClass >boolean ;
 195
 196 : unless-defined ( class quot -- )
 197     >r class-exists? r> unless ; inline
 198
 199 : define-objc-class-word ( name quot -- )
 200     [
 201         over , , \ unless-defined , dup , \ objc-class ,
 202     ] [ ] make >r "cocoa.classes" create r>
 203     (( -- class )) define-declared ;
 204
 205 : import-objc-class ( name quot -- )
 206     2dup unless-defined
 207     dupd define-objc-class-word
 208     [
 209         dup
 210         objc-class register-objc-methods
 211         objc-meta-class register-objc-methods
 212     ] curry try ;
 213
 214 : root-class ( class -- root )
 215     dup class_getSuperclass [ root-class ] [ ] ?if ;