mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Have -Wformat' better recognize the gettext' procedure.

Browse source 
Fixes <http://bugs.gnu.org/10846>.
Reported by Bruno Haible <bruno@clisp.org>.

* 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.
This commit is contained in:
Ludovic Courtès 2012-02-19 23:08:49 +01:00
parent 5de0053178
commit afc9803113
2 changed files with 41 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

31
module/language/tree-il/analyze.scm
View file

@ -1347,14 +1347,30 @@ 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)
(define (gettext? proc env)
"Return #t when PROC designates the `gettext' procedure in ENV."
(match proc
(($ <toplevel-ref> _ name)
(let ((var (false-if-exception (module-variable env name))))
(if var
(eq? (variable-ref var) gettext)
(eq? 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))
gettext))))
(_ #f)))
(define (const-fmt x env)
;; Return the literal format pattern for X, or #f.
(match x
(($ <const> _ exp)
exp)
(($ <application> _
(or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
(($ <const> _ (and (? string?) fmt))))
(($ <application> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
(_ #f)))
@ -1371,11 +1387,11 @@ 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
@ -1430,7 +1446,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 ...)
((port ($ <application> _ (? (cut gettext? <> env)) (fmt))
args ...)
(check-simple-format-args `(,port ,fmt ,args) loc))
(_ #t)))

18
test-suite/tests/tree-il.test
View file

@ -2156,6 +2156,13 @@
"non-literal format string")))))
(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")
@ -2203,7 +2210,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)
@ -2534,5 +2541,14 @@
(compile '(simple-format #t "foo ~x~%" 16)
#: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"))))))))