hars 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 'any 'any))))) ;; XXX: approximation
                    0 0))
             ((#\;)
              (if end-group
                  (loop (cdr chars) 'literal '()
                        (cons (cons min-count max-count) conditions)
                        end-group
                        0 0)
                  (throw &syntax-error 'unexpected-semicolon)))
             ((#\])
              (if end-group
                  (end-group (cdr chars)
                             (reverse (cons (cons min-count max-count)
                                            conditions)))
                  (throw &syntax-error 'unexpected-conditional-termination)))
             ((#\{)     (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 #\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))
             ((#\^)
              (values min-count 'any))
             ((#\h #\H)
                        (let ((argc (if (memq #\: params) 2 1)))
                          (loop (cdr chars) 'literal '()
                                conditions end-group
                                (+ argc min-count)
                                (+ argc max-count))))
             ((#\')
              (if (null? (cdr chars))
                  (throw &syntax-error 'unexpected-termination)
                  (loop (cddr chars) 'tilde (cons (cadr chars) params)
                        conditions end-group min-count max-count)))
             (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 (proc-ref? exp proc special-name env)
  "Return #t when EXP designates procedure PROC in ENV.  As a last
resort, return #t when EXP refers to the global variable SPECIAL-NAME."

  (define special?
    (cut eq? <> special-name))

  (match exp
    (($ <toplevel-ref> _ _ (? special?))
     ;; Allow top-levels like: (define G_ (cut gettext <> "my-domain")).
     #t)
    (($ <toplevel-ref> _ _ name)
     (let ((var (module-variable env name)))
       (and var (variable-bound? var)
            (eq? (variable-ref var) proc))))
    (($ <module-ref> _ _ (? special?))
     #t)
    (($ <module-ref> _ module name public?)
     (let* ((mod (if public?
                     (false-if-exception (resolve-interface module))
                     (resolve-module module #:ensure #f)))
            (var (and mod (module-variable mod name))))
       (and var (variable-bound? var) (eq? (variable-ref var) proc))))
    (($ <lexical-ref> _ (? special?))
     #t)
    (_ #f)))

(define gettext? (cut proc-ref? <> gettext 'G_ <>))
(define ngettext? (cut proc-ref? <> ngettext 'N_ <>))

(define (const-fmt x env)
  ;; Return the literal format string for X, or #f.
  (match x
    (($ <const> _ (? string? exp))
     exp)
    (($ <call> _ (? (cut gettext? <> env))
        (($ <const> _ (? string? fmt))))
     ;; Gettexted literals, like `(G_ "foo")'.
     fmt)
    (($ <call> _ (? (cut ngettext? <> env))
        (($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
     ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.

     ;; TODO: Check whether the singular and plural strings have the
     ;; same format escapes.
     fmt)
    (_ #f)))

(define format-analysis
  ;; Report arity mismatches in the given tree.
  (make-tree-analysis
   (lambda (x res env locs)
     ;; Down into X.
     (define (check-format-args args loc)
       (pmatch args
         ((,port ,fmt . ,rest)
          (guard (const-fmt fmt env))
          (if (and (const? port)
                   (not (boolean? (const-exp port))))
              (warning 'format loc 'wrong-port (const-exp port)))
          (let ((fmt   (const-fmt fmt env))
                (count (length rest)))
            (catch &syntax-error
              (lambda ()
                (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)))))
              (lambda (_ key)
                (warning 'format loc 'syntax-error key fmt)))))
         ((,port ,fmt . ,rest)
          (if (and (const? port)
                   (not (boolean? (const-exp port))))
              (warning 'format loc 'wrong-port (const-exp port)))

          (match fmt
            (($ <const> loc* (? (negate string?) fmt))
             (warning 'format (or loc* loc) 'wrong-format-string fmt))

            ;; Warn on non-literal format strings, unless they refer to
            ;; a lexical variable named "fmt".
            (($ <lexical-ref> _ fmt)
             #t)
            ((? (negate const?))
             (warning 'format loc 'non-literal-format-string))))
         (else
          (warning 'format loc 'wrong-num-args (length args)))))

     (define (check-simple-format-args args loc)
       ;; Check the arguments to the `simple-format' procedure, which is
       ;; less capable than that of (ice-9 format).

       (define allowed-chars
         '(#\A #\S #\a #\s #\~ #\%))

       (define (format-chars fmt)
         (let loop ((chars  (string->list fmt))
                    (result '()))
           (match chars
             (()
              (reverse result))
             ((#\~ opt rest ...)
              (loop rest (cons opt result)))
             ((_ rest ...)
              (loop rest result)))))

       (match args
         ((port ($ <const> _ (? string? fmt)) _ ...)
          (let ((opts (format-chars fmt)))
            (or (every (cut memq <> allowed-chars) opts)
                (begin
                  (warning 'format loc 'simple-format fmt
                           (find (negate (cut memq <> allowed-chars)) opts))
                  #f))))
         ((port (= (cut const-fmt <> env) (? string? fmt)) args ...)
          (check-simple-format-args `(,port ,(make-const loc fmt) ,args) loc))
         (_ #t)))

     (define (resolve-toplevel name)
       (and (module? env)
            (false-if-exception (module-ref env name))))

     (match x
       (($ <call> src ($ <toplevel-ref> _ _ name) args)
        (let ((proc (resolve-toplevel name)))
          (if (or (and (eq? proc (@ (guile) simple-format))
                       (check-simple-format-args args
                                                 (or src (find pair? locs))))
                  (eq? proc (@ (ice-9 format) format)))
              (check-format-args args (or src (find pair? locs))))))
       (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
        (check-format-args args (or src (find pair? locs))))
       (($ <call> src ($ <module-ref> _ '(guile)
                         (or 'format 'simple-format))
           args)
        (and (check-simple-format-args args
                                       (or src (find pair? locs)))
             (check-format-args args (or src (find pair? locs)))))
       (_ #t))
     #t)

   (lambda (x _ env locs)
     ;; Up from X.
     #t)

   (lambda (_ env)
     ;; Post-processing.
     #t)

   #t))

(begin-deprecated
 (define-syntax unbound-variable-analysis
   (identifier-syntax
    (begin
      (issue-deprecation-warning
       "`unbound-variable-analysis' is deprecated.  "
       "Use `make-use-before-definition-analysis' instead.")
      (make-use-before-definition-analysis
       #:enabled-warnings '(unbound-variable)))))
 (define-syntax macro-use-before-definition-analysis
   (identifier-syntax
    (begin
      (issue-deprecation-warning
       "`macro-use-before-definition-analysis' is deprecated.  "
       "Use `make-use-before-definition-analysis' instead.")
      (make-use-before-definition-analysis
       #:enabled-warnings '(macro-use-before-definition)))))
 (export unbound-variable-analysis
         macro-use-before-definition-analysis))

(define-syntax-rule (define-analysis make-analysis
                      #:level level #:kind kind #:analysis analysis)
  (define* (make-analysis #:key (warning-level 0) (enabled-warnings '()))
    (and (or (<= level warning-level)
             (memq 'kind enabled-warnings))
         analysis)))

(define-analysis make-unused-variable-analysis
  #:level 3 #:kind unused-variable #:analysis unused-variable-analysis)
(define-analysis make-unused-toplevel-analysis
  #:level 2 #:kind unused-toplevel #:analysis unused-toplevel-analysis)
(define-analysis make-unused-module-analysis
  #:level 2 #:kind unused-module #:analysis unused-module-analysis)
(define-analysis make-shadowed-toplevel-analysis
  #:level 2 #:kind shadowed-toplevel #:analysis shadowed-toplevel-analysis)
(define-analysis make-arity-analysis
  #:level 1 #:kind arity-mismatch #:analysis arity-analysis)
(define-analysis make-format-analysis
  #:level 1 #:kind format #:analysis format-analysis)

(define (make-analyzer warning-level warnings)
  (define-syntax compute-analyses
    (syntax-rules ()
      ((_) '())
      ((_ make-analysis . make-analysis*)
       (let ((tail (compute-analyses . make-analysis*)))
         (match (make-analysis #:warning-level warning-level
                               #:enabled-warnings warnings)
           (#f tail)
           (analysis (cons analysis tail)))))))
  (let ((analyses (compute-analyses make-unused-variable-analysis
                                    make-unused-toplevel-analysis
                                    make-unused-module-analysis
                                    make-shadowed-toplevel-analysis
                                    make-arity-analysis
                                    make-format-analysis
                                    make-use-before-definition-analysis)))
    (lambda (exp env)
      (analyze-tree analyses exp env))))