Less consing of quotations
parent
e967f98afd
commit
5fdee1a611
|
@ -3,7 +3,8 @@
|
||||||
USING: alien alien.c-types alien.compiler
|
USING: alien alien.c-types alien.compiler
|
||||||
arrays assocs combinators compiler inference.transforms kernel
|
arrays assocs combinators compiler inference.transforms kernel
|
||||||
math namespaces parser prettyprint prettyprint.sections
|
math namespaces parser prettyprint prettyprint.sections
|
||||||
quotations sequences strings words cocoa.runtime io macros ;
|
quotations sequences strings words cocoa.runtime io macros
|
||||||
|
memoize ;
|
||||||
IN: cocoa.messages
|
IN: cocoa.messages
|
||||||
|
|
||||||
: make-sender ( method function -- quot )
|
: make-sender ( method function -- quot )
|
||||||
|
@ -20,10 +21,8 @@ IN: cocoa.messages
|
||||||
SYMBOL: message-senders
|
SYMBOL: message-senders
|
||||||
SYMBOL: super-message-senders
|
SYMBOL: super-message-senders
|
||||||
|
|
||||||
global [
|
message-senders global [ H{ } assoc-like ] change-at
|
||||||
message-senders [ H{ } assoc-like ] change
|
super-message-senders global [ H{ } assoc-like ] change-at
|
||||||
super-message-senders [ H{ } assoc-like ] change
|
|
||||||
] bind
|
|
||||||
|
|
||||||
: cache-stub ( method function hash -- )
|
: cache-stub ( method function hash -- )
|
||||||
[
|
[
|
||||||
|
@ -56,14 +55,14 @@ TUPLE: selector name object ;
|
||||||
|
|
||||||
SYMBOL: selectors
|
SYMBOL: selectors
|
||||||
|
|
||||||
H{ } clone selectors set-global
|
selectors global [ H{ } assoc-like ] change-at
|
||||||
|
|
||||||
: cache-selector ( string -- selector )
|
: cache-selector ( string -- selector )
|
||||||
selectors get-global [ <selector> ] cache ;
|
selectors get-global [ <selector> ] cache ;
|
||||||
|
|
||||||
SYMBOL: objc-methods
|
SYMBOL: objc-methods
|
||||||
|
|
||||||
H{ } clone objc-methods set-global
|
objc-methods global [ H{ } assoc-like ] change-at
|
||||||
|
|
||||||
: lookup-method ( selector -- method )
|
: lookup-method ( selector -- method )
|
||||||
dup objc-methods get at
|
dup objc-methods get at
|
||||||
|
@ -74,7 +73,7 @@ H{ } clone objc-methods set-global
|
||||||
\ >r <repetition> >quotation -rot
|
\ >r <repetition> >quotation -rot
|
||||||
\ r> <repetition> >quotation 3append ;
|
\ r> <repetition> >quotation 3append ;
|
||||||
|
|
||||||
: make-prepare-send ( selector method super? -- quot )
|
MEMO: make-prepare-send ( selector method super? -- quot )
|
||||||
[
|
[
|
||||||
[ \ <super> , ] when
|
[ \ <super> , ] when
|
||||||
swap cache-selector , \ selector ,
|
swap cache-selector , \ selector ,
|
||||||
|
@ -82,11 +81,10 @@ H{ } clone objc-methods set-global
|
||||||
swap second length 2 - make-dip ;
|
swap second length 2 - make-dip ;
|
||||||
|
|
||||||
MACRO: (send) ( selector super? -- quot )
|
MACRO: (send) ( selector super? -- quot )
|
||||||
[
|
>r dup lookup-method r>
|
||||||
>r dup lookup-method r>
|
[ make-prepare-send ] 2keep
|
||||||
[ make-prepare-send % ] 2keep
|
super-message-senders message-senders ? get at
|
||||||
super-message-senders message-senders ? get at ,
|
[ slip execute ] 2curry ;
|
||||||
] [ ] make ;
|
|
||||||
|
|
||||||
: send ( args... receiver selector -- return... ) f (send) ; inline
|
: send ( args... receiver selector -- return... ) f (send) ; inline
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue