improve error message for invalid quotation inputs by referencing each declared-effect to its other references
parent
011a39457e
commit
ea4545e366
|
@ -34,5 +34,5 @@ ERROR: transform-expansion-error < inference-error error continuation word ;
|
||||||
|
|
||||||
ERROR: bad-declaration-error < inference-error declaration ;
|
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 ;
|
||||||
|
|
||||||
|
|
|
@ -68,3 +68,8 @@ M: do-not-compile summary
|
||||||
M: invalid-quotation-input summary
|
M: invalid-quotation-input summary
|
||||||
word>> name>>
|
word>> name>>
|
||||||
"The input quotations to " " don't match their expected effects" surround ;
|
"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. ;
|
||||||
|
|
||||||
|
|
|
@ -13,21 +13,23 @@ IN: stack-checker.row-polymorphism
|
||||||
: ?quotation-effect ( in -- effect/f )
|
: ?quotation-effect ( in -- effect/f )
|
||||||
dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
|
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
|
meta-d length :> d-length
|
||||||
n d-length < [
|
n d-length < [
|
||||||
d-length 1 - n - :> n'
|
d-length 1 - n - :> n'
|
||||||
n' meta-d nth :> value
|
n' meta-d nth :> value
|
||||||
value known :> known
|
value known :> known
|
||||||
known word effect variables <declared-effect> :> known'
|
known word effect variables branches <declared-effect> :> known'
|
||||||
known' value set-known
|
known' value set-known
|
||||||
|
known' branches push
|
||||||
] [ word unknown-macro-input ] if ;
|
] [ word unknown-macro-input ] if ;
|
||||||
|
|
||||||
:: declare-input-effects ( word -- )
|
:: declare-input-effects ( word -- )
|
||||||
H{ } clone :> variables
|
H{ } clone :> variables
|
||||||
|
V{ } clone :> branches
|
||||||
word stack-effect in>> <reversed> [| in n |
|
word stack-effect in>> <reversed> [| in n |
|
||||||
in ?quotation-effect [| effect |
|
in ?quotation-effect [| effect |
|
||||||
word effect variables n declare-effect-d
|
word effect variables branches n declare-effect-d
|
||||||
] when*
|
] when*
|
||||||
] each-index ;
|
] each-index ;
|
||||||
|
|
||||||
|
@ -77,10 +79,14 @@ IN: stack-checker.row-polymorphism
|
||||||
] when
|
] when
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
: invalid-quotation-input* ( known -- * )
|
||||||
|
[ word>> ] [
|
||||||
|
branches>> <reversed>
|
||||||
|
[ [ known>callable ] { } map-as ]
|
||||||
|
[ [ effect>> ] { } map-as ] bi
|
||||||
|
] bi invalid-quotation-input ;
|
||||||
|
|
||||||
: check-declared-effect ( known effect -- )
|
: check-declared-effect ( known effect -- )
|
||||||
2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
|
2dup [ [ variables>> ] [ effect>> ] bi ] dip check-variables
|
||||||
[ 2drop ] [
|
[ 2drop ] [ drop invalid-quotation-input* ] if ;
|
||||||
[ { [ word>> ] [ known>callable ] [ variables>> ] [ effect>> ] } cleave ]
|
|
||||||
dip invalid-quotation-input
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
|
|
|
@ -100,7 +100,7 @@ M: input-parameter (literal) current-word get unknown-macro-input ;
|
||||||
|
|
||||||
! Argument corresponding to polymorphic declared input of inline combinator
|
! 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> declared-effect
|
C: <declared-effect> declared-effect
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue