;;; -*-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
(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)))
\f
(define-integrable (window-override-message window)
(buffer-window/override-message (frame-text-inferior window)))
;;; -*-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
;;; current-end-mark
;;; start-mark
;;; start-line-mark
-;;; start-changes-mark
-;;; end-changes-mark
;;; start-clip-mark
;;; end-clip-mark
;; 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.
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
(with-instance-variables buffer-window window (y)
(set! start-line-y y)))
\f
-(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))
(%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)
(%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!))
\f
;;;; Update
(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)))
\f
;;;; Window State
(%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))
(%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)
(%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)))
(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)
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)
(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))))
\f
;;;; Start Mark
(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)
(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))))
\f
(define (set-start-mark! window start-line y-start)
(if (fix:= y-start 0)
(%set-window-start-line-y! window 0))
\f
(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!
((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
((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.
(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))))
\f
;;;; Override Message
(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)
(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
(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))
\f
;;;; Update Finalization
(%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))
;;; -*-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
\f
;;;; 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))))))))
\f
;;;; Clip
(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))
(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)))
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))
\f
(define-integrable (preserve-nothing! window)
(regenerate-outlines window
(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
;;; 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)
(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))))
\f
(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
(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)))))
+\f
+(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
;;; -*-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
(%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))
;;; -*-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
((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
;;; -*-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
\f
(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))))))
#| -*-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
"autold"
"autosv"
"basic"
- "bochser"
- "bochsmod"
+ ;;"bochser"
+ ;;"bochsmod"
"bufcom"
"bufinp"
"bufmnu"
;;; -*-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
(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)))
#| -*-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
(files "grpops")
(parent (edwin))
(export (edwin)
- %group-insert-char!
- %group-insert-substring!
finish-group-insert!
gap-allocation-extra
group-copy-substring!
(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)
edwin-variable$rmail-primary-inbox-list
edwin-variable$rmail-reply-with-re
rmail-spool-directory))
-
+#|
(define-package (edwin bochser)
(files "bochser"
"bochsmod")
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
;;; -*-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
(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))))
\f
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
;;; -*-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
;;;; Group Operations
-(declare (usual-integrations))
+(declare (usual-integrations string-allocate))
\f
;;; These high-performance ops deal directly with groups and indices
;;; for speed and the least consing. Since indices are not in general
(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)
(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))
\f
(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)
(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)))))
(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)
(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))
\f
;;;; Deletions
(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)))
(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
;;; -*-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
;; 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
(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
(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)
;;; -*-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
(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))))))
\f
(syntax-table-define edwin-syntax-table 'DEFINE-COMMAND
(lambda (name description interactive procedure)
#| -*-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
"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
;;; -*-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
((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))
(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))
(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)))
\f
;;;; 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)
(define (line-end-index? group index)
(or (group-end-index? group index)
(char=? (group-right-char group index) #\newline)))
-\f
+
(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)))
(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)))))
+\f
;;;; Motion by Columns
(define (mark-column mark)
(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
;;; -*-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
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
(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))
(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))
(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))
(vector-set! group group-index:start-mark start)
(vector-set! group group-index:end-mark end)))
\f
-(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
(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
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)
;;; -*-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
(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!))))))))
\f
;;;; Horizontal Space
(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
;;; -*-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
;;; 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))
\f
-;;;; 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)
(set-group-undo-data! group outside-data)
(set! outside-data)
unspecific))))
-\f
-(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))
-\f
-(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)
-\f
-;;;; 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)))))
\f
-(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))))))
\f
-;;;; 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)))))
+\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!")))))
-\f
-(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)))
+\f
+(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
;;; -*-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
(declare (usual-integrations))
\f
-(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)))
+\f
+(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)
(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))
-
+\f
(define char-set:null
(char-set))
(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))))
-\f
-(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
(define (char-base char)
(make-char (char-code char) 0))
+\f
+(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
(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
projects / mit-scheme.git / commitdiff