cocoa: cleanup ?-> syntax and implementation.

diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor
index f90e6036ccf2c9d3e47fec0434ce6a8f2b9e7e8c..a0f2af59e440780f07a8616777d5865d23b6bfd8 100644 (file)
--- a/basis/cocoa/cocoa.factor
+++ b/basis/cocoa/cocoa.factor
@@ -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
 
+super-sent-messages [ H{ } clone ] initialize
+
 : remember-super-send ( selector -- )
-    super-sent-messages (remember-send) ;
+    dup super-sent-messages get set-at ;
 
-SYNTAX: SUPER-> scan-token dup remember-super-send suffix! \ super-send suffix! ;
+SYNTAX: SUPER->
+    scan-token dup remember-super-send
+    [ lookup-method suffix! ] [ suffix! ] bi \ super-send suffix! ;
 
 SYMBOL: frameworks
 

diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 8e917975c303c0d12a3d9edd5b445aede4b0f789..3023161be71b40bfa645d9265f7abb729cbdbfbe 100644 (file)
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -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 ] ;
-
-MACRO: (send) ( selector super? -- quot )
-    [ dup lookup-method ] dip
-    [ make-prepare-send ] 2keep
-    super-message-senders message-senders ? get at
-    1quotation append ;
+    ] [ ] make swap second length 2 - '[ _ _ ndip ] ;
 
-: send ( receiver args... selector -- return... ) f (send) ; inline
+MACRO: (send) ( signature selector super? -- quot )
+    swapd [ make-prepare-send ] 2keep
+    super-message-senders message-senders ? get at suffix ;
 
-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... signature selector -- return... ) f (send) ; inline
 
-: ?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