1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs accessors classes classes.algebra fry
4 generic kernel math namespaces sequences words sets
5 combinators.short-circuit classes.tuple alien.c-types ;
6 FROM: classes.tuple.private => tuple-layout ;
7 FROM: assocs => change-at ;
8 IN: stack-checker.dependencies
10 ! Words that the current quotation depends on
13 SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
15 : index>= ( obj1 obj2 seq -- ? )
16 [ index ] curry bi@ >= ;
18 : dependency>= ( how1 how2 -- ? )
19 { effect-dependency conditional-dependency definition-dependency }
22 : strongest-dependency ( how1 how2 -- how )
23 [ effect-dependency or ] bi@ [ dependency>= ] most ;
25 : depends-on ( word how -- )
26 over primitive? [ 2drop ] [
27 dependencies get dup [
28 swap '[ _ strongest-dependency ] change-at
32 : depends-on-effect ( word -- )
33 effect-dependency depends-on ;
35 : depends-on-conditionally ( word -- )
36 conditional-dependency depends-on ;
38 : depends-on-definition ( word -- )
39 definition-dependency depends-on ;
41 GENERIC: depends-on-c-type ( c-type -- )
43 M: void depends-on-c-type drop ;
45 M: c-type-word depends-on-c-type depends-on-definition ;
47 M: array depends-on-c-type
48 [ word? ] filter [ depends-on-definition ] each ;
50 M: pointer depends-on-c-type
51 to>> depends-on-c-type ;
53 ! Generic words that the current quotation depends on
54 SYMBOL: generic-dependencies
56 : ?class-or ( class class/f -- class' )
59 : depends-on-generic ( class generic -- )
60 generic-dependencies get dup
61 [ [ ?class-or ] change-at ] [ 3drop ] if ;
63 ! Conditional dependencies are re-evaluated when classes change;
64 ! if any fail, the word is recompiled
65 SYMBOL: conditional-dependencies
67 GENERIC: satisfied? ( dependency -- ? )
69 : add-conditional-dependency ( ... class -- )
70 boa conditional-dependencies get
71 dup [ conjoin ] [ 2drop ] if ; inline
73 TUPLE: depends-on-class-predicate class1 class2 result ;
75 : depends-on-class-predicate ( class1 class2 result -- )
76 \ depends-on-class-predicate add-conditional-dependency ;
78 M: depends-on-class-predicate satisfied?
80 [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
81 [ [ [ class1>> ] [ class2>> ] bi compare-classes ] [ result>> ] bi eq? ]
84 TUPLE: depends-on-instance-predicate object class result ;
86 : depends-on-instance-predicate ( object class result -- )
87 \ depends-on-instance-predicate add-conditional-dependency ;
89 M: depends-on-instance-predicate satisfied?
92 [ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
95 TUPLE: depends-on-next-method class generic next-method ;
97 : depends-on-next-method ( class generic next-method -- )
98 over depends-on-conditionally
99 \ depends-on-next-method add-conditional-dependency ;
101 M: depends-on-next-method satisfied?
103 [ class>> classoid? ]
104 [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
107 TUPLE: depends-on-method class generic method ;
109 : depends-on-method ( class generic method -- )
110 over depends-on-conditionally
111 \ depends-on-method add-conditional-dependency ;
113 M: depends-on-method satisfied?
115 [ class>> classoid? ]
116 [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
119 TUPLE: depends-on-tuple-layout class layout ;
121 : depends-on-tuple-layout ( class layout -- )
122 [ drop depends-on-conditionally ]
123 [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
125 M: depends-on-tuple-layout satisfied?
126 [ class>> tuple-layout ] [ layout>> ] bi eq? ;
128 TUPLE: depends-on-flushable word ;
130 : depends-on-flushable ( word -- )
131 [ depends-on-conditionally ]
132 [ \ depends-on-flushable add-conditional-dependency ] bi ;
134 M: depends-on-flushable satisfied?
137 TUPLE: depends-on-final class ;
139 : depends-on-final ( word -- )
140 [ depends-on-conditionally ]
141 [ \ depends-on-final add-conditional-dependency ] bi ;
143 M: depends-on-final satisfied?
144 class>> final-class? ;
146 : init-dependencies ( -- )
147 H{ } clone dependencies set
148 H{ } clone generic-dependencies set
149 H{ } clone conditional-dependencies set ;
151 : without-dependencies ( quot -- )
154 generic-dependencies off
155 conditional-dependencies off
157 ] with-scope ; inline