1 ! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors alien alien.parser alien.strings arrays assocs
4 cocoa.messages cocoa.runtime combinators compiler.units
5 io.encodings.utf8 kernel lexer locals.parser locals.types
6 make namespaces parser sequences words ;
9 : init-method ( method -- sel imp types )
11 [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
14 : throw-if-false ( obj what -- )
16 [ "Failed to " prepend throw ] [ drop ] if ;
18 : add-method ( class sel imp types -- )
19 class_addMethod "add method to class" throw-if-false ;
21 : add-methods ( methods class -- )
22 '[ [ _ ] dip init-method add-method ] each ;
24 : add-protocol ( class protocol -- )
25 class_addProtocol "add protocol to class" throw-if-false ;
27 : add-protocols ( protocols class -- )
28 '[ [ _ ] dip objc-protocol add-protocol ] each ;
30 : (define-objc-class) ( methods protocols superclass name -- )
31 [ objc-class ] dip 0 objc_allocateClassPair
32 [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
35 : encode-type ( type -- encoded )
36 [ alien>objc-types get at ] [ no-objc-type ] ?unless ;
38 : encode-types ( return types -- encoding )
39 swap prefix [ encode-type "0" append ] map concat ;
41 : prepare-method ( ret types quot -- type imp )
42 [ [ encode-types ] 2keep ] dip
43 '[ _ _ cdecl _ alien-callback ]
44 ( -- callback ) define-temp ;
46 : prepare-methods ( methods -- methods )
48 [ first4 prepare-method 3array ] map
49 ] with-nested-compilation-unit ;
51 :: (redefine-objc-method) ( class method -- )
52 method init-method :> ( sel imp types )
54 class sel class_getInstanceMethod [
55 imp method_setImplementation drop
57 class sel imp types add-method
60 : redefine-objc-methods ( methods name -- )
62 objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
65 :: define-objc-class ( name superclass protocols methods -- )
66 methods prepare-methods :> methods
67 name "cocoa.classes" create-word drop
68 methods name redefine-objc-methods
69 name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
71 TUPLE: cocoa-protocol name ;
72 C: <cocoa-protocol> cocoa-protocol
74 SYNTAX: COCOA-PROTOCOL:
75 scan-token <cocoa-protocol> suffix! ;
83 \ ;CLASS> parse-until [ cocoa-protocol? ] partition
84 [ [ name>> ] map ] dip define-objc-class ;
86 : (parse-selector) ( -- )
88 { [ dup "[" = ] [ drop ] }
89 { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
90 [ f f 3array , "[" expect ]
93 : parse-selector ( -- selector types names )
94 [ (parse-selector) ] { } make
97 [ sift { id SEL } prepend ]
98 [ sift { "self" "selector" } prepend ] tri* ;
100 : parse-method-body ( names -- quot )
101 [ [ make-local ] map ] H{ } make
102 (parse-lambda) <lambda> ?rewrite-closures first ;
107 parse-method-body [ swap ] 2dip 4array ";" expect