1 ! Copyright (C) 2006, 2008 Slava Pestov
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
6 compiler.units io.encodings.ascii generalizations
10 : init-method ( method -- sel imp types )
12 [ sel_registerName ] [ execute ] [ ascii string>alien ]
15 : throw-if-false ( YES/NO -- )
16 zero? [ "Failed to add method or protocol to class" throw ]
19 : add-methods ( methods class -- )
21 [ init-method class_addMethod throw-if-false ] with each ;
23 : add-protocols ( protocols class -- )
24 swap [ objc-protocol class_addProtocol throw-if-false ]
27 : (define-objc-class) ( protocols superclass name imeth -- )
29 [ objc-class ] dip 0 objc_allocateClassPair
30 [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
33 : encode-types ( return types -- encoding )
35 alien>objc-types get at "0" append
38 : prepare-method ( ret types quot -- type imp )
39 >r [ encode-types ] 2keep r> [
40 "cdecl" swap 4array % \ alien-callback ,
41 ] [ ] make define-temp ;
43 : prepare-methods ( methods -- methods )
45 [ first4 prepare-method 3array ] map
46 ] with-compilation-unit ;
49 [ ascii alien>string ] bi@ = ;
51 : (verify-method-type) ( class sel types -- )
52 [ class_getInstanceMethod method_getTypeEncoding ]
54 [ "Objective-C method types cannot be changed once defined" throw ]
56 : verify-method-type ( class sel imp types -- class sel imp types )
57 4 ndup nip (verify-method-type) ;
59 : (redefine-objc-method) ( class method -- )
60 init-method ! verify-method-type
62 [ class_getInstanceMethod ] dip method_setImplementation drop ;
64 : redefine-objc-methods ( imeth name -- )
66 objc_getClass swap [ (redefine-objc-method) ] with each
75 : define-objc-class ( imeth hash -- )
78 +name+ get "cocoa.classes" create drop
79 +name+ get 2dup redefine-objc-methods swap [
80 +protocols+ get , +superclass+ get , +name+ get , ,
81 \ (define-objc-class) ,
82 ] [ ] make import-objc-class
86 parse-definition unclip
87 >hashtable define-objc-class ; parsing