~ chicken-core (chicken-5) 54a1ba8fa43068741f3d96d39c3ec9576ea76099

commit 54a1ba8fa43068741f3d96d39c3ec9576ea76099
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:26:41 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 12251bcd..c8c1e2fe 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -123,6 +123,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)
   (let ((blist '())			; (((VAR . FLOW) TYPE) ...)
@@ -219,7 +229,7 @@
 	   t (pp-fragment x)))
 	f))
 
-    (define (single what tv loc)
+    (define (single node what tv loc)
       (if (eq? '* tv)
 	  '*
 	  (let ((n (length tv)))
@@ -227,14 +237,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)
@@ -253,6 +263,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
@@ -296,16 +310,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))
@@ -480,7 +487,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))
@@ -533,7 +540,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)))
@@ -600,7 +608,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))
@@ -675,7 +684,8 @@
 				      (make-node
 				       '##core#the/result
 				       (list
-					(single 
+					(single
+					 n
 					 (sprintf 
 					     "in ~a of procedure call `~s'"
 					   (if (zero? i)
@@ -817,9 +827,7 @@
 		      (cond ((null? types)
 			     (quit "~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-concatenate
 				    (map (lambda (t) (sprintf "\n    ~a" t))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 04fe4727..e7b28cb2 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -23,10 +23,10 @@ Warning: at toplevel:
   (scrutiny-tests.scm:21) in procedure call to `pp', 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'