From acd7822e6420f7003071974acecdba5ff77779fd Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 9 Jan 1993 01:16:25 +0000 Subject: [PATCH] This version of Edwin requires microcode 11.125 or later. It should be compiled with compiler version 4.97 or later, because its performance depends on several new compiler optimizations. * Major redesign of low-level insert and delete operations, the primary aim of which is to greatly improve performance: * Insert, delete, and move-point daemons flushed. * Limits that track the extent of the changes to a buffer between display updates are now per-buffer rather than per-window. The windows are notified of these changes at display update rather than while the changes are occurring. * Calls to the primitives STRING-ALLOCATE, SUBSTRING-MOVE-RIGHT!, and SUBSTRING-MOVE-LEFT! have been replaced with calls to Scheme procedures that perform the same functions. These new procedures avoid the cost of calling C code, which can be very high. The latter two procedures use heuristics to decide whether it is better to call the C primitive or to do the operation in line. * The undo subsystem has been reimplemented. The new implementation is a near-exact translation of the new undo code from Emacs 18.56. The major features of this implementation are: unlimited undo memory for one undo step; significantly better performance; and much clearer implementation, reducing probability of bugs (the previous implementation is known to be buggy). * The new implementation of STRING-ALLOCATE fixes the bug that caused the editor to go into an infinite loop when reading in a file that was too large to fit in memory. * The MOVE-TO-COLUMN procedure had a problem because it was searching for the end of line in order to pass it as a limit argument to GROUP-COLUMN->INDEX. In some cases, particularly paragraph fill, this changed a linear algorithm to quadratic. This has been fixed by changing GROUP-COLUMN->INDEX to stop at end of line even if that is not the given limit. * The DEFINE-NAMED-STRUCTURE macro has been changed to create an object like those created by DEFINE-STRUCTURE, so that the printer and pretty-printer will treat them in the usual way. * The LINE-START and LINE-END procedures have been rewritten to make them faster. These procedures are used in many places in the editor and must be fast. The associated MOVE-VERTICALLY has been eliminated as it's no longer used. * TRANSPOSE-THINGS has been rewritten so that it doesn't leave permanent marks attached to the buffer. * HORIZONTAL-SPACE-START and HORIZONTAL-SPACE-END no longer look for the nearest line limit, since that was completely unnecessary. The procedures that they call automatically stop at the line edge. * BOCHSER code, which was not being loaded, is now also not compiled since it depended on the move-point daemons. --- v7/src/edwin/buffrm.scm | 7 +- v7/src/edwin/bufwin.scm | 263 +++++++++-------- v7/src/edwin/bufwiu.scm | 293 +++++++++---------- v7/src/edwin/bufwmc.scm | 7 +- v7/src/edwin/comred.scm | 10 +- v7/src/edwin/curren.scm | 14 +- v7/src/edwin/decls.scm | 8 +- v7/src/edwin/edtfrm.scm | 10 +- v7/src/edwin/edwin.pkg | 16 +- v7/src/edwin/fileio.scm | 26 +- v7/src/edwin/grpops.scm | 226 ++++++++------- v7/src/edwin/image.scm | 15 +- v7/src/edwin/macros.scm | 85 +++--- v7/src/edwin/make.scm | 4 +- v7/src/edwin/motion.scm | 112 ++++---- v7/src/edwin/struct.scm | 84 ++---- v7/src/edwin/things.scm | 115 ++++---- v7/src/edwin/undo.scm | 612 ++++++++++++++++------------------------ v7/src/edwin/utils.scm | 190 +++++++++---- 19 files changed, 1002 insertions(+), 1095 deletions(-) diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm index e87ca68f9..6464f799f 100644 --- a/v7/src/edwin/buffrm.scm +++ b/v7/src/edwin/buffrm.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: buffrm.scm,v 1.46 1992/09/10 02:43:14 cph Exp $ +;;; $Id: buffrm.scm,v 1.47 1993/01/09 01:15:52 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -222,6 +222,9 @@ (if modeline-inferior (modeline-window:event! (inferior-window modeline-inferior) type))) (screen-modeline-event! (window-screen frame) frame type)) + +(define (notice-window-changes! frame) + (%notice-window-changes! (frame-text-inferior frame))) (define-integrable (window-override-message window) (buffer-window/override-message (frame-text-inferior window))) diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index 5685e1eb7..ce4b167a6 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.296 1992/03/13 10:52:39 cph Exp $ +;;; $Id: bufwin.scm,v 1.297 1993/01/09 01:15:54 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -54,8 +54,6 @@ ;;; current-end-mark ;;; start-mark ;;; start-line-mark -;;; start-changes-mark -;;; end-changes-mark ;;; start-clip-mark ;;; end-clip-mark @@ -135,15 +133,9 @@ ;; non-positive. start-line-y - ;; This contains the daemon that is invoked when insertions or - ;; deletions are performed on the buffer. - changes-daemon - - ;; These variables delimit the region of the buffer that has been - ;; affected by insertions or deletions since the last display - ;; update. If no changes have occurred, they are #F. - start-changes-mark - end-changes-mark + ;; This contains the buffer's MODIFIED-TICK from the last time that + ;; redisplay completed for this window. + modified-tick ;; This contains the daemon that is invoked when the buffer's ;; display clipping is changed. @@ -155,8 +147,15 @@ start-clip-mark end-clip-mark - ;; If true, this flag indicates that point has moved since the last - ;; time that START-LINE-MARK was set. + ;; This flag is set to #F at the end of a display update, and + ;; subsequently set to a true value if the point has moved, or if + ;; it was inside a changed region, or if it was outside a clipping + ;; region, or any of several other conditions that could possibly + ;; affect the validity of our idea about where point is. However, + ;; there are two possible true values: #T means that the START-MARK + ;; for the window has been recomputed and is known to be correct. + ;; 'SINCE-START-MARK means the new START-MARK has not yet been + ;; computed. point-moved? ;; If true, this flag indicates that the window should be entirely @@ -333,32 +332,18 @@ (with-instance-variables buffer-window window (y) (set! start-line-y y))) -(define-integrable (%window-changes-daemon window) - (with-instance-variables buffer-window window () changes-daemon)) +(define-integrable (%window-modified-tick window) + (with-instance-variables buffer-window window () modified-tick)) -(define-integrable (%set-window-changes-daemon! window daemon) - (with-instance-variables buffer-window window (daemon) - (set! changes-daemon daemon))) - -(define-integrable (%window-start-changes-mark window) - (with-instance-variables buffer-window window () start-changes-mark)) +(define-integrable (%set-window-modified-tick! window tick) + (with-instance-variables buffer-window window (tick) + (set! modified-tick tick))) (define-integrable (%window-start-changes-index window) - (mark-index (%window-start-changes-mark window))) - -(define-integrable (%set-window-start-changes-mark! window mark) - (with-instance-variables buffer-window window (mark) - (set! start-changes-mark mark))) - -(define-integrable (%window-end-changes-mark window) - (with-instance-variables buffer-window window () end-changes-mark)) + (group-start-changes-index (%window-group window))) (define-integrable (%window-end-changes-index window) - (mark-index (%window-end-changes-mark window))) - -(define-integrable (%set-window-end-changes-mark! window mark) - (with-instance-variables buffer-window window (mark) - (set! end-changes-mark mark))) + (group-end-changes-index (%window-group window))) (define-integrable (%window-clip-daemon window) (with-instance-variables buffer-window window () clip-daemon)) @@ -642,16 +627,18 @@ (%clear-window-buffer-state! window)) (define-method buffer-window (:kill! window) - (without-interrupts (lambda () (%unset-window-buffer! window))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%unset-window-buffer! window) + (set-interrupt-enables! mask)) (usual=> window :kill!)) (define-method buffer-window (:salvage! window) - (without-interrupts - (lambda () - (%set-window-point-index! window (%window-group-start-index window)) - (%set-window-point-moved?! window 'SINCE-START-SET) - (%reset-window-structures! window) - (buffer-window/redraw! window)))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-point-index! window (%window-group-start-index window)) + (%set-window-point-moved?! window 'SINCE-START-SET) + (%reset-window-structures! window) + (buffer-window/redraw! window) + (set-interrupt-enables! mask))) (define-method buffer-window (:set-size! window x y) (if (%window-debug-trace window) @@ -675,6 +662,16 @@ (%release-window-outlines! window) (set-window-y-size! window y) (%set-window-point-moved?! window 'SINCE-START-SET)) + +(define (buffer-window/cursor-enable! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'cursor-enable!)) + (=> (inferior-window (%window-cursor-inferior window)) :enable!)) + +(define (buffer-window/cursor-disable! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window 'cursor-disable!)) + (=> (inferior-window (%window-cursor-inferior window)) :disable!)) ;;;; Update @@ -739,21 +736,11 @@ (define (buffer-window/redraw! window) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'force-redraw!)) - (without-interrupts - (lambda () - (%set-window-force-redraw?! window true) - (%clear-window-incremental-redisplay-state! window) - (window-needs-redisplay! window)))) - -(define (buffer-window/cursor-enable! window) - (if (%window-debug-trace window) - ((%window-debug-trace window) 'window window 'cursor-enable!)) - (=> (inferior-window (%window-cursor-inferior window)) :enable!)) - -(define (buffer-window/cursor-disable! window) - (if (%window-debug-trace window) - ((%window-debug-trace window) 'window window 'cursor-disable!)) - (=> (inferior-window (%window-cursor-inferior window)) :disable!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-force-redraw?! window true) + (%clear-window-incremental-redisplay-state! window) + (window-needs-redisplay! window) + (set-interrupt-enables! mask))) ;;;; Window State @@ -764,7 +751,6 @@ (%release-window-outlines! window) (%set-window-free-o3! window false) (%set-window-override-string! window false) - (%set-window-changes-daemon! window (make-changes-daemon window)) (%set-window-clip-daemon! window (make-clip-daemon window)) (%set-window-debug-trace! window false) (%set-window-saved-screen! window false)) @@ -779,7 +765,6 @@ (%set-window-point! window false) (if (%window-start-line-mark window) (clear-start-mark! window)) - (%set-window-point-moved?! window false) (%clear-window-incremental-redisplay-state! window)) (define (%clear-window-incremental-redisplay-state! window) @@ -799,18 +784,19 @@ (%clear-window-outstanding-changes! window)) (define-integrable (%clear-window-outstanding-changes! window) - (if (%window-start-changes-mark window) - (begin - (mark-temporary! (%window-start-changes-mark window)) - (%set-window-start-changes-mark! window false) - (mark-temporary! (%window-end-changes-mark window)) - (%set-window-end-changes-mark! window false))) + (if (%window-buffer window) + (update-modified-tick! window)) (if (%window-start-clip-mark window) (begin (mark-temporary! (%window-start-clip-mark window)) (%set-window-start-clip-mark! window false) (mark-temporary! (%window-end-clip-mark window)) - (%set-window-end-clip-mark! window false)))) + (%set-window-end-clip-mark! window false))) + (%set-window-point-moved?! window false)) + +(define-integrable (update-modified-tick! window) + (%set-window-modified-tick! window + (group-modified-tick (%window-group window)))) (define (%recache-window-buffer-local-variables! window) (let ((buffer (%window-buffer window))) @@ -839,10 +825,7 @@ (if (%window-buffer window) (%unset-window-buffer! window)) (%set-window-buffer! window new-buffer) - (let ((group (%window-group window)) - (changes-daemon (%window-changes-daemon window))) - (add-group-delete-daemon! group changes-daemon) - (add-group-insert-daemon! group changes-daemon) + (let ((group (%window-group window))) (add-group-clip-daemon! group (%window-clip-daemon window)) (%set-window-point-index! window (mark-index (group-point group)))) (if (buffer-display-start new-buffer) @@ -861,11 +844,8 @@ buffer (mark-permanent! (buffer-window/start-mark window))) (%set-buffer-point! buffer (buffer-window/point window))) - (let ((group (%window-group window)) - (changes-daemon (%window-changes-daemon window))) - (remove-group-delete-daemon! group changes-daemon) - (remove-group-insert-daemon! group changes-daemon) - (remove-group-clip-daemon! group (%window-clip-daemon window))) + (remove-group-clip-daemon! (%window-group window) + (%window-clip-daemon window)) (%clear-window-buffer-state! window)) (define-integrable (buffer-window/point window) @@ -875,12 +855,12 @@ (let ((mark (clip-mark-to-display window mark))) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'set-point! mark)) - (without-interrupts - (lambda () - (%set-window-point-index! window (mark-index mark)) - (%set-window-point-moved?! window 'SINCE-START-SET) - (%set-buffer-point! (%window-buffer window) mark) - (window-needs-redisplay! window))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-point-index! window (mark-index mark)) + (%set-window-point-moved?! window 'SINCE-START-SET) + (%set-buffer-point! (%window-buffer window) mark) + (window-needs-redisplay! window) + (set-interrupt-enables! mask)))) ;;;; Start Mark @@ -916,17 +896,17 @@ (lambda (start y-start) (cond ((predict-index-visible? window start y-start (%window-point-index window)) - (without-interrupts - (lambda () - (set-start-mark! window start y-start)))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-start-mark! window start y-start) + (set-interrupt-enables! mask))) (point-y - (without-interrupts - (lambda () - (%set-window-point-index! - window - (or (predict-index window start y-start 0 point-y) - (%window-group-end-index window))) - (set-start-mark! window start y-start)))))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-point-index! + window + (or (predict-index window start y-start 0 point-y) + (%window-group-end-index window))) + (set-start-mark! window start y-start) + (set-interrupt-enables! mask))))))) (define (buffer-window/scroll-y-absolute! window y-point) (if (%window-debug-trace window) @@ -939,9 +919,26 @@ (lambda () (predict-start-line window (%window-point-index window) y-point)) (lambda (start y-start) - (without-interrupts - (lambda () - (set-start-mark! window start y-start)))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (set-start-mark! window start y-start) + (set-interrupt-enables! mask))))) + +(define (buffer-window/y-center window) + (let ((y-size (window-y-size window))) + (let ((result + (round->exact + (* y-size (/ (ref-variable cursor-centering-point) 100))))) + (if (< result y-size) + result + (- y-size 1))))) + +(define-variable cursor-centering-point + "The distance from the top of the window at which to center the point. +This number is a percentage, where 0 is the window's top and 100 the bottom." + 50 + (lambda (cursor-centering-point) + (and (real? cursor-centering-point) + (<= 0 cursor-centering-point 100)))) (define (set-start-mark! window start-line y-start) (if (fix:= y-start 0) @@ -990,7 +987,9 @@ (%set-window-start-line-y! window 0)) (define (guarantee-start-mark! window) - (without-interrupts (lambda () (%guarantee-start-mark! window)))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%guarantee-start-mark! window) + (set-interrupt-enables! mask))) (define (%guarantee-start-mark! window) (let ((index-at! @@ -1007,20 +1006,31 @@ ((eq? (%window-point-moved? window) 'SINCE-START-SET) (let ((point (%window-point-index window))) (if (or (%window-start-clip-mark window) - (%window-start-changes-mark window) + (fix:> (group-modified-tick (%window-group window)) + (%window-modified-tick window)) (not (%window-current-start-mark window)) - (fix:< point (%window-current-start-index window)) - (fix:> point (%window-current-end-index window)) - (fix:< (%window-current-start-y window) 0) - (fix:> (%window-current-end-y window) - (window-y-size window))) + (fix:< + point + (if (fix:< (%window-current-start-y window) 0) + (fix:+ (%window-current-start-index window) + (outline-index-length + (%window-start-outline window))) + (%window-current-start-index window))) + (fix:> point + (if (fix:> (%window-current-end-y window) + (window-y-size window)) + (fix:- (%window-current-end-index window) + (outline-index-length + (%window-end-outline window))) + (%window-current-end-index window)))) (let ((start-y (%window-start-line-y window)) (y-size (window-y-size window)) (scroll-step (ref-variable scroll-step))) (if (fix:= 0 scroll-step) - (if (not (predict-y-limited window start-line - start-y point - 0 y-size)) + (if (predict-y-limited window start-line + start-y point + 0 y-size) + (%set-window-point-moved?! window true) (index-at! point (buffer-window/y-center window))) (let ((y @@ -1036,9 +1046,9 @@ ((fix:< y 0) (index-at! point (fix:+ y scroll-step))) ((fix:>= y y-size) - (index-at! - point - (fix:- y scroll-step))))))))))))))) + (index-at! point + (fix:- y scroll-step))))))) + (%set-window-point-moved?! window true))))))))) (define-variable scroll-step "The number of lines to try scrolling a window by when point moves out. @@ -1048,23 +1058,6 @@ If this is zero, point is always centered after it moves off screen." (lambda (scroll-step) (and (fix:fixnum? scroll-step) (fix:>= scroll-step 0)))) - -(define (buffer-window/y-center window) - (let ((y-size (window-y-size window))) - (let ((result - (round->exact - (* y-size (/ (ref-variable cursor-centering-point) 100))))) - (if (< result y-size) - result - (- y-size 1))))) - -(define-variable cursor-centering-point - "The distance from the top of the window at which to center the point. -This number is a percentage, where 0 is the window's top and 100 the bottom." - 50 - (lambda (cursor-centering-point) - (and (real? cursor-centering-point) - (<= 0 cursor-centering-point 100)))) ;;;; Override Message @@ -1075,10 +1068,10 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'set-override-message! message)) - (without-interrupts - (lambda () - (%set-window-override-string! window message) - (window-needs-redisplay! window)))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-override-string! window message) + (window-needs-redisplay! window) + (set-interrupt-enables! mask))) (define (buffer-window/clear-override-message! window) (if (%window-override-string window) @@ -1086,10 +1079,10 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'clear-override-message!)) - (without-interrupts - (lambda () - (%set-window-override-string! window false) - (buffer-window/redraw! window)))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-override-string! window false) + (buffer-window/redraw! window) + (set-interrupt-enables! mask))))) (define (update-override-string! window screen x-start y-start xl xu yl yu) ;; This should probably update like any other string, paying @@ -1116,7 +1109,8 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." (set-inferior-start! (%window-cursor-inferior window) (vector-ref results 1) 0)))) - (%update-blank-inferior! window 1 true)) + (%update-blank-inferior! window 1 true) + (update-modified-tick! window)) ;;;; Update Finalization @@ -1138,7 +1132,6 @@ This number is a percentage, where 0 is the window's top and 100 the bottom." (%set-window-current-end-y! window (o3-y end)) (deallocate-o3! window start) (deallocate-o3! window end) - (%clear-window-outstanding-changes! window) (update-blank-inferior! window true) (update-cursor! window) (%window-modeline-event! window 'SET-OUTLINES)) diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm index 066f5b4e3..8758fec90 100644 --- a/v7/src/edwin/bufwiu.scm +++ b/v7/src/edwin/bufwiu.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.19 1991/04/02 19:55:27 cph Exp $ +;;; $Id: bufwiu.scm,v 1.20 1993/01/09 01:15:56 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -48,52 +48,49 @@ ;;;; Insert/Delete -(define (make-changes-daemon window) - ;; It is assumed that the insert daemon is called after the - ;; insertion has been performed, and the delete daemon before the - ;; deletion has been performed. It is also assumed that interrupts - ;; are disabled. - (lambda (group start end) - (if (%window-debug-trace window) - ((%window-debug-trace window) 'window window 'change-daemon - group start end)) - ;; Record changes that intersect the current outlines. - (if (and (not (%window-force-redraw? window)) - (fix:<= (%window-current-start-index window) end) - (fix:<= start (%window-current-end-index window))) - (begin - (if (not (%window-start-changes-mark window)) - (begin - (%set-window-start-changes-mark! - window - (make-permanent-mark group start false)) - (%set-window-end-changes-mark! - window - (make-permanent-mark group end true))) - (begin - (if (fix:< start (%window-start-changes-index window)) - (set-mark-index! (%window-start-changes-mark window) - start)) - (if (fix:> end (%window-end-changes-index window)) - (set-mark-index! (%window-end-changes-mark window) end)))) - (window-needs-redisplay! window))) - ;; If this change affects where the window starts, choose a - ;; new place to start it. - (if (%window-start-line-mark window) - (begin - (if (let ((wlstart (%window-start-line-index window)) - (wstart (%window-start-index window))) - (and (if (fix:= wlstart wstart) - (fix:< start wstart) - (fix:<= start wstart)) - (fix:<= wlstart end))) +(define (%notice-window-changes! window) + ;; Assumes that interrupts are disabled. + (let ((group (%window-group window))) + (if (fix:> (group-modified-tick group) (%window-modified-tick window)) + (let ((start (group-start-changes-index group)) + (end (group-end-changes-index group))) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + '%notice-window-changes!)) + (if (not (%window-force-redraw? window)) + ;; If this change intersects the visible region of the + ;; buffer, request a display update. + (if (and start + (fix:<= (%window-current-start-index window) end) + (fix:<= start (%window-current-end-index window))) + (window-needs-redisplay! window) + ;; Otherwise mark the window to indicate that it has + ;; been updated to reflect these changes. + (%set-window-modified-tick! window + (group-modified-tick group)))) + (if (%window-start-line-mark window) (begin - (clear-start-mark! window) - (window-needs-redisplay! window))) - (if (and (not (eq? (%window-point-moved? window) 'SINCE-START-SET)) - (fix:<= start (%window-point-index window)) - (fix:<= (%window-point-index window) end)) - (%set-window-point-moved?! window 'SINCE-START-SET)))))) + ;; If this change affects START-MARK, invalidate it + ;; and request a display update. + (if (let ((wlstart (%window-start-line-index window)) + (wstart (%window-start-index window))) + (and (if (fix:= wlstart wstart) + (fix:< start wstart) + (fix:<= start wstart)) + (fix:<= wlstart end))) + (begin + (clear-start-mark! window) + (window-needs-redisplay! window))) + ;; If this change affects POINT, invalidate it. It's + ;; not necessary to request a display update here + ;; because POINT is always in the visible region of + ;; the buffer. + (if (and (not (eq? (%window-point-moved? window) + 'SINCE-START-SET)) + (fix:<= start (%window-point-index window)) + (fix:<= (%window-point-index window) end)) + (%set-window-point-moved?! window + 'SINCE-START-SET)))))))) ;;;; Clip @@ -151,6 +148,8 @@ (if (%window-force-redraw? window) (begin (%set-window-force-redraw?! window false) + ;; When one of the cached buffer-local variables is set, it + ;; sets the FORCE-REDRAW bit so that this code will run. (%recache-window-buffer-local-variables! window) (preserve-nothing! window)) (let ((start (%window-current-start-index window)) @@ -163,7 +162,10 @@ (fix:< (%window-end-clip-index window) (%window-group-end-index window)))) (preserve-nothing! window)) - ((%window-start-changes-mark window) + ((and (fix:> (group-modified-tick (%window-group window)) + (%window-modified-tick window)) + (fix:<= start (%window-end-changes-index window)) + (fix:<= (%window-start-changes-index window) end)) (let ((start-changes (let ((start-changes (%window-start-changes-index window))) @@ -181,7 +183,8 @@ end-changes end) (preserve-top! window start start-changes))))) (else - (preserve-all! window start end)))))) + (preserve-all! window start end))))) + (%clear-window-outstanding-changes! window)) (define-integrable (preserve-nothing! window) (regenerate-outlines window @@ -307,11 +310,8 @@ (regenerate-outlines window wlstart wlsy)))))) (cond ((fix:= wlstart start-index) (cond ((fix:= wlsy start-y) - (%clear-window-outstanding-changes! window) (if (%window-point-moved? window) - (begin - (%set-window-point-moved?! window false) - (update-cursor! window)))) + (update-cursor! window))) ((fix:< wlsy start-y) (scroll-up wlsy)) (else @@ -399,43 +399,41 @@ ;;; redisplay. (define (buffer-window/needs-redisplay? window) - (if (or (window-needs-redisplay? window) - (not (%window-saved-screen window)) - (screen-needs-update? (%window-saved-screen window))) - true - false)) + (or (window-needs-redisplay? window) + (not (%window-saved-screen window)) + (screen-needs-update? (%window-saved-screen window)))) (define (buffer-window/direct-output-forward-char! window) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-forward-char!)) - (without-interrupts - (lambda () - (%set-window-point-index! window (fix:+ (%window-point-index window) 1)) - (let ((x-start - (fix:+ (inferior-x-start (%window-cursor-inferior window)) 1)) - (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-move-cursor - (%window-saved-screen window) - (fix:+ (%window-saved-x-start window) x-start) - (fix:+ (%window-saved-y-start window) y-start)) - (%set-inferior-x-start! (%window-cursor-inferior window) x-start))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-point-index! window (fix:+ (%window-point-index window) 1)) + (let ((x-start + (fix:+ (inferior-x-start (%window-cursor-inferior window)) 1)) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-move-cursor + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start)) + (%set-inferior-x-start! (%window-cursor-inferior window) x-start)) + (set-interrupt-enables! mask))) (define (buffer-window/direct-output-backward-char! window) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-backward-char!)) - (without-interrupts - (lambda () - (%set-window-point-index! window (fix:- (%window-point-index window) 1)) - (let ((x-start - (fix:- (inferior-x-start (%window-cursor-inferior window)) 1)) - (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-move-cursor - (%window-saved-screen window) - (fix:+ (%window-saved-x-start window) x-start) - (fix:+ (%window-saved-y-start window) y-start)) - (%set-inferior-x-start! (%window-cursor-inferior window) x-start))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (%set-window-point-index! window (fix:- (%window-point-index window) 1)) + (let ((x-start + (fix:- (inferior-x-start (%window-cursor-inferior window)) 1)) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-move-cursor + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start)) + (%set-inferior-x-start! (%window-cursor-inferior window) x-start)) + (set-interrupt-enables! mask))) (define (buffer-window/home-cursor! window) (if (%window-debug-trace window) @@ -445,82 +443,62 @@ (fix:< 0 (%window-saved-xu window)) (fix:<= (%window-saved-yl window) 0) (fix:< 0 (%window-saved-yu window))) - (without-interrupts - (lambda () - (screen-direct-output-move-cursor (%window-saved-screen window) - (%window-saved-x-start window) - (%window-saved-y-start window)))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (screen-direct-output-move-cursor (%window-saved-screen window) + (%window-saved-x-start window) + (%window-saved-y-start window)) + (set-interrupt-enables! mask)))) (define (buffer-window/direct-output-insert-char! window char) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-insert-char! char)) - (without-interrupts - (lambda () - (%group-insert-char! (%window-group window) - (%window-point-index window) - char) - (let ((x-start (inferior-x-start (%window-cursor-inferior window))) - (y-start (inferior-y-start (%window-cursor-inferior window)))) - (screen-direct-output-char - (%window-saved-screen window) - (fix:+ (%window-saved-x-start window) x-start) - (fix:+ (%window-saved-y-start window) y-start) - char - false) - (let ((outline (direct-output-outline window y-start))) - (set-outline-index-length! outline - (fix:+ (outline-index-length outline) 1))) - (%set-inferior-x-start! (%window-cursor-inferior window) - (fix:+ x-start 1)))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (group-insert-char! (%window-group window) + (%window-point-index window) + char) + (let ((x-start (inferior-x-start (%window-cursor-inferior window))) + (y-start (inferior-y-start (%window-cursor-inferior window)))) + (screen-direct-output-char + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start) + char + false) + (let ((outline (direct-output-outline window y-start))) + (set-outline-index-length! outline + (fix:+ (outline-index-length outline) 1))) + (%set-inferior-x-start! (%window-cursor-inferior window) + (fix:+ x-start 1))) + (update-modified-tick! window) + (set-interrupt-enables! mask))) (define (buffer-window/direct-output-insert-substring! window string start end) (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'direct-output-insert-substring! (string-copy string) start end)) - (without-interrupts - (lambda () - (%group-insert-substring! (%window-group window) - (%window-point-index window) - string start end) - (let ((x-start (inferior-x-start (%window-cursor-inferior window))) - (y-start (inferior-y-start (%window-cursor-inferior window))) - (length (fix:- end start))) - (screen-direct-output-substring - (%window-saved-screen window) - (fix:+ (%window-saved-x-start window) x-start) - (fix:+ (%window-saved-y-start window) y-start) - string start end - false) - (let ((outline (direct-output-outline window y-start))) - (set-outline-index-length! outline - (fix:+ (outline-index-length outline) - length))) - (%set-inferior-x-start! (%window-cursor-inferior window) - (fix:+ x-start length)))))) - -(define (buffer-window/direct-output-insert-newline! window) - (if (%window-debug-trace window) - ((%window-debug-trace window) 'window window - 'direct-output-insert-newline!)) - (without-interrupts - (lambda () - (%group-insert-char! (%window-group window) - (%window-point-index window) - #\newline) - (let ((end-y (%window-current-end-y window))) - (screen-direct-output-move-cursor (%window-saved-screen window) - (%window-saved-x-start window) - (fix:+ (%window-saved-y-start window) - end-y)) - (%set-window-end-outline! - window - (make-outline window 0 1 (%window-end-outline window) false)) - (%set-window-current-end-y! window (fix:+ end-y 1)) - (update-blank-inferior! window false) - (%set-inferior-x-start! (%window-cursor-inferior window) 0) - (%set-inferior-y-start! (%window-cursor-inferior window) end-y))))) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (group-insert-substring! (%window-group window) + (%window-point-index window) + string start end) + (let ((x-start (inferior-x-start (%window-cursor-inferior window))) + (y-start (inferior-y-start (%window-cursor-inferior window))) + (length (fix:- end start))) + (screen-direct-output-substring + (%window-saved-screen window) + (fix:+ (%window-saved-x-start window) x-start) + (fix:+ (%window-saved-y-start window) y-start) + string start end + false) + (let ((outline (direct-output-outline window y-start))) + (set-outline-index-length! outline + (fix:+ (outline-index-length outline) + length))) + (%set-inferior-x-start! (%window-cursor-inferior window) + (fix:+ x-start length))) + (update-modified-tick! window) + (set-interrupt-enables! mask))) (define (direct-output-outline window y) (let loop @@ -529,4 +507,27 @@ (let ((end-y (fix:+ start-y (outline-y-size outline)))) (if (fix:< y end-y) outline - (loop (outline-next outline) end-y))))) \ No newline at end of file + (loop (outline-next outline) end-y))))) + +(define (buffer-window/direct-output-insert-newline! window) + (if (%window-debug-trace window) + ((%window-debug-trace window) 'window window + 'direct-output-insert-newline!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + (group-insert-char! (%window-group window) + (%window-point-index window) + #\newline) + (let ((end-y (%window-current-end-y window))) + (screen-direct-output-move-cursor (%window-saved-screen window) + (%window-saved-x-start window) + (fix:+ (%window-saved-y-start window) + end-y)) + (%set-window-end-outline! + window + (make-outline window 0 1 (%window-end-outline window) false)) + (%set-window-current-end-y! window (fix:+ end-y 1)) + (update-blank-inferior! window false) + (%set-inferior-x-start! (%window-cursor-inferior window) 0) + (%set-inferior-y-start! (%window-cursor-inferior window) end-y)) + (update-modified-tick! window) + (set-interrupt-enables! mask))) \ No newline at end of file diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm index 3c5ca8da3..0be0fa57e 100644 --- a/v7/src/edwin/bufwmc.scm +++ b/v7/src/edwin/bufwmc.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwmc.scm,v 1.14 1991/05/17 19:11:32 cph Exp $ +;;; $Id: bufwmc.scm,v 1.15 1993/01/09 01:15:59 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -173,7 +173,8 @@ (%window-start-line-y window))))) (define-integrable (outlines-valid? window) - (and (not (%window-start-changes-mark window)) + (and (fix:= (group-modified-tick (%window-group window)) + (%window-modified-tick window)) (not (%window-start-clip-mark window)) (not (%window-point-moved? window)) (not (%window-force-redraw? window)) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index 871bd90e3..728be5516 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.94 1992/05/14 18:38:58 cph Exp $ +;;; $Id: comred.scm,v 1.95 1993/01/09 01:16:01 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -302,16 +302,14 @@ ((eq? command (ref-command-object forward-char)) (if (and (not (group-end? point)) (char-graphic? (mark-right-char point)) - (fix:< point-x (fix:- (window-x-size window) 2)) - (null? (group-move-point-daemons (mark-group point)))) + (fix:< point-x (fix:- (window-x-size window) 2))) (window-direct-output-forward-char! window) (normal))) ((eq? command (ref-command-object backward-char)) (if (and (not (group-start? point)) (char-graphic? (mark-left-char point)) (fix:< 0 point-x) - (fix:< point-x (fix:- (window-x-size window) 1)) - (null? (group-move-point-daemons (mark-group point)))) + (fix:< point-x (fix:- (window-x-size window) 1))) (window-direct-output-backward-char! window) (normal))) (else diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm index 643a7b322..198a52975 100644 --- a/v7/src/edwin/curren.scm +++ b/v7/src/edwin/curren.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: curren.scm,v 1.105 1992/11/13 21:40:06 cph Exp $ +;;; $Id: curren.scm,v 1.106 1993/01/09 01:16:02 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -109,7 +109,15 @@ (define (update-screens! display-style) (let loop ((screens (screen-list))) - (or (null? screens) + (if (null? screens) + (begin + ;; All the buffer changes have been successfully written to + ;; the screens, so erase the change records. + (do ((buffers (buffer-list) (cdr buffers))) + ((null? buffers)) + (set-group-start-changes-index! (buffer-group (car buffers)) + false)) + true) (and (update-screen! (car screens) display-style) (loop (cdr screens)))))) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 68f6816be..e8a7a5f93 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.43 1992/11/17 22:42:45 cph Exp $ +$Id: decls.scm,v 1.44 1993/01/09 01:16:04 cph Exp $ -Copyright (c) 1989-1992 Massachusetts Institute of Technology +Copyright (c) 1989-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -114,8 +114,8 @@ MIT in each case. |# "autold" "autosv" "basic" - "bochser" - "bochsmod" + ;;"bochser" + ;;"bochsmod" "bufcom" "bufinp" "bufmnu" diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm index 8ae111559..28c5a6baf 100644 --- a/v7/src/edwin/edtfrm.scm +++ b/v7/src/edwin/edtfrm.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.84 1991/04/01 10:06:58 cph Exp $ +;;; $Id: edtfrm.scm,v 1.85 1993/01/09 01:16:06 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -81,6 +81,12 @@ (define (editor-frame-update-display! window display-style) ;; Returns true if update is successfully completed (or unnecessary). ;; Assumes that interrupts are disabled. + (notice-window-changes! (editor-frame-typein-window window)) + (let ((start (editor-frame-window0 window))) + (notice-window-changes! start) + (do ((window (window1+ start) (window1+ window))) + ((eq? window start)) + (notice-window-changes! window))) (with-instance-variables editor-frame window (display-style) (if (and (not display-style) (not (car redisplay-flags))) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 2e29c9b2c..6258ec29d 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: edwin.pkg,v 1.109 1992/12/15 19:54:38 gjr Exp $ +$Id: edwin.pkg,v 1.110 1993/01/09 01:16:07 cph Exp $ -Copyright (c) 1989-1992 Massachusetts Institute of Technology +Copyright (c) 1989-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -169,8 +169,6 @@ MIT in each case. |# (files "grpops") (parent (edwin)) (export (edwin) - %group-insert-char! - %group-insert-substring! finish-group-insert! gap-allocation-extra group-copy-substring! @@ -204,12 +202,17 @@ MIT in each case. |# (parent (edwin)) (export (edwin) disable-group-undo! + edwin-command$undo + edwin-variable$undo-limit + edwin-variable$undo-strong-limit enable-group-undo! undo-boundary! undo-done! undo-leave-window! + undo-more undo-record-deletion! undo-record-insertion! + undo-start with-group-undo-disabled)) (define-package (edwin display-type) @@ -1102,7 +1105,7 @@ MIT in each case. |# edwin-variable$rmail-primary-inbox-list edwin-variable$rmail-reply-with-re rmail-spool-directory)) - +#| (define-package (edwin bochser) (files "bochser" "bochsmod") @@ -1140,4 +1143,5 @@ MIT in each case. |# edwin-variable$bindings-window-fraction) (import (runtime debugger-utilities) show-environment-bindings) - (initialization (initialize-bochser-mode!))) \ No newline at end of file + (initialization (initialize-bochser-mode!))) +|# \ No newline at end of file diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 00973e709..6a741d6e1 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: fileio.scm,v 1.113 1992/11/16 22:41:01 cph Exp $ +;;; $Id: fileio.scm,v 1.114 1993/01/09 01:16:10 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-1992 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -157,8 +157,7 @@ Each procedure is called with three arguments: (lambda () (let ((gap-start* (fix:+ index n))) (undo-record-insertion! group index gap-start*) - (finish-group-insert! group index n) - (record-insertion! group index gap-start*)))) + (finish-group-insert! group index n)))) (channel-close channel) n)))) @@ -688,29 +687,14 @@ Otherwise, a message is written both before and after long file writes." end-of-line))) (define (with-group-daemons-disabled group redisplay? action) - (let ((insert-daemons '()) - (delete-daemons '()) - (clip-daemons '()) - (move-point-daemons '())) + (let ((clip-daemons '())) (let ((swap (lambda () - (let ((old (vector-ref group group-index:insert-daemons))) - (vector-set! group group-index:insert-daemons - insert-daemons) - (set! insert-daemons old)) - (let ((old (vector-ref group group-index:delete-daemons))) - (vector-set! group group-index:delete-daemons - delete-daemons) - (set! delete-daemons old)) - ;; I think the following two are unnecessary, but... + ;; I think the following is unnecessary, but... (let ((old (vector-ref group group-index:clip-daemons))) (vector-set! group group-index:clip-daemons clip-daemons) (set! clip-daemons old)) - (let ((old (vector-ref group group-index:move-point-daemons))) - (vector-set! group group-index:move-point-daemons - move-point-daemons) - (set! move-point-daemons old)) unspecific))) (dynamic-wind swap diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm index 98d5b7b95..ae44131e4 100644 --- a/v7/src/edwin/grpops.scm +++ b/v7/src/edwin/grpops.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.16 1992/04/04 13:07:09 cph Exp $ +;;; $Id: grpops.scm,v 1.17 1993/01/09 01:16:11 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -44,7 +44,7 @@ ;;;; Group Operations -(declare (usual-integrations)) +(declare (usual-integrations string-allocate)) ;;; These high-performance ops deal directly with groups and indices ;;; for speed and the least consing. Since indices are not in general @@ -65,42 +65,42 @@ (define (group-extract-string group start end) (let ((text (group-text group)) (gap-start (group-gap-start group)) - (string (make-string (fix:- end start)))) + (string (string-allocate (fix:- end start)))) (cond ((fix:<= end gap-start) - (substring-move-right! text start end string 0)) + (%substring-move! text start end string 0)) ((fix:>= start gap-start) - (substring-move-right! text - (fix:+ start (group-gap-length group)) - (fix:+ end (group-gap-length group)) - string - 0)) + (%substring-move! text + (fix:+ start (group-gap-length group)) + (fix:+ end (group-gap-length group)) + string + 0)) (else - (substring-move-right! text start gap-start string 0) - (substring-move-right! text - (group-gap-end group) - (fix:+ end (group-gap-length group)) - string - (fix:- gap-start start)))) + (%substring-move! text start gap-start string 0) + (%substring-move! text + (group-gap-end group) + (fix:+ end (group-gap-length group)) + string + (fix:- gap-start start)))) string)) (define (group-copy-substring! group start end string start*) (let ((text (group-text group)) (gap-start (group-gap-start group))) (cond ((fix:<= end gap-start) - (substring-move-right! text start end string start*)) + (%substring-move! text start end string start*)) ((fix:>= start gap-start) - (substring-move-right! text - (fix:+ start (group-gap-length group)) - (fix:+ end (group-gap-length group)) - string - start*)) + (%substring-move! text + (fix:+ start (group-gap-length group)) + (fix:+ end (group-gap-length group)) + string + start*)) (else - (substring-move-right! text start gap-start string start*) - (substring-move-right! text - (group-gap-end group) - (fix:+ end (group-gap-length group)) - string - (fix:+ start* (fix:- gap-start start))))))) + (%substring-move! text start gap-start string start*) + (%substring-move! text + (group-gap-end group) + (fix:+ end (group-gap-length group)) + string + (fix:+ start* (fix:- gap-start start))))))) (define (group-left-char group index) (string-ref (group-text group) @@ -119,65 +119,58 @@ (define (group-insert-char! group index char) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (declare (integrate %group-insert-char!)) - (%group-insert-char! group index char) - (if (not (null? (group-insert-daemons group))) - (invoke-group-daemons! (group-insert-daemons group) - group index (group-gap-start group))) - (set-interrupt-enables! interrupt-mask))) - -(define (%group-insert-char! group index char) - (if (group-read-only? group) - (barf-if-read-only)) - (if (not (group-modified? group)) - (check-first-group-modification group)) - (if (group-undo-data group) - (undo-record-insertion! group index (fix:+ index 1))) - (prepare-gap-for-insert! group index 1) - (string-set! (group-text group) index char) - (finish-group-insert! group index 1)) + (if (group-read-only? group) + (barf-if-read-only)) + (if (not (group-modified? group)) + (check-first-group-modification group)) + (undo-record-insertion! group index (fix:+ index 1)) + (prepare-gap-for-insert! group index 1) + (string-set! (group-text group) index char) + (finish-group-insert! group index 1) + (set-interrupt-enables! interrupt-mask) + unspecific)) (define (group-insert-string! group index string) (group-insert-substring! group index string 0 (string-length string))) (define (group-insert-substring! group index string start end) (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (declare (integrate %group-insert-substring!)) - (%group-insert-substring! group index string start end) - (if (not (null? (group-insert-daemons group))) - (invoke-group-daemons! (group-insert-daemons group) - group index (group-gap-start group))) - (set-interrupt-enables! interrupt-mask))) - -(define (%group-insert-substring! group index string start end) - (if (group-read-only? group) - (barf-if-read-only)) - (if (not (group-modified? group)) - (check-first-group-modification group)) - (let ((n (fix:- end start))) - (if (group-undo-data group) - (undo-record-insertion! group index (fix:+ index n))) - (prepare-gap-for-insert! group index n) - (substring-move-right! string start end (group-text group) index) - (finish-group-insert! group index n))) + (if (group-read-only? group) + (barf-if-read-only)) + (if (not (group-modified? group)) + (check-first-group-modification group)) + (let ((n (fix:- end start))) + (undo-record-insertion! group index (fix:+ index n)) + (prepare-gap-for-insert! group index n) + ;; SUBSTRING-MOVE-RIGHT is a primitive, and as such has a high + ;; calling cost; but the C compiler probably generates better + ;; code for the primitive's inner loop. So inline code this + ;; primitive for small insertions to avoid the calling overhead, + ;; and use the primitive for large insertions to gain the inner + ;; loop speed. There's no reason why 32 is a special number + ;; here, it's just out of the hat. + (%substring-move! string start end (group-text group) index) + (finish-group-insert! group index n)) + (set-interrupt-enables! interrupt-mask) + unspecific)) (define-integrable (prepare-gap-for-insert! group new-start n) (cond ((fix:< new-start (group-gap-start group)) (let ((new-end (fix:+ new-start (group-gap-length group)))) - (substring-move-right! (group-text group) - new-start - (group-gap-start group) - (group-text group) - new-end) + (%substring-move! (group-text group) + new-start + (group-gap-start group) + (group-text group) + new-end) (vector-set! group group-index:gap-start new-start) (vector-set! group group-index:gap-end new-end))) ((fix:> new-start (group-gap-start group)) (let ((new-end (fix:+ new-start (group-gap-length group)))) - (substring-move-left! (group-text group) - (group-gap-end group) - new-end - (group-text group) - (group-gap-start group)) + (%substring-move! (group-text group) + (group-gap-end group) + new-end + (group-text group) + (group-gap-start group)) (vector-set! group group-index:gap-start new-start) (vector-set! group group-index:gap-end new-end)))) (if (fix:< (group-gap-length group) n) @@ -191,8 +184,8 @@ (let ((end* (string-length text))) (let ((text* (string-allocate (fix:+ end* n))) (new-end (fix:+ end n))) - (substring-move-right! text 0 start text* 0) - (substring-move-right! text end end* text* new-end) + (%substring-move! text 0 start text* 0) + (%substring-move! text end end* text* new-end) (vector-set! group group-index:text text*) (vector-set! group group-index:gap-end new-end))) (vector-set! group group-index:gap-length (fix:+ length n))))) @@ -200,6 +193,18 @@ (define-integrable (finish-group-insert! group index n) (vector-set! group group-index:gap-start (fix:+ index n)) (vector-set! group group-index:gap-length (fix:- (group-gap-length group) n)) + (if (group-start-changes-index group) + (begin + (if (fix:< index (group-start-changes-index group)) + (set-group-start-changes-index! group index)) + (set-group-end-changes-index! + group + (if (fix:> index (group-end-changes-index group)) + (fix:+ index n) + (fix:+ (group-end-changes-index group) n)))) + (begin + (set-group-start-changes-index! group index) + (set-group-end-changes-index! group (fix:+ index n)))) (do ((marks (group-marks group) (system-pair-cdr marks))) ((null? marks)) (if (and (system-pair-car marks) @@ -208,7 +213,9 @@ (mark-left-inserting? (system-pair-car marks))))) (set-mark-index! (system-pair-car marks) (fix:+ (mark-index (system-pair-car marks)) n)))) - ;; The MODIFIED? bit must not be set until after the undo record is made. + (vector-set! group group-index:modified-tick + (fix:+ (group-modified-tick group) 1)) + ;; The MODIFIED? bit must be set *after* the undo recording. (set-group-modified! group true)) ;;;; Deletions @@ -226,50 +233,56 @@ (barf-if-read-only)) (if (not (group-modified? group)) (check-first-group-modification group)) - (if (group-undo-data group) - (undo-record-deletion! group start end)) - (if (not (null? (group-delete-daemons group))) - (invoke-group-daemons! (group-delete-daemons group) - group start end)) - ;; The MODIFIED? bit must not be set until after the undo - ;; record is made. - (set-group-modified! group true) - (let ((length (fix:- end start))) + ;; Guarantee that the gap is between START and END. This is + ;; best done before the undo recording. + (cond ((fix:< (group-gap-start group) start) + (%substring-move! (group-text group) + (group-gap-end group) + (fix:+ start (group-gap-length group)) + (group-text group) + (group-gap-start group))) + ((fix:> (group-gap-start group) end) + (%substring-move! (group-text group) + end + (group-gap-start group) + (group-text group) + (fix:+ end (group-gap-length group))))) + (undo-record-deletion! group start end) + (let ((n (fix:- end start))) + (if (group-start-changes-index group) + (begin + (if (fix:< start (group-start-changes-index group)) + (set-group-start-changes-index! group start)) + (set-group-end-changes-index! + group + (if (fix:>= end (group-end-changes-index group)) + start + (fix:- (group-end-changes-index group) n)))) + (begin + (set-group-start-changes-index! group start) + (set-group-end-changes-index! group start))) (do ((marks (group-marks group) (system-pair-cdr marks))) ((null? marks)) (cond ((or (not (system-pair-car marks)) - (fix:< (mark-index (system-pair-car marks)) start)) + (fix:<= (mark-index (system-pair-car marks)) start)) unspecific) ((fix:<= (mark-index (system-pair-car marks)) end) (set-mark-index! (system-pair-car marks) start)) (else (set-mark-index! (system-pair-car marks) - (fix:- (mark-index (system-pair-car marks)) length)))))) - ;; Guarantee that the gap is between START and END. - (cond ((fix:< (group-gap-start group) start) - (let ((text (group-text group)) - (new-end (fix:+ start (group-gap-length group)))) - (do ((index (group-gap-end group) (fix:+ index 1)) - (index* (group-gap-start group) (fix:+ index* 1))) - ((not (fix:< index new-end))) - (string-set! text index* (string-ref text index))))) - ((fix:> (group-gap-start group) end) - (let ((text (group-text group))) - (do ((index (group-gap-start group) (fix:- index 1)) - (index* (group-gap-end group) (fix:- index* 1))) - ((not (fix:< end index))) - (string-set! text - (fix:- index* 1) - (string-ref text (fix:- index 1))))))) + (fix:- (mark-index (system-pair-car marks)) n)))))) + (vector-set! group group-index:modified-tick + (fix:+ (group-modified-tick group) 1)) + ;; The MODIFIED? bit must be set *after* the undo recording. + (set-group-modified! group true) (vector-set! group group-index:gap-start start) (let ((gap-end (fix:+ end (group-gap-length group)))) (if (fix:> (fix:- gap-end start) gap-maximum-extra) (let* ((new-gap-end (fix:+ start gap-allocation-extra)) (text (group-text group)) (text-end (string-length text))) - (substring-move-left! text gap-end text-end - text new-gap-end) + (%substring-move! text gap-end text-end text new-gap-end) (set-string-maximum-length! text (fix:+ new-gap-end (fix:- text-end gap-end))) @@ -280,4 +293,5 @@ (vector-set! group group-index:gap-end gap-end) (vector-set! group group-index:gap-length (fix:- gap-end start))))) - (set-interrupt-enables! interrupt-mask)))) \ No newline at end of file + (set-interrupt-enables! interrupt-mask) + unspecific))) \ No newline at end of file diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm index cf7d5b747..e3a382c40 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.128 1991/04/01 10:07:13 cph Exp $ +;;; $Id: image.scm,v 1.129 1993/01/09 01:16:13 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -109,7 +109,9 @@ ;; Various things depend on this. (if tab-width (let loop ((index start) (c start-column)) - (if (or (fix:= c column) (fix:= index end)) + (if (or (fix:= c column) + (fix:= index end) + (fix:= (char->integer #\newline) (vector-8b-ref string index))) (cons index c) (let ((c (fix:+ c @@ -121,7 +123,9 @@ (cons index c) (loop (fix:+ index 1) c))))) (let loop ((index start) (c start-column)) - (if (or (fix:= c column) (fix:= index end)) + (if (or (fix:= c column) + (fix:= index end) + (fix:= (char->integer #\newline) (vector-8b-ref string index))) (cons index c) (let ((c (fix:+ c @@ -211,7 +215,8 @@ (let ((i&c (%substring-column->index text start gap-start start-column tab-width column))) - (if (fix:< (cdr i&c) column) + (if (and (fix:< (cdr i&c) column) + (not (char=? #\newline (string-ref text (car i&c))))) (fix:- (substring-column->index text gap-end (fix:+ end gap-length) (cdr i&c) tab-width column) diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm index 29f4ed64a..ec0d6772d 100644 --- a/v7/src/edwin/macros.scm +++ b/v7/src/edwin/macros.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: macros.scm,v 1.58 1992/11/17 21:37:49 cph Exp $ +;;; $Id: macros.scm,v 1.59 1993/01/09 01:16:15 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-1992 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -57,57 +57,36 @@ (syntax-table-define edwin-syntax-table 'DEFINE-NAMED-STRUCTURE (lambda (name . slots) - (define ((make-symbols x) y) - (make-symbol x y)) - - (define (make-symbol . args) - (intern (apply string-append args))) - - (let ((structure-name (intern name)) - (slot-strings (map symbol->string slots)) - (prefix (string-append name "-"))) - (let ((tag-name (make-symbol "%" prefix "tag")) - (constructor-name (make-symbol "%make-" name)) - (predicate-name (make-symbol name "?")) - (slot-names - (map (make-symbols (string-append prefix "index:")) slot-strings)) - (selector-names (map (make-symbols prefix) slot-strings))) - (define (slot-loop slot-names n) - (if (null? slot-names) - '() - (cons `(DEFINE-INTEGRABLE ,(car slot-names) ,n) - (slot-loop (cdr slot-names) (+ n 1))))) - - (define (selector-loop selector-names n) - (if (null? selector-names) - '() - (cons `(DEFINE-INTEGRABLE - (,(car selector-names) ,structure-name) - (VECTOR-REF ,structure-name ,n)) - (selector-loop (cdr selector-names) (+ n 1))))) - - `(BEGIN (DEFINE ,tag-name ,name) - (DEFINE (,constructor-name) - (LET ((,structure-name - (MAKE-VECTOR ,(+ (length slots) 1) '()))) - (VECTOR-SET! ,structure-name 0 ,tag-name) - ,structure-name)) - (DEFINE (,predicate-name OBJECT) - (AND (VECTOR? OBJECT) - (NOT (ZERO? (VECTOR-LENGTH OBJECT))) - (EQ? ,tag-name (VECTOR-REF OBJECT 0)))) - (UNPARSER/SET-TAGGED-VECTOR-METHOD! - ,tag-name - (UNPARSER/STANDARD-METHOD ',structure-name)) - (NAMED-STRUCTURE/SET-TAG-DESCRIPTION! - ,tag-name - (LAMBDA (OBJECT) - (LIST ,@(map (lambda (slot selector-name) - `(LIST ',slot (,selector-name OBJECT))) - slots - selector-names)))) - ,@(slot-loop slot-names 1) - ,@(selector-loop selector-names 1)))))) + (let ((name (if (symbol? name) name (intern name))) + (indexes + (let loop ((slots slots) (index 1)) + (if (null? slots) + '() + (cons index (loop (cdr slots) (+ index 1))))))) + (let ((tag-name (symbol-append '% name '-TAG))) + `(BEGIN + (DEFINE ,tag-name + (MAKE-DEFINE-STRUCTURE-TYPE 'VECTOR + ',name + ',slots + ',indexes + (UNPARSER/STANDARD-METHOD ',name))) + (DEFINE (,(symbol-append '%MAKE- name)) + (LET ((,name (MAKE-VECTOR ,(+ (length slots) 1) '()))) + (VECTOR-SET! ,name 0 ,tag-name) + ,name)) + (DEFINE (,(symbol-append name '?) OBJECT) + (AND (VECTOR? OBJECT) + (NOT (ZERO? (VECTOR-LENGTH OBJECT))) + (EQ? ,tag-name (VECTOR-REF OBJECT 0)))) + ,@(append-map + (lambda (slot index) + `((DEFINE-INTEGRABLE (,(symbol-append name '- slot) ,name) + (VECTOR-REF ,name ,index)) + (DEFINE-INTEGRABLE ,(symbol-append name '-INDEX: slot) + ,index))) + slots + indexes)))))) (syntax-table-define edwin-syntax-table 'DEFINE-COMMAND (lambda (name description interactive procedure) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 520da52e7..bfd11b6f0 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 3.76 1992/11/17 22:56:24 cph Exp $ +$Id: make.scm,v 3.77 1993/01/09 01:16:16 cph Exp $ Copyright (c) 1989-1992 Massachusetts Institute of Technology @@ -40,4 +40,4 @@ MIT in each case. |# "edwin" `((os-type . ,(intern (microcode-identification-item 'OS-NAME-STRING)))) 'QUERY) -(add-system! (make-system "Edwin" 3 76 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 77 '())) \ No newline at end of file diff --git a/v7/src/edwin/motion.scm b/v7/src/edwin/motion.scm index 149de06b6..d9645eb4b 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.83 1991/03/22 00:32:37 cph Exp $ +;;; $Id: motion.scm,v 1.84 1993/01/09 01:16:18 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -54,7 +54,7 @@ ((eq? limit? 'FAILURE) (editor-failure) limit) ((eq? limit? 'ERROR) (editor-error)) ((not limit?) false) - (else (error "Unknown limit type" limit?)))) + (else (error "Unknown limit type:" limit?)))) (define (mark1+ mark #!optional limit?) (let ((group (mark-group mark)) @@ -62,7 +62,7 @@ (if (group-end-index? group index) (limit-mark-motion (and (not (default-object? limit?)) limit?) (group-end-mark group)) - (make-mark group (fix:1+ index))))) + (make-mark group (fix:+ index 1))))) (define (mark-1+ mark #!optional limit?) (let ((group (mark-group mark)) @@ -70,7 +70,7 @@ (if (group-start-index? group index) (limit-mark-motion (and (not (default-object? limit?)) limit?) (group-start-mark group)) - (make-mark group (fix:-1+ index))))) + (make-mark group (fix:- index 1))))) (define (region-count-chars region) (fix:- (region-end-index region) (region-start-index region))) @@ -111,38 +111,16 @@ ;;;; Motion by Lines -;;; Move to the beginning of the Nth line, starting from INDEX in -;;; GROUP, where positive N means down, negative N means up, and zero -;;; N means the current line. If such a line exists, call IF-OK on -;;; the position (of the line's start), otherwise call IF-NOT-OK on -;;; the limiting mark (the group's start or end) which was exceeded. - -(define (move-vertically group index n if-ok if-not-ok) - (cond ((fix:positive? n) - (let ((limit (group-end-index group))) - (let loop ((i index) (n n)) - (let ((j (%find-next-newline group i limit))) - (cond ((not j) (if-not-ok (group-end-mark group))) - ((fix:= n 1) (if-ok (fix:1+ j))) - (else (loop (fix:1+ j) (fix:-1+ n)))))))) - ((fix:negative? n) - (let ((limit (group-start-index group))) - (let loop ((i index) (n n)) - (let ((j (%find-previous-newline group i limit))) - (cond ((fix:zero? n) (if-ok (or j limit))) - ((not j) (if-not-ok (group-start-mark group))) - (else (loop (fix:-1+ j) (fix:1+ n)))))))) - (else - (if-ok (line-start-index group index))))) - (define (line-start-index group index) (let ((limit (group-start-index group))) - (or (%find-previous-newline group index limit) - limit))) + (let ((index (group-find-previous-char group limit index #\newline))) + (if index + (fix:+ index 1) + limit)))) (define (line-end-index group index) (let ((limit (group-end-index group))) - (or (%find-next-newline group index limit) + (or (group-find-next-char group index limit #\newline) limit))) (define (line-start-index? group index) @@ -152,27 +130,46 @@ (define (line-end-index? group index) (or (group-end-index? group index) (char=? (group-right-char group index) #\newline))) - + (define (line-start mark n #!optional limit?) - (let ((group (mark-group mark))) - (move-vertically group (mark-index mark) n - (lambda (index) - (make-mark group index)) - (lambda (mark) - (limit-mark-motion (and (not (default-object? limit?)) limit?) - mark))))) + (let ((group (mark-group mark)) + (lose + (lambda (mark) + (limit-mark-motion (and (not (default-object? limit?)) limit?) + mark)))) + (if (fix:> n 0) + (let ((limit (group-end-index group))) + (let loop ((i (mark-index mark)) (n n)) + (let ((j (group-find-next-char group i limit #\newline))) + (cond ((not j) (lose (group-end-mark group))) + ((fix:= n 1) (make-mark group (fix:+ j 1))) + (else (loop (fix:+ j 1) (fix:- n 1))))))) + (let ((limit (group-start-index group))) + (let loop ((i (mark-index mark)) (n n)) + (let ((j (group-find-previous-char group limit i #\newline))) + (cond ((fix:= n 0) (make-mark group (if j (fix:+ j 1) limit))) + ((not j) (lose (group-start-mark group))) + (else (loop j (fix:+ n 1)))))))))) (define (line-end mark n #!optional limit?) - (let ((group (mark-group mark))) - (move-vertically group (mark-index mark) n - (lambda (index) - (let ((end (%find-next-newline group index (group-end-index group)))) - (if end - (make-mark group end) - (group-end-mark group)))) - (lambda (mark) - (limit-mark-motion (and (not (default-object? limit?)) limit?) - mark))))) + (let ((group (mark-group mark)) + (lose + (lambda (mark) + (limit-mark-motion (and (not (default-object? limit?)) limit?) + mark)))) + (if (fix:< n 0) + (let ((limit (group-start-index group))) + (let loop ((i (mark-index mark)) (n n)) + (let ((j (group-find-previous-char group limit i #\newline))) + (cond ((not j) (lose (group-start-mark group))) + ((fix:= n -1) (make-mark group j)) + (else (loop j (fix:+ n 1))))))) + (let ((limit (group-end-index group))) + (let loop ((i (mark-index mark)) (n n)) + (let ((j (group-find-next-char group i limit #\newline))) + (cond ((fix:= n 0) (make-mark group (or j limit))) + ((not j) (lose (group-end-mark group))) + (else (loop (fix:+ j 1) (fix:- n 1)))))))))) (define (line-start? mark) (line-start-index? (mark-group mark) (mark-index mark))) @@ -187,14 +184,11 @@ (define (group-count-lines group start end) (let loop ((start start) (n 0)) - (if (fix:= start end) - n - (let ((i (%find-next-newline group start end)) - (n (fix:1+ n))) - (if (not i) - n - (loop (fix:1+ i) n)))))) - + (cond ((fix:= start end) n) + ((group-find-next-char group start end #\newline) + => (lambda (i) (loop (fix:+ i 1) (fix:+ n 1)))) + (else (fix:+ n 1))))) + ;;;; Motion by Columns (define (mark-column mark) @@ -212,7 +206,7 @@ (make-mark group (group-column->index group (line-start-index group index) - (line-end-index group index) + (group-end-index group) 0 column (group-tab-width group))))) \ No newline at end of file diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm index 6571be52b..d74a97147 100644 --- a/v7/src/edwin/struct.scm +++ b/v7/src/edwin/struct.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: struct.scm,v 1.81 1992/11/12 18:00:39 cph Exp $ +;;; $Id: struct.scm,v 1.82 1993/01/09 01:16:20 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -99,10 +99,10 @@ read-only? display-start display-end - insert-daemons - delete-daemons + start-changes-index + end-changes-index + modified-tick clip-daemons - move-point-daemons undo-data modified? point @@ -124,10 +124,10 @@ (vector-set! group group-index:end-mark end) (vector-set! group group-index:display-end end)) (vector-set! group group-index:read-only? false) - (vector-set! group group-index:insert-daemons '()) - (vector-set! group group-index:delete-daemons '()) + (vector-set! group group-index:start-changes-index false) + (vector-set! group group-index:end-changes-index false) + (vector-set! group group-index:modified-tick 0) (vector-set! group group-index:clip-daemons '()) - (vector-set! group group-index:move-point-daemons '()) (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)) @@ -167,6 +167,12 @@ (define-integrable (set-group-writable! group) (vector-set! group group-index:read-only? false)) +(define-integrable (set-group-start-changes-index! group start) + (vector-set! group group-index:start-changes-index start)) + +(define-integrable (set-group-end-changes-index! group end) + (vector-set! group group-index:end-changes-index end)) + (define-integrable (set-group-marks! group marks) (vector-set! group group-index:marks marks)) @@ -204,14 +210,9 @@ (define-integrable (set-group-modified! group sense) (vector-set! group group-index:modified? sense)) -(define-integrable (%set-group-point! group point) +(define-integrable (set-group-point! group point) (vector-set! group group-index:point (mark-left-inserting-copy point))) -(define (set-group-point! group point) - (let ((old-point (group-point group))) - (%set-group-point! group point) - (record-move-point! group point old-point))) - (define (group-absolute-start group) (make-temporary-mark group 0 false)) @@ -259,39 +260,6 @@ (vector-set! group group-index:start-mark start) (vector-set! group group-index:end-mark end))) -(define (invoke-group-daemons! daemons group start end) - (let loop ((daemons daemons)) - (if (not (null? daemons)) - (begin - ((car daemons) group start end) - (loop (cdr daemons)))))) - -(define (record-insertion! group start end) - (invoke-group-daemons! (group-insert-daemons group) group start end)) - -(define (add-group-insert-daemon! group daemon) - (vector-set! group - group-index:insert-daemons - (cons daemon (vector-ref group group-index:insert-daemons)))) - -(define (remove-group-insert-daemon! group daemon) - (vector-set! group - group-index:insert-daemons - (delq! daemon (vector-ref group group-index:insert-daemons)))) - -(define (record-deletion! group start end) - (invoke-group-daemons! (group-delete-daemons group) group start end)) - -(define (add-group-delete-daemon! group daemon) - (vector-set! group - group-index:delete-daemons - (cons daemon (vector-ref group group-index:delete-daemons)))) - -(define (remove-group-delete-daemon! group daemon) - (vector-set! group - group-index:delete-daemons - (delq! daemon (vector-ref group group-index:delete-daemons)))) - (define (record-clipping! group start end) (let ((buffer (group-buffer group))) (if (and buffer @@ -303,6 +271,13 @@ (set-buffer-display-start! buffer false))) (invoke-group-daemons! (group-clip-daemons group) group start end)) +(define (invoke-group-daemons! daemons group start end) + (let loop ((daemons daemons)) + (if (not (null? daemons)) + (begin + ((car daemons) group start end) + (loop (cdr daemons)))))) + (define (add-group-clip-daemon! group daemon) (vector-set! group group-index:clip-daemons @@ -313,21 +288,6 @@ group-index:clip-daemons (delq! daemon (vector-ref group group-index:clip-daemons)))) -(define (record-move-point! group start end) - (invoke-group-daemons! (group-move-point-daemons group) group start end)) - -(define (add-group-move-point-daemon! group daemon) - (vector-set! group - group-index:move-point-daemons - (cons daemon (vector-ref group - group-index:move-point-daemons)))) - -(define (remove-group-move-point-daemon! group daemon) - (vector-set! group - group-index:move-point-daemons - (delq! daemon (vector-ref group - group-index:move-point-daemons)))) - (define (group-local-ref group variable) (variable-local-value (let ((buffer (group-buffer group))) (if (not buffer) diff --git a/v7/src/edwin/things.scm b/v7/src/edwin/things.scm index 8d501c2f7..954ed70a1 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.83 1991/11/21 10:38:40 cph Exp $ +;;; $Id: things.scm,v 1.84 1993/01/09 01:16:21 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -110,55 +110,64 @@ (kill-region (forward-thing (current-point) n limit?))) (define (transpose-things forward-thing n) - (define (forward-once i) - i ;ignore - (let ((m4 (mark-right-inserting (forward-thing (current-point) 1 'ERROR)))) - (set-current-point! m4) - (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))) - (insert-string (extract-and-delete-string m1 m3) m4) - (insert-string (extract-and-delete-string m2 m4) m1)))))) - - (define (backward-once i) - i ;ignore - (let ((m2 (mark-permanent! (forward-thing (current-point) -1 'ERROR)))) - (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)))) - (insert-string (extract-and-delete-string m1 m3) m4) - (insert-string (extract-and-delete-string m2 m4) m1)) - (set-current-point! m1)))) - - (define (special) - (let ((m1 (normalize (current-point))) - (m2 (normalize (current-mark)))) - (cond ((mark< m1 m2) - (exchange m1 m2 - (lambda (m1 m2) - (set-current-point! m2) - (set-current-mark! m1)))) - ((mark< m2 m1) - (exchange m2 m1 - (lambda (m2 m1) - (set-current-point! m2) - (set-current-mark! m1))))))) - - (define (exchange m1 m2 receiver) - (let ((m1 (mark-right-inserting m1)) - (m3 (forward-thing m1 1 'ERROR)) - (m2 (mark-permanent! m2)) - (m4 (mark-right-inserting (forward-thing m2 1 'ERROR)))) - (insert-string (extract-and-delete-string m1 m3) m4) - (insert-string (extract-and-delete-string m2 m4) m1) - (receiver m4 m1))) - - (define (normalize m) - (forward-thing (forward-thing m 1 'ERROR) -1 'ERROR)) - - (cond ((positive? n) (dotimes n forward-once)) - ((negative? n) (dotimes (- n) backward-once)) - (else (special)))) + (cond ((> n 0) + (do ((i 0 (+ i 1))) + ((= i n)) + (let* ((m4 + (mark-right-inserting-copy + (forward-thing (current-point) 1 'ERROR))) + (m2 + (mark-left-inserting-copy (forward-thing m4 -1 'ERROR))) + (m1 + (mark-left-inserting-copy (forward-thing m2 -1 'ERROR))) + (m3 (forward-thing m1 1 'ERROR))) + (set-current-point! m4) + (insert-string (extract-and-delete-string m1 m3) m4) + (insert-string (extract-and-delete-string m2 m4) m1) + (mark-temporary! m1) + (mark-temporary! m2) + (mark-temporary! m4)))) + ((< n 0) + (do ((i 0 (- i 1))) + ((= i n)) + (let* ((m2 + (mark-left-inserting-copy + (forward-thing (current-point) -1 'ERROR))) + (m1 (mark-left-inserting-copy (forward-thing m2 -1 'ERROR))) + (m3 (forward-thing m1 1 'ERROR)) + (m4 (mark-right-inserting-copy (forward-thing m2 1 'ERROR)))) + (insert-string (extract-and-delete-string m1 m3) m4) + (insert-string (extract-and-delete-string m2 m4) m1) + (set-current-point! m1) + (mark-temporary! m1) + (mark-temporary! m2) + (mark-temporary! m4)))) + (else + (let ((normalize + (lambda (m) + (forward-thing (forward-thing m 1 'ERROR) -1 'ERROR))) + (exchange + (lambda (m1 m2 set-m1! set-m2!) + (let ((m1 (mark-right-inserting-copy m1)) + (m3 (forward-thing m1 1 'ERROR)) + (m2 (mark-left-inserting-copy m2)) + (m4 + (mark-right-inserting-copy + (forward-thing m2 1 'ERROR)))) + (insert-string (extract-and-delete-string m1 m3) m4) + (insert-string (extract-and-delete-string m2 m4) m1) + (set-m1! m4) + (set-m2! m1) + (mark-temporary! m1) + (mark-temporary! m2) + (mark-temporary! m4))))) + (let ((m1 (normalize (current-point))) + (m2 (normalize (current-mark)))) + (cond ((mark< m1 m2) + (exchange m1 m2 set-current-mark! set-current-point!)) + ((mark< m2 m1) + (exchange m2 m1 + set-current-point! set-current-mark!)))))))) ;;;; Horizontal Space @@ -167,10 +176,10 @@ (horizontal-space-end mark))) (define (horizontal-space-start mark) - (skip-chars-backward " \t" mark (line-start mark 0))) + (skip-chars-backward " \t" mark)) (define (horizontal-space-end mark) - (skip-chars-forward " \t" mark (line-end mark 0))) + (skip-chars-forward " \t" mark)) (define (compute-horizontal-space c1 c2 tab-width) ;; Compute the number of tabs/spaces required to fill from column C1 diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm index c844ab578..3c9c76125 100644 --- a/v7/src/edwin/undo.scm +++ b/v7/src/edwin/undo.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.50 1992/04/04 13:05:16 cph Exp $ +;;; $Id: undo.scm,v 1.51 1993/01/09 01:16:23 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -42,77 +42,19 @@ ;;; of that license should have been included along with this file. ;;; -;;;; Undo, translated from the GNU Emacs implementation in C. +;;;; Undo, translated from the GNU Emacs implementation in C/Emacs-Lisp. (declare (usual-integrations)) -;;;; Basic Record Keeping - -(define-integrable initial-undo-records 8) -(define-integrable initial-undo-chars 128) -(define-integrable maximum-undo-records 512) -(define-integrable maximum-undo-chars 8192) - -(define-structure (undo-data) - records ; vector of records - next-record ; position in vector - chars ; string of characters - next-char ; position in string - last-undo-record - last-undone-record - last-undone-char - - ;; This counts the total number of records that have been undone, - ;; so that it can be compared to the total number of records, to - ;; determine if we have run out of records. - number-records-undone - - ;; This says how many chars of undo are left. It is initialized by - ;; the Undo command to the length of the chars string, and used, - ;; like NUMBER-RECORDS-UNDONE, to determine if we have run out of - ;; undo data. This, however, is kept up to date by NEW-UNDO - ;; because there is no NOT-UNDOABLE boundary in the chars array to - ;; tell us where the chars end. - number-chars-left - ) - -(define-structure (undo-record - (type vector) - (constructor %make-undo-record ())) - (type false) - (start false) - (length false)) - -(define-integrable (undo-records-ref records index) - (or (vector-ref records index) - (let ((new-record (%make-undo-record))) - (vector-set! records index new-record) - new-record))) - (define (enable-group-undo! group) - (without-interrupts - (lambda () - (set-group-undo-data! - group - (make-undo-data (let ((records (make-vector initial-undo-records false))) - (mark-not-undoable! - (undo-records-ref records (- initial-undo-records 1))) - records) - 0 - (string-allocate initial-undo-chars) - 0 - false - false - false - 0 - 0))))) + (set-group-undo-data! group '())) (define (disable-group-undo! group) - (set-group-undo-data! group false)) + (set-group-undo-data! group #t)) (define (with-group-undo-disabled group thunk) (let ((outside-data) - (inside-data false)) + (inside-data #t)) (dynamic-wind (lambda () (set! outside-data (group-undo-data group)) (set-group-undo-data! group inside-data) @@ -124,339 +66,257 @@ (set-group-undo-data! group outside-data) (set! outside-data) unspecific)))) - -(define (new-undo! undo-data type group start length) - group - (let ((records (undo-data-records undo-data)) - (index (undo-data-next-record undo-data))) - (let ((undo-record (undo-records-ref records index))) - (set-undo-record-type! undo-record type) - (set-undo-record-start! undo-record start) - (set-undo-record-length! undo-record length) - (set-undo-data-last-undo-record! undo-data undo-record)) - (let ((next (fix:+ index 1))) - (cond ((fix:< next (vector-length records)) - (mark-not-undoable! (undo-records-ref records next)) - (set-undo-data-next-record! undo-data next)) - ((fix:>= next maximum-undo-records) - (mark-not-undoable! (vector-ref records 0)) - (set-undo-data-next-record! undo-data 0)) - (else - (let ((new-records (make-vector maximum-undo-records false)) - (length (vector-length records)) - (new-record (%make-undo-record)) - (max-record (%make-undo-record))) - (do ((index 0 (fix:+ index 1))) - ((fix:= index length)) - (vector-set! new-records index (vector-ref records index))) - (mark-not-undoable! new-record) - (mark-not-undoable! max-record) - (vector-set! new-records length new-record) - (vector-set! new-records - (fix:- maximum-undo-records 1) - max-record) - (set-undo-data-records! undo-data new-records) - (set-undo-data-next-record! undo-data next)))))) - (if (not (eq? 'BOUNDARY type)) - (set-undo-data-last-undone-record! undo-data -1))) -(define-integrable (mark-not-undoable! record) - (set-undo-record-type! record 'NOT-UNDOABLE)) - -(define (undo-store-substring! undo-data string start end) - (let loop ((start start)) - (let ((chars (undo-data-chars undo-data)) - (i (undo-data-next-char undo-data))) - (let ((room (fix:- (string-length chars) i)) - (needed (fix:- end start))) - (cond ((fix:> room needed) - (do ((index start (fix:+ index 1)) - (i i (fix:+ i 1))) - ((fix:= index end)) - (string-set! chars i (string-ref string index))) - (set-undo-data-next-char! undo-data (fix:+ i needed)) - (set-undo-data-number-chars-left! - undo-data - (fix:- (undo-data-number-chars-left undo-data) needed))) - ((fix:= room needed) - (do ((index start (fix:+ index 1)) - (i i (fix:+ i 1))) - ((fix:= index end)) - (string-set! chars i (string-ref string index))) - (set-undo-data-next-char! undo-data 0) - (set-undo-data-number-chars-left! - undo-data - (fix:- (undo-data-number-chars-left undo-data) needed))) - ((fix:< (string-length chars) maximum-undo-chars) - (let ((new-chars (string-allocate maximum-undo-chars))) - (do ((index 0 (fix:+ index 1))) - ((fix:= index i)) - (string-set! new-chars index (string-ref chars index))) - (set-undo-data-chars! undo-data new-chars)) - (set-undo-data-number-chars-left! - undo-data - (fix:+ (fix:- maximum-undo-chars (string-length chars)) - (undo-data-number-chars-left undo-data))) - (loop start)) - (else - (let ((new-start (fix:+ start room))) - (do ((index start (fix:+ index 1)) - (i i (fix:+ i 1))) - ((fix:= index new-start)) - (string-set! chars i (string-ref string index))) - (set-undo-data-next-char! undo-data 0) - (set-undo-data-number-chars-left! - undo-data - (fix:- (undo-data-number-chars-left undo-data) room)) - (loop new-start))))))) - unspecific) - -;;;; External Recording Hooks +(define (undo-done! point) + ;; Called to say that POINT's group should have no undo data, + ;; usually because it has just been filled from a file. + (set-group-undo-data! (mark-group point) '())) -;;; These must be called before the GROUP-MODIFIED? is updated, so -;;; that they can read its old value. In addition, the deletion -;;; recording hook must be called before the deletion is performed. +(define (undo-boundary! point) + ;; Called to say that M-x undo should consider this the boundary of + ;; a single undoable sequence of changes. + (group-undo-boundary! (mark-group point))) -(define (undo-record-insertion! group start end) - (let ((undo-data (group-undo-data group))) - (if undo-data - (begin - (undo-mark-modified! group start undo-data) - (let ((last (undo-data-last-undo-record undo-data)) - (length (fix:- end start))) - (if (and last - (eq? 'DELETE (undo-record-type last)) - (fix:= start - (fix:+ (undo-record-start last) - (undo-record-length last)))) - (set-undo-record-length! last - (fix:+ length - (undo-record-length last))) - (new-undo! undo-data 'DELETE group start length))))))) +(define (undo-leave-window! window) + ;; Called to say that WINDOW is being deselected, and that therefore + ;; this is a good point at which to mark an undo boundary. + (group-undo-boundary! (buffer-group (window-buffer window)))) -(define (undo-record-deletion! group start end) - (let ((undo-data (group-undo-data group))) - (if undo-data - (begin - (undo-mark-modified! group start undo-data) - (let ((last (undo-data-last-undo-record undo-data)) - (length (fix:- end start))) - (if (and last - (eq? 'INSERT (undo-record-type last)) - (fix:= start (undo-record-start last))) - (set-undo-record-length! last - (fix:+ length - (undo-record-length last))) - (new-undo! undo-data 'INSERT group start length))) - (let ((text (group-text group)) - (gap-start (group-gap-start group)) - (length (group-gap-length group))) - (cond ((fix:<= end gap-start) - (undo-store-substring! undo-data text start end)) - ((fix:>= start gap-start) - (undo-store-substring! undo-data - text - (fix:+ start length) - (fix:+ end length))) - (else - (undo-store-substring! undo-data text start gap-start) - (undo-store-substring! undo-data - text - (group-gap-end group) - (fix:+ end length))))))))) +(define (group-undo-boundary! group) + (if (not (or (eq? #t (group-undo-data group)) + ;; Don't allow a boundary to be inserted as the last + ;; element of the list. + (null? (group-undo-data group)) + ;; Don't allow two boundaries to be adjacent. + (eq? #f (car (group-undo-data group))))) + (set-group-undo-data! group (cons #f (group-undo-data group))))) -(define (undo-boundary! point) - (without-interrupts - (lambda () - (let ((group (mark-group point))) - (let ((undo-data (group-undo-data group))) - (if undo-data - (undo-mark-previous! undo-data - 'BOUNDARY - group - (mark-index point)))))))) +;;;; Recording Hooks -(define (undo-leave-window! window) - ;; Assumes that interrupts are disabled. - (let ((point (window-point window))) - (let ((group (mark-group point))) - (let ((undo-data (group-undo-data group))) - (if undo-data - (begin - (undo-mark-previous! undo-data - 'BOUNDARY - group - (mark-index point)) - (set-undo-data-last-undone-record! undo-data -1))))))) +;;; These recording hooks must be called before GROUP-MODIFIED? is +;;; updated, so that they can read its old value. In addition, the +;;; deletion recording hook must be called before the deletion is +;;; performed, so that it can extract the characters being deleted. -(define (undo-done! point) - (without-interrupts - (lambda () - (let ((group (mark-group point))) - (let ((undo-data (group-undo-data group))) - (if undo-data - (undo-mark-previous! undo-data - 'NOT-UNDOABLE - group - (mark-index point)))))))) +(define (undo-record-insertion! group start end) + (cond ((eq? #t (group-undo-data group)) + unspecific) + ((not (group-modified? group)) + (undo-record-first-change! group) + (set-group-undo-data! group + (cons (cons start end) + (group-undo-data group)))) + ((and (pair? (group-undo-data group)) + (pair? (car (group-undo-data group))) + (fix:fixnum? (caar (group-undo-data group))) + (fix:fixnum? (cdar (group-undo-data group))) + (fix:= (cdr (group-undo-data group)) start)) + (set-cdr! (group-undo-data group) end)) + (else + (set-group-undo-data! group + (cons (cons start end) + (group-undo-data group)))))) -(define-integrable (undo-mark-modified! group start undo-data) - (if (not (group-modified? group)) - (new-undo! undo-data 'UNMODIFY group start - (let ((buffer (group-buffer group))) - (and buffer - (buffer-modification-time buffer)))))) +(define (undo-record-deletion! group start end) + (if (not (eq? #t (group-undo-data group))) + (begin + (if (not (group-modified? group)) + (undo-record-first-change! group)) + (set-group-undo-data! + group + (let ((text (group-extract-string group start end)) + (point (mark-index (group-point group)))) + (cond ((fix:= point start) + (cons (cons text start) + (group-undo-data group))) + ((fix:= point end) + (cons (cons text (fix:- 0 start)) + (group-undo-data group))) + (else + (cons* (cons text start) + point + (group-undo-data group))))))))) -(define-integrable (undo-mark-previous! undo-data type group start) - (let ((records (undo-data-records undo-data))) - (let ((index - (let ((next (undo-data-next-record undo-data))) - (- (if (zero? next) - (vector-length records) - next) - 1)))) - (let ((record (vector-ref records index))) - (if record - (if (not (eq? type (undo-record-type record))) - (new-undo! undo-data type group start 0)) - (begin - (vector-set! records index (%make-undo-record)) - (new-undo! undo-data type group start 0))))))) +(define (undo-record-first-change! group) + (let ((buffer (group-buffer group))) + (if buffer + (set-group-undo-data! group + (cons (cons #t (buffer-modification-time buffer)) + (group-undo-data group)))))) -;;;; Undo Command +;;;; Truncation -;;; Some error messages: +(define-variable undo-limit + "Keep no more undo information once it exceeds this size. +This limit is applied when garbage collection happens. +The size is counted as the number of bytes occupied, +which includes both the saved text and other data." + 20000) -(define cant-undo-more - "Cannot undo more: changes have been made since the last undo") +(define-variable undo-strong-limit + "Don't keep more than this much size of undo information. +A command that pushes past this size is itself forgotten. +This limit is applied when garbage collection happens. +The size is counted as the number of bytes occupied, +which includes both the saved text and other data." + 30000) -(define no-more-undo - "No further undo information available") +(define (truncate-buffer-undo-lists!) + ;; This procedure must be careful about accessing editor data + ;; structures because it is a GC daemon and can be run at times when + ;; the editor does not exist or is not running. It would actually + ;; prefer to be run *before* the GC, but that's not possible now. + (if edwin-editor + (let ((bytes-per-word + (vector-ref ((ucode-primitive gc-space-status 0)) 0))) + (let ((min-size + (integer-round (variable-default-value + (ref-variable-object undo-limit)) + bytes-per-word)) + (max-size + (integer-round (variable-default-value + (ref-variable-object undo-strong-limit)) + bytes-per-word))) + (do ((buffers (bufferset-buffer-list (editor-bufferset edwin-editor)) + (cdr buffers))) + ((null? buffers)) + (truncate-undo-data! (group-undo-data (buffer-group (car buffers))) + min-size + max-size)))))) -(define outside-visible-range - "Changes to be undone are outside the visible portion of buffer") +(add-gc-daemon! truncate-buffer-undo-lists!) -(define undo-command-tag "Undo") +(define (truncate-undo-data! undo-data min-size max-size) + (letrec + ((loop + (lambda (undo-data prev size boundary) + (cond ((null? undo-data) + ;; We've reached the end of the list, so no + ;; truncation is needed. + unspecific) + ((eq? #f (car undo-data)) + ;; We've reached a boundary. If it's the first + ;; boundary, continue regardless of size, otherwise + ;; continue only if we haven't yet reached MIN-SIZE. + (if (and boundary (fix:> size min-size)) + ;; If we've exceeded MAX-SIZE, truncate at the + ;; previous boundary, otherwise truncate here. + (set-cdr! (if (fix:> size max-size) boundary prev) '()) + (loop (cdr undo-data) undo-data (fix:+ size 2) prev))) + (else + ;; Normal case: count the storage used by this element. + (loop (cdr undo-data) + undo-data + (fix:+ size + (cond ((not (pair? (car undo-data))) 2) + ((not (string? (caar undo-data))) 4) + (else (fix:+ 5 (system-vector-length + (caar undo-data)))))) + boundary)))))) + (cond ((or (null? undo-data) + (eq? #t undo-data)) + unspecific) + ((eq? #f (car undo-data)) + ;; If list starts with a boundary, skip over it. We want + ;; to include the first non-null undo operation in the + ;; result. + (loop (cdr undo-data) undo-data 2 #f)) + (else + (loop undo-data #f 0 #f))))) + +;;;; M-x undo (define-command undo "Undo some previous changes. Repeat this command to undo more changes. A numeric argument serves as a repeat count." - "p" - (lambda (argument) - (if (positive? argument) - (begin + "*p" + (let ((command-tag (string-copy "undo"))) + (lambda (argument) + (if (> argument 0) (let ((buffer (current-buffer))) - (let ((auto-saved? (buffer-auto-saved? buffer)) - (undo-data (group-undo-data (buffer-group buffer)))) - (if (not undo-data) - (editor-error "Undo information not kept for this buffer")) - (without-interrupts - (lambda () - (command-message-receive undo-command-tag - (lambda () - (if (= -1 (undo-data-last-undone-record undo-data)) - (editor-error cant-undo-more))) - (lambda () - (set-undo-data-number-records-undone! undo-data 0) - (set-undo-data-number-chars-left! - undo-data - (string-length (undo-data-chars undo-data))) - (set-undo-data-last-undone-record! - undo-data - (undo-data-next-record undo-data)) - (set-undo-data-last-undone-char! - undo-data - (undo-data-next-char undo-data)) - ;; This accounts for the boundary that is inserted - ;; just before this command is called. - (set! argument (+ argument 1)) - unspecific)) - (undo-n-records undo-data - buffer - (count-records-to-undo undo-data - argument)))) + (let ((auto-saved? (buffer-auto-saved? buffer))) + (set-command-message! + command-tag + (command-message-receive command-tag + (lambda (undo-data) + (undo-more buffer undo-data argument)) + (lambda () + (undo-more buffer (undo-start buffer) (+ argument 1))))) (if (and auto-saved? (not (buffer-modified? buffer))) - (delete-auto-save-file! buffer)))) - (set-command-message! undo-command-tag) - (temporary-message "Undo!"))))) - -(define (count-records-to-undo undo-data argument) - (let ((records (undo-data-records undo-data))) - (let find-nth-boundary - ((argument argument) - (i (undo-data-last-undone-record undo-data)) - (n 0)) - (let find-boundary ((i i) (n n) (any-records? false)) - (let ((i (- (if (= i 0) (vector-length records) i) 1)) - (n (+ n 1)) - (n-undone (+ (undo-data-number-records-undone undo-data) 1))) - (set-undo-data-number-records-undone! undo-data n-undone) - (if (> n-undone (vector-length records)) (editor-error no-more-undo)) - (case (undo-record-type (vector-ref records i)) - ((BOUNDARY) - (if (= argument 1) - n - (find-nth-boundary (- argument 1) i n))) - ((NOT-UNDOABLE) - (if (not (and (= argument 1) any-records?)) - (editor-error no-more-undo)) - ;; Treat this as if it were a BOUNDARY record. - n) - ((INSERT) - (let ((n-left - (- (undo-data-number-chars-left undo-data) - (undo-record-length (vector-ref records i))))) - (set-undo-data-number-chars-left! undo-data n-left) - (if (< n-left 0) - (editor-error no-more-undo)) - (find-boundary i n true))) - (else - (find-boundary i n true)))))))) + (delete-auto-save-file! buffer)) + (if (not (typein-window? (current-window))) + (message "Undo!")))))))) -(define (undo-n-records undo-data buffer n) +(define (undo-start buffer) + (let ((undo-data (group-undo-data (buffer-group buffer)))) + (if (eq? #t undo-data) + (editor-error "No undo information in this buffer:" buffer)) + undo-data)) + +(define (undo-more buffer undo-data n) + (let loop ((undo-data undo-data) (n n)) + (if (> n 0) + (begin + (if (null? undo-data) + (editor-error "No further undo information:" buffer)) + (loop (undo-one-step buffer undo-data) (- n 1))) + undo-data))) + +(define (undo-one-step buffer data) + ;; Perform one undo step on BUFFER, returning the unused portion of DATA. (let ((group (buffer-group buffer)) - (records (undo-data-records undo-data)) - (chars (undo-data-chars undo-data))) - (do ((n n (- n 1))) - ((= n 0)) - (let ((ir - (- (let ((record (undo-data-last-undone-record undo-data))) - (if (= record 0) (vector-length records) record)) - 1))) - (let ((record (vector-ref records ir))) - (let ((start (undo-record-start record))) - (if (or (< start (group-start-index group)) - (> start (group-end-index group))) - (editor-error outside-visible-range)) - (case (undo-record-type record) - ((DELETE) - (let ((end (+ start (undo-record-length record)))) - (if (> end (group-end-index group)) - (editor-error outside-visible-range)) - (group-delete! group start end)) - (set-current-point! (make-mark group start))) - ((INSERT) - (set-current-point! (make-mark group start)) - (let* ((last-undone-char (undo-data-last-undone-char undo-data)) - (ic (- last-undone-char (undo-record-length record)))) - (if (>= ic 0) - (begin - (group-insert-substring! group start - chars ic last-undone-char) - (set-undo-data-last-undone-char! undo-data ic)) - (let ((l (string-length chars))) - (let ((ic* (+ l ic))) - (group-insert-substring! group start chars ic* l) - (group-insert-substring! group (- start ic) - chars 0 last-undone-char) - (set-undo-data-last-undone-char! undo-data ic*)))))) - ((UNMODIFY) - (if (eqv? (undo-record-length record) - (buffer-modification-time buffer)) - (buffer-not-modified! buffer))) - ((BOUNDARY NOT-UNDOABLE) - unspecific) - (else - (error "Losing undo record type" (undo-record-type record)))))) - (set-undo-data-last-undone-record! undo-data ir))))) \ No newline at end of file + (point (mark-left-inserting-copy (buffer-point buffer))) + (outside-visible-range + (lambda () + (editor-error + "Changes to be undone are outside visible portion of buffer:" + buffer)))) + (let ((finish + (lambda (data) + (set-buffer-point! buffer point) + (mark-temporary! point) + data))) + (let loop ((data data)) + (if (null? data) + (finish data) + (let ((element (car data)) + (data (cdr data))) + (if (eq? #f element) + ;; #F means boundary: this step is done. + (finish data) + (begin + (if (fix:fixnum? element) + ;; Fixnum is a point position. + (set-mark-index! point element) + (let ((a (car element)) + (b (cdr element))) + (cond ((eq? #t a) + ;; (#t . MOD-TIME) means first modification + (if (eqv? b (buffer-modification-time buffer)) + (buffer-not-modified! buffer))) + ((fix:fixnum? a) + ;; (START . END) means insertion + (if (or (fix:< a (group-start-index group)) + (fix:> a (group-end-index group)) + (fix:> b (group-end-index group))) + (outside-visible-range)) + (set-mark-index! point a) + (group-delete! group a b)) + ;; (STRING . START) means deletion + ((fix:< b 0) + ;; negative START means set point at end + (let ((b (fix:- 0 b))) + (if (or (fix:< b (group-start-index group)) + (fix:> b (group-end-index group))) + (outside-visible-range)) + (set-mark-index! point b) + (group-insert-string! group b a))) + (else + ;; nonnegative START means set point at start + (if (or (fix:< b (group-start-index group)) + (fix:> b (group-end-index group))) + (outside-visible-range)) + (group-insert-string! group b a) + (set-mark-index! point b))))) + (loop data))))))))) \ No newline at end of file diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 48613e598..42480e7d0 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.27 1992/02/04 04:04:34 cph Exp $ +;;; $Id: utils.scm,v 1.28 1993/01/09 01:16:25 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -46,21 +46,114 @@ (declare (usual-integrations)) -(define-integrable set-string-maximum-length! - (ucode-primitive set-string-maximum-length! 2)) +(define-macro (chars-to-words-shift) + ;; This is written as a macro so that the shift will be a constant + ;; in the compiled code. + (let ((chars-per-word (vector-ref ((ucode-primitive gc-space-status 0)) 0))) + (case chars-per-word + ((4) -2) + ((8) -3) + (else (error "Can't support this word size:" chars-per-word))))) + +(define (string-allocate n-chars) + (if (not (fix:fixnum? n-chars)) + (error:wrong-type-argument n-chars "fixnum" 'STRING-ALLOCATE)) + (if (not (fix:>= n-chars 0)) + (error:bad-range-argument n-chars 'STRING-ALLOCATE)) + (let ((n-words (fix:+ (fix:lsh n-chars (chars-to-words-shift)) 3))) + (if (not ((ucode-primitive heap-available? 1) n-words)) + (begin + (gc-flip) + (if (not ((ucode-primitive heap-available? 1) n-words)) + (error "Unable to allocate string of this length:" n-chars)))) + (let ((mask (set-interrupt-enables! interrupt-mask/none))) + (let ((result + ((ucode-primitive primitive-get-free 1) + (ucode-type string)))) + ((ucode-primitive primitive-object-set! 3) + result + 0 + ((ucode-primitive primitive-object-set-type 2) + (ucode-type manifest-nm-vector) + (fix:- n-words 1))) + (set-string-length! result n-chars) + ;; This won't work if range-checking is turned on. + (string-set! result (fix:+ n-chars 1) #\nul) + ((ucode-primitive primitive-increment-free 1) n-words) + (set-interrupt-enables! mask) + result)))) + +(define (set-string-maximum-length! string n-chars) + (if (not (string? string)) + (error:wrong-type-argument string "string" 'SET-STRING-MAXIMUM-LENGTH!)) + (if (not (fix:fixnum? n-chars)) + (error:wrong-type-argument n-chars "fixnum" 'SET-STRING-MAXIMUM-LENGTH!)) + (if (not (and (fix:>= n-chars 0) + (fix:< n-chars + (fix:lsh (fix:- (system-vector-length string) 1) + (fix:- 0 (chars-to-words-shift)))))) + (error:bad-range-argument n-chars 'SET-STRING-MAXIMUM-LENGTH!)) + (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + ((ucode-primitive primitive-object-set! 3) + string + 0 + ((ucode-primitive primitive-object-set-type 2) + (ucode-type manifest-nm-vector) + (fix:+ (fix:lsh n-chars (chars-to-words-shift)) 2))) + (set-string-length! string n-chars) + ;; This won't work if range-checking is turned on. + (string-set! string (fix:+ n-chars 1) #\nul) + (set-interrupt-enables! mask))) + +(define (%substring-move! source start-source end-source + target start-target) + (cond ((not (fix:< start-source end-source)) + unspecific) + ((not (eq? source target)) + (if (fix:< (fix:- end-source start-source) 32) + (do ((scan-source start-source (fix:+ scan-source 1)) + (scan-target start-target (fix:+ scan-target 1))) + ((fix:= scan-source end-source) unspecific) + (string-set! target + scan-target + (string-ref source scan-source))) + (substring-move-left! source start-source end-source + target start-target))) + ((fix:< start-source start-target) + (if (fix:< (fix:- end-source start-source) 32) + (do ((scan-source end-source (fix:- scan-source 1)) + (scan-target + (fix:+ start-target (fix:- end-source start-source)) + (fix:- scan-target 1))) + ((fix:= scan-source start-source) unspecific) + (string-set! source + (fix:- scan-target 1) + (string-ref source (fix:- scan-source 1)))) + (substring-move-right! source start-source end-source + source start-target))) + ((fix:< start-target start-source) + (if (fix:< (fix:- end-source start-source) 32) + (do ((scan-source start-source (fix:+ scan-source 1)) + (scan-target start-target (fix:+ scan-target 1))) + ((fix:= scan-source end-source) unspecific) + (string-set! source + scan-target + (string-ref source scan-source))) + (substring-move-left! source start-source end-source + source start-target))))) (define (string-append-char string char) (let ((size (string-length string))) - (let ((result (string-allocate (1+ size)))) - (substring-move-right! string 0 size result 0) + (let ((result (string-allocate (fix:+ size 1)))) + (%substring-move! string 0 size result 0) (string-set! result size char) result))) (define (string-append-substring string1 string2 start2 end2) (let ((length1 (string-length string1))) - (let ((result (string-allocate (+ length1 (- end2 start2))))) - (substring-move-right! string1 0 length1 result 0) - (substring-move-right! string2 start2 end2 result length1) + (let ((result (string-allocate (fix:+ length1 (fix:- end2 start2))))) + (%substring-move! string1 0 length1 result 0) + (%substring-move! string2 start2 end2 result length1) result))) (define (string-greatest-common-prefix strings) @@ -80,22 +173,7 @@ (cond ((string-null? x) y) ((string-null? y) x) (else (string-append x " " y)))) - -(define (list-of-type? object type) - (let loop ((object object)) - (if (null? object) - true - (and (pair? object) - (type (car object)) - (loop (cdr object)))))) - -(define (dotimes n procedure) - (define (loop i) - (if (< i n) - (begin (procedure i) - (loop (1+ i))))) - (loop 0)) - + (define char-set:null (char-set)) @@ -108,31 +186,6 @@ (define char-set:not-graphic (char-set-invert char-set:graphic)) -(define (read-line #!optional port) - (read-string char-set:return - (if (default-object? port) - (current-input-port) - (guarantee-input-port port)))) - -(define (y-or-n? . strings) - (define (loop) - (let ((char (char-upcase (read-char)))) - (cond ((or (char=? char #\Y) - (char=? char #\Space)) - (write-string "Yes") - true) - ((or (char=? char #\N) - (char=? char #\Rubout)) - (write-string "No") - false) - (else - (if (not (char=? char #\newline)) - (beep)) - (loop))))) - (newline) - (for-each write-string strings) - (loop)) - (define (char-controlify char) (if (ascii-controlified? char) char @@ -157,6 +210,31 @@ (define (char-base char) (make-char (char-code char) 0)) + +(define (read-line #!optional port) + (read-string char-set:return + (if (default-object? port) + (current-input-port) + (guarantee-input-port port)))) + +(define (y-or-n? . strings) + (define (loop) + (let ((char (char-upcase (read-char)))) + (cond ((or (char=? char #\Y) + (char=? char #\Space)) + (write-string "Yes") + true) + ((or (char=? char #\N) + (char=? char #\Rubout)) + (write-string "No") + false) + (else + (if (not (char=? char #\newline)) + (beep)) + (loop))))) + (newline) + (for-each write-string strings) + (loop)) (define (catch-file-errors if-error thunk) (call-with-protected-continuation @@ -175,4 +253,14 @@ (define (list-of-strings? object) (and (list? object) - (for-all? object string?))) \ No newline at end of file + (for-all? object string?))) + +(define list-of-type? + for-all?) + +(define (dotimes n procedure) + (define (loop i) + (if (< i n) + (begin (procedure i) + (loop (1+ i))))) + (loop 0)) \ No newline at end of file -- 2.25.1