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 core-graphics.types stack-checker kernel math namespaces make
6 quotations sequences strings words cocoa.runtime cocoa.types io
7 macros memoize io.encodings.utf8 effects layouts libc
8 libc.private lexer init core-foundation fry generalizations
10 QUALIFIED-WITH: alien.c-types c
13 SPECIALIZED-ARRAY: void*
15 : make-sender ( method function -- quot )
16 [ over first , f , , second , \ alien-invoke , ] [ ] make ;
18 : sender-stub ( method function -- word )
19 [ "( sender-stub )" f <word> dup ] 2dip
20 over first large-struct? [ "_stret" append ] when
21 make-sender dup infer define-declared ;
23 SYMBOL: message-senders
24 SYMBOL: super-message-senders
26 message-senders [ H{ } clone ] initialize
27 super-message-senders [ H{ } clone ] initialize
29 : cache-stub ( method assoc function -- )
30 '[ _ sender-stub ] cache drop ;
32 : cache-stubs ( method -- )
33 [ super-message-senders get "objc_msgSendSuper" cache-stub ]
34 [ message-senders get "objc_msgSend" cache-stub ]
37 : <super> ( receiver -- super )
38 [ ] [ object_getClass class_getSuperclass ] bi
39 objc-super <struct-boa> ;
41 TUPLE: selector name object ;
43 MEMO: <selector> ( name -- sel ) f \ selector boa ;
45 : selector ( selector -- alien )
46 dup object>> expired? [
47 dup name>> sel_registerName
48 [ >>object drop ] keep
55 objc-methods [ H{ } clone ] initialize
57 : lookup-method ( selector -- method )
58 dup objc-methods get at
59 [ ] [ "No such method: " prepend throw ] ?if ;
61 MEMO: make-prepare-send ( selector method super? -- quot )
64 swap <selector> , \ selector ,
66 swap second length 2 - '[ _ _ ndip ] ;
68 MACRO: (send) ( selector super? -- quot )
69 [ dup lookup-method ] dip
70 [ make-prepare-send ] 2keep
71 super-message-senders message-senders ? get at
74 : send ( receiver args... selector -- return... ) f (send) ; inline
76 : super-send ( receiver args... selector -- return... ) t (send) ; inline
78 ! Runtime introspection
79 SYMBOL: class-init-hooks
81 class-init-hooks [ H{ } clone ] initialize
83 : (objc-class) ( name word -- class )
84 2dup execute dup [ 2nip ] [
85 drop over class-init-hooks get at [ call( -- ) ] when*
86 2dup execute dup [ 2nip ] [
87 2drop "No such class: " prepend throw
91 : objc-class ( string -- class )
92 \ objc_getClass (objc-class) ;
94 : objc-protocol ( string -- class )
95 \ objc_getProtocol (objc-class) ;
97 : objc-meta-class ( string -- class )
98 \ objc_getMetaClass (objc-class) ;
100 SYMBOL: objc>alien-types
133 assoc-union objc>alien-types set-global
135 SYMBOL: objc>struct-types
138 { "_NSPoint" NSPoint }
139 { "NSPoint" NSPoint }
140 { "CGPoint" NSPoint }
147 { "_NSRange" NSRange }
148 { "NSRange" NSRange }
149 } objc>struct-types set-global
151 ! The transpose of the above map
152 SYMBOL: alien>objc-types
154 objc>alien-types get [ swap ] assoc-map
158 { NSPoint "{_NSPoint=ff}" }
159 { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
160 { NSSize "{_NSSize=ff}" }
161 { NSRange "{_NSRange=II}" }
167 { NSPoint "{CGPoint=dd}" }
168 { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
169 { NSSize "{CGSize=dd}" }
170 { NSRange "{_NSRange=QQ}" }
176 assoc-union alien>objc-types set-global
178 : objc-struct-type ( i string -- ctype )
179 [ CHAR: = ] 2keep index-from swap subseq
180 objc>struct-types get at* [ drop void* ] unless ;
182 ERROR: no-objc-type name ;
184 : decode-type ( ch -- ctype )
185 1string dup objc>alien-types get at
186 [ ] [ no-objc-type ] ?if ;
188 : (parse-objc-type) ( i string -- ctype )
189 [ [ 1 + ] dip ] [ nth ] 2bi {
190 { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
191 { [ dup CHAR: ^ = ] [ 3drop void* ] }
192 { [ dup CHAR: { = ] [ drop objc-struct-type ] }
193 { [ dup CHAR: [ = ] [ 3drop void* ] }
197 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
199 : method-arg-type ( method i -- type )
200 method_copyArgumentType
201 [ utf8 alien>string parse-objc-type ] keep
204 : method-arg-types ( method -- args )
205 dup method_getNumberOfArguments
206 [ method-arg-type ] with map ;
208 : method-return-type ( method -- ctype )
209 method_copyReturnType
210 [ utf8 alien>string parse-objc-type ] keep
213 : register-objc-method ( method -- )
214 dup method-return-type over method-arg-types 2array
216 swap method_getName sel_getName
217 objc-methods get set-at ;
219 : each-method-in-class ( class quot -- )
220 [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
222 [ <direct-void*-array> ] dip
223 [ each ] [ drop (free) ] 2bi
226 : register-objc-methods ( class -- )
227 [ register-objc-method ] each-method-in-class ;
229 : class-exists? ( string -- class ) objc_getClass >boolean ;
231 : define-objc-class-word ( quot name -- )
232 [ class-init-hooks get set-at ]
234 [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
235 (( -- class )) define-declared
238 : import-objc-class ( name quot -- )
239 over define-objc-class-word
240 [ objc-class register-objc-methods ]
241 [ objc-meta-class register-objc-methods ] bi ;
243 : root-class ( class -- root )
244 dup class_getSuperclass [ root-class ] [ ] ?if ;