Merge branch 'objective-c-2' of git://repo.or.cz/factor/jcg into new_cocoa
Slava Pestov
commit
7ef777c3ad
|
|
@ -4,7 +4,8 @@ USING: accessors alien alien.c-types alien.strings
|
|||
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 )
|
||||
|
|
@ -36,7 +37,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
|
|||
|
||||
: <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 ;
|
||||
|
|
@ -101,11 +102,6 @@ MACRO: (send) ( selector super? -- quot )
|
|||
: objc-meta-class ( string -- class )
|
||||
\ objc_getMetaClass (objc-class) ;
|
||||
|
||||
: method-arg-type ( method i -- type )
|
||||
f <void*> 0 <int> over
|
||||
>r method_getArgumentInfo drop
|
||||
r> *void* ascii alien>string ;
|
||||
|
||||
SYMBOL: objc>alien-types
|
||||
|
||||
H{
|
||||
|
|
@ -159,34 +155,32 @@ H{
|
|||
|
||||
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
|
||||
|
||||
: method-arg-type ( method i -- type )
|
||||
method_copyArgumentType
|
||||
[ ascii alien>string parse-objc-type ] keep
|
||||
(free) ;
|
||||
|
||||
: method-arg-types ( method -- args )
|
||||
dup method_getNumberOfArguments
|
||||
[ method-arg-type parse-objc-type ] with map ;
|
||||
[ method-arg-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 parse-objc-type ] 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 ;
|
||||
|
||||
|
|
@ -209,4 +203,4 @@ H{
|
|||
] curry try ;
|
||||
|
||||
: root-class ( class -- root )
|
||||
dup objc-class-super-class [ root-class ] [ ] ?if ;
|
||||
dup class_getSuperclass [ root-class ] [ ] ?if ;
|
||||
|
|
|
|||
|
|
@ -13,9 +13,13 @@ FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
|
|||
|
||||
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 ;
|
||||
|
|
@ -27,61 +31,47 @@ C-STRUCT: objc-super
|
|||
: 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: objc-class* objc_getMetaClass ( char* class ) ;
|
||||
FUNCTION: Class objc_getMetaClass ( char* class ) ;
|
||||
|
||||
FUNCTION: objc-class* objc_getProtocol ( char* class ) ;
|
||||
FUNCTION: Protocol objc_getProtocol ( char* class ) ;
|
||||
|
||||
FUNCTION: void objc_addClass ( objc-class* class ) ;
|
||||
FUNCTION: Class objc_allocateClassPair ( Class superclass, char* name, size_t extraBytes ) ;
|
||||
FUNCTION: void objc_registerClassPair ( Class cls ) ;
|
||||
|
||||
FUNCTION: id class_createInstance ( objc-class* class, uint additionalByteCount ) ;
|
||||
FUNCTION: id class_createInstance ( Class class, uint additionalByteCount ) ;
|
||||
|
||||
FUNCTION: id class_createInstanceFromZone ( objc-class* class, uint additionalByteCount, void* zone ) ;
|
||||
FUNCTION: id class_createInstanceFromZone ( Class class, uint additionalByteCount, void* zone ) ;
|
||||
|
||||
C-STRUCT: objc-method
|
||||
{ "SEL" "name" }
|
||||
{ "char*" "types" }
|
||||
{ "void*" "imp" } ;
|
||||
FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ;
|
||||
|
||||
FUNCTION: objc-method* class_getInstanceMethod ( objc-class* class, SEL selector ) ;
|
||||
FUNCTION: Method class_getClassMethod ( Class class, SEL selector ) ;
|
||||
|
||||
FUNCTION: objc-method* class_getClassMethod ( objc-class* class, SEL selector ) ;
|
||||
FUNCTION: Method* class_copyMethodList ( Class class, uint* outCount ) ;
|
||||
|
||||
C-STRUCT: objc-method-list
|
||||
{ "void*" "obsolete" }
|
||||
{ "int" "count" } ;
|
||||
FUNCTION: Class class_getSuperclass ( Class cls ) ;
|
||||
|
||||
FUNCTION: objc-method-list* class_nextMethodList ( objc-class* class, void** iterator ) ;
|
||||
FUNCTION: char class_addMethod ( Class class, SEL name, void* imp, void* types ) ;
|
||||
|
||||
FUNCTION: void class_addMethods ( objc-class* class, objc-method-list* methodList ) ;
|
||||
FUNCTION: char class_addProtocol ( Class class, Protocol protocol ) ;
|
||||
|
||||
FUNCTION: void class_removeMethods ( objc-class* class, objc-method-list* methodList ) ;
|
||||
FUNCTION: uint method_getNumberOfArguments ( Method method ) ;
|
||||
|
||||
FUNCTION: uint method_getNumberOfArguments ( objc-method* method ) ;
|
||||
FUNCTION: uint method_getSizeOfArguments ( Method method ) ;
|
||||
|
||||
FUNCTION: uint method_getSizeOfArguments ( objc-method* method ) ;
|
||||
FUNCTION: uint method_getArgumentInfo ( Method method, int argIndex, char** type, int* offset ) ;
|
||||
|
||||
FUNCTION: uint method_getArgumentInfo ( objc-method* method, int argIndex, char** type, int* offset ) ;
|
||||
FUNCTION: void* method_copyReturnType ( Method method ) ;
|
||||
|
||||
C-STRUCT: objc-protocol-list
|
||||
{ "void*" "next" }
|
||||
{ "int" "count" }
|
||||
{ "objc-class*" "class" } ;
|
||||
FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ;
|
||||
|
||||
FUNCTION: void* method_getTypeEncoding ( Method method ) ;
|
||||
|
||||
FUNCTION: SEL method_getName ( Method method ) ;
|
||||
|
||||
FUNCTION: void* method_setImplementation ( Method method, void* imp ) ;
|
||||
|
||||
FUNCTION: Class object_getClass ( id object ) ;
|
||||
|
|
|
|||
|
|
@ -3,78 +3,27 @@
|
|||
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 [
|
||||
|
|
@ -91,9 +40,25 @@ IN: cocoa.subclassing
|
|||
[ 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 each
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ M: f <CFNumber>
|
|||
dup <CFBundle> [
|
||||
CFBundleLoadExecutable drop
|
||||
] [
|
||||
"Cannot load bundled named " prepend throw
|
||||
"Cannot load bundle named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
TUPLE: CFRelease-destructor alien disposed ;
|
||||
|
|
|
|||
|
|
@ -127,7 +127,6 @@ CLASS: {
|
|||
{ +protocols+ { "NSTextInput" } }
|
||||
}
|
||||
|
||||
! Rendering
|
||||
! Rendering
|
||||
{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
|
||||
[ 3drop window relayout-1 ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue