diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index f90e6036cc..a0f2af59e4 100644 --- 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 ] - [ suffix! \ cocoa.messages:selector suffix! ] bi ; + scan-token dup remember-send + 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 diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 8e917975c3..3023161be7 100644 --- 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 ) [ [ \ , ] when swap , \ 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