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.

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 340f940..c3ff9e2 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1357,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 96ae989..4ffdce0 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1262,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 ()