[Guile-commits] GNU Guile branch, master, updated. release_1-9-3-58-g61aab1c

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=61aab1c3755a97390fc8e365fbd4a6b1a4f80978

The branch, master has been updated
       via  61aab1c3755a97390fc8e365fbd4a6b1a4f80978 (commit)
       via  f67ddf9dbfec851676806a2f3dff7eae539ac499 (commit)
       via  43eb8acadae88d4b56d0e54fd0870a025bd5259c (commit)
      from  b25aa0b9373d2798469e0fe999cd915e8beedc4f (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 61aab1c3755a97390fc8e365fbd4a6b1a4f80978
Author: Ludovic Courtès <address@hidden>
Date:   Tue Oct 6 23:40:30 2009 +0200

    Fix typo in `scm_array_p_2 ()'.
    
    * libguile/generalized-arrays.c (scm_array_p_2)[FUNC_NAME]: Fix.

commit f67ddf9dbfec851676806a2f3dff7eae539ac499
Author: Ludovic Courtès <address@hidden>
Date:   Tue Oct 6 23:39:56 2009 +0200

    Add compiler warning for possibly unbound variables.
    
    * module/language/tree-il/analyze.scm (<toplevel-info>): New record
      type.
      (env-module, report-possibly-unbound-variables): New procedures.
    
    * module/language/tree-il/compile-glil.scm (%warning-passes): Add
      `unbound-variable'.
    
    * module/system/base/message.scm (%warning-types): Likewise.
    
    * test-suite/tests/tree-il.test (read-and-compile, %opts-w-unbound):
      New.
      ("warnings")["unbound variable"]: New test prefix.

commit 43eb8acadae88d4b56d0e54fd0870a025bd5259c
Author: Ludovic Courtès <address@hidden>
Date:   Tue Oct 6 23:36:53 2009 +0200

    tree-il: Pass the environment to warning passes.
    
    * module/language/tree-il/analyze.scm (report-unused-variables): Taken a
      new parameter, ENV.
    
    * module/language/tree-il/compile-glil.scm (compile-glil): Pass E to
      individual warning passes.

-----------------------------------------------------------------------

Summary of changes:
 libguile/generalized-arrays.c            |    2 +-
 module/language/tree-il/analyze.scm      |  102 +++++++++++++++++++++++++++++-
 module/language/tree-il/compile-glil.scm |    7 +-
 module/system/base/message.scm           |    6 ++
 test-suite/tests/tree-il.test            |   65 +++++++++++++++++++-
 5 files changed, 175 insertions(+), 7 deletions(-)

diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index 13f66fd..8bbbed4 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -43,7 +43,7 @@ SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
            (SCM obj),
            "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
            "not.")
-#define FUNC_NAME s_scm_array_p
+#define FUNC_NAME s_scm_array_p_2
 {
   return scm_from_bool (scm_is_array (obj));
 }
diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 10c1d0b..74d41f2 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -24,8 +24,11 @@
   #:use-module (system base syntax)
   #:use-module (system base message)
   #:use-module (language tree-il)
+  #:use-module ((system base compile)
+                #:select (current-compilation-environment))
   #:export (analyze-lexicals
-            report-unused-variables))
+            report-unused-variables
+            report-possibly-unbound-variables))
 
 ;; Allocation is the process of assigning storage locations for lexical
 ;; variables. A lexical variable has a distinct "address", or storage
@@ -502,7 +505,7 @@
   (refs binding-info-refs)  ;; (GENSYM ...)
   (locs binding-info-locs)) ;; (LOCATION ...)
 
