From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 4 Apr 1992 13:07:09 +0000 (+0000)
Subject: Considerable tuning of the group insert/delete operations.
X-Git-Tag: 20090517-FFI~9522
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6e7b4c414b065b50cbe78e7582fdf3ad4047d10a;p=mit-scheme.git

Considerable tuning of the group insert/delete operations.

* Eliminate buffer-modification-daemon; change group insert/delete
  operations to set the GROUP-MODIFIED? flag directly, and change the
  auto-save code to work around that flag.  Now, buffers that are not
  visible have no insert or delete daemons, and the group
  insert/delete operations notice this to eliminate a procedure call.

* The editor now has a GC daemon that cleans the marks list of every
  known buffer.  The allows FOR-EACH-MARK to be inline-coded in the
  group insert/delete operations.

* Eliminate bug in GROUP-DELETE!: when the gap exceeded
  GAP-MAXIMUM-EXTRA, it was being reduced to GAP-MAXIMUM-EXTRA.  Thus
  a series of deletions would cause the gap to reach that size, then
  each subsequent deletion in the series would pay for a gap
  reduction, which can be thousands (or even millions) of
  instructions, depending on the size of the buffer.  Now when the gap
  reaches maximum size, it is reduced to GAP-ALLOCATION-EXTRA,
  allowing the gap reduction to be amortized over many deletions.
---

diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm
index 743de22cf..94736e7d8 100644
--- a/v7/src/edwin/buffer.scm
+++ b/v7/src/edwin/buffer.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.152 1992/02/10 21:57:09 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.153 1992/04/04 13:07:05 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -62,7 +62,7 @@
   local-bindings-installed?
   initializations
   auto-save-pathname
-  auto-save-state
+  auto-saved?
   save-length
   backed-up?
   modification-time
@@ -85,9 +85,6 @@ The buffer is guaranteed to be deselected at that time."
     (let ((group (make-group (string-copy "") buffer)))
       (vector-set! buffer buffer-index:name name)
       (vector-set! buffer buffer-index:group group)
-      (let ((daemon (buffer-modification-daemon buffer)))
-	(add-group-insert-daemon! group daemon)
-	(add-group-delete-daemon! group daemon))
       (add-group-clip-daemon! group (buffer-clip-daemon buffer))
       (if (not (minibuffer? buffer))
 	  (enable-group-undo! group))
@@ -109,7 +106,7 @@ The buffer is guaranteed to be deselected at that time."
 		   buffer-index:initializations
 		   (list (mode-initialization mode)))
       (vector-set! buffer buffer-index:auto-save-pathname false)
