basis/cocoa/subclassing/subclassing.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
   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 locals
   6 compiler.units io.encodings.utf8 continuations make fry ;
   7 IN: cocoa.subclassing
   8
   9 : init-method ( method -- sel imp types )
  10     first3 swap
  11     [ sel_registerName ] [ execute ] [ utf8 string>alien ]
  12     tri* ;
  13
  14 : throw-if-false ( obj what -- )
  15     swap { f 0 } member?
  16     [ "Failed to " prepend throw ] [ drop ] if ;
  17
  18 : add-method ( class sel imp types -- )
  19     class_addMethod "add method to class" throw-if-false ;
  20
  21 : add-methods ( methods class -- )
  22     '[ [ _ ] dip init-method add-method ] each ;
  23
  24 : add-protocol ( class protocol -- )
  25     class_addProtocol "add protocol to class" throw-if-false ;
  26
  27 : add-protocols ( protocols class -- )
  28     '[ [ _ ] dip objc-protocol add-protocol ] each ;
  29
  30 : (define-objc-class) ( imeth protocols superclass name -- )
  31     [ objc-class ] dip 0 objc_allocateClassPair
  32     [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
  33     tri ;
  34
  35 : encode-types ( return types -- encoding )
  36     swap prefix [
  37         alien>objc-types get at "0" append
  38     ] map concat ;
  39
  40 : prepare-method ( ret types quot -- type imp )
  41     [ [ encode-types ] 2keep ] dip
  42     '[ _ _ "cdecl" _ alien-callback ]
  43     (( -- callback )) define-temp ;
  44
  45 : prepare-methods ( methods -- methods )
  46     [
  47         [ first4 prepare-method 3array ] map
  48     ] with-compilation-unit ;
  49
  50 :: (redefine-objc-method) ( class method -- )
  51     method init-method [| sel imp types |
  52         class sel class_getInstanceMethod [
  53             imp method_setImplementation drop
  54         ] [
  55             class sel imp types add-method
  56         ] if*
  57     ] call ;
  58
  59 : redefine-objc-methods ( imeth name -- )
  60     dup class-exists? [
  61         objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
  62     ] [ 2drop ] if ;
  63
  64 SYMBOL: +name+
  65 SYMBOL: +protocols+
  66 SYMBOL: +superclass+
  67
  68 : define-objc-class ( imeth hash -- )
  69     clone [
  70         prepare-methods
  71         +name+ get "cocoa.classes" create drop
  72         +name+ get 2dup redefine-objc-methods swap
  73         +protocols+ get +superclass+ get +name+ get
  74         '[ _ _ _ _ (define-objc-class) ]
  75         import-objc-class
  76     ] bind ;
  77
  78 : CLASS:
  79     parse-definition unclip
  80     >hashtable define-objc-class ; parsing