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

cocoa: cleanup ?-> syntax and implementation.

paths
John Benediktsson 2018-03-13 13:21:21 -07:00
parent 5e18e609b3
commit d259d7ccec
2 changed files with 33 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
basis/cocoa/cocoa.factor
View File

@ -1,32 +1,39 @@
! Copyright (C) 2006, 2009 Slava Pestov ! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: cocoa.messages compiler.units core-foundation.bundles USING: assocs cocoa.messages compiler.units core-foundation.bundles
hashtables init io kernel lexer namespaces sequences vocabs ; hashtables init io kernel lexer namespaces sequences vocabs ;
IN: cocoa IN: cocoa
SYMBOL: sent-messages SYMBOL: sent-messages
: (remember-send) ( selector variable -- ) sent-messages [ H{ } clone ] initialize
[ dupd ?set-at ] change-global ;
: remember-send ( selector -- ) : remember-send ( selector -- )
sent-messages (remember-send) ; dup sent-messages get set-at ;
SYNTAX: -> scan-token dup remember-send suffix! \ send suffix! ; SYNTAX: ->
scan-token dup remember-send
[ lookup-method suffix! ] [ suffix! ] bi \ send suffix! ;
SYNTAX: ?-> dup last cache-stubs scan-token dup remember-send suffix! \ ?send suffix! ; SYNTAX: ?->
dup last cache-stubs
scan-token dup remember-send
suffix! \ send suffix! ;
SYNTAX: SEL: SYNTAX: SEL:
scan-token scan-token dup remember-send
[ remember-send ] <selector> suffix! \ cocoa.messages:selector suffix! ;
[ <selector> suffix! \ cocoa.messages:selector suffix! ] bi ;
SYMBOL: super-sent-messages SYMBOL: super-sent-messages
: remember-super-send ( selector -- ) super-sent-messages [ H{ } clone ] initialize
super-sent-messages (remember-send) ;
SYNTAX: SUPER-> scan-token dup remember-super-send suffix! \ super-send suffix! ; : remember-super-send ( selector -- )
dup super-sent-messages get set-at ;
SYNTAX: SUPER->
scan-token dup remember-super-send
[ lookup-method suffix! ] [ suffix! ] bi \ super-send suffix! ;
SYMBOL: frameworks SYMBOL: frameworks

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

@ -67,38 +67,24 @@ objc-methods [ H{ } clone ] initialize
ERROR: no-objc-method name ; ERROR: no-objc-method name ;
: ?lookup-method ( selector -- method/f ) : ?lookup-method ( selector -- signature/f )
objc-methods get at ; objc-methods get at ;
: lookup-method ( selector -- method ) : lookup-method ( selector -- signature )
dup ?lookup-method [ ] [ no-objc-method ] ?if ; dup ?lookup-method [ ] [ no-objc-method ] ?if ;
: lookup-sender ( name -- method ) MEMO: make-prepare-send ( selector signature super? -- quot )
lookup-method message-senders get at ;
MEMO: make-prepare-send ( selector method super? -- quot )
[ [
[ \ <super> , ] when swap <selector> , \ selector , [ \ <super> , ] when swap <selector> , \ selector ,
] [ ] make ] [ ] make swap second length 2 - '[ _ _ ndip ] ;
swap second length 2 - '[ _ _ ndip ] ;
MACRO: (send) ( selector super? -- quot ) MACRO: (send) ( signature selector super? -- quot )
[ dup lookup-method ] dip swapd [ make-prepare-send ] 2keep
[ make-prepare-send ] 2keep super-message-senders message-senders ? get at suffix ;
super-message-senders message-senders ? get at
1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline : send ( receiver args... signature selector -- return... ) f (send) ; inline
MACRO:: (?send) ( effect selector super? -- quot ) : super-send ( receiver args... signature selector -- return... ) t (send) ; inline
selector dup ?lookup-method effect or super?
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
1quotation append ;
: ?send ( receiver args... selector effect -- return... ) f (?send) ; inline
: super-send ( receiver args... selector -- return... ) t (send) ; inline
! Runtime introspection ! Runtime introspection
SYMBOL: class-init-hooks SYMBOL: class-init-hooks
@ -235,12 +221,14 @@ ERROR: no-objc-type name ;
[ utf8 alien>string parse-objc-type ] keep [ utf8 alien>string parse-objc-type ] keep
(free) ; (free) ;
: method-signature ( method -- signature )
[ method-return-type ] [ method-arg-types ] bi 2array ;
: method-name ( method -- name ) : method-name ( method -- name )
method_getName sel_getName ; method_getName sel_getName ;
:: register-objc-method ( classname method -- ) :: register-objc-method ( classname method -- )
method method-return-type method method-signature :> signature
method method-arg-types 2array :> signature
method method-name :> name method method-name :> name
classname "." name 3append :> fullname classname "." name 3append :> fullname
signature cache-stubs signature cache-stubs
@ -253,7 +241,7 @@ ERROR: no-objc-type name ;
[ first "." split1 nip ] collect-by [ first "." split1 nip ] collect-by
[ nip values members length 1 > ] assoc-filter ; [ nip values members length 1 > ] assoc-filter ;
: each-method-in-class ( class quot: ( class method -- ) -- ) : each-method-in-class ( class quot: ( classname method -- ) -- )
[ [
[ class_getName ] keep [ class_getName ] keep
{ uint } [ class_copyMethodList ] with-out-parameters { uint } [ class_copyMethodList ] with-out-parameters