Beginning to implement Objective C subclassing

library/cocoa/init-cocoa.factor

@@ -37,5 +37,5 @@ USING: cocoa compiler io kernel objc sequences words ;
     "WebFrame"
     "WebView"
 } [
-    dup print flush define-objc-class
+    dup print flush import-objc-class
 ] each

library/cocoa/runtime.factor

@@ -12,6 +12,16 @@ FUNCTION: bool sel_isMapped ( SEL aSelector ) ;
 
 FUNCTION: SEL sel_registerName ( char* str ) ;
 
+: CLS_CLASS        HEX: 1   ;
+: CLS_META         HEX: 2   ;
+: CLS_INITIALIZED  HEX: 4   ;
+: CLS_POSING       HEX: 8   ;
+: CLS_MAPPED       HEX: 10  ;
+: CLS_FLUSH_CACHE  HEX: 20  ;
+: CLS_GROW_CACHE   HEX: 40  ;
+: CLS_NEED_BIND    HEX: 80  ;
+: CLS_METHOD_ARRAY HEX: 100 ;
+
 BEGIN-STRUCT: objc-class
     FIELD: void* isa
     FIELD: void* super-class
@@ -35,6 +45,8 @@ FUNCTION: objc-class* objc_getClass ( char* class ) ;
 
 FUNCTION: objc-class* objc_getMetaClass ( char* class ) ;
 
+FUNCTION: void objc_addClass ( objc-class* class ) ;
+
 FUNCTION: id class_createInstance ( objc-class* class, uint additionalByteCount ) ;
 
 FUNCTION: id class_createInstanceFromZone ( objc-class* class, uint additionalByteCount, void* zone ) ;

library/cocoa/subclassing.factor

@@ -3,3 +3,38 @@
 IN: objc
 USING: alien kernel kernel-internals libc math sequences ;
 
+: <method-lists> ( -- lists )
+    "void*" <malloc-object> -1 over 0 set-alien-unsigned-cell ;
+
+: <objc-class> ( name info -- class )
+    "objc-class" <malloc-object>
+    [ set-objc-class-info ] keep
+    [ >r <malloc-string> r> set-objc-class-name ] keep
+    <method-lists> over set-objc-class-methodLists ;
+
+! 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 ;
+
+: <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 ;
+
+: <new-class> ( metaclass superclass name -- class )
+    CLS_CLASS <objc-class>
+    [ set-objc-class-super-class ] keep
+    [ set-objc-class-isa ] keep ;
+
+: (define-objc-class) ( superclass name -- class )
+    >r objc-class r> [ <meta-class> ] 2keep <new-class>
+    dup objc_addClass ;
+
+: define-objc-class ( superclass name -- class )
+    dup class-exists?
+    [ nip objc-class ] [ (define-objc-class) ] if ;

library/cocoa/utilities.factor

@@ -26,27 +26,33 @@ C: selector ( name -- sel ) [ set-selector-name ] keep ;
     >r method_getArgumentInfo drop
     r> *char* ;
 
-: objc-primitive-type ( char -- ctype )
+SYMBOL: objc>alien-types
-    H{
+
-        { CHAR: c "char" }
+H{
-        { CHAR: i "int" }
+    { CHAR: c "char" }
-        { CHAR: s "short" }
+    { CHAR: i "int" }
-        { CHAR: l "long" }
+    { CHAR: s "short" }
-        { CHAR: q "longlong" }
+    { CHAR: l "long" }
-        { CHAR: C "uchar" }
+    { CHAR: q "longlong" }
-        { CHAR: I "uint" }
+    { CHAR: C "uchar" }
-        { CHAR: S "ushort" }
+    { CHAR: I "uint" }
-        { CHAR: L "ulong" }
+    { CHAR: S "ushort" }
-        { CHAR: Q "ulonglong" }
+    { CHAR: L "ulong" }
-        { CHAR: f "float" }
+    { CHAR: Q "ulonglong" }
-        { CHAR: d "double" }
+    { CHAR: f "float" }
-        { CHAR: B "bool" }
+    { CHAR: d "double" }
-        { CHAR: v "void" }
+    { CHAR: B "bool" }
-        { CHAR: * "char*" }
+    { CHAR: v "void" }
-        { CHAR: @ "id" }
+    { CHAR: * "char*" }
-        { CHAR: # "id" }
+    { CHAR: @ "id" }
-        { CHAR: : "SEL" }
+    { CHAR: # "id" }
-    } hash ;
+    { CHAR: : "SEL" }
+} hash objc>alien-types set-global
+
+SYMBOL: alien>objc-types
+
+objc>alien-types get hash>alist [ reverse ] map alist>hash
+alien>objc-types get
 
 : objc-struct-type ( i string -- ctype )
     2dup CHAR: = -rot index* swap subseq ;
@@ -57,7 +63,7 @@ C: selector ( name -- sel ) [ set-selector-name ] keep ;
         { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
         { [ dup CHAR: [ = ] [ 3drop "void*" ] }
-        { [ t ] [ 2nip objc-primitive-type ] }
+        { [ t ] [ 2nip objc>alien-types get hash ] }
     } cond ;
 
 : parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
@@ -132,20 +138,23 @@ C: selector ( name -- sel ) [ set-selector-name ] keep ;
     pick c-struct?
     [ make-objc-send-stret ] [ make-objc-send ] if ;
 
-: define-objc-method ( returns types selector -- )
+: import-objc-method ( returns types selector -- )
     [ make-objc-method "[" ] keep "]" append3 create-in
     swap define-compound ;
 
-: define-objc-methods ( seq -- )
+: import-objc-methods ( seq -- )
-    [ first3 swap define-objc-method ] each ;
+    [ first3 swap import-objc-method ] each ;
 
 : define-objc-class-word ( name -- )
-    create-in over [ objc_getClass ] curry define-compound ;
+    create-in over [ objc-class ] curry define-compound ;
 
-: define-objc-class ( name -- )
+: import-objc-class ( name -- )
     [
         "objc-" over append in set
         dup define-objc-class-word
-        dup instance-methods define-objc-methods
+        dup instance-methods import-objc-methods
-        class-methods define-objc-methods
+        class-methods import-objc-methods
     ] with-scope ;
+
+: root-class ( class -- class )
+    dup objc-class-super-class [ root-class ] [ ] ?if ;