New code to grow and shrink buffers guarantees that the average time

of inserting or deleting each character is bounded by a constant.  The
user is given some control over this behavior by means of the editor
variable BUFFER-REALLOCATION-FACTOR, which allows a space-time
tradeoff between the average insertion/deletion time and the average
load factor of the buffer.  BUFFER-REALLOCATION-FACTOR may be given a
local value in a given buffer to change that buffer's allocation
without affecting other buffers.

diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm
index 58429dd73bf308940cfe4333a6ecd0862c7b2646..7365e88a41711b9f9ae146dbe6e9ccae9f51bea8 100644 (file)
--- a/v7/src/edwin/basic.scm
+++ b/v7/src/edwin/basic.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: basic.scm,v 1.125 1992/10/17 23:28:06 jinx Exp $
+;;;    $Id: basic.scm,v 1.126 1993/01/10 10:54:41 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
@@ -97,7 +97,7 @@ With an argument, inserts several newlines."
     (let ((m* (mark-right-inserting (current-point))))
       (insert-newlines (or (command-argument-value argument) 1))
       (set-current-point! m*))))
-
+\f
 (define-command narrow-to-region
   "Restrict editing in current buffer to text between point and mark.
 Use \\[widen] to undo the effects of this command."
@@ -125,6 +125,21 @@ The key is bound in fundamental mode."
   (lambda (command key)
     (if (prompt-for-confirmation? "Go ahead")
        (define-key 'fundamental key (command-name command)))))
+
+(define-variable buffer-reallocation-factor
+  "Determines how much a buffer grows by when it needs to expand.
+This is a real number greater than one.  When a buffer is expanded,
+its size is multiplied by this factor until it is big enough.
+Similarly, when a buffer shrinks, its size is divided by this factor.
+
+Increasing this factor reduces the average time for insertion and
+deletion, but increases the average space used by the buffer.
+
+The minimum ratio between the number of characters in a buffer and the
+amount of space allocated to hold them is
+    (/ 1 (expt buffer-reallocation-factor 2))"
+  5/4
+  (lambda (object) (and (real? object) (> object 1))))
 \f
 ;;;; Prefixes
 

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 18c4e148b029eaf4f266b398838c4a329542c96c..c43e11ec90ac0365f8dad9d2d6b989a30dde8ea2 100644 (file)
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edwin.pkg,v 1.112 1993/01/09 10:33:57 cph Exp $
+$Id: edwin.pkg,v 1.113 1993/01/10 10:54:41 cph Exp $
 
 Copyright (c) 1989-1993 Massachusetts Institute of Technology
 
@@ -180,7 +180,6 @@ MIT in each case. |#
          group-insert-string!
          group-insert-substring!
          group-left-char
-         group-minimum-length
          group-right-char
          prepare-gap-for-insert!))
 

diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm
index ae44131e45dd3b320c71754a551c2e897e83a316..0c66a61da94bedfb5a9be172858611db6d4987d0 100644 (file)
--- a/v7/src/edwin/grpops.scm
+++ b/v7/src/edwin/grpops.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: grpops.scm,v 1.17 1993/01/09 01:16:11 cph Exp $
+;;;    $Id: grpops.scm,v 1.18 1993/01/10 10:54:42 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -52,14 +52,6 @@
 ;;; limited ways.  To save an index across a modification, it must be
 ;;; consed into a permanent mark.
 
-;;; This parameter controls how much extra space (in characters) is
-;;; allocated when the gap is too small to contain a given insertion.
-(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-integrable gap-maximum-extra 20000)
-
 ;;;; Extractions
 
 (define (group-extract-string group start end)
@@ -119,11 +111,6 @@
 
 (define (group-insert-char! group index char)
   (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))
-    (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)
@@ -135,27 +122,21 @@
 
 (define (group-insert-substring! group index string 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))
     (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))
+
+(define (prepare-gap-for-insert! group new-start n)
+  (if (group-read-only? group)
+      (barf-if-read-only))
+  (if (not (group-modified? group))
+      (check-first-group-modification group))
+  (cond ((fix:< (group-gap-length group) n)
+        (grow-group! group new-start n))
+       ((fix:< new-start (group-gap-start group))
         (let ((new-end (fix:+ new-start (group-gap-length group))))
           (%substring-move! (group-text group)
                             new-start
@@ -172,25 +153,9 @@
                             (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))
-                   gap-allocation-extra))
-           (text (group-text group))
-           (start (group-gap-start group))
-           (end (group-gap-end group))
-           (length (group-gap-length group)))
-       (let ((end* (string-length text)))
-         (let ((text* (string-allocate (fix:+ end* n)))
-               (new-end (fix:+ end n)))
-           (%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)))))
+          (vector-set! group group-index:gap-end new-end)))))
 
-(define-integrable (finish-group-insert! group index n)
+(define (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)
@@ -216,6 +181,7 @@
   (vector-set! group group-index:modified-tick
               (fix:+ (group-modified-tick group) 1))
   ;; The MODIFIED? bit must be set *after* the undo recording.
+  (undo-record-insertion! group index (fix:+ index n))
   (set-group-modified! group true))
 \f
 ;;;; Deletions
@@ -233,21 +199,33 @@
            (barf-if-read-only))
        (if (not (group-modified? group))
            (check-first-group-modification group))
-       ;; 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 ((text (group-text group))
+             (gap-length (group-gap-length group)))
+         ;; 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! text
+                                  (group-gap-end group)
+                                  (fix:+ start gap-length)
+                                  text
+                                  (group-gap-start group)))
+               ((fix:> (group-gap-start group) end)
+                (%substring-move! text
+                                  end
+                                  (group-gap-start group)
+                                  text
+                                  (fix:+ end gap-length))))
+         ;; The undo recording must occur *before* the deletion.
+         (undo-record-deletion! group start end)
+         (let ((gap-end (fix:+ end gap-length)))
+           (vector-set! group group-index:gap-start start)
+           (vector-set! group group-index:gap-end gap-end)
+           (vector-set! group group-index:gap-length (fix:- gap-end start))
+           (if (and (group-shrink-length group)
+                    (fix:<= (fix:- (string-length text)
+                                   (fix:- gap-end start))
+                            (group-shrink-length group)))
+               (shrink-group! group))))
        (let ((n (fix:- end start)))
          (if (group-start-changes-index group)
              (begin
@@ -276,22 +254,85 @@
                     (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! 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)
-       unspecific)))
\ No newline at end of file
+       unspecific)))
+\f
+;;;; Resizing
+
+(define (grow-group! group new-gap-start n)
+  (let ((text (group-text group))
+       (gap-start (group-gap-start group))
+       (gap-end (group-gap-end group))
+       (reallocation-factor (group-reallocation-factor group)))
+    (let ((text-length (string-length text))
+         (gap-delta (- new-gap-start gap-start)))
+      (let ((n-chars (- text-length (group-gap-length group))))
+       (let ((new-text-length
+              (let ((minimum-text-length (+ n-chars n)))
+                (let loop ((length (if (= text-length 0) 1 text-length)))
+                  (let ((length (ceiling (* length reallocation-factor))))
+                    (if (< length minimum-text-length)
+                        (loop length)
+                        length))))))
+         (let ((new-text (string-allocate new-text-length))
+               (new-gap-length (- new-text-length n-chars)))
+           (let ((new-gap-end (+ new-gap-start new-gap-length)))
+             (cond ((= gap-delta 0)
+                    (%substring-move! text 0 gap-start new-text 0)
+                    (%substring-move! text gap-end text-length
+                                      new-text new-gap-end))
+                   ((< gap-delta 0)
+                    (%substring-move! text 0 new-gap-start new-text 0)
+                    (%substring-move! text new-gap-start gap-start
+                                      new-text new-gap-end)
+                    (%substring-move! text gap-end text-length
+                                      new-text (- new-gap-end gap-delta)))
+                   (else
+                    (let ((ngsp (+ gap-end gap-delta)))
+                      (%substring-move! text 0 gap-start new-text 0)
+                      (%substring-move! text gap-end ngsp new-text gap-start)
+                      (%substring-move! text ngsp text-length
+                                        new-text new-gap-end))))
+             (vector-set! group group-index:text new-text)
+             (vector-set! group group-index:gap-start new-gap-start)
+             (vector-set! group group-index:gap-end new-gap-end)
+             (vector-set! group group-index:gap-length new-gap-length))))))
+    (memoize-shrink-length! group reallocation-factor)))
+
+(define (shrink-group! group)
+  (let ((text (group-text group))
+       (gap-length (group-gap-length group))
+       (reallocation-factor (group-reallocation-factor group)))
+    (let ((text-length (string-length text)))
+      (let ((n-chars (- text-length gap-length)))
+       (let ((new-text-length
+              (if (= n-chars 0)
+                  0
+                  (let loop ((length text-length))
+                    (let ((length (floor (/ length reallocation-factor))))
+                      (let ((sl
+                             (compute-shrink-length length
+                                                    reallocation-factor)))
+                        (if (< sl n-chars)
+                            length
+                            (loop length)))))))
+             (gap-end (group-gap-end group)))
+         (let ((delta (- text-length new-text-length)))
+           (let ((new-gap-end (- gap-end delta)))
+             (%substring-move! text gap-end text-length text new-gap-end)
+             (vector-set! group group-index:gap-end new-gap-end)
+             (vector-set! group group-index:gap-length (- gap-length delta))))
+         (set-string-maximum-length! text new-text-length))))
+    (memoize-shrink-length! group reallocation-factor)))
+
+(define (memoize-shrink-length! group reallocation-factor)
+  (vector-set! group group-index:shrink-length
+              (compute-shrink-length (string-length (group-text group))
+                                     reallocation-factor)))
+
+(define (compute-shrink-length length reallocation-factor)
+  (floor (/ (floor (/ length reallocation-factor)) reallocation-factor)))
+
+(define (group-reallocation-factor group)
+  ;; We assume the result satisfies (LAMBDA (G) (AND (REAL? G) (> G 1)))
+  (inexact->exact (ref-variable buffer-reallocation-factor group)))
\ No newline at end of file

diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm
index f12adf8d59c81506e1a75f3093e9624b5ab1f258..d3a2a909326332d15a56f1443262323b1e672581 100644 (file)
--- a/v7/src/edwin/struct.scm
+++ b/v7/src/edwin/struct.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: struct.scm,v 1.84 1993/01/09 20:38:24 cph Exp $
+;;;    $Id: struct.scm,v 1.85 1993/01/10 10:54:43 cph Exp $
 ;;;
 ;;;    Copyright (c) 1985, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -110,12 +110,11 @@
   shrink-length)
 
 (define (make-group buffer)
-  (let ((group (%make-group))
-       (length group-minimum-length))
-    (vector-set! group group-index:text (string-allocate length))
+  (let ((group (%make-group)))
+    (vector-set! group group-index:text (string-allocate 0))
     (vector-set! group group-index:gap-start 0)
-    (vector-set! group group-index:gap-length length)
-    (vector-set! group group-index:gap-end length)
+    (vector-set! group group-index:gap-length 0)
+    (vector-set! group group-index:gap-end 0)
     (vector-set! group group-index:marks '())
     (let ((start (make-permanent-mark group 0 false)))
       (vector-set! group group-index:start-mark start)
@@ -132,7 +131,7 @@
     (vector-set! group group-index:modified? false)
     (vector-set! group group-index:point (make-permanent-mark group 0 true))
     (vector-set! group group-index:buffer buffer)
-    (vector-set! group group-index:shrink-length false)
+    (vector-set! group group-index:shrink-length 0)
     group))
 
 (define (group-length group)