;;; -*-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
;;;
(declare (usual-integrations))
\f
-(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)))))))
\f
-(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)))))))))
\f
-(define (scroll-lines! window inferiors start y-start)
- (cond ((or (null? inferiors)
- (fix:= y-start (inferior-y-start (car inferiors))))
- (values inferiors start))
- ((fix:< y-start (inferior-y-start (car inferiors)))
- (scroll-lines-up! window inferiors start y-start))
- (else
- (values (scroll-lines-down! window inferiors y-start) start))))
-
-(define (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)))))))))))))))
\f
-(define (%scroll-lines-down! window inferiors y-start)
- (adjust-scrolled-inferiors!
- window
- inferiors
- y-start
- (let ((yl (inferior-y-start (car inferiors)))
- (yu (%inferior-y-end (car (last-pair inferiors)))))
- (let ((amount (fix:- y-start yl)))
- (and (fix:< yl (%window-saved-yu window))
- (fix:< (%window-saved-yl window) yu)
- (let ((yl (fix:max (%window-saved-yl window) yl))
- (yu (fix:min (%window-saved-yu window) (fix:+ yu amount))))
- (and (fix:< amount (fix:- yu yl))
- (screen-scroll-lines-down
- (%window-saved-screen window)
- (fix:+ (%window-saved-xl window)
- (%window-saved-x-start window))
- (fix:+ (%window-saved-xu window)
- (%window-saved-x-start window))
- (fix:+ yl (%window-saved-y-start window))
- (fix:+ yu (%window-saved-y-start window))
- amount))))))))
+(define (scroll-lines-up window 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)))))
+\f
+(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
;;; -*-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
;;;
;; 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
\f
+ ;; 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
(define-integrable (%set-window-blank-inferior! window inferior)
(with-instance-variables buffer-window window (inferior)
(set! blank-inferior inferior)))
+\f
+(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)))
-\f
-(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))
(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)))
+\f
+(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))
(with-instance-variables buffer-window window (procedure)
(set! debug-trace procedure)))
\f
+;;;; 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)))
+\f
+(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))
+\f
;;;; Narrowing
(define-integrable (%window-group-start-mark window)
(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))
(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))
\f
(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)
(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)
(%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))
(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)
(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))
\f
(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)))
(and (real? cursor-centering-point)
(<= 0 cursor-centering-point 100))))
\f
-;;;; 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)
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))
\f
;;;; Update Finalization
-(define (set-line-inferiors! window inferiors)
- (%set-window-line-inferiors! window inferiors)
- (inferiors-changed! window)
- (%clear-window-outstanding-changes! window)
- (update-cursor! window)
- (%window-modeline-event! window 'SET-LINE-INFERIORS))
-
-(define-integrable (set-current-end-index! window end)
+(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)))
;;; -*-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
;;;
(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)))
\f
;;;; Update
-(define (recompute-image! window)
+(define (update-outlines! window)
(%guarantee-start-mark! window)
(if (%window-force-redraw? window)
(begin
(%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))))))
+\f
(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)))))))
\f
-(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))))))))
\f
-(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)))))
\f
;;;; Direct Output
(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)
(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)
(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))))))
(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)))))
-\f
(define (buffer-window/direct-output-insert-newline! window)
(if (%window-debug-trace window)
((%window-debug-trace window) 'window window
(%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
;;; -*-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
;;;
;;;; Buffer Windows: Mark <-> Coordinate Maps
(declare (usual-integrations))
-
+\f
(define-integrable (buffer-window/mark->x window mark)
(buffer-window/index->x window (mark-index mark)))
(define-integrable (buffer-window/point-coordinates window)
(buffer-window/index->coordinates window (%window-point-index window)))
-\f
+
(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))))))))
-\f
+ (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)))))
\f
-(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))
(%window-start-line-mark window)
(fix:= (mark-position (%window-start-line-mark window))
(mark-position (%window-current-start-mark window)))))
-
-(define-integrable (line-inferiors-contain-index? window index)
- (and (fix:<= (%window-current-start-index window) index)
- (fix:<= index (%window-current-end-index window))))
-
-(define (find-inferior-containing-index window index)
- (let loop
- ((inferiors (%window-line-inferiors window))
- (start (%window-current-start-index window)))
- (let ((start* (fix:+ start (line-inferior-length (car inferiors)))))
- (if (fix:< index start*)
- (values (car inferiors) start)
- (loop (cdr inferiors) start*)))))
-
-(define (find-inferior-containing-y window y)
- (let ((inferiors (%window-line-inferiors window)))
- (if (fix:< y (inferior-y-start (car inferiors)))
- (values false false)
- (let loop
- ((inferiors inferiors)
- (start (%window-current-start-index window)))
- (cond ((fix:< y (%inferior-y-end (car inferiors)))
- (values (car inferiors) start))
- ((null? (cdr inferiors))
- (values false false))
- (else
- (loop (cdr inferiors)
- (fix:+ start
- (line-inferior-length (car inferiors))))))))))
\f
(define (predict-y window start y index)
;; Assuming that the character at index START appears at coordinate
(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
;;; -*-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
;;;
(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!)
#| -*-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
screen-discard!
screen-enter!
screen-exit!
+ screen-get-output-line
screen-in-update?
screen-modeline-event!
screen-move-cursor
edwin-variable$mode-line-procedure
edwin-variable$mode-line-process
format-modeline-string
- modeline-string))
+ modeline-string!))
(define-package (edwin command-reader)
(files "comred")
;;; -*-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
;;;
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))
\f
-(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))))))))
-\f
(define (group-line-columns group start end column tab-width)
(let ((text (group-text group))
(gap-start (group-gap-start group))
gap-length)
(car i&c)))))))
\f
-(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)))))))))))
+\f
+(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
#| -*-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
(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
;;; -*-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
;;;
\f
(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)))
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)
;;; -*-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
;;;
(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!
;;; -*-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
;;;
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)
x cursor-x highlight)))
(set-matrix-cursor-x! current-matrix cursor-x)
(set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
-
+\f
(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))))
;;; -*-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
;;;
(declare (usual-integrations))
\f
-;;;; 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!)
-\f
-(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)))))
-\f
(define (column->x-size column-size y-size truncate-lines?)
;; Assume Y-SIZE > 0.
(cond (truncate-lines?
(define-integrable (coordinates->column x y x-size)
(fix:+ x (fix:* y (fix:- x-size 1))))
\f
-(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)))
-\f
-(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)))
-\f
;;;; Blank Window
(define-class blank-window vanilla-window
projects / mit-scheme.git / commitdiff