basis/cocoa/subclassing/subclassing.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types alien.strings arrays assocs
   4 combinators compiler hashtables kernel libc math namespaces
   5 parser sequences words cocoa.messages cocoa.runtime
   6 compiler.units io.encodings.ascii ;
   7 IN: cocoa.subclassing
   8
   9 : init-method ( method alien -- )
  10     >r first3 r>
  11     [ >r execute r> set-objc-method-imp ] keep
  12     [ >r ascii malloc-string r> set-objc-method-types ] keep
  13     >r sel_registerName r> set-objc-method-name ;
  14
  15 : <empty-method-list> ( n -- alien )
  16     "objc-method-list" heap-size
  17     "objc-method" heap-size pick * + 1 calloc
  18     [ set-objc-method-list-count ] keep ;
  19
  20 : <method-list> ( methods -- alien )
  21     dup length dup <empty-method-list> -rot
  22     [ pick method-list@ objc-method-nth init-method ] 2each ;
  23
  24 : define-objc-methods ( class methods -- )
  25     <method-list> class_addMethods ;
  26
  27 : <objc-class> ( name info -- class )
  28     "objc-class" malloc-object
  29     [ set-objc-class-info ] keep
  30     [ >r ascii malloc-string r> set-objc-class-name ] keep ;
  31
  32 : <protocol-list> ( name -- protocol-list )
  33     "objc-protocol-list" malloc-object
  34     1 over set-objc-protocol-list-count
  35     swap objc-protocol over set-objc-protocol-list-class ;
  36
  37 ! The Objective C object model is a bit funny.
  38 ! Every class has a metaclass.
  39
  40 ! The superclass of the metaclass of X is the metaclass of the
  41 ! superclass of X.
  42
  43 ! The metaclass of the metaclass of X is the metaclass of the
  44 ! root class of X.
  45 : meta-meta-class ( class -- class ) root-class objc-class-isa ;
  46
  47 : copy-instance-size ( class -- )
  48     dup objc-class-super-class objc-class-instance-size
  49     swap set-objc-class-instance-size ;
  50
  51 : <meta-class> ( superclass name -- class )
  52     CLS_META <objc-class>
  53     [ >r dup objc-class-isa r> set-objc-class-super-class ] keep
  54     [ >r meta-meta-class r> set-objc-class-isa ] keep
  55     dup copy-instance-size ;
  56
  57 : set-protocols ( protocols class -- )
  58     swap {
  59         { [ dup empty? ] [ 2drop ] }
  60         { [ dup length 1 = ] [
  61             first <protocol-list>
  62             swap set-objc-class-protocols
  63         ] }
  64     } cond ;
  65
  66 : <new-class> ( protocols metaclass superclass name -- class )
  67     CLS_CLASS <objc-class>
  68     [ set-objc-class-super-class ] keep
  69     [ set-objc-class-isa ] keep
  70     [ set-protocols ] keep
  71     dup copy-instance-size ;
  72
  73 : (define-objc-class) ( protocols superclass name imeth -- )
  74     >r
  75     >r objc-class r>
  76     [ <meta-class> ] 2keep <new-class> dup objc_addClass
  77     r> <method-list> class_addMethods ;
  78
  79 : encode-types ( return types -- encoding )
  80     swap prefix [
  81         alien>objc-types get at "0" append
  82     ] map concat ;
  83
  84 : prepare-method ( ret types quot -- type imp )
  85     >r [ encode-types ] 2keep r> [
  86         "cdecl" swap 4array % \ alien-callback ,
  87     ] [ ] make define-temp ;
  88
  89 : prepare-methods ( methods -- methods )
  90     [
  91         [ first4 prepare-method 3array ] map
  92     ] with-compilation-unit ;
  93
  94 : redefine-objc-methods ( imeth name -- )
  95     dup class-exists? [
  96         objc_getClass swap define-objc-methods
  97     ] [
  98         2drop
  99     ] if ;
 100
 101 SYMBOL: +name+
 102 SYMBOL: +protocols+
 103 SYMBOL: +superclass+
 104
 105 : define-objc-class ( imeth hash -- )
 106     clone [
 107         prepare-methods
 108         +name+ get "cocoa.classes" create drop
 109         +name+ get 2dup redefine-objc-methods swap [
 110             +protocols+ get , +superclass+ get , +name+ get , ,
 111             \ (define-objc-class) ,
 112         ] [ ] make import-objc-class
 113     ] bind ;
 114
 115 : CLASS:
 116     parse-definition unclip
 117     >hashtable define-objc-class ; parsing