~ chicken-core (chicken-5) 7140d3cbe406df979e6c73cf8d0b37196d700c45

commit 7140d3cbe406df979e6c73cf8d0b37196d700c45
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jun 9 04:39:11 2011 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jun 9 04:39:11 2011 -0400

    -verbose enables notices; debug-info about compiler-passes, -phases and interesting events is shown with -debug p

diff --git a/batch-driver.scm b/batch-driver.scm
index f68332d5..d7d4b7e3 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -103,10 +103,10 @@
     (define (cputime) (current-milliseconds))
 
     (define (dribble fstr . args)
-      (when verbose (printf "~?~%~!" fstr args)))
+      (debugging 'p (apply sprintf fstr args)))
 
     (define (print-header mode dbgmode)
-      (dribble "pass: ~a" mode)
+      (debugging 'p "pass" mode)
       (and (memq dbgmode debugging-chicken)
 	   (begin
 	     (printf "[~a]~%" mode)
@@ -212,7 +212,7 @@
     (when (memq 'inline-global options)
       (set! enable-inline-files #t)
       (set! inline-locally #t))
-    (when (or verbose do-scrutinize)
+    (when verbose
       (set! ##sys#notices-enabled #t))
     (when (memq 'no-warnings options) 
       (dribble "Warnings are disabled")
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6015986d..a10e1551 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -136,7 +136,7 @@
 		 (sprintf "use of deprecated library procedure `~a'" id) )
 		'(*))
 	       ((and (pair? a) (eq? (car a) 'deprecated))
-		(report 
+		(report
 		 loc
 		 (sprintf 
 		     "use of deprecated library procedure `~a' - consider using `~a' instead"
@@ -179,7 +179,7 @@
     (define (always-true t loc x)
       (let ((f (always-true1 t)))
 	(when f
-	  (report 
+	  (report-notice 
 	   loc
 	   (sprintf
 	       "expected value of type boolean in conditional but were given a value of\ntype `~a' which is always true:~%~%~a"
@@ -413,17 +413,22 @@
 	  (let ((n (length tv)))
 	    (cond ((= 1 n) (car tv))
 		  ((zero? n)
-		   (report 
+		   (report
 		    loc
 		    (sprintf "expected ~a a single result, but were given zero results" what))
 		   'undefined)
 		  (else
-		   (report 
+		   (report
 		    loc
 		    (sprintf "expected ~a a single result, but were given ~a result~a"
 		      what n (multiples n)))
 		   (first tv))))))
 
+    (define (report-notice loc desc #!optional (show complain))
+      (when show
+	(##sys#notice
+	 (conc (location-name loc) desc))))
+
     (define (report loc desc #!optional (show complain))
       (when show
 	(warning
@@ -520,7 +525,7 @@
 				   (variable-mark pn '##compiler#predicate)) =>
 				   (lambda (pt)
 				     (cond ((match-specialization (list pt) (cdr args) #t)
-					    (report
+					    (report-notice
 					     loc
 					     (sprintf 
 						 "~athe predicate is called with an argument of type `~a' and will always return true"
@@ -531,7 +536,7 @@
 					       `(let ((#:tmp #(1))) '#t))
 					      (set! op (list pn pt))))
 					   ((match-specialization (list `(not ,pt)) (cdr args) #t)
-					    (report
+					    (report-notice
 					     loc
 					     (sprintf 
 						 "~athe predicate is called with an argument of type `~a' and will always return false"
@@ -1013,8 +1018,7 @@
 
 (define (load-type-database name #!optional (path (repository-path)))
   (and-let* ((dbfile (file-exists? (make-pathname path name))))
-    (when verbose-mode
-      (printf "loading type database ~a ...~%" dbfile))
+    (debugging 'p (sprintf "loading type database ~a ...~%" dbfile))
     (for-each
      (lambda (e)
        (let* ((name (car e))
@@ -1040,7 +1044,7 @@
 		(warning "invalid type specification" name new))))
 	   (else))
 	 (when (and old (not (compatible-types? old new)))
-	   (##sys#notice
+	   (warning
 	    (sprintf
 		"type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
 	      name new old)))
diff --git a/support.scm b/support.scm
index 9e9d9b06..088cb2b5 100644
--- a/support.scm
+++ b/support.scm
@@ -1439,8 +1439,7 @@
 (define (load-identifier-database name)
   (and-let* ((rp (repository-path))
 	     (dbfile (file-exists? (make-pathname rp name))))
-    (when verbose-mode
-      (printf "loading identifier database ~a ...~%" dbfile))
+    (debugging 'p (sprintf "loading identifier database ~a ...~%" dbfile))
     (for-each
      (lambda (e)
        (let ((id (car e)))
@@ -1597,7 +1596,7 @@ Available debugging options:
      r          show invocation parameters
      s          show program-size information and other statistics
      a          show node-matching during simplification
-     p          show execution of compiler sub-passes
+     p          show execution of compiler passes
      m          show GC statistics during compilation
      n          print the line-number database 
      c          print every expression before macro-expansion