1 ! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien alien.c-types alien.strings arrays assocs
4 combinators compiler hashtables kernel libc math namespaces
5 parser sequences words cocoa.messages cocoa.runtime locals
6 compiler.units io.encodings.utf8 continuations make fry ;
9 : init-method ( method -- sel imp types )
11 [ sel_registerName ] [ execute ] [ 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) ( imeth protocols superclass name -- )
31 [ objc-class ] dip 0 objc_allocateClassPair
32 [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
35 : encode-type ( type -- encoded )
36 dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
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" swap 4array % \ alien-callback ,
44 ] [ ] make define-temp ;
46 : prepare-methods ( methods -- methods )
48 [ first4 prepare-method 3array ] map
49 ] with-compilation-unit ;
51 :: (redefine-objc-method) ( class method -- )
52 method init-method [| sel imp types |
53 class sel class_getInstanceMethod [
54 imp method_setImplementation drop
56 class sel imp types add-method
60 : redefine-objc-methods ( imeth name -- )
62 objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
69 : define-objc-class ( imeth hash -- )
72 +name+ get "cocoa.classes" create drop
73 +name+ get 2dup redefine-objc-methods swap
74 +protocols+ get +superclass+ get +name+ get
75 '[ _ _ _ _ (define-objc-class) ]
80 parse-definition unclip
81 >hashtable define-objc-class ; parsing