]> gitweb.factorcode.org Git - factor.git/blob - basis/stack-checker/branches/branches.factor
Merge branch 'master' into experimental
[factor.git] / basis / stack-checker / branches / branches.factor
1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry vectors sequences assocs math accessors kernel
4 combinators quotations namespaces grouping stack-checker.state
5 stack-checker.backend stack-checker.errors stack-checker.visitor
6 stack-checker.values stack-checker.recursive-state ;
7 IN: stack-checker.branches
8
9 : balanced? ( pairs -- ? )
10     [ second ] filter [ first2 length - ] map all-equal? ;
11
12 SYMBOL: +bottom+
13
14 : unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
15     dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
16
17 : pad-with-bottom ( seq -- newseq )
18     dup empty? [
19         dup [ length ] map supremum
20         '[ _ +bottom+ pad-left ] map
21     ] unless ;
22
23 : phi-inputs ( max-d-in pairs -- newseq )
24     dup empty? [ nip ] [
25         swap '[ [ _ ] dip first2 unify-inputs ] map
26         pad-with-bottom
27     ] if ;
28
29 : remove-bottom ( seq -- seq' )
30     +bottom+ swap remove ;
31
32 : unify-values ( values -- phi-out )
33     remove-bottom
34     [ <value> ] [
35         [ known ] map dup all-eq?
36         [ first make-known ] [ drop <value> ] if
37     ] if-empty ;
38
39 : phi-outputs ( phi-in -- stack )
40     flip [ unify-values ] map ;
41
42 SYMBOL: quotations
43
44 : unify-branches ( ins stacks -- in phi-in phi-out )
45     zip [ 0 { } { } ] [
46         [ keys supremum ] [ ] [ balanced? ] tri
47         [ dupd phi-inputs dup phi-outputs ]
48         [ quotations get unbalanced-branches-error ]
49         if
50     ] if-empty ;
51
52 : branch-variable ( seq symbol -- seq )
53     '[ [ _ ] dip at ] map ;
54
55 : active-variable ( seq symbol -- seq )
56     [ [ terminated? over at [ drop f ] when ] map ] dip
57     branch-variable ;
58
59 : datastack-phi ( seq -- phi-in phi-out )
60     [ d-in branch-variable ] [ \ meta-d active-variable ] bi
61     unify-branches
62     [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
63
64 : terminated-phi ( seq -- terminated )
65     terminated? branch-variable ;
66
67 : terminate-branches ( seq -- )
68     [ terminated? swap at ] all? [ terminate ] when ;
69
70 : compute-phi-function ( seq -- )
71     [ quotation active-variable sift quotations set ]
72     [ [ datastack-phi ] [ terminated-phi ] bi #phi, ]
73     [ terminate-branches ]
74     tri ;
75
76 : copy-inference ( -- )
77     \ meta-d [ clone ] change
78     literals [ clone ] change
79     d-in [ ] change ;
80
81 GENERIC: infer-branch ( literal -- namespace )
82
83 M: literal infer-branch
84     [
85         copy-inference
86         nest-visitor
87         [ value>> quotation set ] [ infer-literal-quot ] bi
88     ] H{ } make-assoc ;
89
90 M: callable infer-branch
91     [
92         copy-inference
93         nest-visitor
94         [ quotation set ] [ infer-quot-here ] bi
95     ] H{ } make-assoc ;
96
97 : infer-branches ( branches -- input children data )
98     [ pop-d ] dip
99     [ infer-branch ] map
100     [ stack-visitor branch-variable ] keep ; inline
101
102 : (infer-if) ( branches -- )
103     infer-branches
104     [ first2 #if, ] dip compute-phi-function ;
105
106 : infer-if ( -- )
107     2 literals-available? [
108         (infer-if)
109     ] [
110         drop 2 consume-d
111         dup [ known [ curried? ] [ composed? ] bi or ] contains? [
112             output-d
113             [ rot [ drop call ] [ nip call ] if ]
114             infer-quot-here
115         ] [
116             [ #drop, ] [ [ literal ] map (infer-if) ] bi
117         ] if
118     ] if ;
119
120 : infer-dispatch ( -- )
121     pop-literal nip infer-branches
122     [ #dispatch, ] dip compute-phi-function ;