>From 9210d212223ef0b55163d9c74074a0ea26f5c783 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Sun, 14 Feb 2016 11:49:02 +1300
Subject: [PATCH] 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.
---
 scrutinizer.scm         | 54 ++++++++++++++++++++++++++++---------------------
 tests/scrutiny.expected |  4 ++--
 2 files changed, 33 insertions(+), 25 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index ab9ed51..b4ed8e1 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 4907573..bcbe4c7 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'
-- 
2.7.0.rc3