(in-package "C")

(defun print-error-message (what condition)
  (declare (type (member :error :warning :note) what)
	   (type condition condition))
  (let ((*print-level* (or *error-print-level* *print-level*))
	(*print-length* (or *error-print-length* *print-length*))
	(*print-lines* (or *error-print-lines* *print-lines*)))
    (multiple-value-bind
          (format-string format-args)
	(if (typep condition 'simple-condition)
	    (values (simple-condition-format-control condition)
		    (simple-condition-format-arguments condition))
	    (values (with-output-to-string (s)
		      (princ condition s))
		    ()))
      (let ((stream *compiler-error-output*)
	    (context (find-error-context format-args)))
	(cond
          (context
           (let ((file (compiler-error-context-file-name context))
                 (in (compiler-error-context-context context))
                 (form (compiler-error-context-original-source context))
                 (enclosing (compiler-error-context-enclosing-source context))
                 (source (compiler-error-context-source context))
                 (last *last-error-context*))
             (compiler-notification what context)

             (unless (and last
                          (equal file (compiler-error-context-file-name last)))
               (when (pathnamep file)
                 (note-message-repeats)
                 (setq last nil)
                 (format stream "~2&File: ~A~%" (namestring file))))
	    
             (unless (and last
                          (equal in (compiler-error-context-context last)))
               (note-message-repeats)
               (setq last nil)
               (format stream "bold~2&~{~<~%   ~4:;~{ ~S~}~>~^ =>~}pop" in))
	    
             (unless (and last
                          (string= form
                                   (compiler-error-context-original-source last)))
               (note-message-repeats)
               (setq last nil)
               '(write-string form stream))
	    
             (unless (and last
                          (equal enclosing
                                 (compiler-error-context-enclosing-source last)))
               (when enclosing
                 (note-message-repeats)
                 (setq last nil)
                 '(format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
	    
             (unless (and last
                          nil (equal source (compiler-error-context-source last)))
               (setq *last-format-string* nil)
               (when source
                 (note-message-repeats)
                 '(dolist (src source)
                   (write-line "==>" stream)
                   (write-string src stream))))))
          (t
           (compiler-notification what nil)
           (note-message-repeats)
           (setq *last-format-string* nil)
           (format stream "~2&")))

        (setq *last-error-context* context)
    
        (unless (and (equal format-string *last-format-string*)
                     (tree-equal format-args *last-format-args*))
          (note-message-repeats nil)
          (setq *last-format-string* format-string)
          (setq *last-format-args* format-args)
          (fresh-line stream)
          (pprint-logical-block
           (stream nil :per-line-prefix "    ")
           ;;
           (let ((*print-lines* nil)
                 (*print-length* nil)
                 (*print-pretty* nil))
             (write-string
              (format nil "(~A mouse-face isearch emacs-command ~A)"
                      (case what
                        (:note "blue")
                        (:warning "blue")
                        (:error "red"))
                      (and context
                           (let ((*print-length* nil))
                             (format nil "(gb/visit ~S ~D ~('~D~))"
                                     (ignore-errors (namestring (compiler-error-context-file-name context)))
                                     (compiler-error-context-file-position context)
                                     (butlast (compiler-error-context-original-source-path context))))))
              stream))
           ;;
           (format stream "~:(~A~): ~?"
                   what format-string format-args)
           (let ((*print-lines* nil)
                 (*print-length* nil)
                 (*print-pretty* nil))
             (write-string "pop" stream))
           ) ))))
                                
  (incf *last-message-count*)
  (undefined-value))