basis/cocoa/subclassing/subclassing.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.parser alien.strings arrays assocs
   4 cocoa.messages cocoa.runtime combinators compiler.units fry
   5 io.encodings.utf8 kernel lexer locals.parser locals.types
   6 make namespaces parser sequences words ;
   7 IN: cocoa.subclassing
   8
   9 : init-method ( method -- sel imp types )
  10     first3 swap
  11     [ sel_registerName ] [ execute( -- xt ) ] [ 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) ( methods protocols superclass name -- )
  31     [ objc-class ] dip 0 objc_allocateClassPair
  32     [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
  33     tri ;
  34
  35 : encode-type ( type -- encoded )
  36     dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
  37
  38 : encode-types ( return types -- encoding )
  39     swap prefix [ encode-type "0" append ] map concat ;
  40
  41 : prepare-method ( ret types quot -- type imp )
  42     [ [ encode-types ] 2keep ] dip
  43     '[ _ _ cdecl _ alien-callback ]
  44     ( -- callback ) define-temp ;
  45
  46 : prepare-methods ( methods -- methods )
  47     [
  48         [ first4 prepare-method 3array ] map
  49     ] with-nested-compilation-unit ;
  50
  51 :: (redefine-objc-method) ( class method -- )
  52     method init-method :> ( sel imp types )
  53
  54     class sel class_getInstanceMethod [
  55         imp method_setImplementation drop
  56     ] [
  57         class sel imp types add-method
  58     ] if* ;
  59
  60 : redefine-objc-methods ( methods name -- )
  61     dup class-exists? [
  62         objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
  63     ] [ 2drop ] if ;
  64
  65 :: define-objc-class ( name superclass protocols methods -- )
  66     methods prepare-methods :> methods
  67     name "cocoa.classes" create-word drop
  68     methods name redefine-objc-methods
  69     name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
  70
  71 TUPLE: cocoa-protocol name ;
  72 C: <cocoa-protocol> cocoa-protocol
  73
  74 SYNTAX: COCOA-PROTOCOL:
  75     scan-token <cocoa-protocol> suffix! ;
  76
  77 SYMBOL: ;CLASS>
  78
  79 SYNTAX: <CLASS:
  80     scan-token
  81     "<" expect
  82     scan-token
  83     \ ;CLASS> parse-until [ cocoa-protocol? ] partition
  84     [ [ name>> ] map ] dip define-objc-class ;
  85
  86 : (parse-selector) ( -- )
  87     scan-token {
  88         { [ dup "[" = ] [ drop ] }
  89         { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
  90         [ f f 3array , "[" expect ]
  91     } cond ;
  92
  93 : parse-selector ( -- selector types names )
  94     [ (parse-selector) ] { } make
  95     flip first3
  96     [ concat ]
  97     [ sift { id SEL } prepend ]
  98     [ sift { "self" "selector" } prepend ] tri* ;
  99
 100 : parse-method-body ( names -- quot )
 101     [ [ make-local ] map ] H{ } make
 102     (parse-lambda) <lambda> ?rewrite-closures first ;
 103
 104 SYNTAX: METHOD:
 105     scan-c-type
 106     parse-selector
 107     parse-method-body [ swap ] 2dip 4array ";" expect
 108     suffix! ;