From 0257ee2e567a6a839dd26a3303ddbb8853d3b1dd Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 24 Jan 1992 23:02:58 +0000
Subject: [PATCH] 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.

---
 v7/src/edwin/edwin.pkg  |  3 ++-
 v7/src/edwin/grpops.scm | 23 +++++++++++++++++++++--
 2 files changed, 23 insertions(+), 3 deletions(-)

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index 413068d17..120d04e76 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.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 e1bb9f765..6e26bc3ae 100644
--- 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))))
-- 
2.25.1