steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

cocoa.messages: name sender-stubs by signature since they are cached that way.

db4
John Benediktsson 2013-04-26 16:56:53 -07:00
parent 380bb350ca
commit 88ec7ef7de
2 changed files with 20 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/cocoa/messages/messages-tests.factor Normal file
View File

@ -0,0 +1,8 @@
USING: alien.c-types cocoa.runtime tools.test ;
IN: cocoa.messages
{ "( sender-stub:void() )" }
[ { void { } } sender-stub-name ] unit-test
{ "( sender-stub:id(id,SEL,void*,Class) )" }
[ { id { id SEL void* Class } } sender-stub-name ] unit-test

19
basis/cocoa/messages/messages.factor
View File

@ -14,8 +14,13 @@ SPECIALIZED-ARRAY: void*
: make-sender ( signature function -- quot ) : make-sender ( signature function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ; [ over first , f , , second , \ alien-invoke , ] [ ] make ;
: sender-stub ( name signature function -- word ) : sender-stub-name ( signature -- str )
[ "( sender-stub:" ")" surround f <word> dup ] 2dip first2 [ name>> ] [
[ name>> ] map "," join "(" ")" surround
] bi* append "( sender-stub:" " )" surround ;
: sender-stub ( signature function -- word )
[ [ sender-stub-name f <word> dup ] keep ] dip
over first large-struct? [ "_stret" append ] when over first large-struct? [ "_stret" append ] when
make-sender dup infer define-declared ; make-sender dup infer define-declared ;
@ -25,13 +30,13 @@ SYMBOL: super-message-senders
message-senders [ H{ } clone ] initialize message-senders [ H{ } clone ] initialize
super-message-senders [ H{ } clone ] initialize super-message-senders [ H{ } clone ] initialize
:: cache-stub ( name signature function assoc -- ) :: cache-stub ( signature function assoc -- )
signature assoc [ [ name ] dip function sender-stub ] cache drop ; signature assoc [ function sender-stub ] cache drop ;
: cache-stubs ( name signature -- ) : cache-stubs ( signature -- )
[ "objc_msgSendSuper" super-message-senders get cache-stub ] [ "objc_msgSendSuper" super-message-senders get cache-stub ]
[ "objc_msgSend" message-senders get cache-stub ] [ "objc_msgSend" message-senders get cache-stub ]
2bi ; bi ;
: <super> ( receiver -- super ) : <super> ( receiver -- super )
[ ] [ object_getClass class_getSuperclass ] bi [ ] [ object_getClass class_getSuperclass ] bi
@ -224,7 +229,7 @@ ERROR: no-objc-type name ;
: register-objc-method ( method -- ) : register-objc-method ( method -- )
[ method-name ] [ method-name ]
[ [ method-return-type ] [ method-arg-types ] bi 2array ] bi [ [ method-return-type ] [ method-arg-types ] bi 2array ] bi
[ cache-stubs ] [ swap objc-methods get set-at ] 2bi ; [ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
: each-method-in-class ( class quot -- ) : each-method-in-class ( class quot -- )
[ { uint } [ class_copyMethodList ] with-out-parameters ] dip [ { uint } [ class_copyMethodList ] with-out-parameters ] dip