steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

nested scopes were messing up stack checker state

db4
Joe Groff 2010-03-04 20:15:26 -08:00
parent 23de281186
commit 31640ea9c6
1 changed files with 18 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
basis/stack-checker/row-polymorphism/row-polymorphism.factor
View File

@ -66,24 +66,27 @@ ERROR: abandon-check ;
abandon-check abandon-check
] if ; ] if ;
GENERIC: infer-known ( known -- effect ) GENERIC: (infer-known) ( known -- effect )
M: object infer-known M: object (infer-known)
current-word get bad-macro-input ; current-word get bad-macro-input ;
M: literal infer-known M: literal (infer-known)
value>> dup callable? [ infer ] [ current-word get bad-macro-input ] if ; value>> dup callable? [ infer ] [ current-word get bad-macro-input ] if ;
M: composed infer-known M: composed (infer-known)
[ quot1>> known infer-known ] [ quot2>> known infer-known ] bi compose-effects ; [ quot1>> known (infer-known) ] [ quot2>> known (infer-known) ] bi compose-effects ;
M: curried infer-known M: curried (infer-known)
(( -- x )) swap quot>> known infer-known compose-effects ; (( -- x )) swap quot>> known (infer-known) compose-effects ;
: infer-known ( value -- effect )
(infer-known) ; inline
: check-input ( in value -- ) : check-input ( in value -- )
over quotation-effect? [ over quotation-effect? [
[ second ] dip known infer-known (check-input) [ second ] dip known infer-known (check-input)
] [ 2drop ] if ; ] [ 2drop ] if ;
: normalize-variables ( variables -- variables' ) : normalize-variables ( -- variables' )
dup values [ effect-variables get dup values [
infimum dup 0 < infimum dup 0 <
[ '[ _ - ] assoc-map ] [ drop ] if [ '[ _ - ] assoc-map ] [ drop ] if
] unless-empty ; ] unless-empty ;
@ -91,12 +94,14 @@ M: curried infer-known
PRIVATE> PRIVATE>
: infer-polymorphic-vars ( effect -- variables ) : infer-polymorphic-vars ( effect -- variables )
H{ } clone H{ } clone effect-variables set
[ effect-variables [ in>> dup length ensure-d [ check-input ] 2each ] with-variable ] in>> dup length ensure-d [ check-input ] 2each
keep normalize-variables ; normalize-variables ;
: check-polymorphic-effect ( word -- ) : check-polymorphic-effect ( word -- )
dup current-word [ stack-effect infer-polymorphic-vars drop ] with-variable ; current-word get [
dup current-word set stack-effect infer-polymorphic-vars drop
] dip current-word set ;
SYMBOL: infer-polymorphic? SYMBOL: infer-polymorphic?