diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index e928c38c88..6a463b5710 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -34,9 +34,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: bad-declaration-error < inference-error declaration ; -ERROR: invalid-quotation-input < inference-error word branches quots ; - -ERROR: invalid-effect-variable < inference-error effect ; - -ERROR: effect-variable-can't-have-type < inference-error effect ; +ERROR: invalid-quotation-input < inference-error word quot variables expected actual ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 589bd0a056..5a910af767 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -68,8 +68,3 @@ M: do-not-compile summary M: invalid-quotation-input summary word>> name>> "The input quotations to " " don't match their expected effects" surround ; - -M: invalid-quotation-input error. - dup summary print - [ quots>> ] [ branches>> ] bi quots-and-branches. ; - diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 5148efba4d..406ef7aaae 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -53,5 +53,36 @@ IN: stack-checker.row-polymorphism in "x" out "x" terminated? get ; inline +:: check-variable ( actual-count declared-count variable vars -- difference ) + actual-count declared-count - + variable [ + variable vars at* nip + [ variable vars at - ] + [ variable vars set-at 0 ] if + ] [ drop 0 ] if ; + +: adjust-variable ( diff var vars -- ) + pick 0 >= + [ at+ ] + [ 3drop ] if ; inline + +:: check-variables ( vars declared actual -- ? ) + actual terminated?>> [ t ] [ + actual declared [ in>> length ] bi@ declared in-var>> + [ vars check-variable ] keep :> ( in-diff in-var ) + actual declared [ out>> length ] bi@ declared out-var>> + [ vars check-variable ] keep :> ( out-diff out-var ) + { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0|| + dup [ + in-var [ in-diff swap vars adjust-variable ] when* + out-var [ out-diff swap vars adjust-variable ] when* + ] when + ] if ; + : check-declared-effect ( known effect -- ) - [ known>callable P. ] [ P. ] bi* ; + 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables + [ 2drop ] [ + [ { [ word>> ] [ known>callable ] [ variables>> ] [ effect>> ] } cleave ] + dip invalid-quotation-input + ] if ; +