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 generalizations
   7 continuations make ;
   8 IN: cocoa.subclassing
   9
  10 : init-method ( method -- sel imp types )
  11     first3 swap
  12     [ sel_registerName ] [ execute ] [ ascii string>alien ]
  13     tri* ;
  14
  15 : add-methods ( methods class -- )
  16     swap
  17     [ init-method class_addMethod drop ] with each ;
  18
  19 : add-protocols ( protocols class -- )
  20     swap [ objc-protocol class_addProtocol drop ] with each ;
  21
  22 : (define-objc-class) ( protocols superclass name imeth -- )
  23     -rot
  24     [ objc-class ] dip 0 objc_allocateClassPair
  25     [ add-methods ] [ add-protocols ] [ objc_registerClassPair ]
  26     tri ;
  27
  28 : encode-types ( return types -- encoding )
  29     swap prefix [
  30         alien>objc-types get at "0" append
  31     ] map concat ;
  32
  33 : prepare-method ( ret types quot -- type imp )
  34     >r [ encode-types ] 2keep r> [
  35         "cdecl" swap 4array % \ alien-callback ,
  36     ] [ ] make define-temp ;
  37
  38 : prepare-methods ( methods -- methods )
  39     [
  40         [ first4 prepare-method 3array ] map
  41     ] with-compilation-unit ;
  42
  43 : types= ( a b -- ? )
  44     [ ascii alien>string ] bi@ = ;
  45
  46 : (verify-method-type) ( class sel types -- )
  47     [ class_getInstanceMethod method_getTypeEncoding ]
  48     dip types=
  49     [ "Objective-C method types cannot be changed once defined" throw ]
  50     unless ;
  51 : verify-method-type ( class sel imp types -- class sel imp types )
  52     4 ndup nip (verify-method-type) ;
  53
  54 : (redefine-objc-method) ( class method -- )
  55     init-method ! verify-method-type
  56     drop
  57     [ class_getInstanceMethod ] dip method_setImplementation drop ;
  58
  59 : redefine-objc-methods ( imeth name -- )
  60     dup class-exists? [
  61         objc_getClass swap [ (redefine-objc-method) ] with each
  62     ] [
  63         2drop
  64     ] if ;
  65
  66 SYMBOL: +name+
  67 SYMBOL: +protocols+
  68 SYMBOL: +superclass+
  69
  70 : define-objc-class ( imeth hash -- )
  71     clone [
  72         prepare-methods
  73         +name+ get "cocoa.classes" create drop
  74         +name+ get 2dup redefine-objc-methods swap [
  75             +protocols+ get , +superclass+ get , +name+ get , ,
  76             \ (define-objc-class) ,
  77         ] [ ] make import-objc-class
  78     ] bind ;
  79
  80 : CLASS:
  81     parse-definition unclip
  82     >hashtable define-objc-class ; parsing