basis/stack-checker/dependencies/dependencies.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors alien.c-types arrays assocs classes
   5 classes.algebra classes.algebra.private classes.maybe
   6 classes.tuple combinators.short-circuit fry generic kernel math
   7 namespaces sequences sets words ;
   8
   9 FROM: classes.tuple.private => tuple-layout ;
  10 IN: stack-checker.dependencies
  11
  12 SYMBOL: dependencies
  13
  14 SYMBOLS: +effect+ +conditional+ +definition+ ;
  15
  16 : index>= ( obj1 obj2 seq -- ? )
  17     [ index ] curry bi@ >= ;
  18
  19 : dependency>= ( how1 how2 -- ? )
  20     { +effect+ +conditional+ +definition+ } index>= ;
  21
  22 : strongest-dependency ( how1 how2 -- how )
  23     [ +effect+ or ] bi@ [ dependency>= ] most ;
  24
  25 : depends-on ( word how -- )
  26     over primitive? [ 2drop ] [
  27         dependencies get [
  28             swap '[ _ strongest-dependency ] change-at
  29         ] [ 2drop ] if*
  30     ] if ;
  31
  32 GENERIC: add-depends-on-class ( classoid -- )
  33
  34 M: class add-depends-on-class
  35     +conditional+ depends-on ;
  36
  37 M: maybe add-depends-on-class
  38     class>> add-depends-on-class ;
  39
  40 M: anonymous-union add-depends-on-class
  41     members>> [ add-depends-on-class ] each ;
  42
  43 M: anonymous-intersection add-depends-on-class
  44     participants>> [ add-depends-on-class ] each ;
  45
  46 M: anonymous-complement add-depends-on-class
  47     class>> add-depends-on-class ;
  48
  49 GENERIC: add-depends-on-c-type ( c-type -- )
  50
  51 M: void add-depends-on-c-type drop ;
  52
  53 M: c-type-word add-depends-on-c-type +definition+ depends-on ;
  54
  55 M: array add-depends-on-c-type
  56     [ word? ] filter [ +definition+ depends-on ] each ;
  57
  58 M: pointer add-depends-on-c-type
  59     to>> add-depends-on-c-type ;
  60
  61 SYMBOL: generic-dependencies
  62
  63 : ?class-or ( class class/f -- class' )
  64     [ class-or ] when* ;
  65
  66 : add-depends-on-generic ( class generic -- )
  67     generic-dependencies get
  68     [ [ ?class-or ] change-at ] [ 2drop ] if* ;
  69
  70 SYMBOL: conditional-dependencies
  71
  72 GENERIC: satisfied? ( dependency -- ? )
  73
  74 : add-conditional-dependency ( ... class -- )
  75     boa conditional-dependencies get
  76     [ adjoin ] [ drop ] if* ; inline
  77
  78 TUPLE: depends-on-class-predicate class1 class2 result ;
  79
  80 : add-depends-on-class-predicate ( class1 class2 result -- )
  81     depends-on-class-predicate add-conditional-dependency ;
  82
  83 M: depends-on-class-predicate satisfied?
  84     {
  85         [ class1>> classoid? ]
  86         [ class2>> classoid? ]
  87         [ [ [ class1>> ] [ class2>> ] bi evaluate-class-predicate ] [ result>> ] bi eq? ]
  88     } 1&& ;
  89
  90 TUPLE: depends-on-instance-predicate object class result ;
  91
  92 : add-depends-on-instance-predicate ( object class result -- )
  93     depends-on-instance-predicate add-conditional-dependency ;
  94
  95 M: depends-on-instance-predicate satisfied?
  96     {
  97         [ class>> classoid? ]
  98         [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
  99     } 1&& ;
 100
 101 TUPLE: depends-on-next-method class generic next-method ;
 102
 103 : add-depends-on-next-method ( class generic next-method -- )
 104     over +conditional+ depends-on
 105     depends-on-next-method add-conditional-dependency ;
 106
 107 M: depends-on-next-method satisfied?
 108     {
 109         [ class>> classoid? ]
 110         [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
 111     } 1&& ;
 112
 113 TUPLE: depends-on-method class generic method ;
 114
 115 : add-depends-on-method ( class generic method -- )
 116     over +conditional+ depends-on
 117     depends-on-method add-conditional-dependency ;
 118
 119 M: depends-on-method satisfied?
 120     {
 121         [ class>> classoid? ]
 122         [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
 123     } 1&& ;
 124
 125 TUPLE: depends-on-tuple-layout class layout ;
 126
 127 : add-depends-on-tuple-layout ( class layout -- )
 128     [ drop +conditional+ depends-on ]
 129     [ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
 130
 131 M: depends-on-tuple-layout satisfied?
 132     [ class>> tuple-layout ] [ layout>> ] bi eq? ;
 133
 134 TUPLE: depends-on-struct-slots class slots ;
 135
 136 : add-depends-on-struct-slots ( class slots -- )
 137     [ drop +conditional+ depends-on ]
 138     [ depends-on-struct-slots add-conditional-dependency ] 2bi ;
 139
 140 SLOT: fields
 141
 142 M: depends-on-struct-slots satisfied?
 143     [ class>> "c-type" word-prop fields>> ] [ slots>> ] bi eq? ;
 144
 145 TUPLE: depends-on-flushable word ;
 146
 147 : add-depends-on-flushable ( word -- )
 148     [ +conditional+ depends-on ]
 149     [ depends-on-flushable add-conditional-dependency ] bi ;
 150
 151 M: depends-on-flushable satisfied?
 152     word>> flushable? ;
 153
 154 TUPLE: depends-on-final class ;
 155
 156 : add-depends-on-final ( word -- )
 157     [ +conditional+ depends-on ]
 158     [ depends-on-final add-conditional-dependency ] bi ;
 159
 160 M: depends-on-final satisfied?
 161     class>> { [ class? ] [ final-class? ] } 1&& ;
 162
 163 : without-dependencies ( quot -- )
 164     [
 165         dependencies off
 166         generic-dependencies off
 167         conditional-dependencies off
 168         call
 169     ] with-scope ; inline