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
12 SPECIALIZED-ARRAY: void*
14 : make-sender ( signature function -- quot )
15 [ over first , f , , second , f , \ alien-invoke , ] [ ] make ;
17 : sender-stub-name ( signature -- str )
19 [ name>> ] map "," join "(" ")" surround
20 ] bi* append "( sender-stub:" " )" surround ;
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 ;
27 SYMBOL: message-senders
28 SYMBOL: super-message-senders
30 message-senders [ H{ } clone ] initialize
31 super-message-senders [ H{ } clone ] initialize
33 :: cache-stub ( signature function assoc -- )
34 signature assoc [ function sender-stub ] cache drop ;
36 : cache-stubs ( signature -- )
37 [ "objc_msgSendSuper" super-message-senders get cache-stub ]
38 [ "objc_msgSend" message-senders get cache-stub ]
41 : <super> ( receiver -- super )
42 [ ] [ object_getClass class_getSuperclass ] bi
43 objc-super <struct-boa> ;
45 TUPLE: selector-tuple name object ;
47 MEMO: <selector> ( name -- sel ) f \ selector-tuple boa ;
49 : selector ( selector -- alien )
50 dup object>> expired? [
51 dup name>> sel_registerName
52 [ >>object drop ] keep
57 : lookup-selector ( name -- alien )
62 objc-methods [ H{ } clone ] initialize
64 ERROR: no-objc-method name ;
66 : ?lookup-method ( selector -- method/f )
69 : lookup-method ( selector -- method )
70 dup ?lookup-method [ ] [ no-objc-method ] ?if ;
72 : lookup-sender ( name -- method )
73 lookup-method message-senders get at ;
75 MEMO: make-prepare-send ( selector method super? -- quot )
77 [ \ <super> , ] when swap <selector> , \ selector ,
79 swap second length 2 - '[ _ _ ndip ] ;
81 MACRO: (send) ( selector super? -- quot )
82 [ dup lookup-method ] dip
83 [ make-prepare-send ] 2keep
84 super-message-senders message-senders ? get at
87 : send ( receiver args... selector -- return... ) f (send) ; inline
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* ;
95 : ?send ( receiver args... selector effect -- return... ) f (?send) ; inline
97 : super-send ( receiver args... selector -- return... ) t (send) ; inline
99 ! Runtime introspection
100 SYMBOL: class-init-hooks
102 class-init-hooks [ H{ } clone ] initialize
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
112 : objc-class ( string -- class )
113 \ objc_getClass (objc-class) ;
115 : objc-protocol ( string -- class )
116 \ objc_getProtocol (objc-class) ;
118 : objc-meta-class ( string -- class )
119 \ objc_getMetaClass (objc-class) ;
121 SYMBOL: objc>alien-types
154 assoc-union objc>alien-types set-global
156 SYMBOL: objc>struct-types
159 { "_NSPoint" NSPoint }
160 { "NSPoint" NSPoint }
161 { "CGPoint" NSPoint }
168 { "_NSRange" NSRange }
169 { "NSRange" NSRange }
170 } objc>struct-types set-global
172 ! The transpose of the above map
173 SYMBOL: alien>objc-types
175 objc>alien-types get [ swap ] assoc-map
179 { NSPoint "{_NSPoint=ff}" }
180 { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
181 { NSSize "{_NSSize=ff}" }
182 { NSRange "{_NSRange=II}" }
188 { NSPoint "{CGPoint=dd}" }
189 { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
190 { NSSize "{CGSize=dd}" }
191 { NSRange "{_NSRange=QQ}" }
197 assoc-union alien>objc-types set-global
199 : objc-struct-type ( i string -- ctype )
200 [ CHAR: = ] 2keep index-from swap subseq
201 objc>struct-types get at* [ drop void* ] unless ;
203 ERROR: no-objc-type name ;
205 : decode-type ( ch -- ctype )
206 1string dup objc>alien-types get at
207 [ ] [ no-objc-type ] ?if ;
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* ] }
218 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
220 : method-arg-type ( method i -- type )
221 method_copyArgumentType
222 [ utf8 alien>string parse-objc-type ] keep
225 : method-arg-types ( method -- args )
226 dup method_getNumberOfArguments iota
227 [ method-arg-type ] with map ;
229 : method-return-type ( method -- ctype )
230 method_copyReturnType
231 [ utf8 alien>string parse-objc-type ] keep
234 : method-name ( method -- name )
235 method_getName sel_getName ;
237 : register-objc-method ( method -- )
239 [ [ method-return-type ] [ method-arg-types ] bi 2array ] bi
240 [ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
242 : each-method-in-class ( class quot -- )
243 [ { uint } [ class_copyMethodList ] with-out-parameters ] dip
245 [ void* <c-direct-array> ] dip
246 [ each ] [ drop (free) ] 2bi
249 : register-objc-methods ( class -- )
250 [ register-objc-method ] each-method-in-class ;
252 : class-exists? ( string -- class ) objc_getClass >boolean ;
254 : define-objc-class-word ( quot name -- )
255 [ class-init-hooks get set-at ]
257 [ "cocoa.classes" create-word ] [ '[ _ objc-class ] ] bi
258 ( -- class ) define-declared
261 : import-objc-class ( name quot -- )
262 2dup swap define-objc-class-word
263 over class-exists? [ drop ] [ call( -- ) ] if
265 [ objc_getClass register-objc-methods ]
266 [ objc_getMetaClass register-objc-methods ] bi
269 : root-class ( class -- root )
270 dup class_getSuperclass [ root-class ] [ ] ?if ;