;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.288 1991/03/15 23:47:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.289 1991/03/16 08:11:28 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(without-interrupts (lambda () (%guarantee-start-mark! window))))
(define (%guarantee-start-mark! window)
- (let* ((index-at!
- (lambda (index y)
- (with-values (lambda () (predict-start-line window index y))
- (lambda (start y-start)
- (set-start-mark! window start y-start)))))
- (point-at! (lambda (y) (index-at! (%window-point-index window) y)))
- (recenter! (lambda () (point-at! (buffer-window/y-center window)))))
- (cond ((not (%window-start-line-mark window))
- (recenter!))
- ((not (%window-line-start-index? window
- (%window-start-line-index window)))
- (index-at! (%window-start-index window) 0))
- ((eq? (%window-point-moved? window) 'SINCE-START-SET)
- (let ((y
- (predict-y window
- (%window-start-line-index window)
- (%window-start-line-y window)
- (%window-point-index window))))
- (cond ((fix:< y 0)
- (let ((y (fix:+ y (ref-variable scroll-step))))
- (if (fix:< y 0)
- (recenter!)
- (point-at! y))))
- ((fix:>= y (window-y-size window))
- (let ((y (fix:- y (ref-variable scroll-step))))
- (if (fix:>= y (window-y-size window))
- (recenter!)
- (point-at! y))))))))))
+ (let ((index-at!
+ (lambda (index y)
+ (with-values (lambda () (predict-start-line window index y))
+ (lambda (start y-start)
+ (set-start-mark! window start y-start))))))
+ (if (not (%window-start-line-mark window))
+ (index-at! (%window-point-index window)
+ (buffer-window/y-center window))
+ (let ((start-line (%window-start-line-index window)))
+ (cond ((not (%window-line-start-index? window start-line))
+ (index-at! (%window-start-index window) 0))
+ ((eq? (%window-point-moved? window) 'SINCE-START-SET)
+ (let ((point (%window-point-index window)))
+ (if (or (%window-start-clip-mark window)
+ (%window-start-changes-mark window)
+ (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))
+ (let ((start-y (%window-start-line-y window))
+ (y-size (window-y-size window))
+ (scroll-step (ref-variable scroll-step)))
+ (if (fix:= 0 scroll-step)
+ (if (not (predict-y-limited window start-line
+ start-y point
+ 0 y-size))
+ (index-at! point
+ (buffer-window/y-center window)))
+ (let ((y
+ (predict-y-limited window start-line
+ start-y point
+ (fix:- 0 scroll-step)
+ (fix:+ y-size
+ scroll-step))))
+ (cond ((not y)
+ (index-at!
+ point
+ (buffer-window/y-center window)))
+ ((fix:< y 0)
+ (index-at! point (fix:+ y scroll-step)))
+ ((fix:>= y y-size)
+ (index-at!
+ point
+ (fix:- y scroll-step)))))))))))))))
(define-variable scroll-step
"*The number of lines to try scrolling a window by when point moves out.
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.14 1991/03/15 23:48:02 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.15 1991/03/16 08:11:11 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(let ((start (%window-current-start-index window))
(end (%window-current-end-index window)))
(cond ((and (%window-start-clip-mark window)
- (or (not (and (fix:<= (%window-group-start-index window) start)
- (fix:<= end (%window-group-end-index window))))
+ (or (fix:< start (%window-group-start-index window))
(fix:< (%window-group-start-index window)
(%window-start-clip-index window))
+ (fix:< (%window-group-end-index window) end)
(fix:< (%window-end-clip-index window)
(%window-group-end-index window))))
(preserve-nothing! window))
(generate-line-inferiors window
(%window-start-line-index window)
(%window-start-line-y window))))
-\f
+
(define (preserve-contiguous-region! window inferiors start)
(let ((wlstart (%window-start-line-index window))
(wlsy (%window-start-line-y window)))
(set-line-inferiors!
window
(with-values
- (lambda ()
- (scroll-lines! window
- inferiors
- start
- (predict-y window wlstart wlsy start)))
+ (lambda () (maybe-scroll window inferiors start wlstart wlsy))
(lambda (inferiors start)
(if (null? inferiors)
(generate-line-inferiors window wlstart wlsy)
(define-integrable (fill-edges! window inferiors start)
(fill-top window (fill-bottom! window inferiors start) start))
-
+\f
(define (preserve-all! window start)
(let ((wlstart (%window-start-line-index window))
(wlsy (%window-start-line-y window))
(inferiors (%window-line-inferiors window)))
- (let ((scroll-down
+ (let ((regenerate
+ (lambda ()
+ (set-line-inferiors!
+ window
+ (generate-line-inferiors window wlstart wlsy))))
+ (scroll-down
(lambda (y-start)
(set-line-inferiors!
window
(else
(scroll-down wlsy)))))
((fix:< wlstart start)
- (scroll-down (predict-y window wlstart wlsy start)))
+ (let ((y
+ (predict-y-limited window wlstart wlsy start
+ (inferior-y-start (car inferiors))
+ (window-y-size window))))
+ (if (not y)
+ (regenerate)
+ (scroll-down y))))
(else
- (scroll-up (predict-y window wlstart wlsy start)))))))
+ (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)))
+ (if (not y)
+ (regenerate)
+ (scroll-up y))))))))
\f
(define (preserve-top-and-bottom! window start start-changes end-changes end)
(let ((wlstart (%window-start-line-index window))
(set-cdr! middle-tail '())
(with-values
(lambda ()
- (scroll-lines! window
- top-inferiors
- start
- (predict-y window wlstart wlsy start)))
+ (maybe-scroll window top-inferiors start wlstart wlsy))
(lambda (top-inferiors top-start)
(with-values
(lambda ()
- (let ((bottom-start (fix:+ end-changes 1)))
- (scroll-lines! window
- bottom-inferiors
- bottom-start
- (predict-y window wlstart wlsy
- bottom-start))))
+ (maybe-scroll window bottom-inferiors (fix:+ end-changes 1)
+ wlstart wlsy))
(lambda (bottom-inferiors bottom-start)
(set-line-inferiors!
window
bottom-start)
top-start)))))))))))
+(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 (changed-inferiors-tail inferiors end end-changes)
(let find-end
((inferiors inferiors)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.8 1990/11/02 03:23:08 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.9 1991/03/16 08:10:55 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(fix:+ y (%window-column->y-size window columns)))
(fix:+ y (%window-line-y window columns start index))))))))
+(define (predict-y-limited window start y index yl yu)
+ ;; Like PREDICT-Y, except returns #F if the result is not in the
+ ;; range specified by YL and YU. Prevents long search to find INDEX
+ ;; when it is far away from the window.
+ (cond ((fix:= index start)
+ (and (fix:<= yl y)
+ (fix:< y yu)
+ y))
+ ((fix:< index start)
+ (let loop ((start start) (y y))
+ (and (fix:<= yl y)
+ (let* ((end (fix:- start 1))
+ (start (%window-line-start-index window end))
+ (columns (%window-column-length window start end 0))
+ (y (fix:- y (%window-column->y-size window columns))))
+ (if (fix:< index start)
+ (loop start y)
+ (let ((y
+ (fix:+ y
+ (%window-line-y window columns start
+ index))))
+ (and (fix:<= yl y)
+ (fix:< y yu)
+ y)))))))
+ (else
+ (let loop ((start start) (y y))
+ (and (fix:< y yu)
+ (let* ((end (%window-line-end-index window start))
+ (columns (%window-column-length window start end 0)))
+ (if (fix:> index end)
+ (loop (fix:+ end 1)
+ (fix:+ y (%window-column->y-size window columns)))
+ (let ((y
+ (fix:+ y
+ (%window-line-y window columns start
+ index))))
+ (and (fix:<= yl y)
+ (fix:< y yu)
+ y)))))))))
+\f
(define (predict-index-visible? window start y index)
(and (fix:>= index start)
(let ((y-size (window-y-size window)))
projects / mit-scheme.git / commitdiff