;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.139 1991/03/16 00:01:19 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.140 1991/03/22 00:30:44 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(make-event-distributor))
(define (make-buffer name mode directory)
- (let ((group (region-group (string->region ""))))
- (let ((buffer (%make-buffer)))
+ (let ((buffer (%make-buffer)))
+ (let ((group (make-group (string-copy "") buffer)))
(vector-set! buffer buffer-index:name name)
(vector-set! buffer buffer-index:group group)
(let ((daemon (buffer-modification-daemon buffer)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.38 1991/01/15 00:13:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.39 1991/03/22 00:30:50 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989, 1990, 1991 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
(set-inferior-y-size! border-inferior y))
(set-inferior-start! border-inferior false false))
(set-inferior-start! text-inferior 0 0)
- (set-inferior-size! text-inferior x y))
- (if (window-buffer window)
- (window-setup-truncate-lines! window)))
+ (set-inferior-size! text-inferior x y)))
(define-method buffer-frame (:minimum-x-size window)
(if (window-has-right-neighbor? window)
(if (window-buffer frame)
(remove-buffer-window! (window-buffer frame) frame))
(buffer-window/set-buffer! (frame-text-inferior frame) buffer)
- (add-buffer-window! buffer frame)
- (window-setup-truncate-lines! frame))))
+ (add-buffer-window! buffer frame))))
(define-integrable (window-point frame)
(buffer-window/point (frame-text-inferior frame)))
(define-integrable (set-window-debug-trace! frame debug-trace)
(%set-window-debug-trace! (frame-text-inferior frame) debug-trace))
\f
-(define (window-setup-truncate-lines! frame)
- (let ((window (frame-text-inferior frame))
- (truncate-lines?
- (let ((buffer (window-buffer frame)))
- (or (and (variable-local-value
- buffer
- (ref-variable-object truncate-partial-width-windows))
- (window-has-horizontal-neighbor? frame))
- (variable-local-value buffer
- (ref-variable-object truncate-lines))))))
- (if (not (boolean=? (%window-truncate-lines? window) truncate-lines?))
- (without-interrupts
- (lambda ()
- (%set-window-truncate-lines?! window truncate-lines?)
- (buffer-window/redraw! window))))))
-
(define-variable-per-buffer truncate-lines
- "*True means do not display continuation lines;
+ "True means do not display continuation lines;
give each line of text one screen line.
Automatically becomes local when set in any fashion.
Note that this is overridden by the variable
truncate-partial-width-windows if that variable is true
and this buffer is not full-screen width."
- false)
+ false
+ boolean?)
(define-variable truncate-partial-width-windows
- "*True means truncate lines in all windows less than full screen wide."
- true)
+ "True means truncate lines in all windows less than full screen wide."
+ true
+ boolean?)
+
+(define-variable-per-buffer tab-width
+ "Distance between tab stops (for display of tab characters), in columns.
+Automatically becomes local when set in any fashion."
+ 8
+ exact-nonnegative-integer?)
(let ((setup-truncate-lines!
(lambda (variable)
variable ;ignore
- (for-each window-setup-truncate-lines! (window-list)))))
+ (for-each window-redraw! (window-list)))))
(add-variable-assignment-daemon!
(ref-variable-object truncate-lines)
setup-truncate-lines!)
(add-variable-assignment-daemon!
(ref-variable-object truncate-partial-width-windows)
+ setup-truncate-lines!)
+ (add-variable-assignment-daemon!
+ (ref-variable-object tab-width)
setup-truncate-lines!))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.9 1990/11/02 03:22:42 cph Rel $
+;;; $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 $
;;;
-;;; 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
inferiors
(let* ((end (fix:- start 1))
(start (%window-line-start-index window end))
- (inferior (make-line-inferior window start 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)))))
top-inferiors top-start
bottom-inferiors bottom-start)
;; Assumes non-null TOP-INFERIORS and BOTTOM-INFERIORS.
- (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 ((end (%window-line-end-index window start)))
- (let ((inferior (make-line-inferior window start end)))
- (%set-inferior-y-start! inferior y-start)
- (cons inferior
- (loop (fix:+ end 1)
- (fix:+ y-start
- (inferior-y-size inferior))))))))))))
+ (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)
-
+\f
(define (fill-bottom! window inferiors start)
;; Assumes non-null INFERIORS.
(let loop ((inferiors inferiors) (start start))
(let ((end
(fix:+ start
- (line-window-length
+ (string-base:string-length
(inferior-window (car inferiors))))))
(if (not (null? (cdr inferiors)))
(loop (cdr inferiors) (fix:+ end 1))
(define (generate-line-inferiors window start y-start)
;; Assumes (FIX:< Y-START (WINDOW-Y-SIZE WINDOW))
- (let ((y-size (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 ((end (%window-line-end-index window start)))
- (let ((inferior (make-line-inferior window start end)))
+ (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 (or (%window-group-end-index? window end)
- (fix:>= y-start y-size))
+ (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 end)
- '())
- (loop y-start (fix:+ end 1))))))))))
+ (set-current-end-index! window (cdr image&index))
+ '())))))))))
\f
(define (scroll-lines! window inferiors start y-start)
(cond ((or (null? inferiors)
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
;; The buffer being displayed in this window.
buffer
+ ;; Caches for the values of buffer-local variables that are needed
+ ;; for redisplay.
+ truncate-lines?
+ tab-width
+
;; The point marker in this window.
point
- ;; If this flag is false, text lines that are too long to fit on
- ;; a single window line are displayed with multiple window lines.
- ;; If the flag is true, such text lines are truncated to single
- ;; window lines.
- truncate-lines?
-
;; This is the inferior window (of class CURSOR-WINDOW) that
;; displays the cursor for this window.
cursor-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 LINE-WINDOW) that displays the message.
+ ;; window (of class STRING-BASE) that displays the message.
override-inferior
- ;; A list of the inferior windows (of class LINE-WINDOW) that are
+ ;; 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
(with-instance-variables buffer-window window (buffer*)
(set! buffer buffer*)))
+(define-integrable (%window-truncate-lines? window)
+ (with-instance-variables buffer-window window () truncate-lines?))
+
+(define-integrable (%set-window-truncate-lines?! window truncate-lines?*)
+ (with-instance-variables buffer-window window (truncate-lines?*)
+ (set! truncate-lines? truncate-lines?*)))
+
+(define-integrable (%window-tab-width window)
+ (with-instance-variables buffer-window window () tab-width))
+
+(define-integrable (%set-window-tab-width! window tab-width*)
+ (with-instance-variables buffer-window window (tab-width*)
+ (set! tab-width tab-width*)))
+
(define-integrable (%window-point window)
(with-instance-variables buffer-window window () point))
index
true)))
-(define-integrable (%window-truncate-lines? window)
- (with-instance-variables buffer-window window () truncate-lines?))
-
-(define-integrable (%set-window-truncate-lines?! window truncate-lines?*)
- (with-instance-variables buffer-window window (truncate-lines?*)
- (set! truncate-lines? truncate-lines?*)))
-
(define-integrable (%window-cursor-inferior window)
(with-instance-variables buffer-window window () cursor-inferior))
(define (%clear-window-buffer-state! window)
(%set-window-buffer! window false)
(%set-window-point! window false)
- (%set-window-truncate-lines?! window false)
(if (%window-start-line-mark window)
(clear-start-mark! window))
(%set-window-point-moved?! window false)
(mark-temporary! (%window-end-clip-mark window))
(%set-window-start-clip-mark! window false)
(%set-window-end-clip-mark! window false))))
+
+(define (%recache-window-buffer-local-variables! window)
+ (let ((buffer (%window-buffer window)))
+ (%set-window-truncate-lines?!
+ window
+ (or (variable-local-value buffer (ref-variable-object truncate-lines))
+ (and (variable-local-value
+ buffer
+ (ref-variable-object truncate-partial-width-windows))
+ (window-has-horizontal-neighbor? (window-superior window)))))
+ (%set-window-tab-width!
+ window
+ (variable-local-value buffer (ref-variable-object tab-width)))))
\f
;;;; Buffer and Point
\f
;;;; Line Inferiors
-(define-class line-window string-base
- ())
-
-(define-integrable (make-line-inferior window start end)
- (%make-line-inferior window (%window-extract-string window start end)))
-
-(define (%make-line-inferior window string)
- (let ((window* (make-object line-window))
+(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)
- (%set-window-x-size! window* (window-x-size window))
- (let ((*image (string->image string 0)))
- (%set-window-y-size! window*
- (column->y-size (image-column-size *image)
- (window-x-size window)
- (%window-truncate-lines? window)))
- (with-instance-variables line-window window*
- (*image %window-truncate-lines? window)
- (set! image *image)
- (set! truncate-lines? (%window-truncate-lines? window))))
- (string-base:refresh! window*)
+ (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-window-image window)
- (with-instance-variables line-window window () image))
-
-(define-integrable (line-window-string window)
- (image-string (line-window-image window)))
-
-(define-integrable (line-window-length window)
- (string-length (line-window-string window)))
-
(define-integrable (line-inferior-length inferior)
- (fix:+ (line-window-length (inferior-window inferior)) 1))
+ (fix:+ (string-base:string-length (inferior-window inferior)) 1))
(define (buffer-window/override-message window)
(let ((inferior (%window-override-inferior window)))
(and inferior
- (line-window-string (inferior-window inferior)))))
+ (let ((window (inferior-window inferior)))
+ (string-head (string-base:string window)
+ (string-base:string-length 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)))
+ (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!
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $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 $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(if (%window-force-redraw? window)
(begin
(%set-window-force-redraw?! window false)
+ (%recache-window-buffer-local-variables! window)
(preserve-nothing! window))
(let ((start (%window-current-start-index window))
(end (%window-current-end-index window)))
#\newline)
(let ((y-start
(fix:+ (inferior-y-start (%window-cursor-inferior window)) 1)))
- (let ((inferior (make-inferior window line-window)))
+ (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)
;;; -*-Scheme-*-
;;;
-;;; $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 $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.10 1991/03/22 00:31:13 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))
(fix:+ (inferior-x-start inferior)
(string-base:index->x (inferior-window inferior)
(fix:- index start)))))
- (let ((start (%window-line-start-index window index)))
- (%window-column->x window
- (%window-line-columns window start index)
- (%window-column-length window start index 0)))))
+ (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)
(fix:+ (cdr xy) (inferior-y-start inferior))))))
(begin
(guarantee-start-mark! window)
- (let ((start (%window-line-start-index window index)))
+ (let ((start (%window-line-start-index window index))
+ (group (%window-group window))
+ (tab-width (%window-tab-width window)))
(let ((xy
- (%window-column->coordinates
- window
- (%window-line-columns window start index)
- (%window-column-length window start index 0))))
+ (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
;; Assuming that the character at index START appears at coordinate
;; Y, return the coordinate for the character at INDEX. START is
;; assumed to be a line start.
- (cond ((fix:= index start)
- y)
- ((fix:< index start)
- (let loop ((start start) (y 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)
- (fix:+ y (%window-line-y window columns start index))))))
- (else
- (let loop ((start start) (y y))
- (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)))
- (fix:+ y (%window-line-y window columns start index))))))))
-
+ (if (fix:= index start)
+ y
+ (let ((group (%window-group window))
+ (tab-width (%window-tab-width window))
+ (x-size (window-x-size window))
+ (truncate-lines? (%window-truncate-lines? window)))
+ (if (fix:< index start)
+ (let ((group-start (%window-group-start-index window)))
+ (let loop ((start start) (y y))
+ (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
+ (fix:- y
+ (column->y-size columns
+ x-size
+ truncate-lines?))))
+ (if (fix:< index start)
+ (loop start y)
+ (fix:+ y
+ (column->y columns x-size truncate-lines?
+ (group-columns group start index
+ 0 tab-width)))))))
+ (let ((group-end (%window-group-end-index window)))
+ (let loop ((start start) (y y))
+ (let ((e&c
+ (group-line-columns group start group-end 0 tab-width)))
+ (if (fix:> index (car e&c))
+ (loop (fix:+ (car e&c) 1)
+ (fix:+ y
+ (column->y-size (cdr e&c)
+ x-size
+ truncate-lines?)))
+ (fix:+ y
+ (column->y (cdr e&c)
+ x-size
+ truncate-lines?
+ (group-columns group start index
+ 0 tab-width)))))))))))
+\f
(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)))))))))
+ (if (fix:= index start)
+ (and (fix:<= yl y)
+ (fix:< y yu)
+ y)
+ (let ((group (%window-group window))
+ (tab-width (%window-tab-width window))
+ (x-size (window-x-size window))
+ (truncate-lines? (%window-truncate-lines? window)))
+ (if (fix:< index start)
+ (let ((group-start (%window-group-start-index window)))
+ (let loop ((start start) (y y))
+ (and (fix:<= yl y)
+ (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
+ (fix:- y
+ (column->y-size columns
+ x-size
+ truncate-lines?))))
+ (if (fix:< index start)
+ (loop start y)
+ (let ((y
+ (fix:+
+ y
+ (column->y columns
+ x-size
+ truncate-lines?
+ (group-columns group
+ start
+ index
+ 0
+ tab-width)))))
+ (and (fix:<= yl y)
+ (fix:< y yu)
+ y)))))))
+ (let ((group-end (%window-group-end-index window)))
+ (let loop ((start start) (y y))
+ (and (fix:< y yu)
+ (let ((e&c
+ (group-line-columns group start group-end 0
+ tab-width)))
+ (if (fix:> index (car e&c))
+ (loop (fix:+ (car e&c) 1)
+ (fix:+ y
+ (column->y-size (cdr e&c)
+ x-size
+ truncate-lines?)))
+ (let ((y
+ (fix:+
+ y
+ (column->y (cdr e&c)
+ x-size
+ truncate-lines?
+ (group-columns group
+ start
+ index
+ 0
+ tab-width)))))
+ (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)))
+ (let ((x-size (window-x-size window))
+ (y-size (window-y-size window))
+ (group (%window-group window))
+ (tab-width (%window-tab-width window))
+ (truncate-lines? (%window-truncate-lines? window))
+ (group-end (%window-group-end-index window)))
(let loop ((start start) (y y))
(and (fix:< y y-size)
- (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 ((e&c
+ (group-line-columns group start group-end 0 tab-width)))
+ (if (fix:> index (car e&c))
+ (loop (fix:+ (car e&c) 1)
+ (fix:+ y
+ (column->y-size (cdr e&c)
+ x-size
+ truncate-lines?)))
(let ((y
- (fix:+
- y
- (%window-line-y window columns start index))))
- (and (fix:<= 0 y) (fix:< y y-size))))))))))
-
+ (fix:+ y
+ (column->y (cdr e&c)
+ x-size
+ truncate-lines?
+ (group-columns group
+ start
+ index
+ 0
+ tab-width)))))
+ (and (fix:<= 0 y)
+ (fix:< y y-size))))))))))
+\f
(define (predict-index window start y-start x y)
;; Assumes that START is a line start.
- (if (fix:< y y-start)
- (let loop ((start start) (y-start y-start))
- (and (not (%window-group-start-index? window start))
- (let* ((end (fix:- start 1))
- (start (%window-line-start-index window end))
- (columns (%window-column-length window start end 0))
- (y-start
- (fix:- y-start (%window-column->y-size window columns))))
- (if (fix:< y y-start)
- (loop start y-start)
- (%window-coordinates->index window start end columns
- x (fix:- y y-start))))))
- (let loop ((start start) (y-start y-start))
- (let* ((end (%window-line-end-index window start))
- (columns (%window-column-length window start end 0))
- (y-end
- (fix:+ y-start (%window-column->y-size window columns))))
- (if (fix:>= y y-end)
- (and (not (%window-group-end-index? window end))
- (loop (fix:+ end 1) y-end))
- (%window-coordinates->index window start end columns
- x (fix:- y y-start)))))))
+ (let ((group (%window-group window))
+ (tab-width (%window-tab-width window))
+ (x-size (window-x-size window))
+ (truncate-lines? (%window-truncate-lines? window)))
+ (if (fix:< y y-start)
+ (let ((group-start (%window-group-start-index window)))
+ (let loop ((start start) (y-start y-start))
+ (and (fix:< group-start start)
+ (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-start
+ (column->y-size columns
+ x-size
+ 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))))))
+ (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)))
+ (let ((y-end
+ (fix:+ y-start
+ (column->y-size (cdr e&c)
+ x-size
+ truncate-lines?))))
+ (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)))))))))
\f
(define (predict-start-line window index y)
- (let ((start (%window-line-start-index window index)))
+ (let ((start (%window-line-start-index window index))
+ (group (%window-group window))
+ (tab-width (%window-tab-width window))
+ (x-size (window-x-size window))
+ (truncate-lines? (%window-truncate-lines? window)))
(let ((y
(fix:- y
- (%window-line-y window
- (%window-line-columns window start index)
- start
- index))))
+ (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* ((end (%window-line-end-index window start))
- (columns (%window-column-length window start end 0))
- (y-end
- (fix:+ y (%window-column->y-size window columns))))
- (if (and (fix:<= y-end 0)
- (not (%window-group-end-index? window end)))
- (loop (fix:+ end 1) y-end)
- (values start y)))))
+ (let ((group-end (%window-group-end-index window)))
+ (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
+ 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 loop ((start start) (y y))
- (if (%window-group-start-index? window start)
- (values start 0)
- (let* ((end (fix:- start 1))
- (start (%window-line-start-index window end))
- (columns (%window-column-length window start end 0))
- (y-start
- (fix:- y (%window-column->y-size window columns))))
- (if (fix:<= y-start 0)
- (values start y-start)
- (loop start y-start))))))))))
-
+ (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
(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 ((end (%window-line-end-index window start))
- (y (fix:- 0 y-start)))
- (let ((length (%window-column-length window start end 0)))
+ (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
- (%window-coordinates->index window start end length 0 y)))
+ (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
- (%window-index->coordinates window start length index)))
+ (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
(and (fix:= (car xy) 0)
(fix:= (cdr xy) y)))
(fix:+ start index)
- (fix:+ (fix:+ start index) 1)))))))
-\f
-(define-integrable (%window-column-length window start end column)
- (group-column-length (%window-group window) start end column))
-
-(define-integrable (%window-column->index window start end column-start column)
- (group-column->index (%window-group window) start end column-start column))
-
-(define-integrable (%window-line-columns window start index)
- (%window-column-length window start (%window-line-end-index window index) 0))
-
-(define-integrable (%window-line-y window columns start index)
- (%window-column->y window
- columns
- (%window-column-length window start index 0)))
-
-(define-integrable (%window-column->y-size window column-size)
- (column->y-size column-size
- (window-x-size window)
- (%window-truncate-lines? window)))
-
-(define-integrable (%window-column->x window column-size column)
- (column->x column-size
- (window-x-size window)
- (%window-truncate-lines? window)
- column))
-
-(define-integrable (%window-column->y window column-size column)
- (column->y column-size
- (window-x-size window)
- (%window-truncate-lines? window)
- column))
-
-(define-integrable (%window-column->coordinates window column-size column)
- (column->coordinates column-size
- (window-x-size window)
- (%window-truncate-lines? window)
- column))
-
-(define (%window-coordinates->index window start end column-length x y)
- (%window-column->index
- window start end 0
- (let ((column (coordinates->column x y (window-x-size window))))
- (if (fix:< column column-length)
- column
- column-length))))
-
-(define-integrable (%window-index->coordinates window start column-length
- index)
- (%window-column->coordinates window
- column-length
- (%window-column-length window start index 0)))
\ No newline at end of file
+ (fix:+ (fix:+ start index) 1)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.16 1991/03/16 00:01:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/decls.scm,v 1.17 1991/03/22 00:31:17 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(sf-class (sf-dependent 'class-syntax-table)))
(for-each sf-global
'("bufinp"
- "bufott"
"bufout"
"class"
"clscon"
"clsmac"
"comtab"
"display"
- "image"
"macros"
"make"
"nvector"
"winren"
"xform"
"xterm"))
- (sf-global "tterm" "termcap")
(for-each sf-edwin
'("argred"
"autold"
'("comwin"
"modwin"
"edtfrm"))
+ (sf-global "tterm" "termcap")
+ (sf-global "image" "struct")
(sf-edwin "grpops" "struct")
(sf-edwin "regops" "struct")
(sf-edwin "motion" "struct")
(sf-edwin "curren" "buffer")
(sf-class "window" "class")
(sf-class "utlwin" "window" "class")
- (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 "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 "buffrm" "bufwin" "window" "class" "struct"))
\ No newline at end of file
syntax-table/system-internal)
("bufmnu" (edwin buffer-menu)
edwin-syntax-table)
- ("bufott" (edwin buffer-output-port-truncating)
- syntax-table/system-internal)
("bufout" (edwin buffer-output-port)
syntax-table/system-internal)
("bufset" (edwin)
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.12 1991/03/16 00:01:57 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.13 1991/03/22 00:31:28 cph Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "comred" (->environment '(EDWIN COMMAND-READER)))
(load "bufinp" (->environment '(EDWIN BUFFER-INPUT-PORT)))
(load "bufout" (->environment '(EDWIN BUFFER-OUTPUT-PORT)))
- (load "bufott" (->environment '(EDWIN BUFFER-OUTPUT-PORT-TRUNCATING)))
(load "winout" (->environment '(EDWIN WINDOW-OUTPUT-PORT)))
(load "things" environment)
(load "tparse" environment)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.25 1991/03/16 00:02:03 cph Exp $
+$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 $
Copyright (c) 1989-91 Massachusetts Institute of Technology
group-insert-string!
group-insert-substring!
group-left-char
- group-right-char))
+ group-right-char
+ guarantee-gap-length!
+ move-gap-to!))
(define-package (edwin comtab)
(files "comtab")
edwin-variable$cursor-centering-point
edwin-variable$mode-line-inverse-video
edwin-variable$scroll-step
+ edwin-variable$tab-width
edwin-variable$truncate-lines
edwin-variable$truncate-partial-width-windows
set-window-debug-trace!
window-scroll-y-relative!
window-select-time
window-set-override-message!
- window-setup-truncate-lines!
window-start-mark
window-y-center)
(export (edwin screen)
mark->output-port
with-output-to-mark))
-(define-package (edwin buffer-output-port-truncating)
- (files "bufott")
- (parent (edwin))
- (export (edwin)
- truncation-protect
- with-output-to-mark-truncating))
-
(define-package (edwin window-output-port)
(files "winout")
(parent (edwin))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.19 1991/02/15 18:13:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.20 1991/03/22 00:31:39 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(lambda (port)
(write-condition-report condition port)))))
(if (and (not (string-find-next-char string #\newline))
- (< (string-column-length string 18) 80))
+ (< (string-columns string 18 false) 80))
(message "Evaluation error: " string)
(begin
(string->temporary-buffer string "*Error*")
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.92 1991/02/15 18:13:37 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.93 1991/03/22 00:31:46 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((truename (pathname->input-truename pathname)))
(if truename
(begin
- (let ((region (file->region-interactive truename)))
- (region-delete! (buffer-unclipped-region buffer))
- (region-insert! (buffer-start buffer) region))
- (set-buffer-point! buffer (buffer-start buffer))
- (set-buffer-modification-time! buffer
- (file-modification-time truename))))
+ (region-delete! (buffer-unclipped-region buffer))
+ (%insert-file (buffer-start buffer) truename)
+ (set-buffer-point! buffer (buffer-start buffer))
+ (set-buffer-modification-time! buffer
+ (file-modification-time truename))))
(set-buffer-truename! buffer truename))
(set-buffer-save-length! buffer)
(buffer-not-modified! buffer)
(let ((pathname (->pathname filename)))
(let ((truename (pathname->input-truename pathname)))
(if truename
- (region-insert! mark (file->region-interactive truename))
+ (%insert-file mark truename)
(editor-error "File " (pathname->string pathname) " not found")))))
(define-variable read-file-message
"If true, messages are displayed when files are read into the editor."
false)
-(define (file->region-interactive truename)
- (if (ref-variable read-file-message)
- (let ((filename (pathname->string truename)))
- (temporary-message "Reading file \"" filename "\"")
- (let ((region (file->region truename)))
- (append-message " -- done")
- region))
- (file->region truename)))
-
-(define (file->region pathname)
- (call-with-input-file pathname port->region))
-
-(define (port->region port)
- (group-region
- (make-group
- (let ((rest->string (input-port/operation port 'REST->STRING)))
- (if rest->string
- (rest->string port)
- (read-string char-set:null port))))))
+(define (%insert-file mark truename)
+ (let ((doit
+ (lambda ()
+ (group-insert-file! (mark-group mark) (mark-index mark) truename))))
+ (if (ref-variable read-file-message)
+ (begin
+ (temporary-message "Reading file \""
+ (pathname->string truename)
+ "\"")
+ (doit)
+ (append-message " -- done"))
+ (doit))))
+
+(define (group-insert-file! group index truename)
+ (let ((channel (file-open-input-channel (pathname->string truename))))
+ (let ((length (file-length channel)))
+ (without-interrupts
+ (lambda ()
+ (move-gap-to! group index)
+ (guarantee-gap-length! group length)))
+ (let ((n
+ (channel-read channel
+ (group-text group)
+ index
+ (+ index length))))
+ (without-interrupts
+ (lambda ()
+ (vector-set! group
+ group-index:gap-length
+ (fix:- (group-gap-length group) n))
+ (let ((gap-start* (fix:+ index n)))
+ (vector-set! group group-index:gap-start gap-start*)
+ (undo-record-insertion! group index gap-start*)
+ (record-insertion! group index gap-start*))))
+ (channel-close channel)
+ n))))
\f
;;;; Buffer Mode Initialization
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.126 1990/11/02 03:24:25 cph Rel $
+;;; $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 $
;;;
-;;; Copyright (c) 1986, 1989 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
(declare (usual-integrations))
\f
-;;; Display imaging is the process by which strings are converted into
-;;; an image which can be displayed on a screen. The IMAGE
-;;; abstraction, implemented here, captures that process. Given a
-;;; string, it is capable of generating another string which is the
-;;; visual representation of that string. In addition, it retains the
-;;; ability to associate indices into the string with columns in the
-;;; representation.
+(define (string-line-columns string column tab-width)
+ (substring-line-columns string 0 (string-length string) column tab-width))
-;;; *** One important note: the image abstraction will not "correctly"
-;;; display strings that contain newlines. Currently, a newline in
-;;; such a string will be represented by the string "^J" (or perhaps
-;;; "^M"). This is so because images are intended to be used on a
-;;; per-line basis; that is, the string should be for a single line.
+(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)))))))))
-;;; Images are implemented in terms of another abstraction, called a
-;;; PARSE, which describes how characters in the string are displayed.
-;;; Most characters are represented by themselves (these are called
-;;; "graphic" characters), but others (called "non-graphic"
-;;; characters) are represented by strings of graphic characters.
+(define (string-columns string column tab-width)
+ (substring-columns string 0 (string-length string) column tab-width))
-;;; A parse, then, is a list of alternating index/string pairs. The
-;;; index is the position of the next non-graphic character in the
-;;; string, and the following string is its representation. If two or
-;;; more non-graphic characters are adjacent, then the list contains a
-;;; single index, followed by the representations of each of the
-;;; non-graphic characters, in succession. Finally, if the
-;;; non-graphic characters appear at the beginning of the string, then
-;;; the index is omitted altogether.
-
-;;; This representation has a number of advantages.
-
-;;; [] Most of the time, there are no non-graphic characters in the
-;;; string; then the parse is the empty list.
-
-;;; [] Adjacent non-graphic characters (tabs) are common in indented
-;;; Lisp code; this representation optimizes specially for this
-;;; case.
-
-;;; [] The association of string indices and image columns is very
-;;; straightforward.
-
-(define-structure (image (type vector) (constructor false))
- (string false read-only true)
- (start-index false read-only true)
- (start-column false read-only true)
- (parse false read-only true)
- (column-size false read-only true))
-
-(define (make-null-image)
- (vector "" 0 0 '() 0))
-
-(define-integrable (string->image string start-column)
- (string-head->image string 0 start-column))
-
-(define (string-head->image string start start-column)
- (parse-substring-for-image string start (string-length string) start-column
- (lambda (parse column-size)
- (vector string start start-column parse column-size))))
-
-(define (image-index-size image)
- (fix:- (string-length (image-string image)) (image-start-index image)))
-
-(define (image-direct-output-insert-char! image char)
- (vector-set! image 0 (string-append-char (vector-ref image 0) char))
- (vector-set! image 4 (fix:1+ (vector-ref image 4))))
-
-(define (image-direct-output-insert-substring! image string start end)
- (vector-set! image 0
- (string-append-substring (vector-ref image 0)
- string start end))
- (vector-set! image 4 (fix:+ (vector-ref image 4) (fix:- end start))))
+(define (substring-columns string start end column tab-width)
+ (if tab-width
+ (do ((index start (fix:+ index 1))
+ (column column
+ (fix:+ column
+ (let ((ascii (vector-8b-ref string index)))
+ (if (fix:= ascii (char->integer #\tab))
+ (fix:- tab-width
+ (fix:remainder column tab-width))
+ (vector-ref char-image-lengths ascii))))))
+ ((fix:= index end) column))
+ (do ((index start (fix:+ index 1))
+ (column column
+ (fix:+ column
+ (vector-ref char-image-lengths
+ (vector-8b-ref string index)))))
+ ((fix:= index end) column))))
\f
-(define (image-representation image)
- (let ((string (image-string image))
- (result (string-allocate (image-column-size image))))
- (let ((string-end (string-length string)))
- (let loop
- ((parse (image-parse image))
- (string-start (image-start-index image))
- (result-start 0))
- (cond ((null? parse)
- (substring-move-left! string string-start string-end
- result result-start))
- ((string? (car parse))
- (let ((size (string-length (car parse))))
- (substring-move-left! (car parse) 0 size result result-start)
- (loop (cdr parse)
- (fix:1+ string-start)
- (fix:+ result-start size))))
- ((number? (car parse))
- (substring-move-left! string string-start (car parse)
- result result-start)
- (loop (cdr parse)
- (car parse)
- (fix:+ result-start (fix:- (car parse) string-start))))
- (else
- (error "Bad parse element" (car parse))))))
- result))
+(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 (image-index->column image index)
- (let loop
- ((parse (image-parse image))
- (start (image-start-index image))
- (column (image-start-column image)))
- (cond ((null? parse)
- (fix:+ column (fix:- index start)))
- ((string? (car parse))
- (if (fix:= index start)
- column
- (loop (cdr parse)
- (fix:1+ start)
- (fix:+ column (string-length (car parse))))))
- ((number? (car parse))
- (if (fix:> index (car parse))
- (loop (cdr parse)
- (car parse)
- (fix:+ column (fix:- (car parse) start)))
- (fix:+ column (fix:- index start))))
- (else
- (error "Bad parse element" (car parse))))))
-
-(define (image-column->index image 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.
- (let loop
- ((parse (image-parse image))
- (start (image-start-index image))
- (c (image-start-column image)))
- (cond ((null? parse)
- (fix:+ start (fix:- column c)))
- ((string? (car parse))
- (let ((new-c (fix:+ c (string-length (car parse)))))
- (if (fix:< column new-c)
- start
- (loop (cdr parse) (fix:1+ start) new-c))))
- ((number? (car parse))
- (let ((new-c (fix:+ c (fix:- (car parse) start))))
- (if (fix:< column new-c)
- (fix:+ start (fix:- column c))
- (loop (cdr parse) (car parse) new-c))))
- (else
- (error "Bad parse element" (car parse))))))
-\f
-;;;; String Operations
+ (if tab-width
+ (let loop ((index start) (c start-column))
+ (if (or (fix:= c column) (fix:= index end))
+ (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))
+ (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 (string-representation string start-column)
- (substring-representation string 0 (string-length string) start-column))
-
-(define (substring-representation string start end start-column)
- (let ((result
- (string-allocate
- (fix:- (substring-column-length string start end start-column)
- start-column))))
- (let loop ((start start) (column start-column) (rindex 0))
- (let* ((index
- (substring-find-next-char-in-set string start end
- char-set:not-graphic))
- (copy-representation!
- (lambda (column rindex)
- (let* ((representation
- (char-representation (string-ref string index) column))
- (size (string-length representation)))
- (substring-move-right! representation 0 size result rindex)
- (loop (fix:1+ index)
- (fix:+ column size)
- (fix:+ rindex size))))))
- (cond ((not index)
- (substring-move-right! string start end result rindex)
- result)
- ((fix:= start index)
- (copy-representation! column rindex))
- (else
- (substring-move-right! string start index result rindex)
- (let ((size (fix:- index start)))
- (copy-representation! (fix:+ column size)
- (fix:+ rindex size)))))))))
+(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
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 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
+ 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
+ 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-column-length string start-column)
- (substring-column-length string 0 (string-length string) start-column))
+(define (string-line-image string column tab-width)
+ (substring-line-image string 0 (string-length string) column tab-width))
-(define (string-index->column string start-column index)
- (fix:+ start-column (substring-column-length string 0 index start-column)))
+(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 (substring-column-length string start end start-column)
- (let loop ((i start) (c start-column))
- (let ((index
- (substring-find-next-char-in-set string i end
- char-set:not-graphic)))
- (if (not index)
- (fix:+ c (fix:- end i))
- (loop (fix:1+ index)
- (let ((c (fix:+ c (fix:- index i))))
- (fix:+ c
- (char-column-length (string-ref string index)
- c))))))))
+(define (string-image string column tab-width)
+ (substring-image string 0 (string-length string) column tab-width))
-(define (string-column->index string start-column column if-lose)
- (substring-column->index string 0 (string-length string) start-column
- column if-lose))
+(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-column->index string start end start-column column
- #!optional if-lose)
- ;; 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 (fix:zero? column)
- start
- (let loop ((i start) (c start-column) (left (fix:- column start-column)))
- (let ((index
- (substring-find-next-char-in-set string i end
- char-set:not-graphic)))
- (if (not index)
- (let ((n (fix:- end i)))
- (cond ((not (fix:> left n)) (fix:+ i left))
- ((default-object? if-lose) end)
- (else (if-lose (fix:+ c n)))))
- (let ((n (fix:- index i)))
- (if (fix:> left n)
- (let ((c (fix:+ c n))
- (left (fix:- left n)))
+(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
- (char-column-length (string-ref string index) c)))
- (cond ((fix:< left n) index)
- ((fix:= left n) (fix:1+ index))
- (else
- (loop (fix:1+ index)
- (fix:+ c n)
- (fix:- left n))))))
- (fix:+ i left))))))))
+ (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
-;;;; Parsing
+(define (group-line-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-line-columns text start end column tab-width))
+ ((fix:<= gap-start start)
+ (let ((i&c
+ (substring-line-columns text
+ (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ column
+ tab-width)))
+ (cons (fix:- (car i&c) gap-length) (cdr i&c))))
+ (else
+ (let ((i&c
+ (substring-line-columns text start gap-start
+ column tab-width)))
+ (if (fix:< (car i&c) gap-start)
+ i&c
+ (let ((i&c
+ (substring-line-columns text
+ gap-end
+ (fix:+ end gap-length)
+ (cdr i&c)
+ tab-width)))
+ (cons (fix:- (car i&c) gap-length) (cdr i&c)))))))))
-(define (parse-substring-for-image string start end start-column receiver)
- (let ((column-size))
- (let ((parse
- (let loop ((start start) (column start-column))
- (let ((index
- (substring-find-next-char-in-set string start end
- char-set:not-graphic)))
- (if (not index)
- (begin
- (set! column-size (fix:+ column (fix:- end start)))
- '())
- (let ((column (fix:+ column (fix:- index start))))
- (let ((representation
- (char-representation (string-ref string index)
- column)))
- (let ((parse
- (loop (fix:1+ index)
- (fix:+ column
- (string-length representation)))))
- (if (fix:= index start)
- (cons representation parse)
- (cons index (cons representation parse)))))))))))
- (receiver parse column-size))))
+(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 char-column-length)
-(define char-representation)
-(let ((tab-display-images
- #(" " " " " " " " " " " " " " " "))
- (display-images
- #("^@" "^A" "^B" "^C" "^D" "^E" "^F" "^G"
- "^H" "^I" "^J" "^K" "^L" "^M" "^N" "^O"
- "^P" "^Q" "^R" "^S" "^T" "^U" "^V" "^W"
- "^X" "^Y" "^Z" "^[" "^\\" "^]" "^^" "^_"
- " " "!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/"
- "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?"
- "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O"
- "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "_"
- "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o"
- "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?"
- "\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207"
- "\210" "\211" "\212" "\213" "\214" "\215" "\216" "\217"
- "\220" "\221" "\222" "\223" "\224" "\225" "\226" "\227"
- "\230" "\231" "\232" "\233" "\234" "\235" "\236" "\237"
- "\240" "\241" "\242" "\243" "\244" "\245" "\246" "\247"
- "\250" "\251" "\252" "\253" "\254" "\255" "\256" "\257"
- "\260" "\261" "\262" "\263" "\264" "\265" "\266" "\267"
- "\270" "\271" "\272" "\273" "\274" "\275" "\276" "\277"
- "\300" "\301" "\302" "\303" "\304" "\305" "\306" "\307"
- "\310" "\311" "\312" "\313" "\314" "\315" "\316" "\317"
- "\320" "\321" "\322" "\323" "\324" "\325" "\326" "\327"
- "\330" "\331" "\332" "\333" "\334" "\335" "\336" "\337"
- "\340" "\341" "\342" "\343" "\344" "\345" "\346" "\347"
- "\350" "\351" "\352" "\353" "\354" "\355" "\356" "\357"
- "\360" "\361" "\362" "\363" "\364" "\365" "\366" "\367"
- "\370" "\371" "\372" "\373" "\374" "\375" "\376" "\377")))
- (set! char-representation
- (lambda (char column)
- (if (char=? char #\tab)
- (vector-ref tab-display-images (fix:remainder column 8))
- (vector-ref display-images (char->integer char)))))
- (let ((tab-display-lengths (vector-map tab-display-images string-length))
- (display-lengths (vector-map display-images string-length)))
- (set! char-column-length
- (lambda (char column)
- (if (char=? char #\tab)
- (vector-ref tab-display-lengths (fix:remainder column 8))
- (vector-ref display-lengths (char->integer char)))))
- unspecific))
\ No newline at end of file
+(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))
+ ((fix:<= gap-start start)
+ (fix:- (substring-column->index text
+ (fix:+ start gap-length)
+ (fix:+ end gap-length)
+ start-column
+ tab-width
+ column)
+ gap-length))
+ (else
+ (let ((i&c
+ (%substring-column->index text start gap-start
+ start-column tab-width column)))
+ (if (fix:< (cdr i&c) column)
+ (fix:- (substring-column->index text gap-end
+ (fix:+ end gap-length)
+ (cdr i&c) tab-width column)
+ gap-length)
+ (car i&c)))))))
+\f
+(define (group-line-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-line-image text start end column tab-width))
+ ((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))))
+ (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)))))))))
+
+(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))
+ (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
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.10 1991/03/11 01:14:24 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.11 1991/03/22 00:32:01 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
"I-search"
(if (search-state-forward? state) "" " backward")
": "
- (string-representation (search-state-text state) 0)
+ (string-image (search-state-text state) 0 false)
(if invalid-regexp (string-append " [" invalid-regexp "]") ""))))
(string-set! m 0 (char-upcase (string-ref m 0)))
m)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.58 1989/04/28 22:50:41 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.59 1991/03/22 00:32:08 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(else
(let ((m1 (mark-right-inserting (current-point)))
(m2 (mark-right-inserting (current-mark))))
- (let ((r1 (region-extract!
- (make-region (current-point)
- (mark1+ (current-point) 'ERROR))))
- (r2 (region-extract!
- (make-region (current-mark)
- (mark1+ (current-mark) 'ERROR)))))
- (region-insert! m1 r2)
- (region-insert! m2 r1))
- (set-current-point! m1)
- (set-current-mark! m2))))))
+ (if (not (mark= m1 m2))
+ (begin
+ (let ((c1 (extract-right-char m1))
+ (c2 (extract-right-char m2)))
+ (delete-right-char m1)
+ (delete-right-char m2)
+ (insert-char c2 m1)
+ (insert-char c1 m2))
+ (set-current-point! m1)
+ (set-current-mark! m2))))))))
(define (twiddle-characters m1 m2)
(let ((m* (mark-left-inserting m2)))
- (region-insert! m* (region-extract! (make-region (mark-1+ m1 'ERROR) m1)))
+ (let ((char (extract-left-char m1)))
+ (delete-left-char m1)
+ (insert-char char m*))
(set-current-point! m*)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.105 1990/11/16 11:38:07 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.106 1991/03/22 00:32:14 cph Exp $
;;;
-;;; Copyright (c) 1986, 1989 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
(cond ((and (= argument 1) (group-end? (current-point)))
(if (not (line-start? (current-point)))
(insert-newlines 1))
- (let ((region
- (region-extract!
- (make-region (forward-line (current-point) -2 'ERROR)
- (forward-line (current-point) -1 'ERROR)))))
- (region-insert! (current-point) region)))
+ (insert-string (extract-and-delete-string
+ (forward-line (current-point) -2 'ERROR)
+ (forward-line (current-point) -1 'ERROR))
+ (current-point)))
(else
(transpose-things forward-line argument)))))
\f
"\\[delete-indentation] won't insert a space to the left of these."
(char-set #\)))
\f
-(define-variable-per-buffer tab-width
- "Distance between tab stops (for display of tab characters), in columns.
-Automatically becomes local when set in any fashion."
- 8)
-
(define-variable indent-tabs-mode
"If false, do not use tabs for indentation or horizontal spacing."
true)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.28 1991/03/16 08:14:23 cph Exp $
+$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 $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 28 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 29 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.6 1991/03/16 00:02:41 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
line column min-end max-end))
(define (display-substring string start end line column min-end max-end)
- (let ((representation
- (substring-representation string start end column)))
+ (let ((representation (substring-image string start end column false)))
(let ((size (string-length representation)))
(let ((end (+ column size)))
(if (> end max-end)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motion.scm,v 1.82 1990/11/02 03:12:37 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motion.scm,v 1.83 1991/03/22 00:32:37 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(if (not i)
n
(loop (fix:1+ i) n))))))
-\f
+
;;;; Motion by Columns
(define (mark-column mark)
- (group-index->column (mark-group mark) (mark-index mark)))
+ (let ((group (mark-group mark))
+ (index (mark-index mark)))
+ (group-columns group
+ (line-start-index group index)
+ index
+ 0
+ (group-tab-width group))))
(define (move-to-column mark column)
(let ((group (mark-group mark))
(line-start-index group index)
(line-end-index group index)
0
- column))))
-
-(define (group-index->column group index)
- (group-column-length group (line-start-index group index) index 0))
-
-(define (group-column-length group start-index end-index start-column)
- (if (fix:= start-index end-index)
- 0
- (let ((start (group-index->position-integrable group start-index true))
- (end (group-index->position-integrable group end-index false))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
- (text (group-text group)))
- (if (and (fix:<= start gap-start)
- (fix:<= gap-end end))
- (substring-column-length text gap-end end
- (substring-column-length text start gap-start start-column))
- (substring-column-length text start end start-column)))))
-
-(define (group-column->index group start-index end-index start-column column)
- (if (fix:= start-index end-index)
- start-index
- (let ((start (group-index->position-integrable group start-index true))
- (end (group-index->position-integrable group end-index false))
- (gap-start (group-gap-start group))
- (gap-end (group-gap-end group))
- (text (group-text group)))
- (cond ((fix:<= end gap-start)
- (substring-column->index text start end start-column column))
- ((fix:>= start gap-end)
- (fix:- (substring-column->index text start end
- start-column column)
- (group-gap-length group)))
- (else
- (substring-column->index text start gap-start
- start-column column
- (lambda (gap-column)
- (fix:- (substring-column->index text gap-end end
- gap-column column)
- (group-gap-length group)))))))))
\ No newline at end of file
+ column
+ (group-tab-width group)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regops.scm,v 1.80 1989/04/28 22:52:31 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regops.scm,v 1.81 1991/03/22 00:32:43 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define (string->region string)
- (group-region (make-group (string-copy string))))
-
-(define (substring->region string start end)
- (group-region (make-group (substring string start end))))
-
(define (region-insert! mark region)
(let ((string (region->string region))
(group (mark-group mark))
(group-delete! (region-group region)
(region-start-index region)
(region-end-index region)))
-
-(define (region-extract! region)
- (let ((group (region-group region))
- (start (region-start-index region))
- (end (region-end-index region)))
- (let ((string (group-extract-string group start end)))
- (group-delete! group start end)
- (group-region (make-group string)))))
-
-(define (region-copy region)
- (string->region (region->string region)))
\f
(define (mark-left-char mark)
(if (group-start? mark)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.89 1991/03/16 08:13:04 cph Exp $
+;;; $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 $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
;; mean anything.
enable
+ ;; Boolean-vector indicating, for each line, whether there is any
+ ;; highlighting on the line.
+ highlight-enable
+
;; Cursor position.
cursor-x
cursor-y)
(y-size (screen-y-size screen)))
(let ((contents (make-vector y-size))
(highlight (make-vector y-size))
- (enable (make-boolean-vector y-size)))
+ (enable (make-boolean-vector y-size))
+ (highlight-enable (make-boolean-vector y-size)))
(do ((i 0 (fix:1+ i)))
((fix:= i y-size))
(vector-set! contents i (make-string x-size))
(boolean-vector-fill! enable false)
(set-matrix-contents! matrix contents)
(set-matrix-highlight! matrix highlight)
- (set-matrix-enable! matrix enable))
+ (set-matrix-enable! matrix enable)
+ (set-matrix-highlight-enable! matrix highlight-enable))
(set-matrix-cursor-x! matrix false)
(set-matrix-cursor-y! matrix false)
matrix))
(begin
(boolean-vector-set! (matrix-enable new-matrix) y true)
(set-screen-needs-update?! screen true)
- (guarantee-display-line screen y)))
+ (initialize-new-line-contents screen y)))
(string-set! (vector-ref (matrix-contents new-matrix) y) x char)
- (boolean-vector-set! (vector-ref (matrix-highlight new-matrix) y)
- x
- highlight)))
+ (cond ((boolean-vector-ref (matrix-highlight-enable new-matrix) y)
+ (boolean-vector-set! (vector-ref (matrix-highlight new-matrix) y)
+ x highlight))
+ (highlight
+ (boolean-vector-set! (matrix-highlight-enable new-matrix) y true)
+ (initialize-new-line-highlight screen y)
+ (boolean-vector-set! (vector-ref (matrix-highlight new-matrix) y)
+ x highlight)))))
+(define (screen-output-substring screen x y string start end 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)))))
+ (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)))
+ (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))))))
+
+(define-integrable (initialize-new-line-contents screen y)
+ (if (boolean-vector-ref (matrix-enable (screen-current-matrix screen)) y)
+ (string-move!
+ (vector-ref (matrix-contents (screen-current-matrix screen)) y)
+ (vector-ref (matrix-contents (screen-new-matrix screen)) y))
+ (string-fill!
+ (vector-ref (matrix-contents (screen-new-matrix screen)) y)
+ #\space)))
+
+(define-integrable (initialize-new-line-highlight screen y)
+ (if (boolean-vector-ref
+ (matrix-highlight-enable (screen-current-matrix screen))
+ y)
+ (boolean-vector-move!
+ (vector-ref (matrix-highlight (screen-current-matrix screen)) y)
+ (vector-ref (matrix-highlight (screen-new-matrix screen)) y))
+ (boolean-vector-fill!
+ (vector-ref (matrix-highlight (screen-new-matrix screen)) y)
+ false)))
+\f
+(define (screen-clear-rectangle screen xl xu yl yu highlight)
+ (if (screen-debug-trace screen)
+ ((screen-debug-trace screen) 'screen screen 'clear-rectangle
+ xl xu yl yu highlight))
+ (let ((new-matrix (screen-new-matrix screen)))
+ (let ((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)))
+ (cond ((not (and (fix:= xl 0) (fix:= xu (screen-x-size screen))))
+ (let ((current-matrix (screen-current-matrix 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)))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (if (not (boolean-vector-ref new-enable y))
+ (begin
+ (boolean-vector-set! new-enable y true)
+ (if (boolean-vector-ref current-enable y)
+ (begin
+ (string-move! (vector-ref current-contents y)
+ (vector-ref new-contents y))
+ (substring-fill! (vector-ref new-contents y)
+ xl xu #\space))
+ (string-fill! (vector-ref new-contents y)
+ #\space)))
+ (substring-fill! (vector-ref new-contents y)
+ xl xu #\space))
+ (cond ((boolean-vector-ref new-hl-enable y)
+ (boolean-subvector-fill! (vector-ref new-hl y)
+ xl xu highlight))
+ (highlight
+ (boolean-vector-set! new-hl-enable y true)
+ (if (boolean-vector-ref current-hl-enable y)
+ (boolean-vector-move! current-hl
+ (vector-ref new-hl y))
+ (boolean-vector-fill! (vector-ref new-hl y)
+ false))
+ (boolean-subvector-fill! (vector-ref new-hl y)
+ xl xu highlight)))))))
+ (highlight
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (string-fill! (vector-ref new-contents y) #\space)
+ (boolean-vector-fill! (vector-ref new-hl y) true)
+ (boolean-vector-set! new-enable y true)
+ (boolean-vector-set! new-hl-enable y true)))
+ (else
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (string-fill! (vector-ref new-contents y) #\space)
+ (boolean-vector-set! new-enable y true)
+ (boolean-vector-set! new-hl-enable y false))))))
+ (set-screen-needs-update?! screen true))
+\f
(define (screen-direct-output-char screen x y char highlight)
(if (screen-debug-trace screen)
((screen-debug-trace screen) 'screen screen 'direct-output-char
(terminal-move-cursor screen cursor-x y)
(terminal-flush screen)
(string-set! (vector-ref (matrix-contents current-matrix) y) x char)
- (boolean-vector-set! (vector-ref (matrix-highlight current-matrix) y)
- x
- highlight)
+ (cond ((boolean-vector-ref (matrix-highlight-enable current-matrix) y)
+ (boolean-vector-set! (vector-ref (matrix-highlight current-matrix)
+ y)
+ x highlight))
+ (highlight
+ (boolean-vector-set! (matrix-highlight-enable current-matrix)
+ y true)
+ (boolean-vector-set! (vector-ref (matrix-highlight current-matrix)
+ y)
+ x highlight)))
(set-matrix-cursor-x! current-matrix cursor-x)
(set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
-(define (screen-output-substring screen x y string start end 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)))
- (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)
- (guarantee-display-line screen y)))
- (substring-move-left! string start end
- (vector-ref (matrix-contents new-matrix) y) x)
- (boolean-subvector-fill! (vector-ref (matrix-highlight new-matrix) y)
- x (fix:+ x (fix:- end start)) highlight)))
-
(define (screen-direct-output-substring screen x y string start end highlight)
(if (screen-debug-trace screen)
((screen-debug-trace screen) 'screen screen 'direct-output-substring
(terminal-flush screen)
(substring-move-left! string start end
(vector-ref (matrix-contents current-matrix) y) x)
- (boolean-subvector-fill! (vector-ref (matrix-highlight current-matrix) y)
- x cursor-x highlight)
+ (cond ((boolean-vector-ref (matrix-highlight-enable current-matrix) y)
+ (boolean-subvector-fill!
+ (vector-ref (matrix-highlight current-matrix) y)
+ x cursor-x highlight))
+ (highlight
+ (boolean-vector-set! (matrix-highlight-enable current-matrix)
+ y true)
+ (boolean-subvector-fill!
+ (vector-ref (matrix-highlight current-matrix) y)
+ x cursor-x highlight)))
(set-matrix-cursor-x! current-matrix cursor-x)
(set-matrix-cursor-x! (screen-new-matrix screen) cursor-x)))
-(define (guarantee-display-line screen y)
- (let ((current-matrix (screen-current-matrix screen))
- (new-matrix (screen-new-matrix screen)))
- (if (boolean-vector-ref (matrix-enable current-matrix) y)
- (begin
- (string-move! (vector-ref (matrix-contents current-matrix) y)
- (vector-ref (matrix-contents new-matrix) y))
- (boolean-vector-move!
- (vector-ref (matrix-highlight current-matrix) y)
- (vector-ref (matrix-highlight new-matrix) y)))
- (begin
- (string-fill! (vector-ref (matrix-contents new-matrix) y) #\space)
- (boolean-vector-fill! (vector-ref (matrix-highlight new-matrix) y)
- false)))))
-\f
-(define (screen-clear-rectangle screen xl xu yl yu highlight)
- (if (screen-debug-trace screen)
- ((screen-debug-trace screen) 'screen screen 'clear-rectangle
- xl xu yl yu highlight))
- (let ((current-matrix (screen-current-matrix screen))
- (new-matrix (screen-new-matrix screen)))
- (let ((current-contents (matrix-contents current-matrix))
- (current-highlight (matrix-highlight current-matrix))
- (current-enable (matrix-enable current-matrix))
- (new-contents (matrix-contents new-matrix))
- (new-highlight (matrix-highlight new-matrix))
- (new-enable (matrix-enable new-matrix)))
- (if (and (fix:= xl 0) (fix:= xu (screen-x-size screen)))
- (do ((y yl (fix:1+ y)))
- ((fix:= y yu))
- (string-fill! (vector-ref new-contents y) #\space)
- (boolean-vector-fill! (vector-ref new-highlight y) highlight)
- (boolean-vector-set! new-enable y true))
- (do ((y yl (fix:1+ y)))
- ((fix:= y yu))
- (let ((nl (vector-ref new-contents y))
- (nh (vector-ref new-highlight y)))
- (if (boolean-vector-ref new-enable y)
- (begin
- (substring-fill! nl xl xu #\space)
- (boolean-subvector-fill! nh xl xu highlight))
- (begin
- (boolean-vector-set! new-enable y true)
- (set-screen-needs-update?! screen true)
- (if (boolean-vector-ref current-enable y)
- (begin
- (string-move! (vector-ref current-contents y) nl)
- (boolean-vector-move!
- (vector-ref current-highlight y)
- nh)
- (substring-fill! nl xl xu #\space)
- (boolean-subvector-fill! nh xl xu highlight))
- (begin
- (string-fill! nl #\space)
- (boolean-vector-fill! nh false)
- (if highlight
- (boolean-subvector-fill! nh xl xu
- highlight))))))))))))
-
(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))
- (new-matrix (screen-new-matrix screen)))
+ (current-matrix (screen-current-matrix screen)))
(terminal-clear-screen screen)
(let ((current-contents (matrix-contents current-matrix))
- (current-highlight (matrix-highlight current-matrix))
(current-enable (matrix-enable current-matrix))
- (new-contents (matrix-contents new-matrix))
- (new-highlight (matrix-highlight new-matrix))
- (new-enable (matrix-enable new-matrix)))
+ (current-hl-enable (matrix-highlight-enable current-matrix)))
(do ((y 0 (fix:1+ y)))
((fix:= y y-size))
- (if (boolean-vector-ref current-enable y)
- (begin
- (boolean-vector-set! current-enable y false)
- (if (not (boolean-vector-ref new-enable y))
- (begin
- (string-move! (vector-ref current-contents y)
- (vector-ref new-contents y))
- (boolean-vector-move! (vector-ref current-highlight y)
- (vector-ref new-highlight y))))))
(string-fill! (vector-ref current-contents y) #\space)
- (boolean-vector-fill! (vector-ref current-highlight y) false))
- (boolean-vector-fill! current-enable true)))
+ (boolean-vector-set! current-enable y true)
+ (boolean-vector-set! current-hl-enable y false))))
(set-screen-needs-update?! screen true))
\f
(define (screen-scroll-lines-down screen xl xu yl yu amount)
(and scrolled?
(begin
(let ((contents (matrix-contents current-matrix))
- (highlight (matrix-highlight current-matrix)))
+ (hl (matrix-highlight current-matrix))
+ (hl-enable (matrix-highlight-enable current-matrix)))
(do ((y (fix:-1+ (fix:- yu amount)) (fix:-1+ y))
(y* (fix:-1+ yu) (fix:-1+ y*)))
((fix:< y yl))
(substring-move-left! (vector-ref contents y) xl xu
(vector-ref contents y*) xl)
- (boolean-subvector-move-left!
- (vector-ref highlight y) xl xu
- (vector-ref highlight y*) xl)))
- (if (eq? scrolled? 'CLEARED)
- (matrix-clear-rectangle current-matrix
- xl xu yl (fix:+ yl amount)
- false))
+ (cond ((boolean-vector-ref hl-enable y)
+ (boolean-vector-set! hl-enable y* true)
+ (boolean-subvector-move-left!
+ (vector-ref hl y) xl xu
+ (vector-ref hl y*) xl))
+ ((boolean-vector-ref hl-enable y*)
+ (boolean-subvector-fill! (vector-ref hl y*) xl xu
+ false))))
+ (if (eq? scrolled? 'CLEARED)
+ (let ((yu (fix:+ yl amount)))
+ (if (and (fix:= xl 0)
+ (fix:= xu (screen-x-size screen)))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (substring-fill! (vector-ref contents y) xl xu
+ #\space)
+ (boolean-vector-set! hl-enable y false))
+ (do ((y yl (fix:1+ y)))
+ ((fix:= y yu))
+ (substring-fill! (vector-ref contents y) xl xu
+ #\space)
+ (if (boolean-vector-ref hl-enable y)
+ (boolean-subvector-fill! (vector-ref hl y)
+ xl xu false)))))))
scrolled?))))))
-
+\f
(define (screen-scroll-lines-up screen xl xu yl yu amount)
(if (screen-debug-trace screen)
((screen-debug-trace screen) 'screen screen 'scroll-lines-up
(and scrolled?
(begin
(let ((contents (matrix-contents current-matrix))
- (highlight (matrix-highlight current-matrix)))
+ (hl (matrix-highlight current-matrix))
+ (hl-enable (matrix-highlight-enable current-matrix)))
(do ((y yl (fix:1+ y))
(y* (fix:+ yl amount) (fix:1+ y*)))
((fix:= y* yu))
(substring-move-left! (vector-ref contents y*) xl xu
(vector-ref contents y) xl)
- (boolean-subvector-move-left!
- (vector-ref highlight y*) xl xu
- (vector-ref highlight y) xl)))
- (if (eq? scrolled? 'CLEARED)
- (matrix-clear-rectangle current-matrix
- xl xu (fix:- yu amount) yu
- false))
+ (cond ((boolean-vector-ref hl-enable y*)
+ (boolean-vector-set! hl-enable y true)
+ (boolean-subvector-move-left!
+ (vector-ref hl y*) xl xu
+ (vector-ref hl y) xl))
+ ((boolean-vector-ref hl-enable y)
+ (boolean-subvector-fill! (vector-ref hl y) xl xu
+ false))))
+ (if (eq? scrolled? 'CLEARED)
+ (if (and (fix:= xl 0)
+ (fix:= xu (screen-x-size screen)))
+ (do ((y (fix:- yu amount) (fix:1+ y)))
+ ((fix:= y yu))
+ (substring-fill! (vector-ref contents y) xl xu
+ #\space)
+ (boolean-vector-set! hl-enable y false))
+ (do ((y (fix:- yu amount) (fix:1+ y)))
+ ((fix:= y yu))
+ (substring-fill! (vector-ref contents y) xl xu
+ #\space)
+ (if (boolean-vector-ref hl-enable y)
+ (boolean-subvector-fill! (vector-ref hl y)
+ xl xu false))))))
scrolled?))))))
-
-(define (matrix-clear-rectangle matrix xl xu yl yu hl)
- (let ((contents (matrix-contents matrix))
- (highlight (matrix-highlight matrix)))
- (do ((y yl (fix:1+ y)))
- ((fix:= y yu))
- (substring-fill! (vector-ref contents y) xl xu #\space)
- (boolean-subvector-fill! (vector-ref highlight y) xl xu hl))))
\f
(define (with-screen-in-update screen display-style thunk)
(without-interrupts
(let ((current-matrix (screen-current-matrix screen))
(new-matrix (screen-new-matrix screen))
(x-size (screen-x-size screen)))
- (let ((current-contents (vector-ref (matrix-contents current-matrix) y))
- (current-highlight (vector-ref (matrix-highlight current-matrix) y))
- (new-contents (vector-ref (matrix-contents new-matrix) y))
- (new-highlight (vector-ref (matrix-highlight new-matrix) y)))
- (cond ((not (and (boolean-vector-ref (matrix-enable current-matrix) y)
- (boolean-vector=? current-highlight new-highlight)))
- (update-line-ignore-current screen y
- new-contents new-highlight x-size))
- ((string=? current-contents new-contents)
- unspecific)
- ((boolean-vector-all-elements? new-highlight false)
- (update-line-no-highlight screen y current-contents new-contents))
- (else
- (update-line-ignore-current screen y
- new-contents new-highlight x-size)))
- ;; Update current-matrix to contain the new line.
- (vector-set! (matrix-contents current-matrix) y new-contents)
- (vector-set! (matrix-highlight current-matrix) y new-highlight)
- (boolean-vector-set! (matrix-enable current-matrix) y true)
- ;; Move the old line to new-matrix so that it can be reused.
- (vector-set! (matrix-contents new-matrix) y current-contents)
- (vector-set! (matrix-highlight new-matrix) y current-highlight)
- (boolean-vector-set! (matrix-enable new-matrix) y false))))
-
+ (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))
+ (new-contents (matrix-contents new-matrix))
+ (new-hl (matrix-highlight new-matrix))
+ (new-hl-enable (matrix-highlight-enable new-matrix)))
+ (let ((ccy (vector-ref current-contents y))
+ (chy (vector-ref current-hl y))
+ (ncy (vector-ref new-contents y))
+ (nhy (vector-ref new-hl y))
+ (nhey (boolean-vector-ref new-hl-enable y)))
+ (cond (nhey
+ (update-line-ignore-current screen y ncy nhy x-size))
+ ((and (boolean-vector-ref current-enable y)
+ (not (boolean-vector-ref current-hl-enable y)))
+ (update-line-no-highlight screen y ccy ncy))
+ (else
+ (update-line-trivial screen y ncy x-size)))
+ (vector-set! current-contents y ncy)
+ (boolean-vector-set! current-enable y true)
+ (vector-set! new-contents y ccy)
+ (boolean-vector-set! (matrix-enable new-matrix) y false)
+ (if nhey
+ (begin
+ (vector-set! current-hl y nhy)
+ (boolean-vector-set! current-hl-enable y true)
+ (vector-set! new-hl y chy)
+ (boolean-vector-set! new-hl-enable y false))
+ (boolean-vector-set! current-hl-enable y false))))))
+\f
(define (update-line-no-highlight screen y oline nline)
(let ((x-size (screen-x-size screen)))
(let ((olen (substring-non-space-end oline 0 x-size))
(nlen (substring-non-space-end nline 0 x-size)))
(let ((len (fix:min olen nlen)))
- (let loop ((x 0))
- (let ((x
- (fix:+ x (substring-match-forward oline x len nline x len))))
- (if (fix:= x len)
- (if (fix:< x nlen)
- (terminal-output-substring screen x y
- nline x nlen false))
- (let find-match ((x* (fix:1+ x)))
- (cond ((fix:= x* len)
- (if (fix:< x nlen)
- (terminal-output-substring screen x y
- nline x nlen false)))
- ((fix:= (vector-8b-ref oline x*)
- (vector-8b-ref nline x*))
- (let ((n
- (substring-match-forward oline x* len
- nline x* len)))
- ;; Ignore matches of 4 characters or less. The
- ;; overhead of moving the cursor and drawing
- ;; the characters is too much except for very
- ;; slow terminals.
- (if (fix:< n 5)
- (find-match (fix:+ x* n))
- (begin
- (terminal-output-substring screen x y
- nline x x* false)
- (loop (fix:+ x* n))))))
- (else
- (find-match (fix:1+ x*)))))))))
+ (let find-mismatch ((x 0))
+ (cond ((fix:= x len)
+ (if (fix:< x nlen)
+ (terminal-output-substring screen x y
+ nline x nlen false)))
+ ((fix:= (vector-8b-ref oline x)
+ (vector-8b-ref nline x))
+ (find-mismatch (fix:+ x 1)))
+ (else
+ (let find-match ((x* (fix:+ x 1)))
+ (cond ((fix:= x* len)
+ (terminal-output-substring screen x y
+ nline x nlen false))
+ ((not (fix:= (vector-8b-ref oline x*)
+ (vector-8b-ref nline x*)))
+ (find-match (fix:+ x* 1)))
+ (else
+ ;; Ignore matches of 4 characters or less.
+ ;; The overhead of moving the cursor and
+ ;; drawing the characters is too much except
+ ;; for very slow terminals.
+ (let find-end-match ((x** (fix:+ x* 1)))
+ (cond ((fix:= x** len)
+ (if (fix:< (fix:- x** x*) 5)
+ (terminal-output-substring screen x y
+ nline x nlen
+ false)
+ (begin
+ (terminal-output-substring screen x y
+ nline x x*
+ false)
+ (if (fix:< x** nlen)
+ (terminal-output-substring
+ screen x** y
+ nline x** nlen false)))))
+ ((fix:= (vector-8b-ref oline x**)
+ (vector-8b-ref nline x**))
+ (find-end-match (fix:+ x** 1)))
+ ((fix:< (fix:- x** x*) 5)
+ (find-match x**))
+ (else
+ (terminal-output-substring screen x y
+ nline x x* false)
+ (find-mismatch x**)))))))))))
(if (fix:< nlen olen)
(terminal-clear-line screen nlen y olen)))))
-\f
+
(define (update-line-ignore-current screen y nline highlight x-size)
(cond ((not (boolean-subvector-uniform? highlight 0 x-size))
(let loop ((x 0))
((boolean-vector-ref highlight 0)
(terminal-output-substring screen 0 y nline 0 x-size true))
(else
- (let ((xe (substring-non-space-end nline 0 x-size)))
- (if (fix:< 0 xe)
- (terminal-output-substring screen 0 y nline 0 xe false))
- (if (fix:< xe x-size)
- (terminal-clear-line screen xe y x-size))))))
+ (update-line-trivial screen y nline x-size))))
+
+(define (update-line-trivial screen y nline x-size)
+ (let ((xe (substring-non-space-end nline 0 x-size)))
+ (if (fix:< 0 xe)
+ (terminal-output-substring screen 0 y nline 0 xe false))
+ (if (fix:< xe x-size)
+ (terminal-clear-line screen xe y x-size))))
\f
(define-integrable (fix:min x y) (if (fix:< x y) x y))
(define-integrable (fix:max x y) (if (fix:> x y) x y))
-(define (substring-non-space-end string start end)
- (let ((index
- (substring-find-previous-char-in-set string start end
- char-set/not-space)))
- (if index
- (fix:1+ index)
- start)))
-
-(define-integrable (substring-blank? string start end)
- (not (substring-find-next-char-in-set string start end char-set/not-space)))
-
-(define char-set/not-space
- (char-set-invert (char-set #\space)))
+(define-integrable (substring-non-space-end string start end)
+ (do ((index end (fix:- index 1)))
+ ((or (fix:= start index)
+ (not (fix:= (vector-8b-ref string (fix:- index 1))
+ (char->integer #\space))))
+ index)))
(define (string-move! x y)
(substring-move-left! x 0 (string-length x) y 0))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.73 1991/03/15 23:34:14 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.74 1991/03/22 00:33:00 cph Exp $
;;;
;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
undo-data
modified?
point
+ buffer
)
-(define (make-group string)
+(define (make-group string buffer)
(let ((group (%make-group))
(n (string-length string)))
(vector-set! group group-index:text string)
(vector-set! group group-index:undo-data false)
(vector-set! group group-index:modified? false)
(vector-set! group group-index:point (%make-permanent-mark group 0 true))
+ (vector-set! group group-index:buffer buffer)
group))
(define (group-length group)
(vector-set! group
group-index:clip-daemons
(delq! daemon (vector-ref group group-index:clip-daemons))))
+
+(define-integrable (group-tab-width group)
+ (variable-local-value (group-buffer group) (ref-variable-object tab-width)))
\f
;;;; Marks
(and (mark~ mark1 mark2)
(not (fix:< (mark-index mark1) (mark-index mark2)))))
+(define-integrable (mark-buffer mark)
+ (group-buffer (mark-group mark)))
+
(define-integrable (group-start mark)
(group-start-mark (mark-group mark)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.78 1989/04/28 22:53:57 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.79 1991/03/22 00:33:08 cph Exp $
;;;
-;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
+;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(let ((m2 (mark-permanent! (forward-thing m4 -1 'ERROR))))
(let ((m1 (mark-permanent! (forward-thing m2 -1 'ERROR))))
(let ((m3 (forward-thing m1 1 'ERROR)))
- (region-insert! m4 (region-extract! (make-region m1 m3)))
- (region-insert! m1 (region-extract! (make-region m2 m4))))))))
+ (insert-string (extract-and-delete-string m1 m3) m4)
+ (insert-string (extract-and-delete-string m2 m4) m1))))))
(define (backward-once i)
i ;ignore
(let ((m1 (mark-left-inserting (forward-thing m2 -1 'ERROR))))
(let ((m3 (forward-thing m1 1 'ERROR))
(m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
- (region-insert! m4 (region-extract! (make-region m1 m3)))
- (region-insert! m1 (region-extract! (make-region m2 m4))))
+ (insert-string (extract-and-delete-string m1 m3) m4)
+ (insert-string (extract-and-delete-string m2 m4) m1))
(set-current-point! m1))))
(define (special)
(m3 (forward-thing m1 1 'ERROR))
(m2 (mark-permanent! m2))
(m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
- (region-insert! m4 (region-extract! (make-region m1 m3)))
- (region-insert! m1 (region-extract! (make-region m2 m4)))
+ (insert-string (extract-and-delete-string m1 m3) m4)
+ (insert-string (extract-and-delete-string m2 m4) m1)
(receiver m4 m1)))
(define (normalize m)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.55 1990/11/02 03:24:51 cph Rel $
+;;; $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 $
;;;
-;;; 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
;;; from which methods can be built.
(define-class string-base vanilla-window
- (image representation truncate-lines?))
+ (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
(define-method string-base :update-display!
string-base:update-display!)
\f
-(define (string-base:set-size-given-x! window x *truncate-lines?)
- (with-instance-variables string-base window (x *truncate-lines?)
- (set! truncate-lines? *truncate-lines?)
- (set! x-size x)
- (set! y-size (string-base:desired-y-size window x))
- (string-base:refresh! window)))
-
-(define (string-base:set-size-given-y! window y *truncate-lines?)
- (with-instance-variables string-base window (y *truncate-lines?)
- (set! truncate-lines? *truncate-lines?)
- (set! x-size (string-base:desired-x-size window y))
- (set! y-size y)
- (string-base:refresh! window)))
-
-(define (string-base:desired-x-size window y-size)
- (with-instance-variables string-base window (y-size)
- (column->x-size (image-column-size image) y-size truncate-lines?)))
-
-(define (string-base:desired-y-size window x-size)
- (with-instance-variables string-base window (x-size)
- (column->y-size (image-column-size image) x-size truncate-lines?)))
+(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-column-size image)
+ (column->coordinates image-length
x-size
truncate-lines?
- (image-index->column image index))))
+ (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-column-size image)
+ (column->x image-length
x-size
truncate-lines?
- (image-index->column image index))))
+ (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-column-size image)
+ (column->y image-length
x-size
truncate-lines?
- (image-index->column image index))))
+ (substring-columns string 0 index 0 tab-width))))
(define (string-base:coordinates->index window x y)
(with-instance-variables string-base window (x y)
- (image-column->index image
- (let ((column (coordinates->column x y x-size))
- (size (image-column-size image)))
- (if (fix:< column size)
- column
- size)))))
+ (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.
- (if truncate-lines?
- column-size
- (let ((qr (integer-divide column-size y-size)))
- (if (fix:= (integer-divide-remainder qr) 0)
- (integer-divide-quotient qr)
- (fix:1+ (integer-divide-quotient qr))))))
+ (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.
- (if (or truncate-lines? (fix:< column-size x-size))
- 1
- (let ((qr (integer-divide column-size (fix:-1+ x-size))))
- (if (fix:= (integer-divide-remainder qr) 0)
- (integer-divide-quotient qr)
- (fix:1+ (integer-divide-quotient qr))))))
+ (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:-1+ x-size)))
+ (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
- (let ((qr (integer-divide column -1+x-size)))
- (if (and (fix:= (integer-divide-remainder qr) 0)
- (fix:= column column-size))
- (cons -1+x-size
- (fix:-1+ (integer-divide-quotient qr)))
- (cons (integer-divide-remainder qr)
- (integer-divide-quotient qr))))))))
+ (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:-1+ x-size)))
+ (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
- (let ((r (remainder column -1+x-size)))
- (if (and (fix:= r 0) (fix:= column column-size))
- -1+x-size
- r))))))
+ (fix:remainder column -1+x-size)))))
(define (column->y column-size x-size truncate-lines? column)
- (if (or truncate-lines? (fix:< column (fix:-1+ x-size)))
- 0
- (let ((qr (integer-divide column (fix:-1+ x-size))))
- (if (and (fix:= (integer-divide-remainder qr) 0)
- (fix:= column column-size))
- (fix:-1+ (integer-divide-quotient qr))
- (integer-divide-quotient qr)))))
+ (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:-1+ 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)
- (image-direct-output-insert-char! image 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)
x
char)))))
-(define (string-base:direct-output-insert-newline! window)
- (with-instance-variables string-base window ()
- (set! image (make-null-image))
- (set! y-size 1)
- (set! representation false)))
-
(define (string-base:direct-output-insert-substring! window x string start end)
(with-instance-variables string-base window (x string start end)
- (image-direct-output-insert-substring! image 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)
(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 ()
- (let ((string (image-representation image)))
- (let ((column-size (string-length string)))
- (cond ((fix:= column-size 0)
- (set! representation false))
- ((fix:< column-size x-size)
- (let ((s (string-allocate x-size)))
- (substring-move-left! string 0 column-size s 0)
- (substring-fill! s column-size x-size #\space)
- (set! representation s)))
- (truncate-lines?
+ (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))
- (x-max (fix:-1+ x-size)))
- (substring-move-left! string 0 x-max s 0)
- (string-set! s x-max #\$)
- (set! representation s)))
- (else
- (let ((rep (make-vector y-size '()))
- (x-max (fix:-1+ x-size)))
- (let loop ((start 0) (y 0))
- (let ((s (string-allocate x-size))
- (end (fix:+ start x-max)))
- (vector-set! rep y s)
- (if (fix:> column-size end)
- (begin
- (substring-move-left! string start end s 0)
- (string-set! s x-max #\\)
- (loop end (fix:1+ y)))
- (begin
- (substring-move-left! string start column-size s 0)
- (substring-fill! s
- (fix:- column-size start)
- x-size
- #\space)))))
- (set! representation rep))))))
+ (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
projects / mit-scheme.git / commitdiff