~ chicken-core (chicken-5) 5aaedf214425aa6196cb6daaf9fc2e053ed58dde
commit 5aaedf214425aa6196cb6daaf9fc2e053ed58dde
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Feb 14 11:49:02 2016 +1300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Feb 14 14:38:00 2016 +0100
Add line numbers to scrutiny warnings for value count mismatches
Pull the logic for node line number extraction into a single procedure
to make it easier to print line numbers during scrutiny, and use it in
the `single` and `call-result` procedures.
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index ab9ed516..b4ed8e14 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -127,6 +127,16 @@
(define (walked-result n)
(first (node-parameters n))) ; assumes ##core#the/result node
+(define (node-line-number n)
+ (case (node-class n)
+ ((##core#call)
+ (let ((params (node-parameters n)))
+ (and (pair? (cdr params))
+ (pair? (cadr params)) ; debug-info has line-number information?
+ (source-info->line (cadr params)))))
+ ((##core#typecase)
+ (car (node-parameters n)))
+ (else #f)))
(define (scrutinize node db complain specialize strict block-compilation)
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
@@ -226,7 +236,7 @@
t (pp-fragment x)))
f))
- (define (single what tv loc)
+ (define (single node what tv loc)
(if (eq? '* tv)
'*
(let ((n (length tv)))
@@ -234,14 +244,14 @@
((zero? n)
(report
loc
- "expected a single result ~a, but received zero results"
- what)
+ "~aexpected a single result ~a, but received zero results"
+ (node-source-prefix node) what)
'undefined)
(else
(report
loc
- "expected a single result ~a, but received ~a result~a"
- what n (multiples n))
+ "~aexpected a single result ~a, but received ~a result~a"
+ (node-source-prefix node) what n (multiples n))
(first tv))))))
(define (report-notice loc msg . args)
@@ -260,6 +270,10 @@
(set! errors #t)
(apply report loc msg args))
+ (define (node-source-prefix n)
+ (let ((line (node-line-number n)))
+ (if (not line) "" (sprintf "(~a) " line))))
+
(define (location-name loc)
(define (lname loc1)
(if loc1
@@ -303,16 +317,9 @@
(define (call-result node args e loc params typeenv)
(define (pname)
- (sprintf "~ain procedure call to `~s', "
- (if (and (pair? params)
- (pair? (cdr params))
- (pair? (cadr params))) ; sourceinfo has line-number information?
- (let ((n (source-info->line (cadr params))))
- (if n
- (sprintf "(~a) " n)
- ""))
- "")
- (fragment (first (node-subexpressions node)))))
+ (sprintf "~ain procedure call to `~s', "
+ (node-source-prefix node)
+ (fragment (first (node-subexpressions node)))))
(let* ((actualtypes (map walked-result args))
(ptype (car actualtypes))
(pptype? (procedure-type? ptype))
@@ -486,7 +493,7 @@
(tst (first subs))
(nor-1 noreturn))
(set! noreturn #f)
- (let* ((rt (single "in conditional" (walk tst e loc #f #f flow tags) loc))
+ (let* ((rt (single n "in conditional" (walk tst e loc #f #f flow tags) loc))
(c (second subs))
(a (third subs))
(nor0 noreturn))
@@ -539,7 +546,8 @@
(walk (car body) (append e2 e) loc dest tail flow ctags)
(let* ((var (car vars))
(val (car body))
- (t (single
+ (t (single
+ n
(sprintf "in `let' binding of `~a'" (real-name var))
(walk val e loc var #f flow #f)
loc)))
@@ -606,7 +614,8 @@
((set! ##core#set!)
(let* ((var (first params))
(type (variable-mark var '##compiler#type))
- (rt (single
+ (rt (single
+ n
(sprintf "in assignment to `~a'" var)
(walk (first subs) e loc var #f flow #f)
loc))
@@ -680,7 +689,8 @@
(make-node
'##core#the/result
(list
- (single
+ (single
+ n
(sprintf
"in ~a of procedure call `~s'"
(if (zero? i)
@@ -821,11 +831,9 @@
(let loop ((types (cdr params)) (subs (cdr subs)))
(cond ((null? types)
(quit-compiling
- "~a~ano clause applies in `compiler-typecase' for expression of type `~s':~a"
+ "~a~ano clause applies in `compiler-typecase' for expression of type `~s':~a"
(location-name loc)
- (if (first params)
- (sprintf "(~a) " (first params))
- "")
+ (node-source-prefix n)
(car ts)
(string-intersperse
(map (lambda (t) (sprintf "\n ~a" t))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 4907573a..bcbe4c74 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -25,10 +25,10 @@ Warning: at toplevel:
(scrutiny-tests.scm:21) in procedure call to `string?', expected 1 argument but was given 0 arguments
Warning: at toplevel:
- expected a single result in argument #1 of procedure call `(print (cpu-time))', but received 2 results
+ (scrutiny-tests.scm:23) expected a single result in argument #1 of procedure call `(print (cpu-time))', but received 2 results
Warning: at toplevel:
- expected a single result in argument #1 of procedure call `(print (values))', but received zero results
+ (scrutiny-tests.scm:24) expected a single result in argument #1 of procedure call `(print (values))', but received zero results
Warning: at toplevel:
(scrutiny-tests.scm:27) in procedure call to `x', expected a value of type `(procedure () *)' but was given a value of type `fixnum'
Trap