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

cocoa.messages: bind classname.methodname selectors also. 

We currently have a problem which is all selectors are assumed to have
the same method effect.  The problem is we can have method collisions,
for example:

NSObject.load is { void { id SEL } }
NSBundle.load is { char { id SEL } }

So, this inferred wrong:

IN: scratchpad [ NSBundle -> mainBundle -> load ] infer .
( -- )

But now we can do this instead:

IN: scratchpad [ NSBundle -> NSBundle.mainBundle -> NSBundle.load ] infer .
( -- x )

It doesn't really fix the original problem, but its a way to workaround
it and added ``method-collisions`` to report on the conflicts.
paths
John Benediktsson 2018-03-13 10:17:33 -07:00
parent 9fbddec50e
commit 365584a644
1 changed files with 24 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4,8 +4,8 @@ USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs classes.struct cocoa.runtime cocoa.types arrays assocs classes.struct cocoa.runtime cocoa.types
combinators core-graphics.types fry generalizations combinators core-graphics.types fry generalizations
io.encodings.utf8 kernel layouts libc locals macros make math io.encodings.utf8 kernel layouts libc locals macros make math
memoize namespaces quotations sequences specialized-arrays memoize namespaces quotations sequences sets specialized-arrays
stack-checker strings words ; splitting stack-checker strings words ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages IN: cocoa.messages
@ -44,7 +44,8 @@ super-message-senders [ H{ } clone ] initialize
TUPLE: selector-tuple name object ; TUPLE: selector-tuple name object ;
MEMO: <selector> ( name -- sel ) f \ selector-tuple boa ; MEMO: <selector> ( name -- sel )
"." split1 nip f selector-tuple boa ;
: selector ( selector -- alien ) : selector ( selector -- alien )
dup object>> expired? [ dup object>> expired? [
@ -234,16 +235,28 @@ ERROR: no-objc-type name ;
: method-name ( method -- name ) : method-name ( method -- name )
method_getName sel_getName ; method_getName sel_getName ;
: register-objc-method ( method -- ) :: register-objc-method ( classname method -- )
[ method-name ] method method-return-type
[ [ method-return-type ] [ method-arg-types ] bi 2array ] bi method method-arg-types 2array :> signature
[ nip cache-stubs ] [ swap objc-methods get set-at ] 2bi ; method method-name :> name
classname "." name 3append :> fullname
signature cache-stubs
signature name objc-methods get set-at
signature fullname objc-methods get set-at ;
: each-method-in-class ( class quot -- ) : method-collisions ( -- collisions )
[ { uint } [ class_copyMethodList ] with-out-parameters ] dip objc-methods get >alist
over 0 = [ 3drop ] [ [ first CHAR: . swap member? ] filter
[ first "." split1 nip ] collect-by
[ nip values members length 1 > ] assoc-filter ;
: each-method-in-class ( class quot: ( class method -- ) -- )
[
[ class_getName ] keep
{ uint } [ class_copyMethodList ] with-out-parameters
] dip over 0 = [ 4drop ] [
[ void* <c-direct-array> ] dip [ void* <c-direct-array> ] dip
[ each ] [ drop (free) ] 2bi [ with each ] [ drop (free) ] 2bi
] if ; inline ] if ; inline
: register-objc-methods ( class -- ) : register-objc-methods ( class -- )