2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-Scheme-*-
|
|
|
|
|
|
|
|
|
|
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
|
|
|
|
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
|
|
|
|
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
|
|
|
|
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
|
|
|
|
|
|
|
|
|
This file is part of MIT/GNU Scheme.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
|
|
|
|
it under the terms of the GNU General Public License as published by
|
|
|
|
|
the Free Software Foundation; either version 2 of the License, or (at
|
|
|
|
|
your option) any later version.
|
|
|
|
|
|
|
|
|
|
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
|
|
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
|
|
General Public License for more details.
|
|
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
|
|
|
along with MIT/GNU Scheme; if not, write to the Free Software
|
|
|
|
|
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
|
|
|
|
USA.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Buffer Commands
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(define (prompt-for-select-buffer prompt)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(list
|
|
|
|
|
(buffer-name
|
|
|
|
|
(prompt-for-buffer prompt (previous-buffer))))))
|
|
|
|
|
|
|
|
|
|
(define-command switch-to-buffer
|
|
|
|
|
"Select buffer with specified name.
|
|
|
|
|
If the variable select-buffer-create is true,
|
|
|
|
|
specifying a non-existent buffer will cause it to be created."
|
|
|
|
|
(prompt-for-select-buffer "Switch to buffer")
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(select-buffer (find-buffer buffer #t))))
|
|
|
|
|
|
|
|
|
|
(define-command switch-to-buffer-other-window
|
|
|
|
|
"Select buffer in another window."
|
|
|
|
|
(prompt-for-select-buffer "Switch to buffer in other window")
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(select-buffer-other-window (find-buffer buffer #t))))
|
|
|
|
|
|
|
|
|
|
(define-command switch-to-buffer-other-frame
|
|
|
|
|
"Select buffer in another frame."
|
|
|
|
|
(prompt-for-select-buffer "Switch to buffer in other frame")
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(select-buffer-other-screen (find-buffer buffer #t))))
|
|
|
|
|
(define edwin-command$switch-to-buffer-other-screen
|
|
|
|
|
edwin-command$switch-to-buffer-other-frame)
|
|
|
|
|
|
|
|
|
|
(define-command create-buffer
|
|
|
|
|
"Create a new buffer with a given name, and select it."
|
|
|
|
|
"sCreate buffer"
|
|
|
|
|
(lambda (name)
|
|
|
|
|
(select-buffer (new-buffer name))))
|
|
|
|
|
|
|
|
|
|
(define-command create-buffer-other-frame
|
|
|
|
|
"Create a new buffer with a given name, and select it in another frame."
|
|
|
|
|
"sCreate buffer in other frame"
|
|
|
|
|
(lambda (name)
|
|
|
|
|
(select-buffer-other-screen (new-buffer name))))
|
|
|
|
|
(define edwin-command$create-buffer-other-screen
|
|
|
|
|
edwin-command$create-buffer-other-frame)
|
|
|
|
|
|
|
|
|
|
(define-command insert-buffer
|
|
|
|
|
"Insert the contents of a specified buffer at point."
|
|
|
|
|
"bInsert buffer"
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(let ((point (mark-right-inserting (current-point))))
|
|
|
|
|
(region-insert-string!
|
|
|
|
|
point
|
|
|
|
|
(region->string (buffer-region (find-buffer buffer #t))))
|
|
|
|
|
(push-current-mark! (current-point))
|
|
|
|
|
(set-current-point! point))))
|
|
|
|
|
|
|
|
|
|
(define-command twiddle-buffers
|
|
|
|
|
"Select previous buffer."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (previous-buffer)))
|
|
|
|
|
(if buffer
|
|
|
|
|
(select-buffer buffer)
|
|
|
|
|
(editor-error "No previous buffer to select")))))
|
|
|
|
|
|
|
|
|
|
(define-command bury-buffer
|
|
|
|
|
"Put current buffer at the end of the list of all buffers.
|
|
|
|
|
There it is the least likely candidate for other-buffer to return;
|
|
|
|
|
thus, the least likely buffer for \\[switch-to-buffer] to select by default."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (current-buffer))
|
|
|
|
|
(previous (previous-buffer)))
|
|
|
|
|
(if previous
|
|
|
|
|
(begin
|
|
|
|
|
(select-buffer previous)
|
|
|
|
|
(bury-buffer buffer))))))
|
|
|
|
|
|
|
|
|
|
(define-command rename-buffer
|
|
|
|
|
"Change the name of the current buffer.
|
|
|
|
|
Reads the new name in the echo area."
|
|
|
|
|
"sRename buffer (to new name)"
|
|
|
|
|
(lambda (name)
|
|
|
|
|
(if (find-buffer name)
|
|
|
|
|
(editor-error "Buffer named " name " already exists"))
|
|
|
|
|
(rename-buffer (current-buffer) name)))
|
|
|
|
|
|
|
|
|
|
(define-command kill-buffer
|
|
|
|
|
"One arg, a string or a buffer. Get rid of the specified buffer."
|
|
|
|
|
"bKill buffer"
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(kill-buffer-interactive (find-buffer buffer #t))))
|
|
|
|
|
|
|
|
|
|
(define (kill-buffer-interactive buffer)
|
|
|
|
|
(if (not (other-buffer buffer)) (editor-error "Only one buffer"))
|
|
|
|
|
(save-buffer-changes buffer)
|
|
|
|
|
(if (every (lambda (procedure)
|
|
|
|
|
(procedure buffer))
|
|
|
|
|
(ref-variable kill-buffer-query-procedures buffer))
|
|
|
|
|
(kill-buffer buffer)
|
|
|
|
|
(message "Buffer not killed.")))
|
|
|
|
|
|
|
|
|
|
(define (kill-buffer-query-modified buffer)
|
|
|
|
|
(or (not (and (buffer-pathname buffer)
|
|
|
|
|
(buffer-modified? buffer)
|
|
|
|
|
(buffer-writeable? buffer)))
|
|
|
|
|
(prompt-for-yes-or-no?
|
|
|
|
|
(string-append "Buffer "
|
|
|
|
|
(buffer-name buffer)
|
|
|
|
|
" modified; kill anyway"))))
|
|
|
|
|
|
|
|
|
|
(define (kill-buffer-query-process buffer)
|
|
|
|
|
(or (not (get-buffer-process buffer))
|
|
|
|
|
(prompt-for-yes-or-no?
|
|
|
|
|
(string-append "Buffer "
|
|
|
|
|
(buffer-name buffer)
|
|
|
|
|
" has an active process; kill anyway"))))
|
|
|
|
|
|
|
|
|
|
(define-variable kill-buffer-query-procedures
|
|
|
|
|
"List of procedures called to query before killing a buffer.
|
|
|
|
|
Each procedure is called with one argument, the buffer being killed.
|
|
|
|
|
If any procedure returns #f, the buffer is not killed."
|
|
|
|
|
(list kill-buffer-query-modified kill-buffer-query-process)
|
|
|
|
|
(lambda (object) (and (list? object) (every procedure? object))))
|
|
|
|
|
|
|
|
|
|
(define-command kill-some-buffers
|
|
|
|
|
"For each buffer, ask whether to kill it."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(kill-some-buffers true)))
|
|
|
|
|
|
|
|
|
|
(define (kill-some-buffers prompt?)
|
|
|
|
|
(for-each (lambda (buffer)
|
|
|
|
|
(if (and (not (minibuffer? buffer))
|
|
|
|
|
(or (not prompt?)
|
|
|
|
|
(prompt-for-confirmation?
|
|
|
|
|
(string-append "Kill buffer '"
|
|
|
|
|
(buffer-name buffer)
|
|
|
|
|
"'"))))
|
|
|
|
|
(if (other-buffer buffer)
|
|
|
|
|
(kill-buffer-interactive buffer)
|
|
|
|
|
(let ((dummy (new-buffer "*Dummy*")))
|
|
|
|
|
(kill-buffer-interactive buffer)
|
|
|
|
|
(create-buffer initial-buffer-name)
|
|
|
|
|
(kill-buffer dummy)))))
|
|
|
|
|
(buffer-list)))
|
|
|
|
|
|
|
|
|
|
(define-command normal-mode
|
|
|
|
|
"Choose the major mode for this buffer automatically.
|
|
|
|
|
Also sets up any specified local variables of the file.
|
|
|
|
|
Uses the visited file name, the -*- line, and the local variables spec."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(normal-mode (current-buffer) false)))
|
|
|
|
|
|
|
|
|
|
(define-command toggle-mode-lock
|
|
|
|
|
"Change whether this buffer has its major mode locked.
|
|
|
|
|
When locked, the buffer's major mode may not be changed."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (current-buffer)))
|
|
|
|
|
(if (buffer-get buffer 'MAJOR-MODE-LOCKED)
|
|
|
|
|
(begin
|
|
|
|
|
(buffer-remove! buffer 'MAJOR-MODE-LOCKED)
|
|
|
|
|
(message "Major mode unlocked"))
|
|
|
|
|
(begin
|
|
|
|
|
(buffer-put! buffer 'MAJOR-MODE-LOCKED true)
|
|
|
|
|
(message "Major mode locked"))))))
|
|
|
|
|
|
|
|
|
|
(define-command not-modified
|
|
|
|
|
"Pretend that this buffer hasn't been altered."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(buffer-not-modified! (current-buffer))))
|
|
|
|
|
|
|
|
|
|
(define-command toggle-read-only
|
|
|
|
|
"Change whether this buffer is visiting its file read-only."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((buffer (current-buffer)))
|
|
|
|
|
(if (buffer-writeable? buffer)
|
|
|
|
|
(set-buffer-read-only! buffer)
|
|
|
|
|
(set-buffer-writeable! buffer)))))
|
|
|
|
|
|
|
|
|
|
(define-command no-toggle-read-only
|
|
|
|
|
"Display warning indicating that this buffer may not be modified."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(editor-failure "This buffer may not be modified.")))
|
|
|
|
|
|
|
|
|
|
(define (save-buffer-changes buffer)
|
|
|
|
|
(if (and (buffer-pathname buffer)
|
|
|
|
|
(buffer-modified? buffer)
|
|
|
|
|
(buffer-writeable? buffer)
|
|
|
|
|
(prompt-for-yes-or-no?
|
|
|
|
|
(string-append "Buffer "
|
|
|
|
|
(buffer-name buffer)
|
|
|
|
|
" contains changes. Write them out")))
|
|
|
|
|
(write-buffer-interactive buffer false)))
|
|
|
|
|
|
|
|
|
|
(define (new-buffer name)
|
|
|
|
|
(create-buffer (new-buffer-name name)))
|
|
|
|
|
|
|
|
|
|
(define (new-buffer-name name)
|
|
|
|
|
(if (find-buffer name)
|
|
|
|
|
(let search-loop ((n 2))
|
|
|
|
|
(let ((new-name (string-append name "<" (write-to-string n) ">")))
|
|
|
|
|
(if (find-buffer new-name)
|
|
|
|
|
(search-loop (1+ n))
|
|
|
|
|
new-name)))
|
|
|
|
|
name))
|
|
|
|
|
|
|
|
|
|
(define (pop-up-temporary-buffer name properties initialization)
|
|
|
|
|
(let ((buffer (temporary-buffer name)))
|
|
|
|
|
(let ((window (pop-up-buffer buffer #f)))
|
|
|
|
|
(initialization buffer window)
|
|
|
|
|
(set-buffer-point! buffer (buffer-start buffer))
|
|
|
|
|
(buffer-not-modified! buffer)
|
|
|
|
|
(if (memq 'READ-ONLY properties)
|
|
|
|
|
(set-buffer-read-only! buffer))
|
|
|
|
|
(if (and window (memq 'SHRINK-WINDOW properties))
|
|
|
|
|
(shrink-window-if-larger-than-buffer window))
|
|
|
|
|
(if (and (memq 'FLUSH-ON-SPACE properties)
|
|
|
|
|
(not (typein-window? (current-window))))
|
|
|
|
|
(begin
|
|
|
|
|
(message "Hit space to flush.")
|
|
|
|
|
(reset-command-prompt!)
|
|
|
|
|
(let ((char (keyboard-peek)))
|
|
|
|
|
(if (eqv? #\space char)
|
|
|
|
|
(begin
|
|
|
|
|
(keyboard-read)
|
|
|
|
|
(kill-pop-up-buffer #f))))
|
|
|
|
|
(clear-message))))))
|
|
|
|
|
|
|
|
|
|
(define (string->temporary-buffer string name properties)
|
|
|
|
|
(pop-up-temporary-buffer name properties
|
|
|
|
|
(lambda (buffer window)
|
|
|
|
|
window
|
|
|
|
|
(insert-string string (buffer-point buffer)))))
|
|
|
|
|
|
|
|
|
|
(define (call-with-output-to-temporary-buffer name properties procedure)
|
|
|
|
|
(pop-up-temporary-buffer name properties
|
|
|
|
|
(lambda (buffer window)
|
|
|
|
|
window
|
|
|
|
|
(call-with-output-mark (buffer-point buffer) procedure))))
|
|
|
|
|
|
|
|
|
|
(define (with-output-to-temporary-buffer name properties thunk)
|
|
|
|
|
(call-with-output-to-temporary-buffer name properties
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(parameterize ((current-output-port port))
|
|
|
|
|
(thunk)))))
|
|
|
|
|
|
|
|
|
|
(define (call-with-temporary-buffer name procedure)
|
|
|
|
|
(let ((buffer))
|
|
|
|
|
(dynamic-wind (lambda ()
|
|
|
|
|
(set! buffer (temporary-buffer name)))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(procedure buffer))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(kill-buffer buffer)
|
|
|
|
|
(set! buffer)
|
|
|
|
|
unspecific))))
|
|
|
|
|
|
|
|
|
|
(define (temporary-buffer name)
|
|
|
|
|
(let ((buffer (find-or-create-buffer name)))
|
|
|
|
|
(buffer-reset! buffer)
|
|
|
|
|
buffer))
|
|
|
|
|
|
|
|
|
|
(define (prompt-for-buffer prompt default-buffer . options)
|
|
|
|
|
(let ((name
|
|
|
|
|
(apply prompt-for-buffer-name prompt default-buffer
|
|
|
|
|
'REQUIRE-MATCH? (not (ref-variable select-buffer-create))
|
|
|
|
|
options)))
|
|
|
|
|
(or (find-buffer name)
|
|
|
|
|
(let loop ((hooks (ref-variable select-buffer-not-found-hooks)))
|
|
|
|
|
(cond ((null? hooks)
|
|
|
|
|
(let ((buffer (create-buffer name)))
|
|
|
|
|
(temporary-message "(New Buffer)")
|
|
|
|
|
buffer))
|
|
|
|
|
((let ((result ((car hooks) name)))
|
|
|
|
|
(and (buffer? result)
|
|
|
|
|
result)))
|
|
|
|
|
(else
|
|
|
|
|
(loop (cdr hooks))))))))
|
|
|
|
|
|
|
|
|
|
(define-variable select-buffer-create
|
|
|
|
|
"If true, buffer selection commands may create new buffers."
|
|
|
|
|
true
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-variable select-buffer-not-found-hooks
|
|
|
|
|
"List of procedures to be called for select-buffer on nonexistent buffer.
|
|
|
|
|
These procedures are called as soon as the error is detected.
|
|
|
|
|
The procedures are called in the order given,
|
|
|
|
|
until one of them returns a buffer.
|
|
|
|
|
This variable has no effect if select-buffer-create is false."
|
|
|
|
|
'()
|
|
|
|
|
list?)
|
|
|
|
|
|
|
|
|
|
(define (prompt-for-existing-buffer prompt default-buffer . options)
|
|
|
|
|
(find-buffer (apply prompt-for-buffer-name prompt default-buffer
|
|
|
|
|
'REQUIRE-MATCH? #t
|
|
|
|
|
options)
|
|
|
|
|
#t))
|
|
|
|
|
|
|
|
|
|
(define (prompt-for-buffer-name prompt default-buffer . options)
|
|
|
|
|
(apply prompt-for-string-table-name
|
|
|
|
|
prompt
|
|
|
|
|
(and default-buffer (buffer-name default-buffer))
|
|
|
|
|
(buffer-names)
|
|
|
|
|
'DEFAULT-TYPE (if default-buffer 'VISIBLE-DEFAULT 'NO-DEFAULT)
|
2021-04-26 07:57:47 -04:00
|
|
|
|
options))
|