🚀 go-pugleaf

(I originally posted this on Friday, but my news poster (GNUS) put in a
distribution of "local" which I didn't notice until yesterday.  Arrgh!)

This is a huge rewrite of lisp/tags.el

It has these enhancements over the distributed version:

    Handles any number of separate tags files at the same time.  You can
    specify in an arbitrary manner which tags files are to be used for
    each buffer, and in which order for looking up tags.  You can share
    tags files any way you want.

    Tag lookups using regular expressions.  Also provides support for
    matching on exact symbol boundaries.  This is useful in addition to
    matching on "word" boundaries, because characters like "_" are not
    considered part of a word in C mode.

    Tag name completion.  Also available in the buffer, not just when
    looking up tags.  (This is similar to the M-TAB facility with Emacs
    Lisp.)

    Stack of places visited for backtracking tags lookups (and
    backtracking the backtracking).

    A function that looks up a tag, and instead of displaying it in
    another window, simply shows the first line of the tag.  This is good
    for remembering what arguments shows a function takes.  For Emacs C
    DEFUN functions, it displays a short summary.

    Miscellaneous fixes/enhancements to find-tag-default, tags-search.

    Find tag hooks.

Many of the ideas which I am assembling together came
from articles posted to the net in the last couple of years.

I'm posting it initially in this group.  After I feel assured that it is
relatively bug-free, and after I have finished documenting it properly (!),
I'll post it in gnu.emacs and comp.emacs.

Of course, please send me bugs you find (ideally with fixes!), and any
complaints or suggestions (or code!).

There are two files: tags-fix.el, symbol-syntax.el.

If I have forgotten to include any other of my functions to which the code
refers, please send me a nasty note about it!

-- 
Joe Wells <jbw@uswest.com>
----------tags-fix.el follows:----------------------------------------
;; Enhanced tags facility for Emacs.
;; Copyright 1985, 1986, 1988, 1990 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; 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.

;; Created by: Joe Wells, jbw@bucsf.bu.edu
;; Created on: Thu Mar 22 20:17:40 1990
;; Last modified by: JBW, JBW@_CORTEZ
;; Last modified on: Mon Jun 25 17:23:20 1990
;; Filename: TAGS-FIX.EL
;; Purpose: enhanced tags functionality

;; enhancements:
;;  1. default tag tables based on filename
;;  2. multiple tag tables possible per file
;;  3. tag name completion for find-tag
;;  4. find-tag using regexp
;;  5. tag name completion in the buffer
;;  6. find-tag-default now works at beginning of tag
;;  7. buffer-local find-tag hook (used for info enhancement)
;;  8. buffer-local find-tag-default hook (used for info enhancement)
;;  9. show short info on tag match in minibuffer
;; 10. stack for backtracking from find-tag
;; 11. widen buffers for tags-search
;; 12. display message on successful search
;; 13. don't pull all files into memory for tags-search
;; 14. don't leave searched buffers on top of buffer list
;; 15. find-tag can specify exact symbol matches
;; 16. find-tag-default specifies an exact symbol match

;; TODO:
;; 1. place cursor in echo area while searching
;; 2. document!
;; 3. determine semantics of interactively setting the tags file for a buffer

;; Comments with **** mean something is left to be done.

;; Derived from the original lisp/tags.el.

;; Ideas and code from the work of the following people:
;; Andy Norman <ange@hplb.hpl.hp.com>, author of ange-tags.el
;; Ramana Rao <rao@arisia.xerox.com>
;; John Sturdy <jcgs@harlqn.co.uk>, author of tags-helper.el
;; Henry Kautz <kautz@allegra.att.com>, author of tag-completion.el
;; Dan LaLiberte <liberte@cs.uiuc.edu>, author of local-tags.el
;; Tom Dietterich <tgd@turing.cs.orst.edu>, author of quest.el
;; The author(s) of lisp/simple.el
;; Duke Briscoe <briscoe@cs.yale.edu>
;; Lynn Slater <lrs@indetech.com>, author of location.el
;; Shinichirou Sugou <shin@sgtp.apple.juice.or.jp>
;; an unidentified anonymous elisp hacker

(provide 'tags-fix)


;; Auxiliary functions

;; **** will this name conflict?
(defun delete (item list)
  "Foo"
  (cond ((null list)
	 nil)
	((equal item (car list))
	 (delete item (cdr list)))
	(t
	 (cons (car list) (delete item (cdr list))))))

(defun remove-duplicates (list)
  "Foo"
  (cond ((null list)
	 nil)
	(t
	 (cons (car list)
	       (remove-duplicates (delete (car list) (cdr list)))))))

;; derived from generate-new-buffer
(defun generate-new-buffer-name (name)
  "Foo"
  (if (not (get-buffer name))
      name
    (let ((count 1)
	  (template (concat name "<%d>"))
	  tempname)
      (catch 'found
	(while t
	  (setq tempname (format template count))
	  (if (not (get-buffer tempname))
	      (throw 'found tempname))
	  (setq count (1+ count)))))))


;; Tag tables for a buffer

(defvar tag-table-alist nil
  "Foo")
;;(setq tag-table-alist
;;      '(
;;	("/usr/src/public/perl/" . "/usr/src/public/perl/perl-3.0/")
;;	("\\.el\\'" . "/usr/local/emacs/src/")
;;	("/jbw/gnu/" . "/usr15/degree/stud/jbw/gnu/")
;;	("" . "/usr/local/emacs/src/")
;;	))

(defvar buffer-tag-table nil
  "Foo")
(make-variable-buffer-local 'buffer-tag-table)

(defvar tags-file-name nil
  "Foo")
(setq tags-file-name nil)

(defun buffer-tag-table-list ()
  (let (result)
    (if buffer-tag-table
	(setq result (cons buffer-tag-table result)))
    (if (file-readable-p (concat default-directory "TAGS"))
	(setq result (cons (concat default-directory "TAGS") result)))
    (let ((key (or buffer-file-name
		   (concat default-directory (buffer-name))))
	  (alist tag-table-alist))
      (while alist
	;; **** handle arbitrary expressions
	(if (string-match (car (car alist)) key)
	    (if (not (stringp (cdr (car alist))))
		(error "Illegal entry in tag-table-alist")
	      (setq result (cons (cdr (car alist)) result))))
	(setq alist (cdr alist))))
    (if tags-file-name
	(setq result (cons tags-file-name result)))
    (setq result
	  (mapcar
	   (function
	    (lambda (name)
	      (save-excursion
		(set-buffer (get-tag-table-buffer name))
		(buffer-file-name))))
	   result))
    (remove-duplicates (nreverse result))))

;; **** What should the semantics of this be?
(defun set-buffer-tag-table (file)
  "Foo"
  (interactive
   (list
     (read-file-name "Visit tags table: (directory sufficient) "
		     nil default-directory t)))
  (or file (error "No TAGS file name supplied"))
  (setq file (expand-file-name file))
  (if (file-directory-p file)
      (setq file (concat file "TAGS")))
  (or (file-exists-p file) (error "TAGS file missing: %s" file))
  (setq buffer-tag-table file))


;; Manipulating the tag table buffer

(defvar tag-table-completion-status nil
  "Foo")
(make-variable-buffer-local 'tag-table-completion-status)

(require 'symlink-fix)

(defun get-tag-table-buffer (tag-table)
  "Foo"
  (or tag-table (error "No TAGS file name supplied"))
  (if (file-directory-p tag-table)
      (setq tag-table (concat tag-table "TAGS")))
  ;; add support for removing symbolic links from name
  (setq tag-table (symlink-expand-file-name tag-table))
  (let (buf build-completion check-name)
    (setq buf (get-file-buffer tag-table))
    (or buf
	(setq buf (find-file-noselect tag-table)
	      check-name t))
    (save-excursion
      (set-buffer buf)
      ;; make the TAGS buffer invisible
      (if (and check-name (string-match "\\`[^ ]" (buffer-name)))
	  (rename-buffer (generate-new-buffer-name
			  (concat " " (buffer-name)))))
      (or (verify-visited-file-modtime buf)
	  (cond ((yes-or-no-p "Tags file has changed, read new contents? ")
		 (revert-buffer t t)
		 (if (eq tag-table-completion-status t)
		     (setq tag-table-completion-status nil))
		 (setq tag-table-files nil))))
      (or (eq (char-after 1) ?\f)
	  (error "File %s not a valid tag table" tag-table))
      (or (memq tag-table-completion-status '(t disabled))
	  (setq build-completion t))
      (and build-completion
	   (if (or (< (buffer-size) 20000)
		   (y-or-n-p
		    (format "Build tag completion table for %s? " tag-table)))
	       (condition-case foo
		   (progn
		     (add-to-tag-completion-table)
		     (setq tag-table-completion-status t))
		 ;; Allow user to C-g out correctly
		 (quit
		  (setq tag-table-completion-status nil)
		  (setq quit-flag t)
		  (eval t)))
	     (setq tag-table-completion-status 'disabled))))
    buf))

;; This function is unchanged from lisp/tags.el:
(defun file-of-tag ()
  "Return the file name of the file whose tags point is within.
Assumes the tag table is the current buffer.
File name returned is relative to tag table file's directory."
  (let ((opoint (point))
	prev size)
    (save-excursion
     (goto-char (point-min))
     (while (< (point) opoint)
       (forward-line 1)
       (end-of-line)
       (skip-chars-backward "^,\n")
       (setq prev (point))
       (setq size (read (current-buffer)))
       (goto-char prev)
       (forward-line 1)
       (forward-char size))
     (goto-char (1- prev))
     (buffer-substring (point)
		       (progn (beginning-of-line) (point))))))

(defvar tag-table-files nil
  "Foo")
(make-variable-buffer-local 'tag-table-files)

(defun tag-table-files (tag-table)
  "Foo"
  (save-excursion
    (set-buffer (get-tag-table-buffer tag-table))
    (or tag-table-files
	(let (files)
	  (goto-char (point-min))
	  (while (not (eobp))
	    (forward-line 1)
	    (end-of-line)
	    (skip-chars-backward "^,\n")
	    (setq prev (point))
	    (setq size (read (current-buffer)))
	    (goto-char prev)
	    (setq files (cons (expand-file-name
			       (buffer-substring (1- (point))
						 (save-excursion
						   (beginning-of-line)
						   (point)))
			       default-directory)
			      files))
	    (forward-line 1)
	    (forward-char size))
	  (setq tag-table-files (nreverse files))))
    tag-table-files))

;; **** should this be on previous page?
(defun buffer-tag-table-files ()
  "Foo"
  (let ((tag-tables (buffer-tag-table-list))
	result)
    (while tag-tables
      (setq result (nconc result
			  (copy-sequence (tag-table-files (car tag-tables)))))
      (setq tag-tables (cdr tag-tables)))
    result))


;; Building the completion table

;; Test cases for building completion table; must handle these properly:
;; Lisp_Int, XSETINT, current_column 60,2282
;;	   Lisp_Int, XSETINT, point>NumCharacters ? 0 : CharAt(363,9935
;;	   Lisp_Int, XSETINT, point<=FirstCharacter ? 0 : CharAt(366,10108
;;	 point<=FirstCharacter || CharAt(378,10630
;;	 point>NumCharacters || CharAt(382,10825
;; DEFUN ("x-set-foreground-color", Fx_set_foreground_color,191,4562
;; DEFUN ("x-set-foreground-color", Fx_set_foreground_color,191,4562
;; DEFUN ("*", Ftimes,1172,32079
;; DEFUN ("/=", Fneq,1035,28839
;; int pure[PURESIZE / sizeof 53,1564
;; char staticvec1[NSTATICS * sizeof 667,17608
;;  Date: 04 May 87 23:53:11 PDT 26,1077
;; #define anymacroname(324,4344
;; (define-key ctl-x-map 311,11784
;; (define-abbrev-table 'c-mode-abbrev-table 24,1016
;; static char *skip_white(116,3443
;; static foo 348,11643
;; (defun texinfo-insert-@code 91,3358
;; (defvar texinfo-kindex)29,1105
;; (defun texinfo-format-\. 548,18376
;; (defvar sm::menu-kludge-y 621,22726
;; (defvar *mouse-drag-window* 103,3642
;; (defun simula-back-level(317,11263

;; "^[^ ]+ +\\([^ ]+\\) "

(defvar tag-completion-table (make-vector 511 0) "Foo")

;; make two versions of this, macro and non-macro,
;; and have the correct one used depending whether it's byte compiled
(defmacro intern-tag-symbol (tag)
  (`(progn
      (setq tag-symbol (intern (, tag) tag-completion-table)
	    tag-symbol-tables (and (boundp tag-symbol)
				   (symbol-value tag-symbol)))
      (or (memq tag-table-symbol tag-symbol-tables)
	  (set tag-symbol (cons tag-table-symbol tag-symbol-tables))))))

(defun intern-tag-symbol2 (tag)
  (setq tag-symbol (intern tag tag-completion-table)
	tag-symbol-tables (and (boundp tag-symbol)
			       (symbol-value tag-symbol)))
  (or (memq tag-table-symbol tag-symbol-tables)
      (set tag-symbol (cons tag-table-symbol tag-symbol-tables))))

;; This won't be evaluated at during byte-compilation, thus ensuring the
;; macro version will be used then.  Since the macro version is too slow
;; to use unless its usages are byte-compiled, we want to make sure we use
;; the non-macro version if we are using the non byte-compiled version of
;; add-to-tag-completion-table.
(fset 'intern-tag-symbol (symbol-function 'intern-tag-symbol2))

;; Can't use "\\s " in these patterns because that will include newline
(setq tags-DEFUN-pattern
      "DEFUN[ \t]*(\"\\([^\"]+\\)\",[ \t]*\\(\\(\\sw\\|\\s_\\)+\\),\C-?")
(setq tags-array-pattern ".*[ \t]+\\([^ \[]+\\)\\[")
(setq tags-def-pattern
      "\\(.*[ \t]+\\)?\\(\\(\\sw\\|\\s_\\)+\\)[ ()]*\C-?")
;; "\\(\\sw\\|\\s_\\)+[ ()]*\C-?"
(setq tags-file-pattern "^\f\n\\([^,]+\\),[0-9]+\n")

(defun add-to-tag-completion-table ()
  "Foo"
  ;; assume TAGS file in current buffer
  (message "Adding %s to tags completion table..."
	   buffer-file-name)
  (goto-char (point-min))
  (let ((tag-table-symbol (intern buffer-file-name tag-completion-table))
	(original-syntax-table (syntax-table))
	;; tag-table-symbol is used by intern-tag-symbol
	filename file-type name name2 tag-symbol eol-point
	tag-symbol-tables file-type-syntax-table)
    (unwind-protect
	;; loop over the files mentioned in the TAGS file
	;; for each file, try to find its major-mode,
	;; then process tags appropriately
	(while (looking-at tags-file-pattern)
	  (goto-char (match-end 0))
	  (setq filename (buffer-substring (match-beginning 1) (match-end 1)))
	  (setq filename (file-name-sans-versions filename))
	  ;; clear loop variables
	  (setq file-type nil)
	  (setq file-type-syntax-table nil)
	  (setq name nil name2 nil)
	  (let ((alist auto-mode-alist)
		(case-fold-search (eq system-type 'vax-vms)))
	    ;; loop over pairs of regexps and major-modes
	    (while (and (not file-type) alist)
	      (if (string-match (car (car alist)) filename)
		  (setq file-type (cdr (car alist))))
	      (setq alist (cdr alist))))
	  ;; try to find a syntax table whose name begins with the major-mode
	  (if file-type
	      (setq file-type-syntax-table
		    (intern (concat (symbol-name file-type)
				    "-syntax-table"))))
	  ;;	  (message "%s %s" filename file-type-syntax-table)
	  (if (and file-type-syntax-table (boundp file-type-syntax-table))
	      (set-syntax-table (symbol-value file-type-syntax-table))
	    (set-syntax-table (standard-syntax-table)))
	  ;; loop over the individual tag lines
	  (while (not (or (eobp) (eq (following-char) ?\f)))
	    (cond ((and (eq file-type 'c-mode)
			(looking-at "DEFUN"))
		   (or (looking-at tags-DEFUN-pattern)
		       (error "DEFUN doesn't fit pattern"))
		   (setq name (buffer-substring (match-beginning 1)
						(match-end 1)))
		   (setq name2 (buffer-substring (match-beginning 2)
						 (match-end 2))))
		  ((looking-at "\\s ")
		   ;; skip probably bogus entry:
		   )
		  ((and (eq file-type 'c-mode)
			(looking-at ".*\\["))
		   (or (looking-at tags-array-pattern)
		       (error "array definition doesn't fit pattern"))
		   (setq name (buffer-substring (match-beginning 1)
						(match-end 1))))
		  ((looking-at tags-def-pattern)
		   (setq name (buffer-substring (match-beginning 2)
						(match-end 2)))))
	    ;; add the tags we found to the completion table
	    (if name (intern-tag-symbol name))
	    (if name2 (intern-tag-symbol name2))
	    (forward-line 1)))
      (set-syntax-table original-syntax-table))
    (or (eobp) (error "Bad TAGS file")))
  (message "Adding %s to tags completion table...done"
	   buffer-file-name))


;; Interactive find-tag

(defvar find-tag-default-hook 'find-tag-default
  "****Function to call to create a default tag.
Make it buffer-local in a mode hook.
The function is called with no args.")

(defvar find-tag-hook nil
  "****Function to call after a hook is found.
Make it buffer-local in a mode hook.
The function is called with no args.")

;; Return a default tag to search for, based on the text at point.
(defun find-tag-default ()
  (save-excursion
    (if (not (memq (char-syntax (preceding-char)) '(?w ?_)))
	(while (not (looking-at "\\sw\\|\\s_\\|\\'"))
	  (forward-char 1)))
    (while (looking-at "\\sw\\|\\s_")
      (forward-char 1))
    (if (re-search-backward "\\sw\\|\\s_" nil t)
	(regexp-quote
	 (progn (forward-char 1)
		(buffer-substring (point)
				  (progn (forward-sexp -1)
					 (while (looking-at "\\s'")
					   (forward-char 1))
					 (point)))))
      nil)))

;;"\\(\\s \\|\\s.\\|\\s\(\\|\\s\)\\|\\s'\\|\\s\"\\|\\s$\\|\\s/\\|\\s\\\\|\\s<\\|\\s>\\)"
;;"[ \";]"

;;(defun non-symbol-char-regexp ()
;;  (let ((i 0)
;;	(numchars (length (syntax-table)))
;;	symbol-chars)
;;    (while (< i numchars)
;;      (if (memq (char-syntax i) '(?w ?_))
;;	  (setq symbol-chars (cons i symbol-chars)))
;;      (setq i (1+ i)))
;;    (concat symbol-chars)))

;; This function depends on the following symbols being bound properly:
;; buffer-tag-table-list,
;; tag-symbol-tables (value irrelevant, bound outside for efficiency)
(defun tag-completion-predicate (tag-symbol)
  (setq tag-symbol-tables (symbol-value tag-symbol))
  (catch 'found
    (while tag-symbol-tables
      (if (memq (car tag-symbol-tables) buffer-tag-table-list)
	  (throw 'found t))
      (setq tag-symbol-tables (cdr tag-symbol-tables)))))

(defun buffer-tag-table-symbol-list ()
  (mapcar (function
	   (lambda (table-name)
	     (intern table-name tag-completion-table)))
	  (buffer-tag-table-list)))
    
(defun strip-regexp-border (pattern)
  ;; Avoid displaying ugly regexp borders to the user
  (cond (pattern
	 (if (or (string-match "\\`\\[[^\]]+\\]" pattern)
		 ;;(string-match "\\`\\\\(\\([^\\\\]\\|\\\\[^\)]\\)+\\\\)"
		 ;;              pattern)
		 ;;(string-match "\\`\\\\[b<>`'WsS]" pattern)
		 )
	     (setq pattern (substring pattern
				      (match-end 0))))
	 (if (or (string-match "\\[[^\]]+\\]\\'" pattern)
		 ;;(string-match "\\\\(\\([^\\\\]\\|\\\\[^\)]\\)+\\\\)\\'"
		 ;;              pattern)
		 ;;(string-match "\\\\[b<>`'WsS]\\'" pattern)
		 )
	     (setq pattern (substring pattern 0
				      (match-beginning 0))))))
  pattern)

(defun find-tag-tag (prompt)
  (let* ((default (if find-tag-default-hook
		      (funcall find-tag-default-hook)
		    (find-tag-default)))
	 (buffer-tag-table-list (buffer-tag-table-symbol-list))
	 tag-symbol-tables tag-name)
    (setq tag-name
	  (completing-read
	   (if default
	       (format "%s(default %s) " prompt default)
	     prompt)
	   tag-completion-table 'tag-completion-predicate nil nil))
    (if (string-equal tag-name "")
	(concat "\\_" default "\\_")
      tag-name)))

(defvar last-tag-data nil
"Information for continuing a tag search.
Is of the form (TAG POINT TAG-TABLE TAG-TABLE ...).")

(autoload 'get-symbol-syntax-table "symbol-syntax")

(defun find-tag-internal (tagname)
  "Foo"
  (let ((local-find-tag-hook find-tag-hook)
	(next (null tagname))
	symbol-border tag-target
	tag-tables tag-table-point file linebeg startpos target buf
	offset found pat)
    (cond (next
	   (setq tag-tables (cdr (cdr last-tag-data)))
	   (setq tagname (car last-tag-data))
	   (setq tag-table-point (car (cdr last-tag-data))))
	  (t
	   (setq tag-tables (buffer-tag-table-list))
	   (setq tag-table-point 1)))
    (cond ((string-match "\\\\_" tagname)
	   (setq symbol-border t)
	   (setq tag-target (copy-sequence tagname))
	   (while (string-match "\\\\_" tag-target)
	     (aset tag-target (1- (match-end 0)) ?b))
	   ;;	   (let ((i 0)
	   ;;		 (len (length tag-target))
	   ;;		 j)
	   ;;	     (while (< i len)
	   ;;	       (cond ((eq ?\\ (aref tag-target i))
	   ;;		      (setq j (1+ i))
	   ;;		      (if (eq ?_ (aref tag-target j))
	   ;;			  (aset tag-target j ?b))))
	   ;;	       (setq i (1+ i))))
	   )
	  (t
	   (setq tag-target tagname)))
    (save-excursion
      (catch 'found
	(while tag-tables
	  (set-buffer (get-tag-table-buffer (car tag-tables)))
	  (bury-buffer (current-buffer))
	  (goto-char (or tag-table-point (point-min)))
	  (setq tag-table-point nil)
	  (let (osyn case-fold-search)
	    (cond (symbol-border
		   (setq osyn (syntax-table))
		   (set-syntax-table (get-symbol-syntax-table osyn))))
	    (unwind-protect
		;; **** should there be support for non-regexp tag searches?
		(while (re-search-forward tag-target nil t)
		  (if (looking-at "[^\n\C-?]*\C-?")
		      (throw 'found t)))
	      (if osyn
		  (set-syntax-table osyn))))
	  (setq tag-tables (cdr tag-tables)))
	(error "No %sentries containing %s" (if next "more " "") tagname))
      (search-forward "\C-?")
      (setq file (expand-file-name (file-of-tag)))
      (setq linebeg
	    (buffer-substring (1- (point))
			      (save-excursion (beginning-of-line) (point))))
      (search-forward ",")
      (setq startpos (read (current-buffer)))
      (setq last-tag-data (nconc (list tagname (point)) tag-tables)))
    (setq buf (find-file-noselect file))
    (save-excursion
      (set-buffer buf)
      (save-excursion
	(save-restriction
	  (widen)
	  (setq offset 1000)
	  (setq pat (concat "^" (regexp-quote linebeg)))
	  (or startpos (setq startpos (point-min)))
	  (while (and (not found)
		      (progn
			(goto-char (- startpos offset))
			(not (bobp))))
	    (setq found (re-search-forward pat (+ startpos offset) t))
	    (setq offset (* 3 offset)))
	  (or found
	      (re-search-forward pat nil t)
	      (error "%s not found in %s" pat file))
	  (beginning-of-line)
	  (setq startpos (point)))))
    (cons buf startpos)))

(defun find-tag (tagname &optional other-window)
  "****Find tag whose name contains TAGNAME.
 Selects the buffer that the tag is contained in
and puts point at its definition.
 If TAGNAME is a null string, the expression in the buffer
around or before point is used as the tag name.
 If second arg NEXT is non-nil (interactively, with prefix arg),
searches for the next tag in the tag table
that matches the tagname used in the previous find-tag.

See documentation of variable tags-file-name."
  (interactive (if current-prefix-arg
		   '(nil nil)
		 (list (find-tag-tag "Find tag: ") nil)))
  (let* ((local-find-tag-hook find-tag-hook)
	 (next (null tagname))
	 (result (find-tag-internal tagname))
	 (tag-buf (car result))
	 (tag-point (cdr result)))
    ;; push old position
    (if (or (not next)
	    (not (memq last-command
		       '(find-tag find-tag-other-window tags-loop-continue))))
	(push-tag-mark))
    (if other-window
	(pop-to-buffer tag-buf)
      (switch-to-buffer tag-buf))
    (widen)
    (push-mark)
    (goto-char tag-point)
    (if find-tag-hook
	(funcall find-tag-hook)
      (if local-find-tag-hook
	  (funcall local-find-tag-hook))))
  (setq tags-loop-form (list 'find-tag nil nil))
  ;; Return t in case used as the tags-loop-form.
  t)

;; This function is unchanged from lisp/tags.el:
(defun find-tag-other-window (tagname)
  "Find tag (in current tag table) whose name contains TAGNAME.
 Selects the buffer that the tag is contained in in another window
and puts point at its definition.
 If TAGNAME is a null string, the expression in the buffer
around or before point is used as the tag name.
 If second arg NEXT is non-nil (interactively, with prefix arg),
searches for the next tag in the tag table
that matches the tagname used in the previous find-tag.

See documentation of variable tags-file-name."
  (interactive (if current-prefix-arg
		   '(nil)
		 (list (find-tag-tag "Find tag other window: "))))
  (find-tag tagname t))


;; Completion on tags in the buffer

(defun lisp-complete-symbol ()
  "Foo"
  (interactive)
  (let ((fn (save-excursion
	      (backward-sexp 1)
	      (while (= (char-syntax (following-char)) ?\')
		(forward-char 1))
	      (eq (preceding-char) ?\())))
  (complete-symbol obarray
		   (if fn
		       'fboundp
		     (function
		      (lambda (sym)
			(or (boundp sym)
			    (fboundp sym)
			    (symbol-plist sym)))))
		   (if (not fn)
		       ;; prettify the completion list by marking fns
		       ;; with " <f>"
		       (function
			(lambda (list)
			  (let (new)
			    (while list
			      (setq new (cons (if (fboundp (intern (car list)))
						  (list (car list) " <f>")
						(car list))
					      new))
			      (setq list (cdr list)))
			    (nreverse new))))))))

(defun complete-symbol (&optional table predicate prettify)
  "****Perform completion on Lisp symbol preceding point.
That symbol is compared against the symbols that exist
and any additional characters determined by what is there
are inserted.
If the symbol starts just after an open-parenthesis,
only symbols with function definitions are considered.
Otherwise, all symbols with function definitions, values
or properties are considered."
  (let* ((end (point))
	 (beg (save-excursion
		(backward-sexp 1)
		(while (= (char-syntax (following-char)) ?\')
		  (forward-char 1))
		(point)))
	 (pattern (buffer-substring beg end))
	 (table (or table obarray))
	 (completion (try-completion pattern table predicate)))
    (cond ((eq completion t))
	  ((null completion)
	   (message "Can't find completion for \"%s\"" pattern)
	   (ding))
	  ((not (string-equal pattern completion))
	   (delete-region beg end)
	   (insert completion))
	  (t
	   (message "Making completion list...")
	   (let ((list (all-completions pattern table predicate)))
	     (if prettify
		 (setq list (funcall prettify list)))
	     (with-output-to-temp-buffer "*Help*"
	       (display-completion-list list)))
	   (message "Making completion list...%s" "done")))))

(defun tag-complete-symbol ()
  "Foo"
  (interactive)
  (let* ((buffer-tag-table-list (buffer-tag-table-symbol-list))
	 tag-symbol-tables)
    (complete-symbol tag-completion-table 'tag-completion-predicate)))


;; Applying a command to files mentioned in tag tables

(defvar next-file-list nil
  "List of files for next-file to process.")

(defun next-file (&optional initialize)
  "Foo" "Select next file among files in current tag table.
Non-nil argument (prefix arg, if interactive)
initializes to the beginning of the list of files in the tag table."
  (interactive "P")
  (if initialize
      (setq next-file-list (buffer-tag-table-files)))
  (or next-file-list
      (error "All files processed."))
  (let* ((file (car next-file-list))
	 (buf (get-file-buffer file))
	 new)
    (setq next-file-list (cdr next-file-list))
    (or buf
	(setq buf (find-file-noselect file)
	      new t))
    (switch-to-buffer buf t)
    (widen)
    (cond ((> (point) (point-min))
	   (push-mark nil t)
	   (goto-char (point-min))))
    new))

(defvar tags-loop-form nil
  "Form for tags-loop-continue to eval to process one file.
If it returns nil, it is through with one file; move on to next.")

;; This function is unchanged from lisp/tags.el:
(defun tags-loop-continue (&optional first-time)
  "Continue last \\[tags-search] or \\[tags-query-replace] command.
Used noninteractively with non-nil argument
to begin such a command.  See variable tags-loop-form."
  (interactive)
  (let (new-buf message)
    (cond (first-time
	   (setq new-buf (next-file t))
	   (message "Scanning file %s..." buffer-file-name)
	   (setq message t)))
    ;; **** (let ((cursor-in-echo-area t)))
    (while (not (eval tags-loop-form))
      (if (and new-buf (not (buffer-modified-p)))
	  (kill-buffer (current-buffer)))
      (setq new-buf (next-file))
      (message "Scanning file %s..." buffer-file-name)
      (setq message t))
    (switch-to-buffer (current-buffer))
    (if message
	(message "Scanning file %s...done" buffer-file-name))))

;; This function is unchanged from lisp/tags.el:
(defun tags-search (regexp)
  "Search through all files listed in tag table for match for REGEXP.
Stops when a match is found.
To continue searching for next match, use command \\[tags-loop-continue].

See documentation of variable tags-file-name."
  (interactive "sTags search (regexp): ")
  (if (and (equal regexp "")
	   (eq (car tags-loop-form) 're-search-forward))
      (tags-loop-continue nil)
    (setq tags-loop-form
	  (list 're-search-forward regexp nil t))
    (tags-loop-continue t)))

;; This function is unchanged from lisp/tags.el:
(defun tags-query-replace (from to &optional delimited)
  "Query-replace-regexp FROM with TO through all files listed in tag table.
Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
If you exit (C-G or ESC), you can resume the query-replace
with the command \\[tags-loop-continue].

See documentation of variable tags-file-name."
  (interactive "sTags query replace (regexp): \nsTags query replace %s by: \nP")
  (setq tags-loop-form
	(list 'and (list 'save-excursion
			 (list 're-search-forward from nil t))
	      (list 'not (list 'perform-replace from to t t 
			       (not (null delimited))))))
  (tags-loop-continue t))


;; Miscellaneous

;; **** need to alter
;; This function is unchanged from lisp/tags.el:
(defun list-tags (string)
  "Display list of tags in file FILE.
FILE should not contain a directory spec
unless it has one in the tag table."
  (interactive "sList tags (in file): ")
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags in file ")
    (princ string)
    (terpri)
    (save-excursion
     (visit-tags-table-buffer)
     (goto-char 1)
     (search-forward (concat "\f\n" string ","))
     (forward-line 1)
     (while (not (or (eobp) (looking-at "\f")))
       (princ (buffer-substring (point)
				(progn (skip-chars-forward "^\C-?")
				       (point))))
       (terpri)
       (forward-line 1)))))

;; **** need to alter
;; This function is unchanged from lisp/tags.el:
(defun tags-apropos (string)
  "Display list of all tags in tag table REGEXP matches."
  (interactive "sTag apropos (regexp): ")
  (with-output-to-temp-buffer "*Tags List*"
    (princ "Tags matching regexp ")
    (prin1 string)
    (terpri)
    (save-excursion
     (visit-tags-table-buffer)
     (goto-char 1)
     (while (re-search-forward string nil t)
       (beginning-of-line)
       (princ (buffer-substring (point)
				(progn (skip-chars-forward "^\C-?")
				       (point))))
       (terpri)
       (forward-line 1)))))


;; Sample uses of find-tag-hook and find-tag-default-hook

;; Example buffer-local tag finding

(or (memq 'setup-emacs-lisp-default-tag-hook emacs-lisp-mode-hook)
    (setq emacs-lisp-mode-hook
	  (cons 'setup-emacs-lisp-default-tag-hook emacs-lisp-mode-hook)))

(defun setup-emacs-lisp-default-tag-hook ()
  (cond ((eq major-mode 'emacs-lisp-mode)
	 (make-variable-buffer-local 'find-tag-default-hook)
	 (setq find-tag-default-hook 'emacs-lisp-default-tag))))
;; Run it once immediately
(setup-emacs-lisp-default-tag-hook)

(defun emacs-lisp-default-tag ()
  "Function to return a default tag for Emacs-Lisp mode."
  (concat "[ '\"]"
	  (symbol-name
	   (or (variable-at-point)
	       (function-called-at-point)))
	  "[ '\"]"))

;;(defun Info-find-tag-hook ()
;;  "Function to call after finding a tag in Info-mode."
;;  (let ((onode Info-current-node)
;;	(ofile Info-current-file)
;;	(opoint (point)))
;;    (if (not (string= "*info*" (buffer-name)))
;;	(progn				; replace current *info* file
;;	  (kill-buffer "*info*")
;;	  (rename-buffer "*info*")))
;;    (or (eq major-mode 'Info-mode)
;;	(Info-mode))
;;    (setq Info-current-file
;;	  (file-name-sans-versions buffer-file-name))
;;    (Info-select-node)
;;    (or (and (equal onode Info-current-node)
;;	     (equal ofile Info-current-file))
;;	(setq Info-history (cons (list ofile onode opoint)
;;				 Info-history)))))
;;
;;;; Info-mode does not have a hook, so patch in the necessary calls.
;;
;;(require 'info)
;;
;;;; Only do this once
;;(fset 'Info-mode
;;      (append (symbol-function 'Info-mode)
;;	      (list '(make-local-variable 'find-tag-hook)
;;		    '(setq find-tag-hook 'Info-find-tag-hook)
;;		    '(modify-syntax-entry ?\' "."))))


;; Display short info on tag in minibuffer

(if (null (lookup-key esc-map "?"))
    (define-key esc-map "?" 'display-tag-info))

(defun display-tag-info (tagname)
  "Foo"
  (interactive (if current-prefix-arg
		   '(nil)
		 (list (find-tag-tag "Display tag info: "))))
  (let* ((results (find-tag-internal tagname))
	 (tag-buf (car results))
	 (tag-point (cdr results))
	 info lname min max fname args)
    (save-excursion
      (set-buffer tag-buf)
      (save-excursion
	(save-restriction
	  (widen)
	  (goto-char tag-point)
	  (cond ((looking-at "^DEFUN")
		 (forward-sexp 1)
		 (down-list 1)
		 (setq lname (read (current-buffer))
		       fname (buffer-substring
			      (progn (forward-sexp 1) (point))
			      (progn (backward-sexp 1) (point)))
		       min (buffer-substring
			    (progn (forward-sexp 3) (point))
			    (progn (backward-sexp 1) (point)))
		       max (buffer-substring
			    (progn (forward-sexp 2) (point))
			    (progn (backward-sexp 1) (point))))
		 (backward-up-list 1)
		 (setq args (buffer-substring
			     (progn (forward-sexp 2) (point))
			     (progn (backward-sexp 1) (point))))
		 (setq info (format "Elisp: %s, C: %s %s, #args: %s"
				    lname
				    fname args
				    (if (string-equal min max)
					min
				      (format "from %s to %s" min max)))))
		(t
		 (setq info
		       (buffer-substring
			(progn (beginning-of-line) (point))
			(progn (end-of-line) (point)))))))))
    (message "%s" info))
  (setq tags-loop-form '(display-tag-info nil))
  ;; Always return non-nil
  t)


;; Keep track of old locations before finding tags

(defvar tag-mark-stack1 nil)
(defvar tag-mark-stack2 nil)
(defvar tag-mark-stack-max 16 "*Foo")

(defun push-mark-on-stack (stack-symbol &optional max-size)
  (let ((stack (symbol-value stack-symbol)))
    (setq stack (cons (point-marker) stack))
    (cond ((and max-size
		(> (length stack) max-size))
	   (set-marker (car (nthcdr max-size stack)) nil)
	   (setcdr (nthcdr (1- max-size) stack) nil)))
    (set stack-symbol stack)))

(defun pop-mark-from-stack (stack-symbol1 stack-symbol2 &optional max-size)
  (let* ((stack (or (symbol-value stack-symbol1)
		    (error "No more tag marks on stack")))
	 (marker (car stack))
	 (m-buf (marker-buffer marker)))
    (set stack-symbol1 (cdr stack))
    (or m-buf
	(error "Marker has no buffer"))
    (if (null (buffer-name m-buf))
	(error "Buffer has been killed"))
    (push-mark-on-stack stack-symbol2 max-size)
    (switch-to-buffer m-buf)
    (widen)
    (goto-char (marker-position marker))))

(defun push-tag-mark ()
  (push-mark-on-stack 'tag-mark-stack1 tag-mark-stack-max))

(if (memq (lookup-key esc-map "*") '(nil undefined))
    (define-key esc-map "*" 'pop-tag-mark))

(defun pop-tag-mark (arg)
  (interactive "P")
  (if (not arg)
      (pop-mark-from-stack
       'tag-mark-stack1 'tag-mark-stack2 tag-mark-stack-max)
    (pop-mark-from-stack
     'tag-mark-stack2 'tag-mark-stack1 tag-mark-stack-max)))



;; John Sturdy <jcgs@harlqn.co.uk>
;; (defun lookup-tag (use-rec-edit)
;;   "Show a tag from the current tags name list in the other window for
;; reference, then restore the window layout after a pause. With prefix
;; arg, go into a recursive edit instead of pausing."
;;   (interactive "P")
;;   (save-window-excursion
;;     (save-excursion
;;       (find-tag-other-window (completing-read "Tag name: " tags-name-list))
;;       (if use-rec-edit
;;           (recursive-edit)
;;         (sit-for show-tag-time)))))
----------symbol-syntax.el follows:-----------------------------------
;; Created by: JBW, JBW@_CORTEZ
;; Created on: Wed Jun 20 15:15:34 1990
;; Last modified by: JBW, JBW@_CORTEZ
;; Last modified on: Wed Jun 20 16:07:22 1990
;; Filename: SYMBOL-SYNTAX.EL
;; Purpose: find chars with symbol syntax

(defvar symbol-syntax-table-alist
  '((c-mode-syntax-table)
    (emacs-lisp-mode-syntax-table)
    (lisp-mode-syntax-table)
    (text-mode-syntax-table)))

(defun update-symbol-syntax-table-alist ()
  (let (alist symbol-syntax-table-alist)
    (while (consp alist)
      (cond ((null (car alist))
	     (error "impossible"))
	    ((null (car (car alist)))
	     (error "impossible"))
	    ((symbolp (car (car alist)))
	     (or (null (cdr (car alist)))
		 (error "impossible"))
	     (or (syntax-table-p (symbol-value (car (car alist))))
		 (error "bad symbol in alist"))
	     (setcar (car alist)
		     (symbol-value (car (car alist))))))
      (cond ((null (cdr (car alist)))
	     (setcdr (car alist)
		     (make-symbol-syntax-table (car (car alist)))))))))

(defun get-symbol-syntax-table (norm-table)
  (let (result)
    (if (setq result (assq norm-table symbol-syntax-table-alist))
	nil
      (update-symbol-syntax-table-alist)
      (if (setq result (assq norm-table symbol-syntax-table-alist))
	  nil
	(setq symbol-syntax-table-alist
	      (cons (list norm-table)
		    symbol-syntax-table-alist))
	(update-symbol-syntax-table-alist)
	(or (setq result (assq norm-table symbol-syntax-table-alist))
	    (error "impossible"))))
    (or (setq result (cdr result))
	(error "impossible"))
    result))

(defun make-symbol-syntax-table (in-table)
  (let ((osyn (syntax-table))
	(out-table (copy-syntax-table in-table))
	(i 0)
	(syntax nil))
    (while (< i 256)
      (setq syntax (aref out-table i))
      (if (eq 3 (logand 255 syntax))
	  (aset out-table i (logand 2 (logand (lognot 255) syntax)))))
    out-table))

;; stuff for examining contents of syntax tables
;;(show-chars-with-syntax
;; '(c-mode-syntax-table
;;   emacs-lisp-mode-syntax-table
;;   lisp-mode-syntax-table
;;   text-mode-syntax-table)
;; ?_)

(defun show-chars-with-syntax (tables syntax)
  (let ((osyn (syntax-table))
	(schars nil))
    (unwind-protect
	(while (consp tables)
	  (let* ((chars nil)
		 (table-symbol (car tables))
		 (table table-symbol)
		 (i 0))
	    (or (symbolp table-symbol)
		(error "bad argument non-symbol"))
	    (while (symbolp table)
	      (setq table (symbol-value table)))
	    (set-syntax-table table)
	    (while (< i 256)
	      (if (eq syntax (char-syntax i))
		  (setq chars (cons (format "%c" i) chars)))
	      (setq i (1+ i)))
	    (setq schars (cons (list table-symbol
				     (mapconcat 'identity (nreverse chars) ""))
			       schars)))
	  (setq tables (cdr tables)))
      (set-syntax-table osyn))
    (nreverse schars)))

(provide 'symbol-syntax)