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: alien alien.c-types alien.parser alien.strings arrays
   4 assocs combinators compiler hashtables kernel lexer libc
   5 locals.parser locals.types math namespaces parser sequences
   6 words cocoa.messages cocoa.runtime locals compiler.units
   7 io.encodings.utf8 continuations make fry effects stack-checker
   8 stack-checker.errors ;
   9 IN: cocoa.subclassing
  10
  11 : init-method ( method -- sel imp types )
  12     first3 swap
  13     [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ]
  14     tri* ;
  15
  16 : throw-if-false ( obj what -- )
  17     swap { f 0 } member?
  18     [ "Failed to " prepend throw ] [ drop ] if ;
  19
  20 : add-method ( class sel imp types -- )
  21     class_addMethod "add method to class" throw-if-false ;
  22
  23 : add-methods ( methods class -- )
  24     '[ [ _ ] dip init-method add-method ] each ;
  25
  26 : add-protocol ( class protocol -- )
  27     class_addProtocol "add protocol to class" throw-if-false ;
  28
  29 : add-protocols ( protocols class -- )
  30     '[ [ _ ] dip objc-protocol add-protocol ] each ;
  31
  32 : (define-objc-class) ( imeth protocols superclass name -- )
  33     [ objc-class ] dip 0 objc_allocateClassPair
  34     [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
  35     tri ;
  36
  37 : encode-type ( type -- encoded )
  38     dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
  39
  40 : encode-types ( return types -- encoding )
  41     swap prefix [ encode-type "0" append ] map concat ;
  42
  43 : prepare-method ( ret types quot -- type imp )
  44     [ [ encode-types ] 2keep ] dip
  45     '[ _ _ cdecl _ alien-callback ]
  46     (( -- callback )) define-temp ;
  47
  48 : prepare-methods ( methods -- methods )
  49     [
  50         [ first4 prepare-method 3array ] map
  51     ] with-compilation-unit ;
  52
  53 :: (redefine-objc-method) ( class method -- )
  54     method init-method :> ( sel imp types )
  55
  56     class sel class_getInstanceMethod [
  57         imp method_setImplementation drop
  58     ] [
  59         class sel imp types add-method
  60     ] if* ;
  61
  62 : redefine-objc-methods ( imeth name -- )
  63     dup class-exists? [
  64         objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
  65     ] [ 2drop ] if ;
  66
  67 SYMBOL: +name+
  68 SYMBOL: +protocols+
  69 SYMBOL: +superclass+
  70
  71 : define-objc-class ( imeth hash -- )
  72     clone [
  73         prepare-methods
  74         +name+ get "cocoa.classes" create drop
  75         +name+ get 2dup redefine-objc-methods swap
  76         +protocols+ get +superclass+ get +name+ get
  77         '[ _ _ _ _ (define-objc-class) ]
  78         import-objc-class
  79     ] bind ;
  80
  81 SYNTAX: CLASS:
  82     parse-definition unclip
  83     >hashtable define-objc-class ;
  84
  85 : (parse-selector) ( -- )
  86     scan-token {
  87         { [ dup "[" = ] [ drop ] }
  88         { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
  89         [ f f 3array , "[" expect ]
  90     } cond ;
  91
  92 : parse-selector ( -- selector types names )
  93     [ (parse-selector) ] { } make
  94     flip first3
  95     [ concat ]
  96     [ sift { id SEL } prepend ]
  97     [ sift { "self" "selector" } prepend ] tri* ;
  98
  99 : parse-method-body ( names -- quot )
 100     [ [ make-local ] map ] H{ } make-assoc
 101     (parse-lambda) <lambda> ?rewrite-closures first ;
 102
 103 : method-effect ( quadruple -- effect )
 104     [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
 105
 106 : check-method ( quadruple -- )
 107     [ fourth infer ] [ method-effect ] bi
 108     2dup effect<= [ 2drop ] [ effect-error ] if ;
 109
 110 SYNTAX: METHOD:
 111     scan-c-type
 112     parse-selector
 113     parse-method-body [ swap ] 2dip 4array
 114     dup check-method
 115     suffix! ;