From: Chris Hanson Date: Fri, 22 Mar 1991 00:33:14 +0000 (+0000) Subject: * Each group object now has a unique associated buffer, and vice X-Git-Tag: 20090517-FFI~10832 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=764fe590546a995c1d9f50db0d3ef4ed33d64a56;p=mit-scheme.git * Each group object now has a unique associated buffer, and vice versa. This allows low-level group operations to access buffer-local variables associated with the group, such as `tab-width'. New procedures: `group-buffer', `mark-buffer', and `group-tab-width'. * Handling of `truncate-lines' and `tab-width' buffer-local variables is fixed. * Extensive rewriting of redisplay, screen, and image code to squeeze a little more performance from it. * Eliminate truncating buffer output ports, because they were unused, and depended on a feature that is no longer viable. * Code to read files into buffers is redesigned. Previously it read the file into a string, and then inserted the string into the buffer. Now it reads the file directly into the buffer. * Fix representation of characters in the range 200 to 377 octal. Their images are now four-character octal sequences; previously the images were the characters themselves. --- diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index ce268e5c2..de67ea656 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -80,8 +80,8 @@ The buffer is guaranteed to be deselected at that time." (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))) diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm index 70fad83de..675d85d45 100644 --- a/v7/src/edwin/buffrm.scm +++ b/v7/src/edwin/buffrm.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -141,9 +141,7 @@ (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) @@ -205,8 +203,7 @@ (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))) @@ -297,43 +294,38 @@ (define-integrable (set-window-debug-trace! frame debug-trace) (%set-window-debug-trace! (frame-text-inferior frame) debug-trace)) -(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 diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm index 7fa20358f..0aff10dae 100644 --- a/v7/src/edwin/bufwfs.scm +++ b/v7/src/edwin/bufwfs.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -56,7 +56,12 @@ 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))))) @@ -65,31 +70,42 @@ 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) - + (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)) @@ -105,19 +121,27 @@ (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)) + '()))))))))) (define (scroll-lines! window inferiors start y-start) (cond ((or (null? inferiors) diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index 9a382a6e2..8b987f085 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -64,15 +64,14 @@ ;; 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 @@ -87,10 +86,10 @@ ;; 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 @@ -175,6 +174,20 @@ (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)) @@ -191,13 +204,6 @@ 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)) @@ -609,7 +615,6 @@ (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) @@ -646,6 +651,19 @@ (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))))) ;;;; Buffer and Point @@ -893,50 +911,32 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." ;;;; 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) @@ -944,7 +944,10 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." 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! diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm index 0fa1bda70..889309a90 100644 --- a/v7/src/edwin/bufwiu.scm +++ b/v7/src/edwin/bufwiu.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -167,6 +167,7 @@ (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))) @@ -515,7 +516,7 @@ #\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) diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm index 6a9eed1e3..65ffa6f77 100644 --- a/v7/src/edwin/bufwmc.scm +++ b/v7/src/edwin/bufwmc.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -45,7 +45,7 @@ ;;;; Buffer Windows: Mark <-> Coordinate Maps (declare (usual-integrations)) - + (define-integrable (buffer-window/mark->x window mark) (buffer-window/index->x window (mark-index mark))) @@ -63,7 +63,7 @@ (define-integrable (buffer-window/point-coordinates window) (buffer-window/index->coordinates window (%window-point-index window))) - + (define (buffer-window/index->x window index) (if (and (line-inferiors-valid? window) (line-inferiors-contain-index? window index)) @@ -72,10 +72,15 @@ (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) @@ -104,12 +109,17 @@ (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 @@ -208,151 +218,284 @@ ;; 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))))))))))) + (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))))))))))) (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)))))))))) + (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))))))))) (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))))))))))) + (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 @@ -369,55 +512,4 @@ (and (fix:= (car xy) 0) (fix:= (cdr xy) y))) (fix:+ start index) - (fix:+ (fix:+ start index) 1))))))) - -(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 diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index fa888cbfc..b21e6dd0c 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -79,14 +79,12 @@ MIT in each case. |# (sf-class (sf-dependent 'class-syntax-table))) (for-each sf-global '("bufinp" - "bufott" "bufout" "class" "clscon" "clsmac" "comtab" "display" - "image" "macros" "make" "nvector" @@ -104,7 +102,6 @@ MIT in each case. |# "winren" "xform" "xterm")) - (sf-global "tterm" "termcap") (for-each sf-edwin '("argred" "autold" @@ -174,6 +171,8 @@ MIT in each case. |# '("comwin" "modwin" "edtfrm")) + (sf-global "tterm" "termcap") + (sf-global "image" "struct") (sf-edwin "grpops" "struct") (sf-edwin "regops" "struct") (sf-edwin "motion" "struct") @@ -181,8 +180,8 @@ MIT in each case. |# (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 diff --git a/v7/src/edwin/ed-ffi.scm b/v7/src/edwin/ed-ffi.scm index 87ac60c4e..89059bce8 100644 --- a/v7/src/edwin/ed-ffi.scm +++ b/v7/src/edwin/ed-ffi.scm @@ -17,8 +17,6 @@ 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) diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index 293447d96..a3247e0d6 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,5 +1,5 @@ ;;; -*-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. @@ -65,7 +65,6 @@ (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) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 534e2f2f9..2270d1598 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -161,7 +161,9 @@ MIT in each case. |# 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") @@ -307,6 +309,7 @@ MIT in each case. |# 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! @@ -338,7 +341,6 @@ MIT in each case. |# window-scroll-y-relative! window-select-time window-set-override-message! - window-setup-truncate-lines! window-start-mark window-y-center) (export (edwin screen) @@ -475,13 +477,6 @@ MIT in each case. |# 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)) diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index 9fdd0ccb9..139081cf4 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -302,7 +302,7 @@ may be available. The following commands are special to this mode: (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*") diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index b538ceca1..42561bf94 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -54,12 +54,11 @@ (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) @@ -74,32 +73,49 @@ (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)))) ;;;; Buffer Mode Initialization diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm index d762b80eb..fd0cfea15 100644 --- a/v7/src/edwin/image.scm +++ b/v7/src/edwin/image.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -46,310 +46,315 @@ (declare (usual-integrations)) -;;; 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)))) -(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)))))) - -;;;; 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)) -(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)))))))) -;;;; 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))))))) + +(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 diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm index 972d7e838..b854b772f 100644 --- a/v7/src/edwin/iserch.scm +++ b/v7/src/edwin/iserch.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -170,7 +170,7 @@ "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))) diff --git a/v7/src/edwin/kilcom.scm b/v7/src/edwin/kilcom.scm index 1249ef258..5b64d5664 100644 --- a/v7/src/edwin/kilcom.scm +++ b/v7/src/edwin/kilcom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -345,18 +345,20 @@ are transposed." (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 diff --git a/v7/src/edwin/lincom.scm b/v7/src/edwin/lincom.scm index 62363d334..c8601dd03 100644 --- a/v7/src/edwin/lincom.scm +++ b/v7/src/edwin/lincom.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -75,11 +75,10 @@ transposed." (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))))) @@ -341,11 +340,6 @@ moves down one line first (killing newline after current line)." "\\[delete-indentation] won't insert a space to the left of these." (char-set #\))) -(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) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index e98941e16..07d11227f 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,4 +37,4 @@ MIT in each case. |# (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 diff --git a/v7/src/edwin/modlin.scm b/v7/src/edwin/modlin.scm index 65ea6f2f0..ef0bbac09 100644 --- a/v7/src/edwin/modlin.scm +++ b/v7/src/edwin/modlin.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -309,8 +309,7 @@ If #F, the normal method is used." 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) diff --git a/v7/src/edwin/motion.scm b/v7/src/edwin/motion.scm index fda437865..149de06b6 100644 --- a/v7/src/edwin/motion.scm +++ b/v7/src/edwin/motion.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -194,11 +194,17 @@ (if (not i) n (loop (fix:1+ i) n)))))) - + ;;;; 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)) @@ -208,43 +214,5 @@ (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 diff --git a/v7/src/edwin/regops.scm b/v7/src/edwin/regops.scm index 3df17fae6..1d233b77c 100644 --- a/v7/src/edwin/regops.scm +++ b/v7/src/edwin/regops.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -46,12 +46,6 @@ (declare (usual-integrations)) -(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)) @@ -84,17 +78,6 @@ (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))) (define (mark-left-char mark) (if (group-start? mark) diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm index 11cc81609..f60e2f12b 100644 --- a/v7/src/edwin/screen.scm +++ b/v7/src/edwin/screen.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -233,6 +233,10 @@ ;; 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) @@ -243,7 +247,8 @@ (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)) @@ -251,7 +256,8 @@ (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)) @@ -296,12 +302,124 @@ (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))) + +(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)) + (define (screen-direct-output-char screen x y char highlight) (if (screen-debug-trace screen) ((screen-debug-trace screen) 'screen screen 'direct-output-char @@ -312,28 +430,19 @@ (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 @@ -346,97 +455,33 @@ (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))))) - -(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)) (define (screen-scroll-lines-down screen xl xu yl yu amount) @@ -452,21 +497,39 @@ (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?)))))) - + (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 @@ -480,28 +543,37 @@ (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)))) (define (with-screen-in-update screen display-style thunk) (without-interrupts @@ -564,67 +636,89 @@ (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)))))) + (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))))) - + (define (update-line-ignore-current screen y nline highlight x-size) (cond ((not (boolean-subvector-uniform? highlight 0 x-size)) (let loop ((x 0)) @@ -641,28 +735,24 @@ ((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)))) (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)) diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm index 908ed997a..c3a5bae8d 100644 --- a/v7/src/edwin/struct.scm +++ b/v7/src/edwin/struct.scm @@ -1,6 +1,6 @@ ;;; -*-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 ;;; @@ -103,9 +103,10 @@ 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) @@ -126,6 +127,7 @@ (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) @@ -269,6 +271,9 @@ (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))) ;;;; Marks @@ -358,6 +363,9 @@ (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))) diff --git a/v7/src/edwin/things.scm b/v7/src/edwin/things.scm index e6abb3cb1..eee28162a 100644 --- a/v7/src/edwin/things.scm +++ b/v7/src/edwin/things.scm @@ -1,8 +1,8 @@ ;;; -*-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 @@ -118,8 +118,8 @@ (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 @@ -127,8 +127,8 @@ (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) @@ -150,8 +150,8 @@ (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) diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm index 9d6ffbcaf..4b0283954 100644 --- a/v7/src/edwin/utlwin.scm +++ b/v7/src/edwin/utlwin.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.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 @@ -52,7 +52,21 @@ ;;; 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)) @@ -60,6 +74,7 @@ (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 @@ -97,118 +112,117 @@ (define-method string-base :update-display! string-base:update-display!) -(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))))) (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)))) (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) @@ -221,15 +235,16 @@ 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) @@ -243,42 +258,67 @@ (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))) + (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))) ;;;; Blank Window