🚀 go-pugleaf

In article <JBW.90Jul2094458@zeb.uswest.com> jbw@zeb.uswest.com (Joe Wells) writes:

   This is a huge rewrite of lisp/tags.el

   [rest of article deleted]

It turns out I posted an old version of symbol-syntax.el.  Also I had
introduced some bugs in tags-fix.el just before posting it.

I'm including a patch to tags-fix.el which fixes the bugs that I spotted.
I'm also including the correct version of symbol-syntax.el.  The version I
posted doesn't work at all.

Once again, any bugs to me.  I appreciate any help in working bugs out of
this stuff.

Enjoy,

-- 
Joe Wells <jbw@uswest.com>
----------patch to tags-fix.el----------------------------------------
*** tags-fix.el.dist	Mon Jul  2 15:08:09 1990
--- tags-fix.el	Mon Jul  2 18:41:41 1990
***************
*** 20,28 ****
  
  ;; 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:
--- 20,28 ----
  
  ;; Created by: Joe Wells, jbw@bucsf.bu.edu
  ;; Created on: Thu Mar 22 20:17:40 1990
! ;; Last modified by: Joe Wells, jbw@dodge
! ;; Last modified on: Mon Jul  2 18:41:45 1990
! ;; Filename: tags-fix.el
  ;; Purpose: enhanced tags functionality
  
  ;; enhancements:
***************
*** 125,131 ****
  (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"))
--- 125,131 ----
  (setq tags-file-name nil)
  
  (defun buffer-tag-table-list ()
!   (let (result expression)
      (if buffer-tag-table
  	(setq result (cons buffer-tag-table result)))
      (if (file-readable-p (concat default-directory "TAGS"))
***************
*** 135,144 ****
  	  (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)))
--- 135,160 ----
  	  (alist tag-table-alist))
        (while alist
  	;; **** handle arbitrary expressions
! 	(setq expression (car (car alist)))
! 	;; If the car of the alist item is a string, apply it as a regexp
! 	;; to the buffer-file-name.  Otherwise, evaluate it.  If the
! 	;; regexp matches, or the expression evaluates non-nil, then this
! 	;; item in tag-table-alist applies to this buffer.
! 	(if (if (stringp expression)
! 		(string-match (car (car alist)) key)
! 	      (condition-case nil
! 		  (eval expression)
! 		(error nil)))
! 	    ;; Now evaluate the cdr of the alist item to get the name of
! 	    ;; the tag table file.
! 	    (progn
! 	      (setq expression 
! 		    (condition-case nil
! 			(eval (cdr (car alist)))
! 		      (error nil)))
! 	      (if (stringp expression)
! 		  (setq result (cons expression result))
! 		(error "Expression in tag-table-alist evaluated to non-string"))))
  	(setq alist (cdr alist))))
      (if tags-file-name
  	(setq result (cons tags-file-name result)))
***************
*** 465,476 ****
  ;; 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
