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

Less consing of quotations

release
Slava Pestov 2007-10-06 13:39:59 -04:00
parent e967f98afd
commit 5fdee1a611
1 changed files with 11 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extra/cocoa/messages/messages.factor
View File

@ -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