mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Have -Wformat' recognize ngettext' calls.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2012-02-19 23:54:18 +01:00
parent afc9803113
commit 98385ed20a
2 changed files with 67 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1347,32 +1347,41 @@ accurate information is missing from a given `tree-il' element."
min-count max-count))))
(else (error "computer bought the farm" state))))))
(define (gettext? proc env)
"Return #t when PROC designates the `gettext' procedure in ENV."
(match proc
(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) gettext)
(eq? name '_)))) ; special hack to support local aliases
(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))
gettext))))
(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 pattern for X, or #f.
;; Return the literal format string for X, or #f.
(match x
(($ <const> _ exp)
(($ <const> _ (? string? exp))
exp)
(($ <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
@ -1393,30 +1402,32 @@ accurate information is missing from a given `tree-il' element."
(warning 'format loc 'wrong-port (const-exp port)))
(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)))))
@ -1446,9 +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 ($ <application> _ (? (cut gettext? <> env)) (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)

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

@ -2169,6 +2169,21 @@
#: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 ()
@ -2550,5 +2565,14 @@
(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"))))))))