1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.c-types alien.strings arrays assocs
4 combinators compiler compiler.alien kernel math namespaces make
5 parser prettyprint prettyprint.sections quotations sequences
6 strings words cocoa.runtime io macros memoize debugger
7 io.encodings.ascii effects libc libc.private parser lexer init
11 : make-sender ( method function -- quot )
12 [ over first , f , , second , \ alien-invoke , ] [ ] make ;
14 : sender-stub-name ( method function -- string )
15 [ % "_" % unparse % ] "" make ;
17 : sender-stub ( method function -- word )
18 [ sender-stub-name f <word> dup ] 2keep
19 over first large-struct? [ "_stret" append ] when
22 SYMBOL: message-senders
23 SYMBOL: super-message-senders
25 message-senders global [ H{ } assoc-like ] change-at
26 super-message-senders global [ H{ } assoc-like ] change-at
28 : cache-stub ( method function hash -- )
30 over get [ 2drop ] [ over >r sender-stub r> set ] if
33 : cache-stubs ( method -- )
35 "objc_msgSendSuper" super-message-senders get cache-stub
36 "objc_msgSend" message-senders get cache-stub ;
38 : <super> ( receiver -- super )
39 "objc-super" <c-object> [
40 >r dup object_getClass class_getSuperclass r>
43 [ set-objc-super-receiver ] keep ;
45 TUPLE: selector name object ;
47 MEMO: <selector> ( name -- sel ) f \ selector boa ;
49 : selector ( selector -- alien )
50 dup object>> expired? [
51 dup name>> sel_registerName
52 [ >>object drop ] keep
59 objc-methods global [ H{ } assoc-like ] change-at
61 : lookup-method ( selector -- method )
62 dup objc-methods get at
63 [ ] [ "No such method: " prepend throw ] ?if ;
65 : make-dip ( quot n -- quot' )
67 \ >r <repetition> >quotation -rot
68 \ r> <repetition> >quotation 3append ;
70 MEMO: make-prepare-send ( selector method super? -- quot )
73 swap <selector> , \ selector ,
75 swap second length 2 - make-dip ;
77 MACRO: (send) ( selector super? -- quot )
78 >r dup lookup-method r>
79 [ make-prepare-send ] 2keep
80 super-message-senders message-senders ? get at
81 [ slip execute ] 2curry ;
83 : send ( receiver args... selector -- return... ) f (send) ; inline
85 \ send soft "break-after" set-word-prop
87 : super-send ( receiver args... selector -- return... ) t (send) ; inline
89 \ super-send soft "break-after" set-word-prop
91 ! Runtime introspection
92 : (objc-class) ( string word -- class )
94 [ ] [ "No such class: " prepend throw ] ?if ; inline
96 : objc-class ( string -- class )
97 \ objc_getClass (objc-class) ;
99 : objc-protocol ( string -- class )
100 \ objc_getProtocol (objc-class) ;
102 : objc-meta-class ( string -- class )
103 \ objc_getMetaClass (objc-class) ;
105 SYMBOL: objc>alien-types
119 { "?" "unknown_type" }
124 "ptrdiff_t" heap-size {
138 assoc-union objc>alien-types set-global
140 ! The transpose of the above map
141 SYMBOL: alien>objc-types
143 objc>alien-types get [ swap ] assoc-map
145 "ptrdiff_t" heap-size {
147 { "NSPoint" "{_NSPoint=ff}" }
148 { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
149 { "NSSize" "{_NSSize=ff}" }
150 { "NSRange" "{_NSRange=II}" }
156 { "NSPoint" "{CGPoint=dd}" }
157 { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
158 { "NSSize" "{CGSize=dd}" }
159 { "NSRange" "{_NSRange=QQ}" }
165 assoc-union alien>objc-types set-global
167 : objc-struct-type ( i string -- ctype )
168 2dup CHAR: = -rot index-from swap subseq
169 dup c-types get key? [
170 "Warning: no such C type: " write dup print
174 : (parse-objc-type) ( i string -- ctype )
175 2dup nth >r >r 1+ r> r> {
176 { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
177 { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
178 { [ dup CHAR: { = ] [ drop objc-struct-type ] }
179 { [ dup CHAR: [ = ] [ 3drop "void*" ] }
180 [ 2nip 1string objc>alien-types get at ]
183 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
185 : method-arg-type ( method i -- type )
186 method_copyArgumentType
187 [ ascii alien>string parse-objc-type ] keep
190 : method-arg-types ( method -- args )
191 dup method_getNumberOfArguments
192 [ method-arg-type ] with map ;
194 : method-return-type ( method -- ctype )
195 method_copyReturnType
196 [ ascii alien>string parse-objc-type ] keep
199 : register-objc-method ( method -- )
200 dup method-return-type over method-arg-types 2array
202 swap method_getName sel_getName
203 objc-methods get set-at ;
205 : each-method-in-class ( class quot -- )
206 [ 0 <uint> [ class_copyMethodList ] keep *uint over ] dip
207 '[ _ void*-nth @ ] each (free) ; inline
209 : register-objc-methods ( class -- )
210 [ register-objc-method ] each-method-in-class ;
212 : method. ( method -- )
214 [ method_getName sel_getName ]
215 [ method-return-type ]
217 [ method_getImplementation ]
220 : methods. ( class -- )
221 [ method. ] each-method-in-class ;
223 : class-exists? ( string -- class ) objc_getClass >boolean ;
225 : unless-defined ( class quot -- )
226 >r class-exists? r> unless ; inline
228 : define-objc-class-word ( name quot -- )
230 over , , \ unless-defined , dup , \ objc-class ,
231 ] [ ] make >r "cocoa.classes" create r>
232 (( -- class )) define-declared ;
234 : import-objc-class ( name quot -- )
236 dupd define-objc-class-word
239 objc-class register-objc-methods
240 objc-meta-class register-objc-methods
243 : root-class ( class -- root )
244 dup class_getSuperclass [ root-class ] [ ] ?if ;