From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 1 Apr 2017 05:17:20 +0000 (-0700)
Subject: Add 'copy? option to string-builder.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~59
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e330b4ef1596d26d02f66ae687df9b769d251b5d;p=mit-scheme.git

Add 'copy? option to string-builder.
---

diff --git a/src/runtime/bytevector.scm b/src/runtime/bytevector.scm
index 939e52438..3332a62eb 100644
--- a/src/runtime/bytevector.scm
+++ b/src/runtime/bytevector.scm
@@ -122,6 +122,7 @@ USA.
 				bytevector-length
 				bytevector-u8-ref
 				bytevector-u8-set!
+				(lambda (bv) bv)
 				16
 				bytevector-builder:finish-build)))
     (lambda (#!optional object)
diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index bf8adf72e..1ab2a8357 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -581,7 +581,8 @@ USA.
 ;;;; Builder for vector-like sequences
 
 (define (make-sequence-builder make-sequence sequence-length sequence-ref
-			       sequence-set! buffer-length finish-build)
+			       sequence-set! sequence-copy buffer-length
+			       finish-build)
     ;; This is optimized to minimize copying, so it wastes some space.
   (let ((buffers)
 	(buffer)
@@ -624,7 +625,9 @@ USA.
 	    (begin
 	      (if (fix:> index 0)
 		  (new-buffer!))
-	      (set! buffers (cons (cons sequence length) buffers))
+	      (set! buffers
+		    (cons (cons (sequence-copy sequence) length)
+			  buffers))
 	      unspecific))))
 
     (define (build)
diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm
index 27d00f90d..42cc1fd7b 100644
--- a/src/runtime/stringio.scm
+++ b/src/runtime/stringio.scm
@@ -183,7 +183,8 @@ USA.
       (with-output-to-port port thunk))))
 
 (define (open-output-string)
-  (make-textual-port string-output-type (make-ostate (string-builder) 0)))
+  (make-textual-port string-output-type
+		     (make-ostate (string-builder 'copy? #t) 0)))
 
 (define-structure ostate
   (builder #f read-only #t)
@@ -208,7 +209,7 @@ USA.
 (define (string-out/write-substring port string start end)
   (let ((os (textual-port-state port))
 	(n (fix:- end start)))
-    ((ostate-builder os) (string-copy string start end))
+    ((ostate-builder os) (string-slice string start end))
     (update-column-for-substring! os string start end)
     n))
 
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 6a235e6b9..0aa76852f 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -226,7 +226,7 @@ USA.
 	      (else (error "Not a char or string:" object)))))))
 
 (define (make-string-builder options)
-  (receive (buffer-length ->nfc?)
+  (receive (buffer-length ->nfc? copy?)
       (string-builder-options options 'string-builder)
     (let ((tracker (max-cp-tracker)))
       (combine-tracker-and-builder
@@ -235,13 +235,15 @@ USA.
 			      string-length
 			      string-ref
 			      string-set!
+			      (if copy? string-copy (lambda (s) s))
 			      buffer-length
 			      (string-builder-finish ->nfc? (tracker 'get)))))))
 
 (define-deferred string-builder-options
   (keyword-option-parser
    (list (list 'buffer-length positive-fixnum? 16)
-	 (list '->nfc? boolean? #t))))
+	 (list '->nfc? boolean? #t)
+	 (list 'copy? boolean? #f))))
 
 (define (max-cp-tracker)
   (let ((max-cp 0))