;;;; Run commands asynchronously and parse error messages.
;;;;
;;;; Distributed with compile2 version 2.07
;;;; Copyright Nick Duffek, 1993
;;;;
;;;; This file is not part of GNU Emacs.  However, the following applies as
;;;; if it were:
;;;;
;;;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT
;;;; ANY WARRANTY.  No author or distributor accepts responsibility to anyone
;;;; for the consequences of using it or for whether it serves any particular
;;;; purpose or works at all, unless he says so in writing.  Refer to the GNU
;;;; Emacs General Public License for full details.
;;;;
;;;; Everyone is granted permission to copy, modify and redistribute GNU
;;;; Emacs, but only under the conditions described in the GNU Emacs General
;;;; Public License.  A copy of this license is supposed to have been given
;;;; to you along with GNU Emacs so you can know your rights and
;;;; responsibilities.  It should be in a file named COPYING.  Among other
;;;; things, the copyright notice and this notice must be preserved on all
;;;; copies.
;;;;
;;;;===========================================================================
;;;;
;;;; Drop-in replacement for the Emacs distribution's compile.el.

;;; Notes to coders
;;; ---------------
;;;
;;; - Most functions in this file use macros that declare-object defines on
;;;   the fly and that only exist either while byte-compiling or after
;;;   evaluating the entire file.  So, evaluating the whole file before
;;;   calling a function you've changed avoids "Symbol's function definition
;;;   is void" errors.
;;;
;;;   Most names with the form c2-NAME-FIELD and c2-set-NAME-FIELD are macros
;;;   that declare-object generates.
;;;
;;; - Public identifiers almost always begin with compile-, and private ones
;;;   with c2-.

