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 continuations combinators compiler compiler.alien stack-checker kernel
5 math namespaces make parser quotations sequences strings words
6 cocoa.runtime io macros memoize io.encodings.utf8 effects libc
7 libc.private parser lexer init core-foundation fry generalizations
8 specialized-arrays.direct.alien call ;
11 : make-sender ( method function -- quot )
12 [ over first , f , , second , \ alien-invoke , ] [ ] make ;
14 : sender-stub ( method function -- word )
15 [ "( sender-stub )" f <word> dup ] 2dip
16 over first large-struct? [ "_stret" append ] when
17 make-sender dup infer define-declared ;
19 SYMBOL: message-senders
20 SYMBOL: super-message-senders
22 message-senders [ H{ } clone ] initialize
23 super-message-senders [ H{ } clone ] initialize
25 : cache-stub ( method function hash -- )
27 over get [ 2drop ] [ over [ sender-stub ] dip set ] if
30 : cache-stubs ( method -- )
32 "objc_msgSendSuper" super-message-senders get cache-stub
33 "objc_msgSend" message-senders get cache-stub ;
35 : <super> ( receiver -- super )
36 "objc-super" <c-object> [
37 [ dup object_getClass class_getSuperclass ] dip
40 [ set-objc-super-receiver ] keep ;
42 TUPLE: selector name object ;
44 MEMO: <selector> ( name -- sel ) f \ selector boa ;
46 : selector ( selector -- alien )
47 dup object>> expired? [
48 dup name>> sel_registerName
49 [ >>object drop ] keep
56 objc-methods [ H{ } clone ] initialize
58 : lookup-method ( selector -- method )
59 dup objc-methods get at
60 [ ] [ "No such method: " prepend throw ] ?if ;
62 MEMO: make-prepare-send ( selector method super? -- quot )
65 swap <selector> , \ selector ,
67 swap second length 2 - '[ _ _ ndip ] ;
69 MACRO: (send) ( selector super? -- quot )
70 [ dup lookup-method ] dip
71 [ make-prepare-send ] 2keep
72 super-message-senders message-senders ? get at
73 '[ _ call _ execute ] ;
75 : send ( receiver args... selector -- return... ) f (send) ; inline
77 : super-send ( receiver args... selector -- return... ) t (send) ; inline
79 ! Runtime introspection
80 SYMBOL: class-init-hooks
82 class-init-hooks [ H{ } clone ] initialize
84 : (objc-class) ( name word -- class )
85 2dup execute dup [ 2nip ] [
86 drop over class-init-hooks get at [ call( -- ) ] when*
87 2dup execute dup [ 2nip ] [
88 2drop "No such class: " prepend throw
92 : objc-class ( string -- class )
93 \ objc_getClass (objc-class) ;
95 : objc-protocol ( string -- class )
96 \ objc_getProtocol (objc-class) ;
98 : objc-meta-class ( string -- class )
99 \ objc_getMetaClass (objc-class) ;
101 SYMBOL: objc>alien-types
115 { "?" "unknown_type" }
120 "ptrdiff_t" heap-size {
134 assoc-union objc>alien-types set-global
136 ! The transpose of the above map
137 SYMBOL: alien>objc-types
139 objc>alien-types get [ swap ] assoc-map
141 "ptrdiff_t" heap-size {
143 { "NSPoint" "{_NSPoint=ff}" }
144 { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
145 { "NSSize" "{_NSSize=ff}" }
146 { "NSRange" "{_NSRange=II}" }
152 { "NSPoint" "{CGPoint=dd}" }
153 { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
154 { "NSSize" "{CGSize=dd}" }
155 { "NSRange" "{_NSRange=QQ}" }
161 assoc-union alien>objc-types set-global
163 : objc-struct-type ( i string -- ctype )
164 [ CHAR: = ] 2keep index-from swap subseq
165 dup c-types get key? [
166 "Warning: no such C type: " write dup print
170 : (parse-objc-type) ( i string -- ctype )
171 [ [ 1+ ] dip ] [ nth ] 2bi {
172 { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
173 { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
174 { [ dup CHAR: { = ] [ drop objc-struct-type ] }
175 { [ dup CHAR: [ = ] [ 3drop "void*" ] }
176 [ 2nip 1string objc>alien-types get at ]
179 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
181 : method-arg-type ( method i -- type )
182 method_copyArgumentType
183 [ utf8 alien>string parse-objc-type ] keep
186 : method-arg-types ( method -- args )
187 dup method_getNumberOfArguments
188 [ method-arg-type ] with map ;
190 : method-return-type ( method -- ctype )
191 method_copyReturnType
192 [ utf8 alien>string parse-objc-type ] keep
195 : register-objc-method ( method -- )
196 dup method-return-type over method-arg-types 2array
198 swap method_getName sel_getName
199 objc-methods get set-at ;
201 : each-method-in-class ( class quot -- )
202 [ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
204 [ <direct-void*-array> ] dip
205 [ each ] [ drop (free) ] 2bi
208 : register-objc-methods ( class -- )
209 [ register-objc-method ] each-method-in-class ;
211 : class-exists? ( string -- class ) objc_getClass >boolean ;
213 : define-objc-class-word ( quot name -- )
214 [ class-init-hooks get set-at ]
216 [ "cocoa.classes" create ] [ '[ _ objc-class ] ] bi
217 (( -- class )) define-declared
220 : import-objc-class ( name quot -- )
221 over define-objc-class-word
222 [ objc-class register-objc-methods ]
223 [ objc-meta-class register-objc-methods ] bi ;
225 : root-class ( class -- root )
226 dup class_getSuperclass [ root-class ] [ ] ?if ;