;;; -*-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
;;;
(declare (usual-integrations))
\f
(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.
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.
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."
\(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)
(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
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))))))
\f
(define (find-file-noselect filename warn?)
(let ((pathname (pathname-simplify (merge-pathnames filename))))
(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)
((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))
(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))))
\f
(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)
(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
(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))))))))))
(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) (string<? (car x) (car y))))
(lambda (buffer)
(let ((entry
name)))))))
(if entry
(begin
- (define-variable-local-value! buffer
- (ref-variable-object scheme-environment)
- (cadr entry))
+ (local-set-variable! scheme-environment (cadr entry) buffer)
(if (and (eq? 'DEFAULT (ref-variable scheme-environment buffer))
(not (eq? 'default (cadr entry))))
(begin
(message "Ignoring bad evaluation environment: "
(cadr entry))
- (define-variable-local-value! buffer
- (ref-variable-object scheme-syntax-table)
- 'DEFAULT))
- (define-variable-local-value! buffer
- (ref-variable-object scheme-syntax-table)
- (caddr entry))))))))
+ (local-set-variable! scheme-syntax-table
+ 'DEFAULT
+ buffer))
+ (local-set-variable! scheme-syntax-table
+ (caddr entry)
+ buffer)))))))
\f
(define (find-file-revert buffer)
- (if (not (verify-visited-file-modification-time? buffer))
+ (if (verify-visited-file-modification-time? buffer)
+ buffer
(let ((pathname (buffer-pathname buffer)))
(cond ((not (file-exists? pathname))
(editor-error "File "
(if (buffer-modified? buffer)
"Flush your changes"
"Read from disk")))
- (revert-buffer buffer true true))))))
+ (revert-buffer buffer #t #t))
+ (else buffer)))))
(define-command revert-buffer
"Replace the buffer text with the text of the visited file on disk.
Argument means don't offer to use auto-save file."
"P"
(lambda (argument)
- (revert-buffer (current-buffer) argument false)))
+ (revert-buffer (selected-buffer) argument #f)))
(define (revert-buffer buffer dont-use-auto-save? dont-confirm?)
((or (buffer-get buffer 'REVERT-BUFFER-METHOD) revert-buffer-default)
(if auto-save?
(buffer-auto-save-pathname buffer)
(buffer-pathname buffer))))
- (cond ((not pathname)
- (editor-error
- "Buffer does not seem to be associated with any file"))
- ((not (file-readable? pathname))
- (editor-error "File "
- (->namestring 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))))
\f
(define-command recover-file
"Visit file FILE, but get contents from its last 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 "
(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.
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)
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
(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)))
(->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?))
"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)
"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)))))
(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))
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."
"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))
"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
()
(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."
((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)))))
(if (pair? default)
(car default)
default))
- (buffer-default-directory (current-buffer))))
+ (buffer-default-directory (selected-buffer))))
(insertion
(os/pathname->display-string
(if (pair? default)
;;; -*-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
;;;
"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.
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.
;;;; Find Tag
(define find-tag-pathnames-list
- false)
+ #f)
(define (handle-includes! included-pathnames)
(if included-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)
(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))
(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)
\f
(define (find-tag-default)
(let ((end
(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
(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)))))
(editor-error "No tags loop in progress"))
(tags-loop-continuation)))
\f
-(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
"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?)
\f
;;;; Tags Tables
(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
projects / mit-scheme.git / commitdiff