[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-144-g8a74ffe

[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=8a74ffe88a445220f9399cc49d4808baf51651c2

The branch, stable-2.0 has been updated
       via  8a74ffe88a445220f9399cc49d4808baf51651c2 (commit)
       via  2c5f0bdb0e4d59c8a49925f75dd4793c19ebe08a (commit)
      from  4c98474782d11ad02046c87af148e29d14afbc29 (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 8a74ffe88a445220f9399cc49d4808baf51651c2
Author: Ludovic Courtès <address@hidden>
Date:   Sat May 12 16:11:51 2012 +0200

    Have `-Wformat' remain quiet for any procedure called `_' or `N_'.
    
    * module/language/tree-il/analyze.scm (proc-ref?)[special?]: New
      procedure.
      Return #t for any toplevel-ref of `_'.
    
    * test-suite/tests/tree-il.test ("warnings")["format"]("non-literal
      format string using gettext as top-level _"): New test.

commit 2c5f0bdb0e4d59c8a49925f75dd4793c19ebe08a
Author: Ludovic Courtès <address@hidden>
Date:   Sat May 12 15:58:23 2012 +0200

    Have `-Warity-mismatch' handle applicable structs.
    
    * module/language/tree-il/analyze.scm (arity-analysis): Honor applicable
      structs.
    
    * test-suite/tests/tree-il.test ("warnings")["arity
      mismatch"]("top-level applicable struct", "top-level applicable struct
      with wrong arguments"): New tests.

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

Summary of changes:
 module/language/tree-il/analyze.scm |   31 ++++++++++++++++++++++---------
 test-suite/tests/tree-il.test       |   29 +++++++++++++++++++++++++++++
 2 files changed, 51 insertions(+), 9 deletions(-)

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 76923fc..c3ff9e2 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1194,8 +1194,15 @@ accurate information is missing from a given `tree-il' 
element."
                              (false-if-exception
                               (module-ref env name))))
                       proc)))
-            (if (or (lambda? proc*) (procedure? proc*))
-                (validate-arity proc* application (lambda? proc*)))))
+            (cond ((lambda? proc*)
+                   (validate-arity proc* application #t))
+                  ((struct? proc*)
+                   ;; An applicable struct.
+                   (let ((p (struct-ref proc* 0)))
+                     (and (procedure? p)
+                          (validate-arity p application #f))))
+                  ((procedure? proc*)
+                   (validate-arity proc* application #f)))))
         toplevel-calls)))
 
    (make-arity-info vlist-null vlist-null vlist-null)))
@@ -1350,21 +1357,27 @@ accurate information is missing from a given `tree-il' 
element."
 (define (proc-ref? exp proc special-name env)
   "Return #t when EXP designates procedure PROC in ENV.  As a last
 resort, return #t when EXP refers to the global variable SPECIAL-NAME."
+
+  (define special?
+    (cut eq? <> special-name))
+
   (match exp
+    (($ <toplevel-ref> _ (? special?))
+     ;; Allow top-levels like: (define _ (cut gettext <> "my-domain")).
+     #t)
     (($ <toplevel-ref> _ name)
      (let ((var (module-variable env name)))
-       (if (and var (variable-bound? var))
-           (eq? (variable-ref var) proc)
-           (eq? name special-name)))) ; special hack to support local aliases
+       (and var (variable-bound? var)
+            (eq? (variable-ref var) proc))))
+    (($ <module-ref> _ _ (? special?))
+     #t)
     (($ <module-ref> _ module name public?)
      (let* ((mod (if public?
                      (false-if-exception (resolve-interface module))
                      (resolve-module module #:ensure #f)))
             (var (and mod (module-variable mod name))))
-       (if var
-           (and (variable-bound? var) (eq? (variable-ref var) proc))
-           (eq? name special-name))))
-    (($ <lexical-ref> _ (? (cut eq? <> special-name)))
+       (and var (variable-bound? var) (eq? (variable-ref var) proc))))
+    (($ <lexical-ref> _ (? special?))
      #t)
     (_ #f)))
 
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 28c0b26..4ffdce0 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1103,6 +1103,26 @@
                                   w "wrong number of arguments to"))))
                              w)))))
 
+     (pass-if "top-level applicable struct"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(let ((p current-warning-port))
+                             (p (+ (p) 1))
+                             (p))
+                          #:opts %opts-w-arity
+                          #:to 'assembly)))))
+
+     (pass-if "top-level applicable struct with wrong arguments"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(let ((p current-warning-port))
+                               (p 1 2 3))
+                            #:opts %opts-w-arity
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong number of arguments to")))))
+
      (pass-if "local toplevel-defines"
        (let ((w (call-with-warnings
                   (lambda ()
@@ -1242,6 +1262,15 @@
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
+     (pass-if "non-literal format string using gettext as top-level _"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(begin
+                             (define (_ s) (gettext s "my-domain"))
+                             (format #t (_ "~A ~A!") "hello" "world"))
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
      (pass-if "non-literal format string using gettext as module-ref _"
        (null? (call-with-warnings
                (lambda ()


hooks/post-receive
-- 
GNU Guile