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 <[email protected]> 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 <[email protected]> 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 <[email protected]>. * 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
