From e06972410a1f743edb8c8d78dc81eccbbac4ee5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 10 Oct 2010 17:13:21 +0200 Subject: [PATCH] Implement fancy format string analysis. * module/language/tree-il/analyze.scm (format-string-argument-count): Return two values, the minimum and maximum number of arguments. Add support for most of `format' escapes, including conditionals. (format-analysis): Adjust accordingly. * module/system/base/message.scm (%warning-types)[format]: Take two arguments, MIN and MAX, instead of EXPECTED. Display warning accordingly. * test-suite/tests/tree-il.test ("warnings")["format"]("~%, ~~, ~&, ~t, ~_, and ~\\n", "~{...~}", "~{...~}, too many args", "~@{...~}", "~@{...~}, too few args", "~(...~)", "~v", "~v:@y", "~*", "~?", "complex 1", "complex 2", "complex 3"): New tests. ("conditionals"): New test prefix. --- module/language/tree-il/analyze.scm | 154 +++++++++++++++++++--- module/system/base/message.scm | 16 ++- test-suite/tests/tree-il.test | 193 +++++++++++++++++++++++++++- 3 files changed, 339 insertions(+), 24 deletions(-) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 05957934f..2c1972c4c 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -1202,23 +1202,134 @@ accurate information is missing from a given `tree-il' element." ;;; (define (format-string-argument-count fmt) - ;; Return the number of arguments that should follow format string - ;; FMT, or at least a good estimate thereof. + ;; Return the minimum and maxium number of arguments that should + ;; follow format string FMT (or, ahem, a good estimate thereof) or + ;; `any' if the format string can be followed by any number of + ;; arguments. - ;; FIXME: Implement ~[ conditionals. Check - ;; `language/assembly/disassemble.scm' for an example. - (let loop ((chars (string->list fmt)) - (tilde? #f) - (count 0)) + (define (drop-group chars end) + ;; Drop characters from CHARS until "~END" is encountered. + (let loop ((chars chars) + (tilde? #f)) + (if (null? chars) + chars ;; syntax error? + (if tilde? + (if (eq? (car chars) end) + (cdr chars) + (loop (cdr chars) #f)) + (if (eq? (car chars) #\~) + (loop (cdr chars) #t) + (loop (cdr chars) #f)))))) + + (define (digit? char) + ;; Return true if CHAR is a digit, #f otherwise. + (memq char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) + + (define (previous-number chars) + ;; Return the previous series of digits found in CHARS. + (let ((numbers (take-while digit? chars))) + (and (not (null? numbers)) + (string->number (list->string (reverse numbers)))))) + + (let loop ((chars (string->list fmt)) + (state 'literal) + (params '()) + (conditions '()) + (end-group #f) + (min-count 0) + (max-count 0)) (if (null? chars) - count - (if tilde? - (case (car chars) - ((#\~ #\%) (loop (cdr chars) #f count)) - (else (loop (cdr chars) #f (+ 1 count)))) - (case (car chars) - ((#\~) (loop (cdr chars) #t count)) - (else (loop (cdr chars) #f count))))))) + (if end-group + (values #f #f) ;; syntax error + (values min-count max-count)) + (case state + ((tilde) + (case (car chars) + ((#\~ #\% #\& #\t #\_ #\newline #\( #\)) + (loop (cdr chars) 'literal '() + conditions end-group + min-count max-count)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\, #\: #\@) + (loop (cdr chars) + 'tilde (cons (car chars) params) + conditions end-group + min-count max-count)) + ((#\v #\V) (loop (cdr chars) + 'tilde (cons (car chars) params) + conditions end-group + (+ 1 min-count) + (+ 1 max-count))) + ((#\[) + (loop chars 'literal '() '() + (let ((selector (previous-number params)) + (at? (memq #\@ params))) + (lambda (chars conds) + ;; end of group + (let ((mins (map car conds)) + (maxs (map cdr conds)) + (sel? (and selector + (< selector (length conds))))) + (if (and (every number? mins) + (every number? maxs)) + (loop chars 'literal '() conditions end-group + (+ min-count + (if sel? + (car (list-ref conds selector)) + (+ (if at? 0 1) + (if (null? mins) + 0 + (apply min mins))))) + (+ max-count + (if sel? + (cdr (list-ref conds selector)) + (+ (if at? 0 1) + (if (null? maxs) + 0 + (apply max maxs)))))) + (values #f #f))))) + 0 0)) + ((#\;) + (loop (cdr chars) 'literal '() + (cons (cons min-count max-count) conditions) + end-group + 0 0)) + ((#\]) + (if end-group + (end-group (cdr chars) + (reverse (cons (cons min-count max-count) + conditions))) + (values #f #f))) ;; syntax error + ((#\{) (if (memq #\@ params) + (values min-count 'any) + (loop (drop-group (cdr chars) #\}) + 'literal '() + conditions end-group + (+ 1 min-count) (+ 1 max-count)))) + ((#\*) (if (memq #\@ params) + (values 'any 'any) ;; it's unclear what to do here + (loop (cdr chars) + 'literal '() + conditions end-group + (+ (or (previous-number params) 1) + min-count) + (+ (or (previous-number params) 1) + max-count)))) + ((#\? #\k) + ;; We don't have enough info to determine the exact number + ;; of args, but we could determine a lower bound (TODO). + (values 'any 'any)) + (else (loop (cdr chars) 'literal '() + conditions end-group + (+ 1 min-count) (+ 1 max-count))))) + ((literal) + (case (car chars) + ((#\~) (loop (cdr chars) 'tilde '() + conditions end-group + min-count max-count)) + (else (loop (cdr chars) 'literal '() + conditions end-group + min-count max-count)))) + (else (error "computer bought the farm" state)))))) (define format-analysis ;; Report arity mismatches in the given tree. @@ -1233,11 +1344,14 @@ accurate information is missing from a given `tree-il' element." (pmatch args ((,port ,fmt . ,rest) (guard (and (const? fmt) (string? (const-exp fmt)))) - (let* ((fmt (const-exp fmt)) - (expected (format-string-argument-count fmt)) - (actual (length rest))) - (or (= expected actual) - (warning 'format loc fmt expected actual)))) + (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))) (define (resolve-toplevel name) diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 8ca299193..5f62806ed 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -106,7 +106,7 @@ (format "report wrong number of arguments to `format'" - ,(lambda (port loc fmt expected actual) + ,(lambda (port loc fmt min max actual) (define (escape-newlines str) (list->string (string-fold-right (lambda (c r) @@ -115,9 +115,21 @@ (cons c r))) '() str))) + + (define (range) + (cond ((eq? min 'any) + (if (eq? max 'any) + "any number" ;; can't happen + (format #f "up to ~a" max))) + ((eq? max 'any) + (format #f "at least ~a" min)) + ((= min max) (number->string min)) + (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) expected actual)))))) + loc (escape-newlines fmt) (range) actual)))))) (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 2455c176f..39b49782f 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1104,10 +1104,10 @@ #:opts %opts-w-format #:to 'assembly))))) - (pass-if "~% and ~~" + (pass-if "~%, ~~, ~&, ~t, ~_, and ~\\n" (null? (call-with-warnings (lambda () - (compile '(format some-port "~~ hey~%") + (compile '(format some-port "~&~3_~~ ~\n~12they~%") #:opts %opts-w-format #:to 'assembly))))) @@ -1151,6 +1151,195 @@ (number? (string-contains (car w) "expected 1, got 2"))))) + (with-test-prefix "conditionals" + (pass-if "literals" + (null? (call-with-warnings + (lambda () + (compile '(format #f "~A ~[foo~;bar~;baz~;~] ~10,2f" + 'a 1 3.14) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "literals with selector" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~2[foo~;bar~;baz~;~] ~A" + 1 'dont-ignore-me) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 2"))))) + + (pass-if "escapes (exact count)" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~[~a~;~a~]") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 2, got 0"))))) + + (pass-if "escapes with selector" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~1[chbouib~;~a~]") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + + (pass-if "escapes, range" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~[chbouib~;~a~;~2*~a~]") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1 to 4, got 0"))))) + + (pass-if "@" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~@[temperature=~d~]") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + + (pass-if "nested" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~:[~[hey~;~a~;~va~]~;~3*~]") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 2 to 4, got 0"))))) + + (pass-if "invalid syntax" + ;; Syntax errors should be gracefully handled. + (null? (call-with-warnings + (lambda () + (compile '(format #f "~[unterminated") + #:opts %opts-w-format + #:to 'assembly)))))) + + (pass-if "~{...~}" + (null? (call-with-warnings + (lambda () + (compile '(format #f "~A ~{~S~} ~A" + 'hello '("ladies" "and") + 'gentlemen) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "~{...~}, too many args" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~{~S~}" 1 2 3) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 3"))))) + + (pass-if "~@{...~}" + (null? (call-with-warnings + (lambda () + (compile '(format #f "~@{~S~}" 1 2 3) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "~@{...~}, too few args" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~A ~@{~S~}") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected at least 1, got 0"))))) + + (pass-if "~(...~)" + (null? (call-with-warnings + (lambda () + (compile '(format #f "~:@(~A ~A~)" 'foo 'bar) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "~v" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~v_foo") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 1, got 0"))))) + (pass-if "~v:@y" + (null? (call-with-warnings + (lambda () + (compile '(format #f "~v:@y" 1 123) + #:opts %opts-w-format + #:to 'assembly))))) + + + (pass-if "~*" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~2*~a" 'a 'b) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 3, got 2"))))) + + (pass-if "~?" + (null? (call-with-warnings + (lambda () + (compile '(format #f "~?" "~d ~d" '(1 2)) + #:opts %opts-w-format + #:to 'assembly))))) + + (pass-if "complex 1" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f + "~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" + 1 2 3 4 5 6) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 4, got 6"))))) + + (pass-if "complex 2" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f + "~:(~A~) Commands~:[~; [abbrev]~]:~2%" + 1 2 3 4) + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 2, got 4"))))) + + (pass-if "complex 3" + (let ((w (call-with-warnings + (lambda () + (compile '(format #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%") + #:opts %opts-w-format + #:to 'assembly))))) + (and (= (length w) 1) + (number? (string-contains (car w) + "expected 5, got 0"))))) + (pass-if "ice-9 format" (let ((w (call-with-warnings (lambda ()