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