basis/tools/deploy/shaker/strip-cocoa.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
   4 namespaces kernel kernel.private words compiler.units sequences
   5 init vocabs memoize accessors ;
   6 IN: tools.deploy.shaker.cocoa
   7
   8 : pool ( obj -- obj' ) \ pool get [ ] cache ;
   9
  10 : pool-array ( obj -- obj' ) [ pool ] map pool ;
  11
  12 : pool-keys ( assoc -- assoc' ) [ [ pool-array ] dip ] assoc-map ;
  13
  14 : pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
  15
  16 IN: cocoa.application
  17
  18 : objc-error ( error -- ) die ;
  19
  20 [ [ die ] 19 setenv ] "cocoa.application" add-startup-hook
  21
  22 H{ } clone \ pool [
  23     global [
  24         ! Only keeps those methods that we actually call
  25         sent-messages get super-sent-messages get assoc-union
  26         objc-methods [ assoc-intersect pool-values ] change
  27
  28         sent-messages get
  29         super-sent-messages get
  30         [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
  31         super-message-senders [ assoc-intersect pool-keys ] change
  32         message-senders [ assoc-intersect pool-keys ] change
  33
  34         sent-messages off
  35         super-sent-messages off
  36
  37         alien>objc-types off
  38         objc>alien-types off
  39
  40         ! We need this for strip-stack-traces to work fully
  41         { message-senders super-message-senders }
  42         [ get values compile ] each
  43     ] bind
  44 ] with-variable
  45
  46 \ make-prepare-send reset-memoized
  47 \ <selector> reset-memoized
  48
  49 \ (send) def>> second clear-assoc