       "report possibly unbound variables"
            ,(lambda (port loc name)
               (emit port "~A: warning: possibly unbound variable `~A'~%"
                     loc name)))

           (macro-use-before-definition
            "report possibly mis-use of macros before they are defined"
            ,(lambda (port loc name)
               (emit port "~A: warning: macro `~A' used before definition~%"
                     loc name)))

           (arity-mismatch
            "report procedure arity mismatches (wrong number of arguments)"
            ,(lambda (port loc name certain?)
               (if certain?
                   (emit port
                         "~A: warning: wrong number of arguments to `~A'~%"
                         loc name)
                   (emit port
                         "~A: warning: possibly wrong number of arguments to `~A'~%"
                         loc name))))

           (duplicate-case-datum
            "report a duplicate datum in a case expression"
            ,(lambda (port loc datum clause case-expr)
               (emit port
                     "~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%"
                     loc datum clause case-expr)))

           (bad-case-datum
            "report a case datum that cannot be meaningfully compared using `eqv?'"
            ,(lambda (port loc datum clause case-expr)
               (emit port
                     "~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%"
                     loc datum clause case-expr)))

           (format
            "report wrong number of arguments to `format'"
            ,(lambda (port loc . rest)
               (define (escape-newlines str)
                 (list->string
                  (string-fold-right (lambda (c r)
                                       (if (eq? c #\newline)
                                           (append '(#\\ #\n) r)
                                           (cons c r)))
                                     '()
                                     str)))

               (define (range min max)
                 (cond ((eq? min 'any)
                        (if (eq? max 'any)
                            "any number" ;; can't happen
                            (emit #f "up to ~a" max)))
                       ((eq? max 'any)
                        (emit #f "at least ~a" min))
                       ((= min max) (number->string min))
                       (else
                        (emit #f "~a to ~a" min max))))

               (match rest
                 (('simple-format fmt opt)
                  (emit port
                        "~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%"
                        loc (escape-newlines fmt) opt))
                 (('wrong-format-arg-count fmt min max actual)
                  (emit port
                        "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%"
                        loc (escape-newlines fmt)
                        (range min max) actual))
                 (('syntax-error 'unterminated-iteration fmt)
                  (emit port "~A: warning: ~S: unterminated iteration~%"
                        loc (escape-newlines fmt)))
                 (('syntax-error 'unterminated-conditional fmt)
                  (emit port "~A: warning: ~S: unterminated conditional~%"
                        loc (escape-newlines fmt)))
                 (('syntax-error 'unexpected-semicolon fmt)
                  (emit port "~A: warning: ~S: unexpected `~~;'~%"
                        loc (escape-newlines fmt)))
                 (('syntax-error 'unexpected-conditional-termination fmt)
                  (emit port "~A: warning: ~S: unexpected `~~]'~%"
                        loc (escape-newlines fmt)))
                 (('wrong-port wrong-port)
                  (emit port
                        "~A: warning: ~S: wrong port argument~%"
                        loc wrong-port))
                 (('wrong-format-string fmt)
                  (emit port
                        "~A: warning: ~S: wrong format string~%"
                        loc fmt))
                 (('non-literal-format-string)
                  (emit port
                        "~A: warning: non-literal format string~%"
                        loc))
                 (('wrong-num-args count)
                  (emit port
                        "~A: warning: wrong number of arguments to `format'~%"
                        loc))
                 (else
                  (emit port "~A: `format' warning~%" loc)))))))))

(define (lookup-warning-type name)
  "Return the warning type NAME or `#f' if not found."
  (find (lambda (wt)
          (eq? name (warning-type-name wt)))
        %warning-types))

(define (warning type location . args)
  "Emit a warning of type TYPE for source location LOCATION (a source
property alist) using the data in ARGS."
  (let ((wt   (lookup-warning-type type))
        (port (current-warning-port)))
    (if (warning-type? wt)
        (apply (warning-type-printer wt)
               port (location-string location)
               args)
        (format port "~A: unknown warning type `~A': ~A~%"
                (location-string location) type args))))

;;; message.scm ends here