(require 'declare-object)
(require 'hlist)
(require 'command-window)
(require 'generic-filter)
(require 'request-directory)
(require 'window-manip-fns)

;;; User-configurable variables

(defvar compile-window-height-hook
  (function (lambda ()
	      "Eight lines or one-fifth screen height, whichever is larger."
	      (max 8 (/ (screen-height) 5))))
  "*Function which returns suggested height of compilation window.")

(defvar compile-mode-line-format
  (function (lambda (n)
	      (format "  %d Compilation%s " n (if (> n 1) "s" ""))))
  "*Function that returns a string to display in the mode line when the
number of active compilations N is greater than zero.")

(defvar compile-lines-above-current-err 1
  "*Number of lines left visible above current error in compilation window.")

(defvar compile-mrkr-overlay-text ">"
  "*String to overlay in compilation buffer at current compilation error
\(nil for none\).")

(defvar compile-message-indent 2
  "*Number of columns to indent messages compile2 successfully parses.")

(defvar compile-grep-command "egrep"
  "*Program the grep \(\\[grep]\) command runs.")

(defvar compile-ignore-grep-window t
  "*Non-nil suppresses grep window display when jumping to grep hits via
\\[compile-next-error], \\[compile-previous-error], or
\\[compile-current-error].  Non-t also suppresses display when invoking
grep.")

(defvar compile-command-initial-input nil
  "*Non-nil means \\[compile] from a non-compilation buffer inserts the value
of compile-command in the minibuffer before reading a new command, and from a
compilation buffer inserts that compilation's command.")

(defvar compile-command "make -k"
  "*Last compilation command; default for next compilation.")

(defvar compile-save-buffers t
  "*t unconditionally saves all modified buffers before \\[compile]
\(compile\) or \\[grep] \(grep\), non-t and non-nil asks before saving each
buffer, nil saves no buffers.")

(defvar compile-buffer-name-prefix nil
  "*String, for example \"*\", to prepend to the names of compile buffers to
differentiate them from ordinary buffers.")

(defvar compile-silently-favor-cwd nil
  "*Tells \\[compile] \(compile\) and \\[grep] \\(grep\\) whether to silently
favor a compilation with the current buffer's directory even when a
compilation with the same name already exists in a different directory:
 - nil means always ask for confirmation before using the current buffer's
   directory instead of the most recent matching compilation's
 - non-nil and non-t means don't ask for confirmation if a compilation with
   the same name in the current directory already exists
 - t means always use the current directory without asking for confirmation")

(defvar compile-recycle-buffer-threshold nil
  "*Number of compilation buffers to create before recycling finished
compilation buffers.  Nil inhibits buffer recycling.")

(defvar compile-display-if-none-visited t
  "*Non-nil tells \\[compile-current-error] \(current error\) \(and
\\[compile-next-error] \(next error\) with prefix arg 0\) to display the
compilation buffer if no errors in the current compilation have been visited
yet.")

(defvar compile-bind-to-db-regex "make\\>\\|cc\\>"
  "*Regex matching substrings in commands of compilations which should be
bound to the current db debugging session \(if any\).")

(defvar compile-filename-filter nil
  "*If non-nil, function that modifies FILENAME, from error message parsed by
compilation process, before the process loads the file with that name. 
Function need not save and restore match-data.

Local within compilation buffers.")

(defvar compile-dont-parse nil
  "*Non-nil means don't parse compilation process output.  Useful for
repeatedly testing programs whose output coincidentally looks like error
messages to compile.

Local within compilation buffers.")

(defvar compile-marking-inform-threshold 500
  "*Display informational message when generating markers for files with this
many or more errors.")

(defvar compile-start-hook nil
  "*List of functions to call just after a compilation process starts.")

(defvar compile-exit-hook nil
  "*List of functions to call just after a compilation process exits.")

(defvar compile-search-dirs '(("." 1))
  "*List of \(DIRECTORY DEPTH\) pairs, where DIRECTORY is a directory to
breadth-first search when unable to find an error message's file, and DEPTH
is the maximum number of DIRECTORY's subdirectories to search.

Zero DEPTH searches DIRECTORY but none of its subdirectories, and nonnumeric
DEPTH searches subdirectories with no depth limit.

Local within compilation buffers.")

;;; Parsing table and associated code adapted from mult-compile.el written by
;;; wolfgang@wsrc2.com (Wolfgang S. Rupprecht).

(defvar compile-error-parse-regexps
  (`
   (;;
    ;; rule 0 -- line LINE of "FILE"
    ;;
    ;; 'line 18 of "foo.c": i undefined' (4.3bsd compiler)
    ;; 'byacc: e - line 94 of "cpp.y", $5 (sc_args) untyped' (berkeley yacc)
    ;;
    (".*line \\([0-9]+\\) of \"\\([^\"\n]+\\)\"[:,]" 2 1)
    ;;
    ;; rule 1 -- "FILE", line LINE
    ;;
    ;; 'cc: "mode.h", line 78: warning 546: Enumeration type clash.' (hpux)
    ;; '"spl.i" line 23,  Error:  syntax error.' (unknown)
    ;; '(as) "spl.i", line 23:  Error:  syntax error.' (unknown)
    ;; '"./foo.h", line 128: redeclaration of bar' (unknown)
    ;; 'f682: "/usr/include/errno.h", line 15: Error: ...' (Glockenspiel C++
    ;;    compiler 2.0 -- Amir J. Katz)
    ;;
    ((, (concat "\\(cc: \\|f...: \\|(.+)[ \t]+\\)?"
		"\"\\([^\"\n]+\\)\" ?,?[ \t]+"
		"line[ \t]+\\([0-9]+\\)")) 2 3)
    ;;
    ;; rule 2 -- "FILE" LINE,COLUMN:
    ;;
    ;; 'lout "t.lout" 35,5: symbol @RawTaggedList unknown or misspelt' (lout)
    ("lout \"\\([^\n\"]+\\)\" \\([0-9]+\\),[0-9]+" 1 2)
    ;;
    ;; rule 3 -- file FILE at line LINE
    ;;
    ;; 'syntax error in file x.pl at line 2, next token "@Includes"' (perl)
    ;;
    (".* in file \\([^ ]+\\) at line \\([0-9]+\\)," 1 2)
    ;;
    ;; rule 4 -- FILE: .* at line LINE:
    ;;
    ;; './uugo: syntax error at line 5: `newline or ;' unexpected' (/bin/sh)
    ;;
    ("\\([^:\n]+\\):.* at line \\([0-9]+\\):" 1 2)
    ;;
    ;; rule 5 -- at FILE line LINE
    ;;
    ;; 'Possible typo: "a" at t.pl line 8.' (perl -w)
    ;;
    (".* at \\([^ \n]+\\) line \\([0-9]+\\)" 1 2)
    ;;
    ;; rule 6 -- FILE, line LINE:
    ;;
    ;; 'devl.cob, line 13: Compilation abort' (accucobl -- Allan Johannesen)
    ;; 'fort: Severe: foo.f, line 2: Missing op' (Ultrix C -- also A.J.)
    ;;
    ("\\(.* \\)?\\([^ \n,]+\\), line \\([0-9]+\\): " 2 3)
    ;;
    ;; rule 7 -- FILE:LINE:
    ;;
    ;; 'x.c:19: parse error before `char'' (GNU software)
    ;; 'p_slip.c:277 (p_slip.o): Undefined symbol' (GNU ld)
    ;;
    ("\\([^ :\n]+\\):\\([0-9]+\\)\\( ([^ \n\)]+)\\)?:" 1 2)
    ;;
    ;; rule 7.5 -- FILE: LINE: TEXT (HP-UX cc compiler)
    ;;
    ("\\(^[a-zA-Z0-9\\._]+\\) :\\([0-9]+\\):" 1 2)
    ;;
    ;; rule 8 -- FILE(LINE)
    ;;
    ;; 'rand   llib-lc(345) :: uuq.c?(73)' (sysV lint -- kamat@uceng.uc.edu)
    ;; 'rcmd         cico.c?(243)' (sysV)
    ;; 'foo.c(8): warning: w may be used before set' (4.3bsd grep, compile,
    ;;    lint part 1)
    ;; 'strcmp: variable # of args.      llib-lc(359)  ::  foo.c(8)' (4.3bsd
    ;;    lint part 2)
    ;; 'i defined( foo.c(4) ), but never used' (4.3bsd lint part 3)
    ;; 'i used( foo.c(144) ), but not defined' (4.3bsd lint part 3)
    ;;
    (".*\\(^\\| \\)\\([^( ?\n]+\\)\\??(\\([0-9]+\\))" 2 3)
    ;;
    ;; rule 9 -- make -f FILE \n+ line LINE
    ;; 'Make: line 20: syntax error.  Stop.' (Make)
    ;; 'Make: Must be a separator on rules line 84.  Stop.' (Make)
    ;;
    ("[\* \t]*make: [^\n]*line[ \t]+\\([0-9]+\\)[.:]" scan-make 1)
    ;;
    ;; rule 10 -- FILE \n+ (LINE)
    ;;
    ;; 'cico.c
    ;;  ==============
    ;;  (88)  warning: alias unused in function main
    ;;  (656)  warning: main() returns random value to invocation environment
    ;;  cntrl.c:
    ;;
    ;;  uucpd.c
    ;;  ==============
    ;;  warning: argument unused in function:
    ;;      (48)  argc in main
    ;;  warning: possible pointer alignment problem
    ;;      (145)            (246)           (329)  
    ;;      (367)' (sysV lint)
    ;;
    ;; Note:  This regexp has to be incredibly weak.  There just isn't much
    ;; to get a toe-hold on here.  Better keep this one on the end. -wsr
    ;;
    ("[ \t]*(\\([0-9]+\\))[ \t]" scan-s5lint 1)
    ;;
    ;; Add other rules and explanations before the preceding rule.
    ))
  "*A list of lists consisting of
\(\(rexexp filename-match-index line1-match-index\)\(...\)\(...\)\)
for parsing error messages.

Guidelines for adding regular expressions:
 - Regular expressions only match text at the beginning of a line, so prefix
   \".*\" to expressions intended to match beyond beginning-of-line.
 - For the same reason, \"^\" at the start of an expression is redundant, and
   should be omitted.
 - Always include \\n inside square-bracketed character ranges, to avoid
   confusing the parsing mechanism by matching beyond end-of-line.
 - If possible, modify an existing expression that almost performs the
   appropriate matches rather than creating a new one.
 - Position new regular expressions later in the list than more rigid regular
   expressions -- ones less prone to spurious matches -- and earlier than
   less rigid ones.
 - To include your modifications in the next release, please email them to
   the author, Nick Duffek, at nsd@nsd.bbc.com.
 - Function c2-test-parse may be helpful.")

;;; Non-user-configurable variables:

(defconst c2-previous-version (and (boundp 'c2-version) c2-version)
  "Version of compile2 package that was active before most recent load.")

(defconst c2-version "2.07"
  "Current version number of compile2 package.")

(defvar c2-cns nil
  "Hlist of compilations.")

(defvar c2-global-buf-cache nil
  "Global cache that associates files found by scanning the filesystem to
their buffers.")

;; Keep ignore files separate from buffer cache just for simplicity and
;; clarity: global buffer cache maps names and search contexts to buffers,
;; and ignore-files list maps names to flags.

(defvar c2-global-ignore-files nil
  "Hlist of files to ignore in compilation error messages.")

(defvar c2-buffer-to-cn-map nil
  "Mapping from compilation buffers to their compilations.")

(defvar c2-buffer-to-ferrlists-map nil
  "Mapping from buffers to compilation-specific lists of errors in those
buffers' files.")

(defvar compile-mode-line-compilations nil
  "Mode-line control for displaying number of active compilation processes.
Nil when no compilations are active.")

(defvar c2-nr-active-compilations 0
  "Number of active compilation processes.  Used for updating
global-mode-string.")

(defconst c2-huge-pos-int (ash 1 22)
  "Huge positive integer.")
(defconst c2-huge-neg-int (- c2-huge-pos-int)
  "Huge negative integer.")

;;; End of variables section

;;; Define maps between arbitrary objects.

(defun c2-map-create ()
  "Create and return a new map."
  (hlist-create nil))

(defun c2-map-insert (map key val)
  "In MAP associate KEY with VAL."
  (hlist-insert map (cons key val)))

(defun c2-map-lookup (map key)
  "Return value associated in MAP associate with KEY."
  (let ((key-val (hlist-find map (function (lambda (key-val)
					     (eq (car key-val) key))))))
    (and key-val (cdr key-val))))

(defun c2-map-delete (map key)
  "In MAP unassociate KEY with any value."
  (hlist-delete map (function (lambda (key-val) (eq (car key-val) key)))))

(defun c2-map-map (fxn map)
  "Apply FUNCTION to each element in MAP.  FUNCTION accepts two arguments, a
key and its corresponding value.  Return nil."
  ;;
  ;; Name first arg FXN instead of FN because hlist-map has a local variable
  ;; called FN which would occlude the FN in this lexical scope.
  ;;
  ;; I wish elisp would scope lexically instead of dynamically.
  ;;
  (hlist-map (function (lambda (key-val)
			 (apply fxn (car key-val) (cdr key-val) nil)))
	     map))

;;; New compile2 versions may change object definitions, so reinitialize
;;; global structures when loading a new version to prevent new object macros
;;; from incorrectly accessing old objects.

(or (and c2-previous-version (string= c2-previous-version c2-version))
    (setq c2-cns (hlist-create nil)
	  c2-global-buf-cache (make-vector 101 nil)
	  c2-global-ignore-files (hlist-create nil)
	  c2-buffer-to-cn-map (c2-map-create)
	  c2-buffer-to-ferrlists-map (c2-map-create)))

(or global-mode-string (setq global-mode-string '("")))
(or (memq 'compile-mode-line-compilations global-mode-string)
    (setq global-mode-string
	  (nconc global-mode-string '(compile-mode-line-compilations))))

;; Define objects on the fly at compile-time.  Changing their definitions may
;; require resetting c2-cns to (hlist-create nil) to prevent new object
;; macros from incorrectly accessing old objects.

(eval-when-compile
  ;; compilation object
  (declare-object 'c2 'cn
    '(command msg-descrip process buffer db-sn killed-db-sn errs indents
	      beyond-last-err output-begin output-end files-hashtable
	      buf-cache ignore-files current-mrkr no-errs-seen-yet save-first
	      ignore-window can-compile-again name-of-mode user-aware-of-errs
	      recyclable))
  
  ;; error object
  (declare-object 'c2 'err
    '(files lines mrkrs cn-mrkr))
  
  ;; objects to which c2-global-buf-cache associates files
  (declare-object 'c2 'fscached
    '(buffer directory search-dirs))

  ;; compilation- and file-specific list of errors
  (declare-object 'c2 'ferrlist
    '(reverted ignore-modtime errs buf)))

;; Prevent compiler complaints that hooks into debugger package are not known
;; to be defined:
(eval-when-compile
  (mapcar (function (lambda (fn) (or (fboundp fn) (fset fn nil))))
	  '(db-c2-sn-is-alive db-quit-sn db-restart-sn db-current-sn
			      db-c2-sn-cn db-c2-set-sn-cn)))

(defmacro c2-buffer-killed-p (buffer)
  "Return whether BUFFER has been killed."
  (` (null (buffer-name (, buffer)))))

(defun c2-make-cn-current (cn)
  "Make CN be the current compilation."
  (hlist-insert c2-cns cn 'no-duplicates))

(defsubst c2-get-buffer-cn (buffer)
  "Return cn associated with BUFFER, or nil if none."
  (c2-map-lookup c2-buffer-to-cn-map buffer))

(defsubst c2-current-cn (&optional noerr)
  "Return the current buffer's compilation if it has one, otherwise return
the most recently accessed compilation.  Optional argument NOERR non-nil
means just return nil without error if there are no compilations."
  (c2-expunge-killed-cns)
  (let ((cn (or (c2-get-buffer-cn (current-buffer))
		(hlist-first c2-cns))))
    (if (not cn)
	(or noerr (error "No compilations currently exist"))
      (c2-make-cn-current cn))
    cn))

(defsubst c2-process-is-alive (process)
  "Return t if PROCESS' status is 'stop or 'run, nil otherwise."
  (or (eq (process-status process) 'stop)
      (eq (process-status process) 'run)))

(defun c2-get-cn-by-name (command)
  "Retrieve cn named COMMAND."
  ;; Can't simply find buffer named COMMAND and call c2-get-buffer-cn
  ;; because buffer name could have "<n>" appended (e.g., if another buffer
  ;; named COMMAND existed prior to cn's creation).
  (hlist-find c2-cns
	      (function (lambda (cn)
			  (string= (c2-cn-command cn) command)))))

(defmacro c2-get-cn-directory (cn)
  "Return COMPILATION's directory."
  (` (save-excursion
       (set-buffer (c2-cn-buffer (, cn)))
       default-directory)))

(defun c2-get-cn-by-name-and-directory (command directory)
  "Retrieve cn named COMMAND with directory DIRECTORY."
  (hlist-find c2-cns
	      (function
	       (lambda (cn)
		 (and (string= (c2-cn-command cn) command)
		      (string= (c2-get-cn-directory cn) directory))))))

(defun c2-recycle-buffers ()
  "Delete as many recyclable inactive compilation buffers as necessary to
reduce the total number to one less than compile-recycle-buffer-threshold,
starting with the oldest compilations."
  ;; Caller's caller called c2-expunge-killed-cns already.
  ;;
  ;; Slightly inefficient because (hlist-length c2-cns) can be greater than
  ;; the number of recyclable buffers when user has parsed output in regular
  ;; (not compilation) buffer.  Solution of keeping recyclable and
  ;; nonrecyclable compilations in separate lists doesn't seem worth the
  ;; extra complication.
  
  (let ((excess (- (hlist-length c2-cns)
		   (1- compile-recycle-buffer-threshold))))
    (and (> excess 0)
	 (hlist-map-reverse
	  (function (lambda (cn)
		      (and (> excess 0)
			   (not (and (c2-cn-process cn)
				     (c2-process-is-alive (c2-cn-process cn))))
			   (progn
			     (setq excess (1- excess))
			     (and (c2-cn-recyclable cn)
				  ;; Killing buffer will eventually trigger
				  ;; appropriate cleanup via
				  ;; expunge-killed-cns.
				  (kill-buffer (c2-cn-buffer cn)))))))
	  c2-cns))))

(defun c2-new-cn (command directory msg-descrip ignore-window
			  can-compile-again name-of-mode save-first
			  inhibit-recycle buffer recyclable)
  "Create, initialize, and return a new compilation with invocation string
COMMAND."
  (and (not inhibit-recycle)
       (not buffer)
       (integerp compile-recycle-buffer-threshold)
       (c2-recycle-buffers))
  
  (let ((cn (c2-create-cn)))
    (or buffer
	(setq buffer (generate-new-buffer
		      (concat (or compile-buffer-name-prefix "") command))))
    (c2-set-cn-command cn command)
    (c2-set-cn-buffer cn buffer)
    (save-excursion (set-buffer buffer) (setq default-directory directory))
    (c2-set-cn-errs cn (hlist-create nil))
    (c2-set-cn-files-hashtable cn (make-vector 101 nil))
    (c2-set-cn-ignore-files cn (hlist-create nil))
    (c2-set-cn-beyond-last-err cn (make-marker))
    (c2-set-cn-output-begin cn (make-marker))
    (c2-set-cn-output-end cn (make-marker))
    
    (c2-set-cn-msg-descrip cn (or msg-descrip "error"))
    (c2-set-cn-ignore-window cn ignore-window)
    (c2-set-cn-can-compile-again cn can-compile-again)
    (c2-set-cn-name-of-mode cn name-of-mode)
    ;; for use by compile-again:
    (c2-set-cn-save-first cn save-first)
    (c2-set-cn-recyclable cn recyclable)
    
    (c2-map-insert c2-buffer-to-cn-map buffer cn)
    
    cn))

(defun c2-truncate-name (name len)
  "If NAME's length exceeds LEN, truncate it to LEN and append an ellipsis."
  (if (> (length name) len)
      (concat (substring name 0 len) "...")
    name))

(defun c2-breadth-first-search (file dir depth)
  "Perform a breadth-first search for FILE in DIRECTORY, descending at most
DEPTH directories below DIRECTORY.  Zero DEPTH searches DIRECTORY but none of
its subdirectories, and nonnumeric DEPTH searches subdirectories to arbitrary
depth.

Return FILE's full path, or nil on failure to locate FILE."
  (let ((dirs (list (expand-file-name dir)))
	(continue t)
	(path nil))
    (while continue
      
      ;; Look for FILE in each directory in DIRS
      (mapcar (function
	       (lambda (dir)
		 (let ((default-directory dir))
		   (or path (and (file-exists-p file)
				 (setq path (expand-file-name file)))))))
	      dirs)
      
      (if (or path (and (integerp depth)
			(progn (setq depth (1- depth))
			       (< depth 0))))
	  (setq continue nil)
	
	;; Collect directories one level down into DIRS
	(let ((parents dirs))
	  (setq dirs nil)
	  (mapcar
	   (function
	    (lambda (parent)
	      (condition-case nil
		  (let ((files (directory-files parent))
			(default-directory parent))
		    (mapcar
		     (function
		      (lambda (file)
			(and (file-directory-p file)
			     (not (string= "." file))
			     (not (string= ".." file))
			     (setq dirs (cons (expand-file-name file) dirs)))))
		     files))
		(file-error nil))))
	   parents))
	
	(or dirs (setq continue nil))))
    
    path))

(defsubst c2-ignoring-file (file ignore-files-table)
  "Return whether FILE is in IGNORE-FILES-TABLE."
  (and (not (hlist-emptyp ignore-files-table))
       (hlist-find ignore-files-table
		   (function (lambda (f) (string= f file))))))

(defsubst c2-ignoring-file-locally (file cn)
  "Return whether references to FILE in COMPILATION's error messages are
ignored."
  (c2-ignoring-file file (c2-cn-ignore-files cn)))

(defsubst c2-ignoring-file-globally (file)
  "Return whether references to FILE in compilation error messages are
globally ignored."
  (c2-ignoring-file file c2-global-ignore-files))

(defsubst c2-ignore-file (file ignore-files-table)
  "Add FILE to IGNORE-FILES-TABLE."
  (hlist-insert ignore-files-table file))

(defsubst c2-ignore-file-locally (file cn)
  "Ignore references to FILE in COMPILATION's error messages."
  (c2-ignore-file file (c2-cn-ignore-files cn)))

(defsubst c2-ignore-file-globally (file)
  "Globally ignore references to FILE in compilation error messages."
  (c2-ignore-file file c2-global-ignore-files))

(defsubst c2-unignore-file (file ignore-files-table)
  "Remove FILE from IGNORE-FILES-TABLE."
  (hlist-delete ignore-files-table (function (lambda (f) (string= f file)))))

(defsubst c2-unignore-file-locally (file cn)
  "Stop ignoring references to FILE in COMPILATION's error messages."
  (c2-unignore-file file (c2-cn-ignore-files cn)))

(defsubst c2-unignore-file-globally (file)
  "Stop globally ignoring references to FILE in compilation error messages."
  (c2-unignore-file file c2-global-ignore-files))

(defun c2-read-err-file (prompt)
  "Read file name as a string from minibuffer, prompting with PROMPT and
defaulting to the first file of the error at point in the current
compilation's buffer."
  (let* ((cn (c2-current-cn))
	 (err-at-point (and cn (c2-possible-err-near-point cn nil)))
	 (default (and err-at-point (car (c2-err-files err-at-point))))
	 file)
    (and compile-filename-filter
	 (setq default (apply compile-filename-filter default nil)))
    (setq file
	  (read-string
	   (concat prompt (if default (format "(default %s) " default) ""))))
    (if (string= file "") default file)))

(defun compile-ignore-file (file &optional unignore)
  "Ignore references to FILE in compilation error messages.  Prefix-arg
non-nil stops ignoring references to FILE."
  (interactive
   (let* ((unignore current-prefix-arg)
	  (file (c2-read-err-file
		 (format "%s file: " (if unignore "Stop ignoring" "Ignore")))))
     (list file unignore)))
  (let ((cn (c2-current-cn)))
    (if unignore
	(cond ((c2-ignoring-file-locally file cn)
	       (c2-unignore-file-locally file cn)
	       (message "No longer ignoring %s in %s"
			file (buffer-name (c2-cn-buffer cn))))
	      ((c2-ignoring-file-globally file)
	       (c2-unignore-file-globally file)
	       (message "No longer globally ignoring %s" file))
	      (t
	       (error "Wasn't ignoring %s" file)))
      (cond ((y-or-n-p "Ignore file in all compilations? ")
	     (c2-ignore-file-globally file))
	    ((y-or-n-p "Ignore in current compilation only? ")
	     (c2-ignore-file-locally file cn))
	    (t
	     (error "Not ignoring file"))))))

;; Kludge alert!!!

;; There seems to be no sanctioned method for compiling code generated on the
;; fly during compilation.  However, the following seems to work: within an
;; eval-when-compile form, insert the code at the end of the current buffer,
;; which happens to be the " *Compiler Input*" buffer.

;; Here's the version of eval-then-compile for use during compilation:
(eval-when-compile
  (defmacro eval-then-compile (form)
    "Evaluate FORM, then compile or evaluate the result respectively during
compilation or evaluation."
    (` (eval-when-compile
	 (save-excursion
	   (goto-char (point-max))
	   (insert (prin1-to-string (, form))))))))

;; ...and here's the version for use during normal evaluation:
(eval '(defmacro eval-then-compile (form)
	 "Evaluate FORM, then compile or evaluate the result respectively
during compilation or evaluation."
	 (eval (, form))))

;; Modify revert-buffer to set the reverted flags of all file error lists
;; bound to the current buffer.  Thanks to ange-ftp for the original idea and
;; part of the implementation of modifying functions.
(eval-then-compile
  (` (defun c2-revert-buffer (&rest args)
       (, (concat (documentation 'revert-buffer)
		  "
--
Note:  This function has been modified to work with compile2."))
       (interactive)
       (let ((val (apply c2-orig-revert-buffer args))
	     (ferrlists (c2-map-lookup c2-buffer-to-ferrlists-map
				       (current-buffer))))
	 (and ferrlists
	      (hlist-map
	       (function (lambda (ferrlist)
			   (c2-set-ferrlist-ignore-modtime ferrlist nil)
			   (c2-set-ferrlist-reverted ferrlist t)))
	       ferrlists))
	 val))))

;; Redefine revert-buffer during first load only to avoid stacking calls to
;; c2-revert-buffer.

;; Bind revert-buffer to c2-revert-buffer's symbol rather than its function
;; definition to allow redefining c2-revert-buffer later in the same Emacs
;; session without searching through revert-buffer's function chain for the
;; old definition.

(defvar c2-orig-revert-buffer nil
  "Function bound to revert-buffer before loading compile2.")

(or c2-orig-revert-buffer
    (progn (setq c2-orig-revert-buffer (symbol-function 'revert-buffer))
	   (fset 'revert-buffer 'c2-revert-buffer)))

(defun c2-expunge-global-buf-cache ()
  "Remove references to killed buffers from global buffer cache."
  ;; Discards references that would otherwise survive until Emacs terminates.
  (mapatoms
   (function (lambda (sym)
	       (let ((found-killed nil))
		 (mapcar
		  (function (lambda (fscached)
			      (and (c2-buffer-killed-p
				    (c2-fscached-buffer fscached))
				   (setq found-killed t))))
		  (symbol-plist sym))
		 (and found-killed
		      (let ((expunged nil))
			(mapcar
			 (function (lambda (fscached)
				     (or (c2-buffer-killed-p
					  (c2-fscached-buffer fscached))
					 (setq expunged (cons fscached
							      expunged)))))
			 (symbol-plist sym))
			(setplist sym expunged))))))
   c2-global-buf-cache))

(defun c2-find-file-noselect (file cn ferrlist)
  "Return but do not select a buffer on FILE, which COMPILATION's FERRLIST
contains, or nil if FILE should be ignored or cannot be found.

First look in the current directory, then search directories in
compile-search-dirs, and finally ask the user where the file exists."

  ;; FILE is always whatever the error message parser extracted.
  ;;
  ;; To avoid time-consuming filesystem searches and redundant interactive
  ;; queries each time the user jumps to an error,
  ;;  - associate in global c2-global-buf-cache each successful {FILE,
  ;;    default-directory, compile-search-dirs ambient value} search context
  ;;    to its resulting buffer
  ;;  - associate in compilation-local c2-cn-buf-cache each successful user
  ;;    query context to its resulting buffer
  ;;
  ;; Cache filesystem searches globally because the search results for a
  ;; given {FILE, default-directory, compile-search-dirs ambient value}
  ;; search context are independent of which compilation invoked the search.
  ;;
  ;; Query results may differ depending on the compilation that invokes the
  ;; query, however, so cache them locally to each compilation.
  ;;
  ;; Associating FILE to its buffer rather than to its full path gives the
  ;; user a way to force a re-search, by simply killing FILE's buffer.

  ;; Use buffer-local values of compile-filename-filter and
  ;; compile-search-dirs:
  (save-excursion
    (set-buffer (c2-cn-buffer cn))
    
    (and compile-filename-filter
	 (setq file (apply compile-filename-filter file nil)))
    
    (let ((buf
	   
	   ;; First, check whether ignoring file.  Would check
	   ;; compile-ignore-file-regexp here.
	   (if (or (c2-ignoring-file-locally file cn)
		   (c2-ignoring-file-globally file))
	       nil
	     
	     (or
	      
	      ;; Second, look in compilation-local cache
	      (let* ((name-and-buf (assoc file (c2-cn-buf-cache cn)))
		     (buf (and name-and-buf (cdr name-and-buf))))
		(and buf (not (c2-buffer-killed-p buf))
		     buf))
	      
	      ;; Third, look in global cache
	      (let ((buf nil))
		(mapcar
		 (function (lambda (fscached)
			     (and (string= (c2-fscached-directory fscached)
					   default-directory)
				  (eq (c2-fscached-search-dirs fscached)
				      compile-search-dirs)
				  (not buf)
				  (not (c2-buffer-killed-p
					(c2-fscached-buffer fscached)))
				  (setq buf (c2-fscached-buffer fscached)))))
		 (symbol-plist (intern file c2-global-buf-cache)))
		buf)
	      
	      ;; Remaining methods try to get buffer via full path
	      (let* ((path
		      
		      ;; Fourth, search filesystem
		      (cond ((file-exists-p file) file)
			    ((file-name-absolute-p file) nil)
			    
			    ;; search compile-search-dirs
			    (t (message "Searching for %s..." file)
			       (let ((path nil)
				     (dirs compile-search-dirs))
				 (while (and dirs (null path))
				   (let* ((search-dir (car dirs))
					  (dir (nth 0 search-dir))
					  (depth (nth 1 search-dir)))
				     (setq dirs (cdr dirs)
					   path (c2-breadth-first-search
						 file dir depth))))
				 (message "Searching for %s...%s" file
					  (if path "done" "failed"))
				 path))))
		     
		     (found-via-search (not (null path))))
		
		;; Fifth and last, query user
		(or found-via-search
		    (setq path
			  (cond
			   ((y-or-n-p (format "\
Cannot find %s.  Ignore in all compilations? " file))
			    
			    (c2-ignore-file-globally file)
			    nil)
			   
			   ((y-or-n-p "Ignore in current compilation only? ")
			    (c2-ignore-file-locally file cn)
			    nil)
			   
			   (t (read-file-name (format "Path to %s: " file)
					      default-directory nil t)))))
		
		(and path
		     (let ((buf (or (get-file-buffer path)
				    (find-file-noselect path))))
		       
		       ;; Store buffer in cache
		       (if (not found-via-search)
			   ;; cache locally
			   (c2-set-cn-buf-cache cn (cons (cons file buf)
							 (c2-cn-buf-cache cn)))
			 ;; cache globally.  Ought to expunge table entries
			 ;; containing killed buffers.
			 (let ((global-cache-sym
				(intern file c2-global-buf-cache)))
			   (setplist global-cache-sym
				     (cons (let ((fscached (c2-create-fscached)))
					     (c2-set-fscached-buffer
					      fscached buf)
					     (c2-set-fscached-directory
					      fscached default-directory)
					     (c2-set-fscached-search-dirs
					      fscached compile-search-dirs)
					     fscached)
					   (symbol-plist global-cache-sym)))))
		       buf)))))))
      
      (and buf
	   (progn
	     (or (verify-visited-file-modtime buf)
		 
		 ;; Only ask whether to revert once per compilation per
		 ;; reversion.
		 (and (c2-ferrlist-ignore-modtime ferrlist)
		      (not (c2-ferrlist-reverted ferrlist)))
		 
		 (c2-set-ferrlist-ignore-modtime
		  ferrlist
		  ;; Ask whether to revert buffer via find-file-noselect to
		  ;; avoid duplicating code and ensure a consistent user
		  ;; interface.
		  (progn (setq buf (find-file-noselect (buffer-file-name buf)))
			 (not (verify-visited-file-modtime buf)))))
	     
	     buf)))))

(defun c2-associate-ferrlist-with-buf (ferrlist buf)
  "Globally associate FERRLIST with BUFFER."
  (let ((ferrlists (c2-map-lookup c2-buffer-to-ferrlists-map buf)))
    (or ferrlists
	(progn (setq ferrlists (hlist-create nil))
	       (c2-map-insert c2-buffer-to-ferrlists-map buf ferrlists)))
    (hlist-insert ferrlists ferrlist)))

(defun c2-unassociate-ferrlist-with-buf (ferrlist)
  "Globally unassociate FERRLIST with its buffer."
  (and (c2-ferrlist-buf ferrlist)
       (let* ((buf (c2-ferrlist-buf ferrlist))
	      (ferrlists (c2-map-lookup c2-buffer-to-ferrlists-map buf)))
	 (and ferrlists (hlist-delete ferrlists
				      (function (lambda (f)
						  (eq f ferrlist))))))))

(defun c2-mark-err (cn err)
  "Try to ensure COMPILATION's ERR has valid markers for each of its files.
Return whether ERR has valid markers in a buffer on at least one of its
files, which is equivalent to whether user doesn't want to ignore all of
ERR's files."
  ;;
  ;; Actually, try to ensure all COMPILATION's errs with the same files as
  ;; ERR have valid markers, so user can edit buffers on those files without
  ;; screwing up errors farther down in the same buffer.
  ;;
  ;; Fails only on failure to find any of ERR's files.
  ;;
  (let ((default-directory (c2-get-cn-directory cn))
	(has-valid-markers nil)
	(i 0)
	file mrkr)
    
    ;; c2-err-mrkrs may change from nil to a list of markers after the first
    ;; iteration, so access it sequentially via nth rather than via cdr.
    
    (while (setq file (nth i (c2-err-files err)))
      (setq mrkr (nth i (c2-err-mrkrs err)))
      (setq i (1+ i))
      
       (let* (
	      ;; filter stored errs in CN on this file in list attached to
	      ;; file's name in cn's files-hashtable
	      (ferrlist
	       (symbol-plist (intern file (c2-cn-files-hashtable cn))))
	      
	      ;; To immediately detect ignored files or changes to
	      ;; default-directory or compile-search-dirs, always locate buffer
	      ;; via c2-find-file-noselect, even when mrkr points to a
	      ;; nondeleted buffer.
	      (buf (c2-find-file-noselect file cn ferrlist))
	      
	      ;; Must check ferrlist-reverted after c2-find-file-noselect
	      ;; because c2-revert-buffer from find-file-noselect may set it.
	      (reverted (c2-ferrlist-reverted ferrlist)))

	 (or (null buf)
	     (and mrkr (eq (marker-buffer mrkr) buf)
		  (not reverted)
		  (setq has-valid-markers t))
	     
	     ;; [Re-]mark all messages in buf.
	     (progn
	       
	       ;; Set reverted flag when reverting and clear (1) when setting
	       ;; to new buffer and (2) after re-marking all errs below.
	       ;;
	       ;; Set ignore-modtime flag from c2-find-file-noselect only and
	       ;; clear when (1) setting to new buffer and (2) reverting.
	       
	       (or (eq buf (c2-ferrlist-buf ferrlist))
		   ;; Globally associate BUF with FERRLIST so c2-revert-buffer
		   ;; can update FERRLIST's revert flag.
		   (progn
		     (c2-set-ferrlist-reverted ferrlist nil)
		     (c2-set-ferrlist-ignore-modtime ferrlist nil)
		     (c2-unassociate-ferrlist-with-buf ferrlist)
		     (c2-associate-ferrlist-with-buf ferrlist buf)
		     (c2-set-ferrlist-buf ferrlist buf)))
	       
	       (let ((inform-marking
		      (>= (length ferrlist) compile-marking-inform-threshold))
		     ;; Moving to each error's line number from the previous
		     ;; error's is noticeably faster than moving from the
		     ;; beginning of the file.
		     prev-err-line)
		 
		 (and inform-marking
		      (message "Marking errors in file %s..." file))
		 
		 ;; ...move to the buffer containing those errors' file
		 (save-excursion
		   (set-buffer buf)
		   (save-restriction
		     (widen)
		     (goto-char (point-min))
		     (setq prev-err-line 1)
		     
		     ;; ...and generate markers for those errs.
		     (mapcar
		      (function
		       (lambda (err-plus-index)
			 (let* ((err (car err-plus-index))
				(i (cdr err-plus-index))
				(mrkrs (c2-err-mrkrs err)))
			   
			   (or mrkrs
			       ;; Haven't yet generated any markers for this
			       ;; err -- create a list of as many as will
			       ;; ultimately be needed.
			       ;;
			       ;; Lazily create markers here rather than in
			       ;; the filter, to avoid overloading the filter
			       ;; and seriously degrading Emacs response
			       ;; time.
			       ;;
			       (let ((nmrkrs (length (c2-err-files err))))
				 (while (> nmrkrs 0)
				   (setq mrkrs (cons (make-marker) mrkrs))
				   (setq nmrkrs (1- nmrkrs)))
				 (c2-set-err-mrkrs err mrkrs)))
			   
			   ;; Point the marker at the appropriate line in buf
			   ;; if it's not already attached to a buffer (as it
			   ;; can be if user looked at first error in a file
			   ;; before filter parsed all errors for that file).
			   
			   (let ((mrkr (nth i (c2-err-mrkrs err))))
			     (or (and (eq (marker-buffer mrkr) buf)
				      (not reverted))
				 (let* ((err-line (nth i (c2-err-lines err)))
					;; Error messages sometimes
					;; (incorrectly) specify line numbers
					;; beyond end-of-file.
					(beyond-eob
					 (forward-line
					  (- err-line prev-err-line))))
				   (setq prev-err-line
					 (- err-line beyond-eob))
				   (move-marker mrkr (point))))))))
		      
		      (c2-ferrlist-errs ferrlist))))
		 
		 (and inform-marking
		      (message "Marking errors in file %s...done" file)))
		
	       ;; Don't clear reverted until after marking all errors, since
	       ;; user may keyboard-quit while marking them.
	       (and reverted (c2-set-ferrlist-reverted ferrlist nil))
	       
	       (setq has-valid-markers t)))))
    
    has-valid-markers))

(defun compile-again ()
  "Restart compilation in current buffer if buffer is a restartable
compilation, otherwise restart the most recent restartable compilation.

As of this writing, all compilations other than those started by \\[grep]
\(grep\) are restartable."
  (interactive)
  (let ((cn (c2-current-cn 'noerr)))
    (if (and cn (or (c2-cn-can-compile-again cn)
		    (setq cn (hlist-find c2-cns
					 (function
					  (lambda (cn)
					    (c2-cn-can-compile-again cn)))))))
	(c2-run cn)
      (call-interactively 'compile))))

;; Choose compilation during M-x compile: if default-directory is not the
;; same as that of the top compilation matching the name, ask whether to
;; compile in the current dir before going with the top one.
;;
;; What if there is a compilation matching default-directory and the name,
;; but it isn't the top one?  Should we prompt?  ...or silently choose the
;; one matching both the directory and the name?  I'd say prompt, but could
;; add an option to turn off prompt if matches nontop compilation.
;;
;; Choosing during M-x grep: same behavior until someone complains.

(defun grep (args &optional prefix-arg)
  "Run the program specified by the compile-grep-command variable
asynchronously with specified ARGS, collecting output in a buffer.  While or
after grep executes, compile-next-error \(\\[compile-next-error]\) and
compile-previous-error \(\\[compile-previous-error]\) find the text to which
errors refer.

Optional prefix arg positive prompts for directory in which to execute
COMMAND, and negative prevents recycling an old compilation buffer to create
a new one."
  (interactive
   (list (read-string (concat compile-grep-command " "))
	 current-prefix-arg))
  (and (string= args "") (error "No arguments given"))
  (c2-run (c2-get-cn-create
	   (concat compile-grep-command " -n " args " /dev/null")
	   prefix-arg
	   (concat compile-grep-command " hit")
	   compile-save-buffers compile-ignore-grep-window nil nil)))

(defun compile (command &optional prefix-arg)
  "Execute COMMAND asynchronously, collecting output in a buffer.  While or
after COMMAND executes, compile-next-error \(\\[compile-next-error]\) and
compile-previous-error \(\\[compile-previous-error]\) find the text to which
errors refer.

Optional prefix arg positive prompts for directory in which to execute
COMMAND, and negative prevents recycling an old compilation buffer to create
a new one.

From a program, PREFIX-ARG is the second argument."
  ;;
  ;; If compile-command-initial-input, explicitly use compile-command instead
  ;; of (hlist-first c2-cns), because some users set compile-command locally
  ;; depending on language.
  ;;
  (interactive
   (list (read-string "Compile command: "
		      (and compile-command-initial-input
			   (let ((cn (c2-get-buffer-cn (current-buffer))))
			     (if (and cn (c2-cn-command cn))
				 (c2-cn-command cn)
			       compile-command))))
	 current-prefix-arg))
  (setq compile-command command)
  (and (string= command "") (error "No command given"))
  (c2-run (c2-get-cn-create command prefix-arg "error"
			    compile-save-buffers nil t nil)))

(defun c2-get-cn-create (command prefix-arg msg-descrip save-first
				 ignore-window can-compile-again name-of-mode)
  "Find compilation matching COMMAND, or create one if none exists.

PREFIX-ARG positive prompts for directory in which to execute COMMAND, and
negative prevents recycling an old compilation buffer to create a new one.

If PREFIX-ARG doesn't request directory prompting and directory of most
recent compilation matching COMMAND differs from current buffer's directory,
maybe invoke a compilation in the current buffer's directory instead,
depending on several factors including variable compile-silently-favor-cwd's
value.

Remaining arguments:

- MSG-DESCRIP is a short string describing messages COMMAND generates, e.g.
  \"grep hit\".  Defaults to \"error\"
- SAVE-FIRST t means first save all buffers without asking, nil means don't
  save any buffers, non-nil and non-t means ask before saving each buffer
- IGNORE-WINDOW non-nil suppresses display of compilation window by
  compile-next-error, compile-previous-error, and compile-current-error
- CAN-COMPILE-AGAIN non-nil means compile-again may restart compilation
- NAME-OF-MODE is the compilation buffer's mode name.  Defaults to
  \"Compile\""

  ;; If directory specified, use or make a cn named COMMAND with that
  ;; directory.  If directory isn't specified, use or make a cn named
  ;; COMMAND, using default-directory if one needs to be made.
  
  (c2-expunge-killed-cns)
  (let* ((request-directory (and prefix-arg
				 (>= (prefix-numeric-value prefix-arg) 0)))
	 (inhibit-recycle (and prefix-arg
			       (< (prefix-numeric-value prefix-arg) 0)))
	 (directory (if request-directory (request-directory "In directory: ")
		      default-directory))
	 cn)
    (if (or request-directory (eq t compile-silently-favor-cwd))
	(setq cn (c2-get-cn-by-name-and-directory command directory))
      (setq cn (c2-get-cn-by-name command))
      (and cn (not (string= (c2-get-cn-directory cn) default-directory))
	   (let ((cwd-cn (c2-get-cn-by-name-and-directory command directory)))
 	     (and (or (and cwd-cn (not (or (eq nil compile-silently-favor-cwd)
 					   (eq t compile-silently-favor-cwd))))
		      (y-or-n-p "\
Use current directory instead of most recent matching compilation's? "))
		  (setq cn cwd-cn)))))
    
    (or cn (c2-new-cn command directory (or msg-descrip "error")
		      ignore-window can-compile-again name-of-mode save-first
		      inhibit-recycle nil t))))

(defun c2-run (cn)
  "Run COMPILATION."
  (and (c2-cn-process cn) (c2-process-is-alive (c2-cn-process cn))
       (cond ((y-or-n-p
	       "A compilation process is running; kill and restart it? ")
	      
	      ;; Cannot use kill-process, it doesn't trigger the sentinel until
	      ;; after the return to top level, resulting in the sentinel
	      ;; appending its "killed at <time>" message to the startup text
	      ;; we write below when invoking the new process.
	      
	      ;; delete-process, on the other hand, kills its process argument
	      ;; and immediately triggers sentinel.
	      
	      (and (c2-cn-process cn)	;; may have finished during y-or-n-p
		   (delete-process (c2-cn-process cn))))
	     
	     ((y-or-n-p
	       "Create a parallel compilation? ")
	      (setq cn
		    (c2-new-cn (c2-cn-command cn) (c2-get-cn-directory cn)
			       (c2-cn-msg-descrip cn) (c2-cn-ignore-window cn)
			       (c2-cn-can-compile-again cn)
			       (c2-cn-name-of-mode cn) (c2-cn-save-first cn)
			       ;; Inhibit recycling on this rare occasion
			       ;; rather than risking deleting a precious
			       ;; buffer.
			       t
			       nil t)))
	     (t (error "New compilation not started"))))
  
  (and (c2-cn-save-first cn)
       (save-some-buffers (eq (c2-cn-save-first cn) t)))
  
  (let ((command (c2-cn-command cn))
	(inhibit-quit t)
	(start-buffer (current-buffer))
	process)
    
    (c2-set-cn-user-aware-of-errs cn nil)
    (c2-clear-errors cn)
    (c2-make-cn-current cn)
    
    ;; ignore-window non-t and non-nil means ignore window even upon
    ;; invocation.
    (or (and (not (null (c2-cn-ignore-window cn)))
	     (not (eq t (c2-cn-ignore-window cn))))
	(c2-display-cn-window cn))
    
    (unwind-protect
	(progn
	  (set-buffer (c2-cn-buffer cn))
	  (erase-buffer)
	  (insert "cd " default-directory "\n" command "\n")
	  
	  (setq process
		(start-process command (c2-cn-buffer cn)
			       shell-file-name "-c" command))
	  (or compile-dont-parse
	      (set-process-filter process 'c2-filter))
	  (set-process-sentinel process 'c2-sentinel)
	  (set-marker (process-mark process) (point))
	  (set-marker (c2-cn-beyond-last-err cn) (point))
	  (set-marker (c2-cn-output-begin cn) (point))
	  ;; Make output-end the same as the process-mark while the process is
	  ;; active.  Set it to its own marker in sentinel, since process-mark
	  ;; disappears when a sentineled process exits.
	  (set-marker (c2-cn-output-end cn) nil)
	  (c2-set-cn-output-end cn (process-mark process))
	  (compile-mode))
      
      ;; Make point in all windows on this compilation be point-max.
      (let ((point-max (point-max)))
	(mapcar (function (lambda (window)
			    (set-window-point window point-max)))
		(get-buffer-windows (current-buffer))))
      (set-buffer start-buffer))
    
    (c2-increment-active-cns 1)
    (c2-set-cn-process cn process)
    (c2-maybe-bind-to-db cn)
    (let ((sn (c2-cn-db-sn cn)))
      (and sn (db-c2-sn-is-alive sn)
	   ;; kill the sn for restarting when the compilation completes
	   ;; successfully.
	   (progn
	     (db-quit-sn sn)
	     (c2-set-cn-killed-db-sn cn t)))))
  (run-hooks 'compile-start-hook))

(defun compile-kill-compilation (n)
  "Kill the processes of the prefix-arg N most recent active \\[compile] or
\\[grep] commands."
  (interactive "p")
  (c2-expunge-killed-cns)
  (let ((remaining n)
	cn)
    (while (and (> remaining 0)
		(setq cn
		      (hlist-find
		       c2-cns
		       (function (lambda (cn)
				   (let ((p (c2-cn-process cn)))
				     (and p (c2-process-is-alive p))))))))
      (setq remaining (1- remaining))
      (interrupt-process (c2-cn-process cn)))
    (and (> remaining 0)
	 (if (< remaining n) 
	     (error "No more compilations with active processes")
	   (if (hlist-first c2-cns)
	       (error "No compilations with active processes")
	     (error "No compilations currently exist"))))))

(defun compile-delete-compilation (name)
  "Delete compilation BUFFER and its associated compilation."
  ;;
  ;; Cannot delete compilations based on command string, since command string
  ;; isn't necessarily unique.
  ;;
  (interactive
   (progn
     (list (let* ((default-cn (c2-current-cn))
		  (default-name (buffer-name (c2-cn-buffer default-cn)))
		  (name (read-buffer
			 (format "Delete compilation: (default %s) "
				 (c2-truncate-name default-name 20)))))
	     (or name default-name)))))
  
  (let ((buffer (get-buffer name)))
    (or (and buffer (c2-get-buffer-cn buffer))
	(error "No compilations named %s" name))
  
    ;; Killing buffer will eventually trigger appropriate cleanup via
    ;; sentinel and expunge-killed-cns.
    (kill-buffer buffer)))

;; May want to make compilation current when interrupting or killing it.
(defun c2-interrupt-process ()
  "Interrupt current buffer's process."
  (interactive)
  (interrupt-process nil t))

(defun c2-kill-process ()
  "Kill current buffer's process."
  (interactive)
  (kill-process nil t))

(defun compile1 (command error-message &optional name-of-mode)
  "Backwards compatibility for functions that use the Emacs 18 distribution
compile package's undocumented compile1 function."
  (c2-run (c2-get-cn-create
	   command
	   ;; Don't recycle buffers, since callers have no way of inhibiting
	   ;; recycling.
	   (integerp compile-recycle-buffer-threshold)
	   (and (string-match "No more \\(.+\\)'?s" error-message)
		(substring error-message (match-beginning 1) (match-end 1)))
	   'query-save-buffers nil
	   (not (string-match "^grep" command))
	   name-of-mode)))

(defun c2-clear-error (err)
  "Free up whatever resources ERR consumes."
  (mapcar (function (lambda (mrkr) (set-marker mrkr nil)))
	  (c2-err-mrkrs err))
  (and (c2-err-cn-mrkr err) (set-marker (c2-err-cn-mrkr err) nil)))

(defun c2-clear-errors (cn)
  "Forget about all errors in COMPILATION."
  ;; ... deleting their markers in the process.
  (c2-set-cn-no-errs-seen-yet cn t)
  (hlist-map 'c2-clear-error (c2-cn-errs cn))
  (mapatoms
   (function (lambda (file-sym)
	       (and file-sym
		    (let ((ferrlist (symbol-plist file-sym)))
		      (and ferrlist
			   (c2-unassociate-ferrlist-with-buf ferrlist))
		      (setplist file-sym nil)))))
   (c2-cn-files-hashtable cn))
  (mapcar (function (lambda (indent-mrkrs)
		      (set-marker (car indent-mrkrs) nil)
		      (set-marker (cdr indent-mrkrs) nil)))
	  (c2-cn-indents cn))
  (c2-set-cn-indents cn nil)
  (hlist-clear (c2-cn-errs cn)))

(defmacro c2-parse-region (begin end buffer check-for-read-only)
  "Add error messages in region between BEGIN and END to BUFFER's
compilation.  If CHECK-FOR-READ-ONLY is non-nil, ensure BUFFER is not
read-only before indenting successfully parsed messages.

Invoked by c2-filter, among other functions.

Evaluate to whether successfully parsed last line in region, for c2-filter's
sake.  To speed up c2-filter, assume \(1\) BEGIN precedes END and \(2\)
current buffer has a compilation."
  ;; Implement as macro so that c2-filter can set end to (point-max) without
  ;; end migrating backward as we insert indentation spaces.
  (` (let ((cn (c2-get-buffer-cn (, buffer)))
	   (parsed t))
       (goto-char (, begin))
       (while (< (point) (, end))
	 
	 (while (and (null (setq parsed (c2-parse-line)))
		     (progn (forward-line 1)
			    (< (point) (, end)))))
	 
	 ;; Could do multi-line error messages by (1) using prefixize-regexp,
	 ;; (2) moving up a line before starting this loop (duplicates get
	 ;; filtered out below), (3) remembering the most recently parsed error
	 ;; and moving back to just after it before starting this loop.
	 
	 (and parsed
	      (let* ((errs (c2-cn-errs cn))
		     (err (hlist-last errs))
		     (files (car parsed))
		     (lines (cdr parsed))
		     (err-mrkr (copy-marker (point))))
		
		;; Indent to make errors more obvious.  Byte-compiler
		;; optimizes out read-only check if check-for-read-only
		;; is nil.
		(and (not (and (, check-for-read-only)
			       buffer-read-only))
		     (progn (insert-char ?  compile-message-indent)
			    (let ((indent-mrkr (copy-marker (point))))
			      ;; Remember indentation's beginning and end to
			      ;; allow reliable unindenting in compile-reparse.
			      (c2-set-cn-indents
			       cn (cons (cons err-mrkr indent-mrkr)
					(c2-cn-indents cn))))))
		
		;; Avoid redundant error markers for multiple errors at same
		;; file and lineno
		(or (and err
			 (equal files (c2-err-files err))
			 (equal lines (c2-err-lines err)))
		    
		    ;; Allocate new err and associate it with its
		    ;; filename(s).
		    
		    (progn
		      (setq err (c2-create-err files lines nil err-mrkr))
		      
		      ;; Make sure user knows there are now errors (s)he
		      ;; hasn't yet seen.
		      ;;
		      ;; user-aware-of-errs becomes nil when (1) compilation
		      ;; starts, (2) after user visits last error when
		      ;; compilation window is visible, and (3) user
		      ;; attempts to visit beyond-last error.
		      ;;
		      ;; It becomes t again here, whenever the next error
		      ;; arrives.
		      
		      (and (not (c2-cn-user-aware-of-errs cn))
			   (progn
			     (c2-set-cn-user-aware-of-errs cn t)
			     (or (get-buffer-window (, buffer))
				 (progn
				   (ding)
				   (message "found%s %ss in \"%s\""
					    (if (c2-cn-no-errs-seen-yet cn)
						"" " more")
					    (c2-cn-msg-descrip cn)
					    (c2-cn-command cn))))))
		      
		      (hlist-insert-last errs err)
		      
		      ;; Add each of err's files and their indices to the
		      ;; appropriate ferrlist object in COMPILATION's err
		      ;; filename hashtable.
		      
		      (let ((hashtable (c2-cn-files-hashtable cn))
			    (i 0)
			    file ferrlist)
			(while files
			  (setq file (car files))
			  (setq files (cdr files))
			  (setq ferrlist
				(symbol-plist (intern file hashtable)))
			  (or ferrlist (progn
					 (setq ferrlist (c2-create-ferrlist))
					 (setplist (intern file hashtable)
						   ferrlist)))
			  (let ((err-plus-index (cons err i)))
			    (setq i (1+ i))
			    (c2-set-ferrlist-errs
			     ferrlist
			     (cons err-plus-index
				   (c2-ferrlist-errs ferrlist))))))))
		
		(forward-line 1)
		(move-marker (c2-cn-beyond-last-err cn) (point)))))
       
       ;; Evaluate to whether successfully parsed last line in region.
       parsed)))

(defun compile-unparse ()
  "Unindent and forget about errors in current buffer's compilation.
Recommended before adding errors and reparsing via \\[compile-reparse]."
  ;; Use COMPILATION's list of indentation markers to distinguish between
  ;; spaces we added, spaces the user added, and spaces which migrated to
  ;; just after the user deleted intervening text.
  (interactive)
  (let ((cn (or (c2-get-buffer-cn (current-buffer))
		(error "No compilation associated with this buffer"))))
    (save-excursion
      (mapcar (function (lambda (indent-mrkrs)
			  (let ((begin (car indent-mrkrs))
				(end (cdr indent-mrkrs)))
			    (goto-char end)
			    (beginning-of-line)
			    (if (and (looking-at " +")
				     (>= (- (match-end 0) (point))
					 compile-message-indent))
				(delete-char compile-message-indent)
			      (goto-char begin)
			      (and (bolp)
				   (looking-at " +")
				   (>= (- (match-end 0) (point))
				       compile-message-indent)
				   (delete-char compile-message-indent))))))
	      (c2-cn-indents cn)))
    (c2-clear-errors cn)))

(defun compile-parse-region (begin end)
  "Parse region as compilation output and visit its first error."
  (interactive "r")
  (let ((cn (c2-get-buffer-cn (current-buffer))))
    (or cn (setq cn (c2-new-cn nil default-directory "message"
			       compile-ignore-grep-window
			       nil nil nil t (current-buffer) t)))
    (c2-make-cn-current cn)
    (let ((begin-mrkr (c2-cn-output-begin cn))
	  (end-mrkr (c2-cn-output-end cn)))
      ;; Convert BEGIN and END to markers before invoking compile-unparse,
      ;; which could otherwise make BEGIN or END incorrect by modifying the
      ;; current buffer.
      (set-marker begin-mrkr begin)
      (set-marker end-mrkr end)
      (save-excursion
	(compile-unparse)
	(c2-parse-region begin-mrkr end-mrkr (current-buffer) t))))
  (compile-next-error 1))

(defun compile-parse-buffer ()
  "Parse current buffer as compilation output and visit its first error."
  (interactive)
  (compile-parse-region (point-min) (point-max)))

(defun compile-parse-shell-output ()
  "Parse most recent shell output as compilation output and visit its first
error."
  (interactive)
  (or (and (boundp 'last-input-end)
	   last-input-end
	   (eq (marker-buffer last-input-end) (current-buffer)))
      (error "Cannot parse shell output in nonshell buffer"))
  (compile-parse-region last-input-end (point-max)))

(defun compile-reparse ()
  "Reparse input to current buffer's compilation.  See also compile-unparse."
  (interactive)
  (compile-unparse)
  (let ((cn (or (c2-get-buffer-cn (current-buffer))
		(error "No compilation associated with this buffer"))))
    (let ((begin-mrkr (c2-cn-output-begin cn))
	  (end-mrkr (c2-cn-output-end cn)))
      (save-excursion
	(c2-parse-region begin-mrkr end-mrkr (current-buffer) t)))))

(defun c2-filter (process output)
  "Filter function for compilation processes.  Parses and remembers error
messages as they appear."
  (generic-filter c2-filter process output buffer nil
    
    ;; Invariant: at eob if successfully parsed last [partial] line,
    ;; otherwise at bol.  (Must not parse the same line twice, because the
    ;; spaces we prepend upon successful parsing can modify parsing
    ;; behavior.)
    
    ;; Insert all output at end of compilation buffer, parse to end of
    ;; buffer, then maintain invariant by moving to beginning of last line if
    ;; didn't successfully parse it.
    
    (save-excursion (goto-char (point-max)) (insert output))
    (or (bolp)
	;; Already parsed the last line in spite of missing its tail; skip
	;; over its tail.
	(forward-line 1))
    
    (let ((parsed-last-line
	   (c2-parse-region (point) (point-max) buffer nil)))
      
      ;; Maintain invariant that position upon entry to filter is at bol if
      ;; didn't successfully parse last line.
      (or parsed-last-line (beginning-of-line)))))

(defun c2-sentinel (process change)
  "Sentinel function for compilation processes.  Display message if
compilation window is not visible, and restart associated debugger process,
if any."
  (let* ((inhibit-quit nil)
	 (buffer (process-buffer process))
	 (cn (c2-get-buffer-cn buffer))
	 (deactivated nil))
    (if (c2-buffer-killed-p buffer)
	(progn
	  (setq deactivated t)
	  (set-process-buffer process nil)
	  (message (format "Compilation process %s killed (deleted buffer)"
			   (process-name process))))
      (let (state)		;; string describing new compilation state
	(save-excursion
	 (set-buffer buffer)
	 
	 ;; Unconditionally update the mode line to reflect process' new
	 ;; status, and generate a message to inform user of change if buffer
	 ;; isn't visible
	 
	 (setq mode-line-process
	       (concat ": " (symbol-name (process-status process))))
	 ;; Force mode line redisplay soon
	 (set-buffer-modified-p (buffer-modified-p))
	 (setq state (substring change 0 -1))
	 (and (null (get-buffer-window buffer))
	      (message "\"%s\" %s" (c2-cn-command cn) state)))
	
	;; Clean up if process exited or died
	
	(and (memq (process-status process) '(signal exit))
	     (let* ((obuf (current-buffer))
		    omax opoint)
	       (setq deactivated t)
	       
	       ;; save-excursion isn't the right thing if process-buffer is
	       ;; current-buffer
	       (unwind-protect
		   (progn
		     (set-buffer buffer)
		     (setq omax (point-max) opoint (point))
		     (goto-char (point-max))
		     ;; Set output-end to its own marker, since process-mark
		     ;; disappears when a sentineled process exits.
		     (c2-set-cn-output-end cn (copy-marker (point)))
		     (insert "\n" state " at "
			     (substring (current-time-string) 0 -5)
			     "\n"))
		 
		 ;; Delete process now so doesn't stay around until
		 ;; M-x list-processes
		 (delete-process process)
		 (c2-set-cn-process cn nil))
	       
	       (if (and opoint (< opoint omax))
		   (goto-char opoint))
	       (set-buffer obuf)))))

    (and (c2-cn-db-sn cn)
	 deactivated
	 (= (process-exit-status process) 0)
	 ;; sn shouldn't be alive, but check anyway:
	 (not (db-c2-sn-is-alive (c2-cn-db-sn cn)))
	 ;; restart if we killed it
	 (c2-cn-killed-db-sn cn)
	 (progn
	   (db-restart-sn (c2-cn-db-sn cn))
	   (c2-set-cn-killed-db-sn cn nil)))
    
    (and deactivated
	 (progn
	   (c2-increment-active-cns -1)
	   (run-hooks 'compile-exit-hook)))))

(defun c2-maybe-bind-to-db (cn)
  "Maybe associate COMPILATION with the current debugger session."
  ;;
  ;; If (1) cn doesn't already have a db sn and (2) cn's command
  ;; string matches compile-bind-to-db-regex and (3) there's a current
  ;; db sn and (4) the current db sn doesn't yet have an
  ;; associated compilation, bind cn to the sn.
  ;;
  (and (featurep 'db)
       (null (c2-cn-db-sn cn))
       (string-match compile-bind-to-db-regex (c2-cn-command cn))
       (let ((sn (db-current-sn)))
	 (and sn
	      (db-c2-sn-is-alive sn)
	      (null (db-c2-sn-cn sn))
	      (progn
		(db-c2-set-sn-cn sn cn)
		(c2-set-cn-db-sn cn sn))))))

;;; Hooks into db package:

(defun c2-db-cn-sn (cn)
  "Return debugger session associated with COMPILATION."
  (c2-cn-db-sn cn))

(defun c2-db-set-cn-sn (cn sn)
  "Associate with COMPILATION debugger session SESSION."
  (c2-set-cn-db-sn cn sn))

(defun c2-increment-active-cns (nr)
  "Increment the count of active compilations by NR and update the status
line accordingly."
  ;; called by c2-run with NR = 1 and c2-sentinel with NR = -1
  (setq c2-nr-active-compilations
	(+ nr c2-nr-active-compilations))
  (setq compile-mode-line-compilations
	(if (= 0 c2-nr-active-compilations) nil
	  (apply compile-mode-line-format c2-nr-active-compilations nil)))
  ;; Force mode-line updates
  (save-excursion (set-buffer (other-buffer)))
  (set-buffer-modified-p (buffer-modified-p))
  (sit-for 0))

(defvar compile-mode-map nil
  "Keymap for compile-mode.")

(if compile-mode-map
   nil
  (setq compile-mode-map (make-sparse-keymap))
  (define-key compile-mode-map "\C-x." 'compile-current-error)
  (define-key compile-mode-map "\C-c\C-i" 'compile-ignore-file)
  (define-key compile-mode-map "\C-c\C-u" 'compile-unparse)
  (define-key compile-mode-map "\C-c\C-r" 'compile-reparse)
  (define-key compile-mode-map "\C-c\C-c" 'c2-interrupt-process)
  (define-key compile-mode-map "\C-c\C-k" 'c2-kill-process))

(defun compile-mode ()
  "Major mode for compilation output.  Key bindings:
\\{compile-mode-map}"
  (interactive)
  (use-local-map compile-mode-map)
  (setq major-mode 'compile-mode)
  (let ((cn (c2-get-buffer-cn (current-buffer))))
    (setq mode-name (or (and cn (c2-cn-name-of-mode cn)) "Compile")))
  (setq mode-line-process '(": %s"))
  (auto-fill-mode 0)
  (make-local-variable 'compile-filename-filter)
  (make-local-variable 'compile-dont-parse)
  (make-local-variable 'compile-search-dirs)
  (run-hooks 'compile-mode-hook))

(put 'compile-mode 'mode-class 'special)

(defsubst c2-expunge-preceding-deleted-errs (errs)
  "Expunge deleted errors between the current and preceding error."
  ;;
  ;; Delete previous as long as it's the same as current.  Assume ERRS is
  ;; nonempty.
  ;;
  (let ((current-marker-position
	 (marker-position (c2-err-cn-mrkr (hlist-current errs))))
	previous)
    (while (and (setq previous (hlist-forward -1 errs))
		(= (marker-position (c2-err-cn-mrkr previous))
		   current-marker-position))
      (c2-clear-error previous)
      (hlist-delete-current errs))
    
    ;; hlist-forward modifies hlist current position, so undo modification. 
    ;; Could provide new hlist-delete-previous function instead.
    (and previous (hlist-forward 1 errs))))

(defsubst c2-expunge-following-deleted-errs (errs)
  "Expunge deleted errors between the current and next error."
  ;;
  ;; Delete current as long as it's the same as next.  Assume ERRS is
  ;; nonempty.
  ;;
  (let ((current-marker-position
	 (marker-position (c2-err-cn-mrkr (hlist-current errs))))
	next)
    (while (and (setq next (hlist-nth-hence 1 errs))
		(= (marker-position (c2-err-cn-mrkr next))
		   current-marker-position))
      (c2-clear-error (hlist-current errs))
      (hlist-delete-current errs))))

(defun c2-next-undeleted-err (arg cn)
  "Return a pair whose car is the ARGth next undeleted error in COMPILATION,
or the endmost error if there aren't that many errors, and whose cdr is the
number of errors left to move."
  ;; Honor user deletions from compilation buffer.
  ;;
  ;; When user deletes messages from compilation buffer, the associated
  ;; errors' markers migrate to the beginning of the next undeleted message.
  ;;
  ;; Strictly correct behavior requires examining every error en route to the
  ;; target error.
  ;;
  ;; Could check for deleted messages only before and after hlist-forward,
  ;; with likely correct behavior most of the time; but I expect correctness
  ;; is worth the extra cost, which is negligible in the typical case where
  ;; arg is 1 or -1.
  
  (let* ((forward (if (< arg 0) nil t))
	 (remaining (if forward arg (- arg)))
	 (continue t)
	 (errs (c2-cn-errs cn)))
    
    (and (not (hlist-emptyp errs)) ; expunge-*-deleted-errs assume nonempty
	 (progn
	   
	   (while continue
	     (if forward
		 (c2-expunge-following-deleted-errs errs)
	       (c2-expunge-preceding-deleted-errs errs))
	     ;;
	     ;; When arg >= 0, it's important to perform the above once after
	     ;; remaining = 0, to discard deleted errors whose markers have
	     ;; moved to the error the user has targeted.
	     ;;
	     ;; It's unnecessary if arg < 0, since deleted error markers only
	     ;; migrate forward; but it doesn't do any harm.
	     ;;
	     (if (and (> remaining 0)
		      (hlist-forward (if forward 1 -1) errs))
		 (setq remaining (1- remaining))
	       (setq continue nil)))
	   
	   (let ((err (hlist-current errs)))
	     (and err (= (marker-position (c2-err-cn-mrkr err))
			 (marker-position (c2-cn-beyond-last-err cn)))
		  ;; User deleted the last error.
		  (progn (c2-expunge-preceding-deleted-errs errs)
			 (c2-clear-error err)
			 (hlist-delete-current errs)
			 (setq err (hlist-current errs))
			 (and (< remaining arg)
			      (setq remaining (1+ remaining)))))
	     
	     (cons err remaining))))))

(defun c2-next-err (arg cn)
  "Return the ARGth next undeleted error with an associated file in
COMPILATION."
  ;; Find files and mark buffers here rather than while parsing from filter,
  ;; because (1) finding and marking a series of files and buffers can be
  ;; obscenely time-consuming, to the point where emacs stops responding for
  ;; many seconds; and (2) buffer(s) on error's file(s) may have been
  ;; deleted.
  
  (let* ((forward (if (< arg 0) nil t))
	 (err-and-remaining (c2-next-undeleted-err arg cn))
	 (err (and err-and-remaining (car err-and-remaining)))
	 (requested (if forward arg (- arg)))
	 (remaining (and err-and-remaining (cdr err-and-remaining))))
    
    ;; Skip errors whose files the user wants to ignore.
    (and err
	 (or (< remaining requested) (= requested 0))
	 (not (c2-mark-err cn err))
	 
	 (let ((skipped 1)
	       moved)
	   
	   ;; First look in the direction ARG specifies for an err the
	   ;; user doesn't want to ignore.
	   (while
	       (progn (setq err-and-remaining (c2-next-undeleted-err
					       (if forward 1 -1) cn)
			    err (car err-and-remaining)
			    moved (= (cdr err-and-remaining) 0))
		      (and moved (not (c2-mark-err cn err))))
	     (setq skipped (1+ skipped)))
	   
	   (or moved
	       (progn
		 ;; Couldn't find unignored errors in the direction ARG
		 ;; specifies, so search backward from the error
		 ;; c2-next-undeleted-err originally returned.
		 
		 (c2-next-undeleted-err (if forward
					    (- (1- skipped))
					  (1- skipped)) cn)
		 (while
		     (progn
		       (setq err-and-remaining (c2-next-undeleted-err
						(if forward -1 1) cn)
			     err (car err-and-remaining)
			     moved (= (cdr err-and-remaining) 0)
			     remaining (1+ remaining))
		       (and moved (not (c2-mark-err cn err)))))
		 
		 (or moved (setq err nil))))))
    
    ;; If didn't make any progress in satisfying requested
    ;; movement, signal error by returning nil.
    (and err
	 (> requested 0)
	 (>= remaining requested)
	 (setq err nil))
    
    err))

(defun c2-possible-err-near-point (cn set-current)
  "Return the possibly ignored or deleted error message nearest point in
COMPILATION's buffer, making it the current message if SET-CURRENT is
non-nil."
  ;;
  ;; It's not useful to return deleted messages.  However, not returning
  ;; deleted errors would require save-hlist-excursion or changing
  ;; c2-next-undeleted-err to count from an error other than the current one.
  ;;
  ;; It is useful to return ignored messages to compile-ignore-file.
  ;;
  (save-excursion
    (set-buffer (c2-cn-buffer cn))
    (beginning-of-line)
    (let* ((point (point))
	   (errs (c2-cn-errs cn)))
      (or (hlist-find-sorted errs
			     (function (lambda (err)
					 (>= (c2-err-cn-mrkr err) point)))
			     set-current)
	  ;; Either there are no errs or point is beyond the last one.
	  (hlist-last errs set-current)))))

(defun c2-jump-to-err-at-point ()
  "Jump to error message nearest point in current compilation buffer and
display the corresponding source code."
  (interactive)
  (let* ((cn (c2-current-cn))
	 (err-at-point (progn (c2-possible-err-near-point cn 'set-current)
			      ;; retrieve the unignored error nearest point
			      (c2-next-err 0 cn))))
    
    (or err-at-point (error "No error at point"))
    (c2-set-cn-no-errs-seen-yet cn nil)
    (c2-display-err cn err-at-point)))

(defun compile-current-error (parse-current-line)
  "If prefix arg is nil:
From a noncompilation buffer, visit the current compilation error message and
corresponding source code; from a compilation buffer, visit the error message
nearest point.  This operates on the output from the \\[compile] and \\[grep]
commands.

If prefix-arg is non-nil:
Parse current line as compilation output and visit the corresponding file."
  (interactive "P")
  (cond (parse-current-line
	 (compile-parse-region (save-excursion (beginning-of-line) (point))
			       (save-excursion (forward-line 1) (point))))
	((c2-get-buffer-cn (current-buffer))
	 (c2-jump-to-err-at-point))
	(t (compile-next-error 0))))

(defun compile-previous-error (arg)
  "Visit the ARGth previous compilation error message and corresponding
source code.  This operates on the output from the \\[compile] and \\[grep]
commands."
  (interactive "p")
  (compile-next-error (- arg)))

(defun compile-last-error ()
  "Visit the last compilation error message and corresponding source code.
This operates on the output from the \\[compile] and \\[grep] commands."
  (interactive "p")
  (compile-next-error c2-huge-pos-int))

(defun compile-first-error ()
  "Visit the first compilation error message and corresponding source code.
This operates on the output from the \\[compile] and \\[grep] commands."
  (interactive "p")
  (compile-next-error c2-huge-neg-int))

(defun compile-next-error (arg)
  "Visit the ARGth next compilation error message and corresponding source
code.  This operates on the output from the \\[compile] and \\[grep]
commands."
  (interactive "p")
  (let* ((cn (c2-current-cn))
	 (err (if (and (c2-cn-no-errs-seen-yet cn) (= arg 0))
		  ;; If user has visited no errors yet, there is no current one
		  nil
		(c2-next-err (if (and (c2-cn-no-errs-seen-yet cn) (> arg 0))
				 ;; Pretend the current error is a null one
				 ;; before the beginning of the list.
				 (1- arg)
			       arg)
			     cn))))
    (or err
	(let ((alive (and (c2-cn-process cn)
			  (c2-process-is-alive (c2-cn-process cn)))))
	  
	  (and (= arg 0)
	       compile-display-if-none-visited
	       (set-window-point (c2-display-cn-window cn) 1))
	  
	  (error (cond ((hlist-emptyp (c2-cn-errs cn))
			(concat "No %ss" (if alive " yet" "")))
		       ((= arg 0)
			"No %ss visited yet")
		       ((< arg 0)
			"No previous %s")
		       (t
			(progn (c2-set-cn-user-aware-of-errs cn nil)
			       (concat "No more %ss" (if alive " yet" "")))))
		 (c2-cn-msg-descrip cn))))
    
    (c2-set-cn-no-errs-seen-yet cn nil)
    (c2-display-err cn err)
    (and (eq err (hlist-last (c2-cn-errs cn)))
	 (get-buffer-window (c2-cn-buffer cn))
	 ;; User presumably knows there are no more errors at the moment, so
	 ;; say something when more occur.
	 (c2-set-cn-user-aware-of-errs cn nil))))

(defun c2-display-cn-window (cn)
  "Display COMPILATION's buffer in a window and return that window."
  ;; Window goes at the top unless buffer is already displayed elsewhere.
  (pop-up-command-buffer (c2-cn-buffer cn) compile-window-height-hook))

(defun c2-display-err (cn err)
  "Display windows on COMPILATION at ERROR and on ERROR's source file\(s\) at
the appropriate line number\(s\)."
  
  ;; Typically, top window is compilation window, next one is buffer on first
  ;; error-containing file, next one is buffer on second error-containing
  ;; file (if any).
  
  (let ((cn-window
	 ;; If compilation window should be visible, ensure it is to guarantee
	 ;; no other functions make it visible by recycling the source buffer
	 ;; windows we're about to create.
	 (if (c2-cn-ignore-window cn)
	     (get-buffer-window (c2-cn-buffer cn))
	   (c2-display-cn-window cn))))
    
    (c2-set-cn-current-mrkr cn (c2-err-cn-mrkr err))
    (setq overlay-arrow-position (c2-cn-current-mrkr cn))
    (setq overlay-arrow-string compile-mrkr-overlay-text)
    (and cn-window
	 (progn (set-window-point cn-window (c2-cn-current-mrkr cn))
		(set-window-start
		 cn-window
		 (save-excursion
		   (set-buffer (c2-cn-buffer cn))
		   (goto-char (c2-cn-current-mrkr cn))
		   (forward-line (- compile-lines-above-current-err))
		   (point)))))
    
    (let ((mrkrs (c2-err-mrkrs err))
	  (err-windows nil))
      (while mrkrs
	(let* ((mrkr (car mrkrs))
	       (buf (marker-buffer mrkr))
	       (win (apply 'display-buffer-excluding-windows
			   buf 'no-minibuffer cn-window err-windows)))
	  (set-window-point win mrkr)
	  (setq err-windows (cons win err-windows))
	  (setq mrkrs (cdr mrkrs))))
      
      (select-window (car (nreverse err-windows))))))

(defun c2-expunge-killed-cns ()
  "Forget about all killed compilations."
  (let ((found-killed nil))
    (hlist-delete
     c2-cns
     (function
      (lambda (cn)
	(let ((buffer (c2-cn-buffer cn)))
	  (and (c2-buffer-killed-p buffer)
	       (progn (setq found-killed t)
		      (c2-clear-errors cn)
		      ;; Killing buffer may leave process in 'run' state
		      (and (c2-cn-process cn)
			   (delete-process (c2-cn-process cn)))
		      (c2-map-delete c2-buffer-to-cn-map buffer)
		      ;; tell hlist-delete to remove this compilation
		      t))))))
    (and found-killed
	 (c2-garbage-collect))))

(defun c2-expunge-buffer-to-ferrlists-map ()
  "Remove from c2-buffer-to-ferrlists-map associations from killed buffers or
to empty lists."
  (let ((bufs nil))
    (c2-map-map (function (lambda (buf ferrlists)
			    (and (or (c2-buffer-killed-p buf)
				     (hlist-emptyp ferrlists))
				 (setq bufs (cons buf bufs)))))
		c2-buffer-to-ferrlists-map)
    (mapcar (function (lambda (buf)
			(c2-map-delete c2-buffer-to-ferrlists-map buf)))
	    bufs)))

(defun c2-garbage-collect ()
  "Unreference useless pointers accessible from global tables to objects like
killed buffers so the Emacs garbage collector can reuse their memory.  Should
be called regularly but infrequently."
  (c2-expunge-global-buf-cache)
  (c2-expunge-buffer-to-ferrlists-map))

;; Maintain compatibility with names from:
;;  - Emacs 18 compile.el,
(fset 'kill-compilation 'compile-kill-compilation)
(fset 'next-error 'compile-next-error)
;;  - Emacs 19 compile.el,
(fset 'compile-internal 'compile1)
;;  - and compile2 version 1.
(fset 'previous-error 'compile-previous-error)
(fset 'current-error 'compile-current-error)

(eval-and-compile
 (defun c2-debug-log (message &optional data)
   "Insert MESSAGE and optional DATA at end of compile2 debug log buffer."
    (save-excursion
      (set-buffer (get-buffer-create "*c2-debug-log*"))
      (goto-char (point-max))
      (insert "<<" message (if data (concat ": " data) "") ">>")
      (let ((window (get-buffer-window (current-buffer))))
	(and window
	     (set-window-point window (point)))))))

;;; Remaining functions incorporated from wolfgang@wsrc2.com (Wolfgang S.
;;; Rupprecht)'s mult-compile.el package.

(defun c2-test-parse ()
  "Attempt to parse text at point as an error message.  If successful,
display the number of the matching rule and the matched filenames and line
numbers."
  (interactive)
  (let ((parsed (c2-parse-line)))
    (or parsed
	(error "No matching rule"))
    ;; Determine which rule matched here rather than modifying and slowing
    ;; down c2-parse-line.
    (let ((rule-nr 0)
	  (matching-rule-nr nil))
      (mapcar '(lambda (rule)
		 (and (looking-at (car rule))
		      (not matching-rule-nr)
		      (setq matching-rule-nr rule-nr))
		 (setq rule-nr (1+ rule-nr)))
	      compile-error-parse-regexps)
      (message "Matched rule %d: %s" matching-rule-nr
	       (prin1-to-string parsed)))))

(defun c2-parse-line ()
  "Parse this line, returning a pair of lists whose car is a list of names of
files and cdr is a list of line numbers in those files."
  (let* ((parse-list compile-error-parse-regexps)
	 (not-done parse-list)
	 (parsed nil))
    
    (while not-done
      (let ((rule (car parse-list)))
        (if (looking-at (car rule))
            (let* ((file-index (nth 1 rule))
		   (line-index (nth 2 rule))
		   (file-2-index (nth 3 rule))
		   (line-2-index (nth 4 rule))
		   line1 line2 file1 file2)
	      (setq line1 (string-to-int
			   (buffer-substring (match-beginning line-index)
					     (match-end line-index))))
	      (and file-2-index
		   (progn
		     (setq file2 (buffer-substring
				      (match-beginning file-2-index)
				      (match-end file-2-index)))
		     (setq line2 (string-to-int
				  (buffer-substring
				   (match-beginning line-2-index)
				   (match-end line-2-index))))))
              (setq file1
                    (cond ((integerp file-index)
                           (buffer-substring (match-beginning file-index)
                                             (match-end file-index)))
                          ;; careful! this next funcall may mash the
                          ;; match-data, so it must be done after all the
                          ;; line numbers and names have been extracted
                          ((symbolp file-index) (funcall file-index))
                          ((stringp file-index) file-index)
                          (t (error "Parsing error: unknown action type: %s"
                                    file-index))))
	      (setq not-done nil)
	      (setq parsed (cons (cons file1
				       (and file2 (list file2)))
				 (cons line1 (and line2 (list line2))))))
	  
	  (setq parse-list (cdr parse-list))
	  (setq not-done parse-list))))
    parsed))

(defun scan-make ()
  "Attempt to find the name of the Makefile used by this make run.  This
routine shouldn't be used for anything drastic, since it just isn't that
robust."
  (cond ((save-excursion
           (re-search-backward "make[^\n]+-f[ \t]+\\(\\sw\\|\\s_\\)+" nil t))
         (buffer-substring (match-beginning 1)(match-end 1)))
        ((file-exists-p "makefile") "makefile")
        ((file-exists-p "Makefile") "Makefile")
        (t nil)
      ))

(defun scan-s5lint ()
  "Attempt to find the name of the file that lint was griping about on this
line.  This routine also has the side-effect of modifying the current buffer.
The current line will have the first gripe of a multi-gripe line broken off
onto a separate line."
  (let (retval)
    (if (save-excursion
          (re-search-backward "^\\(\\sw\\|\\s_\\|\\s.\\)+\n======+$" nil t))
        (progn
          (setq retval (buffer-substring (match-beginning 1)(match-end 1)))
          (save-excursion
            (if (re-search-forward ")[ \t]*("
                                   (save-excursion (end-of-line) (point)) t)
                (replace-match ")\n(")))))
  retval))

(provide 'compile)
(provide 'compile2)
