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'.

1 files changed, 83 insertions, 1 deletions

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"