1 ! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.parser alien.strings arrays
4 assocs combinators compiler hashtables kernel lexer libc
5 locals.parser locals.types math namespaces parser sequences
6 words cocoa.messages cocoa.runtime locals compiler.units
7 io.encodings.utf8 continuations make fry effects stack-checker
11 : init-method ( method -- sel imp types )
13 [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
16 : throw-if-false ( obj what -- )
18 [ "Failed to " prepend throw ] [ drop ] if ;
20 : add-method ( class sel imp types -- )
21 class_addMethod "add method to class" throw-if-false ;
23 : add-methods ( methods class -- )
24 '[ [ _ ] dip init-method add-method ] each ;
26 : add-protocol ( class protocol -- )
27 class_addProtocol "add protocol to class" throw-if-false ;
29 : add-protocols ( protocols class -- )
30 '[ [ _ ] dip objc-protocol add-protocol ] each ;
32 : (define-objc-class) ( methods protocols superclass name -- )
33 [ objc-class ] dip 0 objc_allocateClassPair
34 [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
37 : encode-type ( type -- encoded )
38 dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
40 : encode-types ( return types -- encoding )
41 swap prefix [ encode-type "0" append ] map concat ;
43 : prepare-method ( ret types quot -- type imp )
44 [ [ encode-types ] 2keep ] dip
45 '[ _ _ cdecl _ alien-callback ]
46 (( -- callback )) define-temp ;
48 : prepare-methods ( methods -- methods )
50 [ first4 prepare-method 3array ] map
51 ] with-compilation-unit ;
53 :: (redefine-objc-method) ( class method -- )
54 method init-method :> ( sel imp types )
56 class sel class_getInstanceMethod [
57 imp method_setImplementation drop
59 class sel imp types add-method
62 : redefine-objc-methods ( methods name -- )
64 objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
67 :: define-objc-class ( name superclass protocols methods -- )
68 methods prepare-methods :> methods
69 name "cocoa.classes" create drop
70 methods name redefine-objc-methods
71 name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
78 \ ] parse-until define-objc-class ;
80 : (parse-selector) ( -- )
82 { [ dup "[" = ] [ drop ] }
83 { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
84 [ f f 3array , "[" expect ]
87 : parse-selector ( -- selector types names )
88 [ (parse-selector) ] { } make
91 [ sift { id SEL } prepend ]
92 [ sift { "self" "selector" } prepend ] tri* ;
94 : parse-method-body ( names -- quot )
95 [ [ make-local ] map ] H{ } make-assoc
96 (parse-lambda) <lambda> ?rewrite-closures first ;
98 : method-effect ( quadruple -- effect )
99 [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
101 : check-method ( quadruple -- )
102 [ fourth infer ] [ method-effect ] bi
103 2dup effect<= [ 2drop ] [ effect-error ] if ;
108 parse-method-body [ swap ] 2dip 4array