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
! 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 ;
IN: cocoa
SYMBOL: sent-messages
: (remember-send) ( selector variable -- )
[ dupd ?set-at ] change-global ;
sent-messages [ H{ } clone ] initialize
: 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:
scan-token
[ remember-send ]
[ <selector> suffix! \ cocoa.messages:selector suffix! ] bi ;
scan-token dup remember-send
<selector> suffix! \ cocoa.messages:selector suffix! ;
SYMBOL: super-sent-messages
: remember-super-send ( selector -- )
super-sent-messages (remember-send) ;
super-sent-messages [ H{ } clone ] initialize
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

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

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