Merge branch 'objective-c-2' of git://repo.or.cz/factor/jcg into new_cocoa

basis/cocoa/messages/messages.factor

@@ -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!
+    method_copyReturnType
-    objc-method-types parse-objc-type ;
+    [ 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 )
+: (register-objc-methods) ( methods count -- methods )
-    "objc-method-list" heap-size swap <displaced-alien> ;
+    over [ void*-nth register-objc-method ] curry each ;
-
-: (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 ( 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 ;

basis/cocoa/runtime/runtime.factor

@@ -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
+FUNCTION: Method class_getInstanceMethod ( Class class, SEL selector ) ;
-    { "SEL" "name" }
-    { "char*" "types" }
-    { "void*" "imp" } ;
 
-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
+FUNCTION: Class class_getSuperclass ( Class cls ) ;
-    { "void*" "obsolete" }
-    { "int" "count" } ;
 
-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
+FUNCTION: void* method_copyArgumentType ( Method method, uint index ) ;
-    { "void*" "next" }
+
-    { "int" "count" }
+FUNCTION: void* method_getTypeEncoding ( Method method ) ;
-    { "objc-class*" "class" } ;
+
+FUNCTION: SEL method_getName ( Method method ) ;
+
+FUNCTION: void* method_setImplementation ( Method method, void* imp ) ; 
+
+FUNCTION: Class object_getClass ( id object ) ;

basis/cocoa/subclassing/subclassing.factor

@@ -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 -- )
+: init-method ( method -- sel imp types )
-    >r first3 r>
+    first3 swap
-    [ >r execute r> set-objc-method-imp ] keep
+    [ sel_registerName ] [ execute ] [ ascii string>alien ]
-    [ >r ascii malloc-string r> set-objc-method-types ] keep
+    tri* ;
-    >r sel_registerName r> set-objc-method-name ;
 
-: <empty-method-list> ( n -- alien )
+: add-methods ( methods class -- )
-    "objc-method-list" heap-size
+    swap
-    "objc-method" heap-size pick * + 1 calloc
+    [ init-method class_addMethod drop ] with each ;
-    [ set-objc-method-list-count ] keep ;
 
-: <method-list> ( methods -- alien )
+: add-protocols ( protocols class -- )
-    dup length dup <empty-method-list> -rot
+    swap [ objc-protocol class_addProtocol drop ] with each ;
-    [ 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 ;
 
 : (define-objc-class) ( protocols superclass name imeth -- )
-    >r
+    -rot
-    >r objc-class r>
+    [ objc-class ] dip 0 objc_allocateClassPair
-    [ <meta-class> ] 2keep <new-class> dup objc_addClass
+    [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
-    r> <method-list> class_addMethods ;
+    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 ;

basis/core-foundation/core-foundation.factor

@@ -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 ;

basis/ui/cocoa/views/views.factor

@@ -127,7 +127,6 @@ CLASS: {
     { +protocols+ { "NSTextInput" } }
 }
 
-! Rendering
 ! Rendering
 { "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
     [ 3drop window relayout-1 ]