1 ! Copyright (C) 2006, 2010 Slava Pestov.
2 ! See https://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 continuations core-graphics.types destructors
6 generalizations io io.encodings.utf8 kernel layouts libc make math
7 math.parser namespaces sequences sets specialized-arrays
8 splitting 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
45 TUPLE: selector-tuple name object ;
47 : selector-name ( name -- name' )
48 CHAR: . over index [ 0 > [ "." split1 nip ] when ] when* ;
50 MEMO: <selector> ( name -- sel )
51 selector-name f selector-tuple boa ;
53 : selector ( selector -- alien )
54 dup object>> expired? [
55 dup name>> sel_registerName
56 [ >>object drop ] keep
61 : lookup-selector ( name -- alien )
66 objc-methods [ H{ } clone ] initialize
68 ERROR: no-objc-method name ;
70 : ?lookup-objc-method ( name -- signature/f )
73 : lookup-objc-method ( name -- signature )
74 [ ?lookup-objc-method ] [ no-objc-method ] ?unless ;
76 MEMO: make-prepare-send ( selector signature super? -- quot )
78 [ \ <super> , ] when swap <selector> , \ selector ,
79 ] [ ] make swap second length 2 - '[ _ _ ndip ] ;
81 MACRO: (send) ( signature selector super? -- quot )
82 swapd [ make-prepare-send ] 2keep
83 super-message-senders message-senders ? get at suffix ;
85 : send ( receiver args... signature selector -- return... ) f (send) ; inline
87 : super-send ( receiver args... signature selector -- return... ) t (send) ; inline
89 ! Runtime introspection
90 SYMBOL: class-init-hooks
92 class-init-hooks [ H{ } clone ] initialize
94 : (objc-class) ( name word -- class )
95 2dup execute [ 2nip ] [
96 over class-init-hooks get at [ call( -- ) ] when*
97 2dup execute [ 2nip ] [
98 drop "No such class: " prepend throw
102 : objc-class ( string -- class )
103 \ objc_getClass (objc-class) ;
105 : objc-protocol ( string -- class )
106 \ objc_getProtocol (objc-class) ;
108 : objc-meta-class ( string -- class )
109 \ objc_getMetaClass (objc-class) ;
111 SYMBOL: objc>alien-types
145 assoc-union objc>alien-types set-global
147 SYMBOL: objc>struct-types
150 { "_NSPoint" NSPoint }
151 { "NSPoint" NSPoint }
152 { "CGPoint" NSPoint }
159 { "_NSRange" NSRange }
160 { "NSRange" NSRange }
161 } objc>struct-types set-global
163 ! The transpose of the above map
164 SYMBOL: alien>objc-types
166 objc>alien-types get [ swap ] assoc-map
170 { NSPoint "{_NSPoint=ff}" }
171 { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
172 { NSSize "{_NSSize=ff}" }
173 { NSRange "{_NSRange=II}" }
179 { NSPoint "{CGPoint=dd}" }
180 { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
181 { NSSize "{CGSize=dd}" }
182 { NSRange "{_NSRange=QQ}" }
188 assoc-union alien>objc-types set-global
190 : objc-struct-type ( i string -- ctype )
191 [ CHAR: = ] 2keep index-from swap subseq
192 objc>struct-types get at* [ drop void* ] unless ;
194 ERROR: no-objc-type name ;
196 : decode-type ( ch -- ctype )
198 [ objc>alien-types get at ] [ no-objc-type ] ?unless ;
200 : (parse-objc-type) ( i string -- ctype )
201 [ [ 1 + ] dip ] [ nth ] 2bi {
202 { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
203 { [ dup CHAR: ^ = ] [ 3drop void* ] }
204 { [ dup CHAR: { = ] [ drop objc-struct-type ] }
205 { [ dup CHAR: [ = ] [ 3drop void* ] }
209 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
211 : method-arg-type ( method i -- type )
212 method_copyArgumentType
213 [ utf8 alien>string parse-objc-type ] keep
216 : method-arg-types ( method -- args )
217 dup method_getNumberOfArguments <iota>
218 [ method-arg-type ] with map ;
220 : method-return-type ( method -- ctype )
221 method_copyReturnType [ utf8 alien>string ] [ (free) ] bi ;
223 : method-return-type-parsed ( method -- ctype/f )
225 [ parse-objc-type ] [ 2drop f ] recover ;
227 : method-signature ( method -- signature )
228 [ method-return-type-parsed ] [ method-arg-types ] bi 2array ;
230 : method-name ( method -- name )
231 method_getName sel_getName ;
233 : warn-unknown-objc-method ( classname method-name method -- )
236 _ "`" dup surround write bl
237 "has unknown method-return-type:" write bl
238 _ method-return-type print
239 ] with-output>error ;
241 :: register-objc-method ( classname method -- )
242 method method-signature :> signature
243 method method-name :> name
244 classname "." name 3append :> fullname
246 signature cache-stubs
247 signature name objc-methods get set-at
248 signature fullname objc-methods get set-at
250 classname name method warn-unknown-objc-method
253 : method-collisions ( -- collisions )
254 objc-methods get >alist
255 [ first CHAR: . swap member? ] filter
256 [ first "." split1 nip ] collect-by
257 [ nip values members length 1 > ] assoc-filter ;
259 : method-count ( class -- c-direct-array )
260 0 uint <ref> [ class_copyMethodList (free) ] keep uint deref ;
262 : each-method-in-class ( class quot: ( classname method -- ) -- )
264 [ class_getName ] keep
265 0 uint <ref> [ class_copyMethodList ] keep uint deref
266 ] dip over 0 = [ 4drop ] [
267 [ void* <c-direct-array> ] dip
268 [ with each ] [ drop (free) ] 2bi
271 : register-objc-methods ( class -- )
272 [ register-objc-method ] each-method-in-class ;
274 : class-exists? ( string -- class ) objc_getClass >boolean ;
276 : define-objc-class-word ( quot name -- )
277 [ class-init-hooks get set-at ]
279 [ "cocoa.classes" create-word ] [ '[ _ objc-class ] ] bi
280 ( -- class ) define-declared
283 : import-objc-class ( name quot -- )
284 2dup swap define-objc-class-word
285 over class-exists? [ drop ] [ call( -- ) ] if
287 [ objc_getClass register-objc-methods ]
288 [ objc_getMetaClass register-objc-methods ] bi
291 : root-class ( class -- root )
292 [ class_getSuperclass ] [ root-class ] ?when ;
294 : objc-class-names ( -- seq )
296 f 0 objc_getClassList
297 [ Class heap-size * malloc &free ] keep
298 dupd objc_getClassList void* <c-direct-array>
299 [ class_getName ] { } map-as