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 GENERIC: add-depends-on-c-type ( c-type -- )
  47
  48 M: void add-depends-on-c-type drop ;
  49
  50 M: c-type-word add-depends-on-c-type +definition+ depends-on ;
  51
  52 M: array add-depends-on-c-type
  53     [ word? ] filter [ +definition+ depends-on ] each ;
  54
  55 M: pointer add-depends-on-c-type
  56     to>> add-depends-on-c-type ;
  57
  58 SYMBOL: generic-dependencies
  59
  60 : ?class-or ( class class/f -- class' )
  61     [ class-or ] when* ;
  62
  63 : add-depends-on-generic ( class generic -- )
  64     generic-dependencies get
  65     [ [ ?class-or ] change-at ] [ 2drop ] if* ;
  66
  67 SYMBOL: conditional-dependencies
  68
  69 GENERIC: satisfied? ( dependency -- ? )
  70
  71 : add-conditional-dependency ( ... class -- )
  72     boa conditional-dependencies get
  73     [ adjoin ] [ drop ] if* ; inline
  74
  75 TUPLE: depends-on-class-predicate class1 class2 result ;
  76
  77 : add-depends-on-class-predicate ( class1 class2 result -- )
  78     depends-on-class-predicate add-conditional-dependency ;
  79
  80 M: depends-on-class-predicate satisfied?
  81     {
  82         [ class1>> classoid? ]
  83         [ class2>> classoid? ]
  84         [ [ [ class1>> ] [ class2>> ] bi evaluate-class-predicate ] [ result>> ] bi eq? ]
  85     } 1&& ;
  86
  87 TUPLE: depends-on-instance-predicate object class result ;
  88
  89 : add-depends-on-instance-predicate ( object class result -- )
  90     depends-on-instance-predicate add-conditional-dependency ;
  91
  92 M: depends-on-instance-predicate satisfied?
  93     {
  94         [ class>> classoid? ]
  95         [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
  96     } 1&& ;
  97
  98 TUPLE: depends-on-next-method class generic next-method ;
  99
 100 : add-depends-on-next-method ( class generic next-method -- )
 101     over +conditional+ depends-on
 102     depends-on-next-method add-conditional-dependency ;
 103
 104 M: depends-on-next-method satisfied?
 105     {
 106         [ class>> classoid? ]
 107         [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
 108     } 1&& ;
 109
 110 TUPLE: depends-on-method class generic method ;
 111
 112 : add-depends-on-method ( class generic method -- )
 113     over +conditional+ depends-on
 114     depends-on-method add-conditional-dependency ;
 115
 116 M: depends-on-method satisfied?
 117     {
 118         [ class>> classoid? ]
 119         [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
 120     } 1&& ;
 121
 122 TUPLE: depends-on-tuple-layout class layout ;
 123
 124 : add-depends-on-tuple-layout ( class layout -- )
 125     [ drop +conditional+ depends-on ]
 126     [ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
 127
 128 M: depends-on-tuple-layout satisfied?
 129     [ class>> tuple-layout ] [ layout>> ] bi eq? ;
 130
 131 TUPLE: depends-on-struct-slots class slots ;
 132
 133 : add-depends-on-struct-slots ( class slots -- )
 134     [ drop +conditional+ depends-on ]
 135     [ depends-on-struct-slots add-conditional-dependency ] 2bi ;
 136
 137 SLOT: fields
 138
 139 M: depends-on-struct-slots satisfied?
 140     [ class>> "c-type" word-prop fields>> ] [ slots>> ] bi eq? ;
 141
 142 TUPLE: depends-on-flushable word ;
 143
 144 : add-depends-on-flushable ( word -- )
 145     [ +conditional+ depends-on ]
 146     [ depends-on-flushable add-conditional-dependency ] bi ;
 147
 148 M: depends-on-flushable satisfied?
 149     word>> flushable? ;
 150
 151 TUPLE: depends-on-final class ;
 152
 153 : add-depends-on-final ( word -- )
 154     [ +conditional+ depends-on ]
 155     [ depends-on-final add-conditional-dependency ] bi ;
 156
 157 M: depends-on-final satisfied?
 158     class>> { [ class? ] [ final-class? ] } 1&& ;
 159
 160 : without-dependencies ( quot -- )
 161     [
 162         dependencies off
 163         generic-dependencies off
 164         conditional-dependencies off
 165         call
 166     ] with-scope ; inline