1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs namespaces sequences kernel definitions math
4 effects accessors words fry classes.algebra stack-checker.errors
6 IN: stack-checker.state
8 : <value> ( -- value ) \ <value> counter ;
12 : known ( value -- known ) known-values get at ;
14 : set-known ( known value -- )
15 over [ known-values get set-at ] [ 2drop ] if ;
17 : make-known ( known -- value )
18 <value> [ set-known ] keep ;
20 : copy-value ( value -- value' )
23 : copy-values ( values -- values' )
27 TUPLE: literal < identity-tuple value recursion ;
29 : <literal> ( obj -- value )
30 recursive-state get \ literal boa ;
32 : literal ( value -- literal )
34 [ \ literal-expected inference-warning ] unless ;
37 TUPLE: curried obj quot ;
42 TUPLE: composed quot1 quot2 ;
44 C: <composed> composed
46 ! Did the current control-flow path throw an error?
49 ! Number of inputs current word expects from the stack
52 ! Compile-time data stack
55 ! Compile-time retain stack
58 : current-stack-height ( -- n ) meta-d get length d-in get - ;
60 : current-effect ( -- effect )
62 meta-d get length <effect>
63 terminated? get >>terminated? ;
65 : init-inference ( -- )
71 : init-known-values ( -- )
72 H{ } clone known-values set ;
74 : recursive-label ( word -- label/f )
75 recursive-state get at ;
77 : local-recursive-state ( -- assoc )
78 recursive-state get dup keys
79 [ dup word? [ inline? ] when not ] find drop
80 [ head-slice ] when* ;
82 : inline-recursive-label ( word -- label/f )
83 local-recursive-state at ;
85 : recursive-quotation? ( quot -- ? )
86 local-recursive-state [ first eq? ] with contains? ;
88 ! Words that the current quotation depends on
91 : depends-on ( word how -- )
92 over primitive? [ 2drop ] [
93 dependencies get dup [
94 swap '[ , strongest-dependency ] change-at
98 ! Generic words that the current quotation depends on
99 SYMBOL: generic-dependencies
101 : depends-on-generic ( generic class -- )
102 generic-dependencies get dup
103 [ swap '[ null or , class-or ] change-at ] [ 3drop ] if ;
105 ! Words we've inferred the stack effect of, for rollback