;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.46 1992/01/25 23:11:21 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable tags-table-pathname
- "Pathname of current tags table."
+(define-variable tags-table-pathnames
+ "List of pathnames of all of the active tags tables.
+
+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 tag table file FILE.
+ "Tell tags commands to use only the tag table file FILE.
FILE should be the name of a file created with the `etags' program.
-A directory name is ok too; it means file TAGS in that directory."
+A directory name is ok too; it means file TAGS in that directory.
+To use more than one tag table file at a time, see visit-additional-tags-table."
"FVisit tags table (default TAGS)"
(lambda (filename)
(let ((pathname (->pathname filename)))
- (set-variable!
- tags-table-pathname
- (if (or (not (pathname-name pathname))
- (file-directory? pathname))
- (pathname-new-name (pathname-as-directory pathname) "TAGS")
- pathname)))))
+ (set-variable! tags-table-pathnames (list (expand-pathname pathname))))))
+
+(define-command visit-additional-tags-table
+ "Adds another tags table file to the current list of active tags tables."
+ "FVisit additional tags table (default TAGS)"
+ (lambda (filename)
+ (let ((pathname (->pathname filename)))
+ (set-variable! tags-table-pathnames
+ (append (ref-variable tags-table-pathnames)
+ (list (expand-pathname pathname)))))))
(define-command find-tag
- "Find tag (in current tag table) whose name contains TAGNAME.
+ "Find tag (in current list of tag tables) 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
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."
+See documentation of variable tags-table-pathnames."
(lambda () (find-tag-arguments "Find tag"))
(lambda (string previous-tag?)
(&find-tag-command string previous-tag? find-file)))
(define-command find-tag-other-window
- "Find tag (in current tag table) whose name contains TAGNAME.
+ "Find tag (in current list of 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
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."
+See documentation of variable tags-table-pathnames."
(lambda () (find-tag-arguments "Find tag in other window"))
(lambda (string previous-tag?)
(&find-tag-command string previous-tag? find-file-other-window)))
\f
;;;; 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 (first-tags-table-buffer)
+ (if (not (ref-variable tags-table-pathnames))
+ (dispatch-on-command (ref-command-object visit-tags-table)))
+ (set! find-tag-pathnames-list (ref-variable tags-table-pathnames))
+ (let* ((pathname (car find-tag-pathnames-list))
+ (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))))
+ buffer))
+
+(define (current-tags-table-buffer)
+ (if find-tag-pathnames-list
+ (find-file-noselect (car find-tag-pathnames-list) false)
+ #f))
+
+(define (next-tags-table-buffer)
+ (if (and find-tag-pathnames-list
+ (not (null? (cdr find-tag-pathnames-list))))
+ (let ((pathname (second find-tag-pathnames-list)))
+ (set! find-tag-pathnames-list
+ (cdr find-tag-pathnames-list))
+ (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))))
+ buffer))
+ #f))
+
(define (find-tag-arguments prompt)
(let ((previous-tag? (command-argument)))
(list (and (not previous-tag?)
previous-tag?)))
(define (&find-tag-command string previous-tag? find-file)
- (let ((buffer (tags-table-buffer)))
- (if previous-tag?
+ (if previous-tag?
+ (let ((buffer (current-tags-table-buffer)))
(find-tag previous-find-tag-string
buffer
(buffer-point buffer)
- find-file)
+ find-file))
(begin
(set! previous-find-tag-string string)
- (find-tag string buffer (buffer-start buffer) find-file))))
+ (let ((buffer (first-tags-table-buffer)))
+ (find-tag string buffer (buffer-start buffer) find-file))))
(set! tags-loop-continuation
(lambda ()
(&find-tag-command false true find-file)))
(or (re-match-forward find-tag-match-regexp mark)
(loop mark)))))))
(if (not tag)
- (editor-failure "No "
- (if (group-start? start) "" "more ")
- "entries containing "
- string)
+ (let ((next-buffer (next-tags-table-buffer)))
+ (if (not next-buffer)
+ (editor-failure "No "
+ (if (group-start? start) "" "more ")
+ "entries containing "
+ string)
+ (find-tag string next-buffer (buffer-start next-buffer) find-file)
+ ))
(let ((pathname
(merge-pathnames
(tag->pathname tag)
;;;; Tags Search
(define-command tags-search
- "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].
+ "Forevery tag table in the current list, search through all files
+specified in it 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."
+See documentation of variable tags-table-pathnames."
(re-search-prompt "Tags search")
(lambda (regexp)
(set! tags-loop-continuation
(tags-loop-start)))
(define-command tags-query-replace
- "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].
+ "Query-replace-regexp FROM with TO through all files listed in all of
+the tag tables. 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."
+See documentation of variable tags-file-pathnames."
(lambda ()
(let ((source (prompt-for-string "Tags query replace (regexp)" false)))
(list source
(tags-loop-continuation)))))
(define-command tags-loop-continue
- "Continue last \\[tags-search] or \\[tags-query-replace] command."
+ "Continue last \\[find-tag], \\[tags-search] or \\[tags-query-replace]
+command."
()
(lambda ()
(if tags-loop-continuation
(tags-loop-continuation)
(editor-error "No tags loop in progress"))))
\f
-(define (tags-table-buffer)
- (if (not (ref-variable tags-table-pathname))
- (dispatch-on-command (ref-command-object visit-tags-table)))
- (let ((pathname (ref-variable tags-table-pathname)))
- (let ((buffer (find-file-noselect pathname false)))
- (if (and (not (verify-visited-file-modification-time? buffer))
- (prompt-for-yes-or-no?
- "Tags file has changed; read new contents"))
- (revert-buffer buffer true true))
- (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page))
- (editor-error "File "
- (->namestring pathname)
- " not a valid tag table"))
- buffer)))
-
(define (tag->pathname tag)
(define (loop mark)
(let ((file-mark (skip-chars-backward "^,\n" (line-end mark 1))))
(loop mark)))))
(loop (group-start tag)))
+(define (verify-tags-table buffer pathname)
+ (if (and (not (verify-visited-file-modification-time? buffer))
+ (prompt-for-yes-or-no?
+ "Tags file has changed; read new contents"))
+ (revert-buffer buffer true true))
+ (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page))
+ (editor-error "File "
+ (->namestring pathname)
+ " not a valid tag table"))
+ buffer)
+
(define (tags-table-pathnames)
- (let ((buffer (tags-table-buffer)))
- (or (buffer-get buffer tags-table-pathnames)
- (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))))
\ No newline at end of file
+ ;; 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)))
+
+(define (get-included-pathnames buffer)
+ ;; Return false until we know the format of includes from Emacs 19.0
+ false)
+
+\f
+;; Edwin Variables:
+;; scheme-environment: '(edwin)
+;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin)))
+;; End:
\ No newline at end of file
projects / mit-scheme.git / commitdiff