--- 481,493 ----
  ;; buffer-tag-table-list,
  ;; tag-symbol-tables (value irrelevant, bound outside for efficiency)
  (defun tag-completion-predicate (tag-symbol)
!   (and (boundp 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
***************
*** 478,501 ****
  	     (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
--- 495,518 ----
  	     (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
***************
*** 510,516 ****
  	     prompt)
  	   tag-completion-table 'tag-completion-predicate nil nil))
      (if (string-equal tag-name "")
! 	(concat "\\_" default "\\_")
        tag-name)))
  
  (defvar last-tag-data nil
--- 527,533 ----
  	     prompt)
  	   tag-completion-table 'tag-completion-predicate nil nil))
      (if (string-equal tag-name "")
! 	(list default)			;indicate exact symbol match
        tag-name)))
  
  (defvar last-tag-data nil
***************
*** 523,531 ****
    "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))
--- 540,550 ----
    "Foo"
    (let ((local-find-tag-hook find-tag-hook)
  	(next (null tagname))
+ 	(exact (consp tagname))
  	symbol-border tag-target
  	tag-tables tag-table-point file linebeg startpos target buf
! 	offset found pat syn-tab)
!     (if exact (setq tagname (car tagname)))
      (cond (next
  	   (setq tag-tables (cdr (cdr last-tag-data)))
  	   (setq tagname (car last-tag-data))
***************
*** 533,543 ****
  	  (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)
--- 552,569 ----
  	  (t
  	   (setq tag-tables (buffer-tag-table-list))
  	   (setq tag-table-point 1)))
!     ;; If tagname is a list: (TAGNAME), this indicates requiring an exact
!     ;; symbol match.  Similarly, \_ in the tagname is used to indicate a
!     ;; symbol boundary.
!     (cond ((or exact
! 	       (string-match "\\\\_" tagname))
  	   (setq symbol-border t)
! 	   (if exact
! 	       (setq tag-target (concat "\\_" tagname "\\_"))
! 	     (setq tag-target (copy-sequence tagname)))
  	   (while (string-match "\\\\_" tag-target)
  	     (aset tag-target (1- (match-end 0)) ?b))
+ 	   (setq syn-tab (get-symbol-syntax-table (syntax-table)))
  	   ;;	   (let ((i 0)
  	   ;;		 (len (length tag-target))
  	   ;;		 j)
***************
*** 549,555 ****
  	   ;;	       (setq i (1+ i))))
  	   )
  	  (t
! 	   (setq tag-target tagname)))
      (save-excursion
        (catch 'found
  	(while tag-tables
--- 575,582 ----
  	   ;;	       (setq i (1+ i))))
  	   )
  	  (t
! 	   (setq tag-target tagname)
! 	   (setq syn-tab (syntax-table))))
      (save-excursion
        (catch 'found
  	(while tag-tables
***************
*** 557,575 ****
  	  (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
--- 584,603 ----
  	  (bury-buffer (current-buffer))
  	  (goto-char (or tag-table-point (point-min)))
  	  (setq tag-table-point nil)
! 	  (let ((osyn (syntax-table))
! 		case-fold-search)
! 	    (set-syntax-table syn-tab)
  	    (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)))
! 	      (set-syntax-table osyn)))
  	  (setq tag-tables (cdr tag-tables)))
! 	(error "No %sentries %s %s"
! 	       (if next "more " "")
! 	       (if exact "matching" "containing")
! 	       tagname))
        (search-forward "\C-?")
        (setq file (expand-file-name (file-of-tag)))
        (setq linebeg
***************
*** 879,889 ****
  
  (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."
--- 907,915 ----
  
  (defun emacs-lisp-default-tag ()
    "Function to return a default tag for Emacs-Lisp mode."
!   (let ((tag (or (variable-at-point)
! 		 (function-called-at-point))))
!     (if tag (symbol-name tag))))
  
  ;;(defun Info-find-tag-hook ()
  ;;  "Function to call after finding a tag in Info-mode."
----------correct version of symbol-syntax.el-------------------------
;; Created by: JBW, JBW@_CORTEZ
;; Created on: Wed Jun 20 15:15:34 1990
;; Last modified by: Joe Wells, jbw@dodge
;; Last modified on: Mon Jul  2 18:23:23 1990
;; Filename: symbol-syntax.el
;; Purpose: find chars with symbol syntax

(defvar symbol-syntax-table-alist nil)
;;  '((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)
	item)
    (while (consp alist)
      (cond ((null (car alist))
	     (error "Missing alist item"))
	    ((null (car (car alist)))
	     (error "Alist item with null car"))
	    ;; this functionality not used
	    ((symbolp (setq item (car (car alist))))
	     (or (null (cdr (car alist)))
		 (error "Alist item expected to have null cdr"))
	     (while (symbolp item)
	       (setq item (symbol-value item)))
	     (setcar (car alist) item)))
      (cond ((not (syntax-table-p (car (car alist))))
	     (error "Alist item car expected to be symbol table"))
	    ((null (cdr (car alist)))
	     (setcdr (car alist)
		     (make-symbol-syntax-table (car (car alist))))))
      (setq alist (cdr 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 "Syntax table missing from symbol-syntax-table-alist"))))
    (or (setq result (cdr result))
	(error "Alist item has null cdr"))
    (or (syntax-table-p result)
	(error "Non-syntax-table item in alist"))
    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 (logior 2 (logand (lognot 255) syntax))))
      (setq i (1+ i)))
    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)