~ chicken-core (chicken-5) 640eb0bc092f374fe3e766ef267cc99fad603580
commit 640eb0bc092f374fe3e766ef267cc99fad603580
Author: megane <meganeka@gmail.com>
AuthorDate: Mon Nov 19 15:52:22 2018 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sat Mar 9 20:30:16 2019 +1300
Pretty print "wrong number of values for procedure argument" errors
Remove `report-notice' (which is now unused) and rename `report-notice2'
to `report-notice'.
Add `single2', which is a copy of `single' but doesn't do the actual
printing. The plan is to replace all uses of `single' with this.
Make `p-arg-expr' print some additional info if the expression is
function call.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 26ca3237..41e91793 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -300,6 +300,18 @@
(node-source-prefix node) what n (multiples n))
(first tv))))))
+ (define (single2 tv r-value-count-mismatch)
+ (if (eq? '* tv)
+ '*
+ (let ((n (length tv)))
+ (cond ((= 1 n) (car tv))
+ ((zero? n)
+ (r-value-count-mismatch tv)
+ 'undefined)
+ (else
+ (r-value-count-mismatch tv)
+ (first tv))))))
+
(define add-loc cons)
(define (get-specializations name)
@@ -652,22 +664,15 @@
((##core#call)
(let* ((f (fragment n))
(len (length subs))
- (args (map (lambda (n i)
+ (args (map (lambda (n2 i)
(make-node
'##core#the/result
(list
- (single
- n
- (sprintf
- "in ~a of procedure call `~s'"
- (if (zero? i)
- "operator position"
- (sprintf "argument #~a" i))
- f)
- (walk n e loc #f #f flow #f)
- loc))
- (list n)))
- subs
+ (single2
+ (walk n2 e loc #f #f flow #f)
+ (cut r-proc-call-argument-value-count loc n i n2 <>)))
+ (list n2)))
+ subs
(iota len)))
(fn (walked-result (car args)))
(pn (procedure-name fn))
@@ -2511,7 +2516,7 @@
(conc "\n" (location-name loc "") (sprintf "~?" msg args))
" ")))))
-(define (report-notice2 location-node-candidates loc msg . args)
+(define (report-notice location-node-candidates loc msg . args)
(apply report2 ##sys#notice location-node-candidates loc msg args))
;;; Reports
@@ -2589,9 +2594,73 @@
(variable-from-module pname)
(type->pp-string ptype)))
+
+(define (r-proc-call-argument-value-count loc call-node i arg-node atype)
+ (define (p-arg-expr)
+ (define (p-expr)
+ (sprintf (string-append
+ "This is the expression"
+ "~%~%"
+ "~a")
+ (pp-fragment arg-node)))
+ (or (and (eq? '##core#call (node-class arg-node))
+ (let ((pnode (first (node-subexpressions arg-node))))
+ (and-let* (((eq? '##core#variable (node-class pnode)))
+ (pname (car (node-parameters pnode)))
+ (ptype (variable-mark pname '##compiler#type)))
+ (sprintf (string-append
+ "It is a call to ~a which has this type"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "~a")
+ (variable-from-module pname)
+ (type->pp-string ptype)
+ (p-expr)))))
+ (p-expr)))
+ (define pn
+ (if (zero? i)
+ ""
+ (sprintf " `~a'"
+ (strip-namespace (fragment (first (node-subexpressions call-node)))))))
+ (if (zero? (length atype))
+ (report2
+ warning
+ (list arg-node call-node)
+ loc
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Argument #~a to procedure~a does not return any values."
+ "~%~%"
+ "~a")
+ (pp-fragment call-node)
+ i
+ pn
+ (p-arg-expr))
+ (report2
+ warning
+ (list arg-node call-node)
+ loc
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Argument #~a to procedure~a returns ~a values but 1 is expected."
+ "~%~%"
+ "~a")
+ (pp-fragment call-node)
+ i
+ pn
+ (length atype)
+ (p-arg-expr))))
+
(define (r-pred-call-always-true loc node pname pred-type atype)
;; pname is "... proc call to predicate `foo' "
- (report-notice2
+ (report-notice
(list node)
loc
(string-append
@@ -2614,7 +2683,7 @@
(type->pp-string atype)))
(define (r-pred-call-always-false loc node pname pred-type atype)
- (report-notice2
+ (report-notice
(list node)
loc
(string-append
@@ -2637,7 +2706,7 @@
(type->pp-string atype)))
(define (r-cond-test-always-true loc if-node test-node t)
- (report-notice2
+ (report-notice
(list test-node if-node)
loc
(string-append
@@ -2652,7 +2721,7 @@
(type->pp-string t)))
(define (r-cond-test-always-false loc if-node test-node)
- (report-notice2
+ (report-notice
(list test-node if-node)
loc
(string-append
diff --git a/tests/scrutinizer-message-format.expected b/tests/scrutinizer-message-format.expected
index 2f1d3aa4..c15f1292 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -35,11 +35,37 @@ Warning: Type mismatch (test-scrutinizer-message-format.scm:XXX)
(list -> fixnum)
-Warning: In `r-proc-call-argument-value-count', a toplevel procedure
- (test-scrutinizer-message-format.scm:XXX) expected a single result in argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but received 2 results
+Warning: Type mismatch (test-scrutinizer-message-format.scm:XXX)
+ In `r-proc-call-argument-value-count', a toplevel procedure
+ In procedure call
-Warning: In `r-proc-call-argument-value-count', a toplevel procedure
- (test-scrutinizer-message-format.scm:XXX) expected a single result in argument #1 of procedure call `(scheme#vector (scheme#values))', but received zero results
+ (scheme#list (chicken.time#cpu-time))
+
+ Argument #1 to procedure `list' returns 2 values but 1 is expected.
+
+ It is a call to `cpu-time' from module `chicken.time' which has this type
+
+ (-> fixnum fixnum)
+
+ This is the expression
+
+ (chicken.time#cpu-time)
+
+Warning: Type mismatch (test-scrutinizer-message-format.scm:XXX)
+ In `r-proc-call-argument-value-count', a toplevel procedure
+ In procedure call
+
+ (scheme#vector (scheme#values))
+
+ Argument #1 to procedure `vector' does not return any values.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure (#!rest values) . *)
+
+ This is the expression
+
+ (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
@@ -296,15 +322,41 @@ Warning: Type mismatch (test-scrutinizer-message-format.scm:XXX)
(list -> fixnum)
-Warning: In `m#toplevel-foo', a toplevel procedure
+Warning: Type mismatch (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
- (test-scrutinizer-message-format.scm:XXX) expected a single result in argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but received 2 results
+ In procedure call
-Warning: In `m#toplevel-foo', a toplevel procedure
+ (scheme#list (chicken.time#cpu-time))
+
+ Argument #1 to procedure `list' returns 2 values but 1 is expected.
+
+ It is a call to `cpu-time' from module `chicken.time' which has this type
+
+ (-> fixnum fixnum)
+
+ This is the expression
+
+ (chicken.time#cpu-time)
+
+Warning: Type mismatch (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
- (test-scrutinizer-message-format.scm:XXX) expected a single result in argument #1 of procedure call `(scheme#vector (scheme#values))', but received zero results
+ In procedure call
+
+ (scheme#vector (scheme#values))
+
+ Argument #1 to procedure `vector' does not return any values.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure (#!rest values) . *)
+
+ This is the expression
+
+ (scheme#values)
Warning: In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index f2bbdee6..bd582964 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -71,11 +71,37 @@ Warning: Type mismatch (scrutiny-tests.scm:XXX)
(* -> boolean)
-Warning: At toplevel
- (scrutiny-tests.scm:XXX) expected a single result in argument #1 of procedure call `(chicken.base#print (scheme#values 1 2))', but received 2 results
+Warning: Type mismatch (scrutiny-tests.scm:XXX)
+ At toplevel
+ In procedure call
-Warning: At toplevel
- (scrutiny-tests.scm:XXX) expected a single result in argument #1 of procedure call `(chicken.base#print (scheme#values))', but received zero results
+ (chicken.base#print (scheme#values 1 2))
+
+ Argument #1 to procedure `print' returns 2 values but 1 is expected.
+
+ 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: Type mismatch (scrutiny-tests.scm:XXX)
+ At toplevel
+ In procedure call
+
+ (chicken.base#print (scheme#values))
+
+ Argument #1 to procedure `print' does not return any values.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure (#!rest values) . *)
+
+ This is the expression
+
+ (scheme#values)
Warning: Type mismatch (scrutiny-tests.scm:XXX)
At toplevel
Trap