[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-54-g98385ed

[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=98385ed20abdc191a67daef8a00b1df0290a074a

The branch, stable-2.0 has been updated
       via  98385ed20abdc191a67daef8a00b1df0290a074a (commit)
       via  afc9803113de660a761f476b7957e92cc60bad19 (commit)
      from  5de0053178b4acc793ae62838175e5f3ab56c603 (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 98385ed20abdc191a67daef8a00b1df0290a074a
Author: Ludovic Courtès <address@hidden>
Date:   Sun Feb 19 23:54:18 2012 +0100

    Have `-Wformat' recognize `ngettext' calls.
    
    * module/language/tree-il/analyze.scm (gettext?): Rename to...
      (proc-ref?): ... this.  Add `proc' and `special-name' parameters.
      (gettext?): Define in terms of `proc-ref?'.
      (ngettext?): New procedure.
      (const-fmt): Recognize `ngettext' calls.
      (format-analysis)[<down>](check-format-args]: Check
      constant-but-non-string 2nd argument in the (not (const-fmt ...))
      case.
      [check-simple-format-args]: Use `const-fmt'.
    
    * test-suite/tests/tree-il.test ("warnings")["format"]("non-literal
      format string using ngettext", "non-literal format string using
      ngettext as N_"): New tests.
      ("simple-format")["unsupported, ngettext"]: New test.

commit afc9803113de660a761f476b7957e92cc60bad19
Author: Ludovic Courtès <address@hidden>
Date:   Sun Feb 19 23:08:49 2012 +0100

    Have `-Wformat' better recognize the `gettext' procedure.
    
    Fixes <http://bugs.gnu.org/10846>.
    Reported by Bruno Haible <address@hidden>.
    
    * module/language/tree-il/analyze.scm (gettext?): New procedure.
      (const-fmt): Add `env' parameter; update callers.  Use `gettext?'.
      (format-analysis)[check-simple-format-args]: Actually support
      gettextized format strings.
    
    * test-suite/tests/tree-il.test ("warnings")["format"]("non-literal
      format string using gettext"): Use `gettext' as the procedure name.
      ("non-literal format string using gettext as _"): New test.
      ["simple-format"]("unsupported, gettext"): New test.

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

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

diff --git a/module/language/tree-il/analyze.scm 
b/module/language/tree-il/analyze.scm
index 9bcc92f..9e6952e 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1347,16 +1347,41 @@ accurate information is missing from a given `tree-il' 
element."
                               min-count max-count))))
           (else (error "computer bought the farm" state))))))
 
-(define (const-fmt x)
-  ;; Return the literal format pattern for X, or #f.
+(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."
+  (match exp
+    (($ <toplevel-ref> _ name)
+     (let ((var (false-if-exception (module-variable env name))))
+       (if var
+           (eq? (variable-ref var) proc)
+           (eq? name special-name))))      ; special hack to support local 
aliases
+    (($ <module-ref> _ module name public?)
+     (let ((m (false-if-exception (if public?
+                                      (resolve-interface module)
+                                      (resolve-module module)))))
+       (and m (eq? (false-if-exception (module-ref module name)) proc))))
+    (_ #f)))
+
+(define gettext? (cut proc-ref? <> gettext '_ <>))
+(define ngettext? (cut proc-ref? <> ngettext 'N_ <>))
+
+(define (const-fmt x env)
+  ;; Return the literal format string for X, or #f.
   (match x
-    (($ <const> _ exp)
+    (($ <const> _ (? string? exp))
      exp)
-    (($ <application> _
-        (or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
-        (($ <const> _ (and (? string?) fmt))))
+    (($ <application> _ (? (cut gettext? <> env))
+        (($ <const> _ (? string? fmt))))
      ;; Gettexted literals, like `(_ "foo")'.
      fmt)
+    (($ <application> _ (? (cut ngettext? <> env))
+        (($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
+     ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
+
+     ;; TODO: Check whether the singular and plural strings have the
+     ;; same format escapes.
+     fmt)
     (_ #f)))
 
 (define format-analysis
@@ -1371,36 +1396,38 @@ accurate information is missing from a given `tree-il' 
element."
      (define (check-format-args args loc)
        (pmatch args
          ((,port ,fmt . ,rest)
-          (guard (const-fmt fmt))
+          (guard (const-fmt fmt env))
           (if (and (const? port)
                    (not (boolean? (const-exp port))))
               (warning 'format loc 'wrong-port (const-exp port)))
-          (let ((fmt   (const-fmt fmt))
+          (let ((fmt   (const-fmt fmt env))
                 (count (length rest)))
-            (if (string? fmt)
-                (catch &syntax-error
-                  (lambda ()
-                    (let-values (((min max)
-                                  (format-string-argument-count fmt)))
-                      (and min max
-                           (or (and (or (eq? min 'any) (>= count min))
-                                    (or (eq? max 'any) (<= count max)))
-                               (warning 'format loc 'wrong-format-arg-count
-                                        fmt min max count)))))
-                  (lambda (_ key)
-                    (warning 'format loc 'syntax-error key fmt)))
-                (warning 'format loc 'wrong-format-string fmt))))
+            (catch &syntax-error
+              (lambda ()
+                (let-values (((min max)
+                              (format-string-argument-count fmt)))
+                  (and min max
+                       (or (and (or (eq? min 'any) (>= count min))
+                                (or (eq? max 'any) (<= count max)))
+                           (warning 'format loc 'wrong-format-arg-count
+                                    fmt min max count)))))
+              (lambda (_ key)
+                (warning 'format loc 'syntax-error key fmt)))))
          ((,port ,fmt . ,rest)
           (if (and (const? port)
                    (not (boolean? (const-exp port))))
               (warning 'format loc 'wrong-port (const-exp port)))
-          ;; Warn on non-literal format strings, unless they refer to a
-          ;; lexical variable named "fmt".
-          (if (record-case fmt
-                ((<lexical-ref> name)
-                 (not (eq? name 'fmt)))
-                (else #t))
-              (warning 'format loc 'non-literal-format-string)))
+
+          (match fmt
+            (($ <const> loc* (? (negate string?) fmt))
+             (warning 'format (or loc* loc) 'wrong-format-string fmt))
+
+            ;; Warn on non-literal format strings, unless they refer to
+            ;; a lexical variable named "fmt".
+            (($ <lexical-ref> _ fmt)
+             #t)
+            ((? (negate const?))
+             (warning 'format loc 'non-literal-format-string))))
          (else
           (warning 'format loc 'wrong-num-args (length args)))))
 
@@ -1430,8 +1457,8 @@ accurate information is missing from a given `tree-il' 
element."
                   (warning 'format loc 'simple-format fmt
                            (find (negate (cut memq <> allowed-chars)) opts))
                   #f))))
-         ((port (($ <const> _ '_) fmt) args ...)
-          (check-simple-format-args `(,port ,fmt ,args) loc))
+         ((port (= (cut const-fmt <> env) (? string? fmt)) args ...)
+          (check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc))
          (_ #t)))
 
      (define (resolve-toplevel name)
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 68827a8..945b236 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -2158,10 +2158,32 @@
      (pass-if "non-literal format string using gettext"
        (null? (call-with-warnings
                (lambda ()
+                 (compile '(format #t (gettext "~A ~A!") "hello" "world")
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using gettext as _"
+       (null? (call-with-warnings
+               (lambda ()
                  (compile '(format #t (_ "~A ~A!") "hello" "world")
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
+     (pass-if "non-literal format string using ngettext"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t
+                                   (ngettext "~a thing" "~a things" n "dom") n)
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
+     (pass-if "non-literal format string using ngettext as N_"
+       (null? (call-with-warnings
+               (lambda ()
+                 (compile '(format #t (N_ "~a thing" "~a things" n) n)
+                          #:opts %opts-w-format
+                          #:to 'assembly)))))
+
      (pass-if "wrong format string"
        (let ((w (call-with-warnings
                  (lambda ()
@@ -2203,7 +2225,7 @@
      (pass-if "one missing argument, gettext"
        (let ((w (call-with-warnings
                  (lambda ()
-                   (compile '(format some-port (_ "foo ~A~%"))
+                   (compile '(format some-port (gettext "foo ~A~%"))
                             #:opts %opts-w-format
                             #:to 'assembly)))))
          (and (= (length w) 1)
@@ -2535,4 +2557,22 @@
                               #:opts %opts-w-format
                               #:to 'assembly)))))
            (and (= (length w) 1)
+                (number? (string-contains (car w) "unsupported format 
option")))))
+
+       (pass-if "unsupported, gettext"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
+                (number? (string-contains (car w) "unsupported format 
option")))))
+
+       (pass-if "unsupported, ngettext"
+         (let ((w (call-with-warnings
+                   (lambda ()
+                     (compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
+                              #:opts %opts-w-format
+                              #:to 'assembly)))))
+           (and (= (length w) 1)
                 (number? (string-contains (car w) "unsupported format 
option"))))))))


hooks/post-receive
-- 
GNU Guile