938 lines
35 KiB
Scheme
938 lines
35 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme is free software; you can redistribute it and/or modify
|
||
it under the terms of the GNU General Public License as published by
|
||
the Free Software Foundation; either version 2 of the License, or (at
|
||
your option) any later version.
|
||
|
||
MIT/GNU Scheme is distributed in the hope that it will be useful, but
|
||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
General Public License for more details.
|
||
|
||
You should have received a copy of the GNU General Public License
|
||
along with MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Screen Abstraction
|
||
|
||
|
||
|
||
(define-structure (screen
|
||
(constructor make-screen
|
||
(state
|
||
operation/beep
|
||
operation/clear-line!
|
||
operation/clear-rectangle!
|
||
operation/clear-screen!
|
||
operation/discard!
|
||
operation/enter!
|
||
operation/exit!
|
||
operation/flush!
|
||
operation/modeline-event!
|
||
operation/discretionary-flush
|
||
operation/scroll-lines-down!
|
||
operation/scroll-lines-up!
|
||
operation/wrap-update!
|
||
operation/write-char!
|
||
operation/write-cursor!
|
||
operation/write-substring!
|
||
preemption-modulus
|
||
x-size
|
||
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/flush! false read-only true)
|
||
(operation/modeline-event! false read-only true)
|
||
(operation/discretionary-flush false read-only true)
|
||
(operation/scroll-lines-down! false read-only true)
|
||
(operation/scroll-lines-up! 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)
|
||
(preemption-modulus false read-only true)
|
||
(root-window false)
|
||
;; Visibility is one of the following:
|
||
;; VISIBLE PARTIALLY-OBSCURED OBSCURED UNMAPPED DELETED
|
||
(visibility 'VISIBLE)
|
||
(needs-update? false)
|
||
(in-update? false)
|
||
(x-size false)
|
||
(y-size false)
|
||
|
||
;; Description of actual screen contents.
|
||
current-matrix
|
||
|
||
;; Description of desired screen contents.
|
||
new-matrix
|
||
|
||
;; Set this variable in the debugger to trace interesting events.
|
||
(debug-trace false))
|
||
|
||
(define (guarantee-screen object procedure)
|
||
(if (not (screen? object))
|
||
(error:wrong-type-argument object "screen" procedure)))
|
||
|
||
(define (initialize-screen-root-window! screen bufferset buffer)
|
||
(set-screen-root-window!
|
||
screen
|
||
(make-editor-frame
|
||
screen
|
||
buffer
|
||
(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)))
|
||
|
||
(define (screen-beep screen)
|
||
((screen-operation/beep screen) screen))
|
||
|
||
(define (screen-enter! screen)
|
||
((screen-operation/enter! screen) screen)
|
||
(screen-modeline-event! screen
|
||
(screen-selected-window screen)
|
||
'SELECT-SCREEN))
|
||
|
||
(define (screen-exit! screen)
|
||
((screen-operation/exit! screen) screen)
|
||
(screen-modeline-event! screen
|
||
(screen-selected-window screen)
|
||
'DESELECT-SCREEN))
|
||
|
||
(define (screen-discard! screen)
|
||
(if (not (screen-deleted? screen))
|
||
(begin
|
||
(set-screen-visibility! screen 'DELETED)
|
||
(for-each (lambda (window) (send window ':kill!))
|
||
(screen-window-list screen))
|
||
((screen-operation/discard! screen) screen))))
|
||
|
||
(define (screen-modeline-event! screen window type)
|
||
((screen-operation/modeline-event! screen) screen window type))
|
||
|
||
(define-integrable (screen-selected-window screen)
|
||
(editor-frame-selected-window (screen-root-window screen)))
|
||
|
||
(define (screen-select-window! screen window)
|
||
(editor-frame-select-window! (screen-root-window screen) window)
|
||
(screen-modeline-event! screen window 'SELECT-WINDOW))
|
||
|
||
(define-integrable (screen-cursor-window screen)
|
||
(editor-frame-cursor-window (screen-root-window screen)))
|
||
|
||
(define-integrable (screen-select-cursor! screen window)
|
||
(editor-frame-select-cursor! (screen-root-window screen) window))
|
||
|
||
(define-integrable (screen-window-list screen)
|
||
(editor-frame-windows (screen-root-window screen)))
|
||
|
||
(define-integrable (screen-window0 screen)
|
||
(editor-frame-window0 (screen-root-window screen)))
|
||
|
||
(define-integrable (screen-typein-window screen)
|
||
(editor-frame-typein-window (screen-root-window screen)))
|
||
|
||
(define (window-screen window)
|
||
(editor-frame-screen (window-root-window window)))
|
||
|
||
(define (screen-visible? screen)
|
||
(not (or (screen-deleted? screen)
|
||
(eq? 'UNMAPPED (screen-visibility screen)))))
|
||
|
||
(define-integrable (screen-deleted? screen)
|
||
(eq? 'DELETED (screen-visibility screen)))
|
||
|
||
(define (update-screen! screen display-style)
|
||
(if (display-style/discard-screen-contents? display-style)
|
||
(screen-force-update screen))
|
||
(let ((finished?
|
||
(with-screen-in-update screen display-style
|
||
(lambda ()
|
||
(editor-frame-update-display! (screen-root-window screen)
|
||
display-style)))))
|
||
(if (eq? finished? #t)
|
||
(set-screen-needs-update?! screen #f))
|
||
finished?))
|
||
|
||
;;; 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-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 face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'terminal screen 'output-char
|
||
x y char face))
|
||
((screen-operation/write-char! screen) screen x y char face))
|
||
|
||
(define-integrable (terminal-output-substring screen x y string start end face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'terminal screen 'output-substring
|
||
x y (string-copy string) start end face))
|
||
((screen-operation/write-substring! screen) screen x y string start end
|
||
face))
|
||
|
||
;;;; 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.
|
||
;; (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
|
||
|
||
;; Boolean-vector indicating, for each line, whether there is any
|
||
;; highlighting on the line.
|
||
highlight-enable
|
||
|
||
;; Cursor position.
|
||
(cursor-x #f)
|
||
(cursor-y #f))
|
||
|
||
(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))
|
||
(highlight-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-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-highlight-enable! matrix highlight-enable))
|
||
matrix))
|
||
|
||
(define-integrable (highlight-ref matrix y x)
|
||
(vector-ref (vector-ref (matrix-highlight matrix) y) x))
|
||
|
||
(define-integrable (highlight-set! matrix y x face)
|
||
(vector-set! (vector-ref (matrix-highlight matrix) y) x face))
|
||
|
||
(define-integrable (set-line-highlights! matrix y face)
|
||
(vector-fill! (vector-ref (matrix-highlight matrix) y) face))
|
||
|
||
(define-integrable (set-subline-highlights! matrix y xl xu face)
|
||
(subvector-fill! (vector-ref (matrix-highlight matrix) y) xl xu face))
|
||
|
||
(define-integrable (clear-line-highlights! matrix y)
|
||
(set-line-highlights! matrix y (default-face)))
|
||
|
||
(define-integrable (clear-subline-highlights! matrix y xl xu)
|
||
(set-subline-highlights! matrix y xl xu (default-face)))
|
||
|
||
(define-integrable (copy-line-highlights! m1 y1 m2 y2)
|
||
(vector-move! (vector-ref (matrix-highlight m1) y1)
|
||
(vector-ref (matrix-highlight m2) y2)))
|
||
|
||
(define-integrable (copy-subline-highlights! m1 y1 xl1 xu1 m2 y2 xl2)
|
||
(subvector-move-left! (vector-ref (matrix-highlight m1) y1) xl1 xu1
|
||
(vector-ref (matrix-highlight m2) y2) xl2))
|
||
|
||
(define (line-highlights-cleared? matrix y)
|
||
(vector-filled? (vector-ref (matrix-highlight matrix) y) (default-face)))
|
||
|
||
(define (swap-line-highlights! m1 y1 m2 y2)
|
||
(let ((h (vector-ref (matrix-highlight m1) y1)))
|
||
(vector-set! (matrix-highlight m1) y1
|
||
(vector-ref (matrix-highlight m2) y2))
|
||
(vector-set! (matrix-highlight m2) y2 h)))
|
||
|
||
(define (subline-highlights-uniform? matrix y xl xu)
|
||
(subvector-uniform? (vector-ref (matrix-highlight matrix) y) xl xu))
|
||
|
||
(define (find-subline-highlight-change matrix y xl xu face)
|
||
(subvector-find-next-element-not (vector-ref (matrix-highlight matrix) y)
|
||
xl xu face))
|
||
|
||
(define-integrable (default-face? face)
|
||
(not face))
|
||
|
||
(define-integrable (default-face)
|
||
#f)
|
||
|
||
(define-integrable (highlight-face)
|
||
#t)
|
||
|
||
(define-integrable (line-contents-enabled? matrix y)
|
||
(boolean-vector-ref (matrix-enable matrix) y))
|
||
|
||
(define-integrable (enable-line-contents! matrix y)
|
||
(boolean-vector-set! (matrix-enable matrix) y #t))
|
||
|
||
(define-integrable (disable-line-contents! matrix y)
|
||
(boolean-vector-set! (matrix-enable matrix) y #f))
|
||
|
||
(define-integrable (multiple-line-contents-enabled? matrix yl yu)
|
||
(boolean-subvector-all-elements? (matrix-enable matrix) yl yu #t))
|
||
|
||
(define-integrable (line-highlights-enabled? matrix y)
|
||
(boolean-vector-ref (matrix-highlight-enable matrix) y))
|
||
|
||
(define-integrable (enable-line-highlights! matrix y)
|
||
(boolean-vector-set! (matrix-highlight-enable matrix) y #t))
|
||
|
||
(define-integrable (disable-line-highlights! matrix y)
|
||
(boolean-vector-set! (matrix-highlight-enable matrix) y #f))
|
||
|
||
(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))
|
||
;; Kludge: forget current position of cursor in order to force it to
|
||
;; move. Works around side-effects in terminal that move cursor.
|
||
(let ((current-matrix (screen-current-matrix screen)))
|
||
(set-matrix-cursor-x! current-matrix #f)
|
||
(set-matrix-cursor-y! current-matrix #f)))
|
||
|
||
(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)))
|
||
|
||
(define (screen-output-char screen x y char face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'screen screen 'output-char x y char face))
|
||
(let ((new-matrix (screen-new-matrix screen)))
|
||
(cond ((not (line-contents-enabled? new-matrix y))
|
||
(enable-line-contents! new-matrix y)
|
||
(set-screen-needs-update?! screen true)
|
||
(initialize-new-line-contents screen y)
|
||
(if (not (default-face? face))
|
||
(begin
|
||
(enable-line-highlights! new-matrix y)
|
||
(initialize-new-line-highlight screen y)
|
||
(highlight-set! new-matrix y x face))))
|
||
((line-highlights-enabled? new-matrix y)
|
||
(highlight-set! new-matrix y x face))
|
||
((not (default-face? face))
|
||
(enable-line-highlights! new-matrix y)
|
||
(clear-line-highlights! new-matrix y)
|
||
(highlight-set! new-matrix y x face)))
|
||
(string-set! (vector-ref (matrix-contents new-matrix) y) x char)))
|
||
|
||
(define (screen-get-output-line screen y xl xu face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'screen screen 'output-line y xl xu face))
|
||
(let ((new-matrix (screen-new-matrix screen)))
|
||
(let ((full-line? (and (fix:= xl 0) (fix:= xu (screen-x-size screen)))))
|
||
(cond ((not (line-contents-enabled? new-matrix y))
|
||
(enable-line-contents! new-matrix y)
|
||
(set-screen-needs-update?! screen true)
|
||
(if (not full-line?) (initialize-new-line-contents screen y))
|
||
(if (not (default-face? face))
|
||
(begin
|
||
(enable-line-highlights! new-matrix y)
|
||
(if (not full-line?)
|
||
(initialize-new-line-highlight screen y))
|
||
(set-subline-highlights! new-matrix y xl xu face))))
|
||
((line-highlights-enabled? new-matrix y)
|
||
(if (and full-line? (not face))
|
||
(disable-line-highlights! new-matrix y)
|
||
(set-subline-highlights! new-matrix y xl xu face)))
|
||
((not (default-face? face))
|
||
(enable-line-highlights! new-matrix y)
|
||
(if (not full-line?)
|
||
(set-line-highlights! new-matrix y (default-face)))
|
||
(set-subline-highlights! new-matrix y xl xu face))))
|
||
(vector-ref (matrix-contents new-matrix) y)))
|
||
|
||
(define (screen-output-substring screen x y string start end face)
|
||
(substring-move-left! string start end
|
||
(screen-get-output-line screen y x
|
||
(fix:+ x (fix:- end start))
|
||
face)
|
||
x))
|
||
|
||
(define-integrable (initialize-new-line-contents screen y)
|
||
(if (line-contents-enabled? (screen-current-matrix screen) y)
|
||
(string-move!
|
||
(vector-ref (matrix-contents (screen-current-matrix screen)) y)
|
||
(vector-ref (matrix-contents (screen-new-matrix screen)) y))
|
||
(string-fill!
|
||
(vector-ref (matrix-contents (screen-new-matrix screen)) y)
|
||
#\space)))
|
||
|
||
(define-integrable (initialize-new-line-highlight screen y)
|
||
(if (line-highlights-enabled? (screen-current-matrix screen) y)
|
||
(copy-line-highlights! (screen-current-matrix screen) y
|
||
(screen-new-matrix screen) y)
|
||
(clear-line-highlights! (screen-new-matrix screen) y)))
|
||
|
||
(define (screen-clear-rectangle screen xl xu yl yu face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'screen screen 'clear-rectangle
|
||
xl xu yl yu face))
|
||
(let ((new-matrix (screen-new-matrix screen)))
|
||
(let ((new-contents (matrix-contents new-matrix)))
|
||
(cond ((not (and (fix:= xl 0) (fix:= xu (screen-x-size screen))))
|
||
(let ((current-matrix (screen-current-matrix screen)))
|
||
(let ((current-contents (matrix-contents current-matrix)))
|
||
(do ((y yl (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(if (not (line-contents-enabled? new-matrix y))
|
||
(begin
|
||
(enable-line-contents! new-matrix y)
|
||
(if (line-contents-enabled? current-matrix y)
|
||
(begin
|
||
(string-move! (vector-ref current-contents y)
|
||
(vector-ref new-contents y))
|
||
(substring-fill! (vector-ref new-contents y)
|
||
xl xu #\space))
|
||
(string-fill! (vector-ref new-contents y)
|
||
#\space)))
|
||
(substring-fill! (vector-ref new-contents y)
|
||
xl xu #\space))
|
||
(cond ((line-highlights-enabled? new-matrix y)
|
||
(set-subline-highlights! new-matrix y xl xu face))
|
||
((not (default-face? face))
|
||
(enable-line-highlights! new-matrix y)
|
||
(if (line-highlights-enabled? current-matrix y)
|
||
(copy-line-highlights! current-matrix y
|
||
new-matrix y)
|
||
(clear-line-highlights! new-matrix y))
|
||
(set-subline-highlights! new-matrix y xl xu face))
|
||
((line-highlights-enabled? current-matrix y)
|
||
(copy-line-highlights! current-matrix y new-matrix y)
|
||
(clear-subline-highlights! new-matrix y xl xu)
|
||
(if (not (line-highlights-cleared? new-matrix y))
|
||
(enable-line-highlights! new-matrix y))))))))
|
||
((not (default-face? face))
|
||
(do ((y yl (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(string-fill! (vector-ref new-contents y) #\space)
|
||
(enable-line-contents! new-matrix y)
|
||
(set-line-highlights! new-matrix y face)
|
||
(enable-line-highlights! new-matrix y)))
|
||
(else
|
||
(do ((y yl (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(string-fill! (vector-ref new-contents y) #\space)
|
||
(enable-line-contents! new-matrix y)
|
||
(disable-line-highlights! new-matrix y))))))
|
||
(set-screen-needs-update?! screen true))
|
||
|
||
(define (screen-direct-output-char screen x y char face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'screen screen 'direct-output-char
|
||
x y char face))
|
||
(let ((cursor-x (fix:1+ x))
|
||
(current-matrix (screen-current-matrix screen)))
|
||
(terminal-output-char screen x y char face)
|
||
(terminal-move-cursor screen cursor-x y)
|
||
(terminal-flush screen)
|
||
(string-set! (vector-ref (matrix-contents current-matrix) y) x char)
|
||
(cond ((line-highlights-enabled? current-matrix y)
|
||
(highlight-set! current-matrix y x face))
|
||
((not (default-face? face))
|
||
(enable-line-highlights! current-matrix y)
|
||
(highlight-set! current-matrix y x face)))
|
||
(set-matrix-cursor-x! current-matrix cursor-x)
|
||
(set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
|
||
|
||
(define (screen-direct-output-substring screen x y string start end face)
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'screen screen 'direct-output-substring
|
||
x y (string-copy string) start end face))
|
||
(let ((cursor-x (fix:+ x (fix:- end start)))
|
||
(current-matrix (screen-current-matrix screen)))
|
||
(terminal-output-substring screen x y string start end face)
|
||
(terminal-move-cursor screen cursor-x y)
|
||
(terminal-flush screen)
|
||
(substring-move-left! string start end
|
||
(vector-ref (matrix-contents current-matrix) y) x)
|
||
(cond ((line-highlights-enabled? current-matrix y)
|
||
(set-subline-highlights! current-matrix y x cursor-x face))
|
||
((not (default-face? face))
|
||
(enable-line-highlights! current-matrix y)
|
||
(set-subline-highlights! current-matrix y x cursor-x face)))
|
||
(set-matrix-cursor-x! current-matrix cursor-x)
|
||
(set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
|
||
|
||
(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))
|
||
(new-contents (matrix-contents new-matrix)))
|
||
(do ((y 0 (fix:1+ y)))
|
||
((fix:= y y-size))
|
||
(if (not (line-contents-enabled? new-matrix y))
|
||
(begin
|
||
(let ((c (vector-ref new-contents y)))
|
||
(vector-set! new-contents y (vector-ref current-contents y))
|
||
(vector-set! current-contents y c))
|
||
(enable-line-contents! new-matrix y)
|
||
(if (line-highlights-enabled? current-matrix y)
|
||
(begin
|
||
(swap-line-highlights! new-matrix y current-matrix y)
|
||
(enable-line-highlights! new-matrix y)))))
|
||
(string-fill! (vector-ref current-contents y) #\space)
|
||
(enable-line-contents! current-matrix y)
|
||
(disable-line-highlights! current-matrix y))))
|
||
(invalidate-cursor screen)
|
||
(set-screen-needs-update?! screen true))
|
||
|
||
(define (invalidate-cursor screen)
|
||
(let ((current-matrix (screen-current-matrix screen))
|
||
(new-matrix (screen-new-matrix screen)))
|
||
(if (or (matrix-cursor-x current-matrix)
|
||
(matrix-cursor-y current-matrix))
|
||
(begin
|
||
(set-matrix-cursor-x! new-matrix (matrix-cursor-x current-matrix))
|
||
(set-matrix-cursor-y! new-matrix (matrix-cursor-y current-matrix))
|
||
(set-matrix-cursor-x! current-matrix #f)
|
||
(set-matrix-cursor-y! current-matrix #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 (multiple-line-contents-enabled? current-matrix yl yu)
|
||
(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)))
|
||
(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)
|
||
(cond ((line-highlights-enabled? current-matrix y)
|
||
(enable-line-highlights! current-matrix y*)
|
||
(copy-subline-highlights! current-matrix y xl xu
|
||
current-matrix y* xl))
|
||
((line-highlights-enabled? current-matrix y*)
|
||
(clear-subline-highlights! current-matrix y*
|
||
xl xu))))
|
||
(case scrolled?
|
||
((CLEARED)
|
||
(let ((yu (fix:+ yl amount)))
|
||
(if (and (fix:= xl 0)
|
||
(fix:= xu (screen-x-size screen)))
|
||
(do ((y yl (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(substring-fill! (vector-ref contents y) xl xu
|
||
#\space)
|
||
(disable-line-highlights! current-matrix y))
|
||
(do ((y yl (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(substring-fill! (vector-ref contents y) xl xu
|
||
#\space)
|
||
(if (line-highlights-enabled? current-matrix y)
|
||
(clear-subline-highlights! current-matrix y
|
||
xl xu))))))
|
||
((CLOBBERED-CURSOR)
|
||
(invalidate-cursor screen))))
|
||
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 (multiple-line-contents-enabled? current-matrix yl yu)
|
||
(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)))
|
||
(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)
|
||
(cond ((line-highlights-enabled? current-matrix y*)
|
||
(enable-line-highlights! current-matrix y)
|
||
(copy-subline-highlights! current-matrix y* xl xu
|
||
current-matrix y xl))
|
||
((line-highlights-enabled? current-matrix y)
|
||
(clear-subline-highlights! current-matrix y
|
||
xl xu))))
|
||
(case scrolled?
|
||
((CLEARED)
|
||
(if (and (fix:= xl 0)
|
||
(fix:= xu (screen-x-size screen)))
|
||
(do ((y (fix:- yu amount) (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(substring-fill! (vector-ref contents y) xl xu
|
||
#\space)
|
||
(disable-line-highlights! current-matrix y))
|
||
(do ((y (fix:- yu amount) (fix:1+ y)))
|
||
((fix:= y yu))
|
||
(substring-fill! (vector-ref contents y) xl xu
|
||
#\space)
|
||
(if (line-highlights-enabled? current-matrix y)
|
||
(clear-subline-highlights! current-matrix y
|
||
xl xu)))))
|
||
((CLOBBERED-CURSOR)
|
||
(invalidate-cursor screen))))
|
||
scrolled?))))))
|
||
|
||
(define (with-screen-in-update screen display-style thunk)
|
||
(without-interrupts
|
||
(lambda ()
|
||
(let ((old-flag (screen-in-update? screen)))
|
||
(set-screen-in-update?! screen true)
|
||
(let ((finished?
|
||
((screen-operation/wrap-update! screen)
|
||
screen
|
||
(lambda ()
|
||
(and (thunk)
|
||
(if (memq (screen-visibility screen)
|
||
'(VISIBLE PARTIALLY-OBSCURED))
|
||
(and (or (not (screen-needs-update? screen))
|
||
(and (not (display-style/no-screen-output?
|
||
display-style))
|
||
(screen-update screen display-style)))
|
||
(begin
|
||
(screen-update-cursor screen)
|
||
#t))
|
||
'INVISIBLE))))))
|
||
(set-screen-in-update?! screen old-flag)
|
||
finished?)))))
|
||
|
||
(define (screen-update-cursor screen)
|
||
(let ((x (matrix-cursor-x (screen-new-matrix screen)))
|
||
(y (matrix-cursor-y (screen-new-matrix screen))))
|
||
(if (not (and (eqv? x (matrix-cursor-x (screen-current-matrix screen)))
|
||
(eqv? y (matrix-cursor-y (screen-current-matrix screen)))))
|
||
(terminal-move-cursor screen x y))
|
||
(set-matrix-cursor-x! (screen-current-matrix screen) x)
|
||
(set-matrix-cursor-y! (screen-current-matrix screen) y)))
|
||
|
||
(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 ((new-matrix (screen-new-matrix screen))
|
||
(y-size (screen-y-size screen))
|
||
(preemption-modulus (screen-preemption-modulus screen))
|
||
(discretionary-flush (screen-operation/discretionary-flush screen))
|
||
(halt-update? (editor-halt-update? current-editor)))
|
||
(let loop ((y 0) (m 0))
|
||
(cond ((fix:= y y-size)
|
||
true)
|
||
((not (line-contents-enabled? new-matrix y))
|
||
(loop (fix:+ y 1) m))
|
||
((not (fix:= 0 m))
|
||
(update-line screen y)
|
||
(loop (fix:+ y 1) (fix:- m 1)))
|
||
((begin
|
||
(if discretionary-flush (discretionary-flush screen))
|
||
(and (not force?) (halt-update?)))
|
||
(if (screen-debug-trace screen)
|
||
((screen-debug-trace screen) 'screen screen
|
||
'update-preemption y))
|
||
false)
|
||
(else
|
||
(update-line screen y)
|
||
(loop (fix:+ y 1) preemption-modulus))))))
|
||
|
||
(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 (matrix-contents current-matrix))
|
||
(new-contents (matrix-contents new-matrix)))
|
||
(let ((ccy (vector-ref current-contents y))
|
||
(ncy (vector-ref new-contents y))
|
||
(nhey (line-highlights-enabled? new-matrix y)))
|
||
(cond ((or (not (line-contents-enabled? current-matrix y))
|
||
(if (line-highlights-enabled? current-matrix y)
|
||
(not nhey)
|
||
nhey))
|
||
(if nhey
|
||
(update-line-ignore-current screen y ncy new-matrix x-size)
|
||
(update-line-trivial screen y ncy x-size)))
|
||
(nhey
|
||
(update-line-highlight screen y
|
||
ccy current-matrix
|
||
ncy new-matrix
|
||
x-size))
|
||
(else
|
||
(update-line-no-highlight screen y ccy ncy x-size)))
|
||
(vector-set! current-contents y ncy)
|
||
(enable-line-contents! current-matrix y)
|
||
(vector-set! new-contents y ccy)
|
||
(disable-line-contents! new-matrix y)
|
||
(if nhey
|
||
(begin
|
||
(swap-line-highlights! current-matrix y new-matrix y)
|
||
(enable-line-highlights! current-matrix y)
|
||
(disable-line-highlights! new-matrix y))
|
||
(disable-line-highlights! current-matrix y))))))
|
||
|
||
(define (update-line-ignore-current screen y nline matrix x-size)
|
||
(cond ((not (subline-highlights-uniform? matrix y 0 x-size))
|
||
(let loop ((x 0))
|
||
(let ((face (highlight-ref matrix y x)))
|
||
(let ((x*
|
||
(find-subline-highlight-change matrix y (fix:1+ x) x-size
|
||
face)))
|
||
(if x*
|
||
(begin
|
||
(terminal-output-substring screen x y nline x x* face)
|
||
(loop x*))
|
||
(terminal-output-substring screen x y nline x x-size
|
||
face))))))
|
||
((not (default-face? (highlight-ref matrix y 0)))
|
||
(terminal-output-substring screen 0 y nline 0 x-size
|
||
(highlight-ref matrix y 0)))
|
||
(else
|
||
(update-line-trivial screen y nline x-size))))
|
||
|
||
(define (update-line-trivial screen y nline x-size)
|
||
(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))))
|
||
|
||
(define (update-line-no-highlight screen y oline nline x-size)
|
||
(let ((olen (substring-non-space-end oline 0 x-size))
|
||
(nlen (substring-non-space-end nline 0 x-size)))
|
||
(cond ((fix:= 0 olen)
|
||
(let ((nstart (substring-non-space-start nline 0 nlen)))
|
||
(if (fix:< nstart nlen)
|
||
(terminal-output-substring screen nstart y
|
||
nline nstart nlen false))))
|
||
((fix:= 0 nlen)
|
||
(terminal-clear-line screen nlen y olen))
|
||
(else
|
||
(let ((len (fix:min olen nlen)))
|
||
(let find-mismatch ((x 0))
|
||
(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))
|
||
(find-mismatch (fix:+ x 1)))
|
||
(else
|
||
(let find-match ((x* (fix:+ x 1)))
|
||
(cond ((fix:= x* len)
|
||
(terminal-output-substring
|
||
screen x y nline x nlen false))
|
||
((not (fix:= (vector-8b-ref oline x*)
|
||
(vector-8b-ref nline x*)))
|
||
(find-match (fix:+ x* 1)))
|
||
(else
|
||
;; 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.
|
||
(let find-end-match ((x** (fix:+ x* 1)))
|
||
(cond ((fix:= x** len)
|
||
(if (fix:< (fix:- x** x*) 5)
|
||
(terminal-output-substring
|
||
screen x y nline x nlen false)
|
||
(begin
|
||
(terminal-output-substring
|
||
screen x y nline x x* false)
|
||
(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**))
|
||
(find-end-match (fix:+ x** 1)))
|
||
((fix:< (fix:- x** x*) 5)
|
||
(find-match x**))
|
||
(else
|
||
(terminal-output-substring
|
||
screen x y nline x x* false)
|
||
(find-mismatch x**)))))))))))
|
||
(if (fix:< nlen olen)
|
||
(terminal-clear-line screen nlen y olen))))))
|
||
|
||
(define (screen-line-draw-cost screen y)
|
||
(let ((line (vector-ref (matrix-contents (screen-current-matrix screen)) y)))
|
||
(let ((end (substring-non-space-end line 0 (string-length line))))
|
||
(if (fix:= 0 end)
|
||
0
|
||
(fix:- end (substring-non-space-start line 0 end))))))
|
||
|
||
(define (update-line-highlight screen y oline om nline nm x-size)
|
||
(let find-mismatch ((x 0))
|
||
(if (not (fix:= x x-size))
|
||
(if (and (fix:= (vector-8b-ref oline x) (vector-8b-ref nline x))
|
||
(eqv? (highlight-ref om y x) (highlight-ref nm y x)))
|
||
(find-mismatch (fix:+ x 1))
|
||
(let ((face (highlight-ref nm y x)))
|
||
(let find-match ((x* (fix:+ x 1)))
|
||
(cond ((fix:= x* x-size)
|
||
(terminal-output-substring screen x y nline x x* face))
|
||
((not (eqv? face (highlight-ref nm y x*)))
|
||
(terminal-output-substring screen x y nline x x* face)
|
||
(find-mismatch x*))
|
||
((not (and (eqv? face (highlight-ref om y x*))
|
||
(fix:= (vector-8b-ref oline x*)
|
||
(vector-8b-ref nline x*))))
|
||
(find-match (fix:+ x* 1)))
|
||
(else
|
||
(let find-end-match ((x** (fix:+ x* 1)))
|
||
(cond ((fix:= x** x-size)
|
||
(terminal-output-substring
|
||
screen x y nline x x* face))
|
||
((and (eqv? face (highlight-ref om y x**))
|
||
(fix:= (vector-8b-ref oline x**)
|
||
(vector-8b-ref nline x**)))
|
||
(find-end-match (fix:+ x** 1)))
|
||
((fix:< (fix:- x** x*) 5)
|
||
;; Ignore matches of 4 chars or less.
|
||
(find-match x**))
|
||
(else
|
||
(terminal-output-substring
|
||
screen x y nline x x* face)
|
||
(find-mismatch x**))))))))))))
|
||
|
||
(define-integrable (substring-non-space-start string start end)
|
||
(do ((index start (fix:+ index 1)))
|
||
((or (fix:= end index)
|
||
(not (fix:= (vector-8b-ref string index)
|
||
(char->integer #\space))))
|
||
index)))
|
||
|
||
(define-integrable (substring-non-space-end string start end)
|
||
(do ((index end (fix:- index 1)))
|
||
((or (fix:= start index)
|
||
(not (fix:= (vector-8b-ref string (fix:- index 1))
|
||
(char->integer #\space))))
|
||
index)))
|
||
|
||
(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)))
|