arrays assocs combinators compiler kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii effects compiler.generator ;
+memoize debugger io.encodings.ascii effects compiler.generator
+libc libc.private ;
IN: cocoa.messages
: make-sender ( method function -- quot )
: <super> ( receiver -- super )
"objc-super" <c-object> [
- >r dup objc-object-isa objc-class-super-class r>
+ >r dup object_getClass class_getSuperclass r>
set-objc-super-class
] keep
[ set-objc-super-receiver ] keep ;
: objc-meta-class ( string -- class )
\ objc_getMetaClass (objc-class) ;
+USE: prettyprint
+: (.) ( foo bar -- foo )
+ . dup . ;
+
: method-arg-type ( method i -- type )
- f <void*> 0 <int> over
- >r method_getArgumentInfo drop
- r> *void* ascii alien>string ;
+ method_copyArgumentType [ ascii alien>string ] keep (free) ;
SYMBOL: objc>alien-types
[ method-arg-type parse-objc-type ] with map ;
: method-return-type ( method -- ctype )
- #! Undocumented hack! Apple does not support this feature!
- objc-method-types parse-objc-type ;
+ method_copyReturnType [ ascii alien>string ] keep (free) ;
: register-objc-method ( method -- )
dup method-return-type over method-arg-types 2array
dup cache-stubs
- swap objc-method-name sel_getName
+ swap method_getName sel_getName
objc-methods get set-at ;
-: method-list@ ( ptr -- ptr )
- "objc-method-list" heap-size swap <displaced-alien> ;
-
-: (register-objc-methods) ( objc-class iterator -- )
- 2dup class_nextMethodList [
- dup objc-method-list-count swap method-list@ [
- objc-method-nth register-objc-method
- ] curry each (register-objc-methods)
- ] [
- 2drop
- ] if* ;
+: (register-objc-methods) ( methods count -- methods )
+ over [ void*-nth register-objc-method ] curry each ;
: register-objc-methods ( class -- )
- f <void*> (register-objc-methods) ;
+ 0 <uint> [ class_copyMethodList ] keep *uint
+ (register-objc-methods) (free) ;
: class-exists? ( string -- class ) objc_getClass >boolean ;
] curry try ;
: root-class ( class -- root )
- dup objc-class-super-class [ root-class ] [ ] ?if ;
+ dup class_getSuperclass [ root-class ] [ ] ?if ;
FUNCTION: SEL sel_registerName ( char* str ) ;
+TYPEDEF: void* Class
+TYPEDEF: void* Method
+TYPEDEF: void* Protocol
+
C-STRUCT: objc-super
{ "id" "receiver" }
- { "void*" "class" } ;
+ { "Class" "class" } ;
: CLS_CLASS HEX: 1 ;
: CLS_META HEX: 2 ;
: CLS_NEED_BIND HEX: 80 ;
: CLS_METHOD_ARRAY HEX: 100 ;
-C-STRUCT: objc-class
- { "void*" "isa" }
- { "void*" "super-class" }
- { "char*" "name" }
- { "long" "version" }
- { "long" "info" }
- { "long" "instance-size" }
- { "void*" "ivars" }
- { "void*" "methodLists" }
- { "void*" "cache" }
- { "void*" "protocols" } ;
-
-C-STRUCT: objc-object
- { "objc-class*" "isa" } ;
-
FUNCTION: int objc_getClassList ( void* buffer, int bufferLen ) ;
-FUNCTION: objc-class* objc_getClass ( char* class ) ;
+FUNCTION: Class objc_getClass ( char* class ) ;
+
+FUNCTION: Class objc_getMetaClass ( char* class ) ;
+
+FUNCTION: Protocol objc_getProtocol ( char* class ) ;
+
+FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
+FUNCTION: Class objc_registerClassPair ( Class cls ) ;
+
+FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
-FUNCTION: objc-class* objc_getMetaClass ( char* class ) ;
+FUNCTION: id class_createInstanceFromZone ( Class class, uint additionalByteCount, void* zone ) ;
-FUNCTION: objc-class* objc_getProtocol ( char* class ) ;
+FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ;
-FUNCTION: void objc_addClass ( objc-class* class ) ;
+FUNCTION: Method class_getClassMethod ( Class class, SEL selector ) ;
-FUNCTION: id class_createInstance ( objc-class* class, uint additionalByteCount ) ;
+FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
-FUNCTION: id class_createInstanceFromZone ( objc-class* class, uint additionalByteCount, void* zone ) ;
+FUNCTION: Class class_getSuperclass ( Class cls ) ;
-C-STRUCT: objc-method
- { "SEL" "name" }
- { "char*" "types" }
- { "void*" "imp" } ;
+FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
-FUNCTION: objc-method* class_getInstanceMethod ( objc-class* class, SEL selector ) ;
+FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
-FUNCTION: objc-method* class_getClassMethod ( objc-class* class, SEL selector ) ;
+FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
-C-STRUCT: objc-method-list
- { "void*" "obsolete" }
- { "int" "count" } ;
+FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
-FUNCTION: objc-method-list* class_nextMethodList ( objc-class* class, void** iterator ) ;
+FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
-FUNCTION: void class_addMethods ( objc-class* class, objc-method-list* methodList ) ;
+FUNCTION: void* method_copyReturnType ( Method method ) ;
-FUNCTION: void class_removeMethods ( objc-class* class, objc-method-list* methodList ) ;
+FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ;
-FUNCTION: uint method_getNumberOfArguments ( objc-method* method ) ;
+FUNCTION: void* method_getTypeEncoding ( Method method ) ;
-FUNCTION: uint method_getSizeOfArguments ( objc-method* method ) ;
+FUNCTION: SEL method_getName ( Method method ) ;
-FUNCTION: uint method_getArgumentInfo ( objc-method* method, int argIndex, char** type, int* offset ) ;
+FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
-C-STRUCT: objc-protocol-list
- { "void*" "next" }
- { "int" "count" }
- { "objc-class*" "class" } ;
+FUNCTION: Class object_getClass ( id object ) ;
USING: alien alien.c-types alien.strings arrays assocs
combinators compiler hashtables kernel libc math namespaces
parser sequences words cocoa.messages cocoa.runtime
-compiler.units io.encodings.ascii ;
+compiler.units io.encodings.ascii generalizations
+continuations ;
IN: cocoa.subclassing
-: init-method ( method alien -- )
- >r first3 r>
- [ >r execute r> set-objc-method-imp ] keep
- [ >r ascii malloc-string r> set-objc-method-types ] keep
- >r sel_registerName r> set-objc-method-name ;
+: init-method ( method -- sel imp types )
+ first3 swap
+ [ sel_registerName ] [ execute ] [ ascii string>alien ]
+ tri* ;
-: <empty-method-list> ( n -- alien )
- "objc-method-list" heap-size
- "objc-method" heap-size pick * + 1 calloc
- [ set-objc-method-list-count ] keep ;
+: add-methods ( methods class -- )
+ swap
+ [ init-method class_addMethod drop ] with each ;
-: <method-list> ( methods -- alien )
- dup length dup <empty-method-list> -rot
- [ pick method-list@ objc-method-nth init-method ] 2each ;
-
-: define-objc-methods ( class methods -- )
- <method-list> class_addMethods ;
-
-: <objc-class> ( name info -- class )
- "objc-class" malloc-object
- [ set-objc-class-info ] keep
- [ >r ascii malloc-string r> set-objc-class-name ] keep ;
-
-: <protocol-list> ( name -- protocol-list )
- "objc-protocol-list" malloc-object
- 1 over set-objc-protocol-list-count
- swap objc-protocol over set-objc-protocol-list-class ;
-
-! The Objective C object model is a bit funny.
-! Every class has a metaclass.
-
-! The superclass of the metaclass of X is the metaclass of the
-! superclass of X.
-
-! The metaclass of the metaclass of X is the metaclass of the
-! root class of X.
-: meta-meta-class ( class -- class ) root-class objc-class-isa ;
-
-: copy-instance-size ( class -- )
- dup objc-class-super-class objc-class-instance-size
- swap set-objc-class-instance-size ;
-
-: <meta-class> ( superclass name -- class )
- CLS_META <objc-class>
- [ >r dup objc-class-isa r> set-objc-class-super-class ] keep
- [ >r meta-meta-class r> set-objc-class-isa ] keep
- dup copy-instance-size ;
-
-: set-protocols ( protocols class -- )
- swap {
- { [ dup empty? ] [ 2drop ] }
- { [ dup length 1 = ] [
- first <protocol-list>
- swap set-objc-class-protocols
- ] }
- } cond ;
-
-: <new-class> ( protocols metaclass superclass name -- class )
- CLS_CLASS <objc-class>
- [ set-objc-class-super-class ] keep
- [ set-objc-class-isa ] keep
- [ set-protocols ] keep
- dup copy-instance-size ;
+: add-protocols ( protocols class -- )
+ swap [ objc-protocol class_addProtocol drop ] with each ;
: (define-objc-class) ( protocols superclass name imeth -- )
- >r
- >r objc-class r>
- [ <meta-class> ] 2keep <new-class> dup objc_addClass
- r> <method-list> class_addMethods ;
+ -rot
+ [ objc-class ] dip 0 objc_allocateClassPair
+ [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
+ tri ;
: encode-types ( return types -- encoding )
swap prefix [
[ first4 prepare-method 3array ] map
] with-compilation-unit ;
+: types= ( a b -- ? )
+ [ ascii alien>string ] bi@ = ;
+
+: (verify-method-type) ( class sel types -- )
+ [ class_getInstanceMethod method_getTypeEncoding ]
+ dip types=
+ [ "Objective-C method types cannot be changed once defined" throw ]
+ unless ;
+: verify-method-type ( class sel imp types -- class sel imp types )
+ 4 ndup nip (verify-method-type) ;
+
+: (redefine-objc-method) ( class method -- )
+ init-method verify-method-type drop
+ [ class_getInstanceMethod ] dip method_setImplementation drop ;
+
: redefine-objc-methods ( imeth name -- )
dup class-exists? [
- objc_getClass swap define-objc-methods
+ objc_getClass swap [ (redefine-objc-method) ] with map
] [
2drop
] if ;
{ +protocols+ { "NSTextInput" } }
}
-! Rendering
! Rendering
{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
[ 3drop window relayout-1 ]
projects / factor.git / commitdiff