;;; -*-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
;;;
;; 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
(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)))
\f
(define-integrable (%window-modified-tick window)
(with-instance-variables buffer-window window () modified-tick))
(%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)
((%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)
(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)))
(<= 0 cursor-centering-point 100))))
\f
(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
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)
(%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))
\f
(define (guarantee-start-mark! window)
(let ((mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(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))
(%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
;;; -*-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
;;;
(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
(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)
;;; -*-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
;;;
(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))
(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
(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
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)))))))))))
\f
(define (predict-y-limited window start y index yl yu)
;; Like PREDICT-Y, except returns #F if the result is not in the
(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)))))))
(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)))))))))))
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))))))))))
\f
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)))
(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)))))))))
\f
-(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)))))))))))
+\f
+(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))))))))))))))
\f
-(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
#| -*-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
"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
;;; -*-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
;;;
(declare (usual-integrations))
\f
-(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))
(vector-ref char-image-lengths
(vector-8b-ref string index)))))
((fix:= index end) column))))
-\f
-(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
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 (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))
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)))))))))
+\f
(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)))))))
\f
(define (substring-image! string string-start string-end
image image-start image-end
;;; -*-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
;;;
(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
;;; -*-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
;;;
(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)
(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)))
\f
(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)
;;; -*-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
(declare (usual-integrations))
\f
-;;;; 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))))
-\f
;;;; Blank Window
(define-class blank-window vanilla-window
projects / mit-scheme.git / commitdiff