1 ! Copyright (C) 2004, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays effects fry kernel locals math
4 math.order namespaces quotations sequences
5 stack-checker.dependencies stack-checker.errors
6 stack-checker.recursive-state stack-checker.state
7 stack-checker.values stack-checker.visitor words ;
8 IN: stack-checker.backend
10 : push-d ( obj -- ) meta-d push ;
12 : introduce-values ( values -- )
13 [ [ input-parameter swap set-known ] each ]
14 [ length input-count +@ ]
18 : update-inner-d ( new -- )
19 inner-d-index get min inner-d-index set ;
23 [ <value> dup 1array introduce-values ]
24 [ pop meta-d length update-inner-d ] if-empty ;
26 : peek-d ( -- obj ) pop-d dup push-d ;
28 : make-values ( n -- values )
29 [ <value> ] replicate ;
31 : ensure-d ( n -- values )
32 meta-d 2dup length > [
34 [ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
35 [ introduce-values ] [ meta-d push-all ] bi
38 swap from-tail [ tail ] [ update-inner-d ] bi ;
40 : shorten-by ( n seq -- )
41 [ length swap - ] keep shorten ; inline
44 meta-d shorten-by meta-d length update-inner-d ;
46 : consume-d ( n -- seq )
47 [ ensure-d ] [ shorten-d ] bi ;
49 : output-d ( values -- ) meta-d push-all ;
51 : produce-d ( n -- values )
52 make-values dup meta-d push-all ;
54 : push-r ( obj -- ) meta-r push ;
57 meta-r [ too-many-r> ] [ pop ] if-empty ;
59 : consume-r ( n -- seq )
60 meta-r 2dup length > [ too-many-r> ] when
61 [ swap tail* ] [ shorten-by ] 2bi ;
63 : output-r ( seq -- ) meta-r push-all ;
65 : push-literal ( obj -- )
68 : pop-literal ( -- obj )
70 pop-d [ 1array #drop, ] [ literal value>> ] bi
73 : literals-available? ( n -- literals ? )
74 literals get 2dup length <= [
75 [ swap tail* ] [ shorten-by ] 2bi t
80 GENERIC: apply-object ( obj -- )
82 M: wrapper apply-object
83 wrapped>> push-literal ;
85 M: object apply-object push-literal ;
88 terminated? on meta-d clone meta-r clone #terminate, ;
91 meta-r empty? [ too-many->r ] unless ;
93 : infer-quot-here ( quot -- )
95 V{ } clone (meta-r) set
96 [ apply-object terminated? get not ] all?
97 [ commit-literals check->r ] [ literals get delete-all ] if
100 : infer-quot ( quot rstate -- )
101 recursive-state get [
104 ] dip recursive-state set ;
106 : time-bomb-quot ( obj generic -- quot )
107 [ literalize ] [ "default-method" word-prop ] bi* [ ] 2sequence ;
109 : time-bomb ( obj generic -- )
110 time-bomb-quot infer-quot-here ;
112 : infer-literal-quot ( literal -- )
113 dup recursive-quotation? [
114 value>> recursive-quotation-error
116 dup value>> callable? [
118 [ [ recursion>> ] keep add-local-quotation ]
121 value>> \ call time-bomb
126 consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ;
129 consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
131 : consume/produce ( ..a effect quot: ( ..a inputs outputs -- ..b ) -- ..b )
132 '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
133 [ terminated?>> [ terminate ] when ]
136 : apply-word/effect ( word effect -- )
137 swap '[ _ #call, ] consume/produce ;
140 meta-d clone #return, ;
142 : required-stack-effect ( word -- effect )
143 [ stack-effect ] [ missing-effect ] ?unless ;
145 : with-infer ( quot -- effect visitor )
148 H{ } clone known-values set
154 ] with-scope ; inline
156 : ?quotation-effect ( in -- effect/f )
157 dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
159 :: declare-effect-d ( word effect variables branches n -- )
160 meta-d length :> d-length
162 d-length 1 - n - :> n'
163 n' meta-d nth :> value
165 known word effect variables branches <declared-effect> :> known'
166 known' value set-known
168 ] [ word unknown-macro-input ] if ;
170 :: declare-input-effects ( word -- )
171 H{ } clone :> variables
172 V{ } clone :> branches
173 word stack-effect in>> <reversed> [| in n |
174 in ?quotation-effect [| effect |
175 word effect variables branches n declare-effect-d