comparison lisp/progmodes/etags.el @ 26720:32e893b03ad2

(etags-tags-completion-table): Modified the regexp to allow for the CL symbols starting with `+*'. (tags-completion-table): Doc fix (it's an obarray, not an alist). (tags-completion-table, tags-recognize-empty-tags-table): Remove `function' quoting lambda. (tags-with-face): New macro. (list-tags, tags-apropos): Use it. (tags-apropos-additional-actions): New user option. (etags-tags-apropos-additional): Use it. (tags-apropos): Call etags-tags-apropos-additional. (tags-apropos-verbose): New user option. (etags-tags-apropos): Use it. (visit-tags-table-buffer, next-file): Use `unless'. (recognize-empty-tags-table): Renamed to tags-recognize-empty-tags-table. (complete-tag): Call tags-complete-tag bypassing try-completion.

26719:8a6fd8991465

;; Boston, MA 02111-1307, USA.

;;; Code:

(require 'ring)

;;;###autoload
(defvar tags-file-name nil
  "*File name of tags table.
To switch to a new tags table, setting this variable is sufficient.

  "*Length of marker rings `find-tag-marker-ring' and `tags-location-ring'."
  :group 'etags
  :type 'integer
  :version "20.3")

(defvar find-tag-marker-ring (make-ring find-tag-marker-ring-length)
  "Ring of markers which are locations from which \\[find-tag] was invoked.")

(defvar default-tags-table-function nil
  "If non-nil, a function to choose a default tags file for a buffer.

(defvar tags-table-files nil
  "List of file names covered by current tags table.
nil means it has not yet been computed; use `tags-table-files' to do so.")

(defvar tags-completion-table nil
  "Alist of tag names defined in current tags table.")

(defvar tags-included-tables nil
  "List of tags tables included by the current tags table.")

(defvar next-file-list nil
  "List of files for \\[next-file] to process.")

;; Hooks for file formats.

(defvar tags-table-format-hooks '(etags-recognize-tags-table
				  recognize-empty-tags-table)
  "List of functions to be called in a tags table buffer to identify the type of tags table.  
The functions are called in order, with no arguments,
until one returns non-nil.  The function should make buffer-local bindings
of the format-parsing tags function variables if successful.")

				 t))))))

  ;; Expand the table name into a full file name.
  (setq tags-file-name (tags-expand-table-name tags-file-name))

  (if (and (eq cont t)
	   (null tags-table-list-pointer))
      ;; All out of tables.
      nil

    ;; Verify that tags-file-name names a valid tags table.
    ;; Bind another variable with the value of tags-file-name
    ;; before we switch buffers, in case tags-file-name is buffer-local.
    (let ((curbuf (current-buffer))
	  (local-tags-file-name tags-file-name))

		 (let ((tags-file-name (car included)))
		   (visit-tags-table-buffer 'same))
		 ;; Recurse in that buffer to compute its completion table.
		 (if (tags-completion-table)
		     ;; Combine the tables.
		     (mapatoms (function
				(lambda (sym)
				  (intern (symbol-name sym) table)))
			       tags-completion-table))
		 (setq included (cdr included))))
	     (setq tags-completion-table table))
	   (message "Making tags completion table for %s...done"
		    buffer-file-name))

(defun etags-recognize-tags-table ()
  (and (etags-verify-tags-table)
       ;; It is annoying to flash messages on the screen briefly,
       ;; and this message is not useful.  -- rms
       ;; (message "%s is an `etags' TAGS file" buffer-file-name)
       (mapcar (function (lambda (elt)
			   (set (make-local-variable (car elt)) (cdr elt))))
	       '((file-of-tag-function . etags-file-of-tag)
		 (tags-table-files-function . etags-tags-table-files)
		 (tags-completion-table-function . etags-tags-completion-table)
		 (snarf-tag-function . etags-snarf-tag)
		 (goto-tag-location-function . etags-goto-tag-location)

      ;;   \4 is not interesting;
      ;;   \5 is the explicitly-specified tag name.
      ;;   \6 is the line to start searching at;
      ;;   \7 is the char to start searching at.
      (while (re-search-forward
	      "^\\(\\([^\177]+[^-a-zA-Z0-9_$\177]+\\)?\\([-a-zA-Z0-9_$?:]+\\)\
\[^-a-zA-Z0-9_$?:\177]*\\)\177\\(\\([^\n\001]+\\)\001\\)?\
\\([0-9]+\\)?,\\([0-9]+\\)?\n"
	      nil t)
	(intern	(if (match-beginning 5)
		    ;; There is an explicit tag name.
		    (buffer-substring (match-beginning 5) (match-end 5))
		  ;; No explicit tag name.  Best guess.

	 (forward-char 1))
    (beginning-of-line)))

(defun etags-list-tags (file)
  (goto-char 1)
  (if (not (search-forward (concat "\f\n" file ",") nil t))
      nil
    (forward-line 1)
    (while (not (or (eobp) (looking-at "\f")))
      (let ((tag (buffer-substring (point)
				   (progn (skip-chars-forward "^\177")
					  (point)))))
	(princ (if (looking-at "[^\n]+\001")
		   ;; There is an explicit tag name; use that.
		   (buffer-substring (1+ (point)) ;skip \177
				     (progn (skip-chars-forward "^\001")
					    (point)))
		 tag)))
      (terpri)
      (forward-line 1))
    t))

(defun etags-tags-apropos (string)
  (goto-char 1)
  (while (re-search-forward string nil t)
    (beginning-of-line)
    (princ (buffer-substring (point)
			     (progn (skip-chars-forward "^\177")
				    (point))))
    (terpri)
    (forward-line 1)))

(defun etags-tags-table-files ()
  (let ((files nil)
	beg)
    (goto-char (point-min))


;; Empty tags file support.

;; Recognize an empty file and give it local values of the tags table format
;; variables which do nothing.
(defun recognize-empty-tags-table ()
  (and (zerop (buffer-size))
       (mapcar (function (lambda (sym)
			   (set (make-local-variable sym) 'ignore)))
	       '(tags-table-files-function
		 tags-completion-table-function
		 find-tag-regexp-search-function
		 find-tag-search-function
		 tags-apropos-function
		 tags-included-tables-function))
       (set (make-local-variable 'verify-tags-table-function)
	    (function (lambda ()
			(zerop (buffer-size)))))))

;;; Match qualifier functions for tagnames.
;;; XXX these functions assume etags file format.

;; This might be a neat idea, but it's too hairy at the moment.
;;(defmacro tags-with-syntax (&rest body)
;;  (` (let ((current (current-buffer))
;;	   (otable (syntax-table))
;;	   (buffer (find-file-noselect (file-of-tag)))
;;	   table)
;;       (unwind-protect
;;	   (progn
;;	     (set-buffer buffer)
;;	     (setq table (syntax-table))
;;	     (set-buffer current)
;;	     (set-syntax-table table)
;;	     (,@ body))
;;	 (set-syntax-table otable)))))
;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form))

;; t if point is at a tag line that matches TAG exactly.
;; point should be just after a string that matches TAG.
(defun tag-exact-match-p (tag)

		 (setq next-file-list (mapcar 'expand-file-name
					      (tags-table-files))))))))
	(t
	 ;; Initialize the list by evalling the argument.
	 (setq next-file-list (eval initialize))))
  (if next-file-list
      ()
    (and novisit
	 (get-buffer " *next-file*")
	 (kill-buffer " *next-file*"))
    (error "All files processed"))
  (let* ((next (car next-file-list))

directory specification."
  (interactive (list (completing-read "List tags in file: "
				      'tags-complete-tags-table-file
				      nil t nil)))
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags in file ")
    (princ file)
    (terpri)
    (save-excursion
      (let ((first-time t)
	    (gotany nil))
	(while (visit-tags-table-buffer (not first-time))
	  (setq first-time nil)
	  (if (funcall list-tags-function file)
	      (setq gotany t)))
	(or gotany
	    (error "File %s not in current tags tables" file))))))

;;;###autoload
(defun tags-apropos (regexp)
  "Display list of all tags in tags table REGEXP matches."
  (interactive "sTags apropos (regexp): ")
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags matching regexp ")
    (prin1 regexp)
    (terpri)
    (save-excursion
      (let ((first-time t))
	(while (visit-tags-table-buffer (not first-time))
	  (setq first-time nil)
	  (funcall tags-apropos-function regexp))))))

;;; XXX Kludge interface.

;; XXX If a file is in multiple tables, selection may get the wrong one.
;;;###autoload

  (pop-to-buffer "*Tags Table List*")
  (setq buffer-read-only nil)
  (erase-buffer)
  (let ((set-list tags-table-set-list)
	(desired-point nil))
    (if tags-table-list
	(progn
	  (setq desired-point (point-marker))
	  (princ tags-table-list (current-buffer))
	  (insert "\C-m")
	  (prin1 (car tags-table-list) (current-buffer)) ;invisible
	  (insert "\n")))
    (while set-list
      (if (eq (car set-list) tags-table-list)
	  ;; Already printed it.
	  ()
	(princ (car set-list) (current-buffer))
	(insert "\C-m")
	(prin1 (car (car set-list)) (current-buffer)) ;invisible
	(insert "\n"))
      (setq set-list (cdr set-list)))
    (if tags-file-name
	(progn
	  (or desired-point
	      (setq desired-point (point-marker)))
	  (insert tags-file-name "\C-m")
	  (prin1 tags-file-name (current-buffer)) ;invisible
	  (insert "\n")))
    (setq set-list (delete tags-file-name
			   (apply 'nconc (cons (copy-sequence tags-table-list)
					       (mapcar 'copy-sequence
						       tags-table-set-list)))))
    (while set-list

    (or pattern
	(error "Nothing to complete"))
    (search-backward pattern)
    (setq beg (point))
    (forward-char (length pattern))
    (setq completion (try-completion pattern 'tags-complete-tag nil))
    (cond ((eq completion t))
	  ((null completion)
	   (message "Can't find completion for \"%s\"" pattern)
	   (ding))
	  ((not (string= pattern completion))

26720:32e893b03ad2

;; Boston, MA 02111-1307, USA.

;;; Code:

(require 'ring)
(eval-when-compile (require 'cl)) ; for `gensym'

;;;###autoload
(defvar tags-file-name nil
  "*File name of tags table.
To switch to a new tags table, setting this variable is sufficient.

  "*Length of marker rings `find-tag-marker-ring' and `tags-location-ring'."
  :group 'etags
  :type 'integer
  :version "20.3")

(defcustom tags-tag-face 'default
  "*Face for tags in the output of `tags-apropos'."
  :group 'etags
  :type 'face
  :version "21.1")

(defcustom tags-apropos-verbose nil
  "If non-nil, print the name of the tags file in the *Tags List* buffer."
  :group 'etags
  :type 'boolean
  :version "21.1")

(defcustom tags-apropos-additional-actions nil
  "Specify additional actions for `tags-apropos'.

If non-nil, value should be a list of triples (TITLE FUNCTION
TO-SEARCH).  For each triple, `tags-apropos' processes TO-SEARCH and
lists tags from it.  TO-SEARCH should be an alist, obarray, or symbol.
If it is a symbol, the symbol's value is used.
TITLE. a string, is a title used to label the additional list of tags.
FUNCTION is a function to call when a symbol is selected in the
*Tags List* buffer.  It will be called with one argument SYMBOL which
is the symbol being selected.

Example value:

  '((\"Emacs Lisp\" Info-goto-emacs-command-node obarray)
    (\"Common Lisp\" common-lisp-hyperspec common-lisp-hyperspec-obarray)
    (\"SCWM\" scwm-documentation scwm-obarray))"
  :group 'etags
  :type 'list
  :version "21.1")

(defvar find-tag-marker-ring (make-ring find-tag-marker-ring-length)
  "Ring of markers which are locations from which \\[find-tag] was invoked.")

(defvar default-tags-table-function nil
  "If non-nil, a function to choose a default tags file for a buffer.

(defvar tags-table-files nil
  "List of file names covered by current tags table.
nil means it has not yet been computed; use `tags-table-files' to do so.")

(defvar tags-completion-table nil
  "Obarray of tag names defined in current tags table.")

(defvar tags-included-tables nil
  "List of tags tables included by the current tags table.")

(defvar next-file-list nil
  "List of files for \\[next-file] to process.")

;; Hooks for file formats.

(defvar tags-table-format-hooks '(etags-recognize-tags-table
				  tags-recognize-empty-tags-table)
  "List of functions to be called in a tags table buffer to identify the type of tags table.  
The functions are called in order, with no arguments,
until one returns non-nil.  The function should make buffer-local bindings
of the format-parsing tags function variables if successful.")

				 t))))))

  ;; Expand the table name into a full file name.
  (setq tags-file-name (tags-expand-table-name tags-file-name))

  (unless (and (eq cont t) (null tags-table-list-pointer))
    ;; Verify that tags-file-name names a valid tags table.
    ;; Bind another variable with the value of tags-file-name
    ;; before we switch buffers, in case tags-file-name is buffer-local.
    (let ((curbuf (current-buffer))
	  (local-tags-file-name tags-file-name))

		 (let ((tags-file-name (car included)))
		   (visit-tags-table-buffer 'same))
		 ;; Recurse in that buffer to compute its completion table.
		 (if (tags-completion-table)
		     ;; Combine the tables.
		     (mapatoms (lambda (sym) (intern (symbol-name sym) table))
			       tags-completion-table))
		 (setq included (cdr included))))
	     (setq tags-completion-table table))
	   (message "Making tags completion table for %s...done"
		    buffer-file-name))

(defun etags-recognize-tags-table ()
  (and (etags-verify-tags-table)
       ;; It is annoying to flash messages on the screen briefly,
       ;; and this message is not useful.  -- rms
       ;; (message "%s is an `etags' TAGS file" buffer-file-name)
       (mapcar (lambda (elt) (set (make-local-variable (car elt)) (cdr elt)))
	       '((file-of-tag-function . etags-file-of-tag)
		 (tags-table-files-function . etags-tags-table-files)
		 (tags-completion-table-function . etags-tags-completion-table)
		 (snarf-tag-function . etags-snarf-tag)
		 (goto-tag-location-function . etags-goto-tag-location)

      ;;   \4 is not interesting;
      ;;   \5 is the explicitly-specified tag name.
      ;;   \6 is the line to start searching at;
      ;;   \7 is the char to start searching at.
      (while (re-search-forward
	      "^\\(\\([^\177]+[^-a-zA-Z0-9_+*$\177]+\\)?\
\\([-a-zA-Z0-9_+*$?:]+\\)[^-a-zA-Z0-9_+*$?:\177]*\\)\177\
\\(\\([^\n\001]+\\)\001\\)?\\([0-9]+\\)?,\\([0-9]+\\)?\n"
	      nil t)
	(intern	(if (match-beginning 5)
		    ;; There is an explicit tag name.
		    (buffer-substring (match-beginning 5) (match-end 5))
		  ;; No explicit tag name.  Best guess.

	 (forward-char 1))
    (beginning-of-line)))

(defun etags-list-tags (file)
  (goto-char 1)
  (when (search-forward (concat "\f\n" file ",") nil t)
    (forward-line 1)
    (while (not (or (eobp) (looking-at "\f")))
      (let ((tag (buffer-substring (point)
				   (progn (skip-chars-forward "^\177")
					  (point))))
            (props `(action find-tag-other-window mouse-face highlight
			    face ,tags-tag-face))
            (pt (with-current-buffer standard-output (point))))
        (when (looking-at "[^\n]+\001")
	  ;; There is an explicit tag name; use that.
          (setq tag (buffer-substring (1+ (point)) ; skip \177
				      (progn (skip-chars-forward "^\001")
                                             (point)))))
        (princ tag)
        (when (= (aref tag 0) ?\() (princ " ...)"))
        (add-text-properties pt (with-current-buffer standard-output (point))
                             (cons 'item (cons tag props)) standard-output))
      (terpri)
      (forward-line 1))
    t))

(defmacro tags-with-face (face &rest body)
  "Execute BODY, give output to `standard-output' face FACE."
  (let ((pp (gensym "twf-")))
    `(let ((,pp (with-current-buffer standard-output (point))))
       ,@body
       (put-text-property ,pp (with-current-buffer standard-output (point))
			  'face ,face standard-output))))

(defun etags-tags-apropos-additional (regexp)
  "Display tags matching REGEXP from `tags-apropos-additional-actions'."
  (with-current-buffer standard-output
    (dolist (oba tags-apropos-additional-actions)
      (princ "\n\n")
      (tags-with-face 'highlight (princ (car oba)))
      (princ":\n\n")
      (let* ((props `(action ,(cadr oba) mouse-face highlight face
			     ,tags-tag-face))
             (beg (point))
	     (symbs (car (cddr oba)))
             (ins-symb (lambda (sy)
                         (let ((sn (symbol-name sy)))
                           (when (string-match regexp sn)
                             (add-text-properties (point)
						  (progn (princ sy) (point))
						  (cons 'item (cons sn props)))
                             (terpri))))))
        (when (symbolp symbs)
          (if (boundp symbs)
	      (setq symbs (symbol-value symbs))
	    (insert "symbol `" (symbol-name symbs) "' has no value\n")
	    (setq symbs nil)))
        (if (vectorp symbs)
	    (mapatoms ins-symb symbs)
	  (dolist (sy symbs)
	    (funcall ins-symb (car sy))))
        (sort-lines nil beg (point))))))

(defun etags-tags-apropos (string)
  (when tags-apropos-verbose
    (princ "Tags in file `")
    (tags-with-face 'highlight (princ buffer-file-name))
    (princ "':\n\n"))
  (goto-char 1)
  (while (re-search-forward string nil t)
    (beginning-of-line)
    (let ((tag (buffer-substring (point)
				 (progn (skip-chars-forward "^\177")
					(point))))
          (props `(action find-tag-other-window mouse-face highlight
			  face ,tags-tag-face))
          (pt (with-current-buffer standard-output (point))))
      (princ tag)
      (when (= (aref tag 0) ?\() (princ " ...)"))
      (add-text-properties pt (with-current-buffer standard-output (point))
                           `(item ,tag ,@props) standard-output))
    (terpri)
    (forward-line 1))
  (when tags-apropos-verbose (princ "\n")))

(defun etags-tags-table-files ()
  (let ((files nil)
	beg)
    (goto-char (point-min))


;; Empty tags file support.

;; Recognize an empty file and give it local values of the tags table format
;; variables which do nothing.
(defun tags-recognize-empty-tags-table ()
  (and (zerop (buffer-size))
       (mapcar (lambda (sym) (set (make-local-variable sym) 'ignore))
	       '(tags-table-files-function
		 tags-completion-table-function
		 find-tag-regexp-search-function
		 find-tag-search-function
		 tags-apropos-function
		 tags-included-tables-function))
       (set (make-local-variable 'verify-tags-table-function)
            (lambda () (zerop (buffer-size))))))

;; Match qualifier functions for tagnames.
;; XXX these functions assume etags file format.

;; This might be a neat idea, but it's too hairy at the moment.
;;(defmacro tags-with-syntax (&rest body)
;;   `(let ((current (current-buffer))
;;	   (otable (syntax-table))
;;	   (buffer (find-file-noselect (file-of-tag)))
;;	   table)
;;       (unwind-protect
;;	   (progn
;;	     (set-buffer buffer)
;;	     (setq table (syntax-table))
;;	     (set-buffer current)
;;	     (set-syntax-table table)
;;            ,@body)
;;       (set-syntax-table otable))))
;;(put 'tags-with-syntax 'edebug-form-spec '(&rest form))

;; t if point is at a tag line that matches TAG exactly.
;; point should be just after a string that matches TAG.
(defun tag-exact-match-p (tag)

		 (setq next-file-list (mapcar 'expand-file-name
					      (tags-table-files))))))))
	(t
	 ;; Initialize the list by evalling the argument.
	 (setq next-file-list (eval initialize))))
  (unless next-file-list
    (and novisit
	 (get-buffer " *next-file*")
	 (kill-buffer " *next-file*"))
    (error "All files processed"))
  (let* ((next (car next-file-list))

directory specification."
  (interactive (list (completing-read "List tags in file: "
				      'tags-complete-tags-table-file
				      nil t nil)))
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags in file `")
    (tags-with-face 'highlight (princ file))
    (princ "':\n\n")
    (save-excursion
      (let ((first-time t)
	    (gotany nil))
	(while (visit-tags-table-buffer (not first-time))
	  (setq first-time nil)
	  (if (funcall list-tags-function file)
	      (setq gotany t)))
	(or gotany
	    (error "File %s not in current tags tables" file)))))
  (with-current-buffer "*Tags List*"
    (setq buffer-read-only t)
    (apropos-mode)))

;;;###autoload
(defun tags-apropos (regexp)
  "Display list of all tags in tags table REGEXP matches."
  (interactive "sTags apropos (regexp): ")
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Click mouse-2 to follow tags.\n\nTags matching regexp `")
    (tags-with-face 'highlight (princ regexp))
    (princ "':\n\n")
    (save-excursion
      (let ((first-time t))
	(while (visit-tags-table-buffer (not first-time))
	  (setq first-time nil)
	  (funcall tags-apropos-function regexp))))
    (etags-tags-apropos-additional regexp))
  (with-current-buffer "*Tags List*"
    (setq buffer-read-only t)
    (apropos-mode)))

;;; XXX Kludge interface.

;; XXX If a file is in multiple tables, selection may get the wrong one.
;;;###autoload

  (pop-to-buffer "*Tags Table List*")
  (setq buffer-read-only nil)
  (erase-buffer)
  (let ((set-list tags-table-set-list)
	(desired-point nil))
    (when tags-table-list
	  (setq desired-point (point-marker))
	  (princ tags-table-list (current-buffer))
	  (insert "\C-m")
	  (prin1 (car tags-table-list) (current-buffer)) ;invisible
      (insert "\n"))
    (while set-list
      (unless (eq (car set-list) tags-table-list)
	(princ (car set-list) (current-buffer))
	(insert "\C-m")
	(prin1 (car (car set-list)) (current-buffer)) ;invisible
	(insert "\n"))
      (setq set-list (cdr set-list)))
    (when tags-file-name
	  (or desired-point
	      (setq desired-point (point-marker)))
	  (insert tags-file-name "\C-m")
	  (prin1 tags-file-name (current-buffer)) ;invisible
      (insert "\n"))
    (setq set-list (delete tags-file-name
			   (apply 'nconc (cons (copy-sequence tags-table-list)
					       (mapcar 'copy-sequence
						       tags-table-set-list)))))
    (while set-list

    (or pattern
	(error "Nothing to complete"))
    (search-backward pattern)
    (setq beg (point))
    (forward-char (length pattern))
    (setq completion (tags-complete-tag pattern nil nil))
    (cond ((eq completion t))
	  ((null completion)
	   (message "Can't find completion for \"%s\"" pattern)
	   (ding))
	  ((not (string= pattern completion))