rg)))))
                (loop (if (pair? (cdr args))
                          (cddr args)
                          '())
                      result)
                (loop (cdr args)
                      (cons arg result)))))))

  (define (arities proc)
    ;; Return the arities of PROC, which can be either a tree-il or a
    ;; procedure.
    (define (len x)
      (or (and (or (null? x) (pair? x))
               (length x))
          0))
    (cond ((program? proc)
           (values (procedure-name proc)
                   (map (lambda (a)
                          (list (length (or (assq-ref a 'required) '()))
                                (length (or (assq-ref a 'optional) '()))
                                (and (assq-ref a 'rest) #t)
                                (map car (or (assq-ref a 'keyword) '()))
                                (assq-ref a 'allow-other-keys?)))
                        (program-arguments-alists proc))))
          ((procedure? proc)
           (if (struct? proc)
               ;; An applicable struct.
               (arities (struct-ref proc 0))
               ;; An applicable smob.
               (let ((arity (procedure-minimum-arity proc)))
                 (values (procedure-name proc)
                         (list (list (car arity) (cadr arity) (caddr arity)
                                     #f #f))))))
          (else
           (let loop ((name    #f)
                      (proc    proc)
                      (arities '()))
             (if (not proc)
                 (values name (reverse arities))
                 (match proc
                   (($ <lambda-case> src req opt rest kw inits gensyms body alt)
                    (loop name alt
                          (cons (list (len req) (len opt) rest
                                      (and (pair? kw) (map car (cdr kw)))
                                      (and (pair? kw) (car kw)))
                                arities)))
                   (($ <lambda> src meta body)
                    (loop (assoc-ref meta 'name) body arities))
                   (_
                    (values #f #f))))))))

  (let ((args (call-args call))
        (src  (tree-il-srcv call)))
    (call-with-values (lambda () (arities proc))
      (lambda (name arities)
        (define matches?
          (find (lambda (arity)
                  (pmatch arity
                    ((,req ,opt ,rest? ,kw ,aok?)
                     (let ((args (if (pair? kw)
                                     (filter-keyword-args kw aok? args)
                                     args)))
                       (if (and req opt)
                           (let ((count (length args)))
                             (and (>= count req)
                                  (or rest?
                                      (<= count (+ req opt)))))
                           #t)))
                    (else #t)))
                arities))

        (if (not matches?)
            (warning 'arity-mismatch src
                     (or name (with-output-to-string (lambda () (write proc))))
                     lexical?)))))
  #t)

(define arity-analysis
  ;; Report arity mismatches in the given tree.
  (make-tree-analysis
   (lambda (x info env locs)
     ;; Down into X.
     (define (extend lexical-name val info)
       ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
       (let ((toplevel-calls   (toplevel-procedure-calls info))
             (lexical-lambdas  (lexical-lambdas info))
             (toplevel-lambdas (toplevel-lambdas info)))
         (match val
           (($ <lambda> src meta body)
            (make-arity-info toplevel-calls
                             (vhash-consq lexical-name val
                                          lexical-lambdas)
                             toplevel-lambdas))
           (($ <lexical-ref> src name gensym)
            ;; lexical alias
            (let ((val* (vhash-assq gensym lexical-lambdas)))
              (if (pair? val*)
                  (extend lexical-name (cdr val*) info)
                  info)))
           (($ <toplevel-ref> src mod name)
            ;; top-level alias
            (make-arity-info toplevel-calls
                             (vhash-consq lexical-name val
                                          lexical-lambdas)
                             toplevel-lambdas))
           (_ info))))

     (let ((toplevel-calls   (toplevel-procedure-calls info))
           (lexical-lambdas  (lexical-lambdas info))
           (toplevel-lambdas (toplevel-lambdas info)))

       (match x
         (($ <toplevel-define> src mod name exp)
          (match exp
            (($ <lambda> src' meta body)
             (make-arity-info toplevel-calls
                              lexical-lambdas
                              (vhash-consq name exp toplevel-lambdas)))
            (($ <toplevel-ref> src' mod name)
             ;; alias for another toplevel
             (let ((proc (vhash-assq name toplevel-lambdas)))
               (make-arity-info toplevel-calls
                                lexical-lambdas
                                (vhash-consq (toplevel-define-name x)
                                             (if (pair? proc)
                                                 (cdr proc)
                                                 exp)
                                             toplevel-lambdas))))
            (_ info)))
         (($ <let> src names gensyms vals)
          (fold extend info gensyms vals))
         (($ <letrec> src in-order? names gensyms vals)
          (fold extend info gensyms vals))
         (($ <fix> src names gensyms vals)
          (fold extend info gensyms vals))

         (($ <call> src proc args)
          (match proc
            (($ <lambda> src' meta body)
             (validate-arity proc x #t)
             info)
            (($ <toplevel-ref> src' mod name)
             (make-arity-info (vhash-consq name x toplevel-calls)
                              lexical-lambdas
                              toplevel-lambdas))
            (($ <lexical-ref> src' name gensym)
             (match (vhash-assq gensym lexical-lambdas)
               ((gensym . ($ <toplevel-ref> src'' mod name'))
                ;; alias to toplevel
                (make-arity-info (vhash-consq name' x toplevel-calls)
                                 lexical-lambdas
                                 toplevel-lambdas))
               ((gensym . proc)
                (validate-arity proc x #t)
                info)
               (#f
                ;; If GENSYM wasn't found, it may be because it's an
                ;; argument of the procedure being compiled.
                info)))
            (_ info)))
         (_ info))))

   (lambda (x info env locs)
     ;; Up from X.
     (define (shrink name val info)
       ;; Remove NAME from the lexical-lambdas of INFO.
       (let ((toplevel-calls   (toplevel-procedure-calls info))
             (lexical-lambdas  (lexical-lambdas info))
             (toplevel-lambdas (toplevel-lambdas info)))
         (make-arity-info toplevel-calls
                          (if (vhash-assq name lexical-lambdas)
                              (vlist-tail lexical-lambdas)
                              lexical-lambdas)
                          toplevel-lambdas)))

     (let ((toplevel-calls   (toplevel-procedure-calls info))
           (lexical-lambdas  (lexical-lambdas info))
           (toplevel-lambdas (toplevel-lambdas info)))
       (match x
         (($ <let> src names gensyms vals)
          (fold shrink info gensyms vals))
         (($ <letrec> src in-order? names gensyms vals)
          (fold shrink info gensyms vals))
         (($ <fix> src names gensyms vals)
          (fold shrink info gensyms vals))

         (_ info))))

   (lambda (result env)
     ;; Post-processing: check all top-level procedure calls that have been
     ;; encountered.
     (let ((toplevel-calls   (toplevel-procedure-calls result))
           (toplevel-lambdas (toplevel-lambdas result)))
       (vlist-for-each
        (lambda (name+call)
          (let* ((name (car name+call))
                 (call (cdr name+call))
                 (proc
                  (or (and=> (vhash-assq name toplevel-lambdas) cdr)
                      (and (module? env)
                           (false-if-exception
                            (module-ref env name)))))
                 (proc*
                  ;; handle toplevel aliases
                  (if (toplevel-ref? proc)
                      (let ((name (toplevel-ref-name proc)))
                        (and (module? env)
                             (false-if-exception
                              (module-ref env name))))
                      proc)))
            (cond ((lambda? proc*)
                   (validate-arity proc* call #t))
                  ((procedure? proc*)
                   (validate-arity proc* call #f)))))
        toplevel-calls)))

   (make-arity-info vlist-null vlist-null vlist-null)))