<commit_before>! Copyright (C) 2006, 2010 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs classes.struct continuations combinators compiler
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc lexer init
core-foundation fry generalizations specialized-arrays locals ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages

SPECIALIZED-ARRAY: void*

: make-sender ( signature function -- quot )
    [ over first , f , , second , \ alien-invoke , ] [ ] make ;

: sender-stub ( name signature function -- word )
    [ "( sender-stub:" ")" surround f <word> dup ] 2dip
    over first large-struct? [ "_stret" append ] when
    make-sender dup infer define-declared ;

SYMBOL: message-senders
SYMBOL: super-message-senders

message-senders [ H{ } clone ] initialize
super-message-senders [ H{ } clone ] initialize

:: cache-stub ( name signature function assoc -- )
    signature assoc [ [ name ] dip function sender-stub ] cache drop ;

: cache-stubs ( name signature -- )
    [ "objc_msgSendSuper" super-message-senders get cache-stub ]
    [ "objc_msgSend" message-senders get cache-stub ]
    2bi ;

: <super> ( receiver -- super )
    [ ] [ object_getClass class_getSuperclass ] bi
    objc-super <struct-boa> ;

TUPLE: selector-tuple name object ;

MEMO: <selector> ( name -- sel ) f \ selector-tuple boa ;

: selector ( selector -- alien )
    dup object>> expired? [
        dup name>> sel_registerName
        [ >>object drop ] keep
    ] [
        object>>
    ] if ;

SYMBOL: objc-methods

objc-methods [ H{ } clone ] initialize

ERROR: no-objc-method name ;

: lookup-method ( selector -- method )
    dup objc-methods get at [ ] [ no-objc-method ] ?if ;

MEMO: make-prepare-send ( selector method 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 ;

: send ( receiver args... selector -- return... ) f (send) ; inline

: super-send ( receiver args... selector -- return... ) t (send) ; inline

! Runtime introspection
SYMBOL: class-init-hooks

class-init-hooks [ H{ } clone ] initialize

: (objc-class) ( name word -- class )<commit_msg>cocoa.messages: some support for runtime message sending.<commit_after>! Copyright (C) 2006, 2010 <NAME>.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs classes.struct continuations combinators compiler
core-graphics.types stack-checker kernel math namespaces make
quotations sequences strings words cocoa.runtime cocoa.types io
macros memoize io.encodings.utf8 effects layouts libc lexer init
core-foundation fry generalizations specialized-arrays locals ;
QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages

SPECIALIZED-ARRAY: void*

: make-sender ( signature function -- quot )
    [ over first , f , , second , \ alien-invoke , ] [ ] make ;

: sender-stub ( name signature function -- word )
    [ "( sender-stub:" ")" surround f <word> dup ] 2dip
    over first large-struct? [ "_stret" append ] when
    make-sender dup infer define-declared ;

SYMBOL: message-senders
SYMBOL: super-message-senders

message-senders [ H{ } clone ] initialize
super-message-senders [ H{ } clone ] initialize

:: cache-stub ( name signature function assoc -- )
    signature assoc [ [ name ] dip function sender-stub ] cache drop ;

: cache-stubs ( name signature -- )
    [ "objc_msgSendSuper" super-message-senders get cache-stub ]
    [ "objc_msgSend" message-senders get cache-stub ]
    2bi ;

: <super> ( receiver -- super )
    [ ] [ object_getClass class_getSuperclass ] bi
    objc-super <struct-boa> ;

TUPLE: selector-tuple name object ;

MEMO: <selector> ( name -- sel ) f \ selector-tuple boa ;

: selector ( selector -- alien )
    dup object>> expired? [
        dup name>> sel_registerName
        [ >>object drop ] keep
    ] [
        object>>
    ] if ;

SYMBOL: objc-methods

objc-methods [ H{ } clone ] initialize

ERROR: no-objc-method name ;

: ?lookup-method ( selector -- method/f )
    objc-methods get at ;

: lookup-method ( selector -- method )
    dup ?lookup-method [ ] [ no-objc-method ] ?if ;

: selector/sender ( selector method -- alien word )
    [ <selector> selector ] [ message-senders get at ] bi* ;

: when-method ( receiver selector quot: ( receiver selector method -- ) -- )
    [ dup ?lookup-method ] dip [ selector/sender ] prepose [ 2drop ] if* ; inline

MEMO: make-prepare-send ( selector method 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 ;

: send ( receiver args... selector -- return... ) f (send) ; inline

: super-send ( receiver args... selector -- return... ) t (send) ; inline

! Runtime introspection
SYMBOL: class-init-hooks

class-init-hooks [ H{ } clone ] initialize

: (objc-class) ( name word -- class )
{'fraction_non_alphanumeric': 0.12216117216117216, 'fraction_numerical': 0.005311355311355312, 'mean_word_length': 2.9919590643274856, 'pattern_counts': {'":': 0, '<': 18, '<?xml version=': 0, '>': 34, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '956913', 'n_tokens_mistral': 1704, 'n_tokens_neox': 1667, 'n_words': 508}