From e729daef32e396add223f0b985cf00040bdd34cf Mon Sep 17 00:00:00 2001 From: Jason Wilson Date: Wed, 20 Jan 1993 21:03:10 +0000 Subject: [PATCH] I added the ability to use more than one TAGS file at one time using the command visit-additional-tags-file. Still to be done is to handle included TAGS files ala Emacs 19. --- v7/src/edwin/tagutl.scm | 221 +++++++++++++++++++++++++++------------- 1 file changed, 153 insertions(+), 68 deletions(-) diff --git a/v7/src/edwin/tagutl.scm b/v7/src/edwin/tagutl.scm index d0b4c69cc..df886d663 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.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 ;;; @@ -47,26 +47,39 @@ (declare (usual-integrations)) -(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 @@ -75,13 +88,13 @@ around or before point is used as the tag name. 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 @@ -90,13 +103,61 @@ around or before point is used as the tag name. 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))) ;;;; 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?) @@ -104,15 +165,16 @@ See documentation of variable tags-file-name." 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))) @@ -149,10 +211,14 @@ See documentation of variable tags-file-name." (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) @@ -199,11 +265,12 @@ See documentation of variable tags-file-name." ;;;; 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 @@ -220,12 +287,12 @@ See documentation of variable tags-file-name." (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 @@ -259,28 +326,14 @@ See documentation of variable tags-file-name." (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")))) -(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)))) @@ -292,24 +345,56 @@ See documentation of variable tags-file-name." (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) + + +;; Edwin Variables: +;; scheme-environment: '(edwin) +;; scheme-syntax-table: (access edwin-syntax-table (->environment '(edwin))) +;; End: \ No newline at end of file -- 2.25.1