git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/etags.el

   1 ;;; etags.el --- etags facility for Emacs
   2
   3 ;; Copyright 1985, 1986, 1988, 1990, 1997, 2003 Free Software Foundation, Inc.
   4
   5 ;; Author: Their Name is Legion (see list below)
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Keywords: tools
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Synched up with: Not synched with FSF.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is completely different from FSF's etags.el.  It appears
  31 ;; that an early version of this file (tags.el) has been rewritten by
  32 ;; two different people; we got one, FSF got the other.  Various
  33 ;; people have said that our version is better and faster.
  34
  35 ;; TODO:
  36 ;; - DOCUMENT!
  37
  38 ;; Derived from the original lisp/tags.el.
  39
  40 ;; Ideas and code from the work of the following people:
  41 ;; Andy Norman <ange@hplb.hpl.hp.com>, author of ange-tags.el
  42 ;; Ramana Rao <rao@arisia.xerox.com>
  43 ;; John Sturdy <jcgs@harlqn.co.uk>, author of tags-helper.el
  44 ;; Henry Kautz <kautz@allegra.att.com>, author of tag-completion.el
  45 ;; Dan LaLiberte <liberte@cs.uiuc.edu>, author of local-tags.el
  46 ;; Tom Dietterich <tgd@turing.cs.orst.edu>, author of quest.el
  47 ;; The author(s) of lisp/simple.el
  48 ;; Duke Briscoe <briscoe@cs.yale.edu>
  49 ;; Lynn Slater <lrs@indetech.com>, author of location.el
  50 ;; Shinichirou Sugou <shin@sgtp.apple.juice.or.jp>
  51 ;; an unidentified anonymous elisp hacker
  52 ;; Kyle Jones <kyle_jones@wonderworks.com>
  53 ;;   added "Exact match, then inexact" code
  54 ;;   added support for include directive.
  55 ;; Hrvoje Niksic <hniksic@xemacs.org>
  56 ;;   various changes.
  57
  58 \f
  59 ;;; User variables.
  60
  61 (defgroup etags nil
  62   "Etags facility for Emacs.
  63 Using etags, you can create tag tables for any number of files, and
  64 easily access the symbols in those files, using the `\\[find-tag]'
  65 command."
  66   :prefix "tags-"
  67   :group 'tools)
  68
  69
  70 (defcustom tags-build-completion-table 'ask
  71   "*If this variable is nil, then tags completion is disabled.
  72 If it is t, then things which prompt for tags will do so with completion
  73  across all known tags.
  74 If it is the symbol `ask', you will be asked whether each tags table
  75  should be added to the completion list as it is read in.  (With the
  76  exception that for very small tags tables, you will not be asked,
  77  since they can be parsed quickly.)"
  78   :type '(choice (const :tag "Disabled" nil)
  79                  (const :tag "Complete All" t)
  80                  (const :tag "Ask" ask))
  81   :group 'etags)
  82
  83 (defcustom tags-always-exact nil
  84   "*If this variable is non-nil, then tags always looks for exact matches.
  85 If it is nil (the default), tags will first go through exact matches,
  86 then through the non-exact ones."
  87   :type 'boolean
  88   :group 'etags)
  89
  90 (defcustom tag-table-alist nil
  91   "*A list which determines which tags files are active for a buffer.
  92 This is not really an association list, in that all elements are
  93 checked.  The CAR of each element of this list is a pattern against
  94 which the buffer's file name is compared; if it matches, then the CDR
  95 of the list should be the name of the tags table to use.  If more than
  96 one element of this list matches the buffer's file name, then all of
  97 the associated tags tables will be used.  Earlier ones will be
  98 searched first.
  99
 100 If the CAR of elements of this list are strings, then they are treated
 101 as regular-expressions against which the file is compared (like the
 102 auto-mode-alist).  If they are not strings, then they are evaluated.
 103 If they evaluate to non-nil, then the current buffer is considered to
 104 match.
 105
 106 If the CDR of the elements of this list are strings, then they are
 107 assumed to name a TAGS file.  If they name a directory, then the string
 108 \"TAGS\" is appended to them to get the file name.  If they are not
 109 strings, then they are evaluated, and must return an appropriate string.
 110
 111 For example:
 112   (setq tag-table-alist
 113         '((\"/usr/src/public/perl/\" . \"/usr/src/public/perl/perl-3.0/\")
 114          (\"\\\\.el$\" . \"/usr/local/emacs/src/\")
 115          (\"/jbw/gnu/\" . \"/usr15/degree/stud/jbw/gnu/\")
 116          (\"\" . \"/usr/local/emacs/src/\")
 117          ))
 118
 119 This means that anything in the /usr/src/public/perl/ directory should use
 120 the TAGS file /usr/src/public/perl/perl-3.0/TAGS; and file ending in .el should
 121 use the TAGS file /usr/local/emacs/src/TAGS; and anything in or below the
 122 directory /jbw/gnu/ should use the TAGS file /usr15/degree/stud/jbw/gnu/TAGS.
 123 A file called something like \"/usr/jbw/foo.el\" would use both the TAGS files
 124 /usr/local/emacs/src/TAGS and /usr15/degree/stud/jbw/gnu/TAGS (in that order)
 125 because it matches both patterns.
 126
 127 If the buffer-local variable `buffer-tag-table' is set, then it names a tags
 128 table that is searched before all others when find-tag is executed from this
 129 buffer.
 130
 131 If there is a file called \"TAGS\" in the same directory as the file in
 132 question, then that tags file will always be used as well (after the
 133 `buffer-tag-table' but before the tables specified by this list.)
 134
 135 If the variable tags-file-name is set, then the tags file it names will apply
 136 to all buffers (for backwards compatibility.)  It is searched first."
 137   :type '(repeat (cons :format "%v"
 138                        (choice :value ""
 139                                (regexp :tag "Buffer regexp")
 140                                sexp)
 141                        (choice :value ""
 142                                (string :tag "Tag file or directory")
 143                                sexp)))
 144   :group 'etags)
 145
 146 (defvar buffer-tag-table nil
 147   "*The additional name of one TAGS table to be used for this buffer.
 148 You can set this with `\\[set-buffer-tag-table]'.  See the documentation
 149 for the variable `tag-table-alist' for more information.")
 150 (make-variable-buffer-local 'buffer-tag-table)
 151
 152 (defvar tags-file-name nil
 153   "The name of the tags-table used by all buffers.
 154 This is for backwards compatibility, and is largely supplanted by the
 155 variable tag-table-alist.")
 156
 157 (defcustom tags-auto-read-changed-tag-files nil
 158   "*If non-nil, always re-read changed TAGS file without prompting.
 159 If nil, prompt whether to re-read the changed TAGS file."
 160   :type 'boolean
 161   :group 'etags)
 162
 163 (defcustom make-tags-files-invisible nil
 164   "*If non-nil, TAGS-files will not show up in buffer-lists or be
 165 selectable (or deletable.)"
 166   :type 'boolean
 167   :group 'etags)
 168
 169 (defcustom tags-search-nuke-uninteresting-buffers t
 170   "*If non-nil, keep newly-visited files if they contain the search target.
 171 This affects the `tags-search' and `tags-query-replace' commands."
 172   :type 'boolean
 173   :group 'etags)
 174
 175 (defcustom tags-check-parent-directories-for-tag-files t
 176   "*If non-nil, look for TAGS files in all parent directories."
 177   :type 'boolean
 178   :group 'etags)
 179
 180 (defcustom tags-exuberant-ctags-optimization-p nil
 181   "*If this variable is nil (the default), then exact tag search is able
 182 to find tag names in the name part of the tagtable (enclosed by  ^?..^A)
 183 and in the sourceline part of the tagtable ( enclosed by ^..^?).
 184 This is needed by xemacs etags as not every tag has a name field.
 185 It is slower for large tables and less precise than the other option.
 186
 187 If it is non-nil, then exact tag will only search tag names in the name
 188 part (enclosed by ^?..^A). This is faster and more precise than the other
 189 option. This is only usable with exuberant etags, as it has a name field
 190 entry for every tag."
 191 :type 'boolean
 192 :group 'etags)
 193 \f
 194 ;; Buffer tag tables.
 195
 196 (defun buffer-tag-table-list ()
 197   "Returns a list (ordered) of the tags tables which should be used for
 198 the current buffer."
 199   (let (result)
 200     ;; Explicitly set buffer-tag-table
 201     (when buffer-tag-table
 202       (push buffer-tag-table result))
 203     ;; Current directory
 204     (when (file-readable-p (concat default-directory "TAGS"))
 205       (push (concat default-directory "TAGS") result))
 206     ;; Parent directories
 207     (when tags-check-parent-directories-for-tag-files
 208       (let ((cur default-directory))
 209         ;; Fuck!  Shouldn't there be a more obvious portable way
 210         ;; to determine if we're the root?  Shouldn't we have a
 211         ;; proper path manipulation API?  Do you know how many
 212         ;; god-damn bugs are lurking out there because of Unix/
 213         ;; Windows differences?  And how much code is littered
 214         ;; with stuff such as 10 lines down from here?
 215         (while (not (and (equal (file-name-as-directory cur) cur)
 216                          (equal (directory-file-name cur) cur)))
 217           (setq cur (expand-file-name ".." cur))
 218           (let ((parent-tag-file (expand-file-name "TAGS" cur)))
 219             (when (file-readable-p parent-tag-file)
 220               (push parent-tag-file result))))))
 221     ;; tag-table-alist
 222     (let* ((key (or buffer-file-name
 223                     (concat default-directory (buffer-name))))
 224            (key (if (eq system-type 'windows-nt)
 225                     (replace-in-string key "\\\\" "/")
 226                   key))
 227            expression)
 228       (dolist (item tag-table-alist)
 229         (setq expression (car item))
 230         ;; If the car of the alist item is a string, apply it as a regexp
 231         ;; to the buffer-file-name.  Otherwise, evaluate it.  If the
 232         ;; regexp matches, or the expression evaluates non-nil, then this
 233         ;; item in tag-table-alist applies to this buffer.
 234         (when (if (stringp expression)
 235                   (string-match expression key)
 236                 (ignore-errors
 237                   (eval expression)))
 238           ;; Now evaluate the cdr of the alist item to get the name of
 239           ;; the tag table file.
 240           (setq expression (ignore-errors
 241                              (eval (cdr item))))
 242           (if (stringp expression)
 243               (push expression result)
 244             (error "Expression in tag-table-alist evaluated to non-string")))))
 245     (setq result (buffer-tag-table-list-load result))
 246     (setq result (delq nil result))
 247     ;; If no TAGS file has been found, ask the user explicitly.
 248     ;; #### tags-file-name is *evil*.
 249     (or result tags-file-name
 250         (call-interactively 'visit-tags-table))
 251     (when tags-file-name
 252       (setq result (nconc result (buffer-tag-table-list-load (list tags-file-name)))))
 253     (or result (error "Buffer has no associated tag tables"))
 254     (delete-duplicates (nreverse result) :test 'equal)))
 255
 256 (defun buffer-tag-table-list-load (list &optional used-buffers)
 257   "Load all tag buffers in LIST. Include directives inside the tag
 258 Buffers result in a recursive call off this function. The USED-BUFFERS
 259 parameter is just for internal use and prevents infinite inclusion
 260 loops. The return value is a list of loaded buffers with the order
 261 from LIST preserved.  The tag files loaded with the include directive
 262 are inserted into the returned list before their parents."
 263   (let (result)
 264     (and list
 265          (mapc
 266           #'(lambda (name)
 267               (when (file-directory-p name)
 268                 (setq name (concat (file-name-as-directory name) "TAGS")))
 269               (and
 270                (file-readable-p name)
 271                (save-excursion
 272                  (set-buffer (get-tag-table-buffer name))
 273                  (when (not (member buffer-file-name used-buffers))
 274                    (add-to-list 'used-buffers buffer-file-name)
 275                    (let ((include-files (tag-table-include-files)))
 276                      (when include-files
 277                        (setq result (nconc result
 278                                            (buffer-tag-table-list-load
 279                                             include-files used-buffers)))))
 280                    (add-to-list 'result buffer-file-name t)))))
 281           list))
 282     result))
 283
 284 ;;;###autoload
 285 (defun visit-tags-table (file)
 286   "Tell tags commands to use tags table file FILE when all else fails.
 287 FILE should be the name of a file created with the `etags' program.
 288 A directory name is ok too; it means file TAGS in that directory."
 289   (interactive (list (read-file-name "Visit tags table: (default TAGS) "
 290                                      default-directory
 291                                      (expand-file-name "TAGS" default-directory)
 292                                      t)))
 293   (if (string-equal file "")
 294       (setq tags-file-name nil)
 295     (setq file (expand-file-name file))
 296     (when (file-directory-p file)
 297       (setq file (expand-file-name "TAGS" file)))
 298     ;; It used to be that, if a user pressed RET by mistake, the bogus
 299     ;; `tags-file-name' would remain, causing the error at
 300     ;; `buffer-tag-table'.
 301     (when (file-exists-p file)
 302       (setq tags-file-name file))))
 303
 304 (defun set-buffer-tag-table (file)
 305   "In addition to the tags tables specified by the variable `tag-table-alist',
 306 each buffer can have one additional table.  This command sets that.
 307 See the documentation for the variable `tag-table-alist' for more information."
 308   (interactive
 309    (list
 310      (read-file-name "Visit tags table: (directory sufficient) "
 311                      nil default-directory t)))
 312   (or file (error "No TAGS file name supplied"))
 313   (setq file (expand-file-name file))
 314   (when (file-directory-p file)
 315     (setq file (expand-file-name "TAGS" file)))
 316   (or (file-exists-p file) (error "TAGS file missing: %s" file))
 317   (setq buffer-tag-table file))
 318
 319 \f
 320 ;; Manipulating the tag table buffer
 321
 322 (defconst tag-table-completion-status nil
 323   "Indicates whether a completion table has been built.
 324 Either nil, t, or `disabled'.")
 325 (make-variable-buffer-local 'tag-table-completion-status)
 326
 327 (defconst tag-table-files nil
 328   "If the current buffer is a TAGS table, this holds a list of the files
 329 referenced by this file, or nil if that hasn't been computed yet.")
 330 (make-variable-buffer-local 'tag-table-files)
 331
 332 (defun get-tag-table-buffer (tag-table)
 333   "Returns a buffer visiting the given TAGS table.
 334 If appropriate, reverting the buffer, and possibly build a completion-table."
 335   (or (stringp tag-table)
 336       (error "Bad tags file name supplied: %s" tag-table))
 337   ;; Remove symbolic links from name.
 338   (setq tag-table (symlink-expand-file-name tag-table))
 339   (let (buf build-completion check-name)
 340     (setq buf (get-file-buffer tag-table))
 341     (unless buf
 342       (if (file-readable-p tag-table)
 343           (setq buf (find-file-noselect tag-table)
 344                 check-name t)
 345         (error "No such tags file: %s" tag-table)))
 346     (with-current-buffer buf
 347       ;; Make the TAGS buffer invisible.
 348       (when (and check-name
 349                  make-tags-files-invisible
 350                  (string-match "\\`[^ ]" (buffer-name)))
 351         (rename-buffer (generate-new-buffer-name
 352                         (concat " " (buffer-name)))))
 353       (or (verify-visited-file-modtime buf)
 354           (cond ((or tags-auto-read-changed-tag-files
 355                      (yes-or-no-p
 356                       (format "Tags file %s has changed, read new contents? "
 357                               tag-table)))
 358                  (when tags-auto-read-changed-tag-files
 359                    (message "Tags file %s has changed, reading new contents..."
 360                             tag-table))
 361                  (revert-buffer t t)
 362                  (when (eq tag-table-completion-status t)
 363                    (setq tag-table-completion-status nil))
 364                  (setq tag-table-files nil))))
 365       (or (eq (char-after 1) ?\f)
 366           (error "File %s not a valid tags file" tag-table))
 367       (or (memq tag-table-completion-status '(t disabled))
 368           (setq build-completion t))
 369       (when build-completion
 370         (if (ecase tags-build-completion-table
 371               ((nil) nil)
 372               ((t) t)
 373               ((ask)
 374                ;; don't bother asking for small ones
 375                (or (< (buffer-size) 20000)
 376                    (y-or-n-p
 377                     (format "Build tag completion table for %s? "
 378                             tag-table)))))
 379             ;; The user wants to build the table:
 380             (condition-case nil
 381                 (progn
 382           (if tags-exuberant-ctags-optimization-p
 383               (add-to-tag-completion-table-exuberant-ctags)
 384             (add-to-tag-completion-table))
 385                   (setq tag-table-completion-status t))
 386               ;; Allow user to C-g out correctly
 387               (quit
 388                (message "Tags completion table construction aborted")
 389                (setq tag-table-completion-status nil
 390                      quit-flag t)
 391                t))
 392           ;; The table is verboten.
 393           (setq tag-table-completion-status 'disabled))))
 394     buf))
 395
 396 (defun file-of-tag ()
 397   "Return the file name of the file whose tags point is within.
 398 Assumes the tag table is the current buffer.
 399 File name returned is relative to tag table file's directory."
 400   (let ((opoint (point))
 401         prev size)
 402     (save-excursion
 403       (goto-char (point-min))
 404       (while (< (point) opoint)
 405         (forward-line 1)
 406         (end-of-line)
 407         (skip-chars-backward "^,\n")
 408         (setq prev (point)
 409               size (read (current-buffer)))
 410         (goto-char prev)
 411         (forward-line 1)
 412         ;; New include syntax
 413         ;;   filename,include
 414         ;; tacked on to the end of a tag file means use filename
 415         ;; as a tag file before giving up.
 416         ;; Skip it here.
 417         (unless (eq size 'include)
 418           (forward-char size)))
 419       (goto-char (1- prev))
 420       (buffer-substring (point) (point-at-bol)))))
 421
 422 (defun tag-table-include-files ()
 423   "Return all file names associated with `include' directives in a tag buffer."
 424   ;; New include syntax
 425   ;;   filename,include
 426   ;; tacked on to the end of a tag file means use filename as a
 427   ;; tag file before giving up.  The filenames are expanded to avoid
 428   ;; problems with relative paths being used in the wrong directory.
 429   (let ((files nil))
 430     (save-excursion
 431       (goto-char (point-min))
 432       (while (re-search-forward tags-include-pattern nil t)
 433         (push (expand-file-name (match-string 1)) files)))
 434     files))
 435
 436 (defun tag-table-files (tag-table)
 437   "Returns a list of the files referenced by the named TAGS table."
 438   (with-current-buffer (get-tag-table-buffer tag-table)
 439     (unless tag-table-files
 440       (let (files prev size)
 441         (goto-char (point-min))
 442         (while (not (eobp))
 443           (forward-line 1)
 444           (end-of-line)
 445           (skip-chars-backward "^,\n")
 446           (setq prev (point)
 447                 size (read (current-buffer)))
 448           (goto-char prev)
 449           (push (expand-file-name (buffer-substring (1- (point))
 450                                                     (point-at-bol))
 451                                   default-directory)
 452                 files)
 453           (forward-line 1)
 454           (forward-char size))
 455         (setq tag-table-files (nreverse files))))
 456     tag-table-files))
 457
 458 ;; #### should this be on previous page?
 459 (defun buffer-tag-table-files ()
 460   "Returns a list of all files referenced by all TAGS tables that
 461 this buffer uses."
 462   (apply #'append
 463          (mapcar #'tag-table-files (buffer-tag-table-list))))
 464
 465 \f
 466 ;; Building the completion table
 467
 468 ;; Test cases for building completion table; must handle these properly:
 469 ;; Lisp_Int, XSETINT, current_column \7f60,2282
 470 ;;         Lisp_Int, XSETINT, point>NumCharacters ? 0 : CharAt(\7f363,9935
 471 ;;         Lisp_Int, XSETINT, point<=FirstCharacter ? 0 : CharAt(\7f366,10108
 472 ;;       point<=FirstCharacter || CharAt(\7f378,10630
 473 ;;       point>NumCharacters || CharAt(\7f382,10825
 474 ;; DEFUN ("x-set-foreground-color", Fx_set_foreground_color,\7f191,4562
 475 ;; DEFUN ("x-set-foreground-color", Fx_set_foreground_color,\7f191,4562
 476 ;; DEFUN ("*", Ftimes,\7f1172,32079
 477 ;; DEFUN ("/=", Fneq,\7f1035,28839
 478 ;; defun_internal \7f4199,101362
 479 ;; int pure[PURESIZE / sizeof \7f53,1564
 480 ;; char staticvec1[NSTATICS * sizeof \7f667,17608
 481 ;;  Date: 04 May 87 23:53:11 PDT \7f26,1077
 482 ;; #define anymacroname(\7f324,4344
 483 ;; (define-key ctl-x-map \7f311,11784
 484 ;; (define-abbrev-table 'c-mode-abbrev-table \7f24,1016
 485 ;; static char *skip_white(\7f116,3443
 486 ;; static foo \7f348,11643
 487 ;; (defun texinfo-insert-@code \7f91,3358
 488 ;; (defvar texinfo-kindex)\7f29,1105
 489 ;; (defun texinfo-format-\. \7f548,18376
 490 ;; (defvar sm::menu-kludge-y \7f621,22726
 491 ;; (defvar *mouse-drag-window* \7f103,3642
 492 ;; (defun simula-back-level(\7f317,11263
 493 ;; } DPxAC,\7f380,14024
 494 ;; } BM_QCB;\7f69,2990
 495 ;; #define MTOS_DONE\t
 496
 497 ;; "^[^ ]+ +\\([^ ]+\\) "
 498
 499 ;; void *find_cactus_segment(\7f116,2444
 500 ;; void *find_pdb_segment(\7f162,3688
 501 ;; void init_dclpool(\7f410,10739
 502 ;; WORD insert_draw_command(\7f342,8881
 503 ;; void *req_pdbmem(\7f579,15574
 504
 505 (defvar tag-completion-table (make-vector 511 0))
 506
 507 (defvar tag-symbol)
 508 (defvar tag-table-symbol)
 509 (defvar tag-symbol-tables)
 510 (defvar buffer-tag-table-list)
 511
 512 (defmacro intern-tag-symbol (tag)
 513   `(progn
 514      (setq tag-symbol (intern ,tag tag-completion-table)
 515            tag-symbol-tables (and (boundp tag-symbol)
 516                                   (symbol-value tag-symbol)))
 517      (or (memq tag-table-symbol tag-symbol-tables)
 518          (set tag-symbol (cons tag-table-symbol tag-symbol-tables)))))
 519
 520 ;; Can't use "\\s-" in these patterns because that will include newline
 521 ;; \2 matches an explicit name.
 522 (defconst tags-explicit-name-pattern "\177\\(\\([^\n\001]+\\)\001\\)?")
 523 ;; \1 matches Lisp-name, \2 matches C-name, \5 (from
 524 ;; tags-explicit-name-pattern) matches explicit name.
 525 (defconst tags-DEFUN-pattern
 526   (concat "DEFUN[ \t]*(\"\\([^\"]+\\)\",[ \t]*\\(\\(\\sw\\|\\s_\\)+\\),"
 527           tags-explicit-name-pattern))
 528 ;; \1 matches an array name.  Explicit names unused?
 529 (defconst tags-array-pattern ".*[ \t]+\\([^ \[]+\\)\\[")
 530 ;; \2 matches a Lispish name, \5 (from tags-explicit-name-pattern) matches
 531 ;; explicit name.
 532 (defconst tags-def-pattern
 533   (concat "\\(.*[ \t]+\\)?\\**\\(\\(\\sw\\|\\s_\\)+\\)[ ();,\t]*"
 534 ;; "\\(.*[ \t]+\\)?\\(\\(\\sw\\|\\s_\\)+\\)[ ()]*"
 535 ;; "\\(\\sw\\|\\s_\\)+[ ()]*"
 536           tags-explicit-name-pattern)
 537       )
 538 ;; \1 matches Schemish name, \4 (from tags-explicit-name-pattern) matches
 539 ;; explicit name
 540 (defconst tags-schemish-pattern
 541   (concat "\\s-*(\\s-*def\\sw*\\s-*(?\\s-*\\(\\(\\sw\\|\\s_\\|:\\)+\\))?\\s-*"
 542           tags-explicit-name-pattern))
 543 (defconst tags-file-pattern "^\f\n\\(.+\\),[0-9]+\n")
 544 (defconst tags-include-pattern "^\f\n\\(.+\\),include\n"
 545   "Holds the pattern for finding the include directive in tagfiles.")
 546
 547
 548 (defun add-to-tag-completion-table-exuberant-ctags ()
 549   "Sucks the current buffer (a TAGS table) into the completion-table.
 550 This is a version which is optimized for exuberant etags and will not
 551 work with xemacs etags."
 552   (message "Adding %s to tags completion table..." buffer-file-name)
 553   (goto-char (point-min))
 554   (let ((tag-table-symbol (intern buffer-file-name tag-completion-table))
 555         ;; tag-table-symbol is used by intern-tag-symbol
 556         name tag-symbol
 557         tag-symbol-tables
 558         (case-fold-search nil))
 559     (while (re-search-forward tags-explicit-name-pattern nil t)
 560       ;; no need to check the mode here
 561       (setq name (match-string 2))
 562       (intern-tag-symbol name)))
 563   (message "Adding %s to tags completion table...done" buffer-file-name))
 564
 565
 566 (defun add-to-tag-completion-table ()
 567   "Sucks the current buffer (a TAGS table) into the completion-table."
 568   (message "Adding %s to tags completion table..." buffer-file-name)
 569   (goto-char (point-min))
 570   (let ((tag-table-symbol (intern buffer-file-name tag-completion-table))
 571         ;; tag-table-symbol is used by intern-tag-symbol
 572         filename file-type name name2 name3 tag-symbol
 573         tag-symbol-tables
 574         (case-fold-search nil))
 575     ;; Loop over the files mentioned in the TAGS file for each file,
 576     ;; try to find its major-mode, then process tags appropriately.
 577     (while (looking-at tags-file-pattern)
 578       (goto-char (match-end 0))
 579       (setq filename (file-name-sans-versions (match-string 1))
 580             ;; We used to check auto-mode-alist for the proper
 581             ;; file-type.  This was way too slow, as it had to process
 582             ;; an enormous amount of regexps for each time.  Now we
 583             ;; use the shotgun approach with only two regexps.
 584             file-type (cond ((string-match "\\.\\([cC]\\|cc\\|cxx\\)\\'"
 585                                            filename)
 586                              'c-mode)
 587                             ((string-match "\\.\\(el\\|cl\\|lisp\\)\\'"
 588                                            filename)
 589                              'lisp-mode)
 590                             ((string-match "\\.scm\\'" filename)
 591                              'scheme-mode)
 592                             (t nil)))
 593       (defvar c-mode-syntax-table)
 594       (set-syntax-table (cond ((and (eq file-type 'c-mode)
 595                                     c-mode-syntax-table)
 596                                c-mode-syntax-table)
 597                               ((eq file-type 'lisp-mode)
 598                                lisp-mode-syntax-table)
 599                               (t (standard-syntax-table))))
 600       ;; Clear loop variables.
 601       (setq name nil name2 nil name3 nil)
 602       (lmessage 'progress "%s..." filename)
 603       ;; Loop over the individual tag lines.
 604       (while (not (or (eobp) (eq (char-after) ?\f)))
 605         (cond ((and (eq file-type 'c-mode)
 606                     (looking-at "DEFUN[ \t]"))
 607                ;; DEFUN
 608                (or (looking-at tags-DEFUN-pattern)
 609                    (error "DEFUN doesn't fit pattern"))
 610                (setq name (match-string 1)
 611                      name2 (match-string 2)
 612                      name3 (match-string 5)))
 613               ;;((looking-at "\\s-")
 614               ;; skip probably bogus entry:
 615               ;;)
 616               ((and (eq file-type 'c-mode)
 617                     (looking-at ".*\\["))
 618                ;; Array
 619                (cond ((not (looking-at tags-array-pattern))
 620                       (message "array definition doesn't fit pattern")
 621                       (setq name nil))
 622                      (t
 623                       (setq name (match-string 1)))))
 624               ((and (eq file-type 'scheme-mode)
 625                     (looking-at tags-schemish-pattern))
 626                ;; Something Schemish (is this really necessary??)
 627                (setq name (match-string 1)
 628                      name2 (match-string 4)))
 629               ((looking-at tags-def-pattern)
 630                ;; ???
 631                (setq name (match-string 2)
 632                      name2 (match-string 5))))
 633         ;; add the tags we found to the completion table
 634         (and name (intern-tag-symbol name))
 635         (and name2 (intern-tag-symbol name2))
 636         (and name3 (intern-tag-symbol name3))
 637         (forward-line 1)))
 638     ;; Skip over the include entries at the bottom of the file.
 639     (while (looking-at tags-include-pattern)
 640       (goto-char (match-end 0))
 641       (setq filename (file-name-sans-versions (match-string 1)))
 642       (forward-line 1))
 643     (or (eobp) (error "Bad TAGS file")))
 644   (message "Adding %s to tags completion table...done" buffer-file-name))
 645
 646 \f
 647 ;; Interactive find-tag
 648
 649 (defvar find-tag-default-hook nil
 650   "Function to call to create a default tag.
 651 Make it buffer-local in a mode hook.  The function is called with no
 652  arguments.")
 653
 654 (defvar find-tag-hook nil
 655   "*Function to call after a tag is found.
 656 Make it buffer-local in a mode hook.  The function is called with no
 657  arguments.")
 658
 659 ;; Return a default tag to search for, based on the text at point.
 660 (defun find-tag-default ()
 661   (or (and (not (memq find-tag-default-hook '(nil find-tag-default)))
 662            (with-trapping-errors
 663              :function 'find-tag-default-hook
 664              :error-form nil
 665              (funcall find-tag-default-hook)))
 666       (symbol-near-point)))
 667
 668 ;; This function depends on the following symbols being bound properly:
 669 ;; buffer-tag-table-list,
 670 ;; tag-symbol-tables (value irrelevant, bound outside for efficiency)
 671 (defun tag-completion-predicate (tag-symbol)
 672   (and (boundp tag-symbol)
 673        (setq tag-symbol-tables (symbol-value tag-symbol))
 674        (catch 'found
 675          (while tag-symbol-tables
 676            (when (memq (car tag-symbol-tables) buffer-tag-table-list)
 677              (throw 'found t))
 678            (setq tag-symbol-tables (cdr tag-symbol-tables))))))
 679
 680 (defun buffer-tag-table-symbol-list ()
 681   (mapcar (lambda (table-name)
 682             (intern table-name tag-completion-table))
 683           (buffer-tag-table-list)))
 684
 685 (defvar find-tag-history nil "History list for find-tag-tag.")
 686
 687 (defun find-tag-tag (prompt)
 688   (let* ((default (find-tag-default))
 689          (buffer-tag-table-list (buffer-tag-table-symbol-list))
 690          tag-symbol-tables tag-name)
 691     (setq tag-name
 692           (completing-read
 693            (if default
 694                (format "%s(default %s) " prompt default)
 695              prompt)
 696            tag-completion-table 'tag-completion-predicate nil nil
 697            'find-tag-history default))
 698     tag-name))
 699
 700 (defvar last-tag-data nil
 701   "Information for continuing a tag search.
 702 Is of the form (TAG POINT MATCHING-EXACT TAG-TABLE TAG-TABLE ...).")
 703
 704 (defvar tags-loop-operate nil
 705   "Form for `tags-loop-continue' to eval to change one file.")
 706
 707 (defvar tags-loop-scan
 708   '(error "%s" (substitute-command-keys
 709                 "No \\[tags-search] or \\[tags-query-replace] in progress."))
 710   "Form for `tags-loop-continue' to eval to scan one file.
 711 If it returns non-nil, this file needs processing by evalling
 712 \`tags-loop-operate'.  Otherwise, move on to the next file.")
 713
 714 (autoload 'get-symbol-syntax-table "symbol-syntax")
 715
 716 (defun find-tag-internal (tagname)
 717
 718   (let ((next (null tagname))
 719         (tmpnext (null tagname))
 720         ;; If tagname is a list: (TAGNAME), this indicates
 721         ;; requiring an exact symbol match.
 722         (exact (or tags-always-exact (consp tagname)))
 723         (normal-syntax-table (syntax-table))
 724         (exact-syntax-table (get-symbol-syntax-table (syntax-table)))
 725         tag-table-currently-matching-exact
 726         tag-target exact-tagname
 727         tag-tables tag-table-point file linebeg line startpos buf
 728         offset found pat syn-tab)
 729     (when (consp tagname)
 730       (setq tagname (car tagname)))
 731     (cond (next
 732            (setq tagname (car last-tag-data))
 733            (setq tag-table-currently-matching-exact
 734                  (car (cdr (cdr last-tag-data)))))
 735           (t
 736            (setq tag-table-currently-matching-exact t)))
 737     ;; \_ in the tagname is used to indicate a symbol boundary.
 738     (if tags-exuberant-ctags-optimization-p
 739         (setq exact-tagname (format "\C-?%s\C-a" tagname))
 740       (setq exact-tagname (format "\C-?%s\C-a\\|\
 741 \\_%s.?\C-?[0-9]*,[0-9]*$" tagname tagname))
 742       )
 743     (while (string-match "\\\\_" exact-tagname)
 744       (aset exact-tagname (1- (match-end 0)) ?b))
 745     (save-excursion
 746       (catch 'found
 747         ;; Loop searching for exact matches and then inexact matches.
 748         (while (not (eq tag-table-currently-matching-exact 'neither))
 749           (cond (tmpnext
 750                  (setq tag-tables (cdr (cdr (cdr last-tag-data)))
 751                        tag-table-point (car (cdr last-tag-data)))
 752                  ;; Start from the beginning of the table list on the
 753                  ;; next iteration of the loop.
 754                  (setq tmpnext nil))
 755                 (t
 756                  (setq tag-tables (buffer-tag-table-list)
 757                        tag-table-point 1)))
 758           (if tag-table-currently-matching-exact
 759               (setq tag-target exact-tagname
 760                     syn-tab exact-syntax-table)
 761             (setq tag-target tagname
 762                   syn-tab normal-syntax-table))
 763           (with-search-caps-disable-folding tag-target t
 764             (while tag-tables
 765               (set-buffer (get-tag-table-buffer (car tag-tables)))
 766               (bury-buffer (current-buffer))
 767               (goto-char (or tag-table-point (point-min)))
 768               (setq tag-table-point nil)
 769               (letf (((syntax-table) syn-tab)
 770                      (case-fold-search nil))
 771                 ;; #### should there be support for non-regexp
 772                 ;; tag searches?
 773                 (while (re-search-forward tag-target nil t)
 774                   (and (save-match-data
 775                          (save-excursion
 776                            (goto-char (match-beginning 0))
 777                            (looking-at "[^\n\C-?]*\C-?")))
 778                        ;; If we're looking for inexact matches, skip
 779                        ;; exact matches since we've visited them
 780                        ;; already.
 781                        (or tag-table-currently-matching-exact
 782                            (letf (((syntax-table) exact-syntax-table))
 783                              (save-excursion
 784                                (goto-char (match-beginning 0))
 785                                (not (looking-at exact-tagname)))))
 786                        (throw 'found t))))
 787               (setq tag-tables (cdr tag-tables))))
 788           (if (and (not exact) (eq tag-table-currently-matching-exact t))
 789               (setq tag-table-currently-matching-exact nil)
 790             (setq tag-table-currently-matching-exact 'neither)))
 791         (error "No %sentries %s %s"
 792                (if next "more " "")
 793                (if exact "matching" "containing")
 794                tagname))
 795       (beginning-of-line)
 796
 797       ;; from here down, synched with FSF 20.7
 798       ;; etags-snarf-tag and etags-goto-tag-location. --ben
 799
 800       (if (save-excursion
 801             (forward-line -1)
 802             (looking-at "\f\n"))
 803           (progn
 804             ;; The match was for a source file name, not any tag
 805             ;; within a file.  Give text of t, meaning to go exactly
 806             ;; to the location we specify, the beginning of the file.
 807             (setq linebeg t
 808                   line nil
 809                   startpos 1)
 810             (setq file
 811                   (expand-file-name (file-of-tag)
 812                                     ;; In XEmacs, this needs to be
 813                                     ;; relative to:
 814                                     (or (file-name-directory (car tag-tables))
 815                                         "./"))))
 816         (search-forward "\C-?")
 817         (setq file
 818               (expand-file-name (file-of-tag)
 819                                 ;; In XEmacs, this needs to be
 820                                 ;; relative to:
 821                                 (or (file-name-directory (car tag-tables))
 822                                     "./")))
 823         (setq linebeg (buffer-substring (1- (point)) (point-at-bol)))
 824         ;; Skip explicit tag name if present.
 825         (search-forward "\001" (save-excursion (forward-line 1) (point)) t)
 826         (if (looking-at "[0-9]")
 827             (setq line (string-to-int (buffer-substring
 828                                        (point)
 829                                        (progn (skip-chars-forward "0-9")
 830                                               (point))))))
 831         (search-forward ",")
 832         (if (looking-at "[0-9]")
 833             (setq startpos (string-to-int (buffer-substring
 834                                            (point)
 835                                            (progn (skip-chars-forward "0-9")
 836                                                   (point)))))))
 837       ;; Leave point on the next line of the tags file.
 838       (forward-line 1)
 839       (setq last-tag-data
 840             (nconc (list tagname (point) tag-table-currently-matching-exact)
 841                    tag-tables))
 842       (setq buf (find-file-noselect file))
 843
 844       ;; LINEBEG is the initial part of a line containing the tag and
 845       ;; STARTPOS is the character position of LINEBEG within the file
 846       ;; (starting from 1); LINE is the line number.  If LINEBEG is t,
 847       ;; it means the tag refers to exactly LINE or STARTPOS
 848       ;; (whichever is present, LINE having preference, no searching).
 849       ;; Either LINE or STARTPOS may be nil; STARTPOS is used if
 850       ;; present.  If the tag isn't exactly at the given position then
 851       ;; look around that position using a search window which expands
 852       ;; until it hits the start of file.
 853
 854       (with-current-buffer buf
 855         (save-excursion
 856           (save-restriction
 857             (widen)
 858             (if (eq linebeg t)
 859                 ;; Direct file tag.
 860                 (cond (line (goto-line line))
 861                       (startpos (goto-char startpos))
 862                       (t (error "etags.el BUG: bogus direct file tag")))
 863               ;; Here we search for PAT in the range [STARTPOS - OFFSET,
 864               ;; STARTPOS + OFFSET], with increasing values of OFFSET.
 865               ;;
 866               ;; We used to set the initial offset to 1000, but the
 867               ;; actual sources show that finer-grained control is
 868               ;; needed (e.g. two `hash_string's in src/symbols.c.)  So,
 869               ;; I changed 1000 to 100, and (* 3 offset) to (* 5 offset).
 870               (setq offset 100)
 871               (setq pat (concat (if (eq selective-display t)
 872                                     "\\(^\\|\^m\\)" "^")
 873                                 (regexp-quote linebeg)))
 874
 875               ;; The character position in the tags table is 0-origin.
 876               ;; Convert it to a 1-origin Emacs character position.
 877               (if startpos (setq startpos (1+ startpos)))
 878               ;; If no char pos was given, try the given line number.
 879               (or startpos
 880                   (if line
 881                       (setq startpos (progn (goto-line line)
 882                                             (point)))))
 883               (or startpos
 884                   (setq startpos (point-min)))
 885               ;; First see if the tag is right at the specified location.
 886               (goto-char startpos)
 887               (setq found (looking-at pat))
 888               (while (and (not found)
 889                           (progn
 890                             (goto-char (- startpos offset))
 891                             (not (bobp))))
 892                 (setq found
 893                       (re-search-forward pat (+ startpos offset) t)
 894                       offset (* 5 offset))) ; expand search window
 895               ;; Finally, try finding it anywhere in the buffer.
 896               (or found
 897                   (re-search-forward pat nil t)
 898                   (error "Rerun etags: `%s' not found in %s"
 899                          pat file))))
 900           ;; Position point at the right place
 901           ;; if the search string matched an extra Ctrl-m at the beginning.
 902           (and (eq selective-display t)
 903                (looking-at "\^m")
 904                (forward-char 1))
 905           (beginning-of-line)
 906           (setq startpos (point))))
 907       (cons buf startpos))))
 908
 909 ;;;###autoload
 910 (defun find-tag-at-point (tagname &optional other-window)
 911   "*Find tag whose name contains TAGNAME.
 912 Identical to `find-tag' but does not prompt for tag when called interactively;
 913 instead, uses tag around or before point."
 914   (interactive (if current-prefix-arg
 915                    '(nil nil)
 916                  (list (find-tag-default) nil)))
 917   (find-tag tagname other-window))
 918
 919 ;;;###autoload
 920 (defun find-tag (tagname &optional other-window)
 921   "*Find tag whose name contains TAGNAME.
 922  Selects the buffer that the tag is contained in
 923 and puts point at its definition.
 924  If TAGNAME is a null string, the expression in the buffer
 925 around or before point is used as the tag name.
 926  If called interactively with a numeric argument, searches for the next tag
 927 in the tag table that matches the tagname used in the previous find-tag.
 928  If second arg OTHER-WINDOW is non-nil, uses another window to display
 929 the tag.
 930
 931 This version of this function supports multiple active tags tables,
 932 and completion.
 933
 934 Variables of note:
 935
 936   tag-table-alist               controls which tables apply to which buffers
 937   tags-file-name                a default tags table
 938   tags-build-completion-table   controls completion behavior
 939   buffer-tag-table              another way of specifying a buffer-local table
 940   make-tags-files-invisible     whether tags tables should be very hidden
 941   tag-mark-stack-max            how many tags-based hops to remember"
 942   (interactive (if current-prefix-arg
 943                    '(nil nil)
 944                  (list (find-tag-tag "Find tag: ") nil)))
 945   (let* ((local-find-tag-hook find-tag-hook)
 946          (next (null tagname))
 947          (result (find-tag-internal tagname))
 948          (tag-buf (car result))
 949          (tag-point (cdr result)))
 950     ;; Push old position on the tags mark stack.
 951     (if (or (not next)
 952             (not (memq last-command
 953                        '(find-tag find-tag-other-window tags-loop-continue))))
 954         (push-tag-mark))
 955     (if other-window
 956         (pop-to-buffer tag-buf t)
 957       (switch-to-buffer tag-buf))
 958     (widen)
 959     (push-mark)
 960     (goto-char tag-point)
 961     (if find-tag-hook
 962                 (run-hooks 'find-tag-hook)
 963       (if local-find-tag-hook
 964                   (run-hooks 'local-find-tag-hook))))
 965   (setq tags-loop-scan (list 'find-tag nil nil)
 966                 tags-loop-operate nil)
 967   ;; Return t in case used as the tags-loop-scan.
 968   t)
 969
 970 ;;;###autoload
 971 (defun find-tag-other-window (tagname &optional next)
 972   "*Find tag whose name contains TAGNAME, in another window.
 973  Selects the buffer that the tag is contained in in another window
 974 and puts point at its definition.
 975  If TAGNAME is a null string, the expression in the buffer
 976 around or before point is used as the tag name.
 977  If second arg NEXT is non-nil (interactively, with prefix arg),
 978 searches for the next tag in the tag table
 979 that matches the tagname used in the previous find-tag.
 980
 981 This version of this function supports multiple active tags tables,
 982 and completion.
 983
 984 Variables of note:
 985
 986   tag-table-alist               controls which tables apply to which buffers
 987   tags-file-name                a default tags table
 988   tags-build-completion-table   controls completion behavior
 989   buffer-tag-table              another way of specifying a buffer-local table
 990   make-tags-files-invisible     whether tags tables should be very hidden
 991   tag-mark-stack-max            how many tags-based hops to remember"
 992   (interactive (if current-prefix-arg
 993                    '(nil t)
 994                  (list (find-tag-tag "Find tag other window: "))))
 995   (if next
 996       (find-tag nil t)
 997     (find-tag tagname t)))
 998
 999 \f
1000 ;; Completion on tags in the buffer.
1001
1002 (defun complete-symbol (&optional table predicate prettify)
1003   (let* ((end (point))
1004          (beg (save-excursion
1005                 (backward-sexp 1)
1006                 ;;(while (= (char-syntax (following-char)) ?\')
1007                 ;;  (forward-char 1))
1008                 (skip-syntax-forward "'")
1009                 (point)))
1010          (pattern (buffer-substring beg end))
1011          (table (or table obarray))
1012          (completion (try-completion pattern table predicate)))
1013     (cond ((eq completion t))
1014           ((null completion)
1015            (error "Can't find completion for \"%s\"" pattern))
1016           ((not (string-equal pattern completion))
1017            (delete-region beg end)
1018            (insert completion))
1019           (t
1020            (message "Making completion list...")
1021            (let ((list (all-completions pattern table predicate)))
1022              (if prettify
1023                  (setq list (funcall prettify list)))
1024              (with-output-to-temp-buffer "*Help*"
1025                (display-completion-list list)))
1026            (message "Making completion list...%s" "done")))))
1027
1028 ;;;###autoload
1029 (defun tag-complete-symbol ()
1030   "The function used to do tags-completion (using 'tag-completion-predicate)."
1031   (interactive)
1032   (let* ((buffer-tag-table-list (buffer-tag-table-symbol-list))
1033          tag-symbol-tables)
1034     (complete-symbol tag-completion-table 'tag-completion-predicate)))
1035
1036 \f
1037 ;; Applying a command to files mentioned in tag tables
1038
1039 (defvar next-file-list nil
1040   "List of files for next-file to process.")
1041
1042 ;;;###autoload
1043 (defun next-file (&optional initialize novisit)
1044   "Select next file among files in current tag table(s).
1045
1046 A first argument of t (prefix arg, if interactive) initializes to the
1047 beginning of the list of files in the (first) tags table.  If the argument
1048 is neither nil nor t, it is evalled to initialize the list of files.
1049
1050 Non-nil second argument NOVISIT means use a temporary buffer
1051 to save time and avoid uninteresting warnings.
1052
1053 Value is nil if the file was already visited;
1054 if the file was newly read in, the value is the filename."
1055   (interactive "P")
1056   (cond ((not initialize)
1057          ;; Not the first run.
1058          )
1059         ((eq initialize t)
1060          ;; Initialize the list from the tags table.
1061          (setq next-file-list (buffer-tag-table-files)))
1062         (t
1063          ;; Initialize the list by evalling the argument.
1064          (setq next-file-list (eval initialize))))
1065   (when (null next-file-list)
1066     (and novisit
1067          (get-buffer " *next-file*")
1068          (kill-buffer " *next-file*"))
1069     (error "All files processed"))
1070   (let* ((file (car next-file-list))
1071          (buf (get-file-buffer file))
1072          (new (not buf)))
1073     (pop next-file-list)
1074
1075     (if (not (and new novisit))
1076         (switch-to-buffer (find-file-noselect file novisit) t)
1077       ;; Like find-file, but avoids random junk.
1078       (set-buffer (get-buffer-create " *next-file*"))
1079       (kill-all-local-variables)
1080       (erase-buffer)
1081       (insert-file-contents file nil))
1082     (widen)
1083     (when (> (point) (point-min))
1084       (push-mark nil t)
1085       (goto-char (point-min)))
1086     (and new file)))
1087
1088 ;;;###autoload
1089 (defun tags-loop-continue (&optional first-time)
1090   "Continue last \\[tags-search] or \\[tags-query-replace] command.
1091 Used noninteractively with non-nil argument to begin such a command (the
1092 argument is passed to `next-file', which see).
1093 Two variables control the processing we do on each file:
1094 the value of `tags-loop-scan' is a form to be executed on each file
1095 to see if it is interesting (it returns non-nil if so)
1096 and `tags-loop-operate' is a form to execute to operate on an interesting file
1097 If the latter returns non-nil, we exit; otherwise we scan the next file."
1098   (interactive)
1099   (let ((messaged nil)
1100         (more-files-p t)
1101         new)
1102     (while more-files-p
1103       ;; Scan files quickly for the first or next interesting one.
1104       (while (or first-time
1105                  (save-restriction
1106                    (widen)
1107                    (not (eval tags-loop-scan))))
1108         (setq new (next-file first-time
1109                              tags-search-nuke-uninteresting-buffers))
1110         ;; If NEW is non-nil, we got a temp buffer,
1111         ;; and NEW is the file name.
1112         (if (or messaged
1113                 (and (not first-time)
1114                      (> (device-baud-rate) search-slow-speed)
1115                      (setq messaged t)))
1116             (lmessage 'progress
1117                 "Scanning file %s..." (or new buffer-file-name)))
1118         (setq first-time nil)
1119         (goto-char (point-min)))
1120
1121       ;; If we visited it in a temp buffer, visit it now for real.
1122       (if (and new tags-search-nuke-uninteresting-buffers)
1123           (let ((pos (point)))
1124             (erase-buffer)
1125             (set-buffer (find-file-noselect new))
1126             (widen)
1127             (goto-char pos)))
1128
1129       (switch-to-buffer (current-buffer))
1130
1131       ;; Now operate on the file.
1132       ;; If value is non-nil, continue to scan the next file.
1133       (setq more-files-p (eval tags-loop-operate)))
1134     (and messaged
1135          (null tags-loop-operate)
1136          (message "Scanning file %s...found" buffer-file-name))))
1137
1138
1139 ;;;###autoload
1140 (defun tags-search (regexp &optional file-list-form)
1141   "Search through all files listed in tags table for match for REGEXP.
1142 Stops when a match is found.
1143 To continue searching for next match, use command \\[tags-loop-continue].
1144
1145 See documentation of variable `tag-table-alist'."
1146   (interactive "sTags search (regexp): ")
1147   (if (and (equal regexp "")
1148            (eq (car tags-loop-scan) 'with-search-caps-disable-folding)
1149            (null tags-loop-operate))
1150       ;; Continue last tags-search as if by `M-,'.
1151       (tags-loop-continue nil)
1152     (setq tags-loop-scan `(with-search-caps-disable-folding ,regexp t
1153                             (re-search-forward ,regexp nil t))
1154           tags-loop-operate nil)
1155     (tags-loop-continue (or file-list-form t))))
1156
1157 ;;;###autoload
1158 (defun tags-query-replace (from to &optional delimited file-list-form)
1159   "Query-replace-regexp FROM with TO through all files listed in tags table.
1160 Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
1161 If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace
1162 with the command \\[tags-loop-continue].
1163
1164 See documentation of variable `tag-table-alist'."
1165   (interactive
1166    "sTags query replace (regexp): \nsTags query replace %s by: \nP")
1167   (setq tags-loop-scan `(with-search-caps-disable-folding ,from t
1168                           (if (re-search-forward ,from nil t)
1169                               ;; When we find a match, move back
1170                               ;; to the beginning of it so perform-replace
1171                               ;; will see it.
1172                               (progn (goto-char (match-beginning 0)) t)))
1173         tags-loop-operate (list 'perform-replace from to t t
1174                                 (not (null delimited))))
1175    (tags-loop-continue (or file-list-form t)))
1176 \f
1177 ;; Miscellaneous
1178
1179 ;;;###autoload
1180 (defun list-tags (file)
1181   "Display list of tags in FILE."
1182   (interactive (list (read-file-name
1183                       (if (buffer-file-name)
1184                           (format "List tags (in file, %s by default): "
1185                                   (file-name-nondirectory (buffer-file-name)))
1186                         "List tags (in file): ")
1187                       nil (buffer-file-name) t)))
1188   (find-file-noselect file)
1189   (with-output-to-temp-buffer "*Tags List*"
1190     (princ "Tags in file ")
1191     (princ file)
1192     (terpri)
1193     (save-excursion
1194       (dolist (tags-file (with-current-buffer (get-file-buffer file)
1195                            (buffer-tag-table-list)))
1196         ;; We don't want completions getting in the way.
1197         (let ((tags-build-completion-table nil))
1198           (set-buffer (get-tag-table-buffer tags-file)))
1199         (goto-char (point-min))
1200         (when
1201             (search-forward (concat "\f\n" (file-name-nondirectory file) ",")
1202                             nil t)
1203           (forward-line 1)
1204           (while (not (or (eobp) (looking-at "\f")))
1205             (princ (buffer-substring (point)
1206                                      (progn (skip-chars-forward "^\C-?")
1207                                             (point))))
1208             (terpri)
1209             (forward-line 1)))))))
1210
1211 ;;;###autoload
1212 (defun tags-apropos (string)
1213   "Display list of all tags in tag table REGEXP matches."
1214   (interactive "sTag apropos (regexp): ")
1215   (with-output-to-temp-buffer "*Tags List*"
1216     (princ "Tags matching regexp ")
1217     (prin1 string)
1218     (terpri)
1219     (save-excursion
1220       (visit-tags-table-buffer)
1221       (goto-char 1)
1222       (while (re-search-forward string nil t)
1223         (beginning-of-line)
1224         (princ (buffer-substring (point)
1225                                  (progn (skip-chars-forward "^\C-?")
1226                                         (point))))
1227         (terpri)
1228         (forward-line 1)))))
1229
1230 ;; #### copied from tags.el.  This function is *very* big in FSF.
1231 (defun visit-tags-table-buffer ()
1232   "Select the buffer containing the current tag table."
1233   (or tags-file-name
1234       (call-interactively 'visit-tags-table))
1235   (set-buffer (or (get-file-buffer tags-file-name)
1236                   (progn
1237                     (setq tag-table-files nil)
1238                     (find-file-noselect tags-file-name))))
1239   (or (verify-visited-file-modtime (get-file-buffer tags-file-name))
1240       (cond ((yes-or-no-p "Tags file has changed, read new contents? ")
1241              (revert-buffer t t)
1242              (setq tag-table-files nil))))
1243   (or (eq (char-after 1) ?\^L)
1244       (error "File %s not a valid tag table" tags-file-name)))
1245
1246 \f
1247 ;; Sample uses of find-tag-hook and find-tag-default-hook
1248
1249 ;; This is wrong.  We should either make this behavior default and
1250 ;; back it up, or not use it at all.  For now, I've commented it out.
1251 ;; --hniksic
1252
1253 ;; Example buffer-local tag finding
1254
1255 ;(add-hook 'emacs-lisp-mode-hook 'setup-emacs-lisp-default-tag-hook)
1256
1257 ;(defun setup-emacs-lisp-default-tag-hook ()
1258 ;  (cond ((eq major-mode 'emacs-lisp-mode)
1259 ;        (make-variable-buffer-local 'find-tag-default-hook)
1260 ;        (setq find-tag-default-hook 'emacs-lisp-default-tag))))
1261 ;;; Run it once immediately
1262 ;(setup-emacs-lisp-default-tag-hook)
1263 ;(when (get-buffer "*scratch*")
1264 ;  (with-current-buffer "*scratch*"
1265 ;    (setup-emacs-lisp-default-tag-hook)))
1266
1267 ;(defun emacs-lisp-default-tag ()
1268 ;  "Function to return a default tag for Emacs-Lisp mode."
1269 ;  (let ((tag (or (variable-at-point)
1270 ;                (function-at-point))))
1271 ;    (if tag (symbol-name tag))))
1272
1273 \f
1274 ;; Display short info on tag in minibuffer
1275
1276 ;; Don't pollute `M-?' -- we may need it for more important stuff.  --hniksic
1277 ;(if (null (lookup-key esc-map "?"))
1278 ;    (define-key esc-map "?" 'display-tag-info))
1279
1280 (defun display-tag-info (tagname)
1281   "Prints a description of the first tag matching TAGNAME in the echo area.
1282 If this is an elisp function, prints something like \"(defun foo (x y z)\".
1283 That is, is prints the first line of the definition of the form.
1284 If this is a C-defined elisp function, it does something more clever."
1285   (interactive (if current-prefix-arg
1286                    '(nil)
1287                  (list (find-tag-tag "Display tag info: "))))
1288   (let* ((results (find-tag-internal tagname))
1289          (tag-buf (car results))
1290          (tag-point (cdr results))
1291          info lname min max fname args)
1292     (with-current-buffer tag-buf
1293       (save-excursion
1294         (save-restriction
1295           (widen)
1296           (goto-char tag-point)
1297           (cond ((let ((case-fold-search nil))
1298                    (looking-at "^DEFUN[ \t]"))
1299                  (forward-sexp 1)
1300                  (down-list 1)
1301                  (setq lname (read (current-buffer))
1302                        fname (buffer-substring
1303                               (progn (forward-sexp 1) (point))
1304                               (progn (backward-sexp 1) (point)))
1305                        min (buffer-substring
1306                             (progn (forward-sexp 3) (point))
1307                             (progn (backward-sexp 1) (point)))
1308                        max (buffer-substring
1309                             (progn (forward-sexp 2) (point))
1310                             (progn (backward-sexp 1) (point))))
1311                  (backward-up-list 1)
1312                  (setq args (buffer-substring
1313                              (progn (forward-sexp 2) (point))
1314                              (progn (backward-sexp 1) (point))))
1315                  (setq info (format "Elisp: %s, C: %s %s, #args: %s"
1316                                     lname
1317                                     fname args
1318                                     (if (string-equal min max)
1319                                         min
1320                                       (format "from %s to %s" min max)))))
1321                 (t
1322                  (setq info
1323                        (buffer-substring
1324                         (progn (beginning-of-line) (point))
1325                         (progn (end-of-line) (point)))))))))
1326     (message "%s" info))
1327   (setq tags-loop-scan '(display-tag-info nil)
1328         tags-loop-operate nil)
1329   ;; Always return non-nil
1330   t)
1331
1332 \f
1333 ;; Tag mark stack.
1334
1335 (defvar tag-mark-stack1 nil)
1336 (defvar tag-mark-stack2 nil)
1337
1338 (defcustom tag-mark-stack-max 16
1339   "*The maximum number of elements kept on the mark-stack used
1340 by tags-search.  See also the commands `\\[push-tag-mark]' and
1341 and `\\[pop-tag-mark]'."
1342   :type 'integer
1343   :group 'etags)
1344
1345 (defun push-mark-on-stack (stack-symbol &optional max-size)
1346   (let ((stack (symbol-value stack-symbol)))
1347     (push (point-marker) stack)
1348     (cond ((and max-size
1349                 (> (length stack) max-size))
1350            (set-marker (car (nthcdr max-size stack)) nil)
1351            (setcdr (nthcdr (1- max-size) stack) nil)))
1352     (set stack-symbol stack)))
1353
1354 (defun pop-mark-from-stack (stack-symbol1 stack-symbol2 &optional max-size)
1355   (let* ((stack (or (symbol-value stack-symbol1)
1356                     (error "No more tag marks on stack")))
1357          (marker (car stack))
1358          (m-buf (marker-buffer marker)))
1359     (set stack-symbol1 (cdr stack))
1360     (or m-buf
1361         (error "Marker has no buffer"))
1362     (or (buffer-live-p m-buf)
1363         (error "Buffer has been killed"))
1364     (push-mark-on-stack stack-symbol2 max-size)
1365     (switch-to-buffer m-buf)
1366     (widen)
1367     (goto-char marker)))
1368
1369 (defun push-tag-mark ()
1370   (push-mark-on-stack 'tag-mark-stack1 tag-mark-stack-max))
1371
1372 ;;;###autoload (define-key esc-map "*" 'pop-tag-mark)
1373
1374 ;;;###autoload
1375 (defun pop-tag-mark (arg)
1376   "Go to last tag position.
1377 `find-tag' maintains a mark-stack seperate from the \\[set-mark-command] mark-stack.
1378 This function pops (and moves to) the tag at the top of this stack."
1379   (interactive "P")
1380   (if (not arg)
1381       (pop-mark-from-stack
1382        'tag-mark-stack1 'tag-mark-stack2 tag-mark-stack-max)
1383     (pop-mark-from-stack
1384      'tag-mark-stack2 'tag-mark-stack1 tag-mark-stack-max)))
1385
1386 \f
1387 (provide 'etags)
1388 (provide 'tags)
1389
1390 ;;; etags.el ends here