From: Jason Wilson <edu/mit/csail/zurich/jawilson>
Date: Mon, 25 Jan 1993 18:03:55 +0000 (+0000)
Subject: I finished up the new tag stuff. Now you can include other tags files
X-Git-Tag: 20090517-FFI~8569
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=730561659ddd5b6ee5682520bc31473ad6dd57b2;p=mit-scheme.git
I finished up the new tag stuff. Now you can include other tags files
as in emacs 19. Also, you can optionally cause tags-search and
tags-query-replace to kill buffers that aren't modified.
---
diff --git a/v7/src/edwin/tagutl.scm b/v7/src/edwin/tagutl.scm
index df886d663..0939bea3d 100644
--- a/v7/src/edwin/tagutl.scm
+++ b/v7/src/edwin/tagutl.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.47 1993/01/20 21:03:10 jawilson Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.48 1993/01/25 18:03:55 jawilson Exp $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
@@ -53,12 +53,6 @@
See documentation for visit-tags-table and visit-additional-tags-table."
false)
-(define (expand-pathname pathname)
- (if (or (not (pathname-name pathname))
- (file-directory? pathname))
- (pathname-new-name (pathname-as-directory pathname) "TAGS")
- pathname))
-
(define-command visit-tags-table
"Tell tags commands to use only the tag table file FILE.
FILE should be the name of a file created with the `etags' program.
@@ -78,6 +72,12 @@ To use more than one tag table file at a time, see visit-additional-tags-table."
(append (ref-variable tags-table-pathnames)
(list (expand-pathname pathname)))))))
+(define (expand-pathname pathname)
+ (if (or (not (pathname-name pathname))
+ (file-directory? pathname))
+ (pathname-new-name (pathname-as-directory pathname) "TAGS")
+ pathname))
+
(define-command find-tag
"Find tag (in current list of tag tables) whose name contains TAGNAME.
Selects the buffer that the tag is contained in
@@ -110,17 +110,18 @@ See documentation of variable tags-table-pathnames."
;;;; Find Tag
-(define (tags-table-buffers)
- (if (not (ref-variable tags-table-pathnames))
- (dispatch-on-command (ref-command-object visit-tags-table)))
- (let ((pathnames (ref-variable tags-table-pathnames)))
- (values (verify-tags-table (find-file-noselect pathname false)
- (car pathnames))
- (cdr pathnames))))
-
(define find-tag-pathnames-list
false)
+(define (handle-includes! included-pathnames)
+ (if included-pathnames
+ (set! find-tag-pathnames-list
+ (append (list (car find-tag-pathnames-list))
+ (if included-pathnames
+ included-pathnames
+ '())
+ (cdr find-tag-pathnames-list)))))
+
(define (first-tags-table-buffer)
(if (not (ref-variable tags-table-pathnames))
(dispatch-on-command (ref-command-object visit-tags-table)))
@@ -129,11 +130,7 @@ See documentation of variable tags-table-pathnames."
(buffer (verify-tags-table (find-file-noselect pathname false)
pathname))
(included-pathnames (get-included-pathnames buffer)))
- (if included-pathnames
- (set! find-tag-pathnames-list
- (append (list (car find-tag-pathnames-list))
- included-pathnames
- (cdr find-tag-pathnames-list))))
+ (handle-includes! included-pathnames)
buffer))
(define (current-tags-table-buffer)
@@ -150,11 +147,7 @@ See documentation of variable tags-table-pathnames."
(let* ((buffer (verify-tags-table (find-file-noselect pathname false)
pathname))
(included-pathnames (get-included-pathnames buffer)))
- (if included-pathnames
- (set! find-tag-pathnames-list
- (append (list (car find-tag-pathnames-list))
- included-pathnames
- (cdr find-tag-pathnames-list))))
+ (handle-includes! included-pathnames)
buffer))
#f))
@@ -264,6 +257,14 @@ See documentation of variable tags-table-pathnames."
;;;; Tags Search
+(define (smart-buffer-kill)
+ (if (and (not buffer-visited-already?)
+ (not (buffer-modified? tags-loop-current-buffer))
+ (ref-variable new-tags-behavior?)
+ )
+ ;; unvisit the current buffer
+ (kill-buffer tags-loop-current-buffer)))
+
(define-command tags-search
"Forevery tag table in the current list, search through all files
specified in it for match for REGEXP. Stops when a match is found.
@@ -282,8 +283,11 @@ See documentation of variable tags-table-pathnames."
(begin
(set-current-point! mark)
(clear-message))
- (tags-loop-start)))))
- (set! tags-loop-pathnames (tags-table-pathnames))
+ (begin
+ (smart-buffer-kill)
+ (tags-loop-start))))))
+ (set! tags-loop-pathnames
+ (get-all-pathnames (initial-tags-table-buffers)))
(tags-loop-start)))
(define-command tags-query-replace
@@ -305,24 +309,39 @@ See documentation of variable tags-file-pathnames."
(set! tags-loop-continuation
(lambda ()
(if (not (replace-string source target delimited true true))
- (tags-loop-start))))
- (set! tags-loop-pathnames (tags-table-pathnames))
+ (begin
+ (smart-buffer-kill)
+ (tags-loop-start)))))
+ (set! tags-loop-pathnames
+ (get-all-pathnames (initial-tags-table-buffers)))
(tags-loop-start)))
(define tags-loop-continuation false)
(define tags-loop-pathnames)
+(define-variable new-tags-behavior?
+ "This variable controls the behavior of tags-search and
+tags-query-replace. The new behavior cause any new buffers to be
+killed if they are not modified."
+ true)
+
+(define buffer-visited-already? false)
+(define tags-loop-current-buffer false)
+
(define (tags-loop-start)
(let ((pathnames tags-loop-pathnames))
(if (null? pathnames)
(editor-error "All files processed.")
(begin
+ (set! buffer-visited-already?
+ (pathname->buffer (car pathnames)))
(set! tags-loop-pathnames (cdr pathnames))
(find-file (car pathnames))
(message "Scanning file "
(->namestring (buffer-truename (current-buffer)))
"...")
(set-current-point! (buffer-start (current-buffer)))
+ (set! tags-loop-current-buffer (current-buffer))
(tags-loop-continuation)))))
(define-command tags-loop-continue
@@ -356,43 +375,70 @@ command."
" not a valid tag table"))
buffer)
-(define (tags-table-pathnames)
+(define (pathnames->tags-table-buffers pathnames)
+ (map (lambda (pathname)
+ (verify-tags-table (find-file-noselect pathname false)
+ pathname))
+ pathnames))
+
+(define (initial-tags-table-buffers)
;; first make sure there is at least one tags table
(if (not (ref-variable tags-table-pathnames))
(dispatch-on-command (ref-command-object visit-tags-table)))
- (let ((buffers
- (map (lambda (pathname)
- (verify-tags-table (find-file-noselect pathname false)
- pathname))
- (ref-variable tags-table-pathnames))))
- (append-map
- (lambda (buffer)
- (or (buffer-get buffer tags-table-pathnames)
- ;; this code may not work correctly with ,include$ from Emacs 19.0
- (let ((pathnames
- (let ((directory
- (directory-pathname (buffer-truename buffer))))
- (let loop ((mark (buffer-start buffer)))
- (let ((file-mark
- (skip-chars-backward "^,\n" (line-end mark 1))))
- (let ((mark
- (mark+ (line-start file-mark 1)
- (with-input-from-mark file-mark read))))
- (cons (merge-pathnames
- (extract-string (line-start file-mark 0)
- (mark-1+ file-mark))
- directory)
- (if (group-end? mark)
- '()
- (loop mark)))))))))
- (buffer-put! buffer tags-table-pathnames pathnames)
- pathnames)))
- buffers)))
+ (pathnames->tags-table-buffers (ref-variable tags-table-pathnames)))
+
+
+(define (tags-table-pathnames buffers)
+ (append-map
+ (lambda (buffer)
+ (or (buffer-get buffer 'TAGS-TABLE-PATHNAMES)
+ (let ((directory
+ (directory-pathname (buffer-truename buffer)))
+ (finish (lambda (pathnames included-pathnames)
+ (buffer-put! buffer 'TAGS-TABLE-PATHNAMES pathnames)
+ (buffer-put! buffer
+ 'TAGS-TABLE-INCLUDED-PATHNAMES
+ included-pathnames)
+ pathnames)))
+ (let loop ((mark (buffer-start buffer))
+ (pathnames '())
+ (included-tables '()))
+ (let ((file-mark
+ (skip-chars-backward "^,\n" (line-end mark 1))))
+ (let ((word (with-input-from-mark file-mark read))
+ (name
+ (merge-pathnames
+ (extract-string (line-start file-mark 0)
+ (mark-1+ file-mark))
+ directory)))
+ (if (number? word)
+ (let ((mark
+ (mark+ (line-start file-mark 1) word)))
+ (if (group-end? mark)
+ (finish (reverse (cons name pathnames)) (reverse included-tables))
+ (loop mark
+ (cons name pathnames)
+ included-tables)))
+ ;; if it is not a number than it must be an include
+ (if (group-end? (line-end file-mark 1))
+ (finish (reverse pathnames) (reverse (cons name included-tables)))
+ (loop (line-start mark 2)
+ pathnames
+ (cons name included-tables))))))))))
+ buffers))
(define (get-included-pathnames buffer)
- ;; Return false until we know the format of includes from Emacs 19.0
- false)
-
+ (tags-table-pathnames (list buffer))
+ (buffer-get buffer 'TAGS-TABLE-INCLUDED-PATHNAMES))
+
+(define (get-all-pathnames buffers)
+ (let ((pathnames (tags-table-pathnames buffers))
+ (includes (append-map get-included-pathnames buffers)))
+ (if (null? includes)
+ pathnames
+ (append pathnames
+ (get-all-pathnames (pathnames->tags-table-buffers includes))))))
+
;; Edwin Variables:
;; scheme-environment: '(edwin)