~ chicken-core (chicken-5) 83014573891718a2a05df13a246ef2e76ba9b7c6
commit 83014573891718a2a05df13a246ef2e76ba9b7c6
Author: megane <meganeka@gmail.com>
AuthorDate: Wed Nov 28 10:48:43 2018 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sat Mar 9 20:35:49 2019 +1300
Add more information to scrutinizer messages
Notably for "incorrect argument to function" print the argument
expression. This is convenient when it's the 5th argument to 9 argument
function, or something similiar requiring complicated mental arithmetic.
Also pretty print value count mismatches for `let', `set!' and `if'.
* scrutinizer.scm (describe-expression): Use source-node-tree to get
the non-mutated AST. Skip "the/result" node so we can see the call
node, if there is one.
* scrutinizer.scm (scrutinize): Pass argument node to
r-invalid-called-procedure-type, r-proc-call-argument-type-mismatch
* scrutinizer.scm (r-invalid-called-procedure-type): Describe the
invalid procedure expression
* scrutinizer.scm (r-proc-call-argument-type-mismatch): Describe the
invalid argument expression
* scrutinizer.scm (report2): Flush output so the last printed warning
gets printed fully right away, and not once the compilation finishes,
which can take a while on bigger files.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 9e691cc3..f59ba388 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -276,25 +276,7 @@
(d "assignment to var ~a in ~a is always immediate" var loc)
#t))
- (define (single node what tv loc)
- (if (eq? '* tv)
- '*
- (let ((n (length tv)))
- (cond ((= 1 n) (car tv))
- ((zero? n)
- (report
- loc
- "~aexpected a single result ~a, but received zero results"
- (node-source-prefix node) what)
- 'undefined)
- (else
- (report
- loc
- "~aexpected a single result ~a, but received ~a result~a"
- (node-source-prefix node) what n (multiples n))
- (first tv))))))
-
- (define (single2 tv r-value-count-mismatch)
+ (define (single tv r-value-count-mismatch)
(if (eq? '* tv)
'*
(let ((n (length tv)))
@@ -464,7 +446,8 @@
(tst (first subs))
(nor-1 noreturn))
(set! noreturn #f)
- (let* ((rt (single n "in conditional" (walk tst e loc #f #f flow tags) loc))
+ (let* ((rt (single (walk tst e loc #f #f flow tags)
+ (cut r-conditional-value-count-invalid loc n tst <>)))
(c (second subs))
(a (third subs))
(nor0 noreturn))
@@ -517,11 +500,8 @@
(walk (car body) (append e2 e) loc dest tail flow ctags)
(let* ((var (car vars))
(val (car body))
- (t (single
- n
- (sprintf "in `let' binding of `~a'" (real-name var))
- (walk val e loc var #f flow #f)
- loc)))
+ (t (single (walk val e loc var #f flow #f)
+ (cut r-let-value-count-invalid loc var n val <>))))
(when (and (eq? (node-class val) '##core#variable)
(not (db-get db var 'assigned)))
(let ((var2 (first (node-parameters val))))
@@ -585,11 +565,9 @@
((set! ##core#set!)
(let* ((var (first params))
(type (variable-mark var '##compiler#type))
- (rt (single
- n
- (sprintf "in assignment to `~a'" var)
- (walk (first subs) e loc var #f flow #f)
- loc))
+ (rt (single (walk (first subs) e loc var #f flow #f)
+ (cut r-assignment-value-count-invalid
+ loc var n (first subs) <>)))
(typeenv (append
(if type (type-typeenv type) '())
(type-typeenv rt)))
@@ -662,7 +640,7 @@
(make-node
'##core#the/result
(list
- (single2
+ (single
(walk n2 e loc #f #f flow #f)
(cut r-proc-call-argument-value-count loc n i n2 <>)))
(list n2)))
@@ -2248,8 +2226,9 @@
(unless (or (null? (cdr arg-types))
(potentially-proper-list? arg1))
(r-proc-call-argument-type-mismatch
- loc node index 'list
- (car arg-types) arg1 (variable-mark 'scheme#append '##compiler#type)))
+ loc node index 'list arg1
+ (car arg-types)
+ (variable-mark 'scheme#append '##compiler#type)))
#f))))))
(cond ((derive-result-type) => list)
(else rtypes)))
@@ -2659,6 +2638,71 @@
(sprintf "a negative index ~a." idx)
(sprintf "index `~a' for a ~a of length `~a'." idx obj-name obj-length))))
+(define (r-conditional-value-count-invalid loc if-node test-node atype)
+ (define (p short long)
+ (report2 short warning (list test-node if-node)
+ loc
+ (string-append
+ "In conditional:"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The test expression ~a"
+ "~%~%"
+ "~a")
+ (pp-fragment if-node)
+ long
+ (describe-expression test-node)))
+ (if (zero? (length atype))
+ (p "Zero values for conditional"
+ "returns 0 values.")
+ (p "Too many values for conditional"
+ (sprintf "returns ~a values." (length atype)))))
+
+(define (r-let-value-count-invalid loc var let-node val-node atype)
+ (define (p short long)
+ (report2 short warning (list val-node let-node)
+ loc
+ (string-append
+ "In let expression:"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Variable `~a' is bound to an expression that ~a"
+ "~%~%"
+ "~a")
+ (pp-fragment let-node)
+ (real-name var)
+ long
+ (describe-expression val-node)))
+ (if (zero? (length atype))
+ (p (sprintf "Let binding to `~a' has zero values" (real-name var))
+ "returns 0 values.")
+ (p (sprintf "Let binding to `~a' has ~a values" (real-name var) (length atype))
+ (sprintf "returns ~a values." (length atype)))))
+
+(define (r-assignment-value-count-invalid loc var set-node val-node atype)
+ (define (p short long)
+ (report2 short warning (list val-node set-node)
+ loc
+ (string-append
+ "In assignment:"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Variable `~a' is assigned from expression that ~a"
+ "~%~%"
+ "~a")
+ (pp-fragment set-node)
+ (strip-namespace var)
+ long
+ (describe-expression val-node)))
+ (if (zero? (length atype))
+ (p (sprintf "Assignment to `~a' has zero values" (strip-namespace var))
+ "returns 0 values.")
+ (p (sprintf "Assignment to `~a' has ~a values" (strip-namespace var) (length atype))
+ (sprintf "returns ~a values." (length atype)))))
+
(define (r-pred-call-always-true loc node pred-type atype)
(define pname (call-node-procedure-name node))
(report-notice
diff --git a/tests/scrutinizer-message-format.expected b/tests/scrutinizer-message-format.expected
index c3b34600..eeaf7d2a 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -71,8 +71,21 @@ Warning: Not enough argument values (test-scrutinizer-message-format.scm:XXX)
(scheme#values)
-Warning: In `r-proc-call-argument-value-count', a toplevel procedure
- expected a single result in `let' binding of `gXXX', but received zero results
+Warning: Let binding to `gXXX' has zero values (test-scrutinizer-message-format.scm:XXX)
+ In `r-proc-call-argument-value-count', a toplevel procedure
+ In let expression:
+
+ (let ((gXXX (scheme#values))) (gXXX))
+
+ Variable `gXXX' is bound to an expression that returns 0 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values)
Warning: Branch values mismatch (test-scrutinizer-message-format.scm:XXX)
In `r-cond-branch-value-count-mismatch', a toplevel procedure
@@ -288,17 +301,69 @@ Warning: Negative vector index (test-scrutinizer-message-format.scm:XXX)
Procedure `vector-ref' from module `scheme' is called with a negative index -1.
-Warning: In `zero-values-for-let', a toplevel procedure
- expected a single result in `let' binding of `a', but received zero results
+Warning: Let binding to `a' has zero values (test-scrutinizer-message-format.scm:XXX)
+ In `zero-values-for-let', a toplevel procedure
+ In let expression:
+
+ (let ((a (scheme#values))) a)
+
+ Variable `a' is bound to an expression that returns 0 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values)
+
+Warning: Let binding to `a' has 2 values (test-scrutinizer-message-format.scm:XXX)
+ In `multiple-values-for-let', a toplevel procedure
+ In let expression:
-Warning: In `multiple-values-for-let', a toplevel procedure
- expected a single result in `let' binding of `a', but received 2 results
+ (let ((a (scheme#values 1 2))) a)
-Warning: In `zero-values-for-conditional', a toplevel procedure
- expected a single result in conditional, but received zero results
+ Variable `a' is bound to an expression that returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
-Warning: In `multiple-values-for-conditional', a toplevel procedure
- expected a single result in conditional, but received 2 results
+ This is the expression:
+
+ (scheme#values 1 2)
+
+Warning: Zero values for conditional (test-scrutinizer-message-format.scm:XXX)
+ In `zero-values-for-conditional', a toplevel procedure
+ In conditional:
+
+ (if (scheme#values) 1 (##core#undefined))
+
+ The test expression returns 0 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values)
+
+Warning: Too many values for conditional (test-scrutinizer-message-format.scm:XXX)
+ In `multiple-values-for-conditional', a toplevel procedure
+ In conditional:
+
+ (if (scheme#values 1 2) 1 (##core#undefined))
+
+ The test expression returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values 1 2)
Note: Test is always true (test-scrutinizer-message-format.scm:XXX)
In `multiple-values-for-conditional', a toplevel procedure
@@ -310,8 +375,21 @@ Note: Test is always true (test-scrutinizer-message-format.scm:XXX)
fixnum
-Warning: In `multiple-values-for-conditional', a toplevel procedure
- expected a single result in `let' binding of `gXXX', but received 2 results
+Warning: Let binding to `gXXX' has 2 values (test-scrutinizer-message-format.scm:XXX)
+ In `multiple-values-for-conditional', a toplevel procedure
+ In let expression:
+
+ (if (scheme#values 1 2) 1 (##core#undefined))
+
+ Variable `gXXX' is bound to an expression that returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values 1 2)
Warning: Wrong number of arguments (test-scrutinizer-message-format.scm:XXX)
In `m#toplevel-foo', a toplevel procedure
@@ -387,10 +465,23 @@ Warning: Not enough argument values (test-scrutinizer-message-format.scm:XXX)
(scheme#values)
-Warning: In `m#toplevel-foo', a toplevel procedure
+Warning: Let binding to `gXXX' has zero values (test-scrutinizer-message-format.scm:XXX)
+ In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
In `r-proc-call-argument-value-count', a local procedure
- expected a single result in `let' binding of `gXXX', but received zero results
+ In let expression:
+
+ (let ((gXXX (scheme#values))) (gXXX))
+
+ Variable `gXXX' is bound to an expression that returns 0 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values)
Warning: Branch values mismatch (test-scrutinizer-message-format.scm:XXX)
In `m#toplevel-foo', a toplevel procedure
@@ -622,25 +713,77 @@ Warning: Negative vector index (test-scrutinizer-message-format.scm:XXX)
Procedure `vector-ref' from module `scheme' is called with a negative index -1.
-Warning: In `m#toplevel-foo', a toplevel procedure
+Warning: Let binding to `a' has zero values (test-scrutinizer-message-format.scm:XXX)
+ In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
In `zero-values-for-let', a local procedure
- expected a single result in `let' binding of `a', but received zero results
+ In let expression:
+
+ (let ((a (scheme#values))) a)
+
+ Variable `a' is bound to an expression that returns 0 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
-Warning: In `m#toplevel-foo', a toplevel procedure
+ This is the expression:
+
+ (scheme#values)
+
+Warning: Let binding to `a' has 2 values (test-scrutinizer-message-format.scm:XXX)
+ In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
In `multiple-values-for-let', a local procedure
- expected a single result in `let' binding of `a', but received 2 results
+ In let expression:
+
+ (let ((a (scheme#values 1 2))) a)
+
+ Variable `a' is bound to an expression that returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
-Warning: In `m#toplevel-foo', a toplevel procedure
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values 1 2)
+
+Warning: Zero values for conditional (test-scrutinizer-message-format.scm:XXX)
+ In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
In `zero-values-for-conditional', a local procedure
- expected a single result in conditional, but received zero results
+ In conditional:
+
+ (if (scheme#values) 1 (##core#undefined))
-Warning: In `m#toplevel-foo', a toplevel procedure
+ The test expression returns 0 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values)
+
+Warning: Too many values for conditional (test-scrutinizer-message-format.scm:XXX)
+ In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
In `multiple-values-for-conditional', a local procedure
- expected a single result in conditional, but received 2 results
+ In conditional:
+
+ (if (scheme#values 1 2) 1 (##core#undefined))
+
+ The test expression returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values 1 2)
Note: Test is always true (test-scrutinizer-message-format.scm:XXX)
In `m#toplevel-foo', a toplevel procedure
@@ -654,10 +797,23 @@ Note: Test is always true (test-scrutinizer-message-format.scm:XXX)
fixnum
-Warning: In `m#toplevel-foo', a toplevel procedure
+Warning: Let binding to `gXXX' has 2 values (test-scrutinizer-message-format.scm:XXX)
+ In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
In `multiple-values-for-conditional', a local procedure
- expected a single result in `let' binding of `gXXX', but received 2 results
+ In let expression:
+
+ (if (scheme#values 1 2) 1 (##core#undefined))
+
+ Variable `gXXX' is bound to an expression that returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values 1 2)
Error: No typecase match (test-scrutinizer-message-format.scm:XXX)
In `m#toplevel-foo', a toplevel procedure
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index bf66e77d..bb42c9f6 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -179,8 +179,21 @@ Warning: Invalid assignment
((pair 'a335 *) -> 'a335)
-Warning: At toplevel
- expected a single result in `let' binding of `gXXX', but received 2 results
+Warning: Let binding to `gXXX' has 2 values (scrutiny-tests.scm:XXX)
+ At toplevel
+ In let expression:
+
+ (let ((gXXX (scheme#values 1 2))) (gXXX))
+
+ Variable `gXXX' is bound to an expression that returns 2 values.
+
+ It is a call to `values' from module `scheme' which has this type:
+
+ (procedure (#!rest values) . *)
+
+ This is the expression:
+
+ (scheme#values 1 2)
Warning: Invalid procedure
At toplevel
Trap