Add -Wshadowed-toplevel.

* module/language/tree-il/analyze.scm (shadowed-toplevel-analysis): New
variable.
* module/language/tree-il/compile-cps.scm (%warning-passes): Add it.
* module/system/base/message.scm (%warning-types): Add it.
* test-suite/tests/tree-il.test ("warnings")["shadowed-toplevel"]: New
test prefix.
* module/ice-9/boot-9.scm (%auto-compilation-options): Add it.
* doc/ref/api-evaluation.texi (Compilation): Add 'shadowed-toplevel' and
'macro-use-before-definition'.

6 files changed, 131 insertions, 6 deletions

diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index d1e4dbe47..c5f1f0dc1 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -670,7 +670,9 @@ For example, to compile R6RS code, you might want to pass @command{-x
 Emit warnings of type @var{warning}; use @code{--warn=help} for a list
 of available warnings and their description.  Currently recognized
 warnings include @code{unused-variable}, @code{unused-toplevel},
-@code{unbound-variable}, @code{arity-mismatch}, @code{format},
+@code{shadowed-toplevel}, @code{unbound-variable},
+@code{macro-use-before-definition},
+@code{arity-mismatch}, @code{format},
 @code{duplicate-case-datum}, and @code{bad-case-datum}.
 
 @item -f @var{lang}
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index db17f4dfd..d8801dada 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3681,7 +3681,8 @@ but it fails to load."
 
 (define %auto-compilation-options
   ;; Default `compile-file' option when auto-compiling.
-  '(#:warnings (unbound-variable macro-use-before-definition arity-mismatch
+  '(#:warnings (unbound-variable shadowed-toplevel
+                macro-use-before-definition arity-mismatch
                 format duplicate-case-datum bad-case-datum)))
 
 (define* (load-in-vicinity dir file-name #:optional reader)
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index ff4b93d31..62632fd3c 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1,6 +1,6 @@
 ;;; TREE-IL -> GLIL compiler
 
-;; Copyright (C) 2001, 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2008-2014, 2018 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -34,6 +34,7 @@
             analyze-tree
             unused-variable-analysis
             unused-toplevel-analysis
+            shadowed-toplevel-analysis
             unbound-variable-analysis
             macro-use-before-definition-analysis
             arity-analysis
@@ -815,6 +816,37 @@ given `tree-il' element."
 
 
 ;;;
+;;; Shadowed top-level definition analysis.
+;;;
+
+(define shadowed-toplevel-analysis
+  ;; Report top-level definitions that shadow previous top-level
+  ;; definitions from the same compilation unit.
+  (make-tree-analysis
+   (lambda (x defs env locs)
+     ;; Going down into X.
+     (record-case x
+                  ((<toplevel-define> name src)
+                   (match (vhash-assq name defs)
+                     ((_ . previous-definition)
+                      (warning 'shadowed-toplevel src name
+                               (toplevel-define-src previous-definition))
+                      defs)
+                     (#f
+                      (vhash-consq name x defs))))
+                  (else defs)))
+
+   (lambda (x defs env locs)
+     ;; Leaving X's scope.
+     defs)
+
+   (lambda (defs env)
+     #t)
+
+   vlist-null))
+
+
+;;;
 ;;; Unbound variable analysis.
 ;;;
 
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 6afbc17d8..62bf7933e 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1014,6 +1014,7 @@ integer."
 (define %warning-passes
   `((unused-variable             . ,unused-variable-analysis)
     (unused-toplevel             . ,unused-toplevel-analysis)
+    (shadowed-toplevel           . ,shadowed-toplevel-analysis)
     (unbound-variable            . ,unbound-variable-analysis)
     (macro-use-before-definition . ,macro-use-before-definition-analysis)
     (arity-mismatch              . ,arity-analysis)
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 979291c1e..8559a8568 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -1,6 +1,6 @@
 ;;; User interface messages
 
-;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012, 2018 Free Software Foundation, Inc.
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -109,6 +109,13 @@
                (emit port "~A: warning: possibly unused local top-level variable `~A'~%"
                      loc name)))
 
+           (shadowed-toplevel
+            "report shadowed top-level variables"
+            ,(lambda (port loc name previous-loc)
+               (emit port "~A: warning: shadows previous definition of `~A' at ~A~%"
+                     loc name
+                     (location-string previous-loc))))
+
            (unbound-variable
             "report possibly unbound variables"
             ,(lambda (port loc name)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index d52a642aa..bba2f6fe7 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014, 2018 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -24,6 +24,8 @@
   #:use-module (system base message)
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-13))
 
 (define-syntax-rule (pass-if-primitives-resolved in expected)
@@ -218,6 +220,9 @@
 (define %opts-w-unused-toplevel
   '(#:warnings (unused-toplevel)))
 
+(define %opts-w-shadowed-toplevel
+  '(#:warnings (shadowed-toplevel)))
+
 (define %opts-w-unbound
   '(#:warnings (unbound-variable)))
 
@@ -406,6 +411,83 @@
                            #:to 'cps
                            #:opts %opts-w-unused-toplevel))))))
 
+   (with-test-prefix "shadowed-toplevel"
+
+     (pass-if "quiet"
+       (null? (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define foo 2) (define bar 3)")))
+                    (read-and-compile in
+                                      #:to 'cps
+                                      #:opts
+                                      %opts-w-shadowed-toplevel))))))
+
+     (pass-if "internal define"
+       (null? (call-with-warnings
+               (lambda ()
+                 (let ((in (open-input-string
+                            "(define foo 2)
+  (define (bar x) (define foo (+ x 2)) (* foo x))")))
+                   (read-and-compile in
+                                     #:to 'cps
+                                     #:opts
+                                     %opts-w-shadowed-toplevel))))))
+
+     (pass-if "one shadowing definition"
+       (match (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define foo 2)\n  (define foo 3)")))
+                    (read-and-compile in
+                                      #:to 'cps
+                                      #:opts
+                                      %opts-w-shadowed-toplevel))))
+         ((message)
+          (->bool (string-match ":2:2:.*previous.*foo.*:1:0" message)))))
+
+     (pass-if "two shadowing definitions"
+       (match (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define-public foo 2)\n(define foo 3)
+  (define (foo x) x)")))
+                    (read-and-compile in
+                                      #:to 'cps
+                                      #:opts
+                                      %opts-w-shadowed-toplevel))))
+         ((message1 message2)
+          (->bool
+           (and (string-match ":2:0:.*previous.*foo.*:1:0" message1)
+                (string-match ":3:2:.*previous.*foo.*:1:0" message2))))))
+
+     (pass-if "define-public"
+       (match (call-with-warnings
+                (lambda ()
+                  (let ((in (open-input-string
+                             "(define foo 2)\n(define-public foo 3)")))
+                    (read-and-compile in
+                                      #:to 'cps
+                                      #:opts
+                                      %opts-w-shadowed-toplevel))))
+         ((message)
+          (->bool (string-match ":2:0:.*previous.*foo.*:1:0" message)))))
+
+     (pass-if "macro"
+       (match (call-with-warnings
+               (lambda ()
+                 (let ((in (open-input-string
+                            "(define foo 42)
+  (define-syntax-rule (defun proc (args ...) body ...)
+    (define (proc args ...) body ...))
+  (defun foo (a b c) (+ a b c))")))
+                   (read-and-compile in
+                                     #:to 'cps
+                                     #:opts
+                                     %opts-w-shadowed-toplevel))))
+         ((message)
+          (->bool (string-match ":4:2:.*previous.*foo.*:1:0" message))))))
+
    (with-test-prefix "unbound variable"
 
      (pass-if "quiet"