1265 lines
45 KiB
Scheme
1265 lines
45 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 Windows: Base
|
||
|
||
|
||
|
||
;;; The following instance variables contain permanent marks, which
|
||
;;; must be copied if they are passed to someone outside the buffer
|
||
;;; window abstraction, because they are modified by side-effect.
|
||
;;;
|
||
;;; current-start-mark
|
||
;;; current-end-mark
|
||
;;; start-mark
|
||
;;; start-line-mark
|
||
;;; start-clip-mark
|
||
;;; end-clip-mark
|
||
|
||
(define-class buffer-window vanilla-window
|
||
(
|
||
;; The buffer being displayed in this window.
|
||
buffer
|
||
|
||
;; Caches for the values of buffer-local variables that are needed
|
||
;; for redisplay.
|
||
truncate-lines?
|
||
tab-width
|
||
char-image-strings
|
||
|
||
;; The point marker in this window.
|
||
point
|
||
|
||
;; This is the inferior window (of class CURSOR-WINDOW) that
|
||
;; displays the cursor for this window.
|
||
cursor-inferior
|
||
|
||
;; This is the inferior window (of class BLANK-WINDOW) that keeps
|
||
;; the bottom of the window clear when there is no text in it.
|
||
;; This is only used when the end of the buffer is visible in the
|
||
;; window. When not in use, it is moved offscreen so the window
|
||
;; clipping will prevent it from being updated.
|
||
blank-inferior
|
||
|
||
;; The topmost and bottommost OUTLINE structures for this window,
|
||
;; respectively. If only one line is shown, these are EQ?.
|
||
start-outline
|
||
end-outline
|
||
|
||
;; A previously allocated OUTLINE structure that is available for
|
||
;; reallocation. Any other free OUTLINE structures are chained to
|
||
;; this one through its NEXT field.
|
||
free-outline
|
||
|
||
;; A permanent right-inserting mark at the beginning of the text
|
||
;; line modelled by START-OUTLINE.
|
||
current-start-mark
|
||
|
||
;; A permanent left-inserting mark at the end of the text line
|
||
;; modelled by END-OUTLINE.
|
||
current-end-mark
|
||
|
||
;; The number of characters on the first line that are invisible,
|
||
;; i.e. off the top of the window.
|
||
current-start-delta
|
||
|
||
;; The value of START-PARTIAL for the current window contents.
|
||
current-start-partial
|
||
|
||
;; The Y position, relative to the window, of the top edge of
|
||
;; START-OUTLINE. A non-positive number.
|
||
current-start-y
|
||
|
||
;; The Y position, relative to the window, of the bottom edge of
|
||
;; END-OUTLINE. A positive number.
|
||
current-end-y
|
||
|
||
;; A previously allocated O3 structure that is available for
|
||
;; reallocation. Any other free O3 structures are chained to this
|
||
;; one through its OUTLINE field.
|
||
free-o3
|
||
|
||
;; This is normally #F. However, when the normal display of the
|
||
;; buffer is overridden by a one-line message, as is commonly done
|
||
;; for the typein window, this variable contains the message
|
||
;; string.
|
||
override-string
|
||
|
||
;; This permanent mark is the smallest that is visible in the
|
||
;; window. If the window's start is not known, this is #F.
|
||
start-mark
|
||
|
||
;; This permanent mark is at the beginning of the line containing
|
||
;; START-MARK. It is #F if START-MARK is. Note that this is the
|
||
;; same as CURRENT-START-MARK at the end of a display update, and
|
||
;; is changed due to point motion and scrolling.
|
||
start-line-mark
|
||
|
||
;; This is the Y coordinate of START-LINE-MARK. It is undefined if
|
||
;; START-LINE-MARK is #F, otherwise it is guaranteed to be
|
||
;; non-positive.
|
||
start-line-y
|
||
|
||
;; This is the number of columns between START-LINE-MARK
|
||
;; (inclusive) and START-MARK (exclusive). In other words, it is
|
||
;; the starting column of START-MARK. This is undefined if
|
||
;; START-MARK is #F.
|
||
start-column
|
||
|
||
;; If the character to the right of START-MARK is completely
|
||
;; visible, this is zero. Otherwise, this is the number of columns
|
||
;; of that character that are visible. This is undefined if
|
||
;; START-MARK is #F.
|
||
start-partial
|
||
|
||
;; This contains the buffer's MODIFIED-TICK from the last time that
|
||
;; redisplay completed for this window.
|
||
modified-tick
|
||
|
||
;; This contains the daemon that is invoked when the buffer's
|
||
;; display clipping is changed.
|
||
clip-daemon
|
||
|
||
;; These variables delimit the region of the buffer that has been
|
||
;; unaffected by clipping since the last display update. If the
|
||
;; clipping has not changed since then, they are #F.
|
||
start-clip-mark
|
||
end-clip-mark
|
||
|
||
;; This flag is set to #F at the end of a display update, and
|
||
;; subsequently set to a true value if the point has moved, or if
|
||
;; it was inside a changed region, or if it was outside a clipping
|
||
;; region, or any of several other conditions that could possibly
|
||
;; affect the validity of our idea about where point is. However,
|
||
;; there are two possible true values: #T means that the START-MARK
|
||
;; for the window has been recomputed and is known to be correct.
|
||
;; 'SINCE-START-MARK means the new START-MARK has not yet been
|
||
;; computed.
|
||
point-moved?
|
||
|
||
;; If true, this flag indicates that the window should be entirely
|
||
;; redrawn at the next display update.
|
||
force-redraw?
|
||
|
||
;; These variables record where the last display update drew its
|
||
;; output. SAVED-SCREEN is the screen on which it occurred.
|
||
;; SAVED-X-START and SAVED-Y-START is the position, in the screen's
|
||
;; coordinates, at which the window was located. SAVED-XL,
|
||
;; SAVED-XU, SAVED-YL, and SAVED-YU (window's coordinates) delimit
|
||
;; the rectangular portion of the window that was drawn.
|
||
saved-screen
|
||
saved-x-start
|
||
saved-y-start
|
||
saved-xl
|
||
saved-xu
|
||
saved-yl
|
||
saved-yu
|
||
|
||
;; This variable, if not #F, is a procedure that is called at
|
||
;; interesting times to generate a debugging trace.
|
||
debug-trace))
|
||
|
||
;;;; Instance Variable Accessors
|
||
|
||
(define-integrable (%window-buffer window)
|
||
(with-instance-variables buffer-window window () buffer))
|
||
|
||
(define-integrable (%window-group window)
|
||
(buffer-group (%window-buffer window)))
|
||
|
||
(define-integrable (%set-window-buffer! window buffer*)
|
||
(with-instance-variables buffer-window window (buffer*)
|
||
(set! buffer buffer*)))
|
||
|
||
(define-integrable (%window-truncate-lines? window)
|
||
(with-instance-variables buffer-window window () truncate-lines?))
|
||
|
||
(define-integrable (%set-window-truncate-lines?! window truncate-lines?*)
|
||
(with-instance-variables buffer-window window (truncate-lines?*)
|
||
(set! truncate-lines? truncate-lines?*)))
|
||
|
||
(define-integrable (%window-tab-width window)
|
||
(with-instance-variables buffer-window window () tab-width))
|
||
|
||
(define-integrable (%set-window-tab-width! window tab-width*)
|
||
(with-instance-variables buffer-window window (tab-width*)
|
||
(set! tab-width tab-width*)))
|
||
|
||
(define-integrable (%window-char-image-strings window)
|
||
(with-instance-variables buffer-window window () char-image-strings))
|
||
|
||
(define-integrable (%set-window-char-image-strings! window char-image-strings*)
|
||
(with-instance-variables buffer-window window (char-image-strings*)
|
||
(set! char-image-strings char-image-strings*)))
|
||
|
||
(define-integrable (%window-char->image window char)
|
||
(vector-ref (%window-char-image-strings window)
|
||
(char->integer char)))
|
||
|
||
(define-integrable (%window-point window)
|
||
(with-instance-variables buffer-window window () point))
|
||
|
||
(define-integrable (%window-point-index window)
|
||
(mark-index (%window-point window)))
|
||
|
||
(define-integrable (%set-window-point! window point*)
|
||
(with-instance-variables buffer-window window (point*)
|
||
(set! point point*)))
|
||
|
||
(define (%set-window-point-index! window index)
|
||
#| Optimization causes lossage. -- cph
|
||
(let ((point (%window-point window)))
|
||
(if point
|
||
(set-mark-index! point index)
|
||
(%set-window-point! window
|
||
(make-permanent-mark (%window-group window)
|
||
index
|
||
#t))))
|
||
|#
|
||
(%set-window-point! window
|
||
(make-permanent-mark (%window-group window)
|
||
index
|
||
#t)))
|
||
|
||
(define (set-window-point-index! window index)
|
||
(%set-window-point-index! window index)
|
||
(%set-buffer-point-index! (%window-buffer window) index))
|
||
|
||
(define-integrable (%window-cursor-inferior window)
|
||
(with-instance-variables buffer-window window () cursor-inferior))
|
||
|
||
(define-integrable (%set-window-cursor-inferior! window inferior)
|
||
(with-instance-variables buffer-window window (inferior)
|
||
(set! cursor-inferior inferior)))
|
||
|
||
(define-integrable (%window-blank-inferior window)
|
||
(with-instance-variables buffer-window window () blank-inferior))
|
||
|
||
(define-integrable (%set-window-blank-inferior! window inferior)
|
||
(with-instance-variables buffer-window window (inferior)
|
||
(set! blank-inferior inferior)))
|
||
|
||
(define-integrable (%window-start-outline window)
|
||
(with-instance-variables buffer-window window () start-outline))
|
||
|
||
(define-integrable (%set-window-start-outline! window outline)
|
||
(with-instance-variables buffer-window window (outline)
|
||
(set! start-outline outline)))
|
||
|
||
(define-integrable (%window-end-outline window)
|
||
(with-instance-variables buffer-window window () end-outline))
|
||
|
||
(define-integrable (%set-window-end-outline! window outline)
|
||
(with-instance-variables buffer-window window (outline)
|
||
(set! end-outline outline)))
|
||
|
||
(define-integrable (%window-free-outline window)
|
||
(with-instance-variables buffer-window window () free-outline))
|
||
|
||
(define-integrable (%set-window-free-outline! window outline)
|
||
(with-instance-variables buffer-window window (outline)
|
||
(set! free-outline outline)))
|
||
|
||
(define-integrable (%window-current-start-mark window)
|
||
(with-instance-variables buffer-window window () current-start-mark))
|
||
|
||
(define-integrable (%window-current-start-index window)
|
||
(mark-index (%window-current-start-mark window)))
|
||
|
||
(define-integrable (%set-window-current-start-mark! window mark)
|
||
(with-instance-variables buffer-window window (mark)
|
||
(set! current-start-mark mark)))
|
||
|
||
(define-integrable (%window-current-end-mark window)
|
||
(with-instance-variables buffer-window window () current-end-mark))
|
||
|
||
(define-integrable (%window-current-end-index window)
|
||
(mark-index (%window-current-end-mark window)))
|
||
|
||
(define-integrable (%set-window-current-end-mark! window mark)
|
||
(with-instance-variables buffer-window window (mark)
|
||
(set! current-end-mark mark)))
|
||
|
||
(define-integrable (%window-current-start-delta window)
|
||
(with-instance-variables buffer-window window () current-start-delta))
|
||
|
||
(define-integrable (%set-window-current-start-delta! window delta)
|
||
(with-instance-variables buffer-window window (delta)
|
||
(set! current-start-delta delta)))
|
||
|
||
(define-integrable (%window-current-start-partial window)
|
||
(with-instance-variables buffer-window window () current-start-partial))
|
||
|
||
(define-integrable (%set-window-current-start-partial! window partial)
|
||
(with-instance-variables buffer-window window (partial)
|
||
(set! current-start-partial partial)))
|
||
|
||
(define-integrable (%window-current-start-y window)
|
||
(with-instance-variables buffer-window window () current-start-y))
|
||
|
||
(define-integrable (%set-window-current-start-y! window y)
|
||
(with-instance-variables buffer-window window (y)
|
||
(set! current-start-y y)))
|
||
|
||
(define-integrable (%window-current-end-y window)
|
||
(with-instance-variables buffer-window window () current-end-y))
|
||
|
||
(define-integrable (%set-window-current-end-y! window y)
|
||
(with-instance-variables buffer-window window (y)
|
||
(set! current-end-y y)))
|
||
|
||
(define-integrable (%window-free-o3 window)
|
||
(with-instance-variables buffer-window window () free-o3))
|
||
|
||
(define-integrable (%set-window-free-o3! window o3)
|
||
(with-instance-variables buffer-window window (o3)
|
||
(set! free-o3 o3)))
|
||
|
||
(define-integrable (%window-override-string window)
|
||
(with-instance-variables buffer-window window () override-string))
|
||
|
||
(define-integrable (%set-window-override-string! window string)
|
||
(with-instance-variables buffer-window window (string)
|
||
(set! override-string string)))
|
||
|
||
(define-integrable (%window-start-mark window)
|
||
(with-instance-variables buffer-window window () start-mark))
|
||
|
||
(define-integrable (%window-start-index window)
|
||
(mark-index (%window-start-mark window)))
|
||
|
||
(define-integrable (%set-window-start-mark! window mark)
|
||
(with-instance-variables buffer-window window (mark)
|
||
(set! start-mark mark)))
|
||
|
||
(define-integrable (%window-start-line-mark window)
|
||
(with-instance-variables buffer-window window () start-line-mark))
|
||
|
||
(define-integrable (%window-start-line-index window)
|
||
(mark-index (%window-start-line-mark window)))
|
||
|
||
(define-integrable (%set-window-start-line-mark! window mark)
|
||
(with-instance-variables buffer-window window (mark)
|
||
(set! start-line-mark mark)))
|
||
|
||
(define-integrable (%window-start-line-y window)
|
||
(with-instance-variables buffer-window window () start-line-y))
|
||
|
||
(define-integrable (%set-window-start-line-y! window y)
|
||
(with-instance-variables buffer-window window (y)
|
||
(set! start-line-y y)))
|
||
|
||
(define-integrable (%window-start-column window)
|
||
(with-instance-variables buffer-window window () start-column))
|
||
|
||
(define-integrable (%set-window-start-column! window column)
|
||
(with-instance-variables buffer-window window (column)
|
||
(set! start-column column)))
|
||
|
||
(define-integrable (%window-start-partial window)
|
||
(with-instance-variables buffer-window window () start-partial))
|
||
|
||
(define-integrable (%set-window-start-partial! window partial)
|
||
(with-instance-variables buffer-window window (partial)
|
||
(set! start-partial partial)))
|
||
|
||
(define-integrable (%window-modified-tick window)
|
||
(with-instance-variables buffer-window window () modified-tick))
|
||
|
||
(define-integrable (%set-window-modified-tick! window tick)
|
||
(with-instance-variables buffer-window window (tick)
|
||
(set! modified-tick tick)))
|
||
|
||
(define-integrable (%window-start-changes-index window)
|
||
(group-start-changes-index (%window-group window)))
|
||
|
||
(define-integrable (%window-end-changes-index window)
|
||
(group-end-changes-index (%window-group window)))
|
||
|
||
(define-integrable (%window-clip-daemon window)
|
||
(with-instance-variables buffer-window window () clip-daemon))
|
||
|
||
(define-integrable (%set-window-clip-daemon! window daemon)
|
||
(with-instance-variables buffer-window window (daemon)
|
||
(set! clip-daemon daemon)))
|
||
|
||
(define-integrable (%window-start-clip-mark window)
|
||
(with-instance-variables buffer-window window () start-clip-mark))
|
||
|
||
(define-integrable (%window-start-clip-index window)
|
||
(mark-index (%window-start-clip-mark window)))
|
||
|
||
(define-integrable (%set-window-start-clip-mark! window mark)
|
||
(with-instance-variables buffer-window window (mark)
|
||
(set! start-clip-mark mark)))
|
||
|
||
(define-integrable (%window-end-clip-mark window)
|
||
(with-instance-variables buffer-window window () end-clip-mark))
|
||
|
||
(define-integrable (%window-end-clip-index window)
|
||
(mark-index (%window-end-clip-mark window)))
|
||
|
||
(define-integrable (%set-window-end-clip-mark! window mark)
|
||
(with-instance-variables buffer-window window (mark)
|
||
(set! end-clip-mark mark)))
|
||
|
||
(define-integrable (%window-point-moved? window)
|
||
(with-instance-variables buffer-window window () point-moved?))
|
||
|
||
(define-integrable (%set-window-point-moved?! window point-moved?*)
|
||
(with-instance-variables buffer-window window (point-moved?*)
|
||
(set! point-moved? point-moved?*)))
|
||
|
||
(define-integrable (%window-force-redraw? window)
|
||
(with-instance-variables buffer-window window () force-redraw?))
|
||
|
||
(define-integrable (%set-window-force-redraw?! window force-redraw?*)
|
||
(with-instance-variables buffer-window window (force-redraw?*)
|
||
(set! force-redraw? force-redraw?*)))
|
||
|
||
(define-integrable (%window-saved-screen window)
|
||
(with-instance-variables buffer-window window () saved-screen))
|
||
|
||
(define-integrable (%set-window-saved-screen! window screen)
|
||
(with-instance-variables buffer-window window (screen)
|
||
(set! saved-screen screen)))
|
||
|
||
(define-integrable (%window-saved-x-start window)
|
||
(with-instance-variables buffer-window window () saved-x-start))
|
||
|
||
(define-integrable (%set-window-saved-x-start! window x-start)
|
||
(with-instance-variables buffer-window window (x-start)
|
||
(set! saved-x-start x-start)))
|
||
|
||
(define-integrable (%window-saved-y-start window)
|
||
(with-instance-variables buffer-window window () saved-y-start))
|
||
|
||
(define-integrable (%set-window-saved-y-start! window y-start)
|
||
(with-instance-variables buffer-window window (y-start)
|
||
(set! saved-y-start y-start)))
|
||
|
||
(define-integrable (%window-saved-xl window)
|
||
(with-instance-variables buffer-window window () saved-xl))
|
||
|
||
(define-integrable (%set-window-saved-xl! window xl)
|
||
(with-instance-variables buffer-window window (xl)
|
||
(set! saved-xl xl)))
|
||
|
||
(define-integrable (%window-saved-xu window)
|
||
(with-instance-variables buffer-window window () saved-xu))
|
||
|
||
(define-integrable (%set-window-saved-xu! window xu)
|
||
(with-instance-variables buffer-window window (xu)
|
||
(set! saved-xu xu)))
|
||
|
||
(define-integrable (%window-saved-yl window)
|
||
(with-instance-variables buffer-window window () saved-yl))
|
||
|
||
(define-integrable (%set-window-saved-yl! window yl)
|
||
(with-instance-variables buffer-window window (yl)
|
||
(set! saved-yl yl)))
|
||
|
||
(define-integrable (%window-saved-yu window)
|
||
(with-instance-variables buffer-window window () saved-yu))
|
||
|
||
(define-integrable (%set-window-saved-yu! window yu)
|
||
(with-instance-variables buffer-window window (yu)
|
||
(set! saved-yu yu)))
|
||
|
||
(define-integrable (%window-debug-trace window)
|
||
(with-instance-variables buffer-window window () debug-trace))
|
||
|
||
(define-integrable (%set-window-debug-trace! window procedure)
|
||
(with-instance-variables buffer-window window (procedure)
|
||
(set! debug-trace procedure)))
|
||
|
||
;;;; Outlines
|
||
|
||
(define-structure (outline
|
||
(constructor %make-outline)
|
||
(print-procedure
|
||
(bracketed-print-method 'OUTLINE
|
||
(lambda (outline port)
|
||
(write-string "index: " port)
|
||
(write (outline-index-length outline) port)
|
||
(write-string " y: " port)
|
||
(write (outline-y-size outline) port)))))
|
||
;; The number of characters in the text line. This is exclusive of
|
||
;; the newlines at the line's beginning and end, if any.
|
||
index-length
|
||
|
||
;; The number of screen lines that are occupied by this text line.
|
||
y-size
|
||
|
||
;; A pointer to the previous outline structure, the one representing
|
||
;; the text line that appears directly above this line.
|
||
previous
|
||
|
||
;; A pointer to the next outline structure, the one representing the
|
||
;; text line that appears directly below this line.
|
||
next)
|
||
|
||
(define (make-outline window index-length y-size previous next)
|
||
(let ((outline
|
||
(let ((outline (%window-free-outline window)))
|
||
(if (%window-free-outline window)
|
||
(begin
|
||
(let ((free (outline-next outline)))
|
||
(if free (set-outline-previous! free #f))
|
||
(%set-window-free-outline! window free))
|
||
(set-outline-index-length! outline index-length)
|
||
(set-outline-y-size! outline y-size)
|
||
(set-outline-previous! outline previous)
|
||
(set-outline-next! outline next)
|
||
outline)
|
||
(%make-outline index-length y-size previous next)))))
|
||
(if previous (set-outline-next! previous outline))
|
||
(if next (set-outline-previous! next outline))
|
||
outline))
|
||
|
||
(define (deallocate-outlines! window start-outline end-outline)
|
||
(let ((free-outline (%window-free-outline window)))
|
||
(if (outline-next end-outline)
|
||
(set-outline-previous! (outline-next end-outline) #f))
|
||
(set-outline-next! end-outline free-outline)
|
||
(if free-outline
|
||
(set-outline-previous! free-outline end-outline)))
|
||
(if (outline-previous start-outline)
|
||
(set-outline-next! (outline-previous start-outline) #f))
|
||
(set-outline-previous! start-outline #f)
|
||
(%set-window-free-outline! window start-outline))
|
||
|
||
(define-integrable (outline-last outline)
|
||
(do ((outline outline (outline-next outline)))
|
||
((not (outline-next outline)) outline)))
|
||
|
||
(define-integrable (outline-end-y outline start-y)
|
||
(do ((outline outline (outline-next outline))
|
||
(y start-y (fix:+ y (outline-y-size outline))))
|
||
((not outline) y)))
|
||
|
||
(define-integrable (outline-start-y outline end-y)
|
||
(do ((outline outline (outline-previous outline))
|
||
(y end-y (fix:- y (outline-y-size outline))))
|
||
((not outline) y)))
|
||
|
||
(define-structure (o3
|
||
(constructor %make-o3)
|
||
(print-procedure
|
||
(bracketed-print-method 'O3
|
||
(lambda (o3 port)
|
||
(write-string "index: " port)
|
||
(write (o3-index o3) port)
|
||
(write-string " y: " port)
|
||
(write (o3-y o3) port)
|
||
(if (outline? (o3-outline o3))
|
||
(begin
|
||
(write-string " " port)
|
||
(write (o3-outline o3) port)))))))
|
||
outline
|
||
index
|
||
y)
|
||
|
||
(define (make-o3 window outline index y)
|
||
(let ((o3 (%window-free-o3 window)))
|
||
(if o3
|
||
(begin
|
||
(%set-window-free-o3! window (o3-outline o3))
|
||
(set-o3-outline! o3 outline)
|
||
(set-o3-index! o3 index)
|
||
(set-o3-y! o3 y)
|
||
o3)
|
||
(%make-o3 outline index y))))
|
||
|
||
(define (deallocate-o3! window o3)
|
||
(set-o3-outline! o3 (%window-free-o3 window))
|
||
(%set-window-free-o3! window o3))
|
||
|
||
;;;; Narrowing
|
||
|
||
(define-integrable (%window-group-start-mark window)
|
||
(group-display-start (%window-group window)))
|
||
|
||
(define-integrable (%window-group-end-mark window)
|
||
(group-display-end (%window-group window)))
|
||
|
||
(define-integrable (%window-group-start-index window)
|
||
(mark-index (%window-group-start-mark window)))
|
||
|
||
(define-integrable (%window-group-end-index window)
|
||
(mark-index (%window-group-end-mark window)))
|
||
|
||
(define-integrable (%window-group-start-index? window index)
|
||
(fix:<= index (%window-group-start-index window)))
|
||
|
||
(define-integrable (%window-group-end-index? window index)
|
||
(fix:>= index (%window-group-end-index window)))
|
||
|
||
(define-integrable (%window-line-start-index window index)
|
||
(let ((start (%window-group-start-index window)))
|
||
(or (%find-previous-newline (%window-group window) index start)
|
||
start)))
|
||
|
||
(define-integrable (%window-line-end-index window index)
|
||
(let ((end (%window-group-end-index window)))
|
||
(or (%find-next-newline (%window-group window) index end)
|
||
end)))
|
||
|
||
(define (%window-line-start-index? window index)
|
||
(or (%window-group-start-index? window index)
|
||
(char=? (string-ref (group-text (%window-group window))
|
||
(fix:- (group-index->position-integrable
|
||
(%window-group window)
|
||
index
|
||
#f)
|
||
1))
|
||
#\newline)))
|
||
|
||
(define (%window-line-end-index? window index)
|
||
(or (%window-group-end-index? window index)
|
||
(char=? (string-ref (group-text (%window-group window))
|
||
(group-index->position-integrable
|
||
(%window-group window)
|
||
index
|
||
#t))
|
||
#\newline)))
|
||
|
||
(define (clip-mark-to-display window mark)
|
||
(if (not (mark? mark))
|
||
(error:wrong-type-argument mark "mark" 'CLIP-MARK-TO-DISPLAY))
|
||
(if (and (%window-point window)
|
||
(not (mark~ (%window-point window) mark)))
|
||
(error:bad-range-argument mark 'CLIP-MARK-TO-DISPLAY))
|
||
(cond ((group-display-start-index? (mark-group mark) (mark-index mark))
|
||
(group-display-start (mark-group mark)))
|
||
((group-display-end-index? (mark-group mark) (mark-index mark))
|
||
(group-display-end (mark-group mark)))
|
||
(else
|
||
mark)))
|
||
|
||
;;;; Utilities
|
||
|
||
(define-integrable (%window-extract-string window start end)
|
||
(group-extract-string (%window-group window) start end))
|
||
|
||
(define-integrable (%window-modeline-event! window type)
|
||
(window-modeline-event! (window-superior window) type))
|
||
|
||
;;;; Standard Methods
|
||
|
||
(define-method buffer-window (:initialize! window window*)
|
||
(usual==> window :initialize! window*)
|
||
(%reset-window-structures! window)
|
||
(%clear-window-buffer-state! window))
|
||
|
||
(define-method buffer-window (:kill! window)
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(%unset-window-buffer! window)
|
||
(set-interrupt-enables! mask))
|
||
(usual==> window :kill!))
|
||
|
||
(define-method buffer-window (:salvage! window)
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(%set-window-point-index! window (%window-group-start-index window))
|
||
(%set-window-point-moved?! window 'SINCE-START-SET)
|
||
(%reset-window-structures! window)
|
||
(buffer-window/redraw! window)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))
|
||
|
||
(define-method buffer-window (:set-size! window x y)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-size! x y))
|
||
(buffer-window/redraw! window)
|
||
(%release-window-outlines! window)
|
||
(set-window-size! window x y)
|
||
(%set-window-point-moved?! window 'SINCE-START-SET))
|
||
|
||
(define-method buffer-window (:set-x-size! window x)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-x-size! x))
|
||
(buffer-window/redraw! window)
|
||
(set-window-x-size! window x)
|
||
(%set-window-point-moved?! window 'SINCE-START-SET))
|
||
|
||
(define-method buffer-window (:set-y-size! window y)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-y-size! y))
|
||
(buffer-window/redraw! window)
|
||
(%release-window-outlines! window)
|
||
(set-window-y-size! window y)
|
||
(%set-window-point-moved?! window 'SINCE-START-SET))
|
||
|
||
(define (buffer-window/cursor-enable! window)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'cursor-enable!))
|
||
(==> (inferior-window (%window-cursor-inferior window)) :enable!))
|
||
|
||
(define (buffer-window/cursor-disable! window)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'cursor-disable!))
|
||
(==> (inferior-window (%window-cursor-inferior window)) :disable!))
|
||
|
||
;;;; Update
|
||
|
||
(define (buffer-window:update-display! window screen x-start y-start
|
||
xl xu yl yu display-style)
|
||
;; Assumes that interrupts are disabled.
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window ':update-display!
|
||
screen x-start y-start xl xu yl yu
|
||
display-style))
|
||
(%set-window-saved-screen! window screen)
|
||
(%set-window-saved-x-start! window x-start)
|
||
(%set-window-saved-y-start! window y-start)
|
||
(%set-window-saved-xl! window xl)
|
||
(%set-window-saved-xu! window xu)
|
||
(%set-window-saved-yl! window yl)
|
||
(%set-window-saved-yu! window yu)
|
||
(update-buffer-window! window screen x-start y-start xl xu yl yu
|
||
display-style))
|
||
|
||
(define-method buffer-window :update-display!
|
||
buffer-window:update-display!)
|
||
|
||
(define (buffer-window/direct-update! window display-style)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'direct-update!
|
||
display-style))
|
||
(and (%window-saved-screen window)
|
||
(begin
|
||
(%notice-window-changes! window)
|
||
(with-screen-in-update (%window-saved-screen window) display-style
|
||
(lambda ()
|
||
(let ((finished?
|
||
(update-buffer-window! window
|
||
(%window-saved-screen window)
|
||
(%window-saved-x-start window)
|
||
(%window-saved-y-start window)
|
||
(%window-saved-xl window)
|
||
(%window-saved-xu window)
|
||
(%window-saved-yl window)
|
||
(%window-saved-yu window)
|
||
display-style)))
|
||
(if finished?
|
||
(set-car! (window-redisplay-flags window) #f))
|
||
finished?))))))
|
||
|
||
(define (update-buffer-window! window screen x-start y-start xl xu yl yu
|
||
display-style)
|
||
(if (%window-override-string window)
|
||
(update-override-string! window screen x-start y-start xl xu yl yu)
|
||
(update-outlines! window))
|
||
(update-inferior! (%window-blank-inferior window) screen x-start y-start
|
||
xl xu yl yu display-style
|
||
blank-window:update-display!)
|
||
(update-inferior! (%window-cursor-inferior window) screen x-start y-start
|
||
xl xu yl yu display-style
|
||
cursor-window:update-display!)
|
||
#t)
|
||
|
||
(define (buffer-window/redraw! window)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'force-redraw!))
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(%set-window-force-redraw?! window #t)
|
||
(%recache-window-buffer-local-variables! window)
|
||
(%clear-window-incremental-redisplay-state! window)
|
||
(window-needs-redisplay! window)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))
|
||
|
||
;;;; Window State
|
||
|
||
(define (%reset-window-structures! window)
|
||
(set-window-inferiors! window '())
|
||
(%set-window-cursor-inferior! window (make-inferior window cursor-window))
|
||
(%set-window-blank-inferior! window (make-inferior window blank-window))
|
||
(%release-window-outlines! window)
|
||
(%set-window-free-o3! window #f)
|
||
(%set-window-override-string! window #f)
|
||
(%set-window-clip-daemon! window (make-clip-daemon window))
|
||
(%set-window-debug-trace! window #f)
|
||
(%set-window-saved-screen! window #f)
|
||
(%set-window-force-redraw?! window #f))
|
||
|
||
(define (%release-window-outlines! window)
|
||
(%set-window-start-outline! window #f)
|
||
(%set-window-end-outline! window #f)
|
||
(%set-window-free-outline! window #f))
|
||
|
||
(define (%clear-window-buffer-state! window)
|
||
(%set-window-buffer! window #f)
|
||
(%set-window-point! window #f)
|
||
(clear-window-start! window)
|
||
(%clear-window-incremental-redisplay-state! window))
|
||
|
||
(define (%clear-window-incremental-redisplay-state! window)
|
||
(if (%window-start-outline window)
|
||
(begin
|
||
(deallocate-outlines! window
|
||
(%window-start-outline window)
|
||
(%window-end-outline window))
|
||
(%set-window-start-outline! window #f)
|
||
(%set-window-end-outline! window #f)))
|
||
(if (%window-current-start-mark window)
|
||
(begin
|
||
(mark-temporary! (%window-current-start-mark window))
|
||
(%set-window-current-start-mark! window #f)
|
||
(mark-temporary! (%window-current-end-mark window))
|
||
(%set-window-current-end-mark! window #f)
|
||
(%set-window-current-start-delta! window #f)
|
||
(%set-window-current-start-partial! window #f)))
|
||
(%clear-window-outstanding-changes! window))
|
||
|
||
(define-integrable (%clear-window-outstanding-changes! window)
|
||
(if (%window-buffer window)
|
||
(update-modified-tick! window))
|
||
(if (%window-start-clip-mark window)
|
||
(begin
|
||
(mark-temporary! (%window-start-clip-mark window))
|
||
(%set-window-start-clip-mark! window #f)
|
||
(mark-temporary! (%window-end-clip-mark window))
|
||
(%set-window-end-clip-mark! window #f)))
|
||
(%set-window-point-moved?! window #f))
|
||
|
||
(define-integrable (update-modified-tick! window)
|
||
(%set-window-modified-tick! window
|
||
(group-modified-tick (%window-group window))))
|
||
|
||
(define (%recache-window-buffer-local-variables! window)
|
||
(let ((maybe-recache
|
||
(lambda (read write new-value)
|
||
(let ((old-value (read window)))
|
||
(if (not (eqv? new-value old-value))
|
||
(begin
|
||
(%set-window-force-redraw?! window #t)
|
||
(clear-window-start! window)
|
||
(write window new-value))))))
|
||
(buffer (%window-buffer window)))
|
||
(maybe-recache
|
||
%window-truncate-lines?
|
||
%set-window-truncate-lines?!
|
||
(or (variable-local-value buffer (ref-variable-object truncate-lines))
|
||
(and (variable-local-value
|
||
buffer
|
||
(ref-variable-object truncate-partial-width-windows))
|
||
(window-has-horizontal-neighbor? (window-superior window)))))
|
||
(maybe-recache
|
||
%window-tab-width
|
||
%set-window-tab-width!
|
||
(variable-local-value buffer (ref-variable-object tab-width)))
|
||
(maybe-recache
|
||
%window-char-image-strings
|
||
%set-window-char-image-strings!
|
||
(variable-local-value buffer (ref-variable-object char-image-strings)))))
|
||
|
||
;;;; Buffer and Point
|
||
|
||
(define-integrable (buffer-window/buffer window)
|
||
(%window-buffer window))
|
||
|
||
(define (buffer-window/set-buffer! window new-buffer)
|
||
;; Interrupts must be disabled when this is called.
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-buffer! new-buffer))
|
||
(if (not (buffer? new-buffer))
|
||
(error:wrong-type-argument new-buffer "buffer" 'SET-WINDOW-BUFFER!))
|
||
(if (%window-buffer window)
|
||
(%unset-window-buffer! window))
|
||
(%set-window-buffer! window new-buffer)
|
||
(%recache-window-buffer-local-variables! window)
|
||
(let ((group (%window-group window)))
|
||
(add-group-clip-daemon! group (%window-clip-daemon window))
|
||
(%set-window-point-index! window (mark-index (group-point group))))
|
||
(if (and (buffer-display-start new-buffer)
|
||
(window-x-size window))
|
||
(set-new-coordinates! window
|
||
(mark-index (buffer-display-start new-buffer))
|
||
0
|
||
#f))
|
||
(buffer-window/redraw! window))
|
||
|
||
(define (%unset-window-buffer! window)
|
||
;; Interrupts must be disabled when this is called.
|
||
(let ((buffer (%window-buffer window)))
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'unset-buffer! buffer))
|
||
(set-buffer-display-start!
|
||
buffer
|
||
(mark-permanent! (buffer-window/start-mark window)))
|
||
(%set-buffer-point! buffer (buffer-window/point window)))
|
||
(remove-group-clip-daemon! (%window-group window)
|
||
(%window-clip-daemon window))
|
||
(%clear-window-buffer-state! window))
|
||
|
||
(define-integrable (buffer-window/point window)
|
||
(%window-point window))
|
||
|
||
(define (buffer-window/set-point! window mark)
|
||
(let ((mark (clip-mark-to-display window mark)))
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-point! mark))
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(set-window-point-index! window (mark-index mark))
|
||
(%set-window-point-moved?! window 'SINCE-START-SET)
|
||
(window-needs-redisplay! window)
|
||
(set-interrupt-enables! mask)
|
||
unspecific)))
|
||
|
||
;;;; Start Mark
|
||
|
||
(define (buffer-window/start-mark window)
|
||
(guarantee-start-mark! window)
|
||
(mark-temporary-copy (%window-start-mark window)))
|
||
|
||
(define (buffer-window/set-start-mark! window mark force?)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-start-mark! mark))
|
||
(set-new-coordinates! window
|
||
(mark-index (clip-mark-to-display window mark))
|
||
0
|
||
(and force? (buffer-window/y-center window))))
|
||
|
||
(define (buffer-window/scroll-y-relative! window y-delta)
|
||
(if (not (fix:= y-delta 0))
|
||
(begin
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'scroll-y-relative!
|
||
y-delta))
|
||
(guarantee-start-mark! window)
|
||
(set-new-coordinates! window
|
||
(%window-start-line-index window)
|
||
(fix:- (%window-start-line-y window) y-delta)
|
||
(if (fix:> y-delta 0)
|
||
0
|
||
(fix:- (window-y-size window) 1))))))
|
||
|
||
(define (buffer-window/scroll-y-absolute! window y-point)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'scroll-y-absolute!
|
||
y-point))
|
||
(if (not (and (fix:<= 0 y-point)
|
||
(fix:< y-point (window-y-size window))))
|
||
(error:bad-range-argument y-point 'WINDOW-SCROLL-Y-ABSOLUTE!))
|
||
(let ((cws
|
||
(compute-window-start window (%window-point-index window) y-point)))
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(set-window-start! window cws)
|
||
(set-interrupt-enables! mask)
|
||
unspecific)))
|
||
|
||
(define (buffer-window/y-center window)
|
||
(let ((y-size (window-y-size window)))
|
||
(let ((result
|
||
(round->exact
|
||
(* y-size (/ (ref-variable cursor-centering-point) 100)))))
|
||
(if (< result y-size)
|
||
result
|
||
(- y-size 1)))))
|
||
|
||
(define-variable cursor-centering-point
|
||
"The distance from the top of the window at which to center the point.
|
||
This number is a percentage, where 0 is the window's top and 100 the bottom."
|
||
50
|
||
(lambda (cursor-centering-point)
|
||
(and (real? cursor-centering-point)
|
||
(<= 0 cursor-centering-point 100))))
|
||
|
||
(define (set-new-coordinates! window index y point-y)
|
||
(let ((cws (compute-window-start window index y)))
|
||
(let ((start (vector-ref cws 0))
|
||
(y-start (vector-ref cws 1)))
|
||
(cond ((predict-index-visible? window start y-start
|
||
(%window-point-index window))
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(set-window-start! window cws)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))
|
||
(point-y
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(set-window-point-index!
|
||
window
|
||
(or (predict-index window start y-start
|
||
(vector-ref cws 4) point-y)
|
||
(%window-group-end-index window)))
|
||
(set-window-start! window cws)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))))))
|
||
|
||
(define (set-window-start! window cws)
|
||
(let ((start-line (vector-ref cws 0))
|
||
(start (vector-ref cws 2)))
|
||
(if (fix:= start-line start)
|
||
(if (%window-start-line-mark window)
|
||
(begin
|
||
(set-mark-index! (%window-start-line-mark window) start-line)
|
||
(if (not (eq? (%window-start-line-mark window)
|
||
(%window-start-mark window)))
|
||
(begin
|
||
(mark-temporary! (%window-start-mark window))
|
||
(%set-window-start-mark!
|
||
window
|
||
(%window-start-line-mark window)))))
|
||
(let ((mark
|
||
(make-permanent-mark (%window-group window) start-line #f)))
|
||
(%set-window-start-line-mark! window mark)
|
||
(%set-window-start-mark! window mark)))
|
||
(if (%window-start-line-mark window)
|
||
(begin
|
||
(set-mark-index! (%window-start-line-mark window) start-line)
|
||
(if (eq? (%window-start-line-mark window)
|
||
(%window-start-mark window))
|
||
(%set-window-start-mark!
|
||
window
|
||
(make-permanent-mark (%window-group window) start #f))
|
||
(set-mark-index! (%window-start-mark window) start)))
|
||
(let ((group (%window-group window)))
|
||
(%set-window-start-line-mark!
|
||
window
|
||
(make-permanent-mark group start-line #f))
|
||
(%set-window-start-mark!
|
||
window
|
||
(make-permanent-mark group start #f))))))
|
||
(%set-window-start-line-y! window (vector-ref cws 1))
|
||
(%set-window-start-column! window (vector-ref cws 3))
|
||
(%set-window-start-partial! window (vector-ref cws 4))
|
||
(if (eq? (%window-point-moved? window) 'SINCE-START-SET)
|
||
(%set-window-point-moved?! window #t))
|
||
(window-needs-redisplay! window))
|
||
|
||
(define (clear-window-start! window)
|
||
(if (%window-start-line-mark window)
|
||
(begin
|
||
(mark-temporary! (%window-start-line-mark window))
|
||
(%set-window-start-line-mark! window #f)))
|
||
(if (%window-start-mark window)
|
||
(begin
|
||
(mark-temporary! (%window-start-mark window))
|
||
(%set-window-start-mark! window #f)))
|
||
(%set-window-start-line-y! window 0)
|
||
(%set-window-start-column! window 0)
|
||
(%set-window-start-partial! window 0))
|
||
|
||
(define (guarantee-start-mark! window)
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(%guarantee-start-mark! window)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))
|
||
|
||
(define (%guarantee-start-mark! window)
|
||
(let ((index-at!
|
||
(lambda (index y)
|
||
(set-window-start! window (compute-window-start window index y)))))
|
||
(if (not (%window-start-line-mark window))
|
||
(index-at! (%window-point-index window)
|
||
(buffer-window/y-center window))
|
||
(let ((start-line (%window-start-line-index window)))
|
||
(cond ((not (%window-line-start-index? window start-line))
|
||
(index-at! (%window-start-index window) 0))
|
||
((eq? (%window-point-moved? window) 'SINCE-START-SET)
|
||
(let ((point (%window-point-index window)))
|
||
(if (or (%window-start-clip-mark window)
|
||
(fix:> (group-modified-tick (%window-group window))
|
||
(%window-modified-tick window))
|
||
(not (%window-current-start-mark window))
|
||
(fix:<
|
||
point
|
||
(if (fix:< (%window-current-start-y window) 0)
|
||
(fix:+ (%window-current-start-index window)
|
||
(outline-index-length
|
||
(%window-start-outline window)))
|
||
(%window-current-start-index window)))
|
||
(fix:> point
|
||
(if (fix:> (%window-current-end-y window)
|
||
(window-y-size window))
|
||
(fix:- (%window-current-end-index window)
|
||
(outline-index-length
|
||
(%window-end-outline window)))
|
||
(%window-current-end-index window))))
|
||
(let ((start-y (%window-start-line-y window))
|
||
(y-size (window-y-size window))
|
||
(scroll-step
|
||
(ref-variable scroll-step
|
||
(%window-buffer window))))
|
||
(if (fix:= 0 scroll-step)
|
||
(if (predict-y-limited window start-line
|
||
start-y point
|
||
0 y-size)
|
||
(%set-window-point-moved?! window #t)
|
||
(index-at! point
|
||
(buffer-window/y-center window)))
|
||
(let ((y
|
||
(predict-y-limited window start-line
|
||
start-y point
|
||
(fix:- 0 scroll-step)
|
||
(fix:+ y-size
|
||
scroll-step))))
|
||
(cond ((not y)
|
||
(index-at!
|
||
point
|
||
(buffer-window/y-center window)))
|
||
((fix:< y 0)
|
||
(index-at! point (fix:+ y scroll-step)))
|
||
((fix:>= y y-size)
|
||
(index-at! point
|
||
(fix:- y scroll-step)))))))
|
||
(%set-window-point-moved?! window #t)))))))))
|
||
|
||
(define-variable scroll-step
|
||
"The number of lines to try scrolling a window by when point moves out.
|
||
If that fails to bring point back on screen, point is centered instead.
|
||
If this is zero, point is always centered after it moves off screen."
|
||
0
|
||
(lambda (scroll-step)
|
||
(and (fix:fixnum? scroll-step)
|
||
(fix:>= scroll-step 0))))
|
||
|
||
;;;; Override Message
|
||
|
||
(define (buffer-window/override-message window)
|
||
(%window-override-string window))
|
||
|
||
(define (buffer-window/set-override-message! window message)
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window 'set-override-message!
|
||
message))
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(%set-window-override-string! window message)
|
||
(window-needs-redisplay! window)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))
|
||
|
||
(define (buffer-window/clear-override-message! window)
|
||
(if (%window-override-string window)
|
||
(begin
|
||
(if (%window-debug-trace window)
|
||
((%window-debug-trace window) 'window window
|
||
'clear-override-message!))
|
||
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
|
||
(%set-window-override-string! window #f)
|
||
(buffer-window/redraw! window)
|
||
(set-interrupt-enables! mask)
|
||
unspecific))))
|
||
|
||
(define (update-override-string! window screen x-start y-start xl xu yl yu)
|
||
;; This should probably update like any other string, paying
|
||
;; attention to TRUNCATE-LINES? and going to multiple lines if
|
||
;; necessary. For now we'll force it to be truncated to a single
|
||
;; line, which is fine as long as the minibuffer is only one line.
|
||
(if (and (fix:= yl 0) (not (fix:= yu 0)))
|
||
(let ((string (%window-override-string window))
|
||
(xl (fix:+ x-start xl))
|
||
(xu (fix:+ x-start xu))
|
||
(results substring-image-results))
|
||
(let ((end (string-length string))
|
||
(line
|
||
(screen-get-output-line screen (fix:+ y-start yl) xl xu #f)))
|
||
(substring-image! string 0 end
|
||
line xl (fix:- xu 1)
|
||
#f 0 results
|
||
(%window-char-image-strings window))
|
||
(if (fix:= (vector-ref results 0) end)
|
||
(do ((x (vector-ref results 1) (fix:+ x 1)))
|
||
((fix:= x xu))
|
||
(string-set! line x #\space))
|
||
(string-set! line (fix:- xu 1) #\$))
|
||
(set-inferior-start! (%window-cursor-inferior window)
|
||
(vector-ref results 1)
|
||
0))))
|
||
(%update-blank-inferior! window 1 #t)
|
||
(update-modified-tick! window))
|
||
|
||
;;;; Update Finalization
|
||
|
||
(define (set-outlines! window start end)
|
||
(%set-window-start-outline! window (o3-outline start))
|
||
(%set-window-end-outline! window (o3-outline end))
|
||
(if (%window-current-start-mark window)
|
||
(begin
|
||
(set-mark-index! (%window-current-start-mark window) (o3-index start))
|
||
(set-mark-index! (%window-current-end-mark window) (o3-index end)))
|
||
(begin
|
||
(%set-window-current-start-mark!
|
||
window
|
||
(make-permanent-mark (%window-group window) (o3-index start) #f))
|
||
(%set-window-current-end-mark!
|
||
window
|
||
(make-permanent-mark (%window-group window) (o3-index end) #t))))
|
||
(%set-window-current-start-delta! window
|
||
(fix:- (%window-start-index window)
|
||
(%window-start-line-index window)))
|
||
(%set-window-current-start-partial! window (%window-start-partial window))
|
||
(%set-window-current-start-y! window (o3-y start))
|
||
(%set-window-current-end-y! window (o3-y end))
|
||
(deallocate-o3! window start)
|
||
(deallocate-o3! window end)
|
||
(update-blank-inferior! window #t)
|
||
(update-cursor! window)
|
||
(%window-modeline-event! window 'SET-OUTLINES))
|
||
|
||
(define (update-blank-inferior! window signal?)
|
||
(%update-blank-inferior! window (%window-current-end-y window) signal?))
|
||
|
||
(define (%update-blank-inferior! window end-y signal?)
|
||
(let ((inferior (%window-blank-inferior window)))
|
||
(if (fix:< end-y (window-y-size window))
|
||
(begin
|
||
(%set-window-x-size! (inferior-window inferior)
|
||
(window-x-size window))
|
||
(%set-window-y-size! (inferior-window inferior)
|
||
(fix:- (window-y-size window) end-y))
|
||
(%set-inferior-x-start! inferior 0)
|
||
(%set-inferior-y-start! inferior end-y)
|
||
(if signal?
|
||
(setup-redisplay-flags! (inferior-redisplay-flags inferior))))
|
||
(begin
|
||
(%set-inferior-x-start! inferior #f)
|
||
(%set-inferior-y-start! inferior #f)))))
|
||
|
||
(define (update-cursor! window)
|
||
(let ((xy (buffer-window/point-coordinates window)))
|
||
(if (and (fix:<= 0 (car xy))
|
||
(fix:< (car xy) (window-x-size window))
|
||
(fix:<= 0 (cdr xy))
|
||
(fix:< (cdr xy) (window-y-size window)))
|
||
(set-inferior-position! (%window-cursor-inferior window) xy)
|
||
(begin
|
||
(if point-not-visible-error?
|
||
(error "point not visible at end of redisplay"))
|
||
(set-window-point-index!
|
||
window
|
||
(or (predict-index window
|
||
(%window-start-line-index window)
|
||
(%window-start-line-y window)
|
||
(%window-start-partial window)
|
||
0)
|
||
(%window-group-end-index window)))
|
||
(update-cursor! window)))))
|
||
|
||
(define point-not-visible-error?
|
||
#f)
|