;;;
(define (format-string-argument-count fmt)
- ;; Return the number of arguments that should follow format string
- ;; FMT, or at least a good estimate thereof.
-
- ;; FIXME: Implement ~[ conditionals. Check
- ;; `language/assembly/disassemble.scm' for an example.
- (let loop ((chars (string->list fmt))
- (tilde? #f)
- (count 0))
+ ;; 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.
+
+ (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.
(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)
(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)
(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."
#: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)))))
(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 ()
HCoop / bpt / guile.git / commitdiff