[Guile-commits] 54/58: Add -Wshadowed-toplevel.

[Andy Wingo]

wingo pushed a commit to branch lightning
in repository guile.

commit c6f70e4b04a7ac3ecdc6ee3b53e0ae4380945f9c
Author: Ludovic Courtès <address@hidden>
Date:   Tue Jul 24 11:53:02 2018 +0200

    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'.
---
 doc/ref/api-evaluation.texi             |  4 +-
 module/ice-9/boot-9.scm                 |  3 +-
 module/language/tree-il/analyze.scm     | 34 ++++++++++++-
 module/language/tree-il/compile-cps.scm |  1 +
 module/system/base/message.scm          |  9 +++-
 test-suite/tests/tree-il.test           | 84 ++++++++++++++++++++++++++++++++-
 6 files changed, 130 insertions(+), 5 deletions(-)

diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 60f7fec..cfae07f 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},
address@hidden, @code{arity-mismatch}, @code{format},
address@hidden, @code{unbound-variable},
address@hidden,
address@hidden, @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 6e44ce7..77bb3ce 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3665,7 +3665,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 ff4b93d..62632fd 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 7672524..6c8884a 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -2319,6 +2319,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 979291c..8559a85 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 d52a642..bba2f6f 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 <address@hidden> --- 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"