diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 2c1972c4c..cbb6dd660 100644 --- 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 5f62806ed..ace6503eb 100644 --- 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 39b49782f..0be9aa3b0 100644 --- 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 ()