-      (set-buffer-auto-save-state! buffer 'NO-CHANGES)
+      (vector-set! buffer buffer-index:auto-saved? false)
       (vector-set! buffer buffer-index:save-length 0)
       (vector-set! buffer buffer-index:backed-up? false)
       (vector-set! buffer buffer-index:modification-time false)
@@ -138,7 +135,7 @@ The buffer is guaranteed to be deselected at that time."
      (vector-set! buffer buffer-index:truename false)
      (buffer-modeline-event! buffer 'BUFFER-PATHNAME)
      (vector-set! buffer buffer-index:auto-save-pathname false)
-     (set-buffer-auto-save-state! buffer 'NO-CHANGES)
+     (vector-set! buffer buffer-index:auto-saved? false)
      (vector-set! buffer buffer-index:save-length 0))))
 
 (define (set-buffer-name! buffer name)
@@ -163,9 +160,6 @@ The buffer is guaranteed to be deselected at that time."
 (define-integrable (set-buffer-auto-save-pathname! buffer pathname)
   (vector-set! buffer buffer-index:auto-save-pathname pathname))
 
-(define-integrable (set-buffer-auto-save-state! buffer state)
-  (vector-set! buffer buffer-index:auto-save-state state))
-
 (define-integrable (set-buffer-save-length! buffer)
   (vector-set! buffer buffer-index:save-length (buffer-length buffer)))
 
@@ -291,34 +285,23 @@ The buffer is guaranteed to be deselected at that time."
 	   (begin
 	     (set-group-modified! group false)
 	     (buffer-modeline-event! buffer 'BUFFER-MODIFIED)
-	     (set-buffer-auto-save-state! buffer 'NO-CHANGES)))))))
+	     (vector-set! buffer buffer-index:auto-saved? false)))))))
 
 (define (buffer-modified! buffer)
   (without-interrupts
    (lambda ()
-     (%buffer-modified! buffer (buffer-group buffer)))))
-
-(define (buffer-modification-daemon buffer)
-  (lambda (group start end)
-    start end				;ignore
-    (%buffer-modified! buffer group)))
-
-(define-integrable (%buffer-modified! buffer group)
-  (cond ((not (group-modified? group))
-	 (set-group-modified! group true)
-	 (buffer-modeline-event! buffer 'BUFFER-MODIFIED)
-	 (set-buffer-auto-save-state! buffer 'UNSAVED-CHANGES))
-	((eq? 'AUTO-SAVED (buffer-auto-save-state buffer))
-	 (set-buffer-auto-save-state! buffer 'AUTO-SAVED+CHANGES))))
+     (let ((group (buffer-group buffer)))
+       (if (not (group-modified? group))
+	   (begin
+	     (set-group-modified! group true)
+	     (buffer-modeline-event! buffer 'BUFFER-MODIFIED)))))))
 
-(define-integrable (set-buffer-auto-saved! buffer)
-  (set-buffer-auto-save-state! buffer 'AUTO-SAVED))
+(define (set-buffer-auto-saved! buffer)
+  (vector-set! buffer buffer-index:auto-saved? true)
+  (set-group-modified! (buffer-group buffer) 'AUTO-SAVED))
 
 (define-integrable (buffer-auto-save-modified? buffer)
-  (memq (buffer-auto-save-state buffer) '(UNSAVED-CHANGES AUTO-SAVED+CHANGES)))
-
-(define-integrable (buffer-auto-saved? buffer)
-  (memq (buffer-auto-save-state buffer) '(AUTO-SAVED AUTO-SAVED+CHANGES)))
+  (eq? true (group-modified? (buffer-group buffer))))
 
 (define (buffer-clip-daemon buffer)
   (lambda (group start end)
diff --git a/v7/src/edwin/debuge.scm b/v7/src/edwin/debuge.scm
index 7e9116131..5c56cb3f2 100644
--- a/v7/src/edwin/debuge.scm
+++ b/v7/src/edwin/debuge.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.44 1992/01/13 19:15:42 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.45 1992/04/04 13:07:06 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -105,15 +105,6 @@
 		(receiver n-existing (1+ n-gced)))))
 	(receiver 0 0))))
 
-(define-command debug-clean-marks
-  "Perform a GC, then remove GC'ed marks from all buffers."
-  ()
-  (lambda ()
-    (gc-flip)
-    ((ref-command debug-count-marks))
-    (for-each (lambda (buffer) (clean-group-marks! (buffer-group buffer)))
-	      (buffer-list))))
-
 (define-command debug-show-standard-marks
   ""
   ()
diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm
index 12fa8956f..9c23ab050 100644
--- a/v7/src/edwin/editor.scm
+++ b/v7/src/edwin/editor.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.218 1992/03/13 10:08:11 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.219 1992/04/04 13:07:07 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -240,6 +240,16 @@ with the contents of the startup message."
 
 (define recursive-edit-continuation)
 (define recursive-edit-level)
+
+(define (editor-gc-daemon)
+  (let ((editor edwin-editor))
+    (if editor
+	(do ((buffers (bufferset-buffer-list (editor-bufferset editor))
+		      (cdr buffers)))
+	    ((null? buffers))
+	  (clean-group-marks! (buffer-group (car buffers)))))))
+
+(add-gc-daemon! editor-gc-daemon)
 
 (define (internal-error-handler condition)
   (cond (debug-internal-errors?
diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 6b23a2e8f..41db2686a 100644
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.82 1992/03/26 00:02:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.83 1992/04/04 13:07:07 cph Exp $
 
 Copyright (c) 1989-92 Massachusetts Institute of Technology
 
@@ -159,6 +159,7 @@ MIT in each case. |#
   (export (edwin)
 	  %group-insert-char!
 	  %group-insert-substring!
+	  finish-group-insert!
 	  gap-allocation-extra
 	  group-copy-substring!
 	  group-delete!
@@ -171,8 +172,7 @@ MIT in each case. |#
 	  group-insert-substring!
 	  group-left-char
 	  group-right-char
-	  guarantee-gap-length!
-	  move-gap-to!))
+	  prepare-gap-for-insert!))
 
 (define-package (edwin comtab)
   (files "comtab")
@@ -739,9 +739,7 @@ MIT in each case. |#
 	  stack-frame/compiled-code?
 	  write-restarts)
   (import (runtime error-handler)
-	  hook/invoke-restart)
-  (import (runtime unparser)
-	  *unparse-primitives-by-name?*))
+	  hook/invoke-restart))
 
 (define-package (edwin dired)
   (files "dired")
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index b17ab6bc1..ed932bf42 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.106 1992/02/04 04:03:02 cph Exp $
+;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.107 1992/04/04 13:07:08 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -125,25 +125,14 @@ Each procedure is called with three arguments:
     (let ((length (file-length channel)))
       (without-interrupts
        (lambda ()
-	 (move-gap-to! group index)
-	 (guarantee-gap-length! group length)))
+	 (prepare-gap-for-insert! group index length)))
       (let ((n
 	     (channel-read channel (group-text group) index (+ index length))))
 	(without-interrupts
 	 (lambda ()
 	   (let ((gap-start* (fix:+ index n)))
 	     (undo-record-insertion! group index gap-start*)
-	     (vector-set! group
-			  group-index:gap-length
-			  (fix:- (group-gap-length group) n))
-	     (vector-set! group group-index:gap-start gap-start*)
-	     (for-each-mark group
-	       (lambda (mark)
-		 (let ((index* (mark-index mark)))
-		   (if (or (fix:> index* index)
-			   (and (fix:= index* index)
-				(mark-left-inserting? mark)))
-		       (set-mark-index! mark (fix:+ index* n))))))
+	     (finish-group-insert! group index n)
 	     (record-insertion! group index gap-start*))))
 	(channel-close channel)
 	n))))
diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm
index 6e26bc3ae..98d5b7b95 100644
--- a/v7/src/edwin/grpops.scm
+++ b/v7/src/edwin/grpops.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.15 1992/01/24 23:02:29 cph Exp $
+;;;	$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 $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -54,11 +54,11 @@
 
 ;;; This parameter controls how much extra space (in characters) is
 ;;; allocated when the gap is too small to contain a given insertion.
-(define gap-allocation-extra 2000)
+(define-integrable gap-allocation-extra 2000)
 
 ;;; This parameter controls how large the gap is allowed to be between
 ;;; operations.  It must be at least `gap-allocation-extra'.
-(define gap-maximum-extra 20000)
+(define-integrable gap-maximum-extra 20000)
 
 ;;;; Extractions
 
@@ -104,7 +104,7 @@
 
 (define (group-left-char group index)
   (string-ref (group-text group)
-	      (fix:-1+ (group-index->position-integrable group index false))))
+	      (fix:- (group-index->position-integrable group index false) 1)))
 
 (define (group-right-char group index)
   (string-ref (group-text group)
@@ -118,136 +118,68 @@
 ;;;; Insertions
 
 (define (group-insert-char! group index char)
-  (without-interrupts
-   (lambda ()
-     (%group-insert-char! group index char)
-     (record-insertion! group index (group-gap-start group)))))
+  (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-integrable (%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))
-  (move-gap-to! group index)
-  (guarantee-gap-length! group 1)
-  (let ((gap-start* (fix:1+ index)))
-    (undo-record-insertion! group index gap-start*)
-    (vector-set! group group-index:gap-start gap-start*))
-  (vector-set! group group-index:gap-length (fix:-1+ (group-gap-length group)))
+(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)
-  (for-each-mark group
-    (lambda (mark)
-      (let ((index* (mark-index mark)))
-	(if (or (fix:> index* index)
-		(and (fix:= index* index)
-		     (mark-left-inserting? mark)))
-	    (set-mark-index! mark (fix:+ index* 1)))))))
+  (finish-group-insert! group index 1))
 
 (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)
-  (without-interrupts
-   (lambda ()
-     (%group-insert-substring! group index string start end)
-     (record-insertion! group index (group-gap-start group)))))
+  (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-integrable (%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))
-  (move-gap-to! group index)
+(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)))
-    (guarantee-gap-length! group n)
-    (let ((gap-start* (fix:+ index n)))
-      (undo-record-insertion! group index gap-start*)
-      (vector-set! group group-index:gap-start gap-start*))
-    (vector-set! group
-		 group-index:gap-length
-		 (fix:- (group-gap-length group) n))
+    (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)
-    (for-each-mark group
-      (lambda (mark)
-	(let ((index* (mark-index mark)))
-	  (if (or (fix:> index* index)
-		  (and (fix:= index* index)
-		       (mark-left-inserting? mark)))
-	      (set-mark-index! mark (fix:+ index* n))))))))
+    (finish-group-insert! group index n)))
 
-;;;; Deletions
-
-(define (group-delete-left-char! group index)
-  (group-delete! group (fix:-1+ index) index))
-
-(define (group-delete-right-char! group index)
-  (group-delete! group index (fix:1+ index)))
-
-(define (group-delete! group start end)
-  (without-interrupts
-   (lambda ()
-     (if (not (fix:= start end))
-	 (begin
-	   (if (group-read-only? group) (barf-if-read-only))
-	   (if (not (group-modified? group))
-	       (check-first-group-modification group))
-	   ;; Guarantee that the gap is between START and END.
-	   (let ((gap-start (group-gap-start group)))
-	     (cond ((fix:< gap-start start) (move-gap-to-right! group start))
-		   ((fix:> gap-start end) (move-gap-to-left! group end))))
-	   (undo-record-deletion! group start end)
-	   (record-deletion! group start end)
-	   (let ((length (fix:- end start)))
-	     (for-each-mark group
-	       (lambda (mark)
-		 (let ((index (mark-index mark)))
-		   (cond ((fix:> index end)
-			  (set-mark-index! mark (fix:- index length)))
-			 ((fix:>= index start)
-			  (set-mark-index! mark start)))))))
-	   (vector-set! group group-index:gap-start start)
-	   (let ((gap-end (fix:+ end (group-gap-length group)))
-		 (max-gap-length gap-maximum-extra))
-	     (if (fix:> (fix:- gap-end start) max-gap-length)
-		 (let* ((new-gap-end (fix:+ start max-gap-length))
-			(text (group-text group))
-			(text-end (string-length text))
-			(new-text-end
-			 (fix:- text-end
-				(fix:- (fix:- gap-end start) max-gap-length))))
-		   (substring-move-left! text gap-end text-end
-					 text new-gap-end)
-		   (set-string-maximum-length! text new-text-end)
-		   (vector-set! group group-index:gap-end new-gap-end)
-		   (vector-set! group group-index:gap-length max-gap-length))
-		 (begin
-		   (vector-set! group group-index:gap-end gap-end)
-		   (vector-set! group group-index:gap-length
-				(fix:- gap-end start))))))))))
-
-;;;; The Gap
-
-(define (move-gap-to! group index)
-  (let ((gap-start (group-gap-start group)))
-    (cond ((fix:< index gap-start) (move-gap-to-left! group index))
-	  ((fix:> index gap-start) (move-gap-to-right! group index)))))
-
-(define (move-gap-to-left! group new-start)
-  (let ((start (group-gap-start group))
-	(length (group-gap-length group))
-	(text (group-text group)))
-    (let ((new-end (fix:+ new-start length)))
-      (substring-move-right! text new-start start text new-end)
-      (vector-set! group group-index:gap-start new-start)
-      (vector-set! group group-index:gap-end new-end))))
-
-(define (move-gap-to-right! group new-start)
-  (let ((start (group-gap-start group))
-	(end (group-gap-end group))
-	(length (group-gap-length group))
-	(text (group-text group)))
-    (let ((new-end (fix:+ new-start length)))
-      (substring-move-left! text end new-end text start)
-      (vector-set! group group-index:gap-start new-start)
-      (vector-set! group group-index:gap-end new-end))))
-
-(define (guarantee-gap-length! group n)
+(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)
+	   (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))
+	   (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 ((n
 	     (fix:+ (fix:- n (group-gap-length group))
@@ -263,4 +195,89 @@
 	    (substring-move-right! 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)))))
\ No newline at end of file
+	(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))
+  (do ((marks (group-marks group) (system-pair-cdr marks)))
+      ((null? marks))
+    (if (and (system-pair-car marks)
+	     (or (fix:> (mark-index (system-pair-car marks)) index)
+		 (and (fix:= (mark-index (system-pair-car marks)) index)
+		      (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.
+  (set-group-modified! group true))
+
+;;;; Deletions
+
+(define (group-delete-left-char! group index)
+  (group-delete! group (fix:- index 1) index))
+
+(define (group-delete-right-char! group index)
+  (group-delete! group index (fix:+ index 1)))
+
+(define (group-delete! group start end)
+  (if (not (fix:= start end))
+      (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+	(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-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)))
+	  (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))
+		   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)))))))
+	(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)
+		(set-string-maximum-length! text
+					    (fix:+ new-gap-end
+						   (fix:- text-end gap-end)))
+		(vector-set! group group-index:gap-end new-gap-end)
+		(vector-set! group group-index:gap-length
+			     gap-allocation-extra))
+	      (begin
+		(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