From 3c5c50697e7f26c1e7ecd3d1b80b7bab0445c227 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 17 Jan 2011 01:49:44 -0700 Subject: [PATCH] Replaced the screen struct with SOS classes. * src/edwin/buffrm.scm (buffer-frame-needs-redisplay?): Punted; not in use, and the only user of buffer-window/needs-redisplay?. * src/edwin/bufwfs.scm (draw-region!, %scroll-lines-up) (%scroll-lines-down): Should only be used in the tty-screen-specific output optimizer, and thus may use tty-screen-specific procedures. * src/edwin/bufwin.scm (buffer-window:update-display!): Check that the :update-display! message is sent to buffer-windows on tty-screens only. (buffer-window/direct-update!): Use the new update-screen-window! generic procedure, which dispatches according to the screen type. Moved the original, tty-screen-specific code to a new procedure: update-tty-screen-window!. (buffer-window/redraw!): Genericized; moved the tty-screen-specific code to a new procedure, tty-screen/buffer-window/redraw!. Non-tty-screen windows just punt. (buffer-window/set-buffer!): Call update-modified-tick!, else %window-modified-tick can be #f, causing %notice-window-changes to complain. Found when running Edwin interpretively. The compiled code had no problem with (fix:> (group-modified-tick group) #f)! (update-override-string!): Use the tty-screen-specific procedure tty-screen-get-output-line. The screen is necessarily a tty-screen because this procedure is only called by update-buffer-window!, which is only called by update-tty-screen-window! and buffer-window:update-display!. * src/edwin/bufwiu.scm: Genericized the direct-output procedures, moving their tty-screen-specific code to new procedures named e.g. tty-screen/buffer-window/direct-output-insert-newline!, which can safely call e.g. tty-screen-direct-output-move-cursor. Other types of screens will, probably, not support direct output. (buffer-window/needs-redisplay?): Punted; used only by buffer-frame-needs-redisplay?, which was punted. * src/edwin/edtfrm.scm (set-editor-frame-size!): Conditionalized a tiny bit of tty-screen-specific code. * src/edwin/edwin.pkg: Include SOS. Renamed several procedures from screen-... to tty-screen-... Punted screen-in-update?, screen-needs-update? and with-screen-in-update?. The "needs-update?" and "in-update?" slots are now tty-screen-specific. Export tty-screen? for general use. Export update-screen-window! for use by buffer-window/direct-update!, and with-tty-screen-in-update for use by update-tty-screen-window!. Punted buffer-frame-needs-redisplay?. Export update-tty-screen-window! so it can be used to implement the tty-screen method of update-screen-window!. The method could not be defined directly in bufwin.scm because define-method means something different there. * src/edwin/edwin.sf, src/edwin/make.scm: Load option 'SOS when syntaxing or loading. * src/edwin/modwin.scm, src/edwin/utlwin.scm: The :update-display! message is sent only to windows on tty-screens, so tty-screen-specific procedures can be used. * src/edwin/screen.scm: Replaced the screen struct with SOS classes and . Most of its slots, related to the output optimizer, went into , and code using the old accessor/mutator procedure names was updated. Some uses moved to tty-screen-specific methods of new generic procedures like update-screen!. Some users, e.g. terminal-output-char, obviously assume a tty-screen argument. Others, e.g. screen-move-cursor, changed their names to show their tty-screen-specificity. Thus all users, and users of users, of tty-screen-specific code were updated. * src/edwin/tterm.scm (scroll-draw-cost): Use tty-screen-specific procedure tty-screen-line-draw-cost in, which is only used by console-scroll-lines-up/down!. --- src/edwin/buffrm.scm | 3 - src/edwin/bufwfs.scm | 8 +- src/edwin/bufwin.scm | 24 +++- src/edwin/bufwiu.scm | 63 +++++--- src/edwin/edtfrm.scm | 22 +-- src/edwin/edwin.pkg | 37 ++--- src/edwin/edwin.sf | 1 + src/edwin/make.scm | 1 + src/edwin/modwin.scm | 2 +- src/edwin/screen.scm | 335 ++++++++++++++++++++++++------------------- src/edwin/tterm.scm | 4 +- src/edwin/utlwin.scm | 13 +- 12 files changed, 296 insertions(+), 217 deletions(-) diff --git a/src/edwin/buffrm.scm b/src/edwin/buffrm.scm index 51979c625..37fae7697 100644 --- a/src/edwin/buffrm.scm +++ b/src/edwin/buffrm.scm @@ -159,9 +159,6 @@ USA. (define-integrable (buffer-frame-y-size frame) (window-y-size (frame-text-inferior frame))) -(define-integrable (buffer-frame-needs-redisplay? frame) - (buffer-window/needs-redisplay? (frame-text-inferior frame))) - (define-integrable (window-cursor-enable! frame) (buffer-window/cursor-enable! (frame-text-inferior frame))) diff --git a/src/edwin/bufwfs.scm b/src/edwin/bufwfs.scm index c9540999b..fd71c9b38 100644 --- a/src/edwin/bufwfs.scm +++ b/src/edwin/bufwfs.scm @@ -218,7 +218,7 @@ USA. ;; output so as to avoid consing a dummy image ;; buffer. (line - (screen-get-output-line + (tty-screen-get-output-line screen (if (fix:< y yl) yl y) xl* xu @@ -232,7 +232,7 @@ USA. (cond ((fix:= (vector-ref results 0) end-index) (let ((xl* (vector-ref results 1))) (let ((line - (screen-get-output-line + (tty-screen-get-output-line screen (if (fix:< y yl) yl y) xl* xu false))) @@ -335,7 +335,7 @@ USA. (let ((yl (fix:max (%window-saved-yl window) new-start-y)) (yu (fix:min (%window-saved-yu window) yu))) (and (fix:< amount (fix:- yu yl)) - (screen-scroll-lines-up + (tty-screen-scroll-lines-up (%window-saved-screen window) (fix:+ (%window-saved-xl window) (%window-saved-x-start window)) @@ -412,7 +412,7 @@ USA. (yu (fix:min (%window-saved-yu window) (fix:+ yu amount)))) (and (fix:< amount (fix:- yu yl)) - (screen-scroll-lines-down + (tty-screen-scroll-lines-down (%window-saved-screen window) (fix:+ (%window-saved-xl window) (%window-saved-x-start window)) diff --git a/src/edwin/bufwin.scm b/src/edwin/bufwin.scm index 42f4319ff..300b5faef 100644 --- a/src/edwin/bufwin.scm +++ b/src/edwin/bufwin.scm @@ -728,6 +728,9 @@ USA. (define (buffer-window:update-display! window screen x-start y-start xl xu yl yu display-style) ;; Assumes that interrupts are disabled. + (if (not (tty-screen? screen)) + (error:wrong-type-argument screen "an instance of " + 'BUFFER-WINDOW:UPDATE-DISPLAY!)) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window ':update-display! screen x-start y-start xl xu yl yu @@ -749,14 +752,16 @@ USA. (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-update! display-style)) - (and (%window-saved-screen window) - (begin + (let ((screen (%window-saved-screen window))) + (and screen + (update-screen-window! screen window display-style)))) + +(define (update-tty-screen-window! screen window display-style) (%notice-window-changes! window) - (with-screen-in-update (%window-saved-screen window) display-style + (with-tty-screen-in-update screen display-style (lambda () (let ((finished? - (update-buffer-window! window - (%window-saved-screen window) + (update-buffer-window! window screen (%window-saved-x-start window) (%window-saved-y-start window) (%window-saved-xl window) @@ -766,7 +771,7 @@ USA. display-style))) (if finished? (set-car! (window-redisplay-flags window) #f)) - finished?)))))) + finished?)))) (define (update-buffer-window! window screen x-start y-start xl xu yl yu display-style) @@ -784,6 +789,10 @@ USA. (define (buffer-window/redraw! window) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'force-redraw!)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/redraw! window))) + +(define (tty-screen/buffer-window/redraw! window) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (%set-window-force-redraw?! window #t) (%recache-window-buffer-local-variables! window) @@ -891,6 +900,7 @@ USA. (if (%window-buffer window) (%unset-window-buffer! window)) (%set-window-buffer! window new-buffer) + (update-modified-tick! window) (%recache-window-buffer-local-variables! window) (let ((group (%window-group window))) (add-group-clip-daemon! group (%window-clip-daemon window)) @@ -1177,7 +1187,7 @@ If this is zero, point is always centered after it moves off screen." (results substring-image-results)) (let ((end (string-length string)) (line - (screen-get-output-line screen (fix:+ y-start yl) xl xu #f))) + (tty-screen-get-output-line screen (fix:+ y-start yl) xl xu #f))) (substring-image! string 0 end line xl (fix:- xu 1) #f 0 results diff --git a/src/edwin/bufwiu.scm b/src/edwin/bufwiu.scm index 7c0785399..0017552c1 100644 --- a/src/edwin/bufwiu.scm +++ b/src/edwin/bufwiu.scm @@ -397,19 +397,17 @@ USA. ;;; modified. None of the procedures may be used if the window needs ;;; redisplay. -(define (buffer-window/needs-redisplay? window) - (%notice-window-changes! window) - (or (window-needs-redisplay? window) - (not (%window-saved-screen window)) - (screen-needs-update? (%window-saved-screen window)))) - (define (buffer-window/direct-output-cursor! window) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-cursor!)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/direct-output-cursor! window))) + +(define (tty-screen/buffer-window/direct-output-cursor! window) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let ((x-start (inferior-x-start (%window-cursor-inferior window))) (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-move-cursor + (tty-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))) @@ -420,12 +418,16 @@ USA. (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-forward-char!)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/direct-output-forward-char! window))) + +(define (tty-screen/buffer-window/direct-output-forward-char! window) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (set-window-point-index! window (fix:+ (%window-point-index window) 1)) (let ((x-start (fix:+ (inferior-x-start (%window-cursor-inferior window)) 1)) (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-move-cursor + (tty-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)) @@ -437,12 +439,16 @@ USA. (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-backward-char!)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/direct-output-backward-char! window))) + +(define (tty-screen/buffer-window/direct-output-backward-char! window) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (set-window-point-index! window (fix:- (%window-point-index window) 1)) (let ((x-start (fix:- (inferior-x-start (%window-cursor-inferior window)) 1)) (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-move-cursor + (tty-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)) @@ -453,15 +459,18 @@ USA. (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) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/home-cursor! window))) + +(define (tty-screen/buffer-window/home-cursor! window) + (if (and (fix:<= (%window-saved-xl window) 0) (fix:< 0 (%window-saved-xu window)) (fix:<= (%window-saved-yl window) 0) (fix:< 0 (%window-saved-yu window))) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (screen-direct-output-move-cursor (%window-saved-screen window) - (%window-saved-x-start window) - (%window-saved-y-start window)) + (tty-screen-direct-output-move-cursor + (%window-saved-screen window) + (%window-saved-x-start window) (%window-saved-y-start window)) (set-interrupt-enables! mask) unspecific))) @@ -469,10 +478,14 @@ USA. (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-insert-char! char)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/direct-output-insert-char! window char))) + +(define (tty-screen/buffer-window/direct-output-insert-char! window char) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (let ((x-start (inferior-x-start (%window-cursor-inferior window))) (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-char + (tty-screen-direct-output-char (%window-saved-screen window) (fix:+ (%window-saved-x-start window) x-start) (fix:+ (%window-saved-y-start window) y-start) @@ -492,6 +505,12 @@ USA. ((%window-debug-trace window) 'window window 'direct-output-insert-substring! (string-copy string) start end)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/direct-output-insert-substring! + window string start end))) + +(define (tty-screen/buffer-window/direct-output-insert-substring! + window string start end) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (group-insert-substring! (%window-group window) (%window-point-index window) @@ -499,7 +518,7 @@ USA. (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 + (tty-screen-direct-output-substring (%window-saved-screen window) (fix:+ (%window-saved-x-start window) x-start) (fix:+ (%window-saved-y-start window) y-start) @@ -528,15 +547,19 @@ USA. (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-insert-newline!)) + (if (tty-screen? (%window-saved-screen window)) + (tty-screen/buffer-window/direct-output-insert-newline! window))) + +(define (tty-screen/buffer-window/direct-output-insert-newline! window) (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) (group-insert-char! (%window-group window) (%window-point-index window) #\newline) (let ((end-y (%window-current-end-y window))) - (screen-direct-output-move-cursor (%window-saved-screen window) - (%window-saved-x-start window) - (fix:+ (%window-saved-y-start window) - end-y)) + (tty-screen-direct-output-move-cursor + (%window-saved-screen window) + (%window-saved-x-start window) (fix:+ (%window-saved-y-start window) + end-y)) (%set-window-end-outline! window (make-outline window 0 1 (%window-end-outline window) #f)) diff --git a/src/edwin/edtfrm.scm b/src/edwin/edtfrm.scm index 020780ff3..5ab536f4f 100644 --- a/src/edwin/edtfrm.scm +++ b/src/edwin/edtfrm.scm @@ -87,16 +87,18 @@ USA. (set-inferior-start! typein-inferior 0 y*) (set-inferior-size! root-inferior x y*)) (set-inferior-size! typein-inferior x-size typein-y-size) - (if (< x (screen-x-size screen)) - (screen-clear-rectangle screen - x (screen-x-size screen) - 0 (screen-y-size screen) - false)) - (if (< y (screen-y-size screen)) - (screen-clear-rectangle screen - 0 (screen-x-size screen) - y (screen-y-size screen) - false)))) + (if (tty-screen? screen) + (begin + (if (< x (screen-x-size screen)) + (tty-screen-clear-rectangle screen + x (screen-x-size screen) + 0 (screen-y-size screen) + false)) + (if (< y (screen-y-size screen)) + (tty-screen-clear-rectangle screen + 0 (screen-x-size screen) + y (screen-y-size screen) + false)))))) (define-method editor-frame :set-size! set-editor-frame-size!) diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index aa9648a35..52e45491f 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -28,6 +28,7 @@ USA. (global-definitions "../runtime/runtime") (global-definitions "../xml/xml") +(global-definitions "../sos/sos") (define-package (edwin) (files "utils" @@ -268,26 +269,24 @@ USA. highlight-face initialize-screen-root-window! screen-beep - screen-clear-rectangle + tty-screen-clear-rectangle screen-deleted? - screen-direct-output-char - screen-direct-output-move-cursor - screen-direct-output-substring + tty-screen-direct-output-char + tty-screen-direct-output-move-cursor + tty-screen-direct-output-substring screen-discard! screen-enter! screen-exit! screen-force-update - screen-get-output-line - screen-in-update? - screen-line-draw-cost + tty-screen-get-output-line + tty-screen-line-draw-cost screen-modeline-event! - screen-move-cursor - screen-needs-update? - screen-output-char - screen-output-substring + tty-screen-move-cursor + tty-screen-output-char + tty-screen-output-substring screen-root-window - screen-scroll-lines-down - screen-scroll-lines-up + tty-screen-scroll-lines-down + tty-screen-scroll-lines-up screen-select-cursor! screen-select-window! screen-selected-window @@ -300,11 +299,14 @@ USA. screen-x-size screen-y-size screen? + tty-screen? set-screen-debug-trace! set-screen-root-window! update-screen! - window-screen - with-screen-in-update)) + window-screen) + (export (edwin window) + update-screen-window! + with-tty-screen-in-update)) (define-package (edwin window) (files "window" @@ -354,7 +356,7 @@ USA. window-mark->y window-mark-visible? window-modeline-event! - (window-needs-redisplay? buffer-frame-needs-redisplay?) + window-needs-redisplay? window-override-message window-point window-point-coordinates @@ -382,7 +384,8 @@ USA. editor-frame-update-display! editor-frame-window0 editor-frame-windows - make-editor-frame)) + make-editor-frame + update-tty-screen-window!)) (define-package (edwin window combination) (files "comwin") diff --git a/src/edwin/edwin.sf b/src/edwin/edwin.sf index 833c211e4..4237c2ee7 100644 --- a/src/edwin/edwin.sf +++ b/src/edwin/edwin.sf @@ -25,6 +25,7 @@ USA. |# (load-option 'CREF) +(load-option 'SOS) (if (not (name->package '(EDWIN))) (let ((package-set (package-set-pathname "edwin"))) diff --git a/src/edwin/make.scm b/src/edwin/make.scm index 459456e7e..6591bceb0 100644 --- a/src/edwin/make.scm +++ b/src/edwin/make.scm @@ -28,6 +28,7 @@ USA. (declare (usual-integrations)) +(load-option 'SOS) (with-loader-base-uri (system-library-uri "edwin/") (lambda () (load-package-set "edwin" diff --git a/src/edwin/modwin.scm b/src/edwin/modwin.scm index 805c9b7df..bd15134ab 100644 --- a/src/edwin/modwin.scm +++ b/src/edwin/modwin.scm @@ -54,7 +54,7 @@ USA. (let ((buffer (window-buffer superior))) (modeline-string! superior - (screen-get-output-line + (tty-screen-get-output-line screen y-start xl xu (ref-variable mode-line-inverse-video buffer)) xl xu) diff --git a/src/edwin/screen.scm b/src/edwin/screen.scm index 826390a85..fb7bd781b 100644 --- a/src/edwin/screen.scm +++ b/src/edwin/screen.scm @@ -28,63 +28,76 @@ USA. (declare (usual-integrations)) -(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) +(define-class ( (constructor %make-screen ())) + () + ;; An rtd:editor-frame + (root-window define standard initial-value #f) + ;; 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) + (visibility define standard initial-value 'VISIBLE) + + ;; Width and height in characters cells -- columns and lines. + (x-size define standard initial-value #f) + (y-size define standard initial-value #f) + + ;; Set this variable in the debugger to trace interesting events. + (debug-trace define standard initial-value #f)) + +(define-class ( (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 define standard accessor screen-state) + (operation/beep define accessor) + (operation/clear-line! define accessor) + (operation/clear-rectangle! define accessor) + (operation/clear-screen! define accessor) + (operation/discard! define accessor) + (operation/enter! define accessor) + (operation/exit! define accessor) + (operation/flush! define accessor) + (operation/modeline-event! define accessor) + (operation/discretionary-flush define accessor) + (operation/scroll-lines-down! define accessor) + (operation/scroll-lines-up! define accessor) + (operation/wrap-update! define accessor) + (operation/write-char! define accessor) + (operation/write-cursor! define accessor) + (operation/write-substring! define accessor) + (preemption-modulus define accessor initial-value #f) + (needs-update? define standard initial-value #f) + (in-update? define standard initial-value #f) ;; Description of actual screen contents. - current-matrix + (current-matrix define standard) ;; Description of desired screen contents. - new-matrix + (new-matrix define standard)) - ;; Set this variable in the debugger to trace interesting events. - (debug-trace false)) +(define-method initialize-instance ((screen )) + (call-next-method screen) + (set-tty-screen-current-matrix! screen (make-matrix screen)) + (set-tty-screen-new-matrix! screen (make-matrix screen))) (define (guarantee-screen object procedure) (if (not (screen? object)) @@ -96,35 +109,44 @@ USA. (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))) + (bufferset-find-or-create-buffer bufferset (make-typein-buffer-name -1))))) -(define (screen-beep screen) - ((screen-operation/beep screen) screen)) +(define-generic screen-beep (screen)) + +(define-method screen-beep ((screen )) + (let ((op (tty-screen-operation/beep screen))) (op screen))) -(define (screen-enter! screen) - ((screen-operation/enter! screen) screen) +(define-generic screen-enter! (screen)) + +(define-method screen-enter! ((screen )) + (let ((op (tty-screen-operation/enter! screen))) (op screen)) (screen-modeline-event! screen (screen-selected-window screen) 'SELECT-SCREEN)) -(define (screen-exit! screen) - ((screen-operation/exit! screen) screen) +(define-generic screen-exit! (screen)) + +(define-method screen-exit! ((screen )) + (let ((op (tty-screen-operation/exit! screen))) (op screen)) (screen-modeline-event! screen (screen-selected-window screen) 'DESELECT-SCREEN)) -(define (screen-discard! screen) +(define-generic screen-discard! (screen)) + +(define-method 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)))) + ((tty-screen-operation/discard! screen) screen)))) + +(define-generic screen-modeline-event! (screen window type)) -(define (screen-modeline-event! screen window type) - ((screen-operation/modeline-event! screen) screen window type)) +(define-method screen-modeline-event! ((screen ) window type) + (let ((op (tty-screen-operation/modeline-event! screen))) + (op screen window type))) (define-integrable (screen-selected-window screen) (editor-frame-selected-window (screen-root-window screen))) @@ -158,16 +180,18 @@ USA. (define-integrable (screen-deleted? screen) (eq? 'DELETED (screen-visibility screen))) -(define (update-screen! screen display-style) +(define-generic update-screen! (screen display-style)) + +(define-method 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 + (with-tty-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)) + (set-tty-screen-needs-update?! screen #f)) finished?)) ;;; Interface from update optimizer to terminal: @@ -176,47 +200,47 @@ USA. (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)) + ((tty-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)) + ((tty-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)) + ((tty-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)) + ((tty-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)) + ((tty-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)) + ((tty-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)) + ((tty-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)) + ((tty-screen-operation/write-substring! screen) + screen x y string start end face)) ;;;; Update Optimization @@ -334,49 +358,51 @@ USA. (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) +(define-generic set-screen-size! (screen x-size y-size)) + +(define-method 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)) + (set-tty-screen-current-matrix! screen (make-matrix screen)) + (set-tty-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) +(define (tty-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))) + (let ((new-matrix (tty-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))) + (let ((current-matrix (tty-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) +(define (tty-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))) + (let ((current-matrix (tty-screen-current-matrix screen)) + (new-matrix (tty-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) +(define (tty-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))) + (let ((new-matrix (tty-screen-new-matrix screen))) (cond ((not (line-contents-enabled? new-matrix y)) (enable-line-contents! new-matrix y) - (set-screen-needs-update?! screen true) + (set-tty-screen-needs-update?! screen true) (initialize-new-line-contents screen y) (if (not (default-face? face)) (begin @@ -391,14 +417,14 @@ USA. (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) +(define (tty-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 ((new-matrix (tty-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) + (set-tty-screen-needs-update?! screen true) (if (not full-line?) (initialize-new-line-contents screen y)) (if (not (default-face? face)) (begin @@ -417,36 +443,36 @@ USA. (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) +(define (tty-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) + (tty-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) + (if (line-contents-enabled? (tty-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)) + (vector-ref (matrix-contents (tty-screen-current-matrix screen)) y) + (vector-ref (matrix-contents (tty-screen-new-matrix screen)) y)) (string-fill! - (vector-ref (matrix-contents (screen-new-matrix screen)) y) + (vector-ref (matrix-contents (tty-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))) + (if (line-highlights-enabled? (tty-screen-current-matrix screen) y) + (copy-line-highlights! (tty-screen-current-matrix screen) y + (tty-screen-new-matrix screen) y) + (clear-line-highlights! (tty-screen-new-matrix screen) y))) -(define (screen-clear-rectangle screen xl xu yl yu face) +(define (tty-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-matrix (tty-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-matrix (tty-screen-current-matrix screen))) (let ((current-contents (matrix-contents current-matrix))) (do ((y yl (fix:1+ y))) ((fix:= y yu)) @@ -490,14 +516,14 @@ USA. (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)) + (set-tty-screen-needs-update?! screen true)) -(define (screen-direct-output-char screen x y char face) +(define (tty-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))) + (current-matrix (tty-screen-current-matrix screen))) (terminal-output-char screen x y char face) (terminal-move-cursor screen cursor-x y) (terminal-flush screen) @@ -508,14 +534,14 @@ USA. (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))) + (set-matrix-cursor-x! (tty-screen-new-matrix screen) cursor-x))) -(define (screen-direct-output-substring screen x y string start end face) +(define (tty-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))) + (current-matrix (tty-screen-current-matrix screen))) (terminal-output-substring screen x y string start end face) (terminal-move-cursor screen cursor-x y) (terminal-flush screen) @@ -527,14 +553,16 @@ USA. (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))) + (set-matrix-cursor-x! (tty-screen-new-matrix screen) cursor-x))) -(define (screen-force-update screen) +(define-generic screen-force-update (screen)) + +(define-method 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))) + (current-matrix (tty-screen-current-matrix screen)) + (new-matrix (tty-screen-new-matrix screen))) (terminal-clear-screen screen) (let ((current-contents (matrix-contents current-matrix)) (new-contents (matrix-contents new-matrix))) @@ -554,11 +582,11 @@ USA. (enable-line-contents! current-matrix y) (disable-line-highlights! current-matrix y)))) (invalidate-cursor screen) - (set-screen-needs-update?! screen true)) + (set-tty-screen-needs-update?! screen true)) (define (invalidate-cursor screen) - (let ((current-matrix (screen-current-matrix screen)) - (new-matrix (screen-new-matrix screen))) + (let ((current-matrix (tty-screen-current-matrix screen)) + (new-matrix (tty-screen-new-matrix screen))) (if (or (matrix-cursor-x current-matrix) (matrix-cursor-y current-matrix)) (begin @@ -567,13 +595,13 @@ USA. (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) +(define (tty-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))) + (let ((current-matrix (tty-screen-current-matrix screen))) (and (multiple-line-contents-enabled? current-matrix yl yu) - (not (screen-needs-update? screen)) + (not (tty-screen-needs-update? screen)) (let ((scrolled? (terminal-scroll-lines-down screen xl xu yl yu amount))) (and scrolled? @@ -612,13 +640,13 @@ USA. (invalidate-cursor screen)))) scrolled?)))))) -(define (screen-scroll-lines-up screen xl xu yl yu amount) +(define (tty-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))) + (let ((current-matrix (tty-screen-current-matrix screen))) (and (multiple-line-contents-enabled? current-matrix yl yu) - (not (screen-needs-update? screen)) + (not (tty-screen-needs-update? screen)) (let ((scrolled? (terminal-scroll-lines-up screen xl xu yl yu amount))) (and scrolled? @@ -656,48 +684,60 @@ USA. (invalidate-cursor screen)))) scrolled?)))))) -(define (with-screen-in-update screen display-style thunk) +(define-generic update-screen-window! (screen window display-style) + ;; Mostly for dispatching on the saved-screen of WINDOW in + ;; buffer-window/direct-update!. It is assumed that SCREEN is, + ;; indeed, the saved-screen of WINDOW, a buffer-window. + ) + +(define-method update-screen-window! + ((screen ) window display-style) + (update-tty-screen-window! screen window display-style)) + +(define (with-tty-screen-in-update screen display-style thunk) (without-interrupts (lambda () - (let ((old-flag (screen-in-update? screen))) - (set-screen-in-update?! screen true) + (let ((old-flag (tty-screen-in-update? screen))) + (set-tty-screen-in-update?! screen true) (let ((finished? - ((screen-operation/wrap-update! screen) + ((tty-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 (or (not (tty-screen-needs-update? screen)) (and (not (display-style/no-screen-output? display-style)) - (screen-update screen display-style))) + (tty-screen-update + screen display-style))) (begin - (screen-update-cursor screen) + (tty-screen-update-cursor screen) #t)) 'INVISIBLE)))))) - (set-screen-in-update?! screen old-flag) + (set-tty-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))))) +(define (tty-screen-update-cursor screen) + (let ((x (matrix-cursor-x (tty-screen-new-matrix screen))) + (y (matrix-cursor-y (tty-screen-new-matrix screen)))) + (if (not (and (eqv? x (matrix-cursor-x (tty-screen-current-matrix screen))) + (eqv? y (matrix-cursor-y + (tty-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))) + (set-matrix-cursor-x! (tty-screen-current-matrix screen) x) + (set-matrix-cursor-y! (tty-screen-current-matrix screen) y))) -(define (screen-update screen force?) +(define (tty-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)) + (let ((new-matrix (tty-screen-new-matrix screen)) (y-size (screen-y-size screen)) - (preemption-modulus (screen-preemption-modulus screen)) - (discretionary-flush (screen-operation/discretionary-flush screen)) + (preemption-modulus (tty-screen-preemption-modulus screen)) + (discretionary-flush (tty-screen-operation/discretionary-flush screen)) (halt-update? (editor-halt-update? current-editor))) (let loop ((y 0) (m 0)) (cond ((fix:= y y-size) @@ -719,8 +759,8 @@ USA. (loop (fix:+ y 1) preemption-modulus)))))) (define (update-line screen y) - (let ((current-matrix (screen-current-matrix screen)) - (new-matrix (screen-new-matrix screen)) + (let ((current-matrix (tty-screen-current-matrix screen)) + (new-matrix (tty-screen-new-matrix screen)) (x-size (screen-x-size screen))) (let ((current-contents (matrix-contents current-matrix)) (new-contents (matrix-contents new-matrix))) @@ -835,8 +875,9 @@ USA. (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))) +(define (tty-screen-line-draw-cost screen y) + (let ((line (vector-ref (matrix-contents (tty-screen-current-matrix screen)) + y))) (let ((end (substring-non-space-end line 0 (string-length line)))) (if (fix:= 0 end) 0 diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm index eb9151bde..3a7820656 100644 --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@ -649,7 +649,7 @@ USA. (define (scroll-draw-cost screen yl yu) (do ((yl yl (fix:+ yl 1)) - (cost 0 (fix:+ cost (screen-line-draw-cost screen yl)))) + (cost 0 (fix:+ cost (tty-screen-line-draw-cost screen yl)))) ((fix:= yl yu) cost))) ;;;; Termcap Commands @@ -1203,4 +1203,4 @@ Note that the multiply factors are in tenths of characters. |# (set-terminal-state/delete-line-cost! state delete-line-cost) (set-terminal-state/delete-line-next-cost! state delete-line-next-cost) (set-terminal-state/scroll-region-cost! state scroll-region-cost) - (set-screen-size! screen x-size y-size))))) \ No newline at end of file + (set-screen-size! screen x-size y-size))))) diff --git a/src/edwin/utlwin.scm b/src/edwin/utlwin.scm index 360859283..713a22fdb 100644 --- a/src/edwin/utlwin.scm +++ b/src/edwin/utlwin.scm @@ -36,10 +36,11 @@ USA. (define (blank-window:update-display! window screen x-start y-start xl xu yl yu display-style) window display-style ;ignore - (screen-clear-rectangle screen - (fix:+ x-start xl) (fix:+ x-start xu) - (fix:+ y-start yl) (fix:+ y-start yu) - false) + (tty-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! @@ -76,7 +77,7 @@ USA. (let loop ((y (fix:+ y-start yl))) (if (fix:< y yu) (begin - (screen-output-char screen xl y #\| false) + (tty-screen-output-char screen xl y #\| false) (loop (fix:+ y 1))))))))) true) @@ -112,7 +113,7 @@ USA. (if (and (with-instance-variables cursor-window window () enabled?) (fix:< xl xu) (fix:< yl yu)) - (screen-move-cursor screen x-start y-start)) + (tty-screen-move-cursor screen x-start y-start)) true) (define-method cursor-window :update-display! -- 2.25.1