diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 6a463b5710..3ca9cab7d9 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -34,5 +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 quot variables expected actual ; +ERROR: invalid-quotation-input < inference-error word quots branches ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 5a910af767..589bd0a056 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -68,3 +68,8 @@ 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 2a5696e380..cabb69d47c 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -13,21 +13,23 @@ IN: stack-checker.row-polymorphism : ?quotation-effect ( in -- effect/f ) dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ; -:: declare-effect-d ( word effect variables n -- ) +:: declare-effect-d ( word effect variables branches n -- ) meta-d length :> d-length n d-length < [ d-length 1 - n - :> n' n' meta-d nth :> value value known :> known - known word effect variables :> known' + known word effect variables branches :> known' known' value set-known + known' branches push ] [ word unknown-macro-input ] if ; :: declare-input-effects ( word -- ) H{ } clone :> variables + V{ } clone :> branches word stack-effect in>> [| in n | in ?quotation-effect [| effect | - word effect variables n declare-effect-d + word effect variables branches n declare-effect-d ] when* ] each-index ; @@ -77,10 +79,14 @@ IN: stack-checker.row-polymorphism ] when ] if ; +: invalid-quotation-input* ( known -- * ) + [ word>> ] [ + branches>> + [ [ known>callable ] { } map-as ] + [ [ effect>> ] { } map-as ] bi + ] bi invalid-quotation-input ; + : check-declared-effect ( known effect -- ) 2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables - [ 2drop ] [ - [ { [ word>> ] [ known>callable ] [ variables>> ] [ effect>> ] } cleave ] - dip invalid-quotation-input - ] if ; + [ 2drop ] [ drop invalid-quotation-input* ] if ; diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 668bdd63a8..714634bdc3 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -100,7 +100,7 @@ M: input-parameter (literal) current-word get unknown-macro-input ; ! Argument corresponding to polymorphic declared input of inline combinator -TUPLE: declared-effect known word effect variables ; +TUPLE: declared-effect known word effect variables branches ; C: declared-effect