From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 21 Feb 2017 03:35:34 +0000 (-0800)
Subject: Generalize string-builder to be useful for other sequences.
X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~51
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=451ed5896af742d391c3f867aa1ace606fb1aed8;p=mit-scheme.git

Generalize string-builder to be useful for other sequences.
---

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index 1e32ddf14..2a6582e95 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -585,6 +585,63 @@ USA.
 	((get-if-available) get)
 	(else (error "Unknown operator:" operator))))))
 
+;;;; Builder for vector-like sequences
+
+(define (make-sequence-builder make-buffer sequence-length sequence-set!
+			       finish-build)
+    ;; This is optimized to minimize copying, so it wastes some space.
+  (let ((buffers)
+	(buffer)
+	(index))
+
+    (define (reset!)
+      (set! buffers '())
+      (set! buffer (make-buffer))
+      (set! index 0)
+      unspecific)
+
+    (define (new-buffer!)
+      (set! buffers (cons (cons buffer index) buffers))
+      (set! buffer (make-buffer))
+      (set! index 0)
+      unspecific)
+
+    (define (empty?)
+      (and (fix:= 0 index)
+	   (null? buffers)))
+
+    (define (count)
+      (do ((buffers buffers (cdr buffers))
+	   (n 0 (fix:+ n (cdr (car buffers)))))
+	  ((not (pair? buffers)) (fix:+ n index))))
+
+    (define (append-element! element)
+      (if (not (fix:< index (sequence-length buffer)))
+	  (new-buffer!))
+      (sequence-set! buffer index element)
+      (set! index (fix:+ index 1))
+      unspecific)
+
+    (define (append-sequence! sequence)
+      (if (fix:> index 0)
+	  (new-buffer!))
+      (set! buffers (cons (cons sequence (sequence-length sequence)) buffers))
+      unspecific)
+
+    (define (build)
+      (finish-build (reverse (cons (cons buffer index) buffers))))
+
+    (reset!)
+    (lambda (operator)
+      (case operator
+	((append-element!) append-element!)
+	((append-sequence!) append-sequence!)
+	((build) build)
+	((empty?) empty?)
+	((count) count)
+	((reset!) reset!)
+	(else (error "Unknown operator:" operator))))))
+
 ;;;; Ephemerons
 
 ;;; The layout of an ephemeron is as follows:
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 61c957d93..a91129471 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -516,6 +516,7 @@ USA.
 	  make-hashed-metadata-table
 	  make-hook-list
 	  make-non-pointer-object
+	  make-sequence-builder
 	  non-pointer-type-code?
 	  null-procedure
 	  obarray->list
diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index 507480970..81263b0be 100644
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -212,70 +212,34 @@ USA.
 		       (fix:- end start))))))
 
 (define (string-builder)
-  ;; This is optimized to minimize copying, so it wastes some space.
-  (let ((buffer-size 16))
-    (let ((buffers)
-	  (buffer)
-	  (index))
-
-      (define (reset!)
-	(set! buffers '())
-	(set! buffer (full-string-allocate buffer-size))
-	(set! index 0)
-	unspecific)
-
-      (define (new-buffer!)
-	(set! buffers (cons (string-slice buffer 0 index) buffers))
-	(set! buffer (full-string-allocate buffer-size))
-	(set! index 0)
-	unspecific)
-
-      (define (empty?)
-	(and (fix:= 0 index)
-	     (null? buffers)))
-
-      (define (count)
-	(do ((buffers buffers (cdr buffers))
-	     (n 0 (fix:+ n (string-length (car buffers)))))
-	    ((not (pair? buffers)) (fix:+ n index))))
-
-      (define (append-char! char)
-	(if (not (fix:< index buffer-size))
-	    (new-buffer!))
-	(string-set! buffer index char)
-	(set! index (fix:+ index 1))
-	unspecific)
-
-      (define (append-string! string)
-	(if (fix:> index 0)
-	    (new-buffer!))
-	(set! buffers (cons string buffers))
-	unspecific)
-
-      (define (build)
-	(let ((strings (reverse (cons (string-slice buffer 0 index) buffers))))
-	  (let ((result
-		 (do ((strings strings (cdr strings))
-		      (n 0 (fix:+ n (string-length (car strings))))
-		      (8-bit? #t (and 8-bit? (string-8-bit? (car strings)))))
-		     ((not (pair? strings))
-		      (if 8-bit?
-			  (legacy-string-allocate n)
-			  (full-string-allocate n))))))
-	    (do ((strings strings (cdr strings))
-		 (i 0 (string-copy! result i (car strings))))
-		((not (pair? strings))))
-	    result)))
-
-      (reset!)
-      (lambda (#!optional object)
-	(cond ((default-object? object) (build))
-	      ((bitless-char? object) (append-char! object))
-	      ((string? object) (append-string! object))
-	      ((eq? 'empty? object) (empty?))
-	      ((eq? 'count object) (count))
-	      ((eq? 'reset! object) (reset!))
-	      (else (error "Not a char or string:" object)))))))
+  (let ((builder
+	 (make-sequence-builder (lambda () (full-string-allocate 16))
+				string-length
+				string-set!
+				string-builder:finish-build)))
+    (lambda (#!optional object)
+      (cond ((default-object? object) ((builder 'build)))
+	    ((bitless-char? object) ((builder 'append-element!) object))
+	    ((string? object) ((builder 'append-sequence!) object))
+	    ((memq object '(empty? count reset!)) ((builder object)))
+	    (else (error "Not a char or string:" object))))))
+
+(define (string-builder:finish-build parts)
+  (let ((result
+	 (do ((parts parts (cdr parts))
+	      (n 0 (fix:+ n (cdar parts)))
+	      (8-bit? #t
+		      (and 8-bit?
+			   (string-8-bit?
+			    (string-slice (caar parts) 0 (cdar parts))))))
+	     ((not (pair? parts))
+	      (if 8-bit?
+		  (legacy-string-allocate n)
+		  (full-string-allocate n))))))
+    (do ((parts parts (cdr parts))
+	 (i 0 (string-copy! result i (caar parts) 0 (cdar parts))))
+	((not (pair? parts))))
+    result))
 
 (define (string-copy! to at from #!optional start end)
   (let* ((end (fix:end-index end (string-length from) 'string-copy!))