basis/cocoa/messages/messages.factor

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