From 1e48485abe91ab49fb45466043a4277add6499f2 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 27 Mar 2000 20:44:25 +0000 Subject: [PATCH] Change variable FIND-FILE-HOOKS to be a list. The procedures in this list are called in order, and each must return a buffer, which may be different form the argument. The resulting buffer is to be used in place of the argument buffer. This affects the result of FIND-FILE-NOSELECT, AFTER-FIND-FILE, FIND-FILE-REVERT, and REVERT-BUFFER. --- v7/src/edwin/bufmnu.scm | 5 +- v7/src/edwin/dired.scm | 5 +- v7/src/edwin/filcom.scm | 205 +++++++++++++++++++++------------------- v7/src/edwin/rmail.scm | 14 +-- v7/src/edwin/snr.scm | 6 +- v7/src/edwin/tagutl.scm | 82 ++++++++-------- 6 files changed, 162 insertions(+), 155 deletions(-) diff --git a/v7/src/edwin/bufmnu.scm b/v7/src/edwin/bufmnu.scm index 10eaa52cd..039d59753 100644 --- a/v7/src/edwin/bufmnu.scm +++ b/v7/src/edwin/bufmnu.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: bufmnu.scm,v 1.127 2000/03/23 03:19:03 cph Exp $ +;;; $Id: bufmnu.scm,v 1.128 2000/03/27 20:44:09 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; @@ -60,7 +60,8 @@ Type q immediately to make the buffer menu go away." dont-use-auto-save? dont-confirm? ;ignore (set-buffer-writeable! buffer) (region-delete! (buffer-region buffer)) - (fill-buffer-menu! buffer (buffer-get buffer 'REVERT-BUFFER-FILES-ONLY?))) + (fill-buffer-menu! buffer (buffer-get buffer 'REVERT-BUFFER-FILES-ONLY?)) + buffer) (define (fill-buffer-menu! buffer files-only?) (call-with-output-mark (buffer-point buffer) diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm index 9b1506a8a..edc524296 100644 --- a/v7/src/edwin/dired.scm +++ b/v7/src/edwin/dired.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: dired.scm,v 1.172 2000/03/23 03:19:06 cph Exp $ +;;; $Id: dired.scm,v 1.173 2000/03/27 20:44:24 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; @@ -196,7 +196,8 @@ Type `h' after entering dired for more info." (if (mark< lstart (buffer-end buffer)) lstart (buffer-end buffer)) - 0)))))) + 0))))) + buffer) (define (fill-dired-buffer! buffer directory-spec) (let ((pathname (car directory-spec)) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index c3ec56221..776a06e37 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: filcom.scm,v 1.209 2000/03/23 03:19:10 cph Exp $ +;;; $Id: filcom.scm,v 1.210 2000/03/27 20:43:22 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; @@ -23,7 +23,7 @@ (declare (usual-integrations)) (define (find-file filename) - (select-buffer (find-file-noselect filename true))) + (select-buffer (find-file-noselect filename #t))) (define-command find-file "Visit a file in its own buffer. @@ -33,7 +33,7 @@ Otherwise, visit the file in a buffer named after the file." find-file) (define (find-file-other-window filename) - (select-buffer-other-window (find-file-noselect filename true))) + (select-buffer-other-window (find-file-noselect filename #t))) (define-command find-file-other-window "Visit a file in another window. @@ -42,7 +42,7 @@ May create a window, or reuse one." find-file-other-window) (define (find-file-other-screen filename) - (select-buffer-other-screen (find-file-noselect filename true))) + (select-buffer-other-screen (find-file-noselect filename #t))) (define-command find-file-other-frame "Visit a file in another frame." @@ -57,7 +57,7 @@ If the current buffer now contains an empty file that you just visited \(presumably by mistake), use this command to visit the file you really want." "FFind alternate file" (lambda (filename) - (let ((buffer (current-buffer))) + (let ((buffer (selected-buffer))) (let ((do-it (lambda () (kill-buffer-interactive buffer) @@ -70,7 +70,7 @@ If the current buffer now contains an empty file that you just visited (define-variable find-file-run-dired "True says run dired if find-file is given the name of a directory." - true + #t boolean?) (define-variable find-file-not-found-hooks @@ -79,13 +79,22 @@ These functions are called as soon as the error is detected. The functions are called in the order given, until one of them returns non-false." '() - list?) + (lambda (object) + (list-of-type? object + (lambda (object) + (and (procedure? object) + (procedure-arity-valid? object 1)))))) (define-variable find-file-hooks - "Event distributor to be invoked after a buffer is loaded from a file. + "List of procedures to be called after a buffer is loaded from a file. The buffer's local variables (if any) will have been processed before the -invocation." - (make-event-distributor)) +procedures are called." + '() + (lambda (object) + (list-of-type? object + (lambda (object) + (and (procedure? object) + (procedure-arity-valid? object 1)))))) (define (find-file-noselect filename warn?) (let ((pathname (pathname-simplify (merge-pathnames filename)))) @@ -95,15 +104,15 @@ invocation." (editor-error (->namestring pathname) " is a directory.")) (let ((buffer (pathname->buffer pathname))) (if buffer - (begin - (if warn? (find-file-revert buffer)) - buffer) + (if warn? + (find-file-revert buffer) + buffer) (let ((buffer (new-buffer (pathname->buffer-name pathname)))) (let ((error? (not (catch-file-errors - (lambda () false) - (lambda () (read-buffer buffer pathname true)))))) + (lambda () #f) + (lambda () (read-buffer buffer pathname #t)))))) (if error? (do ((hooks (ref-variable find-file-not-found-hooks buffer) @@ -111,8 +120,7 @@ invocation." ((or (null? hooks) ((car hooks) buffer)))) (maybe-change-buffer-name! buffer pathname)) - (after-find-file buffer error? warn?)) - buffer)))))) + (after-find-file buffer error? warn?)))))))) (define (maybe-change-buffer-name! buffer pathname) (let ((name (pathname->buffer-name pathname)) @@ -158,12 +166,15 @@ invocation." (if (file-test-no-errors file-exists? directory) "write-protected" "doesn't exist"))))))))) - (normal-mode buffer true) - (event-distributor/invoke! (ref-variable find-file-hooks buffer) buffer) - (load-find-file-initialization buffer pathname))) + (normal-mode buffer #t) + (load-find-file-initialization buffer pathname) + (let loop ((hooks (ref-variable find-file-hooks buffer)) (buffer buffer)) + (if (pair? hooks) + (loop (cdr hooks) ((car hooks) buffer)) + buffer)))) (define (file-test-no-errors test . args) - (catch-file-errors (lambda () false) + (catch-file-errors (lambda () #f) (lambda () (apply test args)))) (define (file-newer-than-file? a b) @@ -176,7 +187,7 @@ invocation." (define (load-find-file-initialization buffer pathname) (let ((pathname (catch-file-errors - (lambda () false) + (lambda () #f) (lambda () (os/find-file-initialization-filename pathname))))) (if pathname (let ((database @@ -185,9 +196,9 @@ invocation." (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () - (catch-file-errors (lambda () false) + (catch-file-errors (lambda () #f) (lambda () - (fluid-let ((load/suppress-loading-message? true)) + (fluid-let ((load/suppress-loading-message? #t)) (load pathname '(EDWIN) edwin-syntax-table)))))))))) @@ -200,8 +211,7 @@ invocation." (define (standard-scheme-find-file-initialization database) ;; DATABASE -must- be a vector whose elements are all three element - ;; lists. The car of each element must be a string, and the - ;; elements must be sorted on those strings. + ;; lists. The car of each element must be a string. (sort! database (lambda (x y) (stringnamestring pathname) - " no longer " - (if (file-exists? pathname) "exists" "readable") - "!")) - ((or dont-confirm? - (prompt-for-yes-or-no? - (string-append "Revert buffer from file " - (->namestring pathname)))) - ;; If file was backed up but has changed since, we - ;; should make another backup. - (if (and (not auto-save?) - (not (verify-visited-file-modification-time? buffer))) - (set-buffer-backed-up?! buffer false)) - (let ((where (mark-index (buffer-point buffer))) - (group (buffer-group buffer)) - (do-it - (lambda () - (read-buffer buffer pathname (not auto-save?))))) - (if (group-undo-data group) - (begin - ;; Throw away existing undo data. - (disable-group-undo! group) - (do-it) - (enable-group-undo! group)) - (do-it)) - (set-buffer-point! - buffer - (make-mark group (min where (buffer-length buffer)))) - (after-find-file buffer false false))))))) + (if (not pathname) + (editor-error "Buffer does not seem to be associated with any file")) + (if (not (file-readable? pathname)) + (editor-error "File " + (->namestring pathname) + " no longer " + (if (file-exists? pathname) "exists" "readable") + "!")) + (if (or dont-confirm? + (prompt-for-yes-or-no? + (string-append "Revert buffer from file " + (->namestring pathname)))) + (begin + ;; If file was backed up but has changed since, we + ;; should make another backup. + (if (and (not auto-save?) + (not (verify-visited-file-modification-time? buffer))) + (set-buffer-backed-up?! buffer #f)) + (let ((where (mark-index (buffer-point buffer))) + (group (buffer-group buffer)) + (do-it + (lambda () + (read-buffer buffer pathname (not auto-save?))))) + (if (group-undo-data group) + (begin + ;; Throw away existing undo data. + (disable-group-undo! group) + (do-it) + (enable-group-undo! group)) + (do-it)) + (set-buffer-point! + buffer + (make-mark group (min where (buffer-length buffer)))) + (after-find-file buffer #f #f))) + buffer)))) (define-command recover-file "Visit file FILE, but get contents from its last auto-save file." @@ -315,7 +326,7 @@ Argument means don't offer to use auto-save file." (let ((filename (->namestring pathname))) (if (os/auto-save-filename? filename) (editor-error filename " is an auto-save file"))) - (let ((auto-save-pathname (os/auto-save-pathname pathname false))) + (let ((auto-save-pathname (os/auto-save-pathname pathname #f))) (let ((auto-save-filename (->namestring auto-save-pathname))) (if (not (file-newer-than-file? auto-save-pathname pathname)) (editor-error "Auto-save file " @@ -328,18 +339,18 @@ Argument means don't offer to use auto-save file." (buffer-end buffer)) (set-buffer-point! buffer (buffer-start buffer)) (buffer-not-modified! buffer) - (pop-up-buffer buffer false) + (pop-up-buffer buffer #f) (prompt-for-yes-or-no? (string-append "Recover auto save file " auto-save-filename))))) (editor-error "Recover-file cancelled.")) - (let ((buffer (find-file-noselect pathname false))) - (read-buffer buffer auto-save-pathname false) - (after-find-file buffer false false) - (disable-buffer-auto-save! buffer) - (message - "Auto-save off in this buffer till you do M-x auto-save-mode.") - (select-buffer buffer))))))) + (let ((buffer (find-file-noselect pathname #f))) + (read-buffer buffer auto-save-pathname #f) + (let ((buffer (after-find-file buffer #f #f))) + (disable-buffer-auto-save! buffer) + (message + "Auto-save off in this buffer till you do M-x auto-save-mode.") + (select-buffer buffer)))))))) (define-command insert-filename "Interactively read a file name and insert it at point. @@ -385,13 +396,13 @@ If `trim-versions-without-asking' is false, system will query user before trimming versions. Otherwise it does it silently." "p" (lambda (argument) - (save-buffer (current-buffer) + (save-buffer (selected-buffer) (case argument ((0) 'NO-BACKUP) ((4) 'BACKUP-NEXT) ((16) 'BACKUP-PREVIOUS) ((64) 'BACKUP-BOTH) - (else false))))) + (else #f))))) (define (save-buffer buffer backup-mode) (if (buffer-modified? buffer) @@ -415,7 +426,7 @@ If `trim-versions-without-asking' is false, system will query user With argument, saves all with no questions." "P" (lambda (no-confirmation?) - (save-some-buffers no-confirmation? false))) + (save-some-buffers no-confirmation? #f))) (define (save-some-buffers no-confirmation? exiting?) (let ((buffers @@ -430,7 +441,7 @@ With argument, saves all with no questions." (for-each (if (and (not (default-object? no-confirmation?)) no-confirmation?) (lambda (buffer) - (write-buffer-interactive buffer false)) + (write-buffer-interactive buffer #f)) (lambda (buffer) (if (prompt-for-confirmation? (let ((pathname (buffer-pathname buffer))) @@ -439,7 +450,7 @@ With argument, saves all with no questions." (->namestring pathname)) (string-append "Save buffer " (buffer-name buffer))))) - (write-buffer-interactive buffer false)))) + (write-buffer-interactive buffer #f)))) buffers) (let ((abbrevs-saved? (maybe-save-abbrevs no-confirmation?))) (if (and (null? buffers) (not abbrevs-saved?)) @@ -449,7 +460,7 @@ With argument, saves all with no questions." "True in a buffer means offer to save the buffer on exit even if the buffer is not visiting a file. Automatically local in all buffers." - false + #f boolean?) (define (pathname->buffer-name pathname) @@ -477,7 +488,7 @@ if you wish to make buffer not be visiting any file." "FSet visited file name" (lambda (filename) (set-visited-pathname - (current-buffer) + (selected-buffer) (let ((pathname (->pathname filename))) (and (not (string-null? (file-namestring pathname))) pathname))))) @@ -487,12 +498,12 @@ if you wish to make buffer not be visiting any file." (editor-error "File name cannot be a directory: " (->namestring pathname))) (set-buffer-pathname! buffer pathname) - (set-buffer-truename! buffer false) + (set-buffer-truename! buffer #f) (if pathname (let ((name (pathname->buffer-name pathname))) (if (not (find-buffer name)) (rename-buffer buffer name)))) - (set-buffer-backed-up?! buffer false) + (set-buffer-backed-up?! buffer #f) (clear-visited-file-modification-time! buffer) (cond ((buffer-auto-save-pathname buffer) (rename-auto-save-file! buffer)) @@ -506,14 +517,14 @@ if you wish to make buffer not be visiting any file." Makes buffer visit that file, and marks it not modified." "FWrite file" (lambda (filename) - (write-file (current-buffer) filename))) + (write-file (selected-buffer) filename))) (define (write-file buffer filename) (if (and filename (not (string-null? filename))) (set-visited-pathname buffer (->pathname filename))) (buffer-modified! buffer) - (save-buffer buffer false)) + (save-buffer buffer #f)) (define-command write-region "Write current region into specified file." @@ -542,7 +553,7 @@ Leaves point at the beginning, mark at the end." "Copy a file; the old and new names are read in the typein window. If a file with the new name already exists, confirmation is requested first." (lambda () - (let ((old (prompt-for-existing-file "Copy file" false))) + (let ((old (prompt-for-existing-file "Copy file" #f))) (list old (prompt-for-file "Copy to" old)))) (lambda (old new) (if (or (not (file-exists? new)) @@ -558,7 +569,7 @@ If a file with the new name already exists, confirmation is requested first." "Rename a file; the old and new names are read in the typein window. If a file with the new name already exists, confirmation is requested first." (lambda () - (let ((old (prompt-for-existing-file "Rename file" false))) + (let ((old (prompt-for-existing-file "Rename file" #f))) (list old (prompt-for-file "Rename to" old)))) (lambda (old new) (let ((do-it @@ -584,7 +595,7 @@ If a file with the new name already exists, confirmation is requested first." () (lambda () (message "Directory " - (->namestring (buffer-default-directory (current-buffer)))))) + (->namestring (buffer-default-directory (selected-buffer)))))) (define-command cd "Make DIR become the current buffer's default directory." @@ -594,7 +605,7 @@ If a file with the new name already exists, confirmation is requested first." ((ref-command pwd)))) (define (set-default-directory directory) - (let ((buffer (current-buffer))) + (let ((buffer (selected-buffer))) (let ((directory (pathname-as-directory (merge-pathnames directory (buffer-default-directory buffer))))) @@ -755,7 +766,7 @@ Prefix arg means treat the plaintext file as binary data." (if (pair? default) (car default) default)) - (buffer-default-directory (current-buffer)))) + (buffer-default-directory (selected-buffer)))) (insertion (os/pathname->display-string (if (pair? default) diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 04db9dc7e..050e5539a 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: rmail.scm,v 1.69 2000/03/23 06:33:08 cph Exp $ +;;; $Id: rmail.scm,v 1.70 2000/03/27 20:43:24 cph Exp $ ;;; ;;; Copyright (c) 1991-2000 Massachusetts Institute of Technology ;;; @@ -341,14 +341,15 @@ but does not copy any new mail into the file." (let ((memo (buffer-msg-memo buffer))) (and (msg-memo? memo) (<= n (msg-memo/number (msg-memo/last memo))) - n)))))) + n))))) + buffer) (define (rmail-after-find-file buffer error? warn?) error? warn? - ;; No need to auto save RMAIL files. - (disable-buffer-auto-save! buffer) + (disable-buffer-auto-save! buffer) ;No need to auto save RMAIL files. (convert-buffer-to-babyl-format buffer) - (set-buffer-major-mode! buffer (ref-mode-object rmail))) + (set-buffer-major-mode! buffer (ref-mode-object rmail)) + buffer) (define-command rmail-quit "Quit out of RMAIL." @@ -382,8 +383,7 @@ and use that file as the inbox." (list (and (command-argument) (prompt-for-existing-file "Get new mail from file" #f)))) (lambda (filename) - (let ((buffer (current-buffer))) - (rmail-find-file-revert buffer) + (let ((buffer (rmail-find-file-revert (current-buffer)))) (let ((n-messages (let ((memo (buffer-msg-memo buffer))) (if (msg-memo? memo) diff --git a/v7/src/edwin/snr.scm b/v7/src/edwin/snr.scm index 243a331b6..33cd6e992 100644 --- a/v7/src/edwin/snr.scm +++ b/v7/src/edwin/snr.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: snr.scm,v 1.55 2000/01/10 03:25:14 cph Exp $ +;;; $Id: snr.scm,v 1.56 2000/03/27 20:43:25 cph Exp $ ;;; ;;; Copyright (c) 1995-2000 Massachusetts Institute of Technology ;;; @@ -3471,9 +3471,7 @@ With prefix arg, replaces the file with the list information." (let ((pathname (os/newsrc-file-name (nntp-connection:server connection)))) (let ((buffer (pathname->buffer pathname))) (if buffer - (begin - (find-file-revert buffer) - (receiver buffer)) + (receiver (find-file-revert buffer)) (let ((buffer (find-file-noselect pathname #f))) (set-variable! version-control #f buffer) (let ((value (receiver buffer))) diff --git a/v7/src/edwin/tagutl.scm b/v7/src/edwin/tagutl.scm index 285b26159..681c275d1 100644 --- a/v7/src/edwin/tagutl.scm +++ b/v7/src/edwin/tagutl.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: tagutl.scm,v 1.58 2000/02/25 20:18:38 cph Exp $ +;;; $Id: tagutl.scm,v 1.59 2000/03/27 20:44:25 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology ;;; @@ -27,7 +27,12 @@ "List of pathnames of all of the active tags tables. See documentation for visit-tags-table and visit-additional-tags-table." - false) + '() + (lambda (object) + (list-of-type? object + (lambda (object) + (or (string? object) + (pathname? object)))))) (define-command visit-tags-table "Tell tags commands to use only the tag table file FILE. @@ -37,23 +42,16 @@ 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-pathnames (list (expand-pathname pathname)))))) + (set-variable! tags-table-pathnames + (list (pathname-default-name filename "TAGS"))))) (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 (expand-pathname pathname) - (if (or (not (pathname-name pathname)) - (file-directory? pathname)) - (pathname-new-name (pathname-as-directory pathname) "TAGS") - pathname)) + (set-variable! tags-table-pathnames + (append (ref-variable tags-table-pathnames) + (list (pathname-default-name filename "TAGS")))))) (define-command find-tag "Find tag (in current list of tag tables) whose name contains TAGNAME. @@ -85,7 +83,7 @@ See documentation of variable tags-table-pathnames." ;;;; Find Tag (define find-tag-pathnames-list - false) + #f) (define (handle-includes! included-pathnames) (if included-pathnames @@ -101,15 +99,14 @@ See documentation of 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)) + (buffer (get-tags-table pathname)) (included-pathnames (get-included-pathnames buffer))) (handle-includes! included-pathnames) buffer)) (define (current-tags-table-buffer) (if find-tag-pathnames-list - (find-file-noselect (car find-tag-pathnames-list) false) + (find-file-noselect (car find-tag-pathnames-list) #f) #f)) (define (next-tags-table-buffer) @@ -118,8 +115,7 @@ See documentation of variable tags-table-pathnames." (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)) + (let* ((buffer (get-tags-table pathname)) (included-pathnames (get-included-pathnames buffer))) (handle-includes! included-pathnames) buffer)) @@ -144,11 +140,11 @@ See documentation of variable tags-table-pathnames." (find-tag string buffer (buffer-start buffer) find-file)))) (set! tags-loop-continuation (lambda () - (&find-tag-command false true find-file))) + (&find-tag-command #f #t find-file))) unspecific) (define previous-find-tag-string - false) + #f) (define (find-tag-default) (let ((end @@ -156,12 +152,12 @@ See documentation of variable tags-table-pathnames." (or (re-match-forward "\\(\\sw\\|\\s_\\)+" point (group-end point) - false) + #f) (let ((mark (re-search-backward "\\sw\\|\\s_" point (group-start point) - false))) + #f))) (and mark (mark1+ mark))))))) (and end @@ -276,7 +272,7 @@ See documentation of variable tags-file-pathnames." (lambda (source target delimited) (set! tags-loop-continuation (lambda () - (if (not (replace-string source target delimited true true)) + (if (not (replace-string source target delimited #t #t)) (begin (smart-buffer-kill) (tags-loop-start))))) @@ -293,15 +289,15 @@ command." (editor-error "No tags loop in progress")) (tags-loop-continuation))) -(define tags-loop-continuation false) +(define tags-loop-continuation #f) (define tags-loop-pathnames) -(define tags-loop-current-buffer false) +(define tags-loop-current-buffer #f) (define (tags-loop-start) (let ((pathnames tags-loop-pathnames)) (if (null? pathnames) (begin - (set! tags-loop-continuation false) + (set! tags-loop-continuation #f) (editor-error "All files processed."))) (set! tags-loop-pathnames (cdr pathnames)) (let ((buffer @@ -342,7 +338,7 @@ command." "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 + #t boolean?) ;;;; Tags Tables @@ -358,22 +354,22 @@ killed if they are not modified." (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 (get-tags-table pathname) + (let ((buffer + (let ((buffer (find-file-noselect pathname #f))) + (if (and (not (verify-visited-file-modification-time? buffer)) + (prompt-for-yes-or-no? + "Tags file has changed; read new contents")) + (revert-buffer buffer #t #t) + buffer)))) + (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page)) + (editor-error "File " + (->namestring pathname) + " not a valid tag table")) + buffer)) (define (pathnames->tags-table-buffers pathnames) - (map (lambda (pathname) - (verify-tags-table (find-file-noselect pathname false) - pathname)) - pathnames)) + (map get-tags-table pathnames)) (define (initial-tags-table-buffers) ;; first make sure there is at least one tags table -- 2.25.1