533 lines
19 KiB
Scheme
533 lines
19 KiB
Scheme
#| -*-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 Frames
|
||
|
||
|
||
|
||
(define-class buffer-frame combination-leaf-window
|
||
(
|
||
;; The inferior (of type BUFFER-WINDOW) that displays the buffer's
|
||
;; text.
|
||
text-inferior
|
||
|
||
;; The inferior (of type MODELINE-WINDOW) that displays the
|
||
;; modeline. May be #F if this window has no modeline (e.g. a
|
||
;; typein window).
|
||
modeline-inferior
|
||
|
||
;; The inferior (of type VERTICAL-BORDER-WINDOW) that draws a
|
||
;; vertical border on the right-hand side of the window when this
|
||
;; window has a neighbor to its right.
|
||
border-inferior
|
||
|
||
;; A nonnegative integer that is updated when this window is
|
||
;; selected. This updating is performed by the editor frame that
|
||
;; this window is a part of.
|
||
last-select-time
|
||
))
|
||
|
||
(define-method buffer-frame (:make-leaf frame)
|
||
(let ((frame* (==> superior :make-inferior buffer-frame)))
|
||
(set-buffer-frame-size! frame* (window-x-size frame) (window-y-size frame))
|
||
(set-window-buffer! frame* (window-buffer frame))
|
||
(initial-modeline! frame* modeline-inferior)
|
||
frame*))
|
||
|
||
(define-method buffer-frame (:initialize! frame window*)
|
||
(usual==> frame :initialize! window*)
|
||
(set! text-inferior (make-inferior frame buffer-window))
|
||
(set! border-inferior (make-inferior frame vertical-border-window))
|
||
(set! last-select-time 0))
|
||
|
||
(define-method buffer-frame (:kill! window)
|
||
(remove-buffer-window! (window-buffer window) window)
|
||
(usual==> window :kill!))
|
||
|
||
(define-method buffer-frame (:update-display! window screen x-start y-start
|
||
xl xu yl yu display-style)
|
||
;; Assumes that interrupts are disabled.
|
||
(update-inferior! text-inferior screen x-start y-start
|
||
xl xu yl yu display-style
|
||
buffer-window:update-display!)
|
||
(if modeline-inferior
|
||
(update-inferior! modeline-inferior screen x-start y-start
|
||
xl xu yl yu display-style
|
||
modeline-window:update-display!))
|
||
(update-inferior! border-inferior screen x-start y-start
|
||
xl xu yl yu display-style
|
||
vertical-border-window:update-display!)
|
||
#t)
|
||
|
||
(define (initial-modeline! frame modeline?)
|
||
;; **** Kludge: The text-inferior will generate modeline events, so
|
||
;; if the modeline gets redisplayed first it will be left with its
|
||
;; redisplay-flag set but its superior's redisplay-flag cleared.
|
||
(with-instance-variables buffer-frame frame (modeline?)
|
||
(if modeline?
|
||
(begin
|
||
(set! modeline-inferior (make-inferior frame modeline-window))
|
||
(set! inferiors
|
||
(append! (delq! modeline-inferior inferiors)
|
||
(list modeline-inferior))))
|
||
(set! modeline-inferior #f))))
|
||
|
||
(define-integrable (frame-text-inferior frame)
|
||
(with-instance-variables buffer-frame frame ()
|
||
(inferior-window text-inferior)))
|
||
|
||
(define-integrable (frame-modeline-inferior frame)
|
||
(with-instance-variables buffer-frame frame ()
|
||
(and modeline-inferior
|
||
(inferior-window modeline-inferior))))
|
||
|
||
(define-method buffer-frame (:set-size! window x y)
|
||
(set-buffer-frame-size! window x y))
|
||
|
||
(define-method buffer-frame (:set-x-size! window x)
|
||
(set-buffer-frame-size! window x y-size))
|
||
|
||
(define-method buffer-frame (:set-y-size! window y)
|
||
(set-buffer-frame-size! window x-size y))
|
||
|
||
(define (set-buffer-frame-size! window x y)
|
||
(with-instance-variables buffer-frame window (x y)
|
||
(usual==> window :set-size! x y)
|
||
(if modeline-inferior
|
||
(begin
|
||
(set! y (- y (inferior-y-size modeline-inferior)))
|
||
(set-inferior-start! modeline-inferior 0 y)
|
||
(set-inferior-x-size! modeline-inferior x)))
|
||
(if (window-has-right-neighbor? window)
|
||
(begin
|
||
(set! x (- x (inferior-x-size border-inferior)))
|
||
(set-inferior-start! border-inferior x 0)
|
||
(set-inferior-y-size! border-inferior y))
|
||
(set-inferior-start! border-inferior #f #f))
|
||
(set-inferior-start! text-inferior 0 0)
|
||
(set-inferior-size! text-inferior x y)))
|
||
|
||
(define-method buffer-frame (:minimum-x-size window)
|
||
(if (window-has-right-neighbor? window)
|
||
(+ (ref-variable window-min-width)
|
||
(inferior-x-size border-inferior))
|
||
(ref-variable window-min-width)))
|
||
|
||
(define-method buffer-frame (:minimum-y-size window)
|
||
(if modeline-inferior
|
||
(+ (ref-variable window-min-height)
|
||
(inferior-y-size modeline-inferior))
|
||
(ref-variable window-min-height)))
|
||
|
||
;;;; External Entries
|
||
|
||
(define-integrable (buffer-frame? object)
|
||
(object-of-class? buffer-frame object))
|
||
|
||
(define (make-buffer-frame superior new-buffer modeline?)
|
||
(let ((frame (==> superior :make-inferior buffer-frame)))
|
||
(set-window-buffer! frame new-buffer)
|
||
(initial-modeline! frame modeline?)
|
||
frame))
|
||
|
||
(define-integrable (buffer-frame-x-size frame)
|
||
(window-x-size (frame-text-inferior frame)))
|
||
|
||
(define-integrable (buffer-frame-y-size frame)
|
||
(window-y-size (frame-text-inferior frame)))
|
||
|
||
(define-integrable (buffer-frame-needs-redisplay? frame)
|
||
(buffer-window/needs-redisplay? (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-cursor-enable! frame)
|
||
(buffer-window/cursor-enable! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-cursor-disable! frame)
|
||
(buffer-window/cursor-disable! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-select-time frame)
|
||
(with-instance-variables buffer-frame frame ()
|
||
last-select-time))
|
||
|
||
(define-integrable (set-window-select-time! frame time)
|
||
(with-instance-variables buffer-frame frame (time)
|
||
(set! last-select-time time)))
|
||
|
||
(define-integrable (window-buffer frame)
|
||
(buffer-window/buffer (frame-text-inferior frame)))
|
||
|
||
(define (set-window-buffer! frame buffer)
|
||
;; BUFFER-WINDOW/SET-BUFFER! expects to have interrupts locked here.
|
||
(without-interrupts
|
||
(lambda ()
|
||
;; Someday this will bite someone...
|
||
(if (and (string-ci=? (buffer-name buffer) "bluffer")
|
||
(null? (buffer-windows buffer)))
|
||
(buffer-reset! buffer))
|
||
(if (window-buffer frame)
|
||
(remove-buffer-window! (window-buffer frame) frame))
|
||
(buffer-window/set-buffer! (frame-text-inferior frame) buffer)
|
||
(add-buffer-window! buffer frame))))
|
||
|
||
(define-integrable (window-point frame)
|
||
(buffer-window/point (frame-text-inferior frame)))
|
||
|
||
(define-integrable (set-window-point! frame mark)
|
||
(buffer-window/set-point! (frame-text-inferior frame) mark))
|
||
|
||
(define-integrable (window-redraw! frame)
|
||
(buffer-window/redraw! (frame-text-inferior frame)))
|
||
|
||
(define (window-modeline-event! frame type)
|
||
(let ((window (frame-modeline-inferior frame)))
|
||
(if window
|
||
(modeline-window:event! window type)))
|
||
(screen-modeline-event! (window-screen frame) frame type))
|
||
|
||
(define (notice-window-changes! frame)
|
||
(let ((window (frame-modeline-inferior frame)))
|
||
(if window
|
||
(modeline-window:notice-changes! window)))
|
||
(%notice-window-changes! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-override-message window)
|
||
(buffer-window/override-message (frame-text-inferior window)))
|
||
|
||
(define-integrable (window-set-override-message! window message)
|
||
(buffer-window/set-override-message! (frame-text-inferior window) message))
|
||
|
||
(define-integrable (window-clear-override-message! window)
|
||
(buffer-window/clear-override-message! (frame-text-inferior window)))
|
||
|
||
(define-integrable (window-direct-update! frame display-style)
|
||
(buffer-window/direct-update! (frame-text-inferior frame) display-style))
|
||
|
||
(define-integrable (window-home-cursor! window)
|
||
(buffer-window/home-cursor! (frame-text-inferior window)))
|
||
|
||
(define-integrable (window-char->image frame char)
|
||
(%window-char->image (frame-text-inferior frame) char))
|
||
|
||
(define-integrable (window-direct-output-cursor! frame)
|
||
(buffer-window/direct-output-cursor! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-direct-output-forward-char! frame)
|
||
(buffer-window/direct-output-forward-char! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-direct-output-backward-char! frame)
|
||
(buffer-window/direct-output-backward-char! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-direct-output-insert-char! frame char)
|
||
(buffer-window/direct-output-insert-char! (frame-text-inferior frame) char))
|
||
|
||
(define-integrable (window-direct-output-insert-newline! frame)
|
||
(buffer-window/direct-output-insert-newline! (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-direct-output-insert-substring! frame
|
||
string start end)
|
||
(buffer-window/direct-output-insert-substring! (frame-text-inferior frame)
|
||
string start end))
|
||
|
||
(define-integrable (window-scroll-y-absolute! frame y-point)
|
||
(buffer-window/scroll-y-absolute! (frame-text-inferior frame) y-point))
|
||
|
||
(define-integrable (window-scroll-y-relative! frame delta)
|
||
(buffer-window/scroll-y-relative! (frame-text-inferior frame) delta))
|
||
|
||
(define-integrable (set-window-start-mark! frame mark force?)
|
||
(buffer-window/set-start-mark! (frame-text-inferior frame) mark force?))
|
||
|
||
(define-integrable (window-y-center frame)
|
||
(buffer-window/y-center (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-start-mark frame)
|
||
(buffer-window/start-mark (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-mark-visible? frame mark)
|
||
(buffer-window/mark-visible? (frame-text-inferior frame) mark))
|
||
|
||
(define-integrable (window-mark->x frame mark)
|
||
(buffer-window/mark->x (frame-text-inferior frame) mark))
|
||
|
||
(define-integrable (window-mark->y frame mark)
|
||
(buffer-window/mark->y (frame-text-inferior frame) mark))
|
||
|
||
(define-integrable (window-mark->coordinates frame mark)
|
||
(buffer-window/mark->coordinates (frame-text-inferior frame) mark))
|
||
|
||
(define-integrable (window-point-x frame)
|
||
(buffer-window/point-x (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-point-y frame)
|
||
(buffer-window/point-y (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-point-coordinates frame)
|
||
(buffer-window/point-coordinates (frame-text-inferior frame)))
|
||
|
||
(define-integrable (window-coordinates->mark frame x y)
|
||
(buffer-window/coordinates->mark (frame-text-inferior frame) x y))
|
||
|
||
(define-integrable (set-window-debug-trace! frame debug-trace)
|
||
(%set-window-debug-trace! (frame-text-inferior frame) debug-trace))
|
||
|
||
(define-variable-per-buffer truncate-lines
|
||
"True means do not display continuation lines;
|
||
give each line of text one screen line.
|
||
Automatically becomes local when set in any fashion.
|
||
|
||
Note that this is overridden by the variable
|
||
truncate-partial-width-windows if that variable is true
|
||
and this buffer is not full-screen width."
|
||
#f
|
||
boolean?)
|
||
|
||
(define-variable truncate-partial-width-windows
|
||
"True means truncate lines in all windows less than full screen wide."
|
||
#t
|
||
boolean?)
|
||
|
||
(define-variable-per-buffer tab-width
|
||
"Distance between tab stops (for display of tab characters), in columns.
|
||
Automatically becomes local when set in any fashion."
|
||
8
|
||
exact-nonnegative-integer?)
|
||
|
||
(define-variable-per-buffer char-image-strings
|
||
"A vector of 256 strings mapping ascii bytes to image strings.
|
||
Each image is a short string of at least one character.
|
||
Index 0 might contain \"^@\" so ascii NUL appears as ^@.
|
||
The indices for normal printing characters usually contain a
|
||
string containing just that character, e.g. index 65 usually contains \"A\".
|
||
Automatically becomes local when set in any fashion."
|
||
default-char-image-strings
|
||
(lambda (object)
|
||
(and (vector? object)
|
||
(= (vector-length object) 256)
|
||
(let loop ((i 0))
|
||
(if (= i 256)
|
||
#T
|
||
(and (string? (vector-ref object i))
|
||
(<= 1 (string-length (vector-ref object i)) 255)
|
||
(loop (+ i 1))))))))
|
||
|
||
(let ((setup-truncate-lines!
|
||
(lambda (buffer variable)
|
||
variable ;ignore
|
||
(for-each window-redraw! ;recaches these variables
|
||
(if buffer
|
||
(buffer-windows buffer)
|
||
(window-list))))))
|
||
(add-variable-assignment-daemon!
|
||
(ref-variable-object truncate-lines)
|
||
setup-truncate-lines!)
|
||
(add-variable-assignment-daemon!
|
||
(ref-variable-object truncate-partial-width-windows)
|
||
setup-truncate-lines!)
|
||
(add-variable-assignment-daemon!
|
||
(ref-variable-object tab-width)
|
||
setup-truncate-lines!)
|
||
(add-variable-assignment-daemon!
|
||
(ref-variable-object char-image-strings)
|
||
setup-truncate-lines!))
|
||
|
||
;;;; Window Configurations
|
||
|
||
(define-structure (window-configuration (conc-name window-configuration/))
|
||
(screen-x-size #f read-only #t)
|
||
(screen-y-size #f read-only #t)
|
||
(root-window #f read-only #t)
|
||
(root-x-size #f read-only #t)
|
||
(root-y-size #f read-only #t)
|
||
(selected-window #f read-only #t)
|
||
(cursor-window #f read-only #t)
|
||
(minibuffer-scroll-window #f read-only #t))
|
||
|
||
(define-structure (saved-combination (conc-name saved-combination/))
|
||
(vertical? #f read-only #t)
|
||
(children #f read-only #t))
|
||
|
||
(define-structure (saved-window (conc-name saved-window/))
|
||
(buffer #f read-only #t)
|
||
(point #f read-only #t)
|
||
(mark #f read-only #t)
|
||
(start-mark #f read-only #t))
|
||
|
||
(define (guarantee-window-configuration object procedure)
|
||
(if (not (window-configuration? object))
|
||
(error:wrong-type-argument object "window configuration" procedure)))
|
||
|
||
(define (screen-window-configuration screen)
|
||
(guarantee-screen screen 'SCREEN-WINDOW-CONFIGURATION)
|
||
(let ((frame (screen-root-window screen))
|
||
(converted-windows '()))
|
||
(let ((root-window
|
||
(let convert-window ((window (editor-frame-root-window frame)))
|
||
(if (combination? window)
|
||
(let ((vertical? (combination-vertical? window)))
|
||
(make-saved-combination
|
||
vertical?
|
||
(let loop ((window (combination-child window)))
|
||
(cons (cons (if vertical?
|
||
(window-y-size window)
|
||
(window-x-size window))
|
||
(convert-window window))
|
||
(let ((next (window-next window)))
|
||
(if next
|
||
(loop next)
|
||
'()))))))
|
||
(let ((saved-window
|
||
(let ((buffer (window-buffer window)))
|
||
(make-saved-window
|
||
buffer
|
||
(mark-right-inserting-copy (window-point window))
|
||
(let ((ring (buffer-mark-ring buffer)))
|
||
(if (ring-empty? ring)
|
||
#f
|
||
(mark-right-inserting-copy
|
||
(ring-ref ring 0))))
|
||
(mark-right-inserting-copy
|
||
(window-start-mark window))))))
|
||
(set! converted-windows
|
||
(cons (cons window saved-window) converted-windows))
|
||
saved-window))))
|
||
(converted-window
|
||
(lambda (window)
|
||
(let ((association (assq window converted-windows)))
|
||
(and association
|
||
(cdr association)))))
|
||
(selected-window (editor-frame-selected-window frame)))
|
||
(make-window-configuration
|
||
(screen-x-size screen)
|
||
(screen-y-size screen)
|
||
root-window
|
||
(window-x-size frame)
|
||
(window-y-size frame)
|
||
(converted-window selected-window)
|
||
(let ((window (editor-frame-cursor-window frame)))
|
||
(and (not (eq? window selected-window))
|
||
(converted-window window)))
|
||
(let ((window (weak-car *minibuffer-scroll-window*)))
|
||
(and (window? window)
|
||
(converted-window window)))))))
|
||
|
||
(define (set-screen-window-configuration! screen configuration)
|
||
(guarantee-screen screen 'SET-SCREEN-WINDOW-CONFIGURATION!)
|
||
(guarantee-window-configuration configuration
|
||
'SET-SCREEN-WINDOW-CONFIGURATION!)
|
||
(if (and (= (screen-x-size screen)
|
||
(window-configuration/screen-x-size configuration))
|
||
(= (screen-y-size screen)
|
||
(window-configuration/screen-y-size configuration)))
|
||
(begin
|
||
(delete-other-windows (screen-window0 screen))
|
||
(let ((x-size (window-configuration/root-x-size configuration))
|
||
(y-size (window-configuration/root-y-size configuration))
|
||
(frame (screen-root-window screen)))
|
||
(if (not (and (= x-size (window-x-size frame))
|
||
(= y-size (window-y-size frame))))
|
||
(set-editor-frame-size! frame x-size y-size)))
|
||
(let ((converted-windows '())
|
||
(need-buffers '()))
|
||
(let loop
|
||
((window (screen-window0 screen))
|
||
(saved-window (window-configuration/root-window configuration)))
|
||
(if (saved-combination? saved-window)
|
||
(let ((vertical? (saved-combination/vertical? saved-window)))
|
||
(let child-loop
|
||
((window window)
|
||
(children (saved-combination/children saved-window)))
|
||
(let ((new
|
||
((if vertical?
|
||
window-split-vertically!
|
||
window-split-horizontally!)
|
||
window
|
||
(caar children))))
|
||
(loop window (cdar children))
|
||
(if (null? (cddr children))
|
||
(loop new (cdadr children))
|
||
(child-loop new (cdr children))))))
|
||
(let ((buffer (saved-window/buffer saved-window)))
|
||
(if (buffer-alive? buffer)
|
||
(begin
|
||
(%set-buffer-point! buffer
|
||
(saved-window/point saved-window))
|
||
(select-buffer-no-record buffer window)
|
||
(let ((mark (saved-window/mark saved-window)))
|
||
(if mark (push-buffer-mark! buffer mark)))
|
||
(set-window-start-mark!
|
||
window
|
||
(saved-window/start-mark saved-window)
|
||
#t))
|
||
(set! need-buffers (cons window need-buffers)))
|
||
(set! converted-windows
|
||
(cons (cons saved-window window) converted-windows)))))
|
||
(for-each (lambda (window)
|
||
(let ((buffer (other-buffer #f)))
|
||
(if buffer
|
||
(select-buffer-no-record buffer window))))
|
||
need-buffers)
|
||
(let ((convert-window
|
||
(lambda (saved-window)
|
||
(let ((association (assq saved-window converted-windows)))
|
||
(and association (cdr association))))))
|
||
(let ((window
|
||
(window-configuration/selected-window configuration)))
|
||
(if window
|
||
(let ((window (convert-window window)))
|
||
(without-interrupts
|
||
(lambda () (screen-select-window! screen window))))))
|
||
(let ((window (window-configuration/cursor-window configuration)))
|
||
(if window
|
||
(let ((window (convert-window window)))
|
||
(without-interrupts
|
||
(lambda () (screen-select-cursor! screen window))))))
|
||
(let ((window
|
||
(window-configuration/minibuffer-scroll-window
|
||
configuration)))
|
||
(if window
|
||
(weak-set-car! *minibuffer-scroll-window*
|
||
(convert-window window)))))))))
|
||
|
||
(define (with-saved-configuration thunk)
|
||
(let ((screen (selected-screen)))
|
||
(let ((configuration (screen-window-configuration screen)))
|
||
(fluid-let ((restore-saved-continuation? #t))
|
||
(dynamic-wind
|
||
(lambda () unspecific)
|
||
thunk
|
||
(lambda ()
|
||
(if restore-saved-continuation?
|
||
(set-screen-window-configuration! screen configuration))))))))
|
||
|
||
(define (dont-restore-saved-configuration)
|
||
;; This conditional will signal an error if this procedure is called
|
||
;; outside the dynamic context of WITH-SAVED-CONFIGURATION.
|
||
(if restore-saved-continuation?
|
||
(set! restore-saved-continuation? #f))
|
||
unspecific)
|
||
|
||
(define restore-saved-continuation?)
|