basis/cocoa/messages/messages.factor

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