From: Chris Hanson Date: Mon, 1 Apr 1991 10:08:00 +0000 (+0000) Subject: * Redesign redisplay to get line-contents strings from the screen X-Git-Tag: 20090517-FFI~10795 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=86d127eb78a04c59df720b26b07ee3e1e375fe3c;p=mit-scheme.git * Redesign redisplay to get line-contents strings from the screen abstraction and write directly on those strings, thus avoiding much intermediate copying and the consequent computation. Eliminate as much intermediate consing as possible from the image-generation code. * Eliminate `string-base' window class, which was storing too much information for each buffer line. Instead, use new `outline' abstraction, which keeps track of two pieces of information for each line: the number of characters in the line and the height of the line's image on the screen. This is all that is needed when computing what needs to be redrawn -- all other information is already being stored in the screen abstraction. * New `outline' and `o3' objects are explicitly managed for each window. Instead of being discarded after use, they are saved for reuse later, preventing the generation of garbage during most redisplay. * Fix bug in redisplay: if the image of the last line in a window extends past the bottom of the window, and the point moves, we must check to see if it has gone offscreen, even if it is on a displayed line. --- diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm index 0aff10dae..15ac8975c 100644 --- a/v7/src/edwin/bufwfs.scm +++ b/v7/src/edwin/bufwfs.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.10 1991/03/22 00:30:55 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.11 1991/04/01 10:06:21 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -46,204 +46,341 @@ (declare (usual-integrations)) -(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 - (let ((string (%window-extract-string window start end))) - (make-line-inferior - window - string - (string-image string 0 (%window-tab-width window))))) - (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 start) + (let ((group (%window-group window)) + (start-column 0) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window))) + (let loop + ((outline (o3-outline start)) + (index (o3-index start)) + (y (o3-y start))) + (if (fix:<= y 0) + (begin + (set-o3-outline! start outline) + (set-o3-index! start index) + (set-o3-y! start y)) + (let* ((end-index (fix:- index 1)) + (start-index (%window-line-start-index window end-index)) + (end-column + (group-columns group start-index end-index + start-column tab-width)) + (y-size (column->y-size end-column x-size truncate-lines?)) + (y (fix:- y y-size))) + (draw-region! window + group start-index end-index + start-column + y y-size) + (loop (make-outline window (fix:- end-index start-index) y-size + false outline) + start-index + y)))))) -(define (fill-middle! window - top-inferiors top-start - bottom-inferiors bottom-start) - ;; Assumes non-null TOP-INFERIORS and BOTTOM-INFERIORS. +(define (fill-middle window top-end bot-start) (let ((group (%window-group window)) - (end (%window-group-end-index window)) - (tab-width (%window-tab-width window))) - (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 ((image&index - (group-line-image group start end 0 tab-width))) - (let ((inferior - (make-line-inferior - window - (group-extract-string group - start - (cdr image&index)) - (car image&index)))) - (%set-inferior-y-start! inferior y-start) - (cons - inferior - (loop (fix:+ (cdr image&index) 1) - (fix:+ y-start - (inferior-y-size inferior))))))))))))) - top-inferiors) + (start-column 0) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window)) + (bot-start-index (o3-index bot-start))) + (let loop + ((outline (o3-outline top-end)) + (index (o3-index top-end)) + (y (o3-y top-end))) + (let ((start-index (fix:+ index 1))) + (if (fix:< start-index bot-start-index) + (let ((index&column + (group-line-columns group start-index bot-start-index + start-column tab-width))) + (let ((end-index (car index&column)) + (end-column (cdr index&column))) + (let ((y-size + (column->y-size end-column x-size truncate-lines?))) + (draw-region! window + group start-index end-index + start-column + y y-size) + (loop (make-outline window + (fix:- end-index start-index) + y-size + outline + false) + end-index + (fix:+ y y-size))))) + (begin + (if (not (fix:= start-index bot-start-index)) + (error "Mismatched indexes:" start-index bot-start-index)) + (if (not (fix:= y (o3-y bot-start))) + (error "Mismatched y coordinates:" y (o3-y bot-start))) + (set-outline-next! outline (o3-outline bot-start)) + (set-outline-previous! (o3-outline bot-start) outline))))))) -(define (fill-bottom! window inferiors start) - ;; Assumes non-null INFERIORS. - (let loop ((inferiors inferiors) (start start)) - (let ((end - (fix:+ start - (string-base:string-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 (fill-bottom window end) + (let ((group (%window-group window)) + (start-column 0) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window)) + (y-size (window-y-size window)) + (group-end (%window-group-end-index window))) + (let loop + ((outline (o3-outline end)) + (index (o3-index end)) + (y (o3-y end))) + (if (or (fix:>= index group-end) (fix:>= y y-size)) + (begin + (set-o3-outline! end outline) + (set-o3-index! end index) + (set-o3-y! end y)) + (let ((start-index (fix:+ index 1))) + (let ((index&column + (group-line-columns group start-index group-end + start-column tab-width))) + (let ((end-index (car index&column)) + (end-column (cdr index&column))) + (let ((y-size + (column->y-size end-column x-size truncate-lines?))) + (draw-region! window + group start-index end-index + start-column + y y-size) + (loop (make-outline window + (fix:- end-index start-index) + y-size + outline + false) + end-index + (fix:+ y y-size)))))))))) -(define (generate-line-inferiors window start y-start) - ;; Assumes (FIX:< Y-START (WINDOW-Y-SIZE WINDOW)) - (let ((y-size (window-y-size window)) - (group (%window-group window)) - (end (%window-group-end-index window)) - (tab-width (%window-tab-width window))) - (let loop ((y-start y-start) (start start)) - (let ((image&index (group-line-image group start end 0 tab-width))) - (let ((inferior - (make-line-inferior window - (group-extract-string group - start - (cdr image&index)) - (car image&index)))) - (%set-inferior-y-start! inferior y-start) - (cons inferior - (let ((y-start (fix:+ y-start (inferior-y-size inferior)))) - (if (and (fix:< (cdr image&index) end) - (fix:< y-start y-size)) - (loop y-start (fix:+ (cdr image&index) 1)) - (begin - (set-current-end-index! window (cdr image&index)) - '()))))))))) +(define (generate-outlines window start end) + (let ((group (%window-group window)) + (start-column 0) + (tab-width (%window-tab-width window)) + (truncate-lines? (%window-truncate-lines? window)) + (x-size (window-x-size window)) + (y-size (window-y-size window)) + (group-end (%window-group-end-index window))) + (let loop ((outline false) (start-index (o3-index start)) (y (o3-y start))) + (let ((index&column + (group-line-columns group start-index group-end + start-column tab-width))) + (let ((end-index (car index&column)) + (end-column (cdr index&column))) + (let ((line-y (column->y-size end-column x-size truncate-lines?))) + (draw-region! window + group start-index end-index + start-column + y line-y) + (let ((outline* + (make-outline window + (fix:- end-index start-index) + line-y + outline + false)) + (y (fix:+ y line-y))) + (if (not outline) + (set-o3-outline! start outline*)) + (if (or (fix:>= end-index group-end) (fix:>= y y-size)) + (begin + (set-o3-outline! end outline*) + (set-o3-index! end end-index) + (set-o3-y! end y)) + (loop outline* (fix:+ end-index 1) y))))))))) -(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 (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 (scroll-lines-down! window 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)))) +(define (draw-region! window + group start-index end-index + start-column + y y-size) + (clip-window-region-1 (fix:- (%window-saved-yl window) y) + (fix:- (%window-saved-yu window) y) + y-size + (lambda (yl yu) + (let ((screen (%window-saved-screen window)) + (xl + (fix:+ (%window-saved-x-start window) + (%window-saved-xl window))) + (xu + (fix:+ (%window-saved-x-start window) + (%window-saved-xu window))) + (y-start (fix:+ (%window-saved-y-start window) y)) + (truncate-lines? (%window-truncate-lines? window)) + (tab-width (%window-tab-width window)) + (results substring-image-results)) + (let ((xm (fix:- xu 1)) + (yu (fix:+ y-start yu))) + (let ((columns (fix:- xm xl))) + (let loop + ((index start-index) + (column-offset (fix:- start-column xl)) + (partial 0) + (y (fix:+ y-start yl))) + (if (fix:< y yu) + (let ((line (screen-get-output-line screen y xl xu false))) + (let ((fill-line + (lambda (index xl) + (group-image! group index end-index + line xl xm + tab-width column-offset results) + (cond ((fix:= (vector-ref results 0) end-index) + (do ((x (vector-ref results 1) + (fix:+ x 1))) + ((fix:= x xu)) + (string-set! line x #\space))) + (truncate-lines? + (string-set! line xm #\$)) + (else + (string-set! line xm #\\) + (loop (vector-ref results 0) + (fix:+ column-offset columns) + (vector-ref results 2) + (fix:+ y 1))))))) + (if (fix:= partial 0) + (fill-line index xl) + (begin + (partial-image! (group-right-char group index) + partial + line xl xm + tab-width) + (if (fix:> partial columns) + (begin + (string-set! line xm #\\) + (loop index + (fix:+ column-offset columns) + (fix:- partial columns) + (fix:+ y 1))) + (fill-line (fix:+ index 1) + (fix:+ xl partial))))))))))))))) -(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 start end new-start-y) + (if (fix:>= new-start-y 0) + (%scroll-lines-up window start end new-start-y) + (let ((start-outline (o3-outline start)) + (amount (fix:- (o3-y start) new-start-y))) + (if (fix:<= (fix:- (o3-y end) amount) 0) + (begin + (deallocate-outlines! window start-outline (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false) + (let loop + ((outline start-outline) + (index (o3-index start)) + (new-start-y new-start-y)) + (let ((new-end-y (fix:+ new-start-y (outline-y-size outline)))) + (cond ((fix:< new-end-y 0) + (loop (outline-next outline) + (fix:+ index + (fix:+ (outline-index-length outline) 1)) + new-end-y)) + ((fix:> new-end-y 0) + (set-o3-outline! start outline) + (set-o3-index! start index) + (set-o3-y! start (fix:+ new-start-y amount)) + (if (not (eq? start-outline outline)) + (deallocate-outlines! window + start-outline + (outline-previous outline))) + (%scroll-lines-up window start end new-start-y)) + (else + (set-o3-outline! start (outline-next outline)) + (set-o3-index! + start + (fix:+ (fix:+ index (outline-index-length outline)) + 1)) + (set-o3-y! start amount) + (deallocate-outlines! window start-outline outline) + (%scroll-lines-up window start end new-end-y))))))))) -(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 (%scroll-lines-up window start end new-start-y) + (let ((yl (o3-y start)) + (yu (o3-y end))) + (let ((amount (fix:- yl new-start-y))) + (if (and (fix:< yl (%window-saved-yu window)) + (fix:< (%window-saved-yl window) yu) + (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 + (%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)))) + (begin + (set-o3-y! start new-start-y) + (set-o3-y! end (fix:- yu amount)) + true) + (begin + (deallocate-outlines! window (o3-outline start) (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false))))) + +(define (scroll-lines-down window start end new-start-y) + (let ((y-size (window-y-size window)) + (start-outline (o3-outline start)) + (end-outline (o3-outline end))) + (if (fix:>= new-start-y y-size) + (begin + (deallocate-outlines! window start-outline end-outline) + (deallocate-o3! window start) + (deallocate-o3! window end) + false) + (begin + (let loop + ((outline start-outline) + (start-index (o3-index start)) + (start-y new-start-y)) + (let ((end-y (fix:+ start-y (outline-y-size outline)))) + (cond ((fix:>= end-y y-size) + (if (not (eq? outline end-outline)) + (deallocate-outlines! window + (outline-next outline) + end-outline)) + (set-o3-outline! end outline) + (set-o3-index! end + (fix:+ start-index + (outline-index-length outline))) + (set-o3-y! end + (fix:- end-y + (fix:- new-start-y (o3-y start))))) + ((not (eq? outline end-outline)) + (loop (outline-next outline) + (fix:+ (fix:+ start-index + (outline-index-length outline)) + 1) + end-y))))) + (%scroll-lines-down window start end new-start-y))))) -(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)) +(define (%scroll-lines-down window start end new-start-y) + (let ((yl (o3-y start)) + (yu (o3-y end))) + (let ((amount (fix:- new-start-y yl))) + (if (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)))) + (begin + (set-o3-y! start new-start-y) + (set-o3-y! end (fix:+ yu amount)) + true) (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 + (deallocate-outlines! window (o3-outline start) (o3-outline end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + false))))) \ No newline at end of file diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index 8b987f085..3bac1f0f8 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.290 1991/03/22 00:31:01 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.291 1991/04/01 10:06:30 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -83,24 +83,43 @@ ;; 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 STRING-BASE) that displays the message. - override-inferior + ;; The topmost and bottommost OUTLINE structures for this window, + ;; respectively. If only one line is shown, these are EQ?. + start-outline + end-outline - ;; A list of the inferior windows (of class STRING-BASE) that are - ;; currently displaying the portion of the buffer that is visible - ;; in this window. - line-inferiors + ;; A previously allocated OUTLINE structure that is available for + ;; reallocation. Any other free OUTLINE structures are chained to + ;; this one through its NEXT field. + free-outline - ;; This permanent mark records where the first line inferior - ;; starts. + ;; A permanent right-inserting mark at the beginning of the text + ;; line modelled by START-OUTLINE. current-start-mark - ;; This permanent mark records where the last line inferior ends. + ;; A permanent left-inserting mark at the end of the text line + ;; modelled by END-OUTLINE. current-end-mark + + ;; The Y position, relative to the window, of the top edge of + ;; START-OUTLINE. A non-positive number. + current-start-y + + ;; The Y position, relative to the window, of the bottom edge of + ;; END-OUTLINE. A positive number. + current-end-y + + ;; A previously allocated O3 structure that is available for + ;; reallocation. Any other free O3 structures are chained to this + ;; one through its OUTLINE field. + free-o3 + ;; This is normally #F. However, when the normal display of the + ;; buffer is overridden by a one-line message, as is commonly done + ;; for the typein window, this variable contains the message + ;; string. + override-string + ;; This permanent mark is the smallest that is visible in the ;; window. If the window's start is not known, this is #F. start-mark @@ -217,20 +236,27 @@ (define-integrable (%set-window-blank-inferior! window inferior) (with-instance-variables buffer-window window (inferior) (set! blank-inferior inferior))) + +(define-integrable (%window-start-outline window) + (with-instance-variables buffer-window window () start-outline)) -(define-integrable (%window-override-inferior window) - (with-instance-variables buffer-window window () override-inferior)) +(define-integrable (%set-window-start-outline! window outline) + (with-instance-variables buffer-window window (outline) + (set! start-outline outline))) -(define-integrable (%set-window-override-inferior! window inferior) - (with-instance-variables buffer-window window (inferior) - (set! override-inferior inferior))) - -(define-integrable (%window-line-inferiors window) - (with-instance-variables buffer-window window () line-inferiors)) +(define-integrable (%window-end-outline window) + (with-instance-variables buffer-window window () end-outline)) -(define-integrable (%set-window-line-inferiors! window inferiors) - (with-instance-variables buffer-window window (inferiors) - (set! line-inferiors inferiors))) +(define-integrable (%set-window-end-outline! window outline) + (with-instance-variables buffer-window window (outline) + (set! end-outline outline))) + +(define-integrable (%window-free-outline window) + (with-instance-variables buffer-window window () free-outline)) + +(define-integrable (%set-window-free-outline! window outline) + (with-instance-variables buffer-window window (outline) + (set! free-outline outline))) (define-integrable (%window-current-start-mark window) (with-instance-variables buffer-window window () current-start-mark)) @@ -252,6 +278,34 @@ (with-instance-variables buffer-window window (mark) (set! current-end-mark mark))) +(define-integrable (%window-current-start-y window) + (with-instance-variables buffer-window window () current-start-y)) + +(define-integrable (%set-window-current-start-y! window y) + (with-instance-variables buffer-window window (y) + (set! current-start-y y))) + +(define-integrable (%window-current-end-y window) + (with-instance-variables buffer-window window () current-end-y)) + +(define-integrable (%set-window-current-end-y! window y) + (with-instance-variables buffer-window window (y) + (set! current-end-y y))) + +(define-integrable (%window-free-o3 window) + (with-instance-variables buffer-window window () free-o3)) + +(define-integrable (%set-window-free-o3! window o3) + (with-instance-variables buffer-window window (o3) + (set! free-o3 o3))) + +(define-integrable (%window-override-string window) + (with-instance-variables buffer-window window () override-string)) + +(define-integrable (%set-window-override-string! window string) + (with-instance-variables buffer-window window (string) + (set! override-string string))) + (define-integrable (%window-start-mark window) (with-instance-variables buffer-window window () start-mark)) @@ -403,6 +457,98 @@ (with-instance-variables buffer-window window (procedure) (set! debug-trace procedure))) +;;;; Outlines + +(define-structure (outline (constructor %make-outline)) + ;; The number of characters in the text line. This is exclusive of + ;; the newlines at the line's beginning and end, if any. + index-length + + ;; The number of screen lines that are occupied by this text line. + y-size + + ;; A pointer to the previous outline structure, the one representing + ;; the text line that appears directly above this line. + previous + + ;; A pointer to the next outline structure, the one representing the + ;; text line that appears directly below this line. + next) + +(define (make-outline window index-length y-size previous next) + (let ((outline + (let ((outline (%window-free-outline window))) + (if (%window-free-outline window) + (begin + (let ((free (outline-next outline))) + (if free (set-outline-previous! free false)) + (%set-window-free-outline! window free)) + (set-outline-index-length! outline index-length) + (set-outline-y-size! outline y-size) + (set-outline-previous! outline previous) + (set-outline-next! outline next) + outline) + (%make-outline index-length y-size previous next))))) + (if previous (set-outline-next! previous outline)) + (if next (set-outline-previous! next outline)) + outline)) + +(define (deallocate-outlines! window start-outline end-outline) + (let ((free-outline (%window-free-outline window))) + (if (outline-next end-outline) + (set-outline-previous! (outline-next end-outline) false)) + (set-outline-next! end-outline free-outline) + (if free-outline + (set-outline-previous! free-outline end-outline))) + (if (outline-previous start-outline) + (set-outline-next! (outline-previous start-outline) false)) + (set-outline-previous! start-outline false) + (%set-window-free-outline! window start-outline)) + +(define-integrable (outline-last outline) + (do ((outline outline (outline-next outline))) + ((not (outline-next outline)) outline))) + +(define-integrable (outline-end-y outline start-y) + (do ((outline outline (outline-next outline)) + (y start-y (fix:+ y (outline-y-size outline)))) + ((not outline) y))) + +(define-integrable (outline-start-y outline end-y) + (do ((outline outline (outline-previous outline)) + (y end-y (fix:- y (outline-y-size outline)))) + ((not outline) y))) + +(define-structure (o3 + (constructor %make-o3) + (print-procedure + (unparser/standard-method 'O3 + (lambda (state o3) + (unparse-string state "index: ") + (unparse-object state (o3-index o3)) + (unparse-string state " y: ") + (unparse-object state (o3-y o3)) + (unparse-string state " ") + (unparse-object state (o3-outline o3)))))) + outline + index + y) + +(define (make-o3 window outline index y) + (let ((o3 (%window-free-o3 window))) + (if o3 + (begin + (%set-window-free-o3! window (o3-outline o3)) + (set-o3-outline! o3 outline) + (set-o3-index! o3 index) + (set-o3-y! o3 y) + o3) + (%make-o3 outline index y)))) + +(define (deallocate-o3! window o3) + (set-o3-outline! o3 (%window-free-o3 window)) + (%set-window-free-o3! window o3)) + ;;;; Narrowing (define-integrable (%window-group-start-mark window) @@ -505,6 +651,7 @@ (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'set-size! x y)) (buffer-window/redraw! window) + (%release-window-outlines! window) (set-window-size! window x y) (%set-window-point-moved?! window 'SINCE-START-SET)) @@ -519,6 +666,7 @@ (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'set-y-size! y)) (buffer-window/redraw! window) + (%release-window-outlines! window) (set-window-y-size! window y) (%set-window-point-moved?! window 'SINCE-START-SET)) @@ -567,15 +715,10 @@ (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) + (if (%window-override-string window) + (update-override-string! window screen x-start y-start xl xu yl yu) + (update-outlines! window)) + (and (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) @@ -607,11 +750,18 @@ (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) + (%release-window-outlines! window) + (%set-window-free-o3! window false) + (%set-window-override-string! 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 (%release-window-outlines! window) + (%set-window-start-outline! window false) + (%set-window-end-outline! window false) + (%set-window-free-outline! window false)) + (define (%clear-window-buffer-state! window) (%set-window-buffer! window false) (%set-window-point! window false) @@ -621,19 +771,18 @@ (%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-start-outline window) + (begin + (deallocate-outlines! window + (%window-start-outline window) + (%window-end-outline window)) + (%set-window-start-outline! window false) + (%set-window-end-outline! window false))) (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) + (mark-temporary! (%window-current-end-mark window)) (%set-window-current-end-mark! window false))) (%set-window-saved-screen! window false) (%clear-window-outstanding-changes! window)) @@ -642,14 +791,14 @@ (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) + (mark-temporary! (%window-end-changes-mark window)) (%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) + (mark-temporary! (%window-end-clip-mark window)) (%set-window-end-clip-mark! window false)))) (define (%recache-window-buffer-local-variables! window) @@ -827,8 +976,8 @@ (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) + (mark-temporary! (%window-start-mark window)) (%set-window-start-mark! window false) (%set-window-start-line-y! window 0)) @@ -854,9 +1003,9 @@ (not (%window-current-start-mark window)) (fix:< point (%window-current-start-index window)) (fix:> point (%window-current-end-index window)) - (fix:< (inferior-y-start - (car (%window-line-inferiors window))) - 0)) + (fix:< (%window-current-start-y window) 0) + (fix:> (%window-current-end-y window) + (window-y-size window))) (let ((start-y (%window-start-line-y window)) (y-size (window-y-size window)) (scroll-step (ref-variable scroll-step))) @@ -909,34 +1058,10 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." (and (real? cursor-centering-point) (<= 0 cursor-centering-point 100)))) -;;;; Line Inferiors - -(define (make-line-inferior window string image) - (let ((window* (make-object string-base)) - (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) - (string-base:initialize! window* - string - image - (window-x-size window) - (%window-truncate-lines? window) - (%window-tab-width window)) - (%set-inferior-x-start! inferior 0) - inferior))) - -(define-integrable (line-inferior-length inferior) - (fix:+ (string-base:string-length (inferior-window inferior)) 1)) +;;;; Override Message (define (buffer-window/override-message window) - (let ((inferior (%window-override-inferior window))) - (and inferior - (let ((window (inferior-window inferior))) - (string-head (string-base:string window) - (string-base:string-length window)))))) + (%window-override-string window)) (define (buffer-window/set-override-message! window message) (if (%window-debug-trace window) @@ -944,89 +1069,94 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." message)) (without-interrupts (lambda () - (let ((inferior - (make-line-inferior window - message - (string-image message 0 false)))) - (%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)))) + (%set-window-override-string! window message) + (window-needs-redisplay! window)))) (define (buffer-window/clear-override-message! window) - (if (%window-override-inferior window) + (if (%window-override-string 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) + (%set-window-override-string! window false) + (update-blank-inferior! window true) (update-cursor! window) - (inferiors-changed! window) - (for-each-inferior window inferior-needs-redisplay!)))))) + (window-needs-redisplay! window)))))) + +(define (update-override-string! window screen x-start y-start xl xu yl yu) + ;; This should probably update like any other string, paying + ;; attention to TRUNCATE-LINES? and going to multiple lines if + ;; necessary. For now we'll force it to be truncated to a single + ;; line, which is fine as long as the minibuffer is only one line. + (if (and (fix:= yl 0) (not (fix:= yu 0))) + (let ((string (%window-override-string window)) + (xl (fix:+ x-start xl)) + (xu (fix:+ x-start xu)) + (results substring-image-results)) + (let ((end (string-length string)) + (line + (screen-get-output-line screen (fix:+ y-start yl) xl xu + false))) + (substring-image! string 0 end + line xl (fix:- xu 1) + false 0 results) + (if (fix:= (vector-ref results 0) end) + (do ((x (vector-ref results 1) (fix:+ x 1))) + ((fix:= x xu)) + (string-set! line x #\space)) + (string-set! line (fix:- xu 1) #\$)) + (set-inferior-start! (%window-cursor-inferior window) + (vector-ref results 1) + 0)))) + (%update-blank-inferior! window 1 true)) ;;;; 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) +(define (set-outlines! window start end) + (%set-window-start-outline! window (o3-outline start)) + (%set-window-end-outline! window (o3-outline end)) (if (%window-current-start-mark window) (begin - (set-mark-position! (%window-current-start-mark window) - (mark-position (%window-start-line-mark window))) - (set-mark-index-integrable! (%window-current-end-mark window) end)) + (set-mark-index-integrable! (%window-current-start-mark window) + (o3-index start)) + (set-mark-index-integrable! (%window-current-end-mark window) + (o3-index end))) (begin (%set-window-current-start-mark! window - (mark-permanent-copy (%window-start-line-mark window))) + (%make-permanent-mark (%window-group window) (o3-index start) false)) (%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))))))) + (%make-permanent-mark (%window-group window) (o3-index end) true)))) + (%set-window-current-start-y! window (o3-y start)) + (%set-window-current-end-y! window (o3-y end)) + (deallocate-o3! window start) + (deallocate-o3! window end) + (%clear-window-outstanding-changes! window) + (update-blank-inferior! window true) + (update-cursor! window) + (%window-modeline-event! window 'SET-OUTLINES)) + +(define (update-blank-inferior! window signal?) + (%update-blank-inferior! window (%window-current-end-y window) signal?)) + +(define (%update-blank-inferior! window end-y signal?) + (let ((inferior (%window-blank-inferior window))) + (if (fix:< end-y (window-y-size window)) + (begin + (%set-window-x-size! (inferior-window inferior) + (window-x-size window)) + (%set-window-y-size! (inferior-window inferior) + (fix:- (window-y-size window) end-y)) + (%set-inferior-x-start! inferior 0) + (%set-inferior-y-start! inferior end-y) + (if signal? + (setup-redisplay-flags! (inferior-redisplay-flags inferior)))) + (begin + (%set-inferior-x-start! inferior false) + (%set-inferior-y-start! inferior false))))) (define (update-cursor! window) (let ((xy (buffer-window/point-coordinates window))) diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm index 889309a90..6c0df769d 100644 --- a/v7/src/edwin/bufwiu.scm +++ b/v7/src/edwin/bufwiu.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.16 1991/03/22 00:31:07 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.17 1991/04/01 10:06:42 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -57,7 +57,7 @@ (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'change-daemon group start end)) - ;; Record changes that intersect the current line inferiors. + ;; Record changes that intersect the current outlines. (if (and (not (%window-force-redraw? window)) (fix:<= (%window-current-start-index window) end) (fix:<= start (%window-current-end-index window))) @@ -162,7 +162,7 @@ ;;;; Update -(define (recompute-image! window) +(define (update-outlines! window) (%guarantee-start-mark! window) (if (%window-force-redraw? window) (begin @@ -189,201 +189,212 @@ (%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-bottom! window end-changes end) (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)))))) + (preserve-top! window start start-changes))))) (else - (preserve-all! window start)))))) - + (preserve-all! window start end)))))) + (define-integrable (preserve-nothing! window) - (set-line-inferiors! - window - (generate-line-inferiors window - (%window-start-line-index window) - (%window-start-line-y window)))) + (regenerate-outlines window + (%window-start-line-index window) + (%window-start-line-y window))) + +(define (preserve-top! window start start-changes) + (let ((start-outline (%window-start-outline window)) + (start-y (%window-current-start-y window))) + (let ((last-unchanged + (last-unchanged-outline start-outline + start + start-changes))) + (deallocate-outlines! window + (outline-next last-unchanged) + (%window-end-outline window)) + (preserve-contiguous-region! window + (make-o3 window start-outline start start-y) + (make-o3 window + last-unchanged + (fix:- start-changes 1) + (outline-end-y start-outline + start-y)))))) -(define (preserve-contiguous-region! window inferiors start) +(define (preserve-bottom! window end-changes end) + (let ((end-outline (%window-end-outline window)) + (end-y (%window-current-end-y window))) + (let ((first-unchanged + (first-unchanged-outline end-outline end end-changes))) + (if (not (eq? first-unchanged (%window-start-outline window))) + (deallocate-outlines! window + (%window-start-outline window) + (outline-previous first-unchanged))) + (preserve-contiguous-region! window + (make-o3 window + first-unchanged + (fix:+ end-changes 1) + (outline-start-y end-outline + end-y)) + (make-o3 window end-outline end end-y))))) + +(define (preserve-contiguous-region! window start end) (let ((wlstart (%window-start-line-index window)) (wlsy (%window-start-line-y window))) - (set-line-inferiors! - window - (with-values - (lambda () (maybe-scroll window inferiors start wlstart wlsy)) - (lambda (inferiors start) - (if (null? inferiors) - (generate-line-inferiors window wlstart wlsy) - (fill-edges! window inferiors start))))))) + (if (maybe-scroll window start end wlstart wlsy) + (fill-edges window start end) + (regenerate-outlines window wlstart wlsy)))) -(define-integrable (fill-edges! window inferiors start) - (fill-top window (fill-bottom! window inferiors start) 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-head (%window-start-outline window)) + (bot-tail (%window-end-outline window)) + (top-start-y (%window-current-start-y window)) + (bot-end-y (%window-current-end-y window))) + (let ((top-tail (last-unchanged-outline top-head start start-changes)) + (bot-head (first-unchanged-outline bot-tail end end-changes))) + (deallocate-outlines! window + (outline-next top-tail) + (outline-previous bot-head)) + (let ((top-start (make-o3 window top-head start top-start-y)) + (top-end + (make-o3 window + top-tail + (fix:- start-changes 1) + (outline-end-y top-head top-start-y))) + (bot-start + (make-o3 window + bot-head + (fix:+ end-changes 1) + (outline-start-y bot-tail bot-end-y))) + (bot-end (make-o3 window bot-tail end bot-end-y))) + (if (maybe-scroll window top-start top-end wlstart wlsy) + (if (maybe-scroll window bot-start bot-end wlstart wlsy) + (begin + (fill-middle window top-end bot-start) + (deallocate-o3! window top-end) + (deallocate-o3! window bot-start) + (fill-edges window top-start bot-end)) + (fill-edges window top-start top-end)) + (if (maybe-scroll window bot-start bot-end wlstart wlsy) + (fill-edges window bot-start bot-end) + (regenerate-outlines window wlstart wlsy))))))) -(define (preserve-all! window start) +(define (preserve-all! window start-index end-index) (let ((wlstart (%window-start-line-index window)) (wlsy (%window-start-line-y window)) - (inferiors (%window-line-inferiors window))) - (let ((regenerate - (lambda () - (set-line-inferiors! - window - (generate-line-inferiors window wlstart wlsy)))) - (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))))))) + (start-y (%window-current-start-y window)) + (end-y (%window-current-end-y window))) + (let ((scroll-down + (lambda (y) + (let ((start + (make-o3 window + (%window-start-outline window) + start-index + start-y)) + (end + (make-o3 window + (%window-end-outline window) + end-index + end-y))) + (if (scroll-lines-down window start end y) + (begin + (fill-top window start) + (set-outlines! window start end)) + (regenerate-outlines window wlstart wlsy))))) (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) + (lambda (y) + (let ((start + (make-o3 window + (%window-start-outline window) + start-index + start-y)) + (end + (make-o3 window + (%window-end-outline window) + end-index + end-y))) + (if (scroll-lines-up window start end y) + (begin + (fill-bottom window end) + (set-outlines! window start end)) + (regenerate-outlines window wlstart wlsy)))))) + (cond ((fix:= wlstart start-index) + (cond ((fix:= wlsy start-y) + (%clear-window-outstanding-changes! window) + (if (%window-point-moved? window) + (begin + (%set-window-point-moved?! window false) + (update-cursor! window)))) + ((fix:< wlsy start-y) + (scroll-up wlsy)) + (else + (scroll-down wlsy)))) + ((fix:< wlstart start-index) (let ((y - (predict-y-limited window wlstart wlsy start - (inferior-y-start (car inferiors)) + (predict-y-limited window wlstart wlsy start-index start-y (window-y-size window)))) (if (not y) - (regenerate) + (regenerate-outlines window wlstart wlsy) (scroll-down y)))) (else (let ((y - (predict-y-limited - window wlstart wlsy start - (fix:- 1 - (fix:- (inferior-y-end (car (last-pair inferiors))) - (inferior-y-start (car inferiors)))) - 1))) + (predict-y-limited window wlstart wlsy start-index + (fix:- 1 (fix:- end-y start-y)) + 1))) (if (not y) - (regenerate) + (regenerate-outlines window wlstart wlsy) (scroll-up y)))))))) -(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 () - (maybe-scroll window top-inferiors start wlstart wlsy)) - (lambda (top-inferiors top-start) - (with-values - (lambda () - (maybe-scroll window bottom-inferiors (fix:+ end-changes 1) - wlstart wlsy)) - (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))))))))))) +(define (first-unchanged-outline end-outline end end-changes) + (let loop ((outline end-outline) (end end)) + (let ((end-next (fix:- end (fix:+ (outline-index-length outline) 1)))) + (if (fix:> end-next end-changes) + (begin + (if (not (outline-previous outline)) + (error "can't find END-CHANGES")) + (loop (outline-previous outline) end-next)) + (begin + (if (not (fix:= end-next end-changes)) + (error "overshot END-CHANGES" end-next end-changes)) + outline))))) -(define (maybe-scroll window inferiors start wlstart wlsy) - (let ((y - (predict-y-limited - window - wlstart - wlsy - start - (fix:- 1 - (fix:- (inferior-y-end (car (last-pair inferiors))) - (inferior-y-start (car inferiors)))) - (window-y-size window)))) - (if (not y) - (values '() start) - (scroll-lines! window inferiors start y)))) +(define (last-unchanged-outline start-outline start start-changes) + (let loop ((outline start-outline) (start start)) + (let ((start-next (fix:+ start (fix:+ (outline-index-length outline) 1)))) + (if (fix:< start-next start-changes) + (begin + (if (not (outline-next outline)) + (error "can't find START-CHANGES")) + (loop (outline-next outline) start-next)) + (begin + (if (not (fix:= start-next start-changes)) + (error "overshot START-CHANGES" start-next start-changes)) + outline))))) -(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)))))))))) +(define (regenerate-outlines window wlstart wlsy) + (let ((start (make-o3 window false wlstart wlsy)) + (end (make-o3 window false false false))) + (generate-outlines window start end) + (set-outlines! window start end))) -(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)))))) +(define-integrable (fill-edges window start end) + (fill-top window start) + (fill-bottom window end) + (set-outlines! window start end)) + +(define (maybe-scroll window start end wlstart wlsy) + (let ((y + (predict-y-limited window wlstart wlsy + (o3-index start) + (fix:- 1 (fix:- (o3-y end) (o3-y start))) + (window-y-size window)))) + (cond ((not y) false) + ((fix:= (o3-y start) y) true) + ((fix:< (o3-y start) y) (scroll-lines-down window start end y)) + (else (scroll-lines-up window start end y))))) ;;;; Direct Output @@ -411,7 +422,7 @@ (lambda () (%set-window-point-index! window (fix:+ (%window-point-index window) 1)) (let ((x-start - (fix:1+ (inferior-x-start (%window-cursor-inferior window)))) + (fix:+ (inferior-x-start (%window-cursor-inferior window)) 1)) (y-start (inferior-y-start (%window-cursor-inferior window)))) (screen-direct-output-move-cursor (%window-saved-screen window) @@ -427,7 +438,7 @@ (lambda () (%set-window-point-index! window (fix:- (%window-point-index window) 1)) (let ((x-start - (fix:-1+ (inferior-x-start (%window-cursor-inferior window)))) + (fix:- (inferior-x-start (%window-cursor-inferior window)) 1)) (y-start (inferior-y-start (%window-cursor-inferior window)))) (screen-direct-output-move-cursor (%window-saved-screen window) @@ -466,10 +477,9 @@ (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) + (let ((outline (direct-output-outline window y-start))) + (set-outline-index-length! outline + (fix:+ (outline-index-length outline) 1))) (%set-inferior-x-start! (%window-cursor-inferior window) (fix:+ x-start 1)))))) @@ -492,19 +502,13 @@ (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) + (let ((outline (direct-output-outline window y-start))) + (set-outline-index-length! outline + (fix:+ (outline-index-length outline) + length))) (%set-inferior-x-start! (%window-cursor-inferior window) (fix:+ x-start length)))))) -(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))))) - (define (buffer-window/direct-output-insert-newline! window) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window @@ -514,29 +518,24 @@ (%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 string-base))) - (%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) + (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) - y-start)))))) \ No newline at end of file + end-y)) + (%set-window-end-outline! + window + (make-outline window 0 1 (%window-end-outline window) false)) + (%set-window-current-end-y! window (fix:+ end-y 1)) + (update-blank-inferior! window false) + (%set-inferior-x-start! (%window-cursor-inferior window) 0) + (%set-inferior-y-start! (%window-cursor-inferior window) end-y))))) + +(define (direct-output-outline window y) + (let loop + ((outline (%window-start-outline window)) + (start-y (%window-current-start-y window))) + (let ((end-y (fix:+ start-y (outline-y-size outline)))) + (if (fix:< y end-y) + outline + (loop (outline-next outline) end-y))))) \ No newline at end of file diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm index 1509257b3..05fdbad78 100644 --- a/v7/src/edwin/bufwmc.scm +++ b/v7/src/edwin/bufwmc.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.11 1991/03/23 02:22:45 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.12 1991/04/01 10:06:50 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -45,7 +45,7 @@ ;;;; Buffer Windows: Mark <-> Coordinate Maps (declare (usual-integrations)) - + (define-integrable (buffer-window/mark->x window mark) (buffer-window/index->x window (mark-index mark))) @@ -63,120 +63,114 @@ (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)) - (group (%window-group window)) - (tab-width (%window-tab-width window))) - (column->x (cdr (group-line-columns group start - (%window-group-end-index window) - 0 tab-width)) - (window-x-size window) - (%window-truncate-lines? window) - (group-columns group start index 0 tab-width))))) + (let ((start (%window-line-start-index window index)) + (group (%window-group window)) + (tab-width (%window-tab-width window))) + (column->x (cdr (group-line-columns group start + (%window-group-end-index window) + 0 tab-width)) + (window-x-size window) + (%window-truncate-lines? window) + (group-columns group start index 0 tab-width)))) (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)))) + (with-values (lambda () (start-point-for-index window index)) + (lambda (start-index start-y line-start-index) + line-start-index + (predict-y window start-index start-y 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)) - (group (%window-group window)) - (tab-width (%window-tab-width window))) - (let ((xy - (column->coordinates - (cdr (group-line-columns group start - (%window-group-end-index window) - 0 tab-width)) - (window-x-size window) - (%window-truncate-lines? window) - (group-columns group start index 0 tab-width)))) - (cons (car xy) - (fix:+ (cdr xy) - (predict-y window - (%window-start-line-index window) - (%window-start-line-y window) - start)))))))) - + (with-values (lambda () (start-point-for-index window index)) + (lambda (start-index start-y line-start-index) + (let ((group (%window-group window)) + (tab-width (%window-tab-width window))) + (let ((xy + (column->coordinates + (cdr (group-line-columns group line-start-index + (%window-group-end-index window) + 0 tab-width)) + (window-x-size window) + (%window-truncate-lines? window) + (group-columns group line-start-index index 0 tab-width)))) + (cons (car xy) + (fix:+ (cdr xy) + (predict-y window + start-index + start-y + line-start-index)))))))) + (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)))))) + (with-values (lambda () (start-point-for-y window y)) + (lambda (start-index start-y) + (predict-index window start-index start-y 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))))) + (with-values (lambda () (start-point-for-index window index)) + (lambda (start-index start-y line-start-index) + line-start-index + (predict-index-visible? window start-index start-y index))))) -(define-integrable (line-inferiors-valid? window) +(define (start-point-for-index window index) + (if (outlines-valid? window) + (let ((start-index (%window-current-start-index window)) + (start-y (%window-current-start-y window))) + (if (and (fix:<= start-index index) + (fix:<= index (%window-current-end-index window))) + (let loop + ((outline (%window-start-outline window)) + (index* start-index) + (y start-y)) + (let ((index** + (fix:+ index* (fix:+ (outline-index-length outline) 1)))) + (if (fix:< index index**) + (values index* y index*) + (loop (outline-next outline) + index** + (fix:+ y (outline-y-size outline)))))) + (values start-index + start-y + (%window-line-start-index window index)))) + (begin + (guarantee-start-mark! window) + (values (%window-start-line-index window) + (%window-start-line-y window) + (%window-line-start-index window index))))) + +(define (start-point-for-y window y) + (if (outlines-valid? window) + (let ((start-index (%window-current-start-index window)) + (start-y (%window-current-start-y window))) + (if (fix:< y start-y) + (values start-index start-y) + (let loop + ((outline (%window-start-outline window)) + (index start-index) + (y* start-y)) + (let ((y** (fix:+ y* (outline-y-size outline)))) + (cond ((fix:< y y**) + (values index y*)) + ((not (outline-next outline)) + (values start-index start-y)) + (else + (loop (outline-next outline) + (fix:+ index + (fix:+ (outline-index-length outline) 1)) + y**))))))) + (begin + (guarantee-start-mark! window) + (values (%window-start-line-index window) + (%window-start-line-y window))))) + +(define-integrable (outlines-valid? window) (and (not (%window-start-changes-mark window)) (not (%window-start-clip-mark window)) (not (%window-point-moved? window)) @@ -184,35 +178,6 @@ (%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)))))))))) (define (predict-y window start y index) ;; Assuming that the character at index START appears at coordinate @@ -499,17 +464,4 @@ (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))))))) \ No newline at end of file + (fix:+ index 1))))))) \ No newline at end of file diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm index 8a03c9c06..8ae111559 100644 --- a/v7/src/edwin/edtfrm.scm +++ b/v7/src/edwin/edtfrm.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $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 $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.84 1991/04/01 10:06:58 cph Exp $ ;;; ;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology ;;; @@ -99,7 +99,17 @@ (let ((y* (- y typein-y-size))) (set-inferior-start! typein-inferior 0 y*) (set-inferior-size! root-inferior x y*)) - (set-inferior-size! typein-inferior x-size typein-y-size))) + (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)))) (define-method editor-frame :set-size! set-editor-frame-size!) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 2270d1598..e82d499e8 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.26 1991/03/22 00:31:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.27 1991/04/01 10:07:04 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -221,6 +221,7 @@ MIT in each case. |# screen-discard! screen-enter! screen-exit! + screen-get-output-line screen-in-update? screen-modeline-event! screen-move-cursor @@ -389,7 +390,7 @@ MIT in each case. |# edwin-variable$mode-line-procedure edwin-variable$mode-line-process format-modeline-string - modeline-string)) + modeline-string!)) (define-package (edwin command-reader) (files "comred") diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm index fd0cfea15..cf7d5b747 100644 --- a/v7/src/edwin/image.scm +++ b/v7/src/edwin/image.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.127 1991/03/22 00:31:53 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.128 1991/04/01 10:07:13 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -141,74 +141,6 @@ 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4)) -(define (string-line-image string column tab-width) - (substring-line-image string 0 (string-length string) column tab-width)) - -(define (substring-line-image string start end column tab-width) - (let ((i&c (substring-line-columns string start end column tab-width))) - (let ((end (car i&c))) - (let ((image (make-string (fix:- (cdr i&c) column)))) - (%substring-image string start end column tab-width image 0) - (cons image end))))) - -(define (string-image string column tab-width) - (substring-image string 0 (string-length string) column tab-width)) - -(define (substring-image string start end column tab-width) - (let ((image - (make-string - (fix:- (substring-columns string start end column tab-width) - column)))) - (%substring-image string start end column tab-width image 0) - image)) - -(define (%substring-image string start end column tab-width image start-image) - (let loop ((string-index start) (image-index start-image)) - (if (not (fix:= string-index end)) - (loop - (fix:+ string-index 1) - (let ((ascii (vector-8b-ref string string-index))) - (cond ((fix:< ascii #o040) - (if (and tab-width (fix:= ascii (char->integer #\tab))) - (let ((n - (fix:- tab-width - (fix:remainder (fix:+ image-index column) - tab-width)))) - (let ((end (fix:+ image-index n))) - (do ((image-index image-index - (fix:+ image-index 1))) - ((fix:= image-index end) image-index) - (string-set! image image-index #\space)))) - (begin - (string-set! image image-index #\^) - (vector-8b-set! image - (fix:+ image-index 1) - (fix:+ ascii #o100)) - (fix:+ image-index 2)))) - ((fix:< ascii #o177) - (vector-8b-set! image image-index ascii) - (fix:+ image-index 1)) - ((fix:= ascii #o177) - (string-set! image image-index #\^) - (string-set! image image-index #\?) - (fix:+ image-index 2)) - (else - (string-set! image image-index #\\) - (let ((q (fix:quotient ascii 8))) - (vector-8b-set! image - (fix:+ image-index 1) - (fix:+ (fix:quotient q 8) - (char->integer #\0))) - (vector-8b-set! image - (fix:+ image-index 2) - (fix:+ (fix:remainder q 8) - (char->integer #\0)))) - (vector-8b-set! image - (fix:+ image-index 3) - (fix:+ (fix:remainder ascii 8) - (char->integer #\0))) - (fix:+ image-index 4)))))))) - (define (group-line-columns group start end column tab-width) (let ((text (group-text group)) (gap-start (group-gap-start group)) @@ -286,75 +218,161 @@ gap-length) (car i&c))))))) -(define (group-line-image group start end column tab-width) +(define (substring-image! string string-start string-end + image image-start image-end + tab-width column-offset results) + (let loop ((string-index string-start) (image-index image-start)) + (if (or (fix:= image-index image-end) + (fix:= string-index string-end)) + (begin + (vector-set! results 0 string-index) + (vector-set! results 1 image-index) + (vector-set! results 2 0)) + (let ((ascii (vector-8b-ref string string-index)) + (partial + (lambda (partial) + (vector-set! results 0 string-index) + (vector-set! results 1 image-end) + (vector-set! results 2 partial)))) + (cond ((fix:< ascii #o040) + (if (and (fix:= ascii (char->integer #\tab)) tab-width) + (let ((n + (fix:- tab-width + (fix:remainder (fix:+ column-offset + image-index) + tab-width)))) + (let ((end (fix:+ image-index n))) + (if (fix:<= end image-end) + (begin + (do ((image-index image-index + (fix:+ image-index 1))) + ((fix:= image-index end)) + (string-set! image image-index #\space)) + (loop (fix:+ string-index 1) end)) + (begin + (do ((image-index image-index + (fix:+ image-index 1))) + ((fix:= image-index image-end)) + (string-set! image image-index #\space)) + (partial (fix:- end image-end)))))) + (begin + (string-set! image image-index #\^) + (if (fix:= (fix:+ image-index 1) image-end) + (partial 1) + (begin + (vector-8b-set! image + (fix:+ image-index 1) + (fix:+ ascii #o100)) + (loop (fix:+ string-index 1) + (fix:+ image-index 2))))))) + ((fix:< ascii #o177) + (vector-8b-set! image image-index ascii) + (loop (fix:+ string-index 1) (fix:+ image-index 1))) + ((fix:= ascii #o177) + (string-set! image image-index #\^) + (if (fix:= (fix:+ image-index 1) image-end) + (partial 1) + (begin + (string-set! image (fix:+ image-index 1) #\?) + (loop (fix:+ string-index 1) (fix:+ image-index 2))))) + (else + (string-set! image image-index #\\) + (let ((q (fix:quotient ascii 8))) + (let ((d1 (fix:+ (fix:quotient q 8) (char->integer #\0))) + (d2 (fix:+ (fix:remainder q 8) (char->integer #\0))) + (d3 + (fix:+ (fix:remainder ascii 8) (char->integer #\0)))) + (cond ((fix:<= (fix:+ image-index 4) image-end) + (vector-8b-set! image (fix:+ image-index 1) d1) + (vector-8b-set! image (fix:+ image-index 2) d2) + (vector-8b-set! image (fix:+ image-index 3) d3) + (loop (fix:+ string-index 1) + (fix:+ image-index 4))) + ((fix:= (fix:+ image-index 1) image-end) + (partial 3)) + ((fix:= (fix:+ image-index 2) image-end) + (vector-8b-set! image (fix:+ image-index 1) d1) + (partial 2)) + (else + (vector-8b-set! image (fix:+ image-index 1) d1) + (vector-8b-set! image (fix:+ image-index 2) d2) + (partial 1))))))))))) + +(define (string-image string start-column tab-width) + (substring-image string 0 (string-length string) start-column tab-width)) + +(define (substring-image string start end start-column tab-width) + (let ((columns + (fix:- (substring-columns string start end start-column tab-width) + start-column))) + (let ((image (make-string columns))) + (substring-image! string start end + image 0 columns + tab-width start-column substring-image-results) + image))) + +(define substring-image-results + (make-vector 3)) + +(define (group-image! group start end + image image-start image-end + tab-width column-offset results) (let ((text (group-text group)) (gap-start (group-gap-start group)) (gap-end (group-gap-end group)) (gap-length (group-gap-length group))) (cond ((fix:<= end gap-start) - (substring-line-image text start end column tab-width)) + (substring-image! text start end + image image-start image-end + tab-width column-offset results)) ((fix:<= gap-start start) - (let ((image&index - (substring-line-image text - (fix:+ start gap-length) - (fix:+ end gap-length) - column - tab-width))) - (cons (car image&index) (fix:- (cdr image&index) gap-length)))) + (substring-image! text + (fix:+ start gap-length) (fix:+ end gap-length) + image image-start image-end + tab-width column-offset results) + (vector-set! results 0 (fix:- (vector-ref results 0) gap-length))) (else - (let ((index&column - (substring-line-columns text start gap-start - column tab-width))) - (let ((end-1 (car index&column)) - (column-1 (cdr index&column))) - (if (fix:= end-1 gap-start) - (let ((index&column - (substring-line-columns text - gap-end - (fix:+ end gap-length) - column-1 - tab-width))) - (let ((end-2 (car index&column)) - (column-2 (cdr index&column))) - (let ((image (make-string (fix:- column-2 column)))) - (%substring-image text start end-1 - column tab-width - image 0) - (%substring-image text gap-end end-2 - column tab-width - image (fix:- column-1 column)) - (cons image (fix:- end-2 gap-length))))) - (let ((image (make-string (fix:- column-1 column)))) - (%substring-image text start end-1 - column tab-width - image 0) - (cons image end-1))))))))) + (substring-image! text start gap-start + image image-start image-end + tab-width column-offset results) + (if (fix:< (vector-ref results 1) image-end) + (begin + (substring-image! text gap-end (fix:+ end gap-length) + image (vector-ref results 1) image-end + tab-width column-offset results) + (vector-set! results 0 + (fix:- (vector-ref results 0) gap-length)))))))) -(define (group-image group start end column tab-width) - (let ((text (group-text group)) - (gap-start (group-gap-start group)) - (gap-end (group-gap-end group)) - (gap-length (group-gap-length group))) - (cond ((fix:<= end gap-start) - (substring-image text start end column tab-width)) - ((fix:<= gap-start start) - (substring-image text - (fix:+ start gap-length) - (fix:+ end gap-length) - column - tab-width)) +(define (partial-image! char n image image-start image-end tab-width) + ;; Assume that (< IMAGE-START IMAGE-END) and that N is less than the + ;; total width of the image for the character. + (let ((ascii (char->integer char))) + (cond ((fix:< ascii #o040) + (if (and (fix:= ascii (char->integer #\tab)) tab-width) + (let ((end + (let ((end (fix:+ image-start n))) + (if (fix:< end image-end) end image-end)))) + (do ((image-index image-start (fix:+ image-index 1))) + ((fix:= image-index end)) + (string-set! image image-index #\space))) + (vector-8b-set! image image-start (fix:+ ascii #o100)))) + ((fix:= ascii #o177) + (string-set! image image-start #\?)) (else - (let ((column-1 - (substring-columns text start gap-start - column tab-width)) - (end (fix:+ end gap-length))) - (let ((image - (make-string - (fix:- (substring-columns text gap-end end - column-1 tab-width) - column)))) - (%substring-image text start gap-start column tab-width - image 0) - (%substring-image text gap-end end column tab-width - image (fix:- column-1 column)) - image)))))) \ No newline at end of file + (let ((q (fix:quotient ascii 8))) + (let ((d1 (fix:+ (fix:quotient q 8) (char->integer #\0))) + (d2 (fix:+ (fix:remainder q 8) (char->integer #\0))) + (d3 (fix:+ (fix:remainder ascii 8) (char->integer #\0)))) + (case n + ((1) + (vector-8b-set! image image-start d3)) + ((2) + (vector-8b-set! image image-start d2) + (if (fix:< (fix:+ image-start 1) image-end) + (vector-8b-set! image (fix:+ image-start 1) d3))) + (else + (vector-8b-set! image image-start d1) + (if (fix:< (fix:+ image-start 1) image-end) + (vector-8b-set! image (fix:+ image-start 1) d2)) + (if (fix:< (fix:+ image-start 2) image-end) + (vector-8b-set! image (fix:+ image-start 2) d3)))))))))) \ No newline at end of file diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 07d11227f..7bbc55e33 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.29 1991/03/22 00:32:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.30 1991/04/01 10:07:23 cph Exp $ Copyright (c) 1989-91 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 29 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 30 '())) \ No newline at end of file diff --git a/v7/src/edwin/modlin.scm b/v7/src/edwin/modlin.scm index ef0bbac09..6af59928d 100644 --- a/v7/src/edwin/modlin.scm +++ b/v7/src/edwin/modlin.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.7 1991/03/22 00:32:30 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.8 1991/04/01 10:07:32 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -104,22 +104,26 @@ Normally false in most modes, since there is no process to display." (define-variable mode-line-procedure "Procedure used to generate the mode-line. -Must accept one argument, a window. -The value must be a string which has the same length as the window's width. +Must accept four arguments: WINDOW STRING START END. +Must generate a modeline string for WINDOW in the given substring. If #F, the normal method is used." false) -(define (modeline-string window) +(define (modeline-string! window line start end) (let ((procedure (variable-local-value (window-buffer window) (ref-variable-object mode-line-procedure)))) (if procedure - (procedure window) - (format-modeline-string - window - (variable-local-value (window-buffer window) - (ref-variable-object mode-line-format)) - (window-x-size window))))) + (procedure window line start end) + (let ((last + (display-mode-element + (variable-local-value (window-buffer window) + (ref-variable-object mode-line-format)) + window line start end end))) + (if (fix:< last end) + (do ((x last (fix:+ x 1))) + ((fix:= x end)) + (string-set! line x #\space))))))) (define (format-modeline-string window format size) (let ((line (string-allocate size))) @@ -309,21 +313,17 @@ If #F, the normal method is used." line column min-end max-end)) (define (display-substring string start end line column min-end max-end) - (let ((representation (substring-image string start end column false))) - (let ((size (string-length representation))) - (let ((end (+ column size))) - (if (> end max-end) - (begin - (substring-move-right! representation 0 (- max-end column) - line column) - max-end) - (begin - (substring-move-right! representation 0 size line column) - (if (< end min-end) - (begin - (substring-fill! line end min-end #\space) - min-end) - end))))))) + (let ((results substring-image-results)) + (substring-image! string start end + line column max-end + false 0 results) + (if (fix:< (vector-ref results 1) min-end) + (begin + (do ((x (vector-ref results 1) (fix:+ x 1))) + ((fix:= x min-end)) + (string-set! line x #\space)) + min-end) + (vector-ref results 1)))) (define (display-pad line column min-end) (if (< column min-end) diff --git a/v7/src/edwin/modwin.scm b/v7/src/edwin/modwin.scm index 998824075..5d00ee0f6 100644 --- a/v7/src/edwin/modwin.scm +++ b/v7/src/edwin/modwin.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $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 $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.36 1991/04/01 10:07:42 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology ;;; @@ -55,17 +55,18 @@ (define (modeline-window:update-display! window screen x-start y-start xl xu yl yu display-style) display-style ;ignore - (if (< yl yu) + (if (and (fix:= yl 0) (fix:< yl yu)) (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))))) + (modeline-string! + superior + (screen-get-output-line + screen + y-start + (fix:+ x-start xl) + (fix:+ x-start xu) + (variable-local-value (window-buffer superior) + (ref-variable-object mode-line-inverse-video))) + xl xu))) true) (define-method modeline-window :update-display! diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm index f60e2f12b..dd0836e3d 100644 --- a/v7/src/edwin/screen.scm +++ b/v7/src/edwin/screen.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.90 1991/03/22 00:32:50 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.91 1991/04/01 10:07:48 cph Exp $ ;;; ;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; @@ -314,33 +314,37 @@ x highlight))))) (define (screen-output-substring screen x y string start end highlight) + (substring-move-left! string start end + (screen-get-output-line screen y x + (fix:+ x (fix:- end start)) + highlight) + x)) + +(define (screen-get-output-line screen y xl xu 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)) - (xu (fix:+ x (fix:- end start)))) - (let ((full-line? (and (fix:= x 0) (fix:= xu (screen-x-size screen))))) + ((screen-debug-trace screen) 'screen screen 'output-line + y xl xu highlight)) + (let ((new-matrix (screen-new-matrix screen))) + (let ((full-line? (and (fix:= xl 0) (fix:= xu (screen-x-size 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) (if (not full-line?) (initialize-new-line-contents screen y)))) - (substring-move-left! string start end - (vector-ref (matrix-contents new-matrix) y) x) (cond ((boolean-vector-ref (matrix-highlight-enable new-matrix) y) (if (and full-line? (not highlight)) (boolean-vector-set! (matrix-highlight-enable new-matrix) y false) (boolean-subvector-fill! (vector-ref (matrix-highlight new-matrix) y) - x xu highlight))) + xl xu highlight))) (highlight (boolean-vector-set! (matrix-highlight-enable new-matrix) y true) (if (not full-line?) (initialize-new-line-highlight screen y)) (boolean-subvector-fill! (vector-ref (matrix-highlight new-matrix) y) - x xu highlight)))))) + xl xu highlight)))) + (vector-ref (matrix-contents new-matrix) y))) (define-integrable (initialize-new-line-contents screen y) (if (boolean-vector-ref (matrix-enable (screen-current-matrix screen)) y) @@ -467,18 +471,36 @@ x cursor-x highlight))) (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))) + (current-matrix (screen-current-matrix screen)) + (new-matrix (screen-new-matrix screen))) (terminal-clear-screen screen) (let ((current-contents (matrix-contents current-matrix)) + (current-hl (matrix-highlight current-matrix)) (current-enable (matrix-enable current-matrix)) - (current-hl-enable (matrix-highlight-enable current-matrix))) + (current-hl-enable (matrix-highlight-enable current-matrix)) + (new-contents (matrix-contents new-matrix)) + (new-hl (matrix-highlight new-matrix)) + (new-enable (matrix-enable new-matrix)) + (new-hl-enable (matrix-highlight-enable new-matrix))) (do ((y 0 (fix:1+ y))) ((fix:= y y-size)) + (if (not (boolean-vector-ref new-enable 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)) + (boolean-vector-set! new-enable y true) + (if (boolean-vector-ref current-hl-enable y) + (begin + (let ((h (vector-ref current-hl y))) + (vector-set! new-hl y (vector-ref current-hl y)) + (vector-set! current-hl y h)) + (boolean-vector-set! new-hl-enable y true))))) (string-fill! (vector-ref current-contents y) #\space) (boolean-vector-set! current-enable y true) (boolean-vector-set! current-hl-enable y false)))) diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm index 4b0283954..446a89d5e 100644 --- a/v7/src/edwin/utlwin.scm +++ b/v7/src/edwin/utlwin.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.56 1991/03/22 00:33:14 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.57 1991/04/01 10:08:00 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -46,119 +46,8 @@ (declare (usual-integrations)) -;;;; String Window -;;; This "mixin" defines a common base from which 2D text string -;;; windows can be built. Mostly, it provides standard procedures -;;; from which methods can be built. +;;;; Column<->Coordinate Utilities -(define-class string-base vanilla-window - (string string-len string-max-length - image image-length image-max-length - truncate-lines? tab-width representation)) - -(define-integrable (string-base:string window) - (with-instance-variables string-base window () string)) - -(define-integrable (string-base:string-length window) - (with-instance-variables string-base window () string-len)) - -(define-integrable (string-base:image window) - (with-instance-variables string-base window () image)) - -(define-integrable (string-base:image-length window) - (with-instance-variables string-base window () image-length)) - -(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 - (declare (integrate-operator clip)) - (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!) - -(define (string-base:initialize! window *string *image - *x-size *truncate-lines? *tab-width) - (let ((*string-length (string-length *string)) - (*image-length (string-length *image))) - (with-instance-variables string-base window - (*string *image *image-length *truncate-lines? *tab-width *x-size) - (set! string *string) - (set! string-len *string-length) - (set! string-max-length *string-length) - (set! image *image) - (set! image-length *image-length) - (set! image-max-length *image-length) - (set! truncate-lines? *truncate-lines?) - (set! tab-width *tab-width) - (set! x-size *x-size) - (set! y-size (column->y-size *image-length *x-size *truncate-lines?)) - (string-base:refresh! window)))) - -(define (string-base:index->coordinates window index) - (with-instance-variables string-base window (index) - (column->coordinates image-length - x-size - truncate-lines? - (substring-columns string 0 index 0 tab-width)))) - -(define (string-base:index->x window index) - (with-instance-variables string-base window (index) - (column->x image-length - x-size - truncate-lines? - (substring-columns string 0 index 0 tab-width)))) - -(define (string-base:index->y window index) - (with-instance-variables string-base window (index) - (column->y image-length - x-size - truncate-lines? - (substring-columns string 0 index 0 tab-width)))) - -(define (string-base:coordinates->index window x y) - (with-instance-variables string-base window (x y) - (substring-column->index string 0 string-len 0 tab-width - (let ((column (coordinates->column x y x-size))) - (if (fix:< column image-length) - column - image-length))))) - (define (column->x-size column-size y-size truncate-lines?) ;; Assume Y-SIZE > 0. (cond (truncate-lines? @@ -215,112 +104,6 @@ (define-integrable (coordinates->column x y x-size) (fix:+ x (fix:* y (fix:- x-size 1)))) -(define (string-base:direct-output-insert-char! window x char) - (with-instance-variables string-base window (x char) - (if (fix:= string-len string-max-length) - (string-base:grow-image! window 1)) - (string-set! string string-len char) - (set! string-len (fix:+ string-len 1)) - (string-set! image image-length char) - (set! image-length (fix:+ image-length 1)) - (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-substring! window x string start end) - (with-instance-variables string-base window (x string start end) - (let ((len (fix:- end start))) - (let ((*string-len (fix:+ string-len len))) - (if (fix:< string-max-length *string-len) - (string-base:grow-image! window len)) - (substring-move-right! string start end image string-len) - (set! string-len *string-len)) - (substring-move-right! string start end image image-length) - (set! image-length (fix:+ image-length len))) - (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:grow-image! window delta) - (let ((delta (fix:+ delta 16))) - (with-instance-variables string-base window (delta) - (let ((new-max-length (fix:+ string-max-length delta))) - (set! string - (let ((*string (make-string new-max-length))) - (substring-move-right! string 0 string-len *string 0) - *string)) - (set! string-max-length new-max-length)) - (let ((new-max-length (fix:+ image-max-length delta))) - (set! image - (let ((*image (make-string new-max-length))) - (substring-move-right! image 0 image-length *image 0) - *image)) - (set! image-max-length new-max-length))))) - -(define (string-base:direct-output-insert-newline! window) - (with-instance-variables string-base window () - (set! string "") - (set! string-len 0) - (set! string-max-length 0) - (set! image "") - (set! image-length 0) - (set! image-max-length 0) - (set! y-size 1) - (set! representation false))) - -(define (string-base:refresh! window) - (with-instance-variables string-base window () - (cond ((fix:= image-length 0) - (set! representation false)) - ((fix:< image-length x-size) - (let ((s (string-allocate x-size))) - (substring-move-left! image 0 image-length s 0) - (substring-fill! s image-length x-size #\space) - (set! representation s))) - (truncate-lines? - (let ((s (string-allocate x-size)) - (x-max (fix:- x-size 1))) - (substring-move-left! image 0 x-max s 0) - (string-set! s x-max #\$) - (set! representation s))) - (else - (let ((rep (make-vector y-size '())) - (x-max (fix:- x-size 1))) - (let loop ((start 0) (y 0)) - (let ((s (string-allocate x-size)) - (end (fix:+ start x-max))) - (vector-set! rep y s) - (if (fix:> image-length end) - (begin - (substring-move-left! image start end s 0) - (string-set! s x-max #\\) - (loop end (fix:+ 1 y))) - (begin - (substring-move-left! image start image-length s 0) - (substring-fill! s - (fix:- image-length start) - x-size - #\space))))) - (set! representation rep)))) - (setup-redisplay-flags! redisplay-flags))) - ;;;; Blank Window (define-class blank-window vanilla-window