From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 12 Jan 1993 10:50:41 +0000 (+0000)
Subject: Change method by which a window recomputes its starting point. Old
X-Git-Tag: 20090517-FFI~8606
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=85a0f3a52c0e44d8b09d869ab946f082067c42a5;p=mit-scheme.git
Change method by which a window recomputes its starting point. Old
method did too much work, particularly in cases where the line was
very long. New method searches backward -- exactly once -- to start
of first line that will appear in the window, and saves all of the
resulting information in the window for later use.
Unfortunately, there are many other problems with the algorithms that
make them dependent on line length, and it's a lot of work to fix
them. To fix it write will involve rewriting the display update code,
yet again, and I'm not in the mood for that right now. However, it
won't be necessary to rewrite the starting-point computation when that
does finally happen.
---
diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm
index 23734dd1c..30686b10a 100644
--- a/v7/src/edwin/bufwin.scm
+++ b/v7/src/edwin/bufwin.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwin.scm,v 1.298 1993/01/09 09:43:59 cph Exp $
+;;; $Id: bufwin.scm,v 1.299 1993/01/12 10:50:36 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
@@ -133,6 +133,18 @@
;; non-positive.
start-line-y
+ ;; This is the number of columns between START-LINE-MARK
+ ;; (inclusive) and START-MARK (exclusive). In other words, it is
+ ;; the starting column of START-MARK. This is undefined if
+ ;; START-MARK is #F.
+ start-column
+
+ ;; If the character to the right of START-MARK is completely
+ ;; visible, this is zero. Otherwise, this is the number of columns
+ ;; of that character that are visible. This is undefined if
+ ;; START-MARK is #F.
+ start-partial
+
;; This contains the buffer's MODIFIED-TICK from the last time that
;; redisplay completed for this window.
modified-tick
@@ -331,6 +343,20 @@
(define-integrable (%set-window-start-line-y! window y)
(with-instance-variables buffer-window window (y)
(set! start-line-y y)))
+
+(define-integrable (%window-start-column window)
+ (with-instance-variables buffer-window window () start-column))
+
+(define-integrable (%set-window-start-column! window column)
+ (with-instance-variables buffer-window window (column)
+ (set! start-column column)))
+
+(define-integrable (%window-start-partial window)
+ (with-instance-variables buffer-window window () start-partial))
+
+(define-integrable (%set-window-start-partial! window partial)
+ (with-instance-variables buffer-window window (partial)
+ (set! start-partial partial)))
(define-integrable (%window-modified-tick window)
(with-instance-variables buffer-window window () modified-tick))
@@ -766,7 +792,7 @@
(%set-window-buffer! window false)
(%set-window-point! window false)
(if (%window-start-line-mark window)
- (clear-start-mark! window))
+ (clear-window-start! window))
(%clear-window-incremental-redisplay-state! window))
(define (%clear-window-incremental-redisplay-state! window)
@@ -886,7 +912,6 @@
((%window-debug-trace window) 'window window 'scroll-y-relative!
y-delta))
(guarantee-start-mark! window)
- ;; if (> Y-DELTA 0) and line inferiors valid, use them.
(set-new-coordinates! window
(%window-start-line-index window)
(fix:- (%window-start-line-y window) y-delta)
@@ -901,14 +926,12 @@
(if (not (and (fix:<= 0 y-point)
(fix:< y-point (window-y-size window))))
(error:bad-range-argument y-point 'WINDOW-SCROLL-Y-ABSOLUTE!))
- (with-values
- (lambda ()
- (predict-start-line window (%window-point-index window) y-point))
- (lambda (start y-start)
- (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (set-start-mark! window start y-start)
- (set-interrupt-enables! mask)
- unspecific))))
+ (let ((cws
+ (compute-window-start window (%window-point-index window) y-point)))
+ (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (set-window-start! window cws)
+ (set-interrupt-enables! mask)
+ unspecific)))
(define (buffer-window/y-center window)
(let ((y-size (window-y-size window)))
@@ -928,12 +951,13 @@ This number is a percentage, where 0 is the window's top and 100 the bottom."
(<= 0 cursor-centering-point 100))))
(define (set-new-coordinates! window index y point-y)
- (with-values (lambda () (predict-start-line window index y))
- (lambda (start y-start)
+ (let ((cws (compute-window-start window index y)))
+ (let ((start (vector-ref cws 0))
+ (y-start (vector-ref cws 1)))
(cond ((predict-index-visible? window start y-start
(%window-point-index window))
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
- (set-start-mark! window start y-start)
+ (set-window-start! window cws)
(set-interrupt-enables! mask)
unspecific))
(point-y
@@ -942,28 +966,30 @@ This number is a percentage, where 0 is the window's top and 100 the bottom."
window
(or (predict-index window start y-start 0 point-y)
(%window-group-end-index window)))
- (set-start-mark! window start y-start)
+ (set-window-start! window cws)
(set-interrupt-enables! mask)
unspecific))))))
-(define (set-start-mark! window start-line y-start)
- (if (fix:= y-start 0)
- (if (%window-start-line-mark window)
- (begin
- (set-mark-index! (%window-start-line-mark window) start-line)
- (if (not (eq? (%window-start-line-mark window)
- (%window-start-mark window)))
- (begin
- (mark-temporary! (%window-start-mark window))
- (%set-window-start-mark! window
- (%window-start-line-mark window)))))
- (let ((mark
- (make-permanent-mark (%window-group window)
- start-line
- false)))
- (%set-window-start-line-mark! window mark)
- (%set-window-start-mark! window mark)))
- (let ((start (predict-start-index window start-line y-start)))
+(define (set-window-start! window cws)
+ (let ((start-line (vector-ref cws 0))
+ (start (vector-ref cws 2)))
+ (if (fix:= start-line start)
+ (if (%window-start-line-mark window)
+ (begin
+ (set-mark-index! (%window-start-line-mark window) start-line)
+ (if (not (eq? (%window-start-line-mark window)
+ (%window-start-mark window)))
+ (begin
+ (mark-temporary! (%window-start-mark window))
+ (%set-window-start-mark!
+ window
+ (%window-start-line-mark window)))))
+ (let ((mark
+ (make-permanent-mark (%window-group window)
+ start-line
+ false)))
+ (%set-window-start-line-mark! window mark)
+ (%set-window-start-mark! window mark)))
(if (%window-start-line-mark window)
(begin
(set-mark-index! (%window-start-line-mark window) start-line)
@@ -980,17 +1006,21 @@ This number is a percentage, where 0 is the window's top and 100 the bottom."
(%set-window-start-mark!
window
(make-permanent-mark group start false))))))
- (%set-window-start-line-y! window y-start)
+ (%set-window-start-line-y! window (vector-ref cws 1))
+ (%set-window-start-column! window (vector-ref cws 3))
+ (%set-window-start-partial! window (vector-ref cws 4))
(if (eq? (%window-point-moved? window) 'SINCE-START-SET)
(%set-window-point-moved?! window true))
(window-needs-redisplay! window))
-(define-integrable (clear-start-mark! window)
+(define-integrable (clear-window-start! window)
(mark-temporary! (%window-start-line-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))
+ (%set-window-start-line-y! window 0)
+ (%set-window-start-column! window 0)
+ (%set-window-start-partial! window 0))
(define (guarantee-start-mark! window)
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
@@ -1001,9 +1031,7 @@ This number is a percentage, where 0 is the window's top and 100 the bottom."
(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))))))
+ (set-window-start! window (compute-window-start window index y)))))
(if (not (%window-start-line-mark window))
(index-at! (%window-point-index window)
(buffer-window/y-center window))
@@ -1032,7 +1060,9 @@ This number is a percentage, where 0 is the window's top and 100 the bottom."
(%window-current-end-index window))))
(let ((start-y (%window-start-line-y window))
(y-size (window-y-size window))
- (scroll-step (ref-variable scroll-step)))
+ (scroll-step
+ (ref-variable scroll-step
+ (%window-buffer window))))
(if (fix:= 0 scroll-step)
(if (predict-y-limited window start-line
start-y point
diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm
index 7c6e42c36..ada796f00 100644
--- a/v7/src/edwin/bufwiu.scm
+++ b/v7/src/edwin/bufwiu.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwiu.scm,v 1.21 1993/01/09 09:44:07 cph Exp $
+;;; $Id: bufwiu.scm,v 1.22 1993/01/12 10:50:38 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
@@ -79,7 +79,7 @@
(fix:<= start wstart))
(fix:<= wlstart end)))
(begin
- (clear-start-mark! window)
+ (clear-window-start! window)
(window-needs-redisplay! window)))
;; If this change affects POINT, invalidate it. It's
;; not necessary to request a display update here
@@ -131,7 +131,7 @@
(or (fix:>= start (%window-start-line-index window))
(fix:< end (%window-start-index window))))
(begin
- (clear-start-mark! window)
+ (clear-window-start! window)
(window-needs-redisplay! window)))
(let ((point (%window-point-index window)))
(cond ((fix:< point start)
diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm
index 0be0fa57e..bbb5766e0 100644
--- a/v7/src/edwin/bufwmc.scm
+++ b/v7/src/edwin/bufwmc.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: bufwmc.scm,v 1.15 1993/01/09 01:15:59 cph Exp $
+;;; $Id: bufwmc.scm,v 1.16 1993/01/12 10:50:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
@@ -68,12 +68,10 @@
(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))
+ (column->x (group-columns group start index 0 tab-width)
(window-x-size window)
(%window-truncate-lines? window)
- (group-columns group start index 0 tab-width))))
+ (%window-line-end-index? window index))))
(define (buffer-window/index->y window index)
(with-values (lambda () (start-point-for-index window index))
@@ -88,12 +86,10 @@
(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))
+ (group-columns group line-start-index index 0 tab-width)
(window-x-size window)
(%window-truncate-lines? window)
- (group-columns group line-start-index index 0 tab-width))))
+ (%window-line-end-index? window index))))
(cons (car xy)
(fix:+ (cdr xy)
(predict-y window
@@ -208,9 +204,12 @@
(if (fix:< index start)
(loop start y)
(fix:+ y
- (column->y columns x-size truncate-lines?
- (group-columns group start index
- 0 tab-width)))))))
+ (column->y (group-columns group start index
+ 0 tab-width)
+ x-size
+ truncate-lines?
+ (%window-line-end-index? window
+ index)))))))
(let ((group-end (%window-group-end-index window)))
(let loop ((start start) (y y))
(let ((e&c
@@ -222,11 +221,13 @@
x-size
truncate-lines?)))
(fix:+ y
- (column->y (cdr e&c)
+ (column->y (group-columns group start index
+ 0 tab-width)
x-size
truncate-lines?
- (group-columns group start index
- 0 tab-width)))))))))))
+ (%window-line-end-index?
+ window
+ index)))))))))))
(define (predict-y-limited window start y index yl yu)
;; Like PREDICT-Y, except returns #F if the result is not in the
@@ -260,14 +261,16 @@
(let ((y
(fix:+
y
- (column->y columns
- x-size
- truncate-lines?
- (group-columns group
+ (column->y (group-columns group
start
index
0
- tab-width)))))
+ tab-width)
+ x-size
+ truncate-lines?
+ (%window-line-end-index?
+ window
+ index)))))
(and (fix:<= yl y)
(fix:< y yu)
y)))))))
@@ -286,14 +289,16 @@
(let ((y
(fix:+
y
- (column->y (cdr e&c)
- x-size
- truncate-lines?
- (group-columns group
+ (column->y (group-columns group
start
index
0
- tab-width)))))
+ tab-width)
+ x-size
+ truncate-lines?
+ (%window-line-end-index?
+ window
+ index)))))
(and (fix:<= yl y)
(fix:< y yu)
y)))))))))))
@@ -318,14 +323,16 @@
truncate-lines?)))
(let ((y
(fix:+ y
- (column->y (cdr e&c)
- x-size
- truncate-lines?
- (group-columns group
+ (column->y (group-columns group
start
index
0
- tab-width)))))
+ tab-width)
+ x-size
+ truncate-lines?
+ (%window-line-end-index?
+ window
+ index)))))
(and (fix:<= 0 y)
(fix:< y y-size))))))))))
@@ -351,16 +358,18 @@
truncate-lines?))))
(if (fix:< y y-start)
(loop start y-start)
- (group-column->index
- group start end 0
- (let ((column
- (coordinates->column x
- (fix:- y y-start)
- x-size)))
- (if (fix:< column columns)
- column
- columns))
- tab-width))))))
+ (vector-ref
+ (group-column->index
+ group start end 0
+ (let ((column
+ (coordinates->column x
+ (fix:- y y-start)
+ x-size)))
+ (if (fix:< column columns)
+ column
+ columns))
+ tab-width)
+ 0))))))
(let ((group-end (%window-group-end-index window)))
(let loop ((start start) (y-start y-start))
(let ((e&c (group-line-columns group start group-end 0 tab-width)))
@@ -372,99 +381,202 @@
(if (fix:>= y y-end)
(and (fix:< (car e&c) group-end)
(loop (fix:+ (car e&c) 1) y-end))
- (group-column->index
- group start (car e&c) 0
- (let ((column
- (coordinates->column x
- (fix:- y y-start)
- x-size)))
- (if (fix:< column (cdr e&c))
- column
- (cdr e&c)))
- tab-width)))))))))
+ (vector-ref (group-column->index
+ group start (car e&c) 0
+ (let ((column
+ (coordinates->column x
+ (fix:- y y-start)
+ x-size)))
+ (if (fix:< column (cdr e&c))
+ column
+ (cdr e&c)))
+ tab-width)
+ 0)))))))))
-(define (predict-start-line window index y)
- (let ((start (%window-line-start-index window index))
- (group (%window-group window))
+(define (compute-window-start window index y-index)
+ ;; INDEX is an index into WINDOW's buffer, and Y-INDEX is the
+ ;; desired y coordinate, in WINDOW's coordinate space, at which
+ ;; INDEX is desired to appear. Returns a vector of values:
+ ;; 0 START-LINE, index at start of first line that is visible in the
+ ;; window.
+ ;; 1 Y-START, coordinate at which START-LINE will appear. Negative
+ ;; if START-LINE is less than START, otherwise zero.
+ ;; 2 START, index of first visible char (in upper left corner).
+ ;; 3 START-COLUMN, first visible column of window. Positive if
+ ;; START is greater than START-LINE, otherwise zero.
+ ;; 4 START-PARTIAL. If START char is fully visible, this is zero.
+ ;; Otherwise this is positive and indicates the number of columns
+ ;; that *are* visible.
+ ;; 5 #F means that it's not possible to place the INDEX char at
+ ;; Y-INDEX, but that the other values are a starting point that
+ ;; gets the INDEX char as close as possible to Y-INDEX.
+ ;; Otherwise, this is #T indicating that the starting point is
+ ;; satisfactory.
+ (if (%window-truncate-lines? window)
+ (compute-window-start-tl window index y-index)
+ (compute-window-start-ntl window index y-index)))
+
+(define (compute-window-start-tl window index y-index)
+ (let ((group (%window-group window)))
+ (let ((group-start (group-display-start-index group))
+ (group-end (group-display-end-index group)))
+ (let ((start
+ (let ((index
+ (group-find-previous-char group group-start index
+ #\newline)))
+ (if index
+ (fix:+ index 1)
+ group-start))))
+ (cond ((fix:= y-index 0)
+ (vector start y-index start 0 0 #t))
+ ((fix:< y-index 0)
+ (let loop ((start start) (y-start y-index))
+ (let ((nl
+ (group-find-next-char group start group-end
+ #\newline)))
+ (if nl
+ (let ((start (fix:+ nl 1))
+ (y-start (fix:+ y-start 1)))
+ (if (fix:= y-start 0)
+ (vector start y-start start 0 0 #t)
+ (loop start y-start)))
+ (vector start 0 start 0 0 #f)))))
+ ((fix:= start group-start)
+ (vector start 0 start 0 0 #f))
+ (else
+ (let loop ((end (fix:- start 1)) (y-start y-index))
+ (let ((nl
+ (group-find-previous-char group group-start end
+ #\newline))
+ (y-start (fix:- y-start 1)))
+ (cond ((fix:= y-start 0)
+ (let ((start (if nl (fix:+ nl 1) group-start)))
+ (vector start y-start start 0 0 #t)))
+ ((not nl)
+ (vector group-start 0 group-start 0 0 #f))
+ (else
+ (loop nl y-start)))))))))))
+
+(define (compute-window-start-ntl window index y-index)
+ (let ((group (%window-group window))
(tab-width (%window-tab-width window))
- (x-size (window-x-size window))
- (truncate-lines? (%window-truncate-lines? window))
- (group-end (%window-group-end-index window)))
- (let ((y
- (fix:- y
- (column->y (cdr (group-line-columns group
- start
- group-end
- 0
- tab-width))
- x-size
- truncate-lines?
- (group-columns group start index 0 tab-width)))))
- (cond ((fix:= y 0)
- (values start y))
- ((fix:< y 0)
- (let loop ((start start) (y y))
- (let ((e&c
- (group-line-columns group start group-end
- 0 tab-width)))
- (let ((y-end
- (fix:+ y
- (column->y-size (cdr e&c)
+ (x-size (window-x-size window)))
+ (let ((group-start (group-display-start-index group))
+ (group-end (group-display-end-index group))
+ (x-max (fix:- x-size 1)))
+ (let ((start
+ (let ((index
+ (group-find-previous-char group group-start index
+ #\newline)))
+ (if index
+ (fix:+ index 1)
+ group-start))))
+ (let ((y-start
+ (fix:- y-index
+ (column->y (group-columns group start index 0 tab-width)
+ x-size
+ #f
+ (%window-line-end-index? window index)))))
+ (cond ((fix:= y-start 0)
+ (vector start y-start start 0 0 #t))
+ ((fix:< y-start 0)
+ (let loop ((start start) (y-start y-start))
+ (let* ((column (fix:* (fix:- 0 y-start) x-max))
+ (icp
+ (group-column->index group start group-end
+ 0 column tab-width)))
+ (cond ((fix:= (vector-ref icp 1) column)
+ (vector start
+ y-start
+ (vector-ref icp 0)
+ (vector-ref icp 1)
+ (vector-ref icp 2)
+ #t))
+ ((fix:= (vector-ref icp 0) group-end)
+ (vector start 0 start 0 0 #f))
+ (else
+ (loop (fix:+ (vector-ref icp 0) 1)
+ (fix:+
+ y-start
+ (column->y-size (vector-ref icp 1)
+ x-size
+ #f))))))))
+ ((fix:= start group-start)
+ (vector start 0 start 0 0 #f))
+ (else
+ (let loop ((end (fix:- start 1)) (y-start y-start))
+ (let ((nl
+ (group-find-previous-char group group-start end
+ #\newline)))
+ (let ((start (if nl (fix:+ nl 1) group-start)))
+ (let ((y-start
+ (fix:-
+ y-start
+ (column->y-size (group-columns group start end
+ 0 tab-width)
x-size
- truncate-lines?))))
- (if (and (fix:<= y-end 0)
- (fix:< (car e&c) group-end))
- (loop (fix:+ (car e&c) 1) y-end)
- (values start y))))))
- (else
- (let ((group-start (%window-group-start-index window)))
- (let loop ((start start) (y y))
- (if (fix:<= start group-start)
- (values start 0)
- (let* ((end (fix:- start 1))
- (start
- (or (%find-previous-newline group end group-start)
- group-start))
- (columns
- (group-columns group start end 0 tab-width))
- (y-start
- (fix:- y
- (column->y-size columns
- x-size
- truncate-lines?))))
- (if (fix:<= y-start 0)
- (values start y-start)
- (loop start y-start)))))))))))
+ #f))))
+ (cond ((fix:= y-start 0)
+ (vector start y-start start 0 0 #t))
+ ((fix:< y-start 0)
+ (let ((icp
+ (group-column->index
+ group start end
+ 0 (fix:* (fix:- 0 y-start) x-max)
+ tab-width)))
+ (vector start
+ y-start
+ (vector-ref icp 0)
+ (vector-ref icp 1)
+ (vector-ref icp 2)
+ #t)))
+ ((not nl)
+ (vector group-start 0 group-start 0 0 #f))
+ (else
+ (loop nl y-start))))))))))))))
-(define (predict-start-index window start y-start)
- ;; Assumes (AND (%WINDOW-LINE-START-INDEX? WINDOW START) (<= Y-START 0))
- (if (fix:= 0 y-start)
- start
- (let ((group (%window-group window))
- (tab-width (%window-tab-width window))
- (x-size (window-x-size window)))
- (let ((e&c
- (group-line-columns group
- start
- (%window-group-end-index window)
- 0
- tab-width))
- (y (fix:- 0 y-start)))
- (let ((index
- (group-column->index group start (car e&c) 0
- (let ((column
- (coordinates->column 0 y x-size)))
- (if (fix:< column (cdr e&c))
- column
- (cdr e&c)))
- tab-width)))
- (if (let ((xy
- (column->coordinates (cdr e&c)
- x-size
- (%window-truncate-lines? window)
- (group-columns group start index
- 0 tab-width))))
- (and (fix:= (car xy) 0)
- (fix:= (cdr xy) y)))
- index
- (fix:+ index 1)))))))
\ No newline at end of file
+;;;; Column<->Coordinate Utilities
+
+(define (column->y-size column-size x-size truncate-lines?)
+ ;; Assume X-SIZE > 1.
+ (cond ((or truncate-lines? (fix:< column-size x-size))
+ 1)
+ ((fix:= (fix:remainder column-size (fix:- x-size 1)) 0)
+ (fix:quotient column-size (fix:- x-size 1)))
+ (else
+ (fix:+ (fix:quotient column-size (fix:- x-size 1)) 1))))
+
+(define (column->coordinates column x-size truncate-lines? line-end?)
+ (let ((x-max (fix:- x-size 1)))
+ (cond ((fix:< column x-max)
+ (cons column 0))
+ (truncate-lines?
+ (cons x-max 0))
+ ((and line-end? (fix:= (fix:remainder column x-max) 0))
+ (cons x-max (fix:- (fix:quotient column x-max) 1)))
+ (else
+ (cons (fix:remainder column x-max)
+ (fix:quotient column x-max))))))
+
+(define (column->x column x-size truncate-lines? line-end?)
+ (let ((x-max (fix:- x-size 1)))
+ (cond ((fix:< column x-max)
+ column)
+ (truncate-lines?
+ x-max)
+ ((and line-end? (fix:= (fix:remainder column x-max) 0))
+ x-max)
+ (else
+ (fix:remainder column x-max)))))
+
+(define (column->y column x-size truncate-lines? line-end?)
+ (let ((x-max (fix:- x-size 1)))
+ (cond ((or truncate-lines? (fix:< column x-max))
+ 0)
+ ((and line-end? (fix:= (fix:remainder column x-max) 0))
+ (fix:- (fix:quotient column x-max) 1))
+ (else
+ (fix:quotient column x-max)))))
+
+(define-integrable (coordinates->column x y x-size)
+ (fix:+ x (fix:* y (fix:- x-size 1))))
\ No newline at end of file
diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm
index e8a7a5f93..e63e7098e 100644
--- a/v7/src/edwin/decls.scm
+++ b/v7/src/edwin/decls.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: decls.scm,v 1.44 1993/01/09 01:16:04 cph Exp $
+$Id: decls.scm,v 1.45 1993/01/12 10:50:39 cph Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
@@ -209,8 +209,8 @@ MIT in each case. |#
"edtfrm"))
(sf-class "window" "class")
(sf-class "utlwin" "window" "class")
- (sf-class "bufwin" "utlwin" "window" "class" "buffer" "struct")
- (sf-class "bufwfs" "bufwin" "utlwin" "window" "class" "buffer" "struct")
- (sf-class "bufwiu" "bufwin" "utlwin" "window" "class" "buffer" "struct")
- (sf-class "bufwmc" "bufwin" "utlwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwfs" "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwiu" "bufwin" "window" "class" "buffer" "struct")
+ (sf-class "bufwmc" "bufwin" "window" "class" "buffer" "struct")
(sf-class "buffrm" "bufwin" "window" "class" "struct"))
\ No newline at end of file
diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm
index e3a382c40..da4c6baa9 100644
--- a/v7/src/edwin/image.scm
+++ b/v7/src/edwin/image.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: image.scm,v 1.129 1993/01/09 01:16:13 cph Exp $
+;;; $Id: image.scm,v 1.130 1993/01/12 10:50:40 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
@@ -46,32 +46,26 @@
(declare (usual-integrations))
-(define (string-line-columns string column tab-width)
- (substring-line-columns string 0 (string-length string) column tab-width))
-
-(define (substring-line-columns string start end column tab-width)
- (if tab-width
- (let loop ((index start) (column column))
- (if (fix:= index end)
- (cons index column)
- (let ((ascii (vector-8b-ref string index)))
- (if (fix:= ascii (char->integer #\newline))
- (cons index column)
- (loop (fix:+ index 1)
- (fix:+ column
- (if (fix:= ascii (char->integer #\tab))
- (fix:- tab-width
- (fix:remainder column tab-width))
- (vector-ref char-image-lengths ascii))))))))
- (let loop ((index start) (column column))
- (if (fix:= index end)
- (cons index column)
- (let ((ascii (vector-8b-ref string index)))
- (if (fix:= ascii (char->integer #\newline))
- (cons index column)
- (loop (fix:+ index 1)
- (fix:+ column
- (vector-ref char-image-lengths ascii)))))))))
+(define (group-columns 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-columns text start end column tab-width))
+ ((fix:<= gap-start start)
+ (substring-columns text
+ (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ column
+ tab-width))
+ (else
+ (substring-columns text
+ gap-end
+ (fix:+ end gap-length)
+ (substring-columns text start gap-start
+ column tab-width)
+ tab-width)))))
(define (string-columns string column tab-width)
(substring-columns string 0 (string-length string) column tab-width))
@@ -93,47 +87,6 @@
(vector-ref char-image-lengths
(vector-8b-ref string index)))))
((fix:= index end) column))))
-
-(define-integrable (substring-column->index string start end start-column
- tab-width column)
- (car (%substring-column->index string start end start-column tab-width
- column)))
-
-(define (%substring-column->index string start end start-column tab-width
- column)
- ;; If COLUMN falls in the middle of a multi-column character, the
- ;; index returned is that of the character. Thinking of the index
- ;; as a pointer between characters, the value is the pointer to the
- ;; left of the multi-column character. Only if COLUMN reaches
- ;; across the character will the right-hand pointer be returned.
- ;; Various things depend on this.
- (if tab-width
- (let loop ((index start) (c start-column))
- (if (or (fix:= c column)
- (fix:= index end)
- (fix:= (char->integer #\newline) (vector-8b-ref string index)))
- (cons index c)
- (let ((c
- (fix:+ c
- (let ((ascii (vector-8b-ref string index)))
- (if (fix:= ascii (char->integer #\tab))
- (fix:- tab-width (fix:remainder c tab-width))
- (vector-ref char-image-lengths ascii))))))
- (if (fix:> c column)
- (cons index c)
- (loop (fix:+ index 1) c)))))
- (let loop ((index start) (c start-column))
- (if (or (fix:= c column)
- (fix:= index end)
- (fix:= (char->integer #\newline) (vector-8b-ref string index)))
- (cons index c)
- (let ((c
- (fix:+ c
- (vector-ref char-image-lengths
- (vector-8b-ref string index)))))
- (if (fix:> c column)
- (cons index c)
- (loop (fix:+ index 1) c)))))))
(define-integrable char-image-lengths
'#(2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
@@ -146,6 +99,7 @@
4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4))
(define (group-line-columns group start end column tab-width)
+ ;; Like GROUP-COLUMNS, but stops at line end.
(let ((text (group-text group))
(gap-start (group-gap-start group))
(gap-end (group-gap-end group))
@@ -174,54 +128,106 @@
tab-width)))
(cons (fix:- (car i&c) gap-length) (cdr i&c)))))))))
-(define (group-columns 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-columns text start end column tab-width))
- ((fix:<= gap-start start)
- (substring-columns text
- (fix:+ start gap-length)
- (fix:+ end gap-length)
- column
- tab-width))
- (else
- (substring-columns text
- gap-end
- (fix:+ end gap-length)
- (substring-columns text start gap-start
- column tab-width)
- tab-width)))))
+(define (string-line-columns string column tab-width)
+ (substring-line-columns string 0 (string-length string) column tab-width))
+(define (substring-line-columns string start end column tab-width)
+ (if tab-width
+ (let loop ((index start) (column column))
+ (if (fix:= index end)
+ (cons index column)
+ (let ((ascii (vector-8b-ref string index)))
+ (if (fix:= ascii (char->integer #\newline))
+ (cons index column)
+ (loop (fix:+ index 1)
+ (fix:+ column
+ (if (fix:= ascii (char->integer #\tab))
+ (fix:- tab-width
+ (fix:remainder column tab-width))
+ (vector-ref char-image-lengths ascii))))))))
+ (let loop ((index start) (column column))
+ (if (fix:= index end)
+ (cons index column)
+ (let ((ascii (vector-8b-ref string index)))
+ (if (fix:= ascii (char->integer #\newline))
+ (cons index column)
+ (loop (fix:+ index 1)
+ (fix:+ column
+ (vector-ref char-image-lengths ascii)))))))))
+
(define (group-column->index group start end start-column 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-column->index text start end start-column tab-width
- column))
+ (substring-column->index text start end start-column column
+ tab-width))
((fix:<= gap-start start)
- (fix:- (substring-column->index text
+ (let ((result
+ (substring-column->index text
(fix:+ start gap-length)
(fix:+ end gap-length)
start-column
- tab-width
- column)
- gap-length))
+ column
+ tab-width)))
+ (vector-set! result 0 (fix:- (vector-ref result 0) gap-length))
+ result))
(else
- (let ((i&c
- (%substring-column->index text start gap-start
- start-column tab-width column)))
- (if (and (fix:< (cdr i&c) column)
- (not (char=? #\newline (string-ref text (car i&c)))))
- (fix:- (substring-column->index text gap-end
+ (let ((result
+ (substring-column->index text start gap-start
+ start-column column tab-width)))
+ (if (and (fix:< (vector-ref result 1) column)
+ (not (char=? #\newline
+ (string-ref text (vector-ref result 0)))))
+ (let ((result
+ (substring-column->index text
+ gap-end
(fix:+ end gap-length)
- (cdr i&c) tab-width column)
- gap-length)
- (car i&c)))))))
+ (fix:+ (vector-ref result 1)
+ (vector-ref result 2))
+ column
+ tab-width)))
+ (vector-set! result 0
+ (fix:- (vector-ref result 0) gap-length))
+ result)
+ result))))))
+
+(define (substring-column->index string start end start-column column
+ tab-width)
+ ;; If COLUMN falls in the middle of a multi-column character, the
+ ;; index returned is that of the character. Thinking of the index
+ ;; as a pointer between characters, the value is the pointer to the
+ ;; left of the multi-column character. Only if COLUMN reaches
+ ;; across the character will the right-hand pointer be returned.
+ ;; Various things depend on this.
+ (if tab-width
+ (let loop ((index start) (c start-column))
+ (if (or (fix:= c column)
+ (fix:= index end)
+ (fix:= (char->integer #\newline) (vector-8b-ref string index)))
+ (vector index c 0)
+ (let ((c
+ (fix:+ c
+ (let ((ascii (vector-8b-ref string index)))
+ (if (fix:= ascii (char->integer #\tab))
+ (fix:- tab-width (fix:remainder c tab-width))
+ (vector-ref char-image-lengths ascii))))))
+ (if (fix:> c column)
+ (vector index column (fix:- c column))
+ (loop (fix:+ index 1) c)))))
+ (let loop ((index start) (c start-column))
+ (if (or (fix:= c column)
+ (fix:= index end)
+ (fix:= (char->integer #\newline) (vector-8b-ref string index)))
+ (vector index c 0)
+ (let ((c
+ (fix:+ c
+ (vector-ref char-image-lengths
+ (vector-8b-ref string index)))))
+ (if (fix:> c column)
+ (vector index column (fix:- c column))
+ (loop (fix:+ index 1) c)))))))
(define (substring-image! string string-start string-end
image image-start image-end
diff --git a/v7/src/edwin/motion.scm b/v7/src/edwin/motion.scm
index d9645eb4b..b0cfc4c3f 100644
--- a/v7/src/edwin/motion.scm
+++ b/v7/src/edwin/motion.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: motion.scm,v 1.84 1993/01/09 01:16:18 cph Exp $
+;;; $Id: motion.scm,v 1.85 1993/01/12 10:50:40 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
;;;
@@ -204,9 +204,10 @@
(let ((group (mark-group mark))
(index (mark-index mark)))
(make-mark group
- (group-column->index group
- (line-start-index group index)
- (group-end-index group)
- 0
- column
- (group-tab-width group)))))
\ No newline at end of file
+ (vector-ref (group-column->index group
+ (line-start-index group index)
+ (group-end-index group)
+ 0
+ column
+ (group-tab-width group))
+ 0))))
\ No newline at end of file
diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm
index 26e5a318c..93e383832 100644
--- a/v7/src/edwin/undo.scm
+++ b/v7/src/edwin/undo.scm
@@ -1,6 +1,6 @@
;;; -*-Scheme-*-
;;;
-;;; $Id: undo.scm,v 1.52 1993/01/10 10:48:22 cph Exp $
+;;; $Id: undo.scm,v 1.53 1993/01/12 10:50:41 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
;;;
@@ -250,7 +250,8 @@ A numeric argument serves as a repeat count."
(define (undo-start buffer)
(let ((undo-data (group-undo-data (buffer-group buffer))))
(if (eq? #t undo-data)
- (editor-error "No undo information in this buffer:" buffer))
+ (editor-error "No undo information in this buffer: "
+ (buffer-name buffer)))
undo-data))
(define (undo-more buffer undo-data n)
@@ -258,7 +259,8 @@ A numeric argument serves as a repeat count."
(if (> n 0)
(begin
(if (null? undo-data)
- (editor-error "No further undo information:" buffer))
+ (editor-error "No further undo information: "
+ (buffer-name buffer)))
(loop (undo-one-step buffer undo-data) (- n 1)))
undo-data)))
@@ -269,8 +271,8 @@ A numeric argument serves as a repeat count."
(outside-visible-range
(lambda ()
(editor-error
- "Changes to be undone are outside visible portion of buffer:"
- buffer))))
+ "Changes to be undone are outside visible portion of buffer: "
+ (buffer-name buffer)))))
(let ((finish
(lambda (data)
(set-buffer-point! buffer point)
diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm
index 446a89d5e..2dcab1aff 100644
--- a/v7/src/edwin/utlwin.scm
+++ b/v7/src/edwin/utlwin.scm
@@ -1,8 +1,8 @@
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Id: utlwin.scm,v 1.58 1993/01/12 10:50:41 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
@@ -46,64 +46,6 @@
(declare (usual-integrations))
-;;;; Column<->Coordinate Utilities
-
-(define (column->x-size column-size y-size truncate-lines?)
- ;; Assume Y-SIZE > 0.
- (cond (truncate-lines?
- column-size)
- ((fix:= (fix:remainder column-size y-size) 0)
- (fix:quotient column-size y-size))
- (else
- (fix:+ (fix:quotient column-size y-size) 1))))
-
-(define (column->y-size column-size x-size truncate-lines?)
- ;; Assume X-SIZE > 1.
- (cond ((or truncate-lines? (fix:< column-size x-size))
- 1)
- ((fix:= (fix:remainder column-size (fix:- x-size 1)) 0)
- (fix:quotient column-size (fix:- x-size 1)))
- (else
- (fix:+ (fix:quotient column-size (fix:- x-size 1)) 1))))
-
-(define (column->coordinates column-size x-size truncate-lines? column)
- (let ((-1+x-size (fix:- x-size 1)))
- (cond ((fix:< column -1+x-size)
- (cons column 0))
- (truncate-lines?
- (cons -1+x-size 0))
- ((and (fix:= (fix:remainder column -1+x-size) 0)
- (fix:= column column-size))
- (cons -1+x-size
- (fix:-1+ (fix:quotient column -1+x-size))))
- (else
- (cons (fix:remainder column -1+x-size)
- (fix:quotient column -1+x-size))))))
-
-(define (column->x column-size x-size truncate-lines? column)
- (let ((-1+x-size (fix:- x-size 1)))
- (cond ((fix:< column -1+x-size)
- column)
- (truncate-lines?
- -1+x-size)
- ((and (fix:= (fix:remainder column -1+x-size) 0)
- (fix:= column column-size))
- -1+x-size)
- (else
- (fix:remainder column -1+x-size)))))
-
-(define (column->y column-size x-size truncate-lines? column)
- (cond ((or truncate-lines? (fix:< column (fix:- x-size 1)))
- 0)
- ((and (fix:= (fix:remainder column (fix:- x-size 1)) 0)
- (fix:= column column-size))
- (fix:- (fix:quotient column (fix:- x-size 1)) 1))
- (else
- (fix:quotient column (fix:- x-size 1)))))
-
-(define-integrable (coordinates->column x y x-size)
- (fix:+ x (fix:* y (fix:- x-size 1))))
-
;;;; Blank Window
(define-class blank-window vanilla-window