Add new procedure GROUP-COPY-SUBSTRING!. This copies part of a

buffer into a pre-allocated string.  This is like
GROUP-EXTRACT-STRING except that the latter also allocates the string.

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 413068d175fa61c8f29d72ee2c9585d41ed9f2ed..120d04e765dbc0fd218d504f97236cfd2d002aac 100644 (file)
--- 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.72 1992/01/10 18:54:57 bal Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.73 1992/01/24 23:02:58 cph Exp $
 
 Copyright (c) 1989-92 Massachusetts Institute of Technology
 
@@ -158,6 +158,7 @@ MIT in each case. |#
          %group-insert-char!
          %group-insert-substring!
          gap-allocation-extra
+         group-copy-substring!
          group-delete!
          group-delete-left-char!
          group-delete-right-char!

diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm
index e1bb9f76531fa4bb8d0f4ad4ecd95cad46354ffc..6e26bc3ae805006e830b06cbace43582732e1e14 100644 (file)
--- a/v7/src/edwin/grpops.scm
+++ b/v7/src/edwin/grpops.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.14 1991/05/16 21:20:53 cph Exp $
+;;;    $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 $
 ;;;
-;;;    Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
+;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -83,6 +83,25 @@
                                  (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*))
+         ((fix:>= start gap-start)
+          (substring-move-right! 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)))))))
+
 (define (group-left-char group index)
   (string-ref (group-text group)
              (fix:-1+ (group-index->position-integrable group index false))))