-(define (report-unused-variables tree)
+(define (report-unused-variables tree env)
   "Report about unused variables in TREE.  Return TREE."
 
   (define (dotless-list lst)
@@ -615,3 +618,98 @@
                 (make-binding-info '() '() '())
                 tree)
   tree)
+
+
+;;;
+;;; Unbound variable analysis.
+;;;
+
+;; <toplevel-info> records are used during tree traversal in search of
+;; possibly unbound variable.  They contain a list of references to
+;; potentially unbound top-level variables, a list of the top-level defines
+;; that have been encountered, and a "location stack" (see above).
+(define-record-type <toplevel-info>
+  (make-toplevel-info refs defs locs)
+  toplevel-info?
+  (refs  toplevel-info-refs)  ;; ((VARIABLE-NAME . LOCATION) ...)
+  (defs  toplevel-info-defs)  ;; (VARIABLE-NAME ...)
+  (locs  toplevel-info-locs)) ;; (LOCATION ...)
+
+(define (env-module e)
+  "Return the module corresponding to E."
+  ;; XXX: This is a bit of a hack since since representation of compile-time
+  ;; environments is hidden in `(language scheme compile-tree-il)'.
+  (cond ((pair? e)   (car e))
+        ((module? e) e)
+        (else        (current-compilation-environment))))
+
+;; TODO: Combine with `report-unused-variables' so we don't traverse the tree
+;; once for each warning type.
+
+(define (report-possibly-unbound-variables tree env)
+  "Return possibly unbound variables in TREE.  Return TREE."
+  (define toplevel
+    (let ((env (env-module env)))
+      (tree-il-fold (lambda (x info)
+                      ;; X is a leaf: extend INFO's refs accordingly.
+                      (let ((refs (toplevel-info-refs info))
+                            (defs (toplevel-info-defs info))
+                            (locs (toplevel-info-locs info)))
+                        (define (bound? name)
+                          (or (and (module? env)
+                                   (module-variable env name))
+                              (memq name defs)))
+
+                        (record-case x
+                          ((<toplevel-ref> name src)
+                           (if (bound? name)
+                               info
+                               (let ((src (or src (find pair? locs))))
+                                 (make-toplevel-info (alist-cons name src refs)
+                                                     defs
+                                                     locs))))
+                          (else info))))
+
+                    (lambda (x info)
+                      ;; Going down into X.
+                      (let* ((refs (toplevel-info-refs info))
+                             (defs (toplevel-info-defs info))
+                             (src  (tree-il-src x))
+                             (locs (cons src (toplevel-info-locs info))))
+                        (define (bound? name)
+                          (or (and (module? env)
+                                   (module-variable env name))
+                              (memq name defs)))
+
+                        (record-case x
+                          ((<toplevel-set> name src)
+                           (if (bound? name)
+                               (make-toplevel-info refs defs locs)
+                               (let ((src (find pair? locs)))
+                                 (make-toplevel-info (alist-cons name src refs)
+                                                     defs
+                                                     locs))))
+                          ((<toplevel-define> name)
+                           (make-toplevel-info (alist-delete name refs eq?)
+                                               (cons name defs)
+                                               locs))
+                          (else
+                           (make-toplevel-info refs defs locs)))))
+
+                    (lambda (x info)
+                      ;; Leaving X's scope.
+                      (let ((refs (toplevel-info-refs info))
+                            (defs (toplevel-info-defs info))
+                            (locs (toplevel-info-locs info)))
+                        (make-toplevel-info refs defs (cdr locs))))
+
+                    (make-toplevel-info '() '() '())
+                    tree)))
+
+  (for-each (lambda (name+loc)
+              (let ((name (car name+loc))
+                    (loc  (cdr name+loc)))
+                (warning 'unbound-variable loc name)))
+            (reverse (toplevel-info-refs toplevel)))
+
+  tree)
diff --git a/module/language/tree-il/compile-glil.scm 
b/module/language/tree-il/compile-glil.scm
index d13cf7c..e8b699e 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -46,18 +46,19 @@
 (define *comp-module* (make-fluid))
 
 (define %warning-passes
-  `((unused-variable . ,report-unused-variables)))
+  `((unused-variable     . ,report-unused-variables)
+    (unbound-variable    . ,report-possibly-unbound-variables)))
 
 (define (compile-glil x e opts)
   (define warnings
     (or (and=> (memq #:warnings opts) cadr)
         '()))
 
-  ;; Go throught the warning passes.
+  ;; Go through the warning passes.
   (for-each (lambda (kind)
                 (let ((warn (assoc-ref %warning-passes kind)))
                   (and (procedure? warn)
-                       (warn x))))
+                       (warn x e))))
             warnings)
 
   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 6b68c56..48a00b8 100644
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -79,6 +79,12 @@
           "report unused variables"
           ,(lambda (port loc name)
              (format port "~A: warning: unused variable `~A'~%"
+                     loc name)))
+
+         (unbound-variable
+          "report possibly unbound variables"
+          ,(lambda (port loc name)
+             (format port "~A: warning: possibly unbound variable `~A'~%"
                      loc name))))))
 
 (define (lookup-warning-type name)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index ee5e4d3..ffc1785 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -26,6 +26,9 @@
   #:use-module (language glil)
   #:use-module (srfi srfi-13))
 
+(define read-and-compile
+  (@@ (system base compile) read-and-compile))
+
 ;; Of course, the GLIL that is emitted depends on the source info of the
 ;; input. Here we're not concerned about that, so we strip source
 ;; information from the incoming tree-il.
@@ -535,6 +538,8 @@
 (define %opts-w-unused
   '(#:warnings (unused-variable)))
 
+(define %opts-w-unbound
+  '(#:warnings (unbound-variable)))
 
 (with-test-prefix "warnings"
 
@@ -588,4 +593,62 @@
        (null? (call-with-warnings
                 (lambda ()
                   (compile '(lambda (x y z) #t)
-                           #:opts %opts-w-unused)))))))
+                           #:opts %opts-w-unused))))))
+
+   (with-test-prefix "unbound variable"
+
+     (pass-if "quiet"
+       (null? (call-with-warnings
+                (lambda ()
+                  (compile '+ #:opts %opts-w-unbound)))))
+
+     (pass-if "ref"
+       (let* ((v (gensym))
+              (w (call-with-warnings
+                   (lambda ()
+                     (compile v
+                              #:to 'assembly
+                              #:opts %opts-w-unbound)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        (format #f "unbound variable `~A'"
+                                                v))))))
+
+     (pass-if "set!"
+       (let* ((v (gensym))
+              (w (call-with-warnings
+                   (lambda ()
+                     (compile `(set! ,v 7)
+                              #:to 'assembly
+                              #:opts %opts-w-unbound)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        (format #f "unbound variable `~A'"
+                                                v))))))
+
+     (pass-if "module-local top-level is visible"
+       (let ((m (make-module))
+             (v (gensym)))
+         (beautify-user-module! m)
+         (compile `(define ,v 123)
+                  #:env m #:opts %opts-w-unbound)
+         (null? (call-with-warnings
+                  (lambda ()
+                    (compile v
+                             #:env m
+                             #:to 'assembly
+                             #:opts %opts-w-unbound))))))
+
+     (pass-if "module-local top-level is visible after"
+       (let ((m (make-module))
+             (v (gensym)))
+         (beautify-user-module! m)
+         (null? (call-with-warnings
+                  (lambda ()
+                    (let ((in (open-input-string
+                               "(define (f)
+                                  (set! chbouib 3))
+                                (define chbouib 5)")))
+                      (read-and-compile in
+                                        #:env m
+                                        #:opts %opts-w-unbound)))))))))


hooks/post-receive
-- 
GNU Guile