Add new `format' warnings.

* module/language/tree-il/analyze.scm (format-analysis): Add new
  sub-warnings: `wrong-port', `wrong-format-string',
  `non-literal-format-string', and `wrong-num-args'.

* module/system/base/message.scm (%warning-types)[format]: Handle
  them.

* test-suite/tests/tree-il.test ("warnings")["wrong port arg",
  "wrong format string", "non-literal format string",
  "wrong number of args"]: New tests.

diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 2c1972c..cbb6dd6 100644 (file)
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1343,16 +1343,25 @@ accurate information is missing from a given `tree-il' element."
      (define (check-format-args args loc)
        (pmatch args
          ((,port ,fmt . ,rest)
-          (guard (and (const? fmt) (string? (const-exp fmt))))
+          (guard (const? fmt))
+          (if (and (const? port)
+                   (not (boolean? (const-exp port))))
+              (warning 'format loc 'wrong-port (const-exp port)))
           (let ((fmt   (const-exp fmt))
                 (count (length rest)))
-            (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 fmt min max count))))))
-         (else #t)))
+            (if (string? fmt)
+                (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))))
+                (warning 'format loc 'wrong-format-string fmt))))
+         ((,port ,fmt . ,rest)
+          (warning 'format loc 'non-literal-format-string))
+         (else
+          (warning 'format loc 'wrong-num-args (length args)))))
 
      (define (resolve-toplevel name)
        (and (module? env)

diff --git a/module/system/base/message.scm b/module/system/base/message.scm
index 5f62806..ace6503 100644 (file)
--- a/module/system/base/message.scm
+++ b/module/system/base/message.scm
@@ -26,6 +26,7 @@
 (define-module (system base message)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
   #:export (*current-warning-port* warning
 
             warning-type? warning-type-name warning-type-description
@@ -106,7 +107,7 @@
 
          (format
           "report wrong number of arguments to `format'"
-          ,(lambda (port loc fmt min max actual)
+          ,(lambda (port loc . rest)
              (define (escape-newlines str)
                (list->string
                 (string-fold-right (lambda (c r)
@@ -116,7 +117,7 @@
                                    '()
                                    str)))
 
-             (define (range)
+             (define (range min max)
                (cond ((eq? min 'any)
                       (if (eq? max 'any)
                           "any number" ;; can't happen
@@ -127,9 +128,30 @@
                      (else
                       (format #f "~a to ~a" min max))))
 
-             (format port
-                     "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
-                     loc (escape-newlines fmt) (range) actual))))))
+             (match rest
+               (('wrong-format-arg-count fmt min max actual)
+                (format port
+                        "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
+                        loc (escape-newlines fmt)
+                        (range min max) actual))
+               (('wrong-port wrong-port)
+                (format port
+                        "~A: warning: ~S: wrong port argument~%"
+                        loc wrong-port))
+               (('wrong-format-string fmt)
+                (format port
+                        "~A: warning: ~S: wrong format string~%"
+                        loc fmt))
+               (('non-literal-format-string)
+                (format port
+                        "~A: warning: non-literal format string~%"
+                        loc))
+               (('wrong-num-args count)
+                (format port
+                        "~A: warning: wrong number of arguments to `format'~%"
+                        loc))
+               (else
+                (format port "~A: `format' warning~%" loc))))))))
 
 (define (lookup-warning-type name)
   "Return the warning type NAME or `#f' if not found."

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 39b4978..0be9aa3 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1104,6 +1104,46 @@
                           #:opts %opts-w-format
                           #:to 'assembly)))))
 
+     (pass-if "wrong port arg"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(format 10 "foo")
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong port argument")))))
+
+     (pass-if "non-literal format string"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(format #f fmt)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "non-literal format string")))))
+
+     (pass-if "wrong format string"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(format #f 'not-a-string)
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong format string")))))
+
+     (pass-if "wrong number of args"
+       (let ((w (call-with-warnings
+                 (lambda ()
+                   (compile '(format "shbweeb")
+                            #:opts %opts-w-format
+                            #:to 'assembly)))))
+         (and (= (length w) 1)
+              (number? (string-contains (car w)
+                                        "wrong number of arguments")))))
+
      (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n"
        (null? (call-with-warnings
                (lambda ()