core/compiler/alien/objc/subclassing.factor

   1 ! Copyright (C) 2006 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: objc
   4 USING: alien arrays compiler hashtables kernel kernel-internals
   5 libc math namespaces sequences strings words ;
   6
   7 : init-method ( method alien -- )
   8     >r first3 r>
   9     [ >r execute r> set-objc-method-imp ] keep
  10     [ >r <malloc-string> r> set-objc-method-types ] keep
  11     >r sel_registerName r> set-objc-method-name ;
  12
  13 : <empty-method-list> ( n -- alien )
  14     "objc-method-list" c-size
  15     "objc-method" c-size pick * + 1 calloc
  16     [ set-objc-method-list-count ] keep ;
  17
  18 : <method-list> ( methods -- alien )
  19     dup length dup <empty-method-list> -rot
  20     [ pick method-list@ objc-method-nth init-method ] 2each ;
  21
  22 : define-objc-methods ( class methods -- )
  23     <method-list> class_addMethods ;
  24
  25 : <objc-class> ( name info -- class )
  26     "objc-class" <malloc-object>
  27     [ set-objc-class-info ] keep
  28     [ >r <malloc-string> r> set-objc-class-name ] keep ;
  29
  30 ! The Objective C object model is a bit funny.
  31 ! Every class has a metaclass.
  32
  33 ! The superclass of the metaclass of X is the metaclass of the
  34 ! superclass of X.
  35
  36 ! The metaclass of the metaclass of X is the metaclass of the
  37 ! root class of X.
  38 : meta-meta-class ( class -- class ) root-class objc-class-isa ;
  39
  40 : copy-instance-size ( class -- )
  41     dup objc-class-super-class objc-class-instance-size
  42     swap set-objc-class-instance-size ;
  43
  44 : <meta-class> ( superclass name -- class )
  45     CLS_META <objc-class>
  46     [ >r dup objc-class-isa r> set-objc-class-super-class ] keep
  47     [ >r meta-meta-class r> set-objc-class-isa ] keep
  48     dup copy-instance-size ;
  49
  50 : <new-class> ( metaclass superclass name -- class )
  51     CLS_CLASS <objc-class>
  52     [ set-objc-class-super-class ] keep
  53     [ set-objc-class-isa ] keep
  54     dup copy-instance-size ;
  55
  56 : (define-objc-class) ( superclass name imeth -- )
  57     >r
  58     >r objc-class r>
  59     [ <meta-class> ] 2keep <new-class> dup objc_addClass
  60     r> <method-list> class_addMethods ;
  61
  62 : encode-types ( return types -- encoding )
  63     >r 1array r> append
  64     [ [ alien>objc-types get hash % CHAR: 0 , ] each ] "" make ;
  65
  66 : struct-return ( ret types quot -- ret types quot )
  67     pick c-struct? [
  68         pick c-size [ memcpy ] curry append
  69         >r { "void*" } swap append >r drop "void" r> r>
  70     ] when ;
  71
  72 : prepare-method ( ret types quot -- type imp )
  73     >r [ encode-types ] 2keep r>
  74     [ struct-return 3array % \ alien-callback , ] [ ] make
  75     compile-quot ;
  76
  77 : prepare-methods ( methods -- methods )
  78     [ first4 prepare-method 3array ] map ;
  79
  80 : redefine-objc-methods ( name imeth -- )
  81     >r objc_getClass r> define-objc-methods ;
  82
  83 : define-objc-class ( superclass name imeth -- )
  84     prepare-methods
  85     over class-exists? [ 2dup redefine-objc-methods ] when
  86     over >r [ 3array % \ (define-objc-class) , ] [ ] make r>
  87     swap import-objc-class ;