From 053ba583fc3f9ead7518e065e6e7ca51c27b582f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 4 Mar 2010 21:51:49 -0800 Subject: [PATCH] improve error reporting --- basis/stack-checker/errors/errors.factor | 2 +- .../errors/prettyprint/prettyprint.factor | 23 +++++++++-- .../row-polymorphism-tests.factor | 1 + .../row-polymorphism/row-polymorphism.factor | 41 +++++++++++++++---- 4 files changed, 54 insertions(+), 13 deletions(-) diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index fbb8515a07..e928c38c88 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -34,7 +34,7 @@ ERROR: transform-expansion-error < inference-error error continuation word ; ERROR: bad-declaration-error < inference-error declaration ; -ERROR: invalid-quotation-input < inference-error branches quots ; +ERROR: invalid-quotation-input < inference-error word branches quots ; ERROR: invalid-effect-variable < inference-error effect ; diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index f762e0559b..3288f4108e 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -13,10 +13,13 @@ M: bad-macro-input summary M: unbalanced-branches-error summary drop "Unbalanced branches" ; +: quots-and-branches. ( quots branches -- ) + zip [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; + M: unbalanced-branches-error error. dup summary print - [ quots>> ] [ branches>> [ length [ "x" ] bi@ ] { } assoc>map ] bi zip - [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; + [ quots>> ] [ branches>> [ length [ "x" ] bi@ ] { } assoc>map ] bi + quots-and-branches. ; M: too-many->r summary drop "Quotation pushes elements on retain stack without popping them" ; @@ -60,4 +63,18 @@ M: transform-expansion-error error. tri ; M: do-not-compile summary - word>> name>> "Cannot compile call to " prepend ; \ No newline at end of file + word>> name>> "Cannot compile call to " prepend ; + +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 + P [ quots>> ] [ branches>> ] bi quots-and-branches. ; + +M: invalid-effect-variable summary + drop "Stack effect variables can only occur as the first input or output" ; +M: effect-variable-can't-have-type summary + drop "Stack effect variables cannot have a declared type" ; + diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor index 39c9a2c13a..d2fc6bfc22 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor @@ -4,6 +4,7 @@ system tools.test stack-checker.backend stack-checker.errors stack-checker.row-polymorphism +stack-checker.state stack-checker.values ; IN: stack-checker.row-polymorphism.tests diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index 8468f56eac..182533640a 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/basis/stack-checker/row-polymorphism/row-polymorphism.factor @@ -9,7 +9,7 @@ stack-checker.values ; IN: stack-checker.row-polymorphism error-quot ( known -- quot ) + +M: object >error-quot drop (unknown) ; +M: literal >error-quot value>> ; +M: composed >error-quot + [ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi + \ compose [ ] 3sequence ; +M: curried >error-quot + [ obj>> known >error-quot ] [ quot>> known >error-quot ] bi + \ curry [ ] 3sequence ; + +: >error-branches-and-quots ( branch/values -- branches quots ) + [ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ; + +: abandon-check ( -- * ) + current-word get + current-effect get in>> current-meta-d get zip + [ first quotation-effect? ] filter + >error-branches-and-quots + invalid-quotation-input ; :: check-variable ( actual-count declared-count variable -- difference ) actual-count declared-count - variable [ - variable effect-variables get at* nip - [ variable effect-variables get at - ] - [ variable effect-variables get set-at 0 ] if + variable current-effect-variables get at* nip + [ variable current-effect-variables get at - ] + [ variable current-effect-variables get set-at 0 ] if ] [ dup [ abandon-check ] unless-zero ] if ; : adjust-variable ( diff var -- ) over 0 >= - [ effect-variables get at+ ] + [ current-effect-variables get at+ ] [ 2drop ] if ; inline :: (check-input) ( declared actual -- ) @@ -86,7 +107,7 @@ M: curried (infer-known) ] [ 2drop ] if ; : normalize-variables ( -- variables' ) - effect-variables get dup values [ + current-effect-variables get dup values [ infimum dup 0 < [ '[ _ - ] assoc-map ] [ drop ] if ] unless-empty ; @@ -94,8 +115,10 @@ M: curried (infer-known) PRIVATE> : infer-polymorphic-vars ( effect -- variables ) - H{ } clone effect-variables set - in>> dup length ensure-d [ check-input ] 2each + H{ } clone current-effect-variables set + dup current-effect set + in>> dup length ensure-d dup current-meta-d set + [ check-input ] 2each normalize-variables ; : check-polymorphic-effect ( word -- )