mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 13:30:26 +02:00
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.
This commit is contained in:
Ludovic Courtès
parent
89702c819c
commit
e06972410a
3 changed files with 339 additions and 24 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue