From: Chris Hanson Date: Sun, 10 Jan 1993 10:54:43 +0000 (+0000) Subject: New code to grow and shrink buffers guarantees that the average time X-Git-Tag: 20090517-FFI~8611 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3c425f395751848014bb9d6849b87cfa98b20943;p=mit-scheme.git 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 58429dd73..7365e88a4 100644 --- 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*)))) - + (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)))) ;;;; Prefixes diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 18c4e148b..c43e11ec9 100644 --- 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 ae44131e4..0c66a61da 100644 --- 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)) - -(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)) ;;;; 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))) + +;;;; 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 f12adf8d5..d3a2a9093 100644 --- 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)