Fleshed out Cocoa subclassing

Makefile

@@ -88,7 +88,7 @@ bsd:
 macosx:
 	$(MAKE) $(BINARY) \
 		CFLAGS="$(DEFAULT_CFLAGS)" \
-		LIBS="$(DEFAULT_LIBS)" \
+		LIBS="$(DEFAULT_LIBS) -framework Cocoa -framework OpenGL" \
 		MACOSX=y
 
 macosx-sdl:

TODO.FACTOR.txt

@@ -19,6 +19,7 @@
 
 + ui/help:
 
+- changelog in the UI
 - make the UI look better, something like this:
   http://twb.ath.cx/~twb/darcs/OBSOLETE/factor/final.html
 - fix remaining HTML stream issues
@@ -29,9 +30,9 @@
 - document tools
 - document conventions
 - new turtle graphics tutorial
-- better line spacing in ui
+- better line spacing in ui and html
 - use vertex arrays and display lists to speed up ui
-- tabular formatting
+- tabular formatting - for inspector and changes
 - don't multiplex in the event loop if there is no pending i/o
 
 + compiler/ffi:

library/alien/alien-callback.factor

@@ -13,7 +13,7 @@ TUPLE: alien-callback-error ;
 M: alien-callback-error summary ( error -- )
     drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
 
-: alien-callback ( ... return parameters quot -- ... )
+: alien-callback ( return parameters quot -- address )
     <alien-callback-error> throw ;
 
 : callback-bottom ( node -- )

library/alien/aliens.factor

@@ -17,7 +17,8 @@ sequences ;
 ! parameter, or a missing abi parameter indicates the cdecl ABI
 ! should be used, which is common on Unix.
 
-: <alien> ( address -- alien ) f <displaced-alien> ; inline
+: <alien> ( address -- alien )
+    dup zero? [ drop f ] [ f <displaced-alien> ] if ; inline
 
 UNION: c-ptr byte-array alien ;
 

library/cocoa/runtime.factor

@@ -64,7 +64,6 @@ FUNCTION: objc-method* class_getClassMethod ( objc-class* class, SEL selector )
 BEGIN-STRUCT: objc-method-list
     FIELD: void* obsolete
     FIELD: int count
-    FIELD: objc-method elements
 END-STRUCT
 
 FUNCTION: objc-method-list* class_nextMethodList ( objc-class* class, void** iterator ) ;

library/cocoa/subclassing.factor

@@ -1,17 +1,41 @@
 ! Copyright (C) 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: objc
-USING: alien kernel kernel-internals libc math sequences ;
+USING: alien arrays compiler hashtables kernel kernel-internals
+libc math namespaces sequences strings ;
 
-: <method-lists> ( -- lists )
-    "void*" <malloc-object> -1 over 0 set-alien-unsigned-cell ;
+: encode-types ( return types -- encoding )
+    >r 1array r> append
+    [ alien>objc-types get hash ] map >string ;
+
+: prepare-method ( { name return types quot } -- sel type imp )
+    [ first3 encode-types >r sel_registerName r> ] keep
+    [ % \ alien-callback , ] [ ] make compile-1 ;
+
+: init-method ( method alien -- )
+    >r prepare-method r>
+    [ set-objc-method-imp ] keep
+    [ set-objc-method-types ] keep
+    set-objc-method-name ;
+
+: <empty-method-list> ( n -- alien )
+    "objc-method-list" c-size
+    "objc-method" c-size rot * + 1 calloc ;
+
+: <method-list> ( methods -- alien )
+    dup length dup <empty-method-list> -rot
+    [ pick objc-method-nth init-method ] 2each ;
+
+: <method-lists> ( methods -- lists )
+    <method-list> alien-address
+    "void*" <malloc-object> [ 0 set-alien-unsigned-cell ] keep ;
 
 : <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 ;
+    [ >r <malloc-string> r> set-objc-class-name ] keep ;
 
+! 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
@@ -21,20 +45,22 @@ USING: alien kernel kernel-internals libc math sequences ;
 ! root class of X.
 : meta-meta-class ( class -- class ) root-class objc-class-isa ;
 
-: <meta-class> ( superclass name -- class )
+: <meta-class> ( methods 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 ;
+    [ >r meta-meta-class r> set-objc-class-isa ] keep
+    [ >r <method-lists> r> set-objc-class-methodLists ] keep ;
 
-: <new-class> ( metaclass superclass name -- class )
+: <new-class> ( methods metaclass superclass name -- class )
     CLS_CLASS <objc-class>
     [ set-objc-class-super-class ] keep
-    [ set-objc-class-isa ] keep ;
+    [ set-objc-class-isa ] keep
+    [ >r <method-lists> r> set-objc-class-methodLists ] keep ;
 
-: (define-objc-class) ( superclass name -- class )
+: (define-objc-class) ( imeth cmeth superclass name -- class )
     >r objc-class r> [ <meta-class> ] 2keep <new-class>
     dup objc_addClass ;
 
-: define-objc-class ( superclass name -- class )
+: define-objc-class ( imeth cmeth superclass name -- class )
     dup class-exists?
-    [ nip objc-class ] [ (define-objc-class) ] if ;
+    [ >r 3drop r> objc-class ] [ (define-objc-class) ] if ;

library/cocoa/utilities.factor

@@ -47,12 +47,12 @@ H{
     { CHAR: @ "id" }
     { CHAR: # "id" }
     { CHAR: : "SEL" }
-} hash objc>alien-types set-global
+} objc>alien-types set-global
 
 SYMBOL: alien>objc-types
 
 objc>alien-types get hash>alist [ reverse ] map alist>hash
-alien>objc-types get
+alien>objc-types set-global
 
 : objc-struct-type ( i string -- ctype )
     2dup CHAR: = -rot index* swap subseq ;

library/inference/known-words.factor

@@ -381,9 +381,6 @@ sequences strings vectors words prettyprint ;
 \ dlsym [ [ string object ] [ integer ] ] "infer-effect" set-word-prop
 \ dlclose [ [ dll ] [ ] ] "infer-effect" set-word-prop
 
-\ <alien> [ [ integer ] [ alien ] ] "infer-effect" set-word-prop
-\ <alien> t "flushable" set-word-prop
-
 \ <byte-array> [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop
 \ <byte-array> t "flushable" set-word-prop
 

native/alien.c

@@ -99,8 +99,12 @@ void primitive_alien_to_string(void)
 /* convert Factor string to C string allocated in the Factor heap */
 void primitive_string_to_alien(void)
 {
+	CELL string, type;
 	maybe_gc(0);
-	drepl(tag_object(string_to_alien(untag_string(dpeek()),true)));
+	string = dpeek();
+	type = type_of(string);
+	if(type != ALIEN_TYPE && type != BYTE_ARRAY_TYPE && type != F_TYPE)
+		drepl(tag_object(string_to_alien(untag_string(string),true)));
 }
 
 /* image loading */