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

cocoa.messages: Apply mrjbq's patch to show the name of the cooca function in sender stubs. rename 'method' in stack effects to 'signature' since we are passing an array with the return value and arguments, not the method.

db4
Doug Coleman 2011-11-21 16:38:16 -08:00
parent 857fc50fff
commit e435a7aa59
1 changed files with 16 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5,17 +5,17 @@ arrays assocs classes.struct continuations combinators compiler
core-graphics.types stack-checker kernel math namespaces make core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc lexer init macros memoize io.encodings.utf8 effects layouts libc lexer init
core-foundation fry generalizations specialized-arrays ; core-foundation fry generalizations specialized-arrays locals ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages IN: cocoa.messages
SPECIALIZED-ARRAY: void* SPECIALIZED-ARRAY: void*
: make-sender ( method function -- quot ) : make-sender ( signature function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ; [ over first , f , , second , \ alien-invoke , ] [ ] make ;
: sender-stub ( method function -- word ) : sender-stub ( name signature function -- word )
[ "( sender-stub )" f <word> dup ] 2dip [ "( sender-stub:" ")" surround f <word> dup ] 2dip
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 +25,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 ( method assoc function -- ) :: cache-stub ( name signature function assoc -- )
'[ _ sender-stub ] cache drop ; signature assoc [ [ name ] dip function sender-stub ] cache drop ;
: cache-stubs ( method -- ) : cache-stubs ( name signature -- )
[ super-message-senders get "objc_msgSendSuper" cache-stub ] [ "objc_msgSendSuper" super-message-senders get cache-stub ]
[ message-senders get "objc_msgSend" cache-stub ] [ "objc_msgSend" message-senders get cache-stub ]
bi ; 2bi ;
: <super> ( receiver -- super ) : <super> ( receiver -- super )
[ ] [ object_getClass class_getSuperclass ] bi [ ] [ object_getClass class_getSuperclass ] bi
@ -209,11 +209,13 @@ ERROR: no-objc-type name ;
[ utf8 alien>string parse-objc-type ] keep [ utf8 alien>string parse-objc-type ] keep
(free) ; (free) ;
: method-name ( method -- name )
method_getName sel_getName ;
: register-objc-method ( method -- ) : register-objc-method ( method -- )
dup method-return-type over method-arg-types 2array [ method-name ]
dup cache-stubs [ [ method-return-type ] [ method-arg-types ] bi 2array ] bi
swap method_getName sel_getName [ cache-stubs ] [ swap objc-methods get set-at ] 2bi ;
objc-methods get set-at ;
: 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