;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.137 1990/10/03 04:54:07 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.138 1990/11/02 03:22:26 cph Rel $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
modes
comtabs
windows
- cursor-y
+ display-start
pathname
truename
alist
(vector-set! buffer buffer-index:modes (list mode))
(vector-set! buffer buffer-index:comtabs (mode-comtabs mode))
(vector-set! buffer buffer-index:windows '())
- (vector-set! buffer buffer-index:cursor-y false)
+ (vector-set! buffer buffer-index:display-start false)
(vector-set! buffer buffer-index:pathname false)
(vector-set! buffer buffer-index:truename false)
(vector-set! buffer buffer-index:alist '())
(buffer-modeline-event! buffer 'BUFFER-PATHNAME)
(vector-set! buffer buffer-index:auto-save-pathname false)
(vector-set! buffer buffer-index:auto-save-modified? false)
- (vector-set! buffer buffer-index:save-length 0)
- unspecific)))
+ (vector-set! buffer buffer-index:save-length 0))))
(define (set-buffer-name! buffer name)
(vector-set! buffer buffer-index:name name)
(buffer-modeline-event! buffer 'BUFFER-TRUENAME))
(define-integrable (set-buffer-auto-save-pathname! buffer pathname)
- (vector-set! buffer buffer-index:auto-save-pathname pathname)
- unspecific)
+ (vector-set! buffer buffer-index:auto-save-pathname pathname))
(define-integrable (set-buffer-auto-saved! buffer)
- (vector-set! buffer buffer-index:auto-save-modified? false)
- unspecific)
+ (vector-set! buffer buffer-index:auto-save-modified? false))
(define-integrable (set-buffer-save-length! buffer)
- (vector-set! buffer buffer-index:save-length (buffer-length buffer))
- unspecific)
+ (vector-set! buffer buffer-index:save-length (buffer-length buffer)))
(define-integrable (set-buffer-backed-up?! buffer flag)
- (vector-set! buffer buffer-index:backed-up? flag)
- unspecific)
+ (vector-set! buffer buffer-index:backed-up? flag))
(define-integrable (set-buffer-modification-time! buffer flag)
- (vector-set! buffer buffer-index:modification-time flag)
- unspecific)
+ (vector-set! buffer buffer-index:modification-time flag))
(define-integrable (set-buffer-comtabs! buffer comtabs)
- (vector-set! buffer buffer-index:comtabs comtabs)
- unspecific)
+ (vector-set! buffer buffer-index:comtabs comtabs))
-(define-integrable (buffer-point buffer)
- (group-point (buffer-group buffer)))
+(define (buffer-point buffer)
+ (if (current-buffer? buffer)
+ (current-point)
+ (group-point (buffer-group buffer))))
(define-integrable (%set-buffer-point! buffer mark)
(set-group-point! (buffer-group buffer) mark))
(define (add-buffer-window! buffer window)
(vector-set! buffer
buffer-index:windows
- (cons window (vector-ref buffer buffer-index:windows)))
- unspecific)
+ (cons window (vector-ref buffer buffer-index:windows))))
(define (remove-buffer-window! buffer window)
(vector-set! buffer
buffer-index:windows
- (delq! window (vector-ref buffer buffer-index:windows)))
- unspecific)
+ (delq! window (vector-ref buffer buffer-index:windows))))
-(define-integrable (set-buffer-cursor-y! buffer cursor-y)
- (vector-set! buffer buffer-index:cursor-y cursor-y)
- unspecific)
+(define-integrable (set-buffer-display-start! buffer mark)
+ (vector-set! buffer buffer-index:display-start mark))
(define-integrable (buffer-visible? buffer)
(not (null? (buffer-windows buffer))))
(set-cdr! entry value)
(vector-set! buffer buffer-index:alist
(cons (cons key value)
- (vector-ref buffer buffer-index:alist)))))
- unspecific)
+ (vector-ref buffer buffer-index:alist))))))
(define (buffer-remove! buffer key)
(vector-set! buffer
buffer-index:alist
- (del-assq! key (vector-ref buffer buffer-index:alist)))
- unspecific)
+ (del-assq! key (vector-ref buffer buffer-index:alist))))
(define-integrable (reset-buffer-alist! buffer)
- (vector-set! buffer buffer-index:alist '())
- unspecific)
+ (vector-set! buffer buffer-index:alist '()))
\f
;;;; Modification Flags
(begin
(set-group-modified! group true)
(buffer-modeline-event! buffer 'BUFFER-MODIFIED)))
- (vector-set! buffer buffer-index:auto-save-modified? true)
- unspecific))
+ (vector-set! buffer buffer-index:auto-save-modified? true)))
(define (buffer-clip-daemon buffer)
(lambda (group start end)
(begin
((car thunks))
(loop (cdr thunks)))))
- (vector-set! buffer buffer-index:initializations '())
- unspecific)
+ (vector-set! buffer buffer-index:initializations '()))
\f
;;;; Local Bindings
(lambda ()
(let ((buffer (current-buffer))
(old-value (variable-value variable)))
+ (check-variable-value-validity! variable new-value)
(%set-variable-value! variable new-value)
(invoke-variable-assignment-daemons! variable)
(let ((bindings (buffer-local-bindings buffer)))
(if (not binding)
(vector-set! buffer
buffer-index:local-bindings
- (cons (cons variable old-value) bindings))))))
- unspecific)))
+ (cons (cons variable old-value) bindings)))))))))
(define (unmake-local-binding! variable)
(without-interrupts
(invoke-variable-assignment-daemons! variable)
(vector-set! buffer
buffer-index:local-bindings
- (delq! binding bindings)))))))
- unspecific)))
+ (delq! binding bindings))))))))))
(define (undo-local-bindings!)
(let ((buffer (current-buffer)))
(%set-variable-value! variable (cdr binding))
(invoke-variable-assignment-daemons! variable)))
(buffer-local-bindings buffer))
- (vector-set! buffer buffer-index:local-bindings '()))
- unspecific)
+ (vector-set! buffer buffer-index:local-bindings '())))
\f
(define (with-current-local-bindings! thunk)
(let ((wind-bindings
(for-each invoke-variable-assignment-daemons! variables))))
\f
(define (variable-local-value buffer variable)
- (let ((in-cell
- (lambda ()
- (variable-value variable))))
- (if (current-buffer? buffer)
- (in-cell)
- (let ((binding (assq variable (buffer-local-bindings buffer))))
- (cond (binding
- (cdr binding))
- ((and (variable-buffer-local? variable)
- (within-editor?))
- (let ((binding
- (assq variable
- (buffer-local-bindings (current-buffer)))))
- (if binding
- (cdr binding)
- (in-cell))))
- (else
- (in-cell)))))))
+ (let ((binding
+ (and (within-editor?)
+ (not (current-buffer? buffer))
+ (or (assq variable (buffer-local-bindings buffer))
+ (and (variable-buffer-local? variable)
+ (assq variable
+ (buffer-local-bindings (current-buffer))))))))
+ (if binding
+ (cdr binding)
+ (variable-value variable))))
(define (set-variable-local-value! buffer variable value)
- (if (current-buffer? buffer)
- (set-variable-value! variable value)
- (let ((binding (assq variable (buffer-local-bindings buffer))))
- (if binding
- (begin
- (set-cdr! binding value)
- unspecific)
- (set-variable-value! variable value)))))
+ (let ((binding
+ (and (not (current-buffer? buffer))
+ (assq variable (buffer-local-bindings buffer)))))
+ (if binding
+ (set-cdr! binding value)
+ (set-variable-value! variable value))))
(define (define-variable-local-value! buffer variable value)
(if (current-buffer? buffer)
(set-cdr! binding value)
(vector-set! buffer
buffer-index:local-bindings
- (cons (cons variable value) bindings)))
- unspecific))))))
+ (cons (cons variable value) bindings)))))))))
(define (variable-local-value? buffer variable)
(assq variable (buffer-local-bindings buffer)))
(define (set-variable-default-value! variable value)
(let ((binding (assq variable (buffer-local-bindings (current-buffer)))))
(if binding
- (begin
- (set-cdr! binding value)
- unspecific)
+ (set-cdr! binding value)
(without-interrupts
(lambda ()
+ (check-variable-value-validity! variable value)
(%set-variable-value! variable value)
(invoke-variable-assignment-daemons! variable))))))
\f
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.36 1990/10/06 00:15:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.37 1990/11/02 03:22:35 cph Rel $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
(define-class buffer-frame combination-leaf-window
- (text-inferior
- border-inferior
+ (
+ ;; 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
- last-select-time
- override-message))
-(define-integrable (buffer-frame? object)
- (object-of-class? buffer-frame object))
+ ;; 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
-(define (make-buffer-frame superior new-buffer modeline?)
- (let ((frame (=> superior :make-inferior buffer-frame)))
- (let ((window (frame-text-inferior frame)))
- (initial-buffer! window new-buffer)
- (%window-setup-truncate-lines! window false))
- (initial-modeline! frame modeline?)
- frame))
+ ;; 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)))
- (initial-buffer! (frame-text-inferior frame*) (window-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*))
(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)
- (set! override-message false)
- unspecific)
-
-;;; **** 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.
+ (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.
+ (and (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!)
+ true)
+ (update-inferior! border-inferior screen x-start y-start
+ xl xu yl yu display-style
+ vertical-border-window:update-display!)))
(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! inferiors
(append! (delq! modeline-inferior inferiors)
(list modeline-inferior))))
- (set! modeline-inferior false))
- unspecific))
-
-(define-integrable (window-cursor frame)
- (%window-cursor (frame-text-inferior frame)))
-
+ (set! modeline-inferior false))))
+\f
(define-integrable (frame-text-inferior frame)
(with-instance-variables buffer-frame frame ()
(inferior-window text-inferior)))
-(define (frame-modeline-inferior frame)
- (with-instance-variables buffer-frame frame ()
- (and modeline-inferior
- (inferior-window modeline-inferior))))
-\f
-(define (window-select-time frame)
- (with-instance-variables buffer-frame frame ()
- last-select-time))
+(define-method buffer-frame (:set-size! window x y)
+ (set-buffer-frame-size! window x y))
-(define (set-window-select-time! frame time)
- (with-instance-variables buffer-frame frame (time)
- (set! last-select-time time)
- unspecific))
+(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)
- (let ((x* (- x (inferior-x-size border-inferior))))
- (set-inferior-start! border-inferior x* 0)
- (set-inferior-y-size! border-inferior y)
- (set! x x*))
+ (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 false false))
- (if modeline-inferior
- (let ((y* (- y (inferior-y-size modeline-inferior))))
- (set-inferior-start! modeline-inferior 0 y*)
- (set-inferior-x-size! modeline-inferior x)
- (set! y y*)))
(set-inferior-start! text-inferior 0 0)
- (set-inferior-size! text-inferior x y)))
-
-(define-method buffer-frame :set-size!
- set-buffer-frame-size!)
-
-(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))
+ (set-inferior-size! text-inferior x y))
+ (window-setup-truncate-lines! window))
(define-method buffer-frame (:minimum-x-size window)
(if (window-has-right-neighbor? window)
(+ (ref-variable window-minimum-height)
(inferior-y-size modeline-inferior))
(ref-variable window-minimum-height)))
+\f
+;;;; External Entries
-(define (buffer-frame-x-size frame)
+(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 (buffer-frame-y-size frame)
+(define-integrable (buffer-frame-y-size frame)
(window-y-size (frame-text-inferior frame)))
-\f
-;;;; External Entries
+
+(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)
- (%window-buffer (frame-text-inferior frame)))
+ (buffer-window/buffer (frame-text-inferior frame)))
(define (set-window-buffer! frame buffer)
- (if (and (string-ci=? (buffer-name buffer) "Bluffer")
- (null? (buffer-windows buffer)))
- (buffer-reset! buffer))
- (%set-window-buffer! (frame-text-inferior 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)
+ (window-setup-truncate-lines! frame))))
(define-integrable (window-point frame)
- (%window-point (frame-text-inferior frame)))
-
-(define (set-window-point! frame point)
- (let ((window (frame-text-inferior frame)))
- (%set-window-point! window (clip-mark-to-display window point))))
+ (buffer-window/point (frame-text-inferior frame)))
-(define (window-redraw! frame redraw-type)
- (%window-force-redraw! (frame-text-inferior frame) redraw-type))
+(define-integrable (set-window-point! frame mark)
+ (buffer-window/set-point! (frame-text-inferior frame) mark))
-(define (window-redraw-preserving-point! frame)
- (let ((window (frame-text-inferior frame)))
- (%window-force-redraw! window (%window-point-y window))))
-
-(define-integrable (window-needs-redisplay? frame)
- (with-instance-variables buffer-frame frame ()
- (car (inferior-redisplay-flags text-inferior))))
+(define-integrable (window-redraw! frame)
+ (buffer-window/redraw! (frame-text-inferior frame)))
(define (window-modeline-event! frame type)
(with-instance-variables buffer-frame frame (type)
(if modeline-inferior
(=> (inferior-window modeline-inferior) :event! type)))
(screen-modeline-event! (window-screen frame) frame type))
+\f
+(define-integrable (window-override-message window)
+ (buffer-window/override-message (frame-text-inferior window)))
-(define (window-set-override-message! window message)
- (with-instance-variables buffer-frame window (message)
- (set! override-message message))
- (set-override-message! (frame-text-inferior window) message))
+(define-integrable (window-set-override-message! window message)
+ (buffer-window/set-override-message! (frame-text-inferior window) message))
-(define (window-clear-override-message! window)
- (clear-override-message! (frame-text-inferior window))
- (with-instance-variables buffer-frame window ()
- (set! override-message false)))
+(define-integrable (window-clear-override-message! window)
+ (buffer-window/clear-override-message! (frame-text-inferior window)))
-(define (window-override-message window)
- (with-instance-variables buffer-frame window ()
- override-message))
+(define-integrable (window-direct-update! frame display-style)
+ (buffer-window/direct-update! (frame-text-inferior frame) display-style))
(define-integrable (window-home-cursor! window)
- (home-cursor! (frame-text-inferior window)))
-\f
-(define-integrable (window-direct-update! frame display-style)
- (%window-direct-update! (frame-text-inferior frame) display-style))
+ (buffer-window/home-cursor! (frame-text-inferior window)))
-(define (window-direct-output-insert-char! frame char)
- (without-interrupts
- (lambda ()
- (let ((point (window-point frame)))
- (%group-insert-char! (mark-group point) (mark-index point) char))
- (%direct-output-insert-char! (frame-text-inferior frame) char))))
+(define-integrable (window-direct-output-forward-char! frame)
+ (buffer-window/direct-output-forward-char! (frame-text-inferior frame)))
-(define (window-direct-output-insert-newline! frame)
- (without-interrupts
- (lambda ()
- (let ((point (window-point frame)))
- (%group-insert-char! (mark-group point) (mark-index point) #\newline))
- (%direct-output-insert-newline! (frame-text-inferior frame)))))
+(define-integrable (window-direct-output-backward-char! frame)
+ (buffer-window/direct-output-backward-char! (frame-text-inferior frame)))
-(define (window-direct-output-insert-substring! frame string start end)
- (without-interrupts
- (lambda ()
- (let ((point (window-point frame)))
- (%group-insert-substring! (mark-group point) (mark-index point)
- string start end))
- (%direct-output-insert-substring! (frame-text-inferior frame)
- string start end))))
+(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-forward-char! frame)
- (without-interrupts
- (lambda ()
- (%direct-output-forward-character! (frame-text-inferior frame)))))
+(define-integrable (window-direct-output-insert-newline! frame)
+ (buffer-window/direct-output-insert-newline! (frame-text-inferior frame)))
-(define-integrable (window-direct-output-backward-char! frame)
- (without-interrupts
- (lambda ()
- (%direct-output-backward-character! (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 (window-scroll-y-absolute! frame y-point)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-scroll-y-absolute! window y-point)))
+(define-integrable (window-scroll-y-absolute! frame y-point)
+ (buffer-window/scroll-y-absolute! (frame-text-inferior frame) y-point))
-(define (window-scroll-y-relative! frame delta)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-scroll-y-relative! window delta)))
+(define-integrable (window-scroll-y-relative! frame delta)
+ (buffer-window/scroll-y-relative! (frame-text-inferior frame) delta))
-(define (set-window-start-mark! frame mark force?)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%set-window-start-mark! window
- (clip-mark-to-display window mark)
- force?)))
+(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)
- (%window-y-center (frame-text-inferior frame)))
+ (buffer-window/y-center (frame-text-inferior frame)))
-(define (window-start-index frame)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-start-index window)))
+(define-integrable (window-start-mark frame)
+ (buffer-window/start-mark (frame-text-inferior frame)))
-(define (window-end-index frame)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-end-index window)))
-\f
-(define (window-mark-visible? frame mark)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-mark-visible? window mark)))
-
-(define (window-mark->x frame mark)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-mark->x window (clip-mark-to-display window mark))))
-
-(define (window-mark->y frame mark)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-mark->y window (clip-mark-to-display window mark))))
-
-(define (window-mark->coordinates frame mark)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-mark->coordinates window (clip-mark-to-display window mark))))
-
-(define (window-point-x frame)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-point-x window)))
-
-(define (window-point-y frame)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-point-y window)))
-
-(define (window-point-coordinates frame)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-point-coordinates window)))
-
-(define (window-coordinates->mark frame x y)
- (let ((window (frame-text-inferior frame)))
- (maybe-recompute-image! window)
- (%window-coordinates->mark window x y)))
+(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))
+\f
(define (window-setup-truncate-lines! frame)
- (%window-setup-truncate-lines! (frame-text-inferior frame) 'START))
\ No newline at end of file
+ (let ((window (frame-text-inferior frame))
+ (truncate-lines?
+ (let ((buffer (window-buffer frame)))
+ (or (and (variable-local-value
+ buffer
+ (ref-variable-object truncate-partial-width-windows))
+ (window-has-horizontal-neighbor? frame))
+ (variable-local-value buffer
+ (ref-variable-object truncate-lines))))))
+ (if (not (boolean=? (%window-truncate-lines? window) truncate-lines?))
+ (without-interrupts
+ (lambda ()
+ (%set-window-truncate-lines?! window truncate-lines?)
+ (buffer-window/redraw! window))))))
+
+(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."
+ false)
+
+(define-variable truncate-partial-width-windows
+ "*True means truncate lines in all windows less than full screen wide."
+ true)
+
+(let ((setup-truncate-lines!
+ (lambda (variable)
+ variable ;ignore
+ (for-each window-setup-truncate-lines! (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!))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.8 1990/10/09 16:23:21 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.9 1990/11/02 03:22:42 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; of that license should have been included along with this file.
;;;
-;;;; Buffer Windows: Fill and Scroll
+;;;; Buffer Windows: Fill and Scroll
(declare (usual-integrations))
\f
-;;;; Fill
+(define (fill-top window inferiors start)
+ ;; Assumes non-null INFERIORS.
+ (let loop
+ ((inferiors inferiors)
+ (start start)
+ (y-start (inferior-y-start (car inferiors))))
+ (if (fix:<= y-start 0)
+ inferiors
+ (let* ((end (fix:- start 1))
+ (start (%window-line-start-index window end))
+ (inferior (make-line-inferior window start end))
+ (y-start (fix:- y-start (inferior-y-size inferior))))
+ (%set-inferior-y-start! inferior y-start)
+ (loop (cons inferior inferiors) start y-start)))))
-(define (fill-top! window inferiors start fill-bottom?)
- (with-instance-variables buffer-window window (inferiors start fill-bottom?)
- ;; INFERIORS is assumed to be not '(), and START is the start index
- ;; of the first inferior in that list. FILL-BOTTOM?, if true, means
- ;; try to fill the bottom of INFERIORS after filling the top.
- (let ((group (buffer-group buffer)))
- (define (do-bottom! inferiors start)
- (if (null? (cdr inferiors))
- (set-cdr! inferiors
- (fill-bottom window
- (inferior-y-end (car inferiors))
- (line-end-index group start)))
- (do-bottom! (cdr inferiors)
- (fix:+ start (line-inferior-length inferiors)))))
- (let loop
- ((y-start (inferior-y-start (car inferiors)))
- (start start)
- (inferiors inferiors))
- (cond ((not (fix:positive? y-start))
- (if fill-bottom? (do-bottom! inferiors start))
- (set-line-inferiors! window inferiors start))
- ((group-start-index? group start)
- (set-line-inferiors! window
- (scroll-lines-up! window inferiors 0 start)
- start))
- (else
- (let ((end (fix:-1+ start)))
- (let ((start (line-start-index group end)))
+(define (fill-middle! window
+ top-inferiors top-start
+ bottom-inferiors bottom-start)
+ ;; Assumes non-null TOP-INFERIORS and BOTTOM-INFERIORS.
+ (let loop ((inferiors top-inferiors) (start top-start))
+ (let ((start (fix:+ start (line-inferior-length (car inferiors)))))
+ (if (not (null? (cdr inferiors)))
+ (loop (cdr inferiors) start)
+ (set-cdr!
+ inferiors
+ (let loop
+ ((start start) (y-start (%inferior-y-end (car inferiors))))
+ (if (fix:= start bottom-start)
+ bottom-inferiors
+ (let ((end (%window-line-end-index window start)))
(let ((inferior (make-line-inferior window start end)))
- (let ((y-start
- (fix:- y-start (inferior-y-size inferior))))
- (set-inferior-start! inferior 0 y-start)
- (loop y-start start (cons inferior inferiors))))))))))))
-
-(define (fill-bottom window y-end end-index)
- (with-instance-variables buffer-window window (y-end end-index)
- ;; Generates a list of inferiors which will be appended to a list
- ;; ending in Y-END and END-INDEX.
- (let ((group (buffer-group buffer)))
- (let loop ((y-start y-end) (end end-index))
- (if (or (not (fix:< y-start y-size))
- (group-end-index? group end))
- '()
- (let ((start (fix:1+ end)))
- (let ((end (line-end-index group start)))
- (let ((inferior (make-line-inferior window start end)))
- (set-inferior-start! inferior 0 y-start)
- (cons inferior (loop (inferior-y-end inferior) end))))))))))
-
-(define (fill-middle! window y-end end-index tail tail-start-index)
- (with-instance-variables buffer-window window
- (y-end end-index tail tail-start-index)
- ;; Generates a list of inferiors which will be appended to a list
- ;; ending in Y-END and END-INDEX. TAIL will be appended to the
- ;; generated list if it is visible, and scrolled up or down as
- ;; needed. TAIL-START-INDEX says where TAIL begins. It is assumed
- ;; that (> TAIL-START-INDEX END-INDEX), and that TAIL is non-'().
- (let ((group (buffer-group buffer)))
- (let loop ((y-end y-end) (end end-index))
- (let ((start (fix:1+ end)))
- (cond ((fix:= start tail-start-index)
- (let ((old-y-end (inferior-y-start (car tail))))
- (cond ((fix:> y-end old-y-end)
- (scroll-lines-down! window tail y-end))
- ((fix:< y-end old-y-end)
- (scroll-lines-up! window tail y-end start))
- (else tail))))
- ((not (fix:< y-end y-size)) '())
- (else
- (let ((end (line-end-index group start)))
- (let ((inferior (make-line-inferior window start end)))
- (set-inferior-start! inferior 0 y-end)
+ (%set-inferior-y-start! inferior y-start)
(cons inferior
- (loop (inferior-y-end inferior) end)))))))))))
-\f
-;;;; Scroll
+ (loop (fix:+ end 1)
+ (fix:+ y-start
+ (inferior-y-size inferior))))))))))))
+ top-inferiors)
-(define (%set-window-start-mark! window mark force?)
- (let ((start-y (%window-mark->y window mark)))
- (and (or force?
- (let ((point-y (fix:- (%window-point-y window) start-y)))
- (and (not (fix:negative? point-y))
- (fix:< point-y (window-y-size window)))))
- (begin
- (%window-scroll-y-relative! window start-y)
- true))))
+(define (fill-bottom! window inferiors start)
+ ;; Assumes non-null INFERIORS.
+ (let loop ((inferiors inferiors) (start start))
+ (let ((end
+ (fix:+ start
+ (line-window-length
+ (inferior-window (car inferiors))))))
+ (if (not (null? (cdr inferiors)))
+ (loop (cdr inferiors) (fix:+ end 1))
+ (let ((y-start (%inferior-y-end (car inferiors))))
+ (if (or (%window-group-end-index? window end)
+ (fix:>= y-start (window-y-size window)))
+ (set-current-end-index! window end)
+ (set-cdr! inferiors
+ (generate-line-inferiors window
+ (fix:+ end 1)
+ y-start)))))))
+ inferiors)
-(define (%window-scroll-y-absolute! window y-point)
- (with-instance-variables buffer-window window (y-point)
- (%window-scroll-y-relative! window
- (fix:- (%window-point-y window) y-point))))
+(define (generate-line-inferiors window start y-start)
+ ;; Assumes (FIX:< Y-START (WINDOW-Y-SIZE WINDOW))
+ (let ((y-size (window-y-size window)))
+ (let loop ((y-start y-start) (start start))
+ (let ((end (%window-line-end-index window start)))
+ (let ((inferior (make-line-inferior window start end)))
+ (%set-inferior-y-start! inferior y-start)
+ (cons inferior
+ (let ((y-start (fix:+ y-start (inferior-y-size inferior))))
+ (if (or (%window-group-end-index? window end)
+ (fix:>= y-start y-size))
+ (begin
+ (set-current-end-index! window end)
+ '())
+ (loop y-start (fix:+ end 1))))))))))
+\f
+(define (scroll-lines! window inferiors start y-start)
+ (cond ((or (null? inferiors)
+ (fix:= y-start (inferior-y-start (car inferiors))))
+ (values inferiors start))
+ ((fix:< y-start (inferior-y-start (car inferiors)))
+ (scroll-lines-up! window inferiors start y-start))
+ (else
+ (values (scroll-lines-down! window inferiors y-start) start))))
-(define (%window-scroll-y-relative! window y-delta)
- (with-instance-variables buffer-window window (y-delta)
- (cond ((fix:negative? y-delta)
- (let ((y-start
- (fix:- (inferior-y-start (car line-inferiors)) y-delta)))
- (if (fix:< y-start y-size)
- (fill-top! window
- (scroll-lines-down! window line-inferiors y-start)
- (mark-index start-line-mark)
- false)
- (redraw-at! window
- (or (%window-coordinates->mark window 0 y-delta)
- (buffer-start buffer))))))
- ((fix:positive? y-delta)
- (let ((inferiors (y->inferiors window y-delta)))
- (if inferiors
- (let ((start (inferiors->index window inferiors)))
- (set-line-inferiors!
- window
- (scroll-lines-up! window
- inferiors
- (fix:- (inferior-y-start (car inferiors))
- y-delta)
- start)
- start))
- (redraw-at! window
- (or (%window-coordinates->mark window 0 y-delta)
- (buffer-end buffer)))))))
- (everything-changed!
- window
- (lambda (window)
- (let ((y
- (if (fix:positive? y-delta)
- 0
- (fix:-1+ (window-y-size window)))))
- (%set-buffer-point! buffer (%window-coordinates->mark window 0 y))
- (set! point (buffer-point buffer))
- (set-inferior-start! cursor-inferior 0 y)
- (set! point-moved? false)
- (window-modeline-event! superior 'WINDOW-SCROLLED))))))
+(define (scroll-lines-up! window inferiors start y-start)
+ (let ((do-scroll
+ (lambda (inferiors start y-start)
+ (%scroll-lines-up! window inferiors y-start)
+ (values inferiors start))))
+ (if (fix:>= y-start 0)
+ (do-scroll inferiors start y-start)
+ (let loop ((inferiors inferiors) (start start) (y-start y-start))
+ (cond ((null? inferiors)
+ (values '() start))
+ ((fix:= y-start 0)
+ (do-scroll inferiors start y-start))
+ (else
+ (let ((y-end
+ (fix:+ y-start (inferior-y-size (car inferiors)))))
+ (if (fix:> y-end 0)
+ (do-scroll inferiors start y-start)
+ (loop (cdr inferiors)
+ (fix:+ start
+ (line-inferior-length (car inferiors)))
+ y-end)))))))))
-(define (redraw-at! window mark)
- (with-instance-variables buffer-window window (mark)
- (%set-buffer-point! buffer mark)
- (set! point (buffer-point buffer))
- (redraw-screen! window 0)))
-\f
(define (scroll-lines-down! window inferiors y-start)
- ;; Returns new list of new inferiors.
- (with-instance-variables buffer-window window (inferiors y-start)
- (let ((scrolled?
- (let ((yl (inferior-y-start (car inferiors))))
- (let ((amount (fix:- y-start yl)))
- (and (fix:< yl saved-yu)
- (fix:< amount (fix:- saved-yu saved-yl))
- (screen-scroll-lines-down! saved-screen
- (fix:+ saved-xl saved-x-start)
- (fix:+ saved-xu saved-x-start)
- (fix:+ (fix:max yl saved-yl)
- saved-y-start)
- (fix:+ saved-yu saved-y-start)
- amount))))))
- (let loop ((inferiors inferiors) (y-start y-start))
- (%set-inferior-y-start! (car inferiors) y-start)
- (if (not scrolled?)
- (inferior-needs-redisplay! (car inferiors)))
- (cons (car inferiors)
- (let ((inferiors (cdr inferiors))
- (y-start (inferior-y-end (car inferiors))))
- (if (or (null? inferiors)
- (not (fix:< y-start y-size)))
- '()
- (loop inferiors y-start))))))))
+ (let ((y-size (window-y-size window)))
+ (if (or (null? inferiors)
+ (fix:>= y-start y-size))
+ '()
+ (begin
+ (let loop ((inferiors inferiors) (y-start y-start))
+ (if (not (null? (cdr inferiors)))
+ (let ((y-end
+ (fix:+ y-start (inferior-y-size (car inferiors)))))
+ (if (fix:>= y-end y-size)
+ (set-cdr! inferiors '())
+ (loop (cdr inferiors) y-end)))))
+ (%scroll-lines-down! window inferiors y-start)
+ inferiors))))
+\f
+(define (%scroll-lines-down! window inferiors y-start)
+ (adjust-scrolled-inferiors!
+ window
+ inferiors
+ y-start
+ (let ((yl (inferior-y-start (car inferiors)))
+ (yu (%inferior-y-end (car (last-pair inferiors)))))
+ (let ((amount (fix:- y-start yl)))
+ (and (fix:< yl (%window-saved-yu window))
+ (fix:< (%window-saved-yl window) yu)
+ (let ((yl (fix:max (%window-saved-yl window) yl))
+ (yu (fix:min (%window-saved-yu window) (fix:+ yu amount))))
+ (and (fix:< amount (fix:- yu yl))
+ (screen-scroll-lines-down
+ (%window-saved-screen window)
+ (fix:+ (%window-saved-xl window)
+ (%window-saved-x-start window))
+ (fix:+ (%window-saved-xu window)
+ (%window-saved-x-start window))
+ (fix:+ yl (%window-saved-y-start window))
+ (fix:+ yu (%window-saved-y-start window))
+ amount))))))))
-(define (scroll-lines-up! window inferiors y-start start-index)
- ;; Returns new list of new inferiors.
- (with-instance-variables buffer-window window (inferiors y-start start-index)
- (let ((scrolled?
- (let ((yl (inferior-y-start (car inferiors))))
- (let ((amount (fix:- yl y-start)))
- (and (fix:< yl saved-yu)
- (fix:< amount (fix:- saved-yu saved-yl))
- (screen-scroll-lines-up! saved-screen
- (fix:+ saved-xl saved-x-start)
- (fix:+ saved-xu saved-x-start)
- (fix:+ (fix:max y-start saved-yl)
- saved-y-start)
- (fix:+ saved-yu saved-y-start)
- amount))))))
- (let loop
- ((inferiors inferiors) (y-start y-start) (start-index start-index))
- (%set-inferior-y-start! (car inferiors) y-start)
- (if (not scrolled?)
- (inferior-needs-redisplay! (car inferiors)))
- (cons (car inferiors)
- (let ((y-start (inferior-y-end (car inferiors))))
- (cond ((null? (cdr inferiors))
- (fill-bottom window
- y-start
- (line-end-index (buffer-group buffer)
- start-index)))
- ((fix:< y-start y-size)
- (loop (cdr inferiors)
- y-start
- (fix:+ start-index
- (line-inferior-length inferiors))))
- (else '()))))))))
+(define (%scroll-lines-up! window inferiors y-start)
+ (adjust-scrolled-inferiors!
+ window
+ inferiors
+ y-start
+ (let ((yl (inferior-y-start (car inferiors)))
+ (yu (%inferior-y-end (car (last-pair inferiors)))))
+ (let ((amount (fix:- yl y-start)))
+ (and (fix:< yl (%window-saved-yu window))
+ (fix:< (%window-saved-yl window) yu)
+ (let ((yl (fix:max (%window-saved-yl window) y-start))
+ (yu (fix:min (%window-saved-yu window) yu)))
+ (and (fix:< amount (fix:- yu yl))
+ (screen-scroll-lines-up
+ (%window-saved-screen window)
+ (fix:+ (%window-saved-xl window)
+ (%window-saved-x-start window))
+ (fix:+ (%window-saved-xu window)
+ (%window-saved-x-start window))
+ (fix:+ yl (%window-saved-y-start window))
+ (fix:+ yu (%window-saved-y-start window))
+ amount))))))))
-(define-integrable (fix:max x y)
- (if (fix:> x y) x y))
\ No newline at end of file
+(define (adjust-scrolled-inferiors! window inferiors y-start scrolled?)
+ (let ((y-size (window-y-size window)))
+ (let loop ((inferiors inferiors) (y-start y-start))
+ (if (not (null? inferiors))
+ (begin
+ (%set-inferior-y-start! (car inferiors) y-start)
+ (let ((y-end (fix:+ y-start (inferior-y-size (car inferiors)))))
+ (if (or (not scrolled?)
+ (fix:<= y-end y-size))
+ (inferior-needs-redisplay! (car inferiors)))
+ (loop (cdr inferiors) y-end)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.285 1990/10/05 23:32:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.286 1990/11/02 03:22:50 cph Rel $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; of that license should have been included along with this file.
;;;
-;;;; Buffer Windows: Base
+;;;; Buffer Windows: Base
(declare (usual-integrations))
\f
-;;; The following instance variables contain marks which must -NEVER-
-;;; be passed to anyone who will keep a pointer to them. The reason
-;;; is that the `mark-temporary!' operation is called on these marks,
-;;; which invalidates them as soon as some change happens to the
-;;; buffer. Remember, you were warned!
+;;; 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.
;;;
-;;; start-line-mark
+;;; current-start-mark
+;;; current-end-mark
;;; start-mark
-;;; end-mark
-;;; end-line-mark
+;;; start-line-mark
;;; start-changes-mark
;;; end-changes-mark
;;; start-clip-mark
;;; end-clip-mark
(define-class buffer-window vanilla-window
- (buffer point changes-daemon clip-daemon
- cursor-inferior blank-inferior
- line-inferiors last-line-inferior
- start-line-mark start-mark end-mark end-line-mark
- start-changes-mark end-changes-mark point-moved?
- start-clip-mark end-clip-mark
- saved-screen saved-x-start saved-y-start
- saved-xl saved-xu saved-yl saved-yu
- override-inferior truncate-lines? force-redraw?))
+ (
+ ;; The buffer being displayed in this window.
+ buffer
+
+ ;; The point marker in this window.
+ point
+
+ ;; If this flag is false, text lines that are too long to fit on
+ ;; a single window line are displayed with multiple window lines.
+ ;; If the flag is true, such text lines are truncated to single
+ ;; window lines.
+ truncate-lines?
+
+ ;; 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
+
+ ;; 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 inferior
+ ;; window (of class LINE-WINDOW) that displays the message.
+ override-inferior
+
+ ;; A list of the inferior windows (of class LINE-WINDOW) that are
+ ;; currently displaying the portion of the buffer that is visible
+ ;; in this window.
+ line-inferiors
+
+ ;; This permanent mark records where the first line inferior
+ ;; starts.
+ current-start-mark
+
+ ;; This permanent mark records where the last line inferior ends.
+ current-end-mark
+\f
+ ;; 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 contains the daemon that is invoked when insertions or
+ ;; deletions are performed on the buffer.
+ changes-daemon
+
+ ;; These variables delimit the region of the buffer that has been
+ ;; affected by insertions or deletions since the last display
+ ;; update. If no changes have occurred, they are #F.
+ start-changes-mark
+ end-changes-mark
+
+ ;; 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
+
+ ;; If true, this flag indicates that point has moved since the last
+ ;; time that START-LINE-MARK was set.
+ 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))
+\f
+;;;; Instance Variable Accessors
-(define-method buffer-window (:initialize! window window*)
- (usual=> window :initialize! window*)
- (set! cursor-inferior (make-inferior window cursor-window))
- (set! blank-inferior (make-inferior window blank-window))
- (set! changes-daemon (make-changes-daemon window))
- (set! clip-daemon (make-clip-daemon window))
- (set! override-inferior false)
- (set! force-redraw? 'CENTER)
- unspecific)
+(define-integrable (%window-buffer window)
+ (with-instance-variables buffer-window window () buffer))
-(define-method buffer-window (:kill! window)
- (delete-window-buffer! window)
- (usual=> window :kill!))
+(define-integrable (%window-group window)
+ (buffer-group (%window-buffer window)))
-(define-method buffer-window (:update-display! window screen x-start y-start
- xl xu yl yu display-style)
- (set! saved-screen screen)
- (set! saved-x-start x-start) (set! saved-y-start y-start)
- (set! saved-xl xl) (set! saved-xu xu) (set! saved-yl yl) (set! saved-yu yu)
- (update-buffer-window! window screen x-start y-start
- xl xu yl yu display-style))
+(define-integrable (%set-window-buffer! window buffer*)
+ (with-instance-variables buffer-window window (buffer*)
+ (set! buffer buffer*)))
-(define-method buffer-window (:salvage! window)
- (%set-buffer-point! buffer
- (make-mark (buffer-group buffer)
- (group-start-index (buffer-group buffer))))
- (set! point (buffer-point buffer))
- (window-modeline-event! superior 'SALVAGE)
- (%window-redraw! window false))
-\f
-(define (set-buffer-window-size! window x y)
- (with-instance-variables buffer-window window (x y)
- (set! saved-screen false)
- (let ((old-y y-size))
- (usual=> window :set-size! x y)
- ;; Preserve point y unless it is offscreen now.
- (%window-setup-truncate-lines! window false)
- (%window-force-redraw! window (and old-y (%window-cursor-y window))))))
-
-(define-method buffer-window :set-size!
- set-buffer-window-size!)
+(define-integrable (%window-point window)
+ (with-instance-variables buffer-window window () point))
-(define-method buffer-window (:set-x-size! window x)
- (set-buffer-window-size! window x y-size))
+(define-integrable (%window-point-index window)
+ (mark-index-integrable (%window-point window)))
-(define-method buffer-window (:set-y-size! window y)
- (set-buffer-window-size! window x-size y))
-
-(define (%window-setup-truncate-lines! window redraw-type)
- (with-instance-variables buffer-window window ()
- (if (not (within-editor?))
- (begin
- (set! truncate-lines? (ref-variable truncate-lines))
- unspecific)
- (let ((new-truncate-lines?
- (or (and (variable-local-value
- buffer
- (ref-variable-object truncate-partial-width-windows))
- (window-has-horizontal-neighbor? superior))
- (variable-local-value
- buffer
- (ref-variable-object truncate-lines)))))
- (if (not (boolean=? truncate-lines? new-truncate-lines?))
- (begin
- (set! truncate-lines? new-truncate-lines?)
- (if (and redraw-type (not force-redraw?))
- (%window-force-redraw! window redraw-type))))))))
-
-(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."
- false)
-
-(define-variable truncate-partial-width-windows
- "*True means truncate lines in all windows less than full screen wide."
- true)
-
-(let ((setup-truncate-lines!
- (lambda (variable)
- variable ;ignore
- (for-each window-setup-truncate-lines! (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!))
+(define-integrable (%set-window-point! window point*)
+ (with-instance-variables buffer-window window (point*)
+ (set! point point*)))
+
+(define-integrable (%set-window-point-index! window index)
+ (%set-window-point! window
+ (%make-permanent-mark (%window-group window)
+ index
+ true)))
+
+(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-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-override-inferior window)
+ (with-instance-variables buffer-window window () override-inferior))
+
+(define-integrable (%set-window-override-inferior! window inferior)
+ (with-instance-variables buffer-window window (inferior)
+ (set! override-inferior inferior)))
\f
-;;;; Group Operations
+(define-integrable (%window-line-inferiors window)
+ (with-instance-variables buffer-window window () line-inferiors))
-;;; These are identical to the operations of the same name used
-;;; elsewhere in the editor, except that they clip at the display clip
-;;; limits rather than the text clip limits.
+(define-integrable (%set-window-line-inferiors! window inferiors)
+ (with-instance-variables buffer-window window (inferiors)
+ (set! line-inferiors inferiors)))
-(define-integrable (group-start-index group)
- (mark-index (group-display-start group)))
+(define-integrable (%window-current-start-mark window)
+ (with-instance-variables buffer-window window () current-start-mark))
-(define-integrable (group-end-index group)
- (mark-index (group-display-end group)))
+(define-integrable (%window-current-start-index window)
+ (mark-index-integrable (%window-current-start-mark window)))
-(define-integrable (group-start-index? group index)
- (not (fix:> index (group-start-index group))))
+(define-integrable (%set-window-current-start-mark! window mark)
+ (with-instance-variables buffer-window window (mark)
+ (set! current-start-mark mark)))
-(define-integrable (group-end-index? group index)
- (not (fix:< index (group-end-index group))))
+(define-integrable (%window-current-end-mark window)
+ (with-instance-variables buffer-window window () current-end-mark))
-(define (line-start-index group index)
- (let ((limit (group-start-index group)))
- (or (%find-previous-newline group index limit)
- limit)))
+(define-integrable (%window-current-end-index window)
+ (mark-index-integrable (%window-current-end-mark window)))
-(define (line-end-index group index)
- (let ((limit (group-end-index group)))
- (or (%find-next-newline group index limit)
- limit)))
+(define-integrable (%set-window-current-end-mark! window mark)
+ (with-instance-variables buffer-window window (mark)
+ (set! current-end-mark mark)))
-(define (line-start-index? group index)
- (or (group-start-index? group index)
- (char=? (group-left-char group index) #\newline)))
+(define-integrable (%window-start-mark window)
+ (with-instance-variables buffer-window window () start-mark))
-(define (line-end-index? group index)
- (or (group-end-index? group index)
- (char=? (group-right-char group index) #\newline)))
+(define-integrable (%window-start-index window)
+ (mark-index-integrable (%window-start-mark window)))
-(define (clip-mark-to-display window mark)
+(define-integrable (%set-window-start-mark! window mark)
(with-instance-variables buffer-window window (mark)
- (if (not (mark? mark))
- (error "Argument not a mark" mark))
- (if (not (mark~ point mark))
- (error "Mark not within displayed buffer" mark))
- (let ((group (mark-group mark))
- (index (mark-index mark)))
- (cond ((group-start-index? group index) (group-display-start group))
- ((group-end-index? group index) (group-display-end group))
- (else 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-integrable (%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)))
\f
-;;;; Buffer and Point
+(define-integrable (%window-changes-daemon window)
+ (with-instance-variables buffer-window window () changes-daemon))
-(define-integrable (%window-buffer window)
- (with-instance-variables buffer-window window ()
- buffer))
-
-(define (%window-buffer-cursor-y window)
- (with-instance-variables buffer-window window ()
- (let ((py (buffer-cursor-y buffer)))
- (and py
- (begin
- (set-buffer-cursor-y! buffer false)
- (and (fix:= (car py) (mark-index point))
- (fix:< (cdr py) y-size)
- (cdr py)))))))
-
-(define (%set-window-buffer! window new-buffer)
- (with-instance-variables buffer-window window (new-buffer)
- (if (not (buffer? new-buffer)) (error "Argument not a buffer" new-buffer))
- (set-buffer-cursor-y! buffer
- (let ((y (%window-cursor-y window)))
- (and y (cons (mark-index point) y))))
- (delete-window-buffer! window)
- (initial-buffer! window new-buffer)
- (window-modeline-event! superior 'NEW-BUFFER)
- (%window-force-redraw! window (%window-buffer-cursor-y window))))
-
-(define (initial-buffer! window new-buffer)
- (with-instance-variables buffer-window window (new-buffer)
- (set! buffer new-buffer)
- (add-buffer-window! buffer superior)
- (let ((group (buffer-group buffer)))
- (add-group-delete-daemon! group changes-daemon)
- (add-group-insert-daemon! group changes-daemon)
- (add-group-clip-daemon! group clip-daemon)
- (let ((point (mark-index (buffer-point buffer)))
- (start (group-start-index group))
- (end (group-end-index group)))
- (cond ((fix:< point start)
- (%set-buffer-point! buffer (make-mark group start)))
- ((fix:> point end)
- (%set-buffer-point! buffer (make-mark group end))))))
- (set! point (buffer-point buffer))
- unspecific))
-
-(define (delete-window-buffer! window)
- (with-instance-variables buffer-window window ()
- (let ((group (buffer-group buffer)))
- (remove-group-delete-daemon! group changes-daemon)
- (remove-group-insert-daemon! group changes-daemon)
- (remove-group-clip-daemon! group clip-daemon))
- (remove-buffer-window! buffer superior)))
+(define-integrable (%set-window-changes-daemon! window daemon)
+ (with-instance-variables buffer-window window (daemon)
+ (set! changes-daemon daemon)))
-(define-integrable (%window-point window)
- (with-instance-variables buffer-window window ()
- point))
+(define-integrable (%window-start-changes-mark window)
+ (with-instance-variables buffer-window window () start-changes-mark))
-(define (%set-window-point! window mark)
+(define-integrable (%window-start-changes-index window)
+ (mark-index-integrable (%window-start-changes-mark window)))
+
+(define-integrable (%set-window-start-changes-mark! window mark)
(with-instance-variables buffer-window window (mark)
- (%set-buffer-point! buffer mark)
- (set! point (buffer-point buffer))
- (set! point-moved? true)
- (setup-redisplay-flags! redisplay-flags)))
-
-(define-integrable (%window-cursor window)
- (with-instance-variables buffer-window window ()
- (inferior-window cursor-inferior)))
-
-(define (%window-cursor-y window)
- (with-instance-variables buffer-window window ()
- (let ((y (inferior-y-start cursor-inferior)))
- (and y (fix:< y y-size) y))))
+ (set! start-changes-mark mark)))
+
+(define-integrable (%window-end-changes-mark window)
+ (with-instance-variables buffer-window window () end-changes-mark))
+
+(define-integrable (%window-end-changes-index window)
+ (mark-index-integrable (%window-end-changes-mark window)))
+
+(define-integrable (%set-window-end-changes-mark! window mark)
+ (with-instance-variables buffer-window window (mark)
+ (set! end-changes-mark mark)))
+
+(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-integrable (%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-integrable (%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?*)))
\f
-;;;; Override Message
-
-;;; This is used to display messages over the typein window.
-
-(define (set-override-message! window message)
- (with-instance-variables buffer-window window (message)
- (if (not override-inferior)
- (begin
- (set! override-inferior (make-inferior window line-window))
- (set! inferiors
- (list override-inferior cursor-inferior blank-inferior))
- (set-inferior-start! override-inferior 0 0)))
- (let ((override-window (inferior-window override-inferior)))
- (set-line-window-string! override-window message truncate-lines?)
- (set-inferior-position!
- cursor-inferior
- (string-base:index->coordinates override-window
- (string-length message))))
- (set-blank-inferior-start! window (inferior-y-end override-inferior))))
-
-(define (clear-override-message! window)
- (with-instance-variables buffer-window window ()
- (if override-inferior
- (begin
- (set! override-inferior false)
- (set! inferiors
- (cons* cursor-inferior blank-inferior line-inferiors))
- (set-inferior-position! cursor-inferior
- (%window-mark->coordinates window point))
- (blank-inferior-changed! window)
- (for-each inferior-needs-redisplay! inferiors)))))
-
-(define (home-cursor! window)
- (with-instance-variables buffer-window window ()
- (screen-write-cursor! saved-screen saved-x-start saved-y-start)
- (screen-flush! saved-screen)))
+(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)))
\f
-;;;; Inferiors
-
-(define (make-line-inferior window start end)
- (with-instance-variables buffer-window window (start end)
- (let ((inferior (make-inferior window line-window)))
- (set-line-window-string! (inferior-window inferior)
- (group-extract-string (buffer-group buffer)
- start end)
- truncate-lines?)
- inferior)))
+;;;; 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)
+ (group-position->index-integrable
+ (%window-group window)
+ (mark-position (group-display-start (%window-group window)))))
+
+(define-integrable (%window-group-end-index window)
+ (group-position->index-integrable
+ (%window-group window)
+ (mark-position (group-display-end (%window-group 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:-1+ (group-index->position-integrable
+ (%window-group window)
+ index
+ false)))
+ #\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
+ true))
+ #\newline)))
-(define-integrable (first-line-inferior window)
- (with-instance-variables buffer-window window ()
- (car line-inferiors)))
-
-(define-integrable (line-inferior-length inferiors)
- (fix:1+ (line-window-length (inferior-window (car inferiors)))))
-
-(define-integrable (blank-inferior-changed! window)
- (with-instance-variables buffer-window window ()
- (if (not override-inferior)
- (set-blank-inferior-start! window
- (inferior-y-end last-line-inferior)))))
-
-(define-integrable (set-blank-inferior-start! window y-end)
- (with-instance-variables buffer-window window (y-end)
- (if (fix:< y-end y-size)
- (begin
- (set-inferior-size! blank-inferior x-size (fix:- y-size y-end))
- (set-inferior-start! blank-inferior 0 y-end))
- (set-inferior-start! blank-inferior false false))))
-
-(define-integrable (set-line-inferiors! window inferiors start)
- (with-instance-variables buffer-window window (inferiors start)
- (set! line-inferiors inferiors)
- (destroy-mark! start-line-mark)
- (set! start-line-mark
- (%make-permanent-mark (buffer-group buffer) start false))
- unspecific))
-
-(define (line-inferiors-changed! window)
- (with-instance-variables buffer-window window ()
- (let loop ((inferiors line-inferiors) (start (mark-index start-line-mark)))
- (if (null? (cdr inferiors))
- (begin
- (set! last-line-inferior (car inferiors))
- (destroy-mark! end-line-mark)
- (set! end-line-mark
- (let ((group (buffer-group buffer)))
- (%make-permanent-mark group
- (line-end-index group start)
- true))))
- (loop (cdr inferiors)
- (fix:+ start (line-inferior-length inferiors)))))
- (set! inferiors
- (if override-inferior
- (list override-inferior cursor-inferior blank-inferior)
- (cons* cursor-inferior blank-inferior line-inferiors)))
- unspecific))
+(define (clip-mark-to-display window mark)
+ (if (not (mark? mark))
+ (error:illegal-datum mark 'CLIP-MARK-TO-DISPLAY))
+ (if (and (%window-point window)
+ (not (mark~ (%window-point window) mark)))
+ (error:datum-out-of-range 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)))
\f
-(define (y->inferiors window y)
- (with-instance-variables buffer-window window (y)
- (define (loop previous-inferiors inferiors)
- (cond ((fix:< y (inferior-y-start (car inferiors))) previous-inferiors)
- ((null? (cdr inferiors))
- (and (fix:< y (inferior-y-end (car inferiors)))
- inferiors))
- (else (loop inferiors (cdr inferiors)))))
- (loop false line-inferiors)))
-
-(define (index->inferiors window index)
- (with-instance-variables buffer-window window (index)
- ;; Assumes that (>= INDEX (MARK-INDEX START-LINE-MARK)).
- (define (loop inferiors start)
- (let ((new-start (fix:+ start (line-inferior-length inferiors))))
- (if (fix:< index new-start)
- inferiors
- (and (not (null? (cdr inferiors)))
- (loop (cdr inferiors) new-start)))))
- (loop line-inferiors (mark-index start-line-mark))))
-
-(define (inferiors->index window inferiors)
- (with-instance-variables buffer-window window (inferiors)
- ;; Assumes that INFERIORS is a tail of LINE-INFERIORS.
- (define (loop inferiors* start)
- (if (eq? inferiors inferiors*)
- start
- (loop (cdr inferiors*)
- (fix:+ start (line-inferior-length inferiors*)))))
- (loop line-inferiors (mark-index start-line-mark))))
-
-(define (y->inferiors&index window y receiver)
- (with-instance-variables buffer-window window (y receiver)
- ;; This is used for scrolling.
- (define (loop inferiors start previous-inferiors previous-start)
- (cond ((fix:< y (inferior-y-start (car inferiors)))
- (receiver previous-inferiors previous-start))
- ((null? (cdr inferiors))
- (and (fix:< y (inferior-y-end (car inferiors)))
- (receiver inferiors start)))
- (else
- (loop (cdr inferiors)
- (fix:+ start (line-inferior-length inferiors))
- inferiors
- start))))
- (loop line-inferiors (mark-index start-line-mark) false false)))
-
-(define (start-changes-inferiors window)
- (with-instance-variables buffer-window window ()
- ;; Assumes that (MARK<= START-LINE-MARK START-CHANGES-MARK).
- ;; Guarantees to return non-'() result.
- (or (index->inferiors window (mark-index start-changes-mark))
- (error "Can't find START-CHANGES"))))
-
-(define (end-changes-inferiors window)
- (with-instance-variables buffer-window window ()
- ;; Assumes that (MARK<= END-CHANGES-MARK END-LINE-MARK).
- ;; Guarantees to return non-'() result.
- (let ((index (mark-index end-changes-mark)))
- (define (loop inferiors not-found)
- (if (null? inferiors)
- (not-found (mark-index end-line-mark))
- (loop (cdr inferiors)
- (lambda (end)
- (let ((new-end (fix:- end (line-inferior-length inferiors))))
- (if (fix:< new-end index)
- inferiors
- (not-found new-end)))))))
- (loop line-inferiors
- (lambda (end)
- end ;ignore
- (error "Can't find END-CHANGES"))))))
+;;;; 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))
+
+(define-integrable (set-mark-index! mark index)
+ (set-mark-position!
+ mark
+ (group-index->position-integrable (mark-group mark)
+ index
+ (mark-left-inserting? mark))))
+
+(define-integrable (fix:max x y)
+ (if (fix:> x y) x y))
+
+(define-integrable (fix:min x y)
+ (if (fix:< x y) x y))
\f
-;;;; Changes
-
-(define (update-cursor! window if-not-visible)
- (with-instance-variables buffer-window window (if-not-invisible)
- (if (%window-mark-visible? window point)
- (begin
- (set-inferior-position! cursor-inferior
- (%window-mark->coordinates window point))
- (set! point-moved? false))
- (if-not-visible window))))
-
-(define (maybe-recenter! window)
- (with-instance-variables buffer-window window ()
- (let ((threshold (ref-variable scroll-step))
- (recenter!
- (lambda ()
- (%window-redraw! window (%window-y-center window)))))
- (if (not (object-type? (ucode-type fixnum) threshold))
- (error "Not a small integer" threshold))
- (if (fix:zero? threshold)
- (recenter!)
- (if (fix:< (mark-index point) (mark-index start-mark))
- (let ((limit
- (%window-coordinates->index window
- 0
- (fix:- 0 threshold))))
- (if (or (not limit)
- (not (fix:< (mark-index point) limit)))
- (%window-scroll-y-relative! window
- (%window-point-y window))
- (recenter!)))
- (let ((limit
- (%window-coordinates->index window
- 0
- (fix:+ (window-y-size window)
- threshold))))
- (if (or (not limit) (fix:< (mark-index point) limit))
- (%window-scroll-y-relative!
- window
- (fix:- (%window-point-y window)
- (fix:-1+ (window-y-size window))))
- (recenter!))))))))
+;;;; Standard Methods
-(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)
+(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)
+ (without-interrupts (lambda () (%unset-window-buffer! window)))
+ (usual=> window :kill!))
+
+(define-method buffer-window (:salvage! window)
+ (without-interrupts
+ (lambda ()
+ (%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))))
+
+(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)
+ (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 (%window-force-redraw! window redraw-type)
- (with-instance-variables buffer-window window ()
- (set! force-redraw? (or redraw-type 'CENTER))
- (setup-redisplay-flags! redisplay-flags)))
-
-(define (%window-redraw-preserving-start! window)
- (with-instance-variables buffer-window window ()
- (let ((group (mark-group start-mark))
- (start-line (mark-index start-line-mark)))
- (let ((start (if truncate-lines? start-line (mark-index start-mark)))
- (end (line-end-index group start-line)))
- (let ((inferior (make-line-inferior window start-line end)))
- (set-inferior-start!
- inferior
- 0
- (fix:- 0
- (string-base:index->y (inferior-window inferior)
- (fix:- start start-line))))
- (set-line-inferiors!
- window
- (cons inferior (fill-bottom window (inferior-y-end inferior) end))
- start)))))
- (everything-changed! window maybe-recenter!))
+(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)
+ (set-window-y-size! window y)
+ (%set-window-point-moved?! window 'SINCE-START-SET))
\f
-(define (%window-redraw! window y)
- (with-instance-variables buffer-window window (y)
- (redraw-screen! window
- (if (not y)
- (%window-y-center window)
- (begin
- (if (or (fix:< y 0)
- (not (fix:< y y-size)))
- (error "Attempt to scroll point off window" y))
- y))))
- (everything-changed! window
- (lambda (w)
- (error "%WINDOW-REDRAW! left point offscreen -- get a wizard" w))))
-
-(define (redraw-screen! window y)
- (with-instance-variables buffer-window window (y)
- (let ((group (mark-group point))
- (index (mark-index point)))
- (let ((start (line-start-index group index)))
- (let ((inferior
- (make-line-inferior window start (line-end-index group index))))
- (set-inferior-start!
- inferior
- 0
- (fix:- y
- (string-base:index->y (inferior-window inferior)
- (fix:- index start))))
- (fill-top! window (list inferior) start true))))))
-
-(define (everything-changed! window if-not-visible)
- (with-instance-variables buffer-window window (if-not-visible)
- (no-outstanding-changes! window)
- (line-inferiors-changed! window)
- (blank-inferior-changed! window)
- (start-mark-changed! window)
- (end-mark-changed! window)
- (update-cursor! window if-not-visible)))
-
-(define (maybe-marks-changed! window inferiors y-end)
- (with-instance-variables buffer-window window (inferiors y-end)
- (no-outstanding-changes! window)
- (if (and (eq? inferiors line-inferiors)
- (fix:negative? (inferior-y-start (car inferiors))))
- (start-mark-changed! window))
- (if (and (null? (cdr inferiors))
- (fix:> y-end y-size))
- (end-mark-changed! window))
- (update-cursor! window maybe-recenter!)))
-
-(define (no-outstanding-changes! window)
- (with-instance-variables buffer-window window ()
- (destroy-mark! start-changes-mark)
- (set! start-changes-mark false)
- (destroy-mark! end-changes-mark)
- (set! end-changes-mark false)
- (destroy-mark! start-clip-mark)
- (set! start-clip-mark false)
- (destroy-mark! end-clip-mark)
- (set! end-clip-mark false)
- (set! force-redraw? false)
- unspecific))
+;;;; 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)
+ (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) false))
+ finished?)))))
+
+(define (update-buffer-window! window screen x-start y-start xl xu yl yu
+ display-style)
+ (recompute-image! window)
+ (and (if (%window-override-inferior window)
+ (update-inferior! (%window-override-inferior window)
+ screen x-start y-start xl xu yl yu display-style
+ string-base:update-display!)
+ (update-inferiors! (%window-line-inferiors window)
+ screen x-start y-start xl xu yl yu
+ display-style string-base:update-display!))
+ (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!)))
+
+(define (buffer-window/redraw! window)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window 'force-redraw!))
+ (without-interrupts
+ (lambda ()
+ (%set-window-force-redraw?! window true)
+ (%clear-window-incremental-redisplay-state! window)
+ (window-needs-redisplay! window))))
+
+(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!))
+\f
+;;;; 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))
+ (%set-window-override-inferior! window false)
+ (%set-window-changes-daemon! window (make-changes-daemon window))
+ (%set-window-clip-daemon! window (make-clip-daemon window))
+ (%set-window-debug-trace! window false))
+
+(define (%clear-window-buffer-state! window)
+ (%set-window-buffer! window false)
+ (%set-window-point! window false)
+ (%set-window-truncate-lines?! window false)
+ (if (%window-start-line-mark window)
+ (clear-start-mark! window))
+ (%set-window-point-moved?! window false)
+ (%clear-window-incremental-redisplay-state! window))
+
+(define (%clear-window-incremental-redisplay-state! window)
+ (%set-window-line-inferiors! window '())
+ (set-window-inferiors! window
+ (if (%window-override-inferior window)
+ (list (%window-override-inferior window)
+ (%window-cursor-inferior window)
+ (%window-blank-inferior window))
+ (list (%window-cursor-inferior window)
+ (%window-blank-inferior window))))
+ (if (%window-current-start-mark window)
+ (begin
+ (mark-temporary! (%window-current-start-mark window))
+ (mark-temporary! (%window-current-end-mark window))
+ (%set-window-current-start-mark! window false)
+ (%set-window-current-end-mark! window false)))
+ (%set-window-saved-screen! window false)
+ (%clear-window-outstanding-changes! window))
+
+(define-integrable (%clear-window-outstanding-changes! window)
+ (if (%window-start-changes-mark window)
+ (begin
+ (mark-temporary! (%window-start-changes-mark window))
+ (mark-temporary! (%window-end-changes-mark window))
+ (%set-window-start-changes-mark! window false)
+ (%set-window-end-changes-mark! window false)))
+ (if (%window-start-clip-mark window)
+ (begin
+ (mark-temporary! (%window-start-clip-mark window))
+ (mark-temporary! (%window-end-clip-mark window))
+ (%set-window-start-clip-mark! window false)
+ (%set-window-end-clip-mark! window false))))
\f
-(define (start-mark-changed! window)
- (with-instance-variables buffer-window window ()
- (destroy-mark! start-mark)
- (set! start-mark
- (%make-permanent-mark
- (buffer-group buffer)
- (fix:+ (mark-index start-line-mark)
- (let ((inferior (first-line-inferior window)))
- (string-base:coordinates->index
- (inferior-window inferior)
- 0
- (fix:- 0 (inferior-y-start inferior)))))
- false))
- (window-modeline-event! superior 'START-MARK-CHANGED!)))
-
-(define (end-mark-changed! window)
- (with-instance-variables buffer-window window ()
- (destroy-mark! end-mark)
- (set! end-mark
- (let ((group (buffer-group buffer)))
- (%make-permanent-mark
- group
- (fix:+ (line-start-index group (mark-index end-line-mark))
- (string-base:coordinates->index
- (inferior-window last-line-inferior)
- (fix:-1+ x-size)
- (fix:-1+
- (fix:- (min y-size (inferior-y-end last-line-inferior))
- (inferior-y-start last-line-inferior)))))
- true)))
- (window-modeline-event! superior 'END-MARK-CHANGED!)))
-
-(define (destroy-mark! mark)
- (if mark
- (mark-temporary! mark)))
+;;;; Buffer and Point
-(define-integrable (%window-start-index window)
- (with-instance-variables buffer-window window ()
- (mark-index start-mark)))
+(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:illegal-datum new-buffer 'set-window-buffer!))
+ (if (%window-buffer window)
+ (%unset-window-buffer! window))
+ (%set-window-buffer! window new-buffer)
+ (let ((group (%window-group window))
+ (changes-daemon (%window-changes-daemon window)))
+ (add-group-delete-daemon! group changes-daemon)
+ (add-group-insert-daemon! group changes-daemon)
+ (add-group-clip-daemon! group (%window-clip-daemon window))
+ (%set-window-point-index! window (mark-index (group-point group))))
+ (if (buffer-display-start new-buffer)
+ (set-new-coordinates! window
+ (mark-index (buffer-display-start new-buffer))
+ 0
+ false))
+ (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)))
+ (let ((group (%window-group window))
+ (changes-daemon (%window-changes-daemon window)))
+ (remove-group-delete-daemon! group changes-daemon)
+ (remove-group-insert-daemon! group changes-daemon)
+ (remove-group-clip-daemon! group (%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))
+ (without-interrupts
+ (lambda ()
+ (%set-window-point-index! window (mark-index mark))
+ (%set-window-point-moved?! window 'SINCE-START-SET)
+ (%set-buffer-point! (%window-buffer window) mark)
+ (window-needs-redisplay! window)))))
+\f
+;;;; 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)
+ ;; if (> Y-DELTA 0) and line inferiors valid, use them.
+ (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 (set-new-coordinates! window index y point-y)
+ (with-values (lambda () (predict-start-line window index y))
+ (lambda (start y-start)
+ (cond ((predict-index-visible? window start y-start
+ (%window-point-index window))
+ (without-interrupts
+ (lambda ()
+ (set-start-mark! window start y-start))))
+ (point-y
+ (without-interrupts
+ (lambda ()
+ (%set-window-point-index!
+ window
+ (or (predict-index window start y-start 0 point-y)
+ (%window-group-end-index window)))
+ (set-start-mark! window start y-start))))))))
+
+(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:datum-out-of-range y-point 'window-scroll-y-absolute!))
+ (with-values
+ (lambda ()
+ (predict-start-line window (%window-point-index window) y-point))
+ (lambda (start y-start)
+ (without-interrupts
+ (lambda ()
+ (set-start-mark! window start y-start))))))
+\f
+(define (set-start-mark! window start-line y-start)
+ (if (fix:= y-start 0)
+ (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
+ false)))
+ (%set-window-start-line-mark! window mark)
+ (%set-window-start-mark! window mark)))
+ (let ((start (predict-start-index window start-line y-start)))
+ (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 false))
+ (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 false))
+ (%set-window-start-mark!
+ window
+ (%make-permanent-mark group start false))))))
+ (%set-window-start-line-y! window y-start)
+ (if (eq? (%window-point-moved? window) 'SINCE-START-SET)
+ (%set-window-point-moved?! window true))
+ (window-needs-redisplay! window))
+
+(define-integrable (clear-start-mark! window)
+ (mark-temporary! (%window-start-line-mark window))
+ (mark-temporary! (%window-start-mark window))
+ (%set-window-start-line-mark! window false)
+ (%set-window-start-mark! window false)
+ (%set-window-start-line-y! window 0))
+\f
+(define (guarantee-start-mark! window)
+ (without-interrupts (lambda () (%guarantee-start-mark! window))))
+
+(define (%guarantee-start-mark! window)
+ (let ((point-at!
+ (lambda (y)
+ (with-values
+ (lambda ()
+ (predict-start-line window (%window-point-index window) y))
+ (lambda (start y-start)
+ (set-start-mark! window start y-start))))))
+ (let ((recenter! (lambda () (point-at! (buffer-window/y-center window)))))
+ (cond ((not (%window-start-line-mark window))
+ (recenter!))
+ ((eq? (%window-point-moved? window) 'SINCE-START-SET)
+ (let ((y
+ (predict-y window
+ (%window-start-line-index window)
+ (%window-start-line-y window)
+ (%window-point-index window))))
+ (cond ((fix:< y 0)
+ (let ((y (fix:+ y (ref-variable scroll-step))))
+ (if (fix:< y 0)
+ (recenter!)
+ (point-at! y))))
+ ((fix:>= y (window-y-size window))
+ (let ((y (fix:- y (ref-variable scroll-step))))
+ (if (fix:>= y (window-y-size window))
+ (recenter!)
+ (point-at! y)))))))))))
-(define-integrable (%window-end-index window)
- (with-instance-variables buffer-window window ()
- (mark-index end-mark)))
+(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)
-(define-integrable (%window-mark-visible? window mark)
- (with-instance-variables buffer-window window (mark)
- (and (mark<= start-mark mark)
- (mark<= mark end-mark))))
+(define-variable-value-validity-test (ref-variable-object scroll-step)
+ (lambda (scroll-step)
+ (and (fix:fixnum? scroll-step)
+ (fix:>= scroll-step 0))))
-(define (%window-y-center window)
- (with-instance-variables buffer-window window ()
+(define (buffer-window/y-center window)
+ (let ((y-size (window-y-size window)))
(let ((result
- (integer-round
- (* y-size
- (inexact->exact (round (ref-variable cursor-centering-point))))
- 100)))
- (cond ((fix:< result 0) 0)
- ((fix:< result y-size) result)
- (else (fix:-1+ y-size))))))
+ (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)
\ No newline at end of file
+ 50)
+
+(define-variable-value-validity-test
+ (ref-variable-object cursor-centering-point)
+ (lambda (value)
+ (and (real? value)
+ (<= 0 value 100))))
+\f
+;;;; Line Inferiors
+
+(define-class line-window string-base
+ ())
+
+(define-integrable (make-line-inferior window start end)
+ (%make-line-inferior window (%window-extract-string window start end)))
+
+(define (%make-line-inferior window string)
+ (let ((window* (make-object line-window))
+ (flags (cons false (window-redisplay-flags window))))
+ (let ((inferior (%make-inferior window* false false flags)))
+ (set-window-inferiors! window (cons inferior (window-inferiors window)))
+ (%set-window-superior! window* window)
+ (set-window-inferiors! window* '())
+ (%set-window-redisplay-flags! window* flags)
+ (%set-window-x-size! window* (window-x-size window))
+ (let ((*image (string->image string 0)))
+ (%set-window-y-size! window*
+ (column->y-size (image-column-size *image)
+ (window-x-size window)
+ (%window-truncate-lines? window)))
+ (with-instance-variables line-window window*
+ (*image %window-truncate-lines? window)
+ (set! image *image)
+ (set! truncate-lines? (%window-truncate-lines? window))))
+ (string-base:refresh! window*)
+ (%set-inferior-x-start! inferior 0)
+ inferior)))
+
+(define-integrable (line-window-image window)
+ (with-instance-variables line-window window () image))
+
+(define-integrable (line-window-string window)
+ (image-string (line-window-image window)))
+
+(define-integrable (line-window-length window)
+ (string-length (line-window-string window)))
+
+(define-integrable (line-inferior-length inferior)
+ (fix:+ (line-window-length (inferior-window inferior)) 1))
+
+(define (buffer-window/override-message window)
+ (let ((inferior (%window-override-inferior window)))
+ (and inferior
+ (line-window-string (inferior-window inferior)))))
+
+(define (buffer-window/set-override-message! window message)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window 'set-override-message!
+ message))
+ (without-interrupts
+ (lambda ()
+ (let ((inferior (%make-line-inferior window message)))
+ (%set-window-override-inferior! window inferior)
+ (set-inferior-start! inferior 0 0)
+ (set-inferior-position!
+ (%window-cursor-inferior window)
+ (string-base:index->coordinates (inferior-window inferior)
+ (string-length message))))
+ (inferiors-changed! window))))
+
+(define (buffer-window/clear-override-message! window)
+ (if (%window-override-inferior window)
+ (begin
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window
+ 'clear-override-message!))
+ (without-interrupts
+ (lambda ()
+ (%set-window-override-inferior! window false)
+ (update-cursor! window)
+ (inferiors-changed! window)
+ (for-each-inferior window inferior-needs-redisplay!))))))
+\f
+;;;; Update Finalization
+
+(define (set-line-inferiors! window inferiors)
+ (%set-window-line-inferiors! window inferiors)
+ (inferiors-changed! window)
+ (%clear-window-outstanding-changes! window)
+ (update-cursor! window)
+ (%window-modeline-event! window 'SET-LINE-INFERIORS))
+
+(define-integrable (set-current-end-index! window end)
+ (if (%window-current-start-mark window)
+ (begin
+ (set-mark-position! (%window-current-start-mark window)
+ (mark-position (%window-start-line-mark window)))
+ (set-mark-index! (%window-current-end-mark window) end))
+ (begin
+ (%set-window-current-start-mark!
+ window
+ (mark-permanent-copy (%window-start-line-mark window)))
+ (%set-window-current-end-mark!
+ window
+ (%make-permanent-mark (%window-group window) end true)))))
+
+(define (inferiors-changed! window)
+ (let ((update-blank-inferior
+ (lambda (last-inferior)
+ (let ((y-end (%inferior-y-end last-inferior))
+ (inferior (%window-blank-inferior window)))
+ (if (fix:< y-end (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) y-end))
+ (%set-inferior-x-start! inferior 0)
+ (%set-inferior-y-start! inferior y-end)
+ (setup-redisplay-flags!
+ (inferior-redisplay-flags inferior)))
+ (begin
+ (%set-inferior-x-start! inferior false)
+ (%set-inferior-y-start! inferior false)))))))
+ (cond ((%window-override-inferior window)
+ (set-window-inferiors! window
+ (list (%window-override-inferior window)
+ (%window-cursor-inferior window)
+ (%window-blank-inferior window)))
+ (update-blank-inferior (%window-override-inferior window)))
+ ((not (null? (%window-line-inferiors window)))
+ (set-window-inferiors! window
+ (cons* (%window-cursor-inferior window)
+ (%window-blank-inferior window)
+ (%window-line-inferiors window)))
+ (update-blank-inferior
+ (car (last-pair (%window-line-inferiors window)))))
+ (else
+ (set-window-inferiors! window
+ (list (%window-cursor-inferior window)
+ (%window-blank-inferior window)))))))
+
+(define (update-cursor! window)
+ (let ((xy (buffer-window/point-coordinates window)))
+ (if (not (and (fix:<= 0 (car xy))
+ (fix:< (car xy) (window-x-size window))
+ (fix:<= 0 (cdr xy))
+ (fix:< (cdr xy) (window-y-size window))))
+ (error "point not visible at end of redisplay"))
+ (set-inferior-position! (%window-cursor-inferior window) xy)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.12 1989/08/14 09:22:07 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.13 1990/11/02 03:23:02 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; of that license should have been included along with this file.
;;;
-;;;; Buffer Windows: Image Update
+;;;; Buffer Windows: Image Update
(declare (usual-integrations))
\f
-;;;; Insert/Delete/Clip
-
-;;; It is assumed that the insert daemon is called after the insertion
-;;; has been performed, and the delete daemon before the deletion has
-;;; been performed. It is also assumed that interrupts are disabled.
+;;;; Insert/Delete
(define (make-changes-daemon window)
+ ;; It is assumed that the insert daemon is called after the
+ ;; insertion has been performed, and the delete daemon before the
+ ;; deletion has been performed. It is also assumed that interrupts
+ ;; are disabled.
(lambda (group start end)
- (with-instance-variables buffer-window window (group start end)
- (let ((start (group-index->position group start false))
- (end (group-index->position group end true)))
- (cond ((not start-changes-mark)
- (set! start-changes-mark
- (%make-permanent-mark group start false))
- (set! end-changes-mark (%make-permanent-mark group end true)))
- ((fix:< start (mark-position start-changes-mark))
- (set-mark-position! start-changes-mark start))
- ((fix:> end (mark-position end-changes-mark))
- (set-mark-position! end-changes-mark end)))
- (if (and (not (car redisplay-flags))
- (not (fix:< end (mark-position start-line-mark)))
- (not (fix:> start (mark-position end-mark))))
- (setup-redisplay-flags! redisplay-flags))))))
-
-;;; It is assumed that the clip daemon is called before the clipping
-;;; has been performed, so that we can get the old clipping limits.
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window 'change-daemon
+ group start end))
+ ;; Record changes that intersect the current line inferiors.
+ (if (and (not (%window-force-redraw? window))
+ (fix:<= (%window-current-start-index window) end)
+ (fix:<= start (%window-current-end-index window)))
+ ;; We can compare marks by their positions here because
+ ;; the marks being compared have the same
+ ;; LEFT-INSERTING? flag.
+ (let ((start
+ (group-index->position-integrable group start false))
+ (end (group-index->position-integrable group end true)))
+ (if (not (%window-start-changes-mark window))
+ (begin
+ (%set-window-start-changes-mark!
+ window
+ (%%make-permanent-mark group start false))
+ (%set-window-end-changes-mark!
+ window
+ (%%make-permanent-mark group end true)))
+ (begin
+ (if (fix:< start
+ (mark-position
+ (%window-start-changes-mark window)))
+ (set-mark-position!
+ (%window-start-changes-mark window)
+ start))
+ (if (fix:> end
+ (mark-position
+ (%window-end-changes-mark window)))
+ (set-mark-position! (%window-end-changes-mark window)
+ end))))
+ (window-needs-redisplay! window)))
+ ;; If this change affects where the window starts, choose a
+ ;; new place to start it.
+ (if (%window-start-line-mark window)
+ (begin
+ (if (let ((wlstart (%window-start-line-index window))
+ (wstart (%window-start-index window)))
+ (and (if (fix:= wlstart wstart)
+ (fix:< start wstart)
+ (fix:<= start wstart))
+ (fix:<= wlstart end)))
+ (begin
+ (clear-start-mark! window)
+ (window-needs-redisplay! window)))
+ (if (and (not (eq? (%window-point-moved? window)
+ 'SINCE-START-SET))
+ (let ((point (%window-point-index window)))
+ (and (fix:<= start point)
+ (fix:<= point end))))
+ (%set-window-point-moved?! window 'SINCE-START-SET))))))
+\f
+;;;; Clip
(define (make-clip-daemon window)
+ ;; It is assumed that the clip daemon is called before the clipping
+ ;; has been performed. It is also assumed that interrupts are
+ ;; disabled.
(lambda (group start end)
- (with-instance-variables buffer-window window (group start end)
- (if (not start-clip-mark)
- (begin
- (set! start-clip-mark (group-display-start group))
- (set! end-clip-mark (group-display-end group))))
- (if (not (car redisplay-flags))
- (let ((start (group-index->position group start false))
- (end (group-index->position group end true))
- (window-start (mark-position start-line-mark))
- (window-end (mark-position end-mark)))
- (if (or (fix:> start window-start)
- (fix:< end window-end)
- (and (fix:< start window-start)
- (fix:= window-start (mark-position start-clip-mark)))
- (and (fix:> end window-end)
- (fix:= window-end (mark-position end-clip-mark))))
- (setup-redisplay-flags! redisplay-flags)))))))
-
-(define (update-buffer-window! window screen x-start y-start
- xl xu yl yu display-style)
- ;; The primary update entry.
- (recompute-image! window)
- (update-inferiors! window screen x-start y-start xl xu yl yu display-style))
-
-(define (maybe-recompute-image! window)
- (with-instance-variables buffer-window window ()
- ;; Used to guarantee everything updated before certain operations.
- (if (car redisplay-flags)
- (recompute-image! window))))
+ (if (not (%window-force-redraw? window))
+ (begin
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window 'clip-daemon
+ group start end))
+ (if (not (%window-start-clip-mark window))
+ (begin
+ (%set-window-start-clip-mark!
+ window
+ (%make-permanent-mark group
+ (group-display-start-index group)
+ true))
+ (%set-window-end-clip-mark!
+ window
+ (%make-permanent-mark group
+ (group-display-end-index group)
+ false))))
+ (let ((start (group-index->position-integrable group start true))
+ (end (group-index->position-integrable group end false)))
+ ;; We can compare marks by their positions here because the
+ ;; marks being compared have the same LEFT-INSERTING? flag.
+ (if (fix:> start (mark-position (%window-start-clip-mark window)))
+ (set-mark-position! (%window-start-clip-mark window) start))
+ (if (fix:< end (mark-position (%window-end-clip-mark window)))
+ (set-mark-position! (%window-end-clip-mark window) end)))
+ (if (and (not (window-needs-redisplay? window))
+ (or (fix:>= (%window-start-clip-index window)
+ (%window-current-start-index window))
+ (fix:<= (%window-end-clip-index window)
+ (%window-current-end-index window))))
+ (window-needs-redisplay! window))))
+ (if (and (%window-start-line-mark window)
+ (or (fix:>= start (%window-start-line-index window))
+ (fix:< end (%window-start-index window))))
+ (begin
+ (clear-start-mark! window)
+ (window-needs-redisplay! window)))))
\f
-(define (recompute-image! window)
- (with-instance-variables buffer-window window ()
- (without-interrupts (lambda () (%recompute-image! window)))))
+;;;; Update
-(define (%recompute-image! window)
- (with-instance-variables buffer-window window ()
- (cond ((not force-redraw?)
- (let ((group (mark-group start-mark))
- (start-line (mark-index start-line-mark))
- (start (mark-index start-mark))
- (end (mark-index end-mark))
- (point-index (mark-index point)))
- (if start-clip-mark
- (let ((new-clip-start (group-start-index group))
- (new-clip-end (group-end-index group)))
- (cond ((fix:< point-index new-clip-start)
- (%set-buffer-point! buffer
- (group-display-start group))
- (set! point (buffer-point buffer)))
- ((fix:> point-index new-clip-end)
- (%set-buffer-point! buffer (group-display-end group))
- (set! point (buffer-point buffer))))
- (cond ((fix:> new-clip-start start-line)
- (%window-redraw! window false))
- ((or (fix:< new-clip-end end)
- (and (fix:< new-clip-start start-line)
- (fix:= start-line
- (mark-index start-clip-mark)))
- (and (fix:> new-clip-end end)
- (fix:= end (mark-index end-clip-mark))))
- (%window-redraw! window
- (and (not start-changes-mark)
- (not (fix:< point-index start))
- (not (fix:> point-index end))
- (%window-point-y window))))
- (else
- (destroy-mark! start-clip-mark)
- (set! start-clip-mark false)
- (destroy-mark! end-clip-mark)
- (set! end-clip-mark false)))))
- (if start-changes-mark
- (let ((start-changes (mark-index start-changes-mark))
- (end-changes (mark-index end-changes-mark)))
- (if (and (not (fix:< end-changes start-line))
- (not (fix:> start-changes end)))
- (if (not (fix:> start-changes start))
- (if (fix:< end-changes end)
- (recompute-image!:top-changed window)
- (%window-redraw! window false))
- (if (not (fix:< end-changes end))
- (recompute-image!:bottom-changed window)
- (recompute-image!:middle-changed window)))
- (begin
- (destroy-mark! start-changes-mark)
- (set! start-changes-mark false)
- (destroy-mark! end-changes-mark)
- (set! end-changes-mark false))))))
- (if point-moved?
- (update-cursor! window maybe-recenter!)))
- ((eq? 'START force-redraw?)
- (%window-redraw-preserving-start! window))
- ((eq? 'POINT force-redraw?)
- (%window-redraw! window (%window-point-y window)))
- ((eq? 'BUFFER-CURSOR-Y force-redraw?)
- (%window-redraw! window (%window-buffer-cursor-y window)))
- ((eq? 'CENTER force-redraw?)
- (%window-redraw! window (%window-y-center window)))
- ((and (object-type? (ucode-type fixnum) force-redraw?)
- (not (fix:negative? force-redraw?))
- (fix:< force-redraw? y-size))
- (%window-redraw! window force-redraw?))
- (else
- (%window-redraw! window (%window-y-center window))))))
-\f
-(define (recompute-image!:top-changed window)
- (with-instance-variables buffer-window window ()
- (let ((inferiors (end-changes-inferiors window))
- (group (mark-group end-changes-mark))
- (index (mark-index end-changes-mark)))
- (let ((start-index (line-start-index group index)))
- (set-line-window-string!
- (inferior-window (car inferiors))
- (group-extract-string group start-index (line-end-index group index))
- truncate-lines?)
- (fill-top! window inferiors start-index true)))
- (everything-changed! window maybe-recenter!)))
+(define (recompute-image! window)
+ (%guarantee-start-mark! window)
+ (if (%window-force-redraw? window)
+ (begin
+ (%set-window-force-redraw?! window false)
+ (preserve-nothing! window))
+ (let ((start (%window-current-start-index window))
+ (end (%window-current-end-index window)))
+ (cond ((and (%window-start-clip-mark window)
+ (let ((start-clip (%window-start-clip-index window))
+ (end-clip (%window-end-clip-index window)))
+ (or (and (fix:<= start start-clip)
+ (fix:<= (%window-group-start-index window)
+ end))
+ (and (fix:<= end-clip end)
+ (fix:<= start
+ (%window-group-end-index window))))))
+ (preserve-nothing! window))
+ ((%window-start-changes-mark window)
+ (let ((start-changes
+ (let ((start-changes
+ (%window-start-changes-index window)))
+ (%window-line-start-index window start-changes)))
+ (end-changes
+ (let ((end-changes (%window-end-changes-index window)))
+ (%window-line-end-index window end-changes))))
+ (if (fix:<= start-changes start)
+ (if (fix:< end-changes end)
+ (preserve-contiguous-region!
+ window
+ (cdr
+ (changed-inferiors-tail
+ (%window-line-inferiors window)
+ end
+ end-changes))
+ (fix:+ end-changes 1))
+ (preserve-nothing! window))
+ (if (fix:< end-changes end)
+ (preserve-top-and-bottom! window
+ start start-changes
+ end-changes end)
+ (let ((inferiors (%window-line-inferiors window)))
+ (set-cdr! (unchanged-inferiors-tail inferiors
+ start
+ start-changes)
+ '())
+ (preserve-contiguous-region! window
+ inferiors
+ start))))))
+ (else
+ (preserve-all! window start))))))
-(define (recompute-image!:bottom-changed window)
- (with-instance-variables buffer-window window ()
- (let ((inferiors (start-changes-inferiors window))
- (group (mark-group start-changes-mark))
- (index (mark-index start-changes-mark)))
- (let ((end-index (line-end-index group index)))
- (set-line-window-string!
- (inferior-window (car inferiors))
- (group-extract-string group (line-start-index group index) end-index)
- truncate-lines?)
- (set-cdr! inferiors
- (fill-bottom window
- (inferior-y-end (car inferiors))
- end-index))))
- (everything-changed! window maybe-recenter!)))
+(define-integrable (preserve-nothing! window)
+ (set-line-inferiors!
+ window
+ (generate-line-inferiors window
+ (%window-start-line-index window)
+ (%window-start-line-y window))))
\f
-(define (recompute-image!:middle-changed window)
- (with-instance-variables buffer-window window ()
- (let ((start-inferiors (start-changes-inferiors window))
- (end-inferiors (end-changes-inferiors window))
- (group (buffer-group buffer))
- (start-index (mark-index start-changes-mark))
- (end-index (mark-index end-changes-mark)))
- (let ((start-start (line-start-index group start-index))
- (start-end (line-end-index group start-index))
- (end-start (line-start-index group end-index))
- (end-end (line-end-index group end-index)))
- (if (eq? start-inferiors end-inferiors)
- (if (fix:= start-start end-start)
+(define (preserve-contiguous-region! window inferiors start)
+ (let ((wlstart (%window-start-line-index window))
+ (wlsy (%window-start-line-y window)))
+ (set-line-inferiors!
+ window
+ (with-values
+ (lambda ()
+ (scroll-lines! window
+ inferiors
+ start
+ (predict-y window wlstart wlsy start)))
+ (lambda (inferiors start)
+ (if (null? inferiors)
+ (generate-line-inferiors window wlstart wlsy)
+ (fill-edges! window inferiors start)))))))
- ;; In this case, the changed region was a single line before the
- ;; changes, and is still a single line now. All we need do is redraw
- ;; the line and then scroll the rest up or down if the y-size of the
- ;; line has been changed.
- (let ((y-end (inferior-y-end (car start-inferiors))))
- (set-line-window-string!
- (inferior-window (car start-inferiors))
- (group-extract-string group start-start start-end)
- truncate-lines?)
- (let ((y-end* (inferior-y-end (car start-inferiors))))
- (if (fix:= y-end y-end*)
- (maybe-marks-changed! window start-inferiors y-end*)
- (begin
- (set-cdr! start-inferiors
- (cond ((fix:< y-end y-end*)
- (scroll-lines-down! window
- (cdr start-inferiors)
- y-end*))
- ((not (null? (cdr start-inferiors)))
- (scroll-lines-up! window
- (cdr start-inferiors)
- y-end*
- (fix:1+ start-end)))
- (else
- (fill-bottom window y-end* start-end))))
- (everything-changed! window maybe-recenter!)))))
+(define-integrable (fill-edges! window inferiors start)
+ (fill-top window (fill-bottom! window inferiors start) start))
- ;; Here, the changed region used to be a single line, and now is
- ;; several, so we need to insert a bunch of new lines.
- (begin
- (set-line-window-string! (inferior-window (car start-inferiors))
- (group-extract-string group start-start start-end)
- truncate-lines?)
- (set-cdr! start-inferiors
- (if (null? (cdr start-inferiors))
- (fill-bottom window
- (inferior-y-end (car start-inferiors))
- start-end)
- (fill-middle! window
- (inferior-y-end (car start-inferiors))
- start-end
- (cdr start-inferiors)
- (fix:1+ end-end))))
- (everything-changed! window maybe-recenter!))
- )
-;;; continued on next page...
+(define (preserve-all! window start)
+ (let ((wlstart (%window-start-line-index window))
+ (wlsy (%window-start-line-y window))
+ (inferiors (%window-line-inferiors window)))
+ (let ((scroll-down
+ (lambda (y-start)
+ (set-line-inferiors!
+ window
+ (let ((inferiors (scroll-lines-down! window inferiors y-start)))
+ (if (null? inferiors)
+ (generate-line-inferiors window wlstart wlsy)
+ (begin
+ (let ((end
+ (let loop ((inferiors inferiors) (start start))
+ (if (null? (cdr inferiors))
+ (%window-line-end-index window start)
+ (loop (cdr inferiors)
+ (fix:+ start
+ (line-inferior-length
+ (car inferiors))))))))
+ ;; SET-CURRENT-END-INDEX! is integrable
+ (set-current-end-index! window end))
+ (fill-top window inferiors start)))))))
+ (scroll-up
+ (lambda (y-start)
+ (set-line-inferiors!
+ window
+ (with-values
+ (lambda () (scroll-lines-up! window inferiors start y-start))
+ (lambda (inferiors start)
+ (if (null? inferiors)
+ (generate-line-inferiors window wlstart wlsy)
+ (fill-bottom! window inferiors start))))))))
+ (cond ((fix:= wlstart start)
+ (let ((y-start (inferior-y-start (car inferiors))))
+ (cond ((fix:= wlsy y-start)
+ (%clear-window-outstanding-changes! window)
+ (if (%window-point-moved? window)
+ (begin
+ (%set-window-point-moved?! window false)
+ (update-cursor! window))))
+ ((fix:< wlsy y-start)
+ (scroll-up wlsy))
+ (else
+ (scroll-down wlsy)))))
+ ((fix:< wlstart start)
+ (scroll-down (predict-y window wlstart wlsy start)))
+ (else
+ (scroll-up (predict-y window wlstart wlsy start)))))))
\f
-;;; ...continued from previous page
-
- (if (fix:= start-start end-start)
+(define (preserve-top-and-bottom! window start start-changes end-changes end)
+ (let ((wlstart (%window-start-line-index window))
+ (wlsy (%window-start-line-y window))
+ (top-inferiors (%window-line-inferiors window)))
+ (let* ((top-tail
+ (unchanged-inferiors-tail top-inferiors start start-changes))
+ (middle-tail
+ (changed-inferiors-tail (cdr top-tail) end end-changes))
+ (bottom-inferiors (cdr middle-tail)))
+ (set-cdr! top-tail '())
+ (set-cdr! middle-tail '())
+ (with-values
+ (lambda ()
+ (scroll-lines! window
+ top-inferiors
+ start
+ (predict-y window wlstart wlsy start)))
+ (lambda (top-inferiors top-start)
+ (with-values
+ (lambda ()
+ (let ((bottom-start (fix:+ end-changes 1)))
+ (scroll-lines! window
+ bottom-inferiors
+ bottom-start
+ (predict-y window wlstart wlsy
+ bottom-start))))
+ (lambda (bottom-inferiors bottom-start)
+ (set-line-inferiors!
+ window
+ (if (null? top-inferiors)
+ (if (null? bottom-inferiors)
+ (generate-line-inferiors window wlstart wlsy)
+ (fill-edges! window bottom-inferiors bottom-start))
+ (if (null? bottom-inferiors)
+ (fill-edges! window top-inferiors top-start)
+ (fill-top window
+ (fill-middle! window
+ top-inferiors
+ top-start
+ (fill-bottom! window
+ bottom-inferiors
+ bottom-start)
+ bottom-start)
+ top-start)))))))))))
- ;; The changed region used to be multiple lines and is now just one.
- ;; We must scroll the bottom of the screen up to fill in.
- (begin
- (set-line-window-string! (inferior-window (car start-inferiors))
- (group-extract-string group start-start start-end)
- truncate-lines?)
- (set-cdr! start-inferiors
- (if (null? (cdr end-inferiors))
- (fill-bottom window
- (inferior-y-end (car start-inferiors))
- start-end)
- (scroll-lines-up! window
- (cdr end-inferiors)
- (inferior-y-end (car start-inferiors))
- (fix:1+ start-end))))
- (everything-changed! window maybe-recenter!))
+(define (changed-inferiors-tail inferiors end end-changes)
+ (let find-end
+ ((inferiors inferiors)
+ (find-end-changes
+ (lambda (end)
+ end
+ (error "can't find END-CHANGES"))))
+ (if (null? inferiors)
+ (find-end-changes end)
+ (find-end (cdr inferiors)
+ (lambda (end)
+ (if (fix:= end end-changes)
+ inferiors
+ (find-end-changes
+ (fix:- end
+ (line-inferior-length (car inferiors))))))))))
- ;; The most general case, we must refill the center of the screen.
- (begin
- (set-line-window-string!
- (inferior-window (car start-inferiors))
- (group-extract-string group start-start start-end)
- truncate-lines?)
- (let ((old-y-end (inferior-y-end (car end-inferiors))))
- (set-line-window-string! (inferior-window (car end-inferiors))
- (group-extract-string group end-start end-end)
- truncate-lines?)
- (let ((y-end (inferior-y-end (car end-inferiors)))
- (tail (cdr end-inferiors)))
- (cond ((fix:> y-end old-y-end)
- (set-cdr! end-inferiors (scroll-lines-down! window tail y-end)))
- ((fix:< y-end old-y-end)
- (set-cdr! end-inferiors
- (scroll-lines-up! window
- tail
- y-end
- (fix:1+ end-end)))))))
- (set-cdr! start-inferiors
- (fill-middle! window
- (inferior-y-end (car start-inferiors))
- start-end
- end-inferiors
- end-start))
- (everything-changed! window maybe-recenter!))
-
- ))))))
+(define (unchanged-inferiors-tail inferiors start start-changes)
+ (let loop ((inferiors inferiors) (start start))
+ (let ((start-next (fix:+ start (line-inferior-length (car inferiors)))))
+ (cond ((fix:>= start-next start-changes)
+ inferiors)
+ ((null? (cdr inferiors))
+ (error "can't find START-CHANGES"))
+ (else
+ (loop (cdr inferiors) start-next))))))
\f
-;;;; Direct Update/Output Support
+;;;; Direct Output
;;; The direct output procedures are hairy and should be used only
;;; under restricted conditions. In particular, the cursor may not be
;;; modifiable, and the modeline must already show that it has been
;;; modified. None of the procedures may be used if the window needs
;;; redisplay.
-;;; They must be called without interrupts.
-(define (%window-direct-update! window display-style)
- (with-instance-variables buffer-window window (display-style)
- (if (not saved-screen)
- (error "Window needs normal redisplay -- can't direct update" window))
- (and (with-screen-in-update! saved-screen
- (lambda ()
- (update-buffer-window! window saved-screen
- saved-x-start saved-y-start
- saved-xl saved-xu saved-yl saved-yu
- display-style)))
- (begin
- (set-car! redisplay-flags false)
- true))))
+(define (buffer-window/needs-redisplay? window)
+ (if (or (window-needs-redisplay? window)
+ (not (%window-saved-screen window))
+ (screen-needs-update? (%window-saved-screen window)))
+ true
+ false))
+
+(define (buffer-window/direct-output-forward-char! window)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window
+ 'direct-output-forward-char!))
+ (without-interrupts
+ (lambda ()
+ (%set-window-point-index! window (fix:+ (%window-point-index window) 1))
+ (let ((x-start
+ (fix:1+ (inferior-x-start (%window-cursor-inferior window))))
+ (y-start (inferior-y-start (%window-cursor-inferior window))))
+ (screen-direct-output-move-cursor
+ (%window-saved-screen window)
+ (fix:+ (%window-saved-x-start window) x-start)
+ (fix:+ (%window-saved-y-start window) y-start))
+ (%set-inferior-x-start! (%window-cursor-inferior window) x-start)))))
-(define (%direct-output-forward-character! window)
- (with-instance-variables buffer-window window ()
- (%set-buffer-point! buffer (mark1+ point))
- (set! point (buffer-point buffer))
- (let ((x-start (fix:1+ (inferior-x-start cursor-inferior)))
- (y-start (inferior-y-start cursor-inferior)))
- (screen-write-cursor! saved-screen
- (fix:+ saved-x-start x-start)
- (fix:+ saved-y-start y-start))
- (screen-flush! saved-screen)
- (%set-inferior-x-start! cursor-inferior x-start))))
+(define (buffer-window/direct-output-backward-char! window)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window
+ 'direct-output-backward-char!))
+ (without-interrupts
+ (lambda ()
+ (%set-window-point-index! window (fix:- (%window-point-index window) 1))
+ (let ((x-start
+ (fix:-1+ (inferior-x-start (%window-cursor-inferior window))))
+ (y-start (inferior-y-start (%window-cursor-inferior window))))
+ (screen-direct-output-move-cursor
+ (%window-saved-screen window)
+ (fix:+ (%window-saved-x-start window) x-start)
+ (fix:+ (%window-saved-y-start window) y-start))
+ (%set-inferior-x-start! (%window-cursor-inferior window) x-start)))))
-(define (%direct-output-backward-character! window)
- (with-instance-variables buffer-window window ()
- (%set-buffer-point! buffer (mark-1+ point))
- (set! point (buffer-point buffer))
- (let ((x-start (fix:-1+ (inferior-x-start cursor-inferior)))
- (y-start (inferior-y-start cursor-inferior)))
- (screen-write-cursor! saved-screen
- (fix:+ saved-x-start x-start)
- (fix:+ saved-y-start y-start))
- (screen-flush! saved-screen)
- (%set-inferior-x-start! cursor-inferior x-start))))
+(define (buffer-window/home-cursor! window)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window 'home-cursor!))
+ (if (and (%window-saved-screen window)
+ (fix:<= (%window-saved-xl window) 0)
+ (fix:< 0 (%window-saved-xu window))
+ (fix:<= (%window-saved-yl window) 0)
+ (fix:< 0 (%window-saved-yu window)))
+ (without-interrupts
+ (lambda ()
+ (screen-direct-output-move-cursor (%window-saved-screen window)
+ (%window-saved-x-start window)
+ (%window-saved-y-start window))))))
\f
-(define (%direct-output-insert-char! window char)
- (with-instance-variables buffer-window window (char)
- (let ((x-start (inferior-x-start cursor-inferior))
- (y-start (inferior-y-start cursor-inferior)))
- (let ((x (fix:+ saved-x-start x-start))
- (y (fix:+ saved-y-start y-start)))
- (screen-write-char! saved-screen x y char)
- (screen-write-cursor! saved-screen (fix:1+ x) y)
- (screen-flush! saved-screen))
- (line-window-direct-output-insert-char!
- (inferior-window (car (y->inferiors window y-start)))
- x-start
- char)
- (%set-inferior-x-start! cursor-inferior (fix:1+ x-start)))))
+(define (buffer-window/direct-output-insert-char! window char)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window
+ 'direct-output-insert-char! char))
+ (without-interrupts
+ (lambda ()
+ (%group-insert-char! (%window-group window)
+ (%window-point-index window)
+ char)
+ (let ((x-start (inferior-x-start (%window-cursor-inferior window)))
+ (y-start (inferior-y-start (%window-cursor-inferior window))))
+ (screen-direct-output-char
+ (%window-saved-screen window)
+ (fix:+ (%window-saved-x-start window) x-start)
+ (fix:+ (%window-saved-y-start window) y-start)
+ char
+ false)
+ (string-base:direct-output-insert-char!
+ (direct-output-line-window window y-start)
+ x-start
+ char)
+ (%set-inferior-x-start! (%window-cursor-inferior window)
+ (fix:+ x-start 1))))))
-(define (%direct-output-insert-newline! window)
- (with-instance-variables buffer-window window ()
- (let ((y-start (fix:1+ (inferior-y-start cursor-inferior))))
- (let ((inferior (make-inferior window line-window)))
- (%set-inferior-x-start! inferior 0)
- (%set-inferior-y-start! inferior y-start)
- (set-cdr! (last-pair line-inferiors) (list inferior))
- (set! last-line-inferior inferior)
- (line-window-direct-output-insert-newline!
- (inferior-window inferior)))
- (let ((y-end (fix:1+ y-start)))
- (if (fix:< y-end y-size)
- (begin
- (%set-inferior-y-size! blank-inferior (fix:- y-size y-end))
- (%set-inferior-y-start! blank-inferior y-end))
- (begin
- (%set-inferior-x-start! blank-inferior false)
- (%set-inferior-y-start! blank-inferior false))))
- (%set-inferior-x-start! cursor-inferior 0)
- (%set-inferior-y-start! cursor-inferior y-start)
- (screen-write-cursor! saved-screen
- saved-x-start
- (fix:+ saved-y-start y-start))
- (screen-flush! saved-screen))))
+(define (buffer-window/direct-output-insert-substring! window string start end)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window
+ 'direct-output-insert-substring!
+ (string-copy string) start end))
+ (without-interrupts
+ (lambda ()
+ (%group-insert-substring! (%window-group window)
+ (%window-point-index window)
+ string start end)
+ (let ((x-start (inferior-x-start (%window-cursor-inferior window)))
+ (y-start (inferior-y-start (%window-cursor-inferior window)))
+ (length (fix:- end start)))
+ (screen-direct-output-substring
+ (%window-saved-screen window)
+ (fix:+ (%window-saved-x-start window) x-start)
+ (fix:+ (%window-saved-y-start window) y-start)
+ string start end
+ false)
+ (string-base:direct-output-insert-substring!
+ (direct-output-line-window window y-start)
+ x-start
+ string start end)
+ (%set-inferior-x-start! (%window-cursor-inferior window)
+ (fix:+ x-start length))))))
-(define (%direct-output-insert-substring! window string start end)
- (with-instance-variables buffer-window window (string start end)
- (let ((x-start (inferior-x-start cursor-inferior))
- (y-start (inferior-y-start cursor-inferior))
- (length (fix:- end start)))
- (let ((x (fix:+ saved-x-start x-start))
- (y (fix:+ saved-y-start y-start)))
- (screen-write-substring! saved-screen x y string start end)
- (screen-write-cursor! saved-screen (fix:+ x length) y)
- (screen-flush! saved-screen))
- (line-window-direct-output-insert-substring!
- (inferior-window (car (y->inferiors window y-start)))
- x-start
- string start end)
- (%set-inferior-x-start! cursor-inferior (fix:+ x-start length)))))
\ No newline at end of file
+(define (direct-output-line-window window y)
+ (let loop ((inferiors (%window-line-inferiors window)))
+ (if (fix:< y (%inferior-y-end (car inferiors)))
+ (inferior-window (car inferiors))
+ (loop (cdr inferiors)))))
+\f
+(define (buffer-window/direct-output-insert-newline! window)
+ (if (%window-debug-trace window)
+ ((%window-debug-trace window) 'window window
+ 'direct-output-insert-newline!))
+ (without-interrupts
+ (lambda ()
+ (%group-insert-char! (%window-group window)
+ (%window-point-index window)
+ #\newline)
+ (let ((y-start
+ (fix:+ (inferior-y-start (%window-cursor-inferior window)) 1)))
+ (let ((inferior (make-inferior window line-window)))
+ (%set-inferior-x-start! inferior 0)
+ (%set-inferior-y-start! inferior y-start)
+ (%set-window-x-size! (inferior-window inferior)
+ (window-x-size window))
+ (set-cdr! (last-pair (%window-line-inferiors window)) (list inferior))
+ (string-base:direct-output-insert-newline!
+ (inferior-window inferior)))
+ (let ((inferior (%window-blank-inferior window))
+ (y-end (fix:+ y-start 1)))
+ (if (fix:< y-end (window-y-size window))
+ (begin
+ (%set-inferior-y-size! inferior
+ (fix:- (window-y-size window) y-end))
+ (%set-inferior-y-start! inferior y-end))
+ (begin
+ (%set-inferior-x-start! inferior false)
+ (%set-inferior-y-start! inferior false))))
+ (%set-inferior-x-start! (%window-cursor-inferior window) 0)
+ (%set-inferior-y-start! (%window-cursor-inferior window) y-start)
+ (screen-direct-output-move-cursor (%window-saved-screen window)
+ (%window-saved-x-start window)
+ (fix:+ (%window-saved-y-start window)
+ y-start))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.7 1989/08/14 09:22:12 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.8 1990/11/02 03:23:08 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; of that license should have been included along with this file.
;;;
-;;;; Buffer Windows: Mark <-> Coordinate Maps
+;;;; Buffer Windows: Mark <-> Coordinate Maps
(declare (usual-integrations))
\f
-(define-integrable (%window-mark->x window mark)
- (car (%window-mark->coordinates window mark)))
-
-(define-integrable (%window-mark->y window mark)
- (cdr (%window-mark->coordinates window mark)))
-
-(define (%window-point-x window)
- (with-instance-variables buffer-window window ()
- (car (%window-mark->coordinates window point))))
-
-(define (%window-point-y window)
- (with-instance-variables buffer-window window ()
- (cdr (%window-mark->coordinates window point))))
-
-(define (%window-point-coordinates window)
- (with-instance-variables buffer-window window ()
- (%window-mark->coordinates window point)))
-
-(define-integrable (%window-mark->coordinates window mark)
- (%window-index->coordinates window (mark-index mark)))
-
-(define (%window-coordinates->mark window x y)
- (with-instance-variables buffer-window window (x y)
- (let ((index (%window-coordinates->index window x y)))
- (and index (make-mark (buffer-group buffer) index)))))
-
-(define (%window-index->coordinates window index)
- (with-instance-variables buffer-window window (index)
- (let ((group (buffer-group buffer)))
- (define (search-upwards end y-end)
- (let ((start (line-start-index group end)))
- (let ((columns (group-column-length group start end 0)))
- (let ((y-start
- (fix:- y-end
- (column->y-size columns x-size truncate-lines?))))
- (if (fix:> start index)
- (search-upwards (fix:-1+ start) y-start)
- (done start columns y-start))))))
-
- (define (search-downwards start y-start)
- (let ((end (line-end-index group start)))
- (let ((columns (group-column-length group start end 0)))
- (if (fix:> index end)
- (search-downwards (fix:1+ end)
- (fix:+ y-start
- (column->y-size columns
- x-size
- truncate-lines?)))
- (done start columns y-start)))))
-
- (define-integrable (done start columns y-start)
- (let ((xy
- (column->coordinates columns
- x-size
- truncate-lines?
- (group-column-length group
- start
- index
- 0))))
- (cons (car xy) (fix:+ (cdr xy) y-start))))
-
- (let ((start (mark-index start-line-mark))
- (end (mark-index end-line-mark)))
- (cond ((fix:< index start)
- (search-upwards (fix:-1+ start)
- (inferior-y-start
- (first-line-inferior window))))
- ((fix:> index end)
- (search-downwards (fix:1+ end)
- (inferior-y-end last-line-inferior)))
- (else
- (let ((start (line-start-index group index)))
- (done start
- (group-column-length group start
- (line-end-index group index) 0)
- (inferior-y-start
- (car (index->inferiors window index)))))))))))
+(define-integrable (buffer-window/mark->x window mark)
+ (buffer-window/index->x window (mark-index mark)))
+
+(define-integrable (buffer-window/mark->y window mark)
+ (buffer-window/index->y window (mark-index mark)))
+
+(define-integrable (buffer-window/mark->coordinates window mark)
+ (buffer-window/index->coordinates window (mark-index mark)))
+
+(define-integrable (buffer-window/point-x window)
+ (buffer-window/index->x window (%window-point-index window)))
+
+(define-integrable (buffer-window/point-y window)
+ (buffer-window/index->y window (%window-point-index window)))
+
+(define-integrable (buffer-window/point-coordinates window)
+ (buffer-window/index->coordinates window (%window-point-index window)))
+
+(define (buffer-window/index->x window index)
+ (if (and (line-inferiors-valid? window)
+ (line-inferiors-contain-index? window index))
+ (with-values (lambda () (find-inferior-containing-index window index))
+ (lambda (inferior start)
+ (fix:+ (inferior-x-start inferior)
+ (string-base:index->x (inferior-window inferior)
+ (fix:- index start)))))
+ (let ((start (%window-line-start-index window index)))
+ (%window-column->x window
+ (%window-line-columns window start index)
+ (%window-column-length window start index 0)))))
+
+(define (buffer-window/index->y window index)
+ (if (and (line-inferiors-valid? window)
+ (line-inferiors-contain-index? window index))
+ (with-values (lambda () (find-inferior-containing-index window index))
+ (lambda (inferior start)
+ (fix:+ (inferior-y-start inferior)
+ (string-base:index->y (inferior-window inferior)
+ (fix:- index start)))))
+ (begin
+ (guarantee-start-mark! window)
+ (predict-y window
+ (%window-start-line-index window)
+ (%window-start-line-y window)
+ index))))
+
+(define (buffer-window/index->coordinates window index)
+ (if (and (line-inferiors-valid? window)
+ (line-inferiors-contain-index? window index))
+ (with-values (lambda () (find-inferior-containing-index window index))
+ (lambda (inferior start)
+ (let ((xy
+ (string-base:index->coordinates (inferior-window inferior)
+ (fix:- index start))))
+ (cons (fix:+ (car xy) (inferior-x-start inferior))
+ (fix:+ (cdr xy) (inferior-y-start inferior))))))
+ (begin
+ (guarantee-start-mark! window)
+ (let ((start (%window-line-start-index window index)))
+ (let ((xy
+ (%window-column->coordinates
+ window
+ (%window-line-columns window start index)
+ (%window-column-length window start index 0))))
+ (cons (car xy)
+ (fix:+ (cdr xy)
+ (predict-y window
+ (%window-start-line-index window)
+ (%window-start-line-y window)
+ start))))))))
+\f
+(define (buffer-window/coordinates->mark window x y)
+ (let ((index (buffer-window/coordinates->index window x y)))
+ (and index
+ (make-mark (%window-group window) index))))
+
+(define (buffer-window/coordinates->index window x y)
+ (with-values
+ (lambda ()
+ (if (line-inferiors-valid? window)
+ (find-inferior-containing-y window y)
+ (values false false)))
+ (lambda (inferior start)
+ (if inferior
+ (fix:+ start
+ (string-base:coordinates->index
+ (inferior-window inferior)
+ x
+ (fix:- y (inferior-y-start inferior))))
+ (begin
+ (guarantee-start-mark! window)
+ (predict-index window
+ (%window-start-line-index window)
+ (%window-start-line-y window)
+ x
+ y))))))
+
+(define (buffer-window/mark-visible? window mark)
+ ;; True iff cursor at this position would be on-screen.
+ (let ((index (mark-index mark)))
+ (if (line-inferiors-valid? window)
+ (and (line-inferiors-contain-index? window index)
+ (fix:<= (%window-start-index window) index)
+ (with-values
+ (lambda () (find-inferior-containing-index window index))
+ (lambda (inferior start)
+ (let ((limit
+ (fix:- (window-y-size window)
+ (inferior-y-start inferior))))
+ (or (fix:< (inferior-y-size inferior) limit)
+ (fix:< (string-base:index->y (inferior-window inferior)
+ (fix:- index start))
+ limit))))))
+ (begin
+ (guarantee-start-mark! window)
+ (predict-index-visible? window
+ (%window-start-line-index window)
+ (%window-start-line-y window)
+ index)))))
+\f
+(define-integrable (line-inferiors-valid? window)
+ (and (not (%window-start-changes-mark window))
+ (not (%window-start-clip-mark window))
+ (not (%window-point-moved? window))
+ (not (%window-force-redraw? window))
+ (%window-start-line-mark window)
+ (fix:= (mark-position (%window-start-line-mark window))
+ (mark-position (%window-current-start-mark window)))))
+
+(define-integrable (line-inferiors-contain-index? window index)
+ (and (fix:<= (%window-current-start-index window) index)
+ (fix:<= index (%window-current-end-index window))))
+
+(define (find-inferior-containing-index window index)
+ (let loop
+ ((inferiors (%window-line-inferiors window))
+ (start (%window-current-start-index window)))
+ (let ((start* (fix:+ start (line-inferior-length (car inferiors)))))
+ (if (fix:< index start*)
+ (values (car inferiors) start)
+ (loop (cdr inferiors) start*)))))
+
+(define (find-inferior-containing-y window y)
+ (let ((inferiors (%window-line-inferiors window)))
+ (if (fix:< y (inferior-y-start (car inferiors)))
+ (values false false)
+ (let loop
+ ((inferiors inferiors)
+ (start (%window-current-start-index window)))
+ (cond ((fix:< y (%inferior-y-end (car inferiors)))
+ (values (car inferiors) start))
+ ((null? (cdr inferiors))
+ (values false false))
+ (else
+ (loop (cdr inferiors)
+ (fix:+ start
+ (line-inferior-length (car inferiors))))))))))
\f
-(define (%window-coordinates->index window x y)
- (with-instance-variables buffer-window window (x y)
- (let ((group (buffer-group buffer)))
- (define (search-upwards start y-end)
- (and (not (group-start-index? group start))
- (let ((end (fix:-1+ start)))
- (let ((start (line-start-index group end)))
- (let ((y-start (fix:- y-end (y-delta start end))))
- (if (fix:> y-start y)
- (search-upwards start y-start)
- (done start end y-start)))))))
-
- (define (search-downwards end y-start)
- (and (not (group-end-index? group end))
- (let ((start (fix:1+ end)))
- (let ((end (line-end-index group start)))
- (let ((y-end (fix:+ y-start (y-delta start end))))
- (if (fix:< y y-end)
- (done start end y-start)
- (search-downwards end y-end)))))))
-
- (define-integrable (y-delta start end)
- (column->y-size (group-column-length group start end 0)
- x-size
- truncate-lines?))
-
- (define (done start end y-start)
- (let ((column-size (group-column-length group start end 0)))
- (if (and truncate-lines? (fix:= x (fix:-1+ x-size)))
- column-size
- (group-column->index group start end 0
- (min (coordinates->column x
- (fix:- y y-start)
- x-size)
- column-size)))))
-
- (let ((start (inferior-y-start (first-line-inferior window)))
- (end (inferior-y-end last-line-inferior)))
- (cond ((fix:< y start)
- (search-upwards (mark-index start-line-mark) start))
- ((not (fix:< y end))
- (search-downwards (mark-index end-line-mark) end))
- (else
- (y->inferiors&index window y
- (lambda (inferiors index)
- (done index
- (line-end-index group index)
- (inferior-y-start (car inferiors)))))))))))
\ No newline at end of file
+(define (predict-y window start y index)
+ ;; Assuming that the character at index START appears at coordinate
+ ;; Y, return the coordinate for the character at INDEX. START is
+ ;; assumed to be a line start.
+ (cond ((fix:= index start)
+ y)
+ ((fix:< index start)
+ (let loop ((start start) (y y))
+ (let* ((end (fix:- start 1))
+ (start (%window-line-start-index window end))
+ (columns (%window-column-length window start end 0))
+ (y (fix:- y (%window-column->y-size window columns))))
+ (if (fix:< index start)
+ (loop start y)
+ (fix:+ y (%window-line-y window columns start index))))))
+ (else
+ (let loop ((start start) (y y))
+ (let* ((end (%window-line-end-index window start))
+ (columns (%window-column-length window start end 0)))
+ (if (fix:> index end)
+ (loop (fix:+ end 1)
+ (fix:+ y (%window-column->y-size window columns)))
+ (fix:+ y (%window-line-y window columns start index))))))))
+
+(define (predict-index-visible? window start y index)
+ (and (fix:>= index start)
+ (let ((y-size (window-y-size window)))
+ (let loop ((start start) (y y))
+ (and (fix:< y y-size)
+ (let* ((end (%window-line-end-index window start))
+ (columns (%window-column-length window start end 0)))
+ (if (fix:> index end)
+ (loop (fix:+ end 1)
+ (fix:+ y (%window-column->y-size window columns)))
+ (let ((y
+ (fix:+
+ y
+ (%window-line-y window columns start index))))
+ (and (fix:<= 0 y) (fix:< y y-size))))))))))
+
+(define (predict-index window start y-start x y)
+ ;; Assumes that START is a line start.
+ (if (fix:< y y-start)
+ (let loop ((start start) (y-start y-start))
+ (and (not (%window-group-start-index? window start))
+ (let* ((end (fix:- start 1))
+ (start (%window-line-start-index window end))
+ (columns (%window-column-length window start end 0))
+ (y-start
+ (fix:- y-start (%window-column->y-size window columns))))
+ (if (fix:< y y-start)
+ (loop start y-start)
+ (%window-coordinates->index window start end columns
+ x (fix:- y y-start))))))
+ (let loop ((start start) (y-start y-start))
+ (let* ((end (%window-line-end-index window start))
+ (columns (%window-column-length window start end 0))
+ (y-end
+ (fix:+ y-start (%window-column->y-size window columns))))
+ (if (fix:>= y y-end)
+ (and (not (%window-group-end-index? window end))
+ (loop (fix:+ end 1) y-end))
+ (%window-coordinates->index window start end columns
+ x (fix:- y y-start)))))))
+\f
+(define (predict-start-line window index y)
+ (let ((start (%window-line-start-index window index)))
+ (let ((y
+ (fix:- y
+ (%window-line-y window
+ (%window-line-columns window start index)
+ start
+ index))))
+ (cond ((fix:= y 0)
+ (values start y))
+ ((fix:< y 0)
+ (let loop ((start start) (y y))
+ (let* ((end (%window-line-end-index window start))
+ (columns (%window-column-length window start end 0))
+ (y-end
+ (fix:+ y (%window-column->y-size window columns))))
+ (if (and (fix:<= y-end 0)
+ (not (%window-group-end-index? window end)))
+ (loop (fix:+ end 1) y-end)
+ (values start y)))))
+ (else
+ (let loop ((start start) (y y))
+ (if (%window-group-start-index? window start)
+ (values start 0)
+ (let* ((end (fix:- start 1))
+ (start (%window-line-start-index window end))
+ (columns (%window-column-length window start end 0))
+ (y-start
+ (fix:- y (%window-column->y-size window columns))))
+ (if (fix:<= y-start 0)
+ (values start y-start)
+ (loop start y-start))))))))))
+
+(define (predict-start-index window start y-start)
+ ;; Assumes (AND (%WINDOW-LINE-START-INDEX? WINDOW START) (<= Y-START 0))
+ (if (fix:= 0 y-start)
+ start
+ (let ((end (%window-line-end-index window start))
+ (y (fix:- 0 y-start)))
+ (let ((length (%window-column-length window start end 0)))
+ (let ((index
+ (%window-coordinates->index window start end length 0 y)))
+ (if (let ((xy
+ (%window-index->coordinates window start length index)))
+ (and (fix:= (car xy) 0)
+ (fix:= (cdr xy) y)))
+ index
+ (fix:+ index 1)))))))
+
+(define (compute-start-index inferior start)
+ (let ((y-start (inferior-y-start inferior)))
+ (if (fix:= 0 y-start)
+ start
+ (let ((window (inferior-window inferior))
+ (y (fix:- 0 y-start)))
+ (let ((index (string-base:coordinates->index window 0 y)))
+ (if (let ((xy (string-base:index->coordinates window index)))
+ (and (fix:= (car xy) 0)
+ (fix:= (cdr xy) y)))
+ (fix:+ start index)
+ (fix:+ (fix:+ start index) 1)))))))
+\f
+(define-integrable (%window-column-length window start end column)
+ (group-column-length (%window-group window) start end column))
+
+(define-integrable (%window-column->index window start end column-start column)
+ (group-column->index (%window-group window) start end column-start column))
+
+(define-integrable (%window-line-columns window start index)
+ (%window-column-length window start (%window-line-end-index window index) 0))
+
+(define-integrable (%window-line-y window columns start index)
+ (%window-column->y window
+ columns
+ (%window-column-length window start index 0)))
+
+(define-integrable (%window-column->y-size window column-size)
+ (column->y-size column-size
+ (window-x-size window)
+ (%window-truncate-lines? window)))
+
+(define-integrable (%window-column->x window column-size column)
+ (column->x column-size
+ (window-x-size window)
+ (%window-truncate-lines? window)
+ column))
+
+(define-integrable (%window-column->y window column-size column)
+ (column->y column-size
+ (window-x-size window)
+ (%window-truncate-lines? window)
+ column))
+
+(define-integrable (%window-column->coordinates window column-size column)
+ (column->coordinates column-size
+ (window-x-size window)
+ (%window-truncate-lines? window)
+ column))
+
+(define (%window-coordinates->index window start end column-length x y)
+ (%window-column->index
+ window start end 0
+ (let ((column (coordinates->column x y (window-x-size window))))
+ (if (fix:< column column-length)
+ column
+ column-length))))
+
+(define-integrable (%window-index->coordinates window start column-length
+ index)
+ (%window-column->coordinates window
+ column-length
+ (%window-column-length window start index 0)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.62 1989/08/11 11:50:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.63 1990/11/02 03:23:13 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
value
buffer-local?
initial-value
- assignment-daemons)
+ assignment-daemons
+ value-validity-test)
(unparser/set-tagged-vector-method!
%variable-tag
(vector-set! variable variable-index:buffer-local? buffer-local?)
(vector-set! variable variable-index:initial-value value)
(vector-set! variable variable-index:assignment-daemons '())
+ (vector-set! variable variable-index:value-validity-test false)
variable))
(define-integrable (%set-variable-value! variable value)
- (vector-set! variable variable-index:value value)
- unspecific)
+ (vector-set! variable variable-index:value value))
(define-integrable (make-variable-buffer-local! variable)
- (vector-set! variable variable-index:buffer-local? true)
- unspecific)
+ (vector-set! variable variable-index:buffer-local? true))
\f
+(define (define-variable-value-validity-test variable test)
+ (vector-set! variable variable-index:value-validity-test test))
+
+(define (check-variable-value-validity! variable value)
+ (if (not (variable-value-valid? variable value))
+ (error:illegal-datum value 'CHECK-VARIABLE-VALUE-VALIDITY)))
+
+(define (variable-value-valid? variable value)
+ (or (not (variable-value-validity-test variable))
+ ((variable-value-validity-test variable) value)))
+
(define (add-variable-assignment-daemon! variable daemon)
(let ((daemons (variable-assignment-daemons variable)))
(if (not (memq daemon daemons))
- (begin
- (vector-set! variable
- variable-index:assignment-daemons
- (cons daemon daemons))
- unspecific))))
+ (vector-set! variable
+ variable-index:assignment-daemons
+ (cons daemon daemons)))))
(define (invoke-variable-assignment-daemons! variable)
(for-each (lambda (daemon) (daemon variable))
(make-local-binding! variable value)
(without-interrupts
(lambda ()
+ (check-variable-value-validity! variable value)
(%set-variable-value! variable value)
(invoke-variable-assignment-daemons! variable)))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comwin.scm,v 1.138 1989/06/21 10:31:40 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comwin.scm,v 1.139 1990/11/02 03:23:19 cph Rel $
;;;
-;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-integrable (set-window-next! window window*)
(with-instance-variables combination-leaf-window window (window*)
- (set! next-window window*)
- unspecific))
+ (set! next-window window*)))
(define-integrable (window-previous window)
(with-instance-variables combination-leaf-window window ()
(define-integrable (set-window-previous! window window*)
(with-instance-variables combination-leaf-window window (window*)
- (set! previous-window window*)
- unspecific))
+ (set! previous-window window*)))
(define (link-windows! previous next)
(set-window-previous! next previous)
(set-window-next! previous next))
-\f
+
(define-class combination-window combination-leaf-window
(vertical? child))
(define-integrable (set-combination-vertical! window v)
(with-instance-variables combination-window window (v)
- (set! vertical? v)
- unspecific))
+ (set! vertical? v)))
(define-integrable (combination-child window)
(with-instance-variables combination-window window ()
(define-integrable (check-leaf-window window name)
(if (not (leaf? window))
- (error "Not a leaf window" name window)))
+ (error:illegal-datum window name)))
\f
;;;; Leaf Ordering
(define (window0 window)
(if (not (and (object? window)
(subclass? (object-class window) combination-leaf-window)))
- (error "WINDOW0: Window neither combination nor leaf" window))
+ (error:illegal-datum window 'WINDOW0))
(window-leftmost-leaf (window-root window)))
\f
(define (%window1+ leaf)
(define (window-split-horizontally! leaf #!optional n)
(check-leaf-window leaf 'WINDOW-SPLIT-HORIZONTALLY!)
- (let ((n
- (if (or (default-object? n) (not n))
- (quotient (window-x-size leaf) 2)
- n))
- (x (window-x-size leaf))
- (y (window-y-size leaf)))
- (let ((n* (- x n))
- (new (allocate-leaf! leaf false)))
- (let ((combination (window-superior leaf)))
- (inferior-start (window-inferior combination leaf)
- (lambda (x y)
- (set-inferior-start! (window-inferior combination new)
- (+ x n)
- y))))
- (if (or (< n (=> leaf :minimum-x-size))
- (< n* (=> new :minimum-x-size)))
- (begin
- (deallocate-leaf! new)
- false)
- (begin
- (=> leaf :set-x-size! n)
- (=> new :set-size! n* y)
- new)))))
+ (without-interrupts
+ (lambda ()
+ (let ((n
+ (if (or (default-object? n) (not n))
+ (quotient (window-x-size leaf) 2)
+ n))
+ (x (window-x-size leaf))
+ (y (window-y-size leaf)))
+ (let ((n* (- x n))
+ (new (allocate-leaf! leaf false)))
+ (let ((combination (window-superior leaf)))
+ (inferior-start (window-inferior combination leaf)
+ (lambda (x y)
+ (set-inferior-start! (window-inferior combination new)
+ (+ x n)
+ y))))
+ (if (or (< n (=> leaf :minimum-x-size))
+ (< n* (=> new :minimum-x-size)))
+ (begin
+ (deallocate-leaf! new)
+ false)
+ (begin
+ (=> leaf :set-x-size! n)
+ (=> new :set-size! n* y)
+ new)))))))
(define (window-split-vertically! leaf #!optional n)
(check-leaf-window leaf 'WINDOW-SPLIT-VERTICALLY!)
- (let ((n
- (if (or (default-object? n) (not n))
- (quotient (window-y-size leaf) 2)
- n))
- (x (window-x-size leaf))
- (y (window-y-size leaf)))
- (let ((n* (- y n))
- (new (allocate-leaf! leaf true)))
- (let ((combination (window-superior leaf)))
- (inferior-start (window-inferior combination leaf)
- (lambda (x y)
- (set-inferior-start! (window-inferior combination new)
- x
- (+ y n)))))
- (if (or (< n (=> leaf :minimum-y-size))
- (< n* (=> new :minimum-y-size)))
- (begin
- (deallocate-leaf! new)
- false)
- (begin
- (=> leaf :set-y-size! n)
- (=> new :set-size! x n*)
- new)))))
+ (without-interrupts
+ (lambda ()
+ (let ((n
+ (if (or (default-object? n) (not n))
+ (quotient (window-y-size leaf) 2)
+ n))
+ (x (window-x-size leaf))
+ (y (window-y-size leaf)))
+ (let ((n* (- y n))
+ (new (allocate-leaf! leaf true)))
+ (let ((combination (window-superior leaf)))
+ (inferior-start (window-inferior combination leaf)
+ (lambda (x y)
+ (set-inferior-start! (window-inferior combination new)
+ x
+ (+ y n)))))
+ (if (or (< n (=> leaf :minimum-y-size))
+ (< n* (=> new :minimum-y-size)))
+ (begin
+ (deallocate-leaf! new)
+ false)
+ (begin
+ (=> leaf :set-y-size! n)
+ (=> new :set-size! x n*)
+ new)))))))
\f
(define (allocate-leaf! leaf v)
(let ((superior (window-superior leaf)))
(define (window-delete! leaf)
(check-leaf-window leaf 'WINDOW-DELETE!)
- (let ((superior (window-superior leaf))
- (next (window-next leaf))
- (previous (window-previous leaf))
- (x-size (window-x-size leaf))
- (y-size (window-y-size leaf)))
- (if (not (combination? superior))
- (editor-error "Window has no neighbors; can't delete"))
- (unlink-leaf! leaf)
- (let ((value
- (let ((adjust-size!
- (lambda (window)
- (if (combination-vertical? superior)
- (=> window :set-y-size!
- (+ (window-y-size window) y-size))
- (=> window :set-x-size!
- (+ (window-x-size window) x-size))))))
- (cond (next
- (adjust-size! next)
- (let ((inferior (window-inferior superior next)))
- (if (combination-vertical? superior)
- (set-inferior-y-start! inferior
- (- (inferior-y-start inferior)
- y-size))
- (set-inferior-x-start! inferior
- (- (inferior-x-start inferior)
- x-size))))
- next)
- (previous
- (adjust-size! previous)
- previous)
- (else
- (error "combination with single child" superior))))))
- (maybe-delete-combination! superior)
- (if (current-window? leaf)
- (select-window value)))))
+ (without-interrupts
+ (lambda ()
+ (let ((superior (window-superior leaf))
+ (next (window-next leaf))
+ (previous (window-previous leaf))
+ (x-size (window-x-size leaf))
+ (y-size (window-y-size leaf)))
+ (if (not (combination? superior))
+ (editor-error "Window has no neighbors; can't delete"))
+ (let ((adjust-size!
+ (lambda (window)
+ (if (current-window? leaf)
+ (select-window window))
+ (unlink-leaf! leaf)
+ (if (combination-vertical? superior)
+ (=> window :set-y-size!
+ (+ (window-y-size window) y-size))
+ (=> window :set-x-size!
+ (+ (window-x-size window) x-size))))))
+ (cond (next
+ (adjust-size! next)
+ (let ((inferior (window-inferior superior next)))
+ (if (combination-vertical? superior)
+ (set-inferior-y-start!
+ inferior
+ (- (inferior-y-start inferior) y-size))
+ (set-inferior-x-start!
+ inferior
+ (- (inferior-x-start inferior) x-size)))))
+ (previous
+ (adjust-size! previous))
+ (else
+ (error "combination with single child" superior))))
+ (maybe-delete-combination! superior)))))
\f
(define (unlink-leaf! leaf)
(let ((combination (window-superior leaf))
(next (window-next leaf))
(previous (window-previous leaf)))
- (delete-inferior! combination leaf)
(=> leaf :kill!)
+ (delete-inferior! combination leaf)
(if previous
(set-window-next! previous next)
(set-combination-child! combination next))
\f
;;;; Sizing
-(define (window-grow! leaf delta
- vertical? size min-size
- set-w-size! start set-start!)
- (check-leaf-window leaf 'WINDOW-GROW!)
- (let ((leaf
- (let loop ((leaf leaf))
- (let ((combination (window-superior leaf)))
- (cond ((not (combination? combination))
- (editor-error "Can't grow this window "
- (if vertical? "vertically" "horizontally")))
- ((boolean=? vertical? (combination-vertical? combination))
- leaf)
- (else
- (loop combination)))))))
- (let ((new-size (+ (size leaf) delta))
- (combination (window-superior leaf))
- (next (window-next leaf))
- (previous (window-previous leaf)))
- (if (> new-size (size combination))
- (begin
- (set! new-size (size combination))
- (set! delta (- new-size (size leaf)))))
- (cond ((< new-size (min-size leaf))
- (window-delete! leaf))
- ((and next (>= (- (size next) delta) (min-size next)))
- (let ((inferior (window-inferior combination next)))
- (set-start! inferior (+ (start inferior) delta)))
- (set-w-size! next (- (size next) delta))
- (set-w-size! leaf new-size))
- ((and previous
- (>= (- (size previous) delta) (min-size previous)))
- (let ((inferior (window-inferior combination leaf)))
- (set-start! inferior (- (start inferior) delta)))
- (set-w-size! previous (- (size previous) delta))
- (set-w-size! leaf new-size))
- (else
- (scale-combination-inferiors! combination
- (- (size combination) new-size)
- leaf vertical? size min-size
- set-w-size! set-start!)
- ;; Scaling may have deleted all other inferiors.
- ;; If so, leaf has replaced combination.
- (set-w-size! leaf
- (if (eq? combination (window-superior leaf))
- new-size
- (size combination))))))))
+(define (window-grow! vertical? size min-size set-w-size! start set-start!
+ scale-combination-inferiors!)
+ (lambda (leaf delta)
+ (check-leaf-window leaf 'WINDOW-GROW!)
+ (without-interrupts
+ (lambda ()
+ (let ((leaf
+ (let loop ((leaf leaf))
+ (let ((combination (window-superior leaf)))
+ (if (not (combination? combination))
+ (editor-error "Can't grow this window "
+ (if vertical?
+ "vertically"
+ "horizontally")))
+ (if (boolean=? vertical? (combination-vertical? combination))
+ leaf
+ (loop combination))))))
+ (let ((new-size (+ (size leaf) delta))
+ (combination (window-superior leaf))
+ (next (window-next leaf))
+ (previous (window-previous leaf)))
+ (if (> new-size (size combination))
+ (begin
+ (set! new-size (size combination))
+ (set! delta (- new-size (size leaf)))))
+ (cond ((< new-size (min-size leaf))
+ (window-delete! leaf))
+ ((and next (>= (- (size next) delta) (min-size next)))
+ (let ((inferior (window-inferior combination next)))
+ (set-start! inferior (+ (start inferior) delta)))
+ (set-w-size! next (- (size next) delta))
+ (set-w-size! leaf new-size))
+ ((and previous
+ (>= (- (size previous) delta) (min-size previous)))
+ (let ((inferior (window-inferior combination leaf)))
+ (set-start! inferior (- (start inferior) delta)))
+ (set-w-size! previous (- (size previous) delta))
+ (set-w-size! leaf new-size))
+ (else
+ (scale-combination-inferiors! combination
+ (- (size combination) new-size)
+ leaf)
+ ;; Scaling may have deleted all other inferiors.
+ ;; If so, leaf has replaced combination.
+ (set-w-size! leaf
+ (if (eq? combination (window-superior leaf))
+ new-size
+ (size combination)))))))))))
+
+;;; (SCALE-COMBINATION-INFERIORS! COMBINATION NEW-ROOM EXCEPT)
+
+;;; Change all of the inferiors of COMBINATION (except EXCEPT) to use
+;;; NEW-ROOM's worth of space. EXCEPT, if given, should not be
+;;; changed in size, but should be moved if its neighbors change. It
+;;; is assumed that EXCEPT is given only for case where the
+;;; combination's VERTICAL? flag is the same as V.
+
+;;; General strategy:
+
+;;; If the window is growing, we can simply change the sizes of the
+;;; inferiors. However, if it is shrinking, we must be more careful
+;;; because some or all of the inferiors can be deleted. So in that
+;;; case, before any sizes are changed, we find those inferiors that
+;;; will be deleted and delete them. If we delete all of the
+;;; inferiors, then we are done: this window has also been deleted.
+;;; Otherwise, we can then perform all of the changes, knowing that no
+;;; window will grow too small.
+\f
+(define (scale-combination-inferiors! v size min-size set-w-size! set-start!)
+ (lambda (combination new-room except)
+ (let ((kernel
+ (lambda (old-room collect-deletions change-inferiors)
+ (cond ((< old-room new-room)
+ (change-inferiors))
+ ((> old-room new-room)
+ (for-each window-delete! (collect-deletions))
+ (if (not (null? (window-inferiors combination)))
+ (change-inferiors))))))
+ (child (combination-child combination))
+ (c-size (size combination)))
+ (if (not (eq? (combination-vertical? combination) v))
+ (kernel
+ c-size
+ (lambda ()
+ (let loop ((window child))
+ (let ((deletions
+ (if (window-next window)
+ (loop (window-next window))
+ '())))
+ (if (< new-room (min-size window))
+ (cons window deletions)
+ deletions))))
+ (lambda ()
+ (let loop ((window child))
+ (set-w-size! window new-room)
+ (if (window-next window)
+ (loop (window-next window))))))
+ (let ((old-room (if except (- c-size (size except)) c-size)))
+ (kernel
+ old-room
+ (lambda ()
+ (let loop
+ ((window child) (old-room old-room) (new-room new-room))
+ (cond ((eq? window except)
+ (if (window-next window)
+ (loop (window-next window) old-room new-room)
+ '()))
+ ((not (window-next window))
+ (if (< new-room (min-size window))
+ (list window)
+ '()))
+ (else
+ (let* ((old-s (size window))
+ (new-s (quotient (* old-s new-room) old-room))
+ (deletions
+ (loop (window-next window)
+ (- old-room old-s)
+ (- new-room new-s))))
+ (if (< new-s (min-size window))
+ (cons window deletions)
+ deletions))))))
+ (lambda ()
+ (let loop
+ ((window child)
+ (start 0)
+ (old-room old-room)
+ (new-room new-room))
+ (set-start! (window-inferior combination window) start)
+ (cond ((eq? window except)
+ (if (window-next window)
+ (loop (window-next window)
+ start
+ old-room
+ new-room)))
+ ((not (window-next window))
+ (set-w-size! window new-room))
+ (else
+ (let* ((old-s (size window))
+ (new-s (quotient (* old-s new-room) old-room)))
+ (set-w-size! window new-s)
+ (loop (window-next window)
+ (+ start new-s)
+ (- old-room old-s)
+ (- new-room new-s)))))))))))))
\f
-(define (window-grow-horizontally! leaf delta)
- (window-grow! leaf delta false
- window-x-size window-min-x-size
- send-window-x-size! inferior-x-start set-inferior-x-start!))
-
-(define (window-grow-vertically! leaf delta)
- (window-grow! leaf delta true
- window-y-size window-min-y-size
- send-window-y-size! inferior-y-start set-inferior-y-start!))
-
-(define (scale-combination-inferiors-x! combination x except)
- (scale-combination-inferiors! combination x except false
- window-x-size window-min-x-size
- send-window-x-size! set-inferior-x-start!))
-
-(define (scale-combination-inferiors-y! combination y except)
- (scale-combination-inferiors! combination y except true
- window-y-size window-min-y-size
- send-window-y-size! set-inferior-y-start!))
-
(define (window-min-x-size window)
(=> window :minimum-x-size))
(define (send-window-y-size! window y)
(=> window :set-y-size! y))
+(define scale-combination-inferiors-x!
+ (scale-combination-inferiors! false window-x-size window-min-x-size
+ send-window-x-size! set-inferior-x-start!))
+
+(define scale-combination-inferiors-y!
+ (scale-combination-inferiors! true window-y-size window-min-y-size
+ send-window-y-size! set-inferior-y-start!))
+
+(define window-grow-horizontally!
+ (window-grow! false window-x-size window-min-x-size send-window-x-size!
+ inferior-x-start set-inferior-x-start!
+ scale-combination-inferiors-x!))
+
+(define window-grow-vertically!
+ (window-grow! true window-y-size window-min-y-size send-window-y-size!
+ inferior-y-start set-inferior-y-start!
+ scale-combination-inferiors-y!))
+
(define-method combination-window (:minimum-x-size combination)
(=> (window-leftmost-leaf combination) :minimum-x-size))
(inferior-containing-coordinates combination x y leaf?))
(define-method combination-leaf-window (:leaf-containing-coordinates leaf x y)
- (values leaf x y))
-\f
-(define (scale-combination-inferiors! combination new-room except
- v size min-size set-w-size! set-start!)
- ;; Change all of the inferiors of COMBINATION (except EXCEPT) to
- ;; use NEW-ROOM's worth of space. EXCEPT, if given, should not be
- ;; changed in size, but should be moved if its neighbors change.
- ;; It is assumed that EXCEPT is given only for case where the
- ;; combination's VERTICAL? flag is the same as V.
-
- ;; General strategy:
- ;; If the window is growing, we can simply change the sizes of the
- ;; inferiors. However, if it is shrinking, we must be more careful
- ;; because some or all of the inferiors can be deleted. So in that
- ;; case, before any sizes are changed, we find those inferiors that
- ;; will be deleted and delete them. If we delete all of the
- ;; inferiors, then we are done: this window has also been deleted.
- ;; Otherwise, we can then perform all of the changes, knowing that
- ;; no window will grow too small.
-
- (let ((kernel
- (lambda (old-room collect-deletions change-inferiors)
- (cond ((< old-room new-room)
- (change-inferiors))
- ((> old-room new-room)
- (for-each window-delete! (collect-deletions))
- (if (not (null? (window-inferiors combination)))
- (change-inferiors))))))
- (child (combination-child combination))
- (c-size (size combination)))
- (if (not (eq? (combination-vertical? combination) v))
- (kernel
- c-size
- (lambda ()
- (let loop ((window child))
- (let ((deletions
- (if (window-next window)
- (loop (window-next window))
- '())))
- (if (< new-room (min-size window))
- (cons window deletions)
- deletions))))
- (lambda ()
- (let loop ((window child))
- (set-w-size! window new-room)
- (if (window-next window)
- (loop (window-next window))))))
- (let ((old-room (if except (- c-size (size except)) c-size)))
- (kernel
- old-room
- (lambda ()
- (let loop ((window child) (old-room old-room) (new-room new-room))
- (cond ((eq? window except)
- (if (window-next window)
- (loop (window-next window) old-room new-room)
- '()))
- ((not (window-next window))
- (if (< new-room (min-size window))
- (list window)
- '()))
- (else
- (let* ((old-s (size window))
- (new-s (quotient (* old-s new-room) old-room))
- (deletions
- (loop (window-next window)
- (- old-room old-s)
- (- new-room new-s))))
- (if (< new-s (min-size window))
- (cons window deletions)
- deletions))))))
- (lambda ()
- (let loop
- ((window child)
- (start 0)
- (old-room old-room)
- (new-room new-room))
- (set-start! (window-inferior combination window) start)
- (cond ((eq? window except)
- (if (window-next window)
- (loop (window-next window) start old-room new-room)))
- ((not (window-next window))
- (set-w-size! window new-room))
- (else
- (let* ((old-s (size window))
- (new-s (quotient (* old-s new-room) old-room)))
- (set-w-size! window new-s)
- (loop (window-next window)
- (+ start new-s)
- (- old-room old-s)
- (- new-room new-s))))))))))))
\ No newline at end of file
+ (values leaf x y))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.39 1990/06/20 23:02:09 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.40 1990/11/02 03:23:28 cph Rel $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
(and (y-or-n? "Save buffer "
(buffer-name buffer)
" (Y or N)? ")
- (begin
- (newline)
- (write-string "Filename: ")
- (->pathname
- (input-port/normal-mode (current-input-port)
- read)))))
+ (->pathname (prompt-for-expression "Filename"))))
((integer? (pathname-version pathname))
(pathname-new-version pathname 'NEWEST))
(else
(let ((entry (assq name (class-instance-transforms (object-class object)))))
(if entry
(vector-set! object (cdr entry) value)
- (error "Not a valid instance-variable name" name))))
\ No newline at end of file
+ (error "Not a valid instance-variable name" name))))
+
+;;;; Screen Trace
+
+(define trace-output '())
+
+(define (debug-tracer . args)
+ (set! trace-output (cons args trace-output))
+ unspecific)
+
+(define (screen-trace #!optional screen)
+ (let ((screen
+ (if (default-object? screen)
+ (begin
+ (if (not edwin-editor)
+ (error "no screen to trace"))
+ (editor-selected-screen edwin-editor))
+ screen)))
+ (set! trace-output '())
+ (for-each (lambda (window)
+ (set-window-debug-trace! window debug-tracer))
+ (screen-window-list screen))
+ (set-screen-debug-trace! screen debug-tracer)))
+
+(define (screen-untrace #!optional screen)
+ (let ((screen
+ (if (default-object? screen)
+ (begin
+ (if (not edwin-editor)
+ (error "no screen to trace"))
+ (editor-selected-screen edwin-editor))
+ screen)))
+ (for-each (lambda (window)
+ (set-window-debug-trace! window false))
+ (screen-window-list screen))
+ (set-screen-debug-trace! screen false)
+ (let ((result trace-output))
+ (set! trace-output '())
+ (map list->vector (reverse! result)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.14 1990/10/09 16:23:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.15 1990/11/02 03:23:33 cph Rel $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
"clscon"
"clsmac"
"comtab"
- "cterm"
"display"
"image"
"macros"
"simple"
"strpad"
"strtab"
+ "termcap"
"utils"
"winout"
"winren"
"xform"
"xterm"))
+ (sf-global "tterm" "termcap")
(for-each sf-edwin
'("argred"
"autold"
(for-each sf-class
'("comwin"
"modwin"
- "buffrm"
"edtfrm"))
(sf-edwin "grpops" "struct")
(sf-edwin "regops" "struct")
(sf-edwin "motion" "struct")
(sf-class "window" "class")
(sf-class "utlwin" "window" "class")
- (sf-class "linwin" "window" "class")
- (sf-class "bufwin" "window" "class" "struct")
- (sf-class "bufwfs" "bufwin" "window" "class" "struct")
- (sf-class "bufwiu" "bufwin" "window" "class" "struct")
- (sf-class "bufwmc" "bufwin" "window" "class" "struct"))
\ No newline at end of file
+ (sf-class "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwfs" "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwiu" "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwmc" "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "buffrm" "bufwin" "window" "class" "struct"))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/display.scm,v 1.2 1990/10/09 16:23:54 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/display.scm,v 1.3 1990/11/02 03:23:38 cph Rel $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(operation/available? false read-only true)
(operation/make-screen false read-only true)
(operation/make-input-port false read-only true)
- (operation/with-interrupt-source false read-only true)
+ (operation/with-display-grabbed false read-only true)
(operation/with-interrupts-enabled false read-only true)
(operation/with-interrupts-disabled false read-only true))
available?
make-screen
make-input-port
- with-interrupt-source
+ with-display-grabbed
with-interrupts-enabled
with-interrupts-disabled)
(let ((display-type
available?
make-screen
make-input-port
- with-interrupt-source
+ with-display-grabbed
with-interrupts-enabled
with-interrupts-disabled)))
(set! display-types (cons display-type display-types))
(define (display-type/make-input-port display-type screen)
((display-type/operation/make-input-port display-type) screen))
-(define (display-type/with-interrupt-source display-type thunk)
- ((display-type/operation/with-interrupt-source display-type) thunk))
+(define (display-type/with-display-grabbed display-type thunk)
+ ((display-type/operation/with-display-grabbed display-type) thunk))
(define (display-type/with-interrupts-enabled display-type thunk)
((display-type/operation/with-interrupts-enabled display-type) thunk))
syntax-table/system-internal)
("comwin" (edwin window combination)
class-syntax-table)
- ("cterm" (edwin console-screen)
- syntax-table/system-internal)
("curren" (edwin)
edwin-syntax-table)
("debug" (edwin debugger)
edwin-syntax-table)
("linden" (edwin lisp-indentation)
edwin-syntax-table)
- ("linwin" (edwin window)
- class-syntax-table)
("loadef" (edwin)
edwin-syntax-table)
("lspcom" (edwin)
edwin-syntax-table)
("tags" (edwin tags)
edwin-syntax-table)
+ ("termcap" (edwin console-screen)
+ syntax-table/system-internal)
("texcom" (edwin)
edwin-syntax-table)
("things" (edwin)
edwin-syntax-table)
("tparse" (edwin)
edwin-syntax-table)
+ ("tterm" (edwin console-screen)
+ syntax-table/system-internal)
("tximod" (edwin)
edwin-syntax-table)
("undo" (edwin undo)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.197 1990/10/09 16:24:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.198 1990/11/02 03:23:48 cph Exp $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
\f
(define (edit)
(if (not edwin-editor)
- (apply create-editor create-editor-args))
+ (create-editor))
(call-with-current-continuation
(lambda (continuation)
(fluid-let ((editor-abort continuation)
- (*auto-save-keystroke-count* 0))
- (within-editor edwin-editor
- (lambda ()
- (with-current-local-bindings!
- (lambda ()
- (bind-condition-handler '() internal-error-handler
- (lambda ()
- (dynamic-wind
- (lambda () (update-screens! true))
- (lambda ()
- (let ((cmdl (nearest-cmdl))
- (message (cmdl-message/null)))
- (let ((input-port (cmdl/input-port cmdl)))
- (input-port/immediate-mode input-port
- (lambda ()
- (make-cmdl cmdl
- input-port
- (cmdl/output-port cmdl)
- (lambda (cmdl)
- cmdl ;ignore
- (top-level-command-reader
- edwin-initialization)
- message)
- false
- message))))))
- (lambda () unspecific)))))))))))
+ (*auto-save-keystroke-count* 0)
+ (current-editor edwin-editor)
+ (recursive-edit-continuation false)
+ (recursive-edit-level 0))
+ (editor-grab-display edwin-editor
+ (lambda (with-editor-ungrabbed)
+ (let ((message (cmdl-message/null)))
+ (push-cmdl (lambda (cmdl)
+ cmdl ;ignore
+ (top-level-command-reader edwin-initialization)
+ message)
+ false
+ message
+ (editor-spawn-child-cmdl with-editor-ungrabbed))))))))
(if edwin-finalization (edwin-finalization))
unspecific)
-(define create-editor-args (list 'X))
+(define (editor-grab-display editor receiver)
+ (display-type/with-display-grabbed (editor-display-type editor)
+ (lambda (with-display-ungrabbed)
+ (with-current-local-bindings!
+ (lambda ()
+ (let ((enter
+ (lambda ()
+ (let ((screen (selected-screen)))
+ (screen-enter! screen)
+ (update-screen! screen true))))
+ (exit (lambda () (screen-exit! (selected-screen)))))
+ (dynamic-wind enter
+ (lambda ()
+ (receiver
+ (lambda (thunk)
+ (dynamic-wind exit
+ (lambda ()
+ (with-display-ungrabbed thunk))
+ enter))))
+ exit)))))))
+
+(define (editor-spawn-child-cmdl with-editor-ungrabbed)
+ (lambda (editor-cmdl input-port output-port driver state message spawn-child)
+ (with-editor-ungrabbed
+ (lambda ()
+ (make-cmdl editor-cmdl
+ (if (eq? input-port (cmdl/input-port editor-cmdl))
+ (cmdl/input-port (cmdl/parent editor-cmdl))
+ input-port)
+ (if (eq? output-port (cmdl/output-port editor-cmdl))
+ (cmdl/output-port (cmdl/parent editor-cmdl))
+ output-port)
+ driver
+ state
+ message
+ spawn-child)))))
+
+(define (within-editor?)
+ (not (unassigned? current-editor)))
+
(define editor-abort)
(define edwin-editor false)
+(define current-editor)
;; Set this before entering the editor to get something done after the
;; editor's dynamic environment is initialized, but before the command
;; reset and then reenter the editor.
(define edwin-finalization false)
\f
-(define (create-editor display-type-name . make-screen-args)
- (reset-editor)
- (initialize-typein!)
- (initialize-typeout!)
- (initialize-syntax-table!)
- (initialize-command-reader!)
- (set! edwin-editor
- (make-editor "Edwin"
- (name->display-type display-type-name)
- make-screen-args))
- (set! edwin-initialization
- (lambda ()
- (set! edwin-initialization false)
- (with-editor-interrupts-disabled standard-editor-initialization)))
- unspecific)
-
-(define (reset-editor)
- (without-interrupts
- (lambda ()
- (if edwin-editor
- (begin
- (for-each (lambda (screen)
- (screen-discard! screen))
- (editor-screens edwin-editor))
- (set! edwin-editor false)
- (set! *previous-popped-up-buffer* (object-hash false))
- (set! *previous-popped-up-window* (object-hash false))
- unspecific)))))
+(define create-editor-args
+ (list false))
-(define (reset-editor-windows)
- (for-each (lambda (screen)
- (send (screen-root-window screen) ':salvage!))
- (editor-screens edwin-editor)))
+(define (create-editor . args)
+ (let ((args
+ (if (null? args)
+ create-editor-args
+ (begin
+ (set! create-editor-args args)
+ args))))
+ (reset-editor)
+ (initialize-typein!)
+ (initialize-typeout!)
+ (initialize-syntax-table!)
+ (initialize-command-reader!)
+ (set! edwin-editor
+ (make-editor "Edwin"
+ (let ((name (car args)))
+ (cond (name
+ (name->display-type name))
+ ((display-type/available? console-display-type)
+ console-display-type)
+ ((display-type/available? x-display-type)
+ x-display-type)
+ (else
+ (error "can't find usable display type"))))
+ (cdr args)))
+ (set! edwin-initialization
+ (lambda ()
+ (set! edwin-initialization false)
+ (with-editor-interrupts-disabled standard-editor-initialization)))
+ unspecific))
(define (standard-editor-initialization)
(if (not init-file-loaded?)
(let ((filename (os/init-file-name)))
(if (file-exists? filename)
(load-edwin-file filename '(EDWIN) true)))
- (set! init-file-loaded? true)
- unspecific))
+ (set! init-file-loaded? true)))
(if (not (ref-variable inhibit-startup-message))
(let ((window (current-window)))
(let ((buffer (window-buffer window)))
")
\f
-;;;; Recursive Edit Levels
-
-(define (within-editor editor thunk)
- (fluid-let ((current-editor editor)
- (recursive-edit-continuation false)
- (recursive-edit-level 0))
- (dynamic-wind
- (lambda ()
- (screen-enter! (selected-screen)))
- (lambda ()
- (display-type/with-interrupt-source (editor-display-type editor)
- thunk))
- (lambda ()
- (screen-exit! (selected-screen))))))
+(define (reset-editor)
+ (without-interrupts
+ (lambda ()
+ (if edwin-editor
+ (begin
+ (for-each (lambda (screen)
+ (screen-discard! screen))
+ (editor-screens edwin-editor))
+ (set! edwin-editor false)
+ (set! init-file-loaded? false)
+ (set! *previous-popped-up-buffer* (object-hash false))
+ (set! *previous-popped-up-window* (object-hash false))
+ unspecific)))))
-(define (within-editor?)
- (not (unassigned? current-editor)))
+(define (reset-editor-windows)
+ (for-each (lambda (screen)
+ (send (screen-root-window screen) ':salvage!))
+ (editor-screens edwin-editor)))
;;; There is a problem with recursive edits and multiple screens.
;;; When you switch screens the recursive edit aborts. The problem
(define recursive-edit-continuation)
(define recursive-edit-level)
-(define current-editor)
\f
-;;;; Internal Errors
-
(define (internal-error-handler condition)
(and (not (condition/internal? condition))
(error? condition)
- (if (ref-variable debug-on-internal-error)
- (begin
- (debug-scheme-error condition)
- (message "Scheme error")
- (%editor-error))
- (exit-editor-and-signal-error condition))))
+ (cond ((ref-variable debug-on-internal-error)
+ (debug-scheme-error condition)
+ (message "Scheme error")
+ (%editor-error))
+ (debug-internal-errors?
+ (signal-error condition))
+ (else
+ (exit-editor-and-signal-error condition)))))
(define-variable debug-on-internal-error
"True means enter debugger if error is signalled while the editor is running.
This does not affect editor errors or evaluation errors."
false)
+(define debug-internal-errors?
+ false)
+
(define (exit-editor-and-signal-error condition)
(within-continuation editor-abort
(lambda ()
(signal-error condition))))
-;;;; C-g Interrupts
-
(define (^G-signal)
(let ((continuations *^G-interrupt-continuations*))
(if (not (pair? continuations))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.82 1990/10/06 00:15:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.83 1990/11/02 03:23:54 cph Rel $
;;;
;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
;;;
typein-inferior
selected-window
cursor-window
- select-time
properties))
(define (make-editor-frame root-screen main-buffer typein-buffer)
(set! typein-inferior (find-inferior inferiors typein-window))
(set! selected-window main-window)
(set! cursor-window main-window)
- (set! select-time 2)
- (set-window-select-time! main-window 1)
- (=> (window-cursor main-window) :enable!))
+ (window-cursor-enable! main-window))
(set-editor-frame-size! window x-size y-size))
window))
(define (editor-frame-update-display! window display-style)
;; Returns true if update is successfully completed (or unnecessary).
+ ;; Assumes that interrupts are disabled.
(with-instance-variables editor-frame window (display-style)
- (with-screen-in-update! screen
- (lambda ()
- (if (and (not display-style)
- (not (car redisplay-flags)))
- true
- (let ((finished?
- (update-inferiors! window screen 0 0
- 0 x-size 0 y-size
- display-style)))
- (if finished?
- (set-car! redisplay-flags false))
- finished?))))))
+ (if (and (not display-style)
+ (not (car redisplay-flags)))
+ true
+ (let ((finished?
+ (window-update-display! window screen 0 0 0 x-size 0 y-size
+ display-style)))
+ (if finished?
+ (set-car! redisplay-flags false))
+ finished?))))
(define (set-editor-frame-size! window x y)
(with-instance-variables editor-frame window (x y)
(with-instance-variables editor-frame window (window*)
(if (not (buffer-frame? window*))
(error "Attempt to select non-window" window*))
- (=> (window-cursor cursor-window) :disable!)
+ (window-cursor-disable! cursor-window)
(set! selected-window window*)
- (set-window-select-time! window* select-time)
- (set! select-time (1+ select-time))
+ (set-window-select-time! window* (increment-select-time!))
(set! cursor-window window*)
- (=> (window-cursor cursor-window) :enable!)))
+ (window-cursor-enable! window*)))
(define (editor-frame-select-cursor! window window*)
(with-instance-variables editor-frame window (window*)
(if (not (buffer-frame? window*))
(error "Attempt to select non-window" window*))
- (=> (window-cursor cursor-window) :disable!)
+ (window-cursor-disable! cursor-window)
(set! cursor-window window*)
- (=> (window-cursor cursor-window) :enable!)))
+ (window-cursor-enable! cursor-window)))
(define-method editor-frame (:button-event! editor-frame button x y)
(with-values
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.11 1990/10/09 16:24:14 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtstr.scm,v 1.12 1990/11/02 03:23:59 cph Rel $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(define-structure (editor (constructor %make-editor))
(name false read-only true)
(display-type false read-only true)
- (screens false)
+ (screens '())
(selected-screen false)
(bufferset false read-only true)
(kill-ring false read-only true)
(char-history false read-only true)
(input-port false read-only true)
- (button-event false))
+ (button-event false)
+ (select-time 1))
(define (make-editor name display-type make-screen-args)
(let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
(make-ring 10)
(make-ring 100)
(display-type/make-input-port display-type screen)
- false))))
+ false
+ 1))))
(define-integrable (current-display-type)
(editor-display-type current-editor))
(define-integrable (current-char-history)
(editor-char-history current-editor))
+
+(define (increment-select-time!)
+ (let ((time (editor-select-time current-editor)))
+ (set-editor-select-time! current-editor (1+ time))
+ time))
\f
(define-structure (button-event (conc-name button-event/))
(window false read-only true)
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.10 1990/10/09 16:24:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.11 1990/11/02 03:24:04 cph Rel $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(let ((environment (->environment '(EDWIN WINDOW))))
(load "window" environment)
(load "utlwin" environment)
- (load "linwin" environment)
(load "bufwin" environment)
(load "bufwfs" environment)
(load "bufwiu" environment)
(load "xterm" env)
((access initialize-package! env)))
(let ((env (->environment '(EDWIN CONSOLE-SCREEN))))
- (load "cterm" env)
+ (load "termcap" env)
+ (load "tterm" env)
((access initialize-package! env)))
(load "edtstr" environment)
(load "editor" environment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.20 1990/10/09 16:24:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.21 1990/11/02 03:24:09 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
editor-display-types)
(export (edwin)
display-type?
+ display-type/available?
display-type/make-input-port
display-type/make-screen
display-type/multiple-screens?
display-type/name
- display-type/with-interrupt-source
+ display-type/with-display-grabbed
display-type/with-interrupts-disabled
display-type/with-interrupts-enabled
make-display-type
(export (edwin)
initialize-screen-root-window!
screen-beep
+ screen-clear-rectangle
+ screen-direct-output-char
+ screen-direct-output-move-cursor
+ screen-direct-output-substring
screen-discard!
screen-enter!
screen-exit!
- screen-flush!
- screen-highlight?
screen-in-update?
screen-modeline-event!
+ screen-move-cursor
+ screen-needs-update?
+ screen-output-char
+ screen-output-substring
screen-root-window
+ screen-scroll-lines-down
+ screen-scroll-lines-up
screen-select-cursor!
screen-select-window!
screen-selected-window
- screen-scroll-lines-down!
- screen-scroll-lines-up!
screen-state
screen-typein-window
screen-window-list
screen-window0
- screen-write-char!
- screen-write-cursor!
- screen-write-substring!
- screen-write-substrings!
screen-x-size
screen-y-size
+ set-screen-debug-trace!
set-screen-root-window!
- subscreen-clear!
update-screen!
window-screen
- with-screen-in-update!
- with-screen-inverse-video!)
+ with-screen-in-update)
(export (edwin console-screen)
make-screen)
(export (edwin x-screen)
make-screen
- set-screen-x-size!
- set-screen-y-size!))
+ set-screen-size!))
(define-package (edwin x-screen)
(files "xterm")
update-xterm-screen-names!))
(define-package (edwin console-screen)
- (files "cterm")
+ (files "termcap" "tterm")
(parent (edwin))
(export (edwin)
console-display-type)
+ (import (runtime primitive-io)
+ channel-type=terminal?
+ terminal-get-state
+ terminal-output-baud-rate
+ terminal-raw-input
+ terminal-raw-output
+ terminal-set-state)
(import (runtime interrupt-handler)
hook/^g-interrupt)
(initialization (initialize-package!)))
(define-package (edwin window)
(files "window"
"utlwin"
- "linwin"
"bufwin"
"bufwfs"
"bufwiu"
edwin-variable$scroll-step
edwin-variable$truncate-lines
edwin-variable$truncate-partial-width-windows
+ set-window-debug-trace!
set-window-point!
set-window-start-mark!
window-buffer
window-direct-output-insert-newline!
window-direct-output-insert-substring!
window-direct-update!
- window-end-index
window-home-cursor!
window-mark->coordinates
window-mark->x
window-mark->y
window-mark-visible?
window-modeline-event!
- window-needs-redisplay?
window-override-message
window-point
window-point-coordinates
window-point-y
window-root-window
window-redraw!
- window-redraw-preserving-point!
window-scroll-y-absolute!
window-scroll-y-relative!
window-select-time
window-set-override-message!
window-setup-truncate-lines!
- window-start-index
+ window-start-mark
window-y-center)
(export (edwin screen)
editor-frame-screen
(read-class-definitions "window")
(read-class-definitions "utlwin")
(read-class-definitions "modwin")
- (read-class-definitions "linwin")
(read-class-definitions "bufwin")
(read-class-definitions "comwin")
(read-class-definitions "buffrm")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.92 1989/08/14 09:30:57 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.93 1990/11/02 03:24:19 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(string-append "Set " (variable-name-string variable) " to value")
(variable-value variable)))))
(lambda (variable value)
- (set-variable-value! (name->variable variable) value)))
+ (let ((variable (name->variable variable)))
+ (if (not (variable-value-valid? variable value))
+ (editor-error "illegal value for variable:" value))
+ (set-variable-value! variable value))))
(define-command make-local-variable
"Make a variable have a local value in the current buffer."
(string-append "Set " (variable-name-string variable) " to value")
(variable-value variable)))))
(lambda (variable value)
- (make-local-binding! (name->variable variable) value)))
+ (let ((variable (name->variable variable)))
+ (if (not (variable-value-valid? variable value))
+ (editor-error "illegal value for variable:" value))
+ (make-local-binding! variable value))))
(define-command kill-local-variable
"Make a variable use its global value in the current buffer."
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.125 1989/08/14 09:22:37 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.126 1990/11/02 03:24:25 cph Rel $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define (image-direct-output-insert-char! image char)
(vector-set! image 0 (string-append-char (vector-ref image 0) char))
- (vector-set! image 4 (fix:1+ (vector-ref image 4)))
- unspecific)
+ (vector-set! image 4 (fix:1+ (vector-ref image 4))))
(define (image-direct-output-insert-substring! image string start end)
(vector-set! image 0
(string-append-substring (vector-ref image 0)
string start end))
- (vector-set! image 4 (fix:+ (vector-ref image 4) (fix:- end start)))
- unspecific)
+ (vector-set! image 4 (fix:+ (vector-ref image 4) (fix:- end start))))
\f
(define (image-representation image)
(let ((string (image-string image))
(string-start (image-start-index image))
(result-start 0))
(cond ((null? parse)
- (substring-move-right! string string-start string-end
- result result-start))
+ (substring-move-left! string string-start string-end
+ result result-start))
((string? (car parse))
(let ((size (string-length (car parse))))
- (substring-move-right! (car parse) 0 size result result-start)
+ (substring-move-left! (car parse) 0 size result result-start)
(loop (cdr parse)
(fix:1+ string-start)
(fix:+ result-start size))))
((number? (car parse))
- (substring-move-right! string string-start (car parse)
- result result-start)
+ (substring-move-left! string string-start (car parse)
+ result result-start)
(loop (cdr parse)
(car parse)
(fix:+ result-start (fix:- (car parse) string-start))))
(else
- (error "Bad parse element" (car parse)))))
- result)))
+ (error "Bad parse element" (car parse))))))
+ result))
(define (image-index->column image index)
(let loop
(error "Bad parse element" (car parse))))))
(define (image-column->index image column)
+ ;; If COLUMN falls in the middle of a multi-column character, the
+ ;; index returned is that of the character. Thinking of the index
+ ;; as a pointer between characters, the value is the pointer to the
+ ;; left of the multi-column character. Only if COLUMN reaches
+ ;; across the character will the right-hand pointer be returned.
+ ;; Various things depend on this.
(let loop
((parse (image-parse image))
(start (image-start-index image))
(define (substring-column->index string start end start-column column
#!optional if-lose)
+ ;; If COLUMN falls in the middle of a multi-column character, the
+ ;; index returned is that of the character. Thinking of the index
+ ;; as a pointer between characters, the value is the pointer to the
+ ;; left of the multi-column character. Only if COLUMN reaches
+ ;; across the character will the right-hand pointer be returned.
+ ;; Various things depend on this.
(if (fix:zero? column)
start
(let loop ((i start) (c start-column) (left (fix:- column start-column)))
;;;; Parsing
(define (parse-substring-for-image string start end start-column receiver)
- (let loop ((start start) (column start-column) (receiver receiver))
- (let ((index
- (substring-find-next-char-in-set string start end
- char-set:not-graphic)))
- (if (not index)
- (receiver '() (fix:+ column (fix:- end start)))
- (let ((column (fix:+ column (fix:- index start))))
- (let ((representation
- (char-representation (string-ref string index) column)))
- (loop (fix:1+ index)
- (fix:+ column (string-length representation))
- (lambda (parse column-size)
- (receiver (if (fix:= index start)
- (cons representation parse)
- (cons index (cons representation parse)))
- column-size)))))))))
+ (let ((column-size))
+ (let ((parse
+ (let loop ((start start) (column start-column))
+ (let ((index
+ (substring-find-next-char-in-set string start end
+ char-set:not-graphic)))
+ (if (not index)
+ (begin
+ (set! column-size (fix:+ column (fix:- end start)))
+ '())
+ (let ((column (fix:+ column (fix:- index start))))
+ (let ((representation
+ (char-representation (string-ref string index)
+ column)))
+ (let ((parse
+ (loop (fix:1+ index)
+ (fix:+ column
+ (string-length representation)))))
+ (if (fix:= index start)
+ (cons representation parse)
+ (cons index (cons representation parse)))))))))))
+ (receiver parse column-size))))
(define char-column-length)
(define char-representation)
"\370" "\371" "\372" "\373" "\374" "\375" "\376" "\377")))
(set! char-representation
(lambda (char column)
- (if (char=? char #\Tab)
- (vector-ref tab-display-images (remainder column 8))
- (vector-ref display-images (char->ascii char)))))
+ (if (char=? char #\tab)
+ (vector-ref tab-display-images (fix:remainder column 8))
+ (vector-ref display-images (char->integer char)))))
(let ((tab-display-lengths (vector-map tab-display-images string-length))
(display-lengths (vector-map display-images string-length)))
(set! char-column-length
(lambda (char column)
- (if (char=? char #\Tab)
- (vector-ref tab-display-lengths (remainder column 8))
- (vector-ref display-lengths (char->ascii char)))))
+ (if (char=? char #\tab)
+ (vector-ref tab-display-lengths (fix:remainder column 8))
+ (vector-ref display-lengths (char->integer char)))))
unspecific))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.4 1990/10/09 16:24:36 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.5 1990/11/02 03:24:31 cph Rel $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
((#\s)
"no processes")
((#\p)
- (if (window-mark-visible? window (buffer-start buffer))
- (if (window-mark-visible? window (buffer-end buffer))
- "All" "Top")
- (if (window-mark-visible? window (buffer-end buffer))
- "Bottom"
+ (if (let ((end (buffer-end buffer)))
+ (or (window-mark-visible? window end)
+ (and (line-start? end)
+ (not (group-start? end))
+ (window-mark-visible? window (mark-1+ end)))))
+ (if (window-mark-visible? window (buffer-start buffer))
+ "All"
+ "Bottom")
+ (if (window-mark-visible? window (buffer-start buffer))
+ "Top"
(string-append
(string-pad-left
(number->string
(min
(let ((start (mark-index (buffer-start buffer))))
(integer-round
- (* 100 (- (window-start-index window) start))
+ (* 100 (- (mark-index (window-start-mark window)) start))
(- (mark-index (buffer-end buffer)) start)))
99))
2)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.34 1990/10/05 13:32:48 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.35 1990/11/02 03:24:36 cph Rel $
;;;
;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;;; Modeline Window
(declare (usual-integrations))
-
+\f
(define-class modeline-window vanilla-window ())
(define-method modeline-window (:initialize! window window*)
(usual=> window :initialize! window*)
(set! y-size 1))
-(define-method modeline-window (:update-display! window screen x-start y-start
- xl xu yl yu display-style)
+(define (modeline-window:update-display! window screen x-start y-start
+ xl xu yl yu display-style)
display-style ;ignore
(if (< yl yu)
- (let ((thunk
- (lambda ()
- (screen-write-substring!
- screen x-start y-start
- (string-pad-right (modeline-string superior) x-size #\-)
- xl xu))))
- (if (variable-local-value
- (window-buffer superior)
- (ref-variable-object mode-line-inverse-video))
- (with-screen-inverse-video! screen thunk)
- (thunk))))
+ (let ((superior (window-superior window)))
+ (screen-output-substring
+ screen x-start y-start
+ (string-pad-right (modeline-string superior)
+ (window-x-size window)
+ #\space)
+ xl xu
+ (variable-local-value
+ (window-buffer superior)
+ (ref-variable-object mode-line-inverse-video)))))
true)
+(define-method modeline-window :update-display!
+ modeline-window:update-display!)
+
(define-variable mode-line-inverse-video
"*True means use inverse video, or other suitable display mode, for the mode line."
true)
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rename.scm,v 1.4 1990/11/02 03:24:41 cph Rel $
+;;;
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Edwin Interpackage Renames
(declare (usual-integrations))
-\f
+
(let ((global (->environment '()))
(edwin (->environment '(edwin)))
(window (->environment '(edwin window))))
(e<-w 'window? 'buffer-frame?)
(e<-w 'window-x-size 'buffer-frame-x-size)
(e<-w 'window-y-size 'buffer-frame-y-size)
+ (e<-w 'window-needs-redisplay? 'buffer-frame-needs-redisplay?)
(e<-w '%set-window-buffer! 'set-window-buffer!)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.84 1990/10/09 16:24:41 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.85 1990/11/02 03:24:45 cph Rel $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(constructor make-screen
(state
operation/beep
+ operation/clear-line!
+ operation/clear-rectangle!
+ operation/clear-screen!
operation/discard!
operation/enter!
operation/exit!
- operation/finish-update!
operation/flush!
- operation/inverse-video!
operation/modeline-event!
- operation/normal-video!
+ operation/preempt-update?
operation/scroll-lines-down!
operation/scroll-lines-up!
- operation/start-update!
- operation/subscreen-clear!
- operation/wipe!
+ operation/wrap-update!
operation/write-char!
operation/write-cursor!
operation/write-substring!
y-size)))
(state false read-only true)
(operation/beep false read-only true)
+ (operation/clear-line! false read-only true)
+ (operation/clear-rectangle! false read-only true)
+ (operation/clear-screen! false read-only true)
(operation/discard! false read-only true)
(operation/enter! false read-only true)
(operation/exit! false read-only true)
- (operation/finish-update! false read-only true)
(operation/flush! false read-only true)
- (operation/inverse-video! false read-only true)
(operation/modeline-event! false read-only true)
- (operation/normal-video! false read-only true)
+ (operation/preempt-update? false read-only true)
(operation/scroll-lines-down! false read-only true)
(operation/scroll-lines-up! false read-only true)
- (operation/start-update! false read-only true)
- (operation/subscreen-clear! false read-only true)
- (operation/wipe! false read-only true)
+ (operation/wrap-update! false read-only true)
(operation/write-char! false read-only true)
(operation/write-cursor! false read-only true)
(operation/write-substring! false read-only true)
(operation/x-size false read-only true)
(operation/y-size false read-only true)
(root-window false)
+ (needs-update? false)
(in-update? false)
(x-size false)
(y-size false)
- (highlight? false))
+
+ ;; Description of actual screen contents.
+ current-matrix
+
+ ;; Description of desired screen contents.
+ new-matrix
+
+ ;; Set this variable in the debugger to force a display preemption.
+ (debug-preemption-y false)
+
+ ;; Set this variable in the debugger to trace interesting events.
+ (debug-trace false))
(define (initialize-screen-root-window! screen bufferset buffer)
(set-screen-root-window!
(make-editor-frame
screen
buffer
- (bufferset-find-or-create-buffer bufferset (make-typein-buffer-name -1)))))
-\f
-(define (with-screen-in-update! screen thunk)
- (call-with-current-continuation
- (lambda (continuation)
- (let ((old-flag)
- (new-flag true)
- (transition
- (lambda (old new)
- (if old
- (if (not new)
- (begin
- ((screen-operation/finish-update! screen) screen)
- (set-screen-in-update?! screen false)))
- (if new
- (begin
- ((screen-operation/start-update! screen) screen)
- (set-screen-in-update?! screen continuation)))))))
- (dynamic-wind (lambda ()
- (set! old-flag (screen-in-update? screen))
- (transition old-flag new-flag))
- thunk
- (lambda ()
- (set! new-flag (screen-in-update? screen))
- (transition new-flag old-flag)))))))
-
-(define (with-screen-inverse-video! screen thunk)
- (let ((old-highlight?)
- (new-highlight? true)
- (transition
- (lambda (old new)
- (if old
- (if (not new)
- (begin
- ((screen-operation/normal-video! screen) screen)
- (set-screen-highlight?! screen false)))
- (if new
- (begin
- ((screen-operation/inverse-video! screen) screen)
- (set-screen-highlight?! screen true)))))))
- (dynamic-wind (lambda ()
- (set! old-highlight? (screen-highlight? screen))
- (transition old-highlight? new-highlight?))
- thunk
- (lambda ()
- (set! new-highlight? (screen-highlight? screen))
- (transition new-highlight? old-highlight?)))))
+ (bufferset-find-or-create-buffer bufferset (make-typein-buffer-name -1))))
+ (set-screen-current-matrix! screen (make-matrix screen))
+ (set-screen-new-matrix! screen (make-matrix screen)))
\f
(define (screen-beep screen)
((screen-operation/beep screen) screen))
-(define (screen-flush! screen)
- ((screen-operation/flush! screen) screen))
-
-(define (subscreen-clear! screen xl xu yl yu)
- ((screen-operation/subscreen-clear! screen) screen xl xu yl yu))
-
-(define (screen-write-cursor! screen x y)
- ((screen-operation/write-cursor! screen) screen x y))
-
-(define (screen-write-char! screen x y char)
- ((screen-operation/write-char! screen) screen x y char))
-
-(define (screen-write-substring! screen x y string start end)
- ((screen-operation/write-substring! screen) screen x y string start end))
-
-(define (screen-write-substrings! screen x y strings bil biu bjl bju)
- (let ((write-substring! (screen-operation/write-substring! screen)))
- (clip (screen-x-size screen) x bil biu
- (lambda (bxl ail aiu)
- (clip (screen-y-size screen) y bjl bju
- (lambda (byl ajl aju)
- (let loop ((y byl) (j ajl))
- (if (fix:< j aju)
- (begin
- (write-substring! screen bxl y
- (vector-ref strings j) ail aiu)
- (loop (fix:1+ y) (fix:1+ j)))))))))))
-
-(define (clip axu x bil biu receiver)
- (let ((ail (fix:- bil x)))
- (if (fix:< ail biu)
- (let ((aiu (fix:+ ail axu)))
- (cond ((not (fix:positive? x))
- (receiver 0 ail (if (fix:< aiu biu) aiu biu)))
- ((fix:< x axu)
- (receiver x bil (if (fix:< aiu biu) aiu biu))))))))
-
-(define (screen-scroll-lines-down! screen xl xu yl yu amount)
- ((screen-operation/scroll-lines-down! screen) screen xl xu yl yu amount))
-
-(define (screen-scroll-lines-up! screen xl xu yl yu amount)
- ((screen-operation/scroll-lines-up! screen) screen xl xu yl yu amount))
-
(define (screen-enter! screen)
((screen-operation/enter! screen) screen)
(screen-modeline-event! screen
(define (screen-modeline-event! screen window type)
((screen-operation/modeline-event! screen) screen window type))
-\f
+
(define-integrable (screen-selected-window screen)
(editor-frame-selected-window (screen-root-window screen)))
(editor-frame-screen (window-root-window window)))
(define (update-screen! screen display-style)
- (if display-style ((screen-operation/wipe! screen) screen))
- (editor-frame-update-display! (screen-root-window screen) display-style))
\ No newline at end of file
+ (if display-style (screen-force-update screen))
+ (with-screen-in-update screen display-style
+ (lambda ()
+ (editor-frame-update-display! (screen-root-window screen)
+ display-style))))
+\f
+;;; Interface from update optimizer to terminal:
+
+(define-integrable (terminal-scroll-lines-down screen xl xu yl yu amount)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'scroll-lines-down
+ xl xu yl yu amount))
+ ((screen-operation/scroll-lines-down! screen) screen xl xu yl yu amount))
+
+(define-integrable (terminal-scroll-lines-up screen xl xu yl yu amount)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'scroll-lines-up
+ xl xu yl yu amount))
+ ((screen-operation/scroll-lines-up! screen) screen xl xu yl yu amount))
+
+(define-integrable (terminal-flush screen)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'flush))
+ ((screen-operation/flush! screen) screen))
+
+(define-integrable (terminal-move-cursor screen x y)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'move-cursor x y))
+ ((screen-operation/write-cursor! screen) screen x y))
+
+(define-integrable (terminal-preempt-update? screen y)
+ ((screen-operation/preempt-update? screen) screen y))
+
+(define-integrable (terminal-clear-screen screen)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'clear-screen))
+ ((screen-operation/clear-screen! screen) screen))
+
+(define-integrable (terminal-clear-line screen x y first-unused-x)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'clear-line
+ x y first-unused-x))
+ ((screen-operation/clear-line! screen) screen x y first-unused-x))
+
+(define-integrable (terminal-output-char screen x y char highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'output-char
+ x y char highlight))
+ ((screen-operation/write-char! screen) screen x y char highlight))
+
+(define-integrable (terminal-output-substring screen x y string start end
+ highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'terminal screen 'output-substring
+ x y (string-copy string) start end
+ highlight))
+ ((screen-operation/write-substring! screen) screen x y string start end
+ highlight))
+\f
+;;;; Update Optimization
+
+(define-structure (matrix (constructor %make-matrix ()))
+ ;; Vector of line contents.
+ ;; (string-ref (vector-ref (matrix-contents m) y) x) is the
+ ;; character at position X, Y.
+ contents
+
+ ;; Vector of line highlights.
+ ;; (boolean-vector-ref (vector-ref (matrix-highlight m) y) x) is the
+ ;; highlight at position X, Y.
+ highlight
+
+ ;; Boolean-vector indicating, for each line, whether its contents
+ ;; mean anything.
+ enable
+
+ ;; Cursor position.
+ cursor-x
+ cursor-y)
+
+(define (make-matrix screen)
+ (let ((matrix (%make-matrix))
+ (x-size (screen-x-size screen))
+ (y-size (screen-y-size screen)))
+ (let ((contents (make-vector y-size))
+ (highlight (make-vector y-size))
+ (enable (make-boolean-vector y-size)))
+ (do ((i 0 (fix:1+ i)))
+ ((fix:= i y-size))
+ (vector-set! contents i (make-string x-size))
+ (vector-set! highlight i (make-boolean-vector x-size)))
+ (boolean-vector-fill! enable false)
+ (set-matrix-contents! matrix contents)
+ (set-matrix-highlight! matrix highlight)
+ (set-matrix-enable! matrix enable))
+ (set-matrix-cursor-x! matrix false)
+ (set-matrix-cursor-y! matrix false)
+ matrix))
+
+(define (set-screen-size! screen x-size y-size)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'set-size! x-size y-size))
+ (without-interrupts
+ (lambda ()
+ (set-screen-x-size! screen x-size)
+ (set-screen-y-size! screen y-size)
+ (set-screen-current-matrix! screen (make-matrix screen))
+ (set-screen-new-matrix! screen (make-matrix screen))
+ (send (screen-root-window screen) ':set-size! x-size y-size))))
+
+(define (screen-move-cursor screen x y)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'move-cursor x y))
+ (let ((new-matrix (screen-new-matrix screen)))
+ (set-matrix-cursor-x! new-matrix x)
+ (set-matrix-cursor-y! new-matrix y)))
+
+(define (screen-direct-output-move-cursor screen x y)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'direct-output-move-cursor
+ x y))
+ (terminal-move-cursor screen x y)
+ (terminal-flush screen)
+ (let ((current-matrix (screen-current-matrix screen))
+ (new-matrix (screen-new-matrix screen)))
+ (set-matrix-cursor-x! current-matrix x)
+ (set-matrix-cursor-y! current-matrix y)
+ (set-matrix-cursor-x! new-matrix x)
+ (set-matrix-cursor-y! new-matrix y)))
+\f
+(define (screen-output-char screen x y char highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'output-char
+ x y char highlight))
+ (let ((new-matrix (screen-new-matrix screen)))
+ (if (not (boolean-vector-ref (matrix-enable new-matrix) y))
+ (begin
+ (boolean-vector-set! (matrix-enable new-matrix) y true)
+ (set-screen-needs-update?! screen true)
+ (guarantee-display-line screen y)))
+ (string-set! (vector-ref (matrix-contents new-matrix) y) x char)
+ (boolean-vector-set! (vector-ref (matrix-highlight new-matrix) y)
+ x
+ highlight)))
+
+(define (screen-direct-output-char screen x y char highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'direct-output-char
+ x y char highlight))
+ (let ((cursor-x (fix:1+ x))
+ (current-matrix (screen-current-matrix screen)))
+ (terminal-output-char screen x y char highlight)
+ (terminal-move-cursor screen cursor-x y)
+ (terminal-flush screen)
+ (string-set! (vector-ref (matrix-contents current-matrix) y) x char)
+ (boolean-vector-set! (vector-ref (matrix-highlight current-matrix) y)
+ x
+ highlight)
+ (set-matrix-cursor-x! current-matrix cursor-x)
+ (set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
+
+(define (screen-output-substring screen x y string start end highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'output-substring
+ x y (string-copy string) start end
+ highlight))
+ (let ((new-matrix (screen-new-matrix screen)))
+ (if (not (boolean-vector-ref (matrix-enable new-matrix) y))
+ (begin
+ (boolean-vector-set! (matrix-enable new-matrix) y true)
+ (set-screen-needs-update?! screen true)
+ (guarantee-display-line screen y)))
+ (substring-move-left! string start end
+ (vector-ref (matrix-contents new-matrix) y) x)
+ (boolean-subvector-fill! (vector-ref (matrix-highlight new-matrix) y)
+ x (fix:+ x (fix:- end start)) highlight)))
+
+(define (screen-direct-output-substring screen x y string start end highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'direct-output-substring
+ x y (string-copy string) start end
+ highlight))
+ (let ((cursor-x (fix:+ x (fix:- end start)))
+ (current-matrix (screen-current-matrix screen)))
+ (terminal-output-substring screen x y string start end highlight)
+ (terminal-move-cursor screen cursor-x y)
+ (terminal-flush screen)
+ (substring-move-left! string start end
+ (vector-ref (matrix-contents current-matrix) y) x)
+ (boolean-subvector-fill! (vector-ref (matrix-highlight current-matrix) y)
+ x cursor-x highlight)
+ (set-matrix-cursor-x! current-matrix cursor-x)
+ (set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
+
+(define (guarantee-display-line screen y)
+ (let ((current-matrix (screen-current-matrix screen))
+ (new-matrix (screen-new-matrix screen)))
+ (if (boolean-vector-ref (matrix-enable current-matrix) y)
+ (begin
+ (string-move! (vector-ref (matrix-contents current-matrix) y)
+ (vector-ref (matrix-contents new-matrix) y))
+ (boolean-vector-move!
+ (vector-ref (matrix-highlight current-matrix) y)
+ (vector-ref (matrix-highlight new-matrix) y)))
+ (begin
+ (string-fill! (vector-ref (matrix-contents new-matrix) y) #\space)
+ (boolean-vector-fill! (vector-ref (matrix-highlight new-matrix) y)
+ false)))))
+\f
+(define (screen-clear-rectangle screen xl xu yl yu highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'clear-rectangle
+ xl xu yl yu highlight))
+ (let ((current-matrix (screen-current-matrix screen))
+ (new-matrix (screen-new-matrix screen)))
+ (let ((current-contents (matrix-contents current-matrix))
+ (current-highlight (matrix-highlight current-matrix))
+ (current-enable (matrix-enable current-matrix))
+ (new-contents (matrix-contents new-matrix))
+ (new-highlight (matrix-highlight new-matrix))
+ (new-enable (matrix-enable new-matrix)))
+ (if (and (fix:= xl 0) (fix:= xu (screen-x-size screen)))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (string-fill! (vector-ref new-contents y) #\space)
+ (boolean-vector-fill! (vector-ref new-highlight y) highlight)
+ (boolean-vector-set! new-enable y true))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (let ((nl (vector-ref new-contents y))
+ (nh (vector-ref new-highlight y)))
+ (if (boolean-vector-ref new-enable y)
+ (begin
+ (substring-fill! nl xl xu #\space)
+ (boolean-subvector-fill! nh xl xu highlight))
+ (begin
+ (boolean-vector-set! new-enable y true)
+ (set-screen-needs-update?! screen true)
+ (if (boolean-vector-ref current-enable y)
+ (begin
+ (string-move! (vector-ref current-contents y) nl)
+ (boolean-vector-move!
+ (vector-ref current-highlight y)
+ nh)
+ (substring-fill! nl xl xu #\space)
+ (boolean-subvector-fill! nh xl xu highlight))
+ (begin
+ (string-fill! nl #\space)
+ (boolean-vector-fill! nh false)
+ (if highlight
+ (boolean-subvector-fill! nh xl xu
+ highlight))))))))))))
+
+(define (screen-force-update screen)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'force-update))
+ (let ((y-size (screen-y-size screen))
+ (current-matrix (screen-current-matrix screen))
+ (new-matrix (screen-new-matrix screen)))
+ (terminal-clear-screen screen)
+ (let ((current-contents (matrix-contents current-matrix))
+ (current-highlight (matrix-highlight current-matrix))
+ (current-enable (matrix-enable current-matrix))
+ (new-contents (matrix-contents new-matrix))
+ (new-highlight (matrix-highlight new-matrix))
+ (new-enable (matrix-enable new-matrix)))
+ (do ((y 0 (fix:1+ y)))
+ ((fix:= y y-size))
+ (if (boolean-vector-ref current-enable y)
+ (begin
+ (boolean-vector-set! current-enable y false)
+ (if (not (boolean-vector-ref new-enable y))
+ (begin
+ (string-move! (vector-ref current-contents y)
+ (vector-ref new-contents y))
+ (boolean-vector-move! (vector-ref current-highlight y)
+ (vector-ref new-highlight y))))))
+ (string-fill! (vector-ref current-contents y) #\space)
+ (boolean-vector-fill! (vector-ref current-highlight y) false))
+ (boolean-vector-fill! current-enable true)))
+ (set-screen-needs-update?! screen true))
+\f
+(define (screen-scroll-lines-down screen xl xu yl yu amount)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'scroll-lines-down
+ xl xu yl yu amount))
+ (let ((current-matrix (screen-current-matrix screen)))
+ (and (boolean-subvector-all-elements? (matrix-enable current-matrix)
+ yl yu true)
+ (not (screen-needs-update? screen))
+ (let ((scrolled?
+ (terminal-scroll-lines-down screen xl xu yl yu amount)))
+ (and scrolled?
+ (begin
+ (let ((contents (matrix-contents current-matrix))
+ (highlight (matrix-highlight current-matrix)))
+ (do ((y (fix:-1+ (fix:- yu amount)) (fix:-1+ y))
+ (y* (fix:-1+ yu) (fix:-1+ y*)))
+ ((fix:< y yl))
+ (substring-move-left! (vector-ref contents y) xl xu
+ (vector-ref contents y*) xl)
+ (boolean-subvector-move-left!
+ (vector-ref highlight y) xl xu
+ (vector-ref highlight y*) xl)))
+ (if (eq? scrolled? 'CLEARED)
+ (matrix-clear-rectangle current-matrix
+ xl xu yl (fix:+ yl amount)
+ false))
+ scrolled?))))))
+
+(define (screen-scroll-lines-up screen xl xu yl yu amount)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'scroll-lines-up
+ xl xu yl yu amount))
+ (let ((current-matrix (screen-current-matrix screen)))
+ (and (boolean-subvector-all-elements? (matrix-enable current-matrix)
+ yl yu true)
+ (not (screen-needs-update? screen))
+ (let ((scrolled?
+ (terminal-scroll-lines-up screen xl xu yl yu amount)))
+ (and scrolled?
+ (begin
+ (let ((contents (matrix-contents current-matrix))
+ (highlight (matrix-highlight current-matrix)))
+ (do ((y yl (fix:1+ y))
+ (y* (fix:+ yl amount) (fix:1+ y*)))
+ ((fix:= y* yu))
+ (substring-move-left! (vector-ref contents y*) xl xu
+ (vector-ref contents y) xl)
+ (boolean-subvector-move-left!
+ (vector-ref highlight y*) xl xu
+ (vector-ref highlight y) xl)))
+ (if (eq? scrolled? 'CLEARED)
+ (matrix-clear-rectangle current-matrix
+ xl xu (fix:- yu amount) yu
+ false))
+ scrolled?))))))
+
+(define (matrix-clear-rectangle matrix xl xu yl yu hl)
+ (let ((contents (matrix-contents matrix))
+ (highlight (matrix-highlight matrix)))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (substring-fill! (vector-ref contents y) xl xu #\space)
+ (boolean-subvector-fill! (vector-ref highlight y) xl xu hl))))
+\f
+(define (with-screen-in-update screen display-style thunk)
+ (without-interrupts
+ (lambda ()
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((old-flag))
+ (dynamic-wind (lambda ()
+ (set! old-flag (screen-in-update? screen))
+ (set-screen-in-update?! screen
+ (or old-flag continuation)))
+ (lambda ()
+ ((screen-operation/wrap-update! screen)
+ screen
+ (lambda ()
+ (and (thunk)
+ (screen-update screen display-style)))))
+ (lambda ()
+ (set-screen-in-update?! screen old-flag)
+ (set! old-flag)
+ unspecific))))))))
+
+(define (screen-update screen force?)
+ ;; Update the actual terminal screen based on the data in `new-matrix'.
+ ;; Value is #F if redisplay stopped due to pending input.
+ ;; FORCE? true means do not stop for pending input.
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'update force?))
+ (let ((current-matrix (screen-current-matrix screen))
+ (new-matrix (screen-new-matrix screen))
+ (y-size (screen-y-size screen)))
+ (let ((enable (matrix-enable new-matrix)))
+ (let loop ((y 0))
+ (cond ((fix:= y y-size)
+ (let ((x (matrix-cursor-x new-matrix))
+ (y (matrix-cursor-y new-matrix)))
+ (terminal-move-cursor screen x y)
+ (set-matrix-cursor-x! current-matrix x)
+ (set-matrix-cursor-y! current-matrix y))
+ (set-screen-needs-update?! screen false)
+ true)
+ ((and (terminal-preempt-update? screen y)
+ ;; `terminal-preempt-update?' has side-effects,
+ ;; and it must be run regardless of `force?'.
+ (not force?)
+ (or (keyboard-active? 0)
+ (eq? (screen-debug-preemption-y screen) y)))
+ (terminal-move-cursor screen
+ (matrix-cursor-x current-matrix)
+ (matrix-cursor-y current-matrix))
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen
+ 'update-preemption y))
+ false)
+ (else
+ (if (boolean-vector-ref enable y)
+ (update-line screen y))
+ (loop (fix:1+ y))))))))
+\f
+(define (update-line screen y)
+ (let ((current-matrix (screen-current-matrix screen))
+ (new-matrix (screen-new-matrix screen))
+ (x-size (screen-x-size screen)))
+ (let ((current-contents (vector-ref (matrix-contents current-matrix) y))
+ (current-highlight (vector-ref (matrix-highlight current-matrix) y))
+ (new-contents (vector-ref (matrix-contents new-matrix) y))
+ (new-highlight (vector-ref (matrix-highlight new-matrix) y)))
+ (cond ((not (and (boolean-vector-ref (matrix-enable current-matrix) y)
+ (boolean-vector=? current-highlight new-highlight)))
+ (update-line-ignore-current screen y
+ new-contents new-highlight x-size))
+ ((string=? current-contents new-contents)
+ unspecific)
+ ((boolean-vector-all-elements? new-highlight false)
+ (update-line-no-highlight screen y current-contents new-contents))
+ (else
+ (update-line-ignore-current screen y
+ new-contents new-highlight x-size)))
+ ;; Update current-matrix to contain the new line.
+ (vector-set! (matrix-contents current-matrix) y new-contents)
+ (vector-set! (matrix-highlight current-matrix) y new-highlight)
+ (boolean-vector-set! (matrix-enable current-matrix) y true)
+ ;; Move the old line to new-matrix so that it can be reused.
+ (vector-set! (matrix-contents new-matrix) y current-contents)
+ (vector-set! (matrix-highlight new-matrix) y current-highlight)
+ (boolean-vector-set! (matrix-enable new-matrix) y false))))
+
+(define (update-line-no-highlight screen y oline nline)
+ (let ((x-size (screen-x-size screen)))
+ (let ((olen (substring-non-space-end oline 0 x-size))
+ (nlen (substring-non-space-end nline 0 x-size)))
+ (let ((len (fix:min olen nlen)))
+ (let loop ((x 0))
+ (let ((x
+ (fix:+ x (substring-match-forward oline x len nline x len))))
+ (if (fix:= x len)
+ (if (fix:< x nlen)
+ (terminal-output-substring screen x y
+ nline x nlen false))
+ (let find-match ((x* (fix:1+ x)))
+ (cond ((fix:= x* len)
+ (if (fix:< x nlen)
+ (terminal-output-substring screen x y
+ nline x nlen false)))
+ ((fix:= (vector-8b-ref oline x*)
+ (vector-8b-ref nline x*))
+ (let ((n
+ (substring-match-forward oline x* len
+ nline x* len)))
+ ;; Ignore matches of 4 characters or less. The
+ ;; overhead of moving the cursor and drawing
+ ;; the characters is too much except for very
+ ;; slow terminals.
+ (if (fix:< n 5)
+ (find-match (fix:+ x* n))
+ (begin
+ (terminal-output-substring screen x y
+ nline x x* false)
+ (loop (fix:+ x* n))))))
+ (else
+ (find-match (fix:1+ x*)))))))))
+ (if (fix:< nlen olen)
+ (terminal-clear-line screen nlen y olen)))))
+\f
+(define (update-line-ignore-current screen y nline highlight x-size)
+ (cond ((not (boolean-subvector-uniform? highlight 0 x-size))
+ (let loop ((x 0))
+ (let ((hl (boolean-vector-ref highlight x)))
+ (let ((x*
+ (boolean-subvector-find-next highlight (fix:1+ x) x-size
+ (not hl))))
+ (if x*
+ (begin
+ (terminal-output-substring screen x y nline x x* hl)
+ (loop x*))
+ (terminal-output-substring screen x y nline x x-size
+ hl))))))
+ ((boolean-vector-ref highlight 0)
+ (terminal-output-substring screen 0 y nline 0 x-size true))
+ (else
+ (let ((xe (substring-non-space-end nline 0 x-size)))
+ (if (fix:< 0 xe)
+ (terminal-output-substring screen 0 y nline 0 xe false))
+ (if (fix:< xe x-size)
+ (terminal-clear-line screen xe y x-size))))))
+\f
+(define-integrable (fix:min x y) (if (fix:< x y) x y))
+(define-integrable (fix:max x y) (if (fix:> x y) x y))
+
+(define (substring-non-space-end string start end)
+ (let ((index
+ (substring-find-previous-char-in-set string start end
+ char-set/not-space)))
+ (if index
+ (fix:1+ index)
+ start)))
+
+(define-integrable (substring-blank? string start end)
+ (not (substring-find-next-char-in-set string start end char-set/not-space)))
+
+(define char-set/not-space
+ (char-set-invert (char-set #\space)))
+
+(define (string-move! x y)
+ (substring-move-left! x 0 (string-length x) y 0))
+
+(define-integrable (boolean-vector-ref vector index)
+ (fix:= (char->integer #\t) (vector-8b-ref vector index)))
+
+(define-integrable (boolean-vector-set! vector index value)
+ (vector-8b-set! vector index (boolean->ascii value)))
+
+(define (boolean-vector-all-elements? vector value)
+ (boolean-subvector-all-elements? vector 0 (boolean-vector-length vector)
+ value))
+
+(define (boolean-subvector-all-elements? vector start end value)
+ (if (vector-8b-find-next-char vector start end (boolean->ascii (not value)))
+ false
+ true))
+
+(define (boolean-subvector-uniform? vector start end)
+ (if (and (fix:< start end)
+ (vector-8b-find-next-char
+ vector start end
+ (boolean->ascii (not (boolean-vector-ref vector start)))))
+ false
+ true))
+
+(define-integrable (boolean-subvector-find-next vector start end value)
+ (vector-8b-find-next-char vector start end (boolean->ascii value)))
+
+(define-integrable make-boolean-vector string-allocate)
+(define-integrable boolean-vector-length string-length)
+(define-integrable boolean-vector=? string=?)
+(define-integrable boolean-subvector-move-right! substring-move-right!)
+(define-integrable boolean-subvector-move-left! substring-move-left!)
+(define-integrable boolean-vector-move! string-move!)
+(define-integrable boolean-vector-copy string-copy)
+
+(define-integrable (boolean-subvector-fill! vector start end value)
+ (vector-8b-fill! vector start end (boolean->ascii value)))
+
+(define (boolean-vector-fill! vector value)
+ (boolean-subvector-fill! vector 0 (boolean-vector-length vector) value))
+
+(define-integrable (boolean->ascii boolean)
+ (if boolean (char->integer #\t) (char->integer #\f)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.54 1989/08/14 09:23:08 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.55 1990/11/02 03:24:51 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(define-class string-base vanilla-window
(image representation truncate-lines?))
-(define-method string-base (:update-display! window screen x-start y-start
- xl xu yl yu display-style)
- window display-style ;ignore
- (cond ((pair? representation)
- (cond ((not (cdr representation))
- ;; disable clipping.
- (subscreen-clear! screen
- x-start (fix:+ x-start xu)
- y-start (fix:+ y-start yu))
-#|
- (subscreen-clear! screen
- (fix:+ x-start xl) (fix:+ x-start xu)
- (fix:+ y-start yl) (fix:+ y-start yu))
-|#
- )
- ((fix:< yl yu)
- (let ((start (cdr representation))
- (end (string-length (car representation)))
- (ayu (fix:+ y-start yu)))
- ;; disable clipping.
- (if (not (fix:zero? start))
- (subscreen-clear! screen
- x-start (fix:+ x-start start)
- y-start ayu))
- (screen-write-substring! screen
- (fix:+ x-start start) y-start
- (car representation)
- start end)
- (if (fix:< end x-size)
- (subscreen-clear! screen
- (fix:+ x-start end)
- (fix:+ x-start x-size)
- y-start
- ayu))
-#|
- (if (not (fix:zero? start))
- (clip-window-region-1 xl xu start
- (lambda (xl xu)
- (subscreen-clear! screen
- (fix:+ x-start xl)
- (fix:+ x-start xu)
- ayl
- ayu))))
- (clip-window-region-1 (fix:- xl start)
- (fix:- xu start)
- (fix:- end start)
- (lambda (xl xu)
- (let ((xl* (fix:+ xl start)))
- (screen-write-substring! screen
- (fix:+ x-start xl*) ayl
- (car representation)
- xl* (fix:+ xu start)))))
- (clip-window-region-1 (fix:- xl end)
- (fix:- xu end)
- (fix:- x-size end)
- (lambda (xl xu)
- (let ((x-start (fix:+ x-start end)))
- (subscreen-clear! screen
- (fix:+ x-start xl) (fix:+ x-start xu)
- ayl ayu))))
-|#
- ))))
- (else
- (screen-write-substrings! screen (fix:+ x-start xl) (fix:+ y-start yl)
- representation xl xu yl yu)))
+(define-integrable (string-base:representation window)
+ (with-instance-variables string-base window () representation))
+
+(define (string-base:update-display! window screen x-start y-start
+ xl xu yl yu display-style)
+ display-style ;ignore
+ (let ((representation (string-base:representation window)))
+ (cond ((false? representation)
+ (screen-clear-rectangle screen
+ x-start (fix:+ x-start xu)
+ y-start (fix:+ y-start yu)
+ false))
+ ((string? representation)
+ (screen-output-substring screen x-start y-start
+ representation
+ 0 (string-length representation) false))
+ (else
+ (clip (screen-x-size screen) (fix:+ x-start xl) xl xu
+ (lambda (x il iu)
+ (clip (screen-y-size screen) (fix:+ y-start yl) yl yu
+ (lambda (y jl ju)
+ (let loop ((y y) (j jl))
+ (if (fix:< j ju)
+ (begin
+ (screen-output-substring screen x y
+ (vector-ref representation
+ j)
+ il iu false)
+ (loop (fix:1+ y) (fix:1+ j))))))))))))
true)
+
+(define (clip axu x bil biu receiver)
+ (let ((ail (fix:- bil x)))
+ (if (fix:< ail biu)
+ (let ((aiu (fix:+ ail axu)))
+ (cond ((fix:<= x 0)
+ (receiver 0 ail (if (fix:< aiu biu) aiu biu)))
+ ((fix:< x axu)
+ (receiver x bil (if (fix:< aiu biu) aiu biu))))))))
+
+(define-method string-base :update-display!
+ string-base:update-display!)
\f
(define (string-base:set-size-given-x! window x *truncate-lines?)
(with-instance-variables string-base window (x *truncate-lines?)
(define (string-base:coordinates->index window x y)
(with-instance-variables string-base window (x y)
(image-column->index image
- (let ((column-size (image-column-size image)))
- (if (and truncate-lines? (fix:= x (fix:-1+ x-size)))
- column-size
- (min (coordinates->column x y x-size)
- column-size))))))
+ (let ((column (coordinates->column x y x-size))
+ (size (image-column-size image)))
+ (if (fix:< column size)
+ column
+ size)))))
\f
(define (column->x-size column-size y-size truncate-lines?)
;; Assume Y-SIZE > 0.
(if truncate-lines?
column-size
(let ((qr (integer-divide column-size y-size)))
- (if (fix:zero? (integer-divide-remainder qr))
+ (if (fix:= (integer-divide-remainder qr) 0)
(integer-divide-quotient qr)
(fix:1+ (integer-divide-quotient qr))))))
(define (column->y-size column-size x-size truncate-lines?)
;; Assume X-SIZE > 1.
- (if (or truncate-lines? (fix:zero? column-size))
+ (if (or truncate-lines? (fix:< column-size x-size))
1
(let ((qr (integer-divide column-size (fix:-1+ x-size))))
- (if (fix:zero? (integer-divide-remainder qr))
+ (if (fix:= (integer-divide-remainder qr) 0)
(integer-divide-quotient qr)
(fix:1+ (integer-divide-quotient qr))))))
(cons -1+x-size 0))
(else
(let ((qr (integer-divide column -1+x-size)))
- (if (and (fix:zero? (integer-divide-remainder qr))
+ (if (and (fix:= (integer-divide-remainder qr) 0)
(fix:= column column-size))
(cons -1+x-size
(fix:-1+ (integer-divide-quotient qr)))
-1+x-size)
(else
(let ((r (remainder column -1+x-size)))
- (if (and (fix:zero? r) (fix:= column column-size))
+ (if (and (fix:= r 0) (fix:= column column-size))
-1+x-size
r))))))
(define (column->y column-size x-size truncate-lines? column)
- (if truncate-lines?
+ (if (or truncate-lines? (fix:< column (fix:-1+ x-size)))
0
- (let ((-1+x-size (fix:-1+ x-size)))
- (if (fix:< column -1+x-size)
- 0
- (let ((qr (integer-divide column -1+x-size)))
- (if (and (fix:zero? (integer-divide-remainder qr))
- (fix:= column column-size))
- (fix:-1+ (integer-divide-quotient qr))
- (integer-divide-quotient qr)))))))
+ (let ((qr (integer-divide column (fix:-1+ x-size))))
+ (if (and (fix:= (integer-divide-remainder qr) 0)
+ (fix:= column column-size))
+ (fix:-1+ (integer-divide-quotient qr))
+ (integer-divide-quotient qr)))))
(define-integrable (coordinates->column x y x-size)
(fix:+ x (fix:* y (fix:-1+ x-size))))
\f
(define (string-base:direct-output-insert-char! window x char)
(with-instance-variables string-base window (x char)
- (if (pair? representation)
- (begin
- (set-car! representation
- (string-append-char (car representation) char))
- (if (and (not (cdr representation))
- (not (char=? char #\Space)))
- (set-cdr! representation x)))
- (string-set! (vector-ref representation (fix:-1+ y-size)) x char))))
+ (image-direct-output-insert-char! image char)
+ (cond ((false? representation)
+ (let ((s (string-allocate x-size)))
+ (string-fill! s #\space)
+ (string-set! s x char)
+ (set! representation s)))
+ ((string? representation)
+ (string-set! representation x char))
+ (else
+ (string-set! (vector-ref representation (fix:-1+ y-size))
+ x
+ char)))))
(define (string-base:direct-output-insert-newline! window)
(with-instance-variables string-base window ()
+ (set! image (make-null-image))
(set! y-size 1)
- (set! representation (cons "" false))))
+ (set! representation false)))
(define (string-base:direct-output-insert-substring! window x string start end)
(with-instance-variables string-base window (x string start end)
- (if (pair? representation)
- (begin
- (set-car! representation
- (string-append-substring (car representation)
- string start end))
- (if (not (cdr representation))
- (let ((index
- (substring-find-next-char-in-set string start end
- char-set:not-space)))
- (if index
- (set-cdr! representation (fix:+ x index))))))
- (substring-move-right! string start end
- (vector-ref representation (fix:-1+ y-size))
- x))))
+ (image-direct-output-insert-substring! image string start end)
+ (cond ((false? representation)
+ (let ((s (string-allocate x-size)))
+ (substring-fill! s 0 x #\space)
+ (substring-move-left! string start end s x)
+ (substring-fill! s (fix:+ x (fix:- end start)) x-size #\space)
+ (set! representation s)))
+ ((string? representation)
+ (substring-move-left! string start end representation x))
+ (else
+ (substring-move-left! string start end
+ (vector-ref representation (fix:-1+ y-size))
+ x)))))
(define (string-base:refresh! window)
(with-instance-variables string-base window ()
- (define (one-liner string)
- (let ((start
- (string-find-next-char-in-set string char-set:not-space)))
- (if (not (and (pair? representation)
- (string=? (car representation) string)
- (eqv? (cdr representation) start)))
- (begin
- (set! representation (cons string start))
- (setup-redisplay-flags! redisplay-flags)))))
- (let* ((string (image-representation image))
- (column-size (string-length string)))
- (cond ((fix:< column-size x-size)
- (one-liner string))
- (truncate-lines?
- (one-liner
- (let ((s (string-allocate x-size))
- (x-max (fix:-1+ x-size)))
- (substring-move-right! string 0 x-max s 0)
- (string-set! s x-max #\$)
- s)))
- (else
- (let ((rep (make-vector y-size '()))
- (x-max (fix:-1+ x-size)))
- (let loop ((start 0) (y 0))
- (let ((s (string-allocate x-size))
- (end (fix:+ start x-max)))
- (vector-set! rep y s)
- (if (fix:> column-size end)
- (begin
- (substring-move-right! string start end s 0)
- (string-set! s x-max #\\)
- (loop end (fix:1+ y)))
- (begin
- (substring-move-right! string start column-size s 0)
- (substring-fill! s
- (fix:- column-size start)
- x-size
- #\space)))))
- (set! representation rep)
- (setup-redisplay-flags! redisplay-flags)))))))
+ (let ((string (image-representation image)))
+ (let ((column-size (string-length string)))
+ (cond ((fix:= column-size 0)
+ (set! representation false))
+ ((fix:< column-size x-size)
+ (let ((s (string-allocate x-size)))
+ (substring-move-left! string 0 column-size s 0)
+ (substring-fill! s column-size x-size #\space)
+ (set! representation s)))
+ (truncate-lines?
+ (let ((s (string-allocate x-size))
+ (x-max (fix:-1+ x-size)))
+ (substring-move-left! string 0 x-max s 0)
+ (string-set! s x-max #\$)
+ (set! representation s)))
+ (else
+ (let ((rep (make-vector y-size '()))
+ (x-max (fix:-1+ x-size)))
+ (let loop ((start 0) (y 0))
+ (let ((s (string-allocate x-size))
+ (end (fix:+ start x-max)))
+ (vector-set! rep y s)
+ (if (fix:> column-size end)
+ (begin
+ (substring-move-left! string start end s 0)
+ (string-set! s x-max #\\)
+ (loop end (fix:1+ y)))
+ (begin
+ (substring-move-left! string start column-size s 0)
+ (substring-fill! s
+ (fix:- column-size start)
+ x-size
+ #\space)))))
+ (set! representation rep))))))
+ (setup-redisplay-flags! redisplay-flags)))
\f
;;;; Blank Window
(define-class blank-window vanilla-window
())
-(define-method blank-window (:update-display! window screen x-start y-start
- xl xu yl yu display-style)
+(define (blank-window:update-display! window screen x-start y-start
+ xl xu yl yu display-style)
window display-style ;ignore
- (subscreen-clear! screen
- (fix:+ x-start xl) (fix:+ x-start xu)
- (fix:+ y-start yl) (fix:+ y-start yu))
+ (screen-clear-rectangle screen
+ (fix:+ x-start xl) (fix:+ x-start xu)
+ (fix:+ y-start yl) (fix:+ y-start yu)
+ false)
true)
+(define-method blank-window :update-display!
+ blank-window:update-display!)
+
;;;; Vertical Border Window
(define-class vertical-border-window vanilla-window
(define-method vertical-border-window (:initialize! window window*)
(usual=> window :initialize! window*)
- (set! x-size 1)
- unspecific)
+ (set! x-size 1))
(define-method vertical-border-window (:set-x-size! window x)
window ;ignore
(define-method vertical-border-window (:set-size! window x y)
(if (not (fix:= x 1))
- (error "x-size of a vertical border window must be 1" x))
+ (error "Can't change the x-size of a vertical border window" x))
(set! x-size x)
(set! y-size y)
(setup-redisplay-flags! redisplay-flags))
-(define-method vertical-border-window
- (:update-display! window screen x-start y-start
- xl xu yl yu display-style)
+(define (vertical-border-window:update-display! window screen x-start y-start
+ xl xu yl yu display-style)
display-style ;ignore
(if (fix:< xl xu)
- (clip-window-region-1 yl yu y-size
+ (clip-window-region-1 yl yu (window-y-size window)
(lambda (yl yu)
(let ((xl (fix:+ x-start xl))
(yu (fix:+ y-start yu)))
(let loop ((y (fix:+ y-start yl)))
(if (fix:< y yu)
(begin
- (screen-write-char! screen xl y #\|)
- (loop (fix:1+ y)))))))))
+ (screen-output-char screen xl y #\| false)
+ (loop (fix:+ y 1)))))))))
true)
+
+(define-method vertical-border-window :update-display!
+ vertical-border-window:update-display!)
\f
;;;; Cursor Window
(usual=> window :initialize! window*)
(set! x-size 1)
(set! y-size 1)
- (set! enabled? false)
- unspecific)
+ (set! enabled? false))
(define-method cursor-window (:set-x-size! window x)
window ;ignore
window ;ignore
(error "Can't change the size of a cursor window" x y))
-(define-method cursor-window (:update-display! window screen x-start y-start
- xl xu yl yu display-style)
+(define (cursor-window:update-display! window screen x-start y-start
+ xl xu yl yu display-style)
display-style ;ignore
- (if (and enabled? (fix:< xl xu) (fix:< yl yu))
- (screen-write-cursor! screen x-start y-start))
+ (if (and (with-instance-variables cursor-window window () enabled?)
+ (fix:< xl xu)
+ (fix:< yl yu))
+ (screen-move-cursor screen x-start y-start))
true)
+(define-method cursor-window :update-display!
+ cursor-window:update-display!)
+
(define-method cursor-window (:enable! window)
(set! enabled? true)
(setup-redisplay-flags! redisplay-flags))
(define-method cursor-window (:disable! window)
(set! enabled? false)
- (set-car! redisplay-flags false)
- unspecific)
\ No newline at end of file
+ (set-car! redisplay-flags false))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.98 1990/10/09 16:24:47 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.99 1990/11/02 03:24:57 cph Rel $
;;;
;;; Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
;;;
(let ((window (current-window)))
(if (not argument)
(begin
- (window-redraw! window false)
+ (window-scroll-y-absolute! window (window-y-center window))
+ (window-redraw! window)
(update-selected-screen! true))
(window-scroll-y-absolute!
window
(multi-scroll-window-argument window argument 1)))))
\f
(define (scroll-window window n #!optional limit)
- (if (if (negative? n)
- (= (window-start-index window)
- (mark-index (buffer-start (window-buffer window))))
- (= (window-end-index window)
- (mark-index (buffer-end (window-buffer window)))))
+ (if (window-mark-visible?
+ window
+ ((if (negative? n) buffer-start buffer-end) (window-buffer window)))
((if (default-object? limit) editor-error limit))
(window-scroll-y-relative! window n)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.151 1990/10/06 21:10:32 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.152 1990/11/02 03:25:03 cph Rel $
;;;
-;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Window System
(declare (usual-integrations))
-\f
+
;;; Based on WINDOW-WIN, designed by RMS.
;;; See WINOPS.TXT for more information.
;;; method invocation. However, these instance variables are always
;;; set by a method defined on the window itself.
+;;; It is assumed in several places that the methods to set a window's
+;;; size are called with interrupts disabled.
+\f
;;;; Vanilla Window
(define-class vanilla-window ()
(superior x-size y-size redisplay-flags inferiors))
(define (window-initialize! window window*)
- (with-instance-variables vanilla-window window (window*)
- (set! superior window*)
- (set! redisplay-flags (=> superior :inferior-redisplay-flags window))
- (set! inferiors '())
- unspecific))
+ (%set-window-superior! window window*)
+ (set-window-inferiors! window '())
+ (%set-window-redisplay-flags! window
+ (=> window* :inferior-redisplay-flags window)))
(define (window-kill! window)
(for-each-inferior-window window (lambda (window) (=> window :kill!))))
(define-integrable (window-superior window)
(with-instance-variables vanilla-window window () superior))
-(define (set-window-superior! window window*)
+(define-integrable (%set-window-superior! window window*)
(with-instance-variables vanilla-window window (window*)
- (set! superior window*)
- (set! redisplay-flags (=> window* :inferior-redisplay-flags window))
- (setup-redisplay-flags! redisplay-flags)
- (for-each (lambda (inferior)
- (set-inferior-redisplay-flags! inferior
- (cons false redisplay-flags))
- (=> (inferior-window inferior) :set-superior! window))
- inferiors)))
-
-(define (window-root-window window)
- (with-instance-variables vanilla-window window ()
- (if superior (window-root-window superior) window)))
+ (set! superior window*)))
(define-integrable (window-x-size window)
(with-instance-variables vanilla-window window () x-size))
-(define (set-window-x-size! window x)
- (with-instance-variables vanilla-window window (x)
- (%set-window-x-size! window x)
- (setup-redisplay-flags! redisplay-flags)))
-
(define-integrable (%set-window-x-size! window x)
- (with-instance-variables vanilla-window window (x)
- (set! x-size x)
- unspecific))
+ (with-instance-variables vanilla-window window (x) (set! x-size x)))
(define-integrable (window-y-size window)
(with-instance-variables vanilla-window window () y-size))
-(define (set-window-y-size! window y)
- (with-instance-variables vanilla-window window (y)
- (%set-window-y-size! window y)
- (setup-redisplay-flags! redisplay-flags)))
-
(define-integrable (%set-window-y-size! window y)
- (with-instance-variables vanilla-window window (y)
- (set! y-size y)
- unspecific))
-\f
-(define (window-size window receiver)
- (with-instance-variables vanilla-window window (receiver)
- (receiver x-size y-size)))
-
-(define (set-window-size! window x y)
- (with-instance-variables vanilla-window window (x y)
- (set! x-size x)
- (set! y-size y)
- (setup-redisplay-flags! redisplay-flags)))
+ (with-instance-variables vanilla-window window (y) (set! y-size y)))
(define-integrable (window-redisplay-flags window)
(with-instance-variables vanilla-window window () redisplay-flags))
-(define-integrable (%window-needs-redisplay? window)
- (with-instance-variables vanilla-window window () (car redisplay-flags)))
+(define-integrable (%set-window-redisplay-flags! window flags)
+ (with-instance-variables vanilla-window window (flags)
+ (set! redisplay-flags flags)))
(define-integrable (window-inferiors window)
(with-instance-variables vanilla-window window () inferiors))
+(define-integrable (set-window-inferiors! window inferiors*)
+ (with-instance-variables vanilla-window window (inferiors*)
+ (set! inferiors inferiors*)))
+
+(define (window-root-window window)
+ (if (window-superior window)
+ (window-root-window (window-superior window))
+ window))
+
+(define (set-window-superior! window window*)
+ (%set-window-superior! window window*)
+ (let ((flags (=> window* :inferior-redisplay-flags window)))
+ (%set-window-redisplay-flags! window flags)
+ (setup-redisplay-flags! flags)
+ (for-each-inferior window
+ (lambda (inferior)
+ (set-inferior-redisplay-flags! inferior (cons false flags))
+ (=> (inferior-window inferior) :set-superior! window)))))
+\f
+(define (window-size window receiver)
+ (receiver (window-x-size window) (window-y-size window)))
+
+(define (set-window-x-size! window x)
+ (%set-window-x-size! window x)
+ (window-needs-redisplay! window))
+
+(define (set-window-y-size! window y)
+ (%set-window-y-size! window y)
+ (window-needs-redisplay! window))
+
+(define (set-window-size! window x y)
+ (%set-window-x-size! window x)
+ (%set-window-y-size! window y)
+ (window-needs-redisplay! window))
+
+(define-integrable (window-needs-redisplay? window)
+ (car (window-redisplay-flags window)))
+
+(define-integrable (window-needs-redisplay! window)
+ (setup-redisplay-flags! (window-redisplay-flags window)))
+
(define-integrable (window-inferior? window window*)
- (with-instance-variables vanilla-window window (window*)
- (find-inferior? inferiors window*)))
+ (find-inferior? (window-inferiors window) window*))
(define-integrable (window-inferior window window*)
- (with-instance-variables vanilla-window window (window*)
- (find-inferior inferiors window*)))
+ (find-inferior (window-inferiors window) window*))
-(define (for-each-inferior window procedure)
- (with-instance-variables vanilla-window window (procedure)
- (let loop ((inferiors inferiors))
- (if (not (null? inferiors))
- (begin
- (procedure (car inferiors))
- (loop (cdr inferiors)))))))
+(define-integrable (for-each-inferior window procedure)
+ (let loop ((inferiors (window-inferiors window)))
+ (if (not (null? inferiors))
+ (begin
+ (procedure (car inferiors))
+ (loop (cdr inferiors))))))
-(define (for-each-inferior-window window procedure)
+(define-integrable (for-each-inferior-window window procedure)
(for-each-inferior window
- (lambda (inferior) (procedure (inferior-window inferior)))))
+ (lambda (inferior)
+ (procedure (inferior-window inferior)))))
(define (make-inferior window class)
- (with-instance-variables vanilla-window window (class)
- (let ((window* (make-object class)))
- (let ((inferior
- (cons window*
- (vector false
+ (let ((window* (make-object class)))
+ (let ((inferior
+ (%make-inferior window*
+ false
false
- (cons false redisplay-flags)))))
- (set! inferiors (cons inferior inferiors))
- (=> window* :initialize! window)
- inferior))))
+ (cons false (window-redisplay-flags window)))))
+ (set-window-inferiors! window (cons inferior (window-inferiors window)))
+ (=> window* :initialize! window)
+ inferior)))
(define (add-inferior! window window*)
- (with-instance-variables vanilla-window window (window*)
- (set! inferiors
- (cons (cons window*
- (vector false
- false
- (cons false redisplay-flags)))
- inferiors))
- (=> window* :set-superior! window)))
+ (let ((inferior
+ (%make-inferior window*
+ false
+ false
+ (cons false (window-redisplay-flags window)))))
+ (set-window-inferiors! window (cons inferior (window-inferiors window)))
+ (=> window* :set-superior! window)
+ inferior))
(define (delete-inferior! window window*)
- (with-instance-variables vanilla-window window (window*)
- (set! inferiors
- (delq! (find-inferior inferiors window*)
- inferiors))))
+ (set-window-inferiors! window
+ (let ((inferiors (window-inferiors window)))
+ (delq! (find-inferior inferiors window*)
+ inferiors))))
(define (replace-inferior! window old new)
- (with-instance-variables vanilla-window window (old new)
- (set-inferior-window! (find-inferior inferiors old) new)
- (=> new :set-superior! window)))
+ (set-inferior-window! (find-inferior (window-inferiors window) old) new)
+ (=> new :set-superior! window))
\f
;;; Returns #T if the redisplay finished, #F if aborted.
;;; Notice that the :UPDATE-DISPLAY! operation is assumed to return
;;; the same value. This is used to control the setting of the
;;; redisplay flags.
-(define (update-inferiors! window screen x-start y-start xl xu yl yu
- display-style)
- (with-instance-variables vanilla-window window
- (screen x-start y-start xl xu yl yu display-style)
- (let loop ((inferiors inferiors))
- (if (null? inferiors)
- true
- (let ((window (inferior-window (car inferiors)))
- (xi (inferior-x-start (car inferiors)))
- (yi (inferior-y-start (car inferiors)))
- (flags (inferior-redisplay-flags (car inferiors))))
- (let ((continue
- (lambda ()
- (set-car! flags false)
- (loop (cdr inferiors)))))
- (if (and (or display-style (car flags))
- xi yi)
- (and (or display-style (not (keyboard-active? 0)))
- (clip-window-region xl xu yl yu
- xi (window-x-size window)
- yi (window-y-size window)
- (lambda (xl xu yl yu)
- (=> window :update-display!
- screen (fix:+ x-start xi) (fix:+ y-start yi)
- xl xu yl yu display-style)))
- (continue))
- (continue))))))))
-
-(define (clip-window-region xl xu yl yu xi xs yi ys receiver)
- (clip-window-region-1 (fix:- xl xi) (fix:- xu xi) xs
- (lambda (xl xu)
- (clip-window-region-1 (fix:- yl yi) (fix:- yu yi) ys
- (lambda (yl yu)
- (receiver xl xu yl yu))))))
+(define (window-update-display! window screen x-start y-start xl xu yl yu
+ display-style)
+ (update-inferiors! (window-inferiors window) screen x-start y-start
+ xl xu yl yu display-style
+ (lambda (window screen x-start y-start xl xu yl yu display-style)
+ (and (or display-style (not (keyboard-active? 0)))
+ (=> window :update-display! screen x-start y-start xl xu yl yu
+ display-style)))))
+
+(define (update-inferiors! inferiors screen x-start y-start xl xu yl yu
+ display-style updater)
+ (let loop ((inferiors inferiors))
+ (if (null? inferiors)
+ true
+ (and (update-inferior! (car inferiors) screen x-start y-start
+ xl xu yl yu display-style updater)
+ (loop (cdr inferiors))))))
+
+(define (update-inferior! inferior screen x-start y-start xl xu yl yu
+ display-style updater)
+ (let ((window (inferior-window inferior))
+ (xi (inferior-x-start inferior))
+ (yi (inferior-y-start inferior))
+ (flags (inferior-redisplay-flags inferior)))
+ (and (or (not xi)
+ (not (or display-style (car flags)))
+ (clip-window-region-1 (fix:- xl xi)
+ (fix:- xu xi)
+ (window-x-size window)
+ (lambda (xl xu)
+ (clip-window-region-1 (fix:- yl yi)
+ (fix:- yu yi)
+ (window-y-size window)
+ (lambda (yl yu)
+ (updater window
+ screen (fix:+ x-start xi) (fix:+ y-start yi)
+ xl xu yl yu display-style))))))
+ (begin
+ (set-car! flags false)
+ true))))
(define (clip-window-region-1 al au bs receiver)
- (if (fix:positive? al)
- (if (fix:> al bs)
- true
- (receiver al (if (fix:< bs au) bs au)))
- (if (fix:positive? au)
- (receiver 0 (if (fix:< bs au) bs au))
- true)))
+ (if (fix:< 0 al)
+ (if (fix:< au bs)
+ (if (fix:< al au) (receiver al au) true)
+ (if (fix:< al bs) (receiver al bs) true))
+ (if (fix:< au bs)
+ (if (fix:< 0 au) (receiver 0 au) true)
+ (if (fix:< 0 bs) (receiver 0 bs) true))))
(define (salvage-inferiors! window)
(for-each-inferior-window window (lambda (window) (=> window :salvage!))))
(define-method vanilla-window :add-inferior! add-inferior!)
(define-method vanilla-window :delete-inferior! delete-inferior!)
(define-method vanilla-window :replace-inferior! replace-inferior!)
-(define-method vanilla-window :update-display! update-inferiors!)
+(define-method vanilla-window :update-display! window-update-display!)
(define-method vanilla-window :salvage! salvage-inferiors!)
;;;; Operations on Inferiors
\f
;;;; Inferiors
+(define %inferior-tag
+ "inferior")
+
+(define-integrable (%make-inferior window x-start y-start redisplay-flags)
+ (vector %inferior-tag window x-start y-start redisplay-flags))
+
+(define-integrable (inferior-window inferior)
+ (vector-ref inferior 1))
+
+(define-integrable (set-inferior-window! inferior window)
+ (vector-set! inferior 1 window))
+
+(define-integrable (inferior-x-start inferior)
+ (vector-ref inferior 2))
+
+(define-integrable (%set-inferior-x-start! inferior x-start)
+ (vector-set! inferior 2 x-start))
+
+(define-integrable (inferior-y-start inferior)
+ (vector-ref inferior 3))
+
+(define-integrable (%set-inferior-y-start! inferior y-start)
+ (vector-set! inferior 3 y-start))
+
+(define-integrable (inferior-redisplay-flags inferior)
+ (vector-ref inferior 4))
+
+(define-integrable (set-inferior-redisplay-flags! inferior redisplay-flags)
+ (vector-set! inferior 4 redisplay-flags))
+
+(unparser/set-tagged-vector-method! %inferior-tag
+ (unparser/standard-method 'INFERIOR
+ (lambda (state inferior)
+ (unparse-object state (inferior-window inferior))
+ (unparse-string state " x,y=(")
+ (unparse-object state (inferior-x-start inferior))
+ (unparse-string state ",")
+ (unparse-object state (inferior-y-start inferior))
+ (unparse-string state ")")
+ (if (inferior-needs-redisplay? inferior)
+ (unparse-string state " needs-redisplay")))))
+
+(define (inferior-copy inferior)
+ (%make-inferior (inferior-window inferior)
+ (inferior-x-start inferior)
+ (inferior-y-start inferior)
+ (inferior-redisplay-flags inferior)))
+\f
+(define (inferior-start inferior receiver)
+ (receiver (inferior-x-start inferior)
+ (inferior-y-start inferior)))
+
+(define (%set-inferior-start! inferior x-start y-start)
+ (%set-inferior-x-start! inferior x-start)
+ (%set-inferior-y-start! inferior y-start))
+
+(define (set-inferior-x-start! inferior x-start)
+ (%set-inferior-x-start! inferior x-start)
+ (inferior-needs-redisplay! inferior))
+
+(define (set-inferior-y-start! inferior y-start)
+ (%set-inferior-y-start! inferior y-start)
+ (inferior-needs-redisplay! inferior))
+
+(define (set-inferior-start! inferior x-start y-start)
+ (%set-inferior-start! inferior x-start y-start)
+ (inferior-needs-redisplay! inferior))
+
+(define-integrable (%inferior-x-end inferior)
+ (fix:+ (inferior-x-start inferior) (inferior-x-size inferior)))
+
+(define-integrable (%inferior-y-end inferior)
+ (fix:+ (inferior-y-start inferior) (inferior-y-size inferior)))
+
+(define (inferior-x-end inferior)
+ (and (inferior-x-start inferior)
+ (%inferior-x-end inferior)))
+
+(define (inferior-y-end inferior)
+ (and (inferior-y-start inferior)
+ (%inferior-y-end inferior)))
+
+(define (set-inferior-x-end! inferior x-end)
+ (set-inferior-x-start! inferior (fix:- x-end (inferior-x-size inferior))))
+
+(define (set-inferior-y-end! inferior y-end)
+ (set-inferior-y-start! inferior (fix:- y-end (inferior-y-size inferior))))
+
(define (inferior-position inferior)
(and (inferior-x-start inferior)
- (inferior-y-start inferior)
(cons (inferior-x-start inferior)
(inferior-y-start inferior))))
(set-inferior-start! inferior false false)
(set-inferior-start! inferior (car position) (cdr position))))
+(define-integrable (inferior-needs-redisplay? inferior)
+ (car (inferior-redisplay-flags inferior)))
+
(define (inferior-needs-redisplay! inferior)
- (if (and (inferior-x-start inferior)
- (inferior-y-start inferior))
+ (if (and (inferior-x-start inferior) (inferior-y-start inferior))
(setup-redisplay-flags! (inferior-redisplay-flags inferior))
- (set-car! (inferior-redisplay-flags inferior) false))
- unspecific)
+ (set-car! (inferior-redisplay-flags inferior) false)))
(define (setup-redisplay-flags! flags)
- (if (not (or (null? flags) (car flags)))
- (begin
- (set-car! flags true)
- (setup-redisplay-flags! (cdr flags)))))
-
+ (let loop ((flags flags))
+ (if (not (or (null? flags) (car flags)))
+ (begin
+ (set-car! flags true)
+ (loop (cdr flags))))))
+\f
(define-integrable (inferior-x-size inferior)
(window-x-size (inferior-window inferior)))
(define-integrable (set-inferior-size! inferior x y)
(=> (inferior-window inferior) :set-size! x y))
+(define (find-inferior? inferiors window)
+ (let loop ((inferiors inferiors))
+ (and (not (null? inferiors))
+ (if (eq? window (inferior-window (car inferiors)))
+ (car inferiors)
+ (loop (cdr inferiors))))))
+
+(define (find-inferior inferiors window)
+ (let ((inferior (find-inferior? inferiors window)))
+ (if (not inferior)
+ (error "window not in inferiors" window))
+ inferior))
+
(define (inferior-containing-coordinates window x y stop-search?)
(let search ((window window) (x x) (y y))
(if (stop-search? window)
(if (and x-start y-start)
(let ((x (fix:- x x-start))
(y (fix:- y y-start)))
- (if (and (not (fix:negative? x))
+ (if (and (fix:<= 0 x)
(fix:< x (inferior-x-size inferior))
- (not (fix:negative? y))
+ (fix:<= 0 y)
(fix:< y (inferior-y-size inferior)))
(search (inferior-window inferior) x y)
(loop (cdr inferiors))))
- (loop (cdr inferiors))))))))))
-\f
-(define-integrable (find-inferior? inferiors window)
- (assq window inferiors))
-
-(define-integrable (find-inferior inferiors window)
- (or (find-inferior? inferiors window)
- (error "Window is not an inferior" window)))
-
-(define-integrable inferior-window car)
-(define-integrable set-inferior-window! set-car!)
-
-(define-integrable (inferior-x-start inferior)
- (vector-ref (cdr inferior) 0))
-
-(define-integrable (%set-inferior-x-start! inferior x-start)
- (vector-set! (cdr inferior) 0 x-start))
-
-(define (set-inferior-x-start! inferior x-start)
- (%set-inferior-x-start! inferior x-start)
- (inferior-needs-redisplay! inferior))
-
-(define (inferior-x-end inferior)
- (let ((x-start (inferior-x-start inferior)))
- (and x-start
- (fix:+ x-start (inferior-x-size inferior)))))
-
-(define (set-inferior-x-end! inferior x-end)
- (set-inferior-x-start! inferior (fix:- x-end (inferior-x-size inferior))))
-
-(define-integrable (inferior-y-start inferior)
- (vector-ref (cdr inferior) 1))
-
-(define-integrable (%set-inferior-y-start! inferior y-start)
- (vector-set! (cdr inferior) 1 y-start))
-
-(define (set-inferior-y-start! inferior y-start)
- (%set-inferior-y-start! inferior y-start)
- (inferior-needs-redisplay! inferior))
-
-(define (inferior-y-end inferior)
- (let ((y-start (inferior-y-start inferior)))
- (and y-start
- (fix:+ y-start (inferior-y-size inferior)))))
-
-(define (set-inferior-y-end! inferior y-end)
- (set-inferior-y-start! inferior (fix:- y-end (inferior-y-size inferior))))
-
-(define (inferior-start inferior receiver)
- (receiver (inferior-x-start inferior)
- (inferior-y-start inferior)))
-
-(define (%set-inferior-start! inferior x-start y-start)
- (%set-inferior-x-start! inferior x-start)
- (%set-inferior-y-start! inferior y-start))
-
-(define (set-inferior-start! inferior x-start y-start)
- (%set-inferior-start! inferior x-start y-start)
- (inferior-needs-redisplay! inferior))
-
-(define-integrable (inferior-redisplay-flags inferior)
- (vector-ref (cdr inferior) 2))
-
-(define-integrable (set-inferior-redisplay-flags! inferior flags)
- (vector-set! (cdr inferior) 2 flags))
\ No newline at end of file
+ (loop (cdr inferiors))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winren.scm,v 1.3 1990/11/02 03:25:09 cph Rel $
+;;;
+;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Window System Rename Exports
(declare (usual-integrations))
-\f
+
;; buffrm.scm
(define window?)
(define window-x-size)
(define window-y-size)
+(define window-needs-redisplay?)
(define %set-window-buffer!)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.12 1990/10/09 16:24:53 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.13 1990/11/02 03:25:13 cph Rel $
;;;
;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology
;;;
(x-display-process-events 2)
(x-display-sync 2)
(x-window-beep 1)
- (x-window-clear 1)
(x-window-display 1)
(x-window-set-event-mask 2)
(x-window-set-icon-name 2)
(xterm-open-window 3)
(xterm-restore-contents 6)
(xterm-save-contents 5)
- (xterm-scroll-lines-down 7)
- (xterm-scroll-lines-up 7)
+ (xterm-scroll-lines-down 6)
+ (xterm-scroll-lines-up 6)
(xterm-set-size 3)
(xterm-write-char! 5)
(xterm-write-cursor! 3)
(make-screen (make-xterm-screen-state xterm
(x-window-display xterm))
xterm-screen/beep
+ xterm-screen/clear-line!
+ xterm-screen/clear-rectangle!
+ xterm-screen/clear-screen!
xterm-screen/discard!
xterm-screen/enter!
xterm-screen/exit!
- xterm-screen/finish-update!
xterm-screen/flush!
- xterm-screen/inverse-video!
xterm-screen/modeline-event!
- xterm-screen/normal-video!
+ xterm-screen/preempt-update?
xterm-screen/scroll-lines-down!
xterm-screen/scroll-lines-up!
- xterm-screen/start-update!
- xterm-screen/subscreen-clear!
- xterm-screen/wipe!
+ xterm-screen/wrap-update!
xterm-screen/write-char!
xterm-screen/write-cursor!
xterm-screen/write-substring!
(define-integrable (screen-display screen)
(xterm-screen-state/display (screen-state screen)))
-(define-integrable (screen-highlight screen)
- (if (screen-highlight? screen) 1 0))
-
(define-integrable (screen-redisplay-flag screen)
(xterm-screen-state/redisplay-flag (screen-state screen)))
(car screens)
(loop (cdr screens))))))
\f
-(define (xterm-screen/start-update! screen)
- (xterm-enable-cursor (screen-xterm screen) false))
-
-(define (xterm-screen/finish-update! screen)
- (if (screen-selected? screen)
- (let ((xterm (screen-xterm screen)))
- (xterm-enable-cursor xterm true)
- (xterm-draw-cursor xterm)))
- (if (screen-redisplay-flag screen)
- (begin
- (update-xterm-screen-names! screen)
- (set-screen-redisplay-flag! screen false)))
- (xterm-screen/flush! screen))
+(define (xterm-screen/wrap-update! screen thunk)
+ (dynamic-wind
+ (lambda ()
+ (xterm-enable-cursor (screen-xterm screen) false))
+ thunk
+ (lambda ()
+ (if (screen-selected? screen)
+ (let ((xterm (screen-xterm screen)))
+ (xterm-enable-cursor xterm true)
+ (xterm-draw-cursor xterm)))
+ (if (screen-redisplay-flag screen)
+ (begin
+ (update-xterm-screen-names! screen)
+ (set-screen-redisplay-flag! screen false)))
+ (xterm-screen/flush! screen))))
(define (xterm-screen/discard! screen)
(set! screen-list (delq! screen screen-list))
(xterm-erase-cursor xterm))
(xterm-screen/flush! screen))
-(define (xterm-screen/inverse-video! screen)
+(define (xterm-screen/preempt-update? screen y)
screen ; ignored
- unspecific)
-
-(define (xterm-screen/normal-video! screen)
- screen ; ignored
- unspecific)
+ (fix:= (fix:remainder y 8) 0))
+
(define (xterm-screen/scroll-lines-down! screen xl xu yl yu amount)
- (xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount 0)
- true)
+ (xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount)
+ 'UNCHANGED)
(define (xterm-screen/scroll-lines-up! screen xl xu yl yu amount)
- (xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount 0)
- true)
+ (xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount)
+ 'UNCHANGED)
(define (xterm-screen/beep screen)
(x-window-beep (screen-xterm screen))
(define-integrable (xterm-screen/flush! screen)
(x-display-flush (screen-display screen)))
-(define (xterm-screen/write-char! screen x y char)
- (xterm-write-char! (screen-xterm screen) x y char (screen-highlight screen)))
+(define (xterm-screen/write-char! screen x y char highlight)
+ (xterm-write-char! (screen-xterm screen) x y char (if highlight 1 0)))
(define (xterm-screen/write-cursor! screen x y)
(xterm-write-cursor! (screen-xterm screen) x y))
-(define (xterm-screen/write-substring! screen x y string start end)
+(define (xterm-screen/write-substring! screen x y string start end highlight)
(xterm-write-substring! (screen-xterm screen) x y string start end
- (screen-highlight screen)))
+ (if highlight 1 0)))
+
+(define (xterm-screen/clear-line! screen x y first-unused-x)
+ (xterm-clear-rectangle! (screen-xterm screen)
+ x first-unused-x y (fix:1+ y) 0))
-(define (xterm-screen/subscreen-clear! screen xl xu yl yu)
- (xterm-clear-rectangle! (screen-xterm screen) xl xu yl yu
- (screen-highlight screen)))
+(define (xterm-screen/clear-rectangle! screen xl xu yl yu highlight)
+ (xterm-clear-rectangle! (screen-xterm screen)
+ xl xu yl yu (if highlight 1 0)))
-(define (xterm-screen/wipe! screen)
- (x-window-clear (screen-xterm screen)))
+(define (xterm-screen/clear-screen! screen)
+ (xterm-clear-rectangle! (screen-xterm screen)
+ 0 (screen-x-size screen) 0 (screen-y-size screen) 0))
\f
;;;; Input Port
(set! pending-interrupt? false)
(^G-signal))
-(define (with-editor-interrupts-from-x thunk)
+(define (with-editor-interrupts-from-x receiver)
(fluid-let ((signal-interrupts? true)
(pending-interrupt? false))
- (thunk)))
+ (receiver (lambda (thunk) (thunk)))))
(define (with-x-interrupts-enabled thunk)
(bind-signal-interrupts? true thunk))
(if (not (and (= x-size (screen-x-size screen))
(= y-size (screen-y-size screen))))
(begin
- (set-screen-x-size! screen x-size)
- (set-screen-y-size! screen y-size)
- (send (screen-root-window screen) ':set-size! x-size y-size)
+ (set-screen-size! screen x-size y-size)
(update-screen! screen true))))))
(define-event-handler event-type:button-down
(define x-display-data)
(define (get-x-display)
+ ;; X-OPEN-DISPLAY hangs, uninterruptibly, when the X server is
+ ;; running the login loop of xdm. Can this be fixed?
(or x-display-data
(let ((display (x-open-display false)))
(set! x-display-data display)
projects / mit-scheme.git / commitdiff