From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 11 Mar 2017 08:42:21 +0000 (-0800)
Subject: Use string-builder instead of call-with-output-string.
X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~98
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=856ad54b0b5155148fe0b1d313e4a05b8f587901;p=mit-scheme.git

Use string-builder instead of call-with-output-string.
---

diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm
index a8e95fced..40d1148c4 100644
--- a/src/runtime/parse.scm
+++ b/src/runtime/parse.scm
@@ -625,79 +625,79 @@ USA.
   (string->symbol (parse-delimited-string db #\| #f)))
 
 (define (parse-delimited-string db delimiter allow-newline-escape?)
-  (call-with-output-string
-    (lambda (port*)
-
-      (define (loop)
-	(dispatch (%read-char/no-eof db)))
-
-      (define (dispatch char)
-	(cond ((char=? delimiter char) unspecific)
-	      ((char=? #\\ char) (parse-quoted))
-	      (else (emit char))))
-
-      (define (parse-quoted)
-	(let ((char (%read-char/no-eof db)))
-	  (cond ((char=? char #\a) (emit #\bel))
-		((char=? char #\b) (emit #\bs))
-		((char=? char #\n) (emit #\newline))
-		((char=? char #\r) (emit #\return))
-		((char=? char #\t) (emit #\tab))
-		((char=? char #\x) (emit (parse-hex-escape 0 '())))
-		((and allow-newline-escape?
-		      (or (char=? char #\newline)
-			  (char=? char #\space)
-			  (char=? char #\tab)))
-		 (if (not (char=? char #\newline))
-		     (let ((char (skip-space)))
-		       (if (not (char=? char #\newline))
-			   (error:illegal-char char))))
-		 (dispatch (skip-space)))
-		;; MIT/GNU extensions:
-		((char=? char #\f) (emit #\page))
-		((char=? char #\v) (emit #\vt))
-		((char->digit char 3)
-		 => (lambda (d) (emit (parse-octal-escape char d))))
-		(else (emit char)))))
-
-      (define (emit char)
-	(write-char char port*)
-	(loop))
-
-      (define (skip-space)
-	(let ((char (%read-char/no-eof db)))
-	  (if (or (char=? char #\space)
-		  (char=? char #\tab))
-	      (skip-space)
-	      char)))
-
-      (define (parse-hex-escape sv chars)
-	(let* ((char (%read-char/no-eof db))
-	       (chars (cons char chars)))
-	  (if (char=? #\; char)
-	      (begin
-		(if (not (unicode-scalar-value? sv))
-		    (ill-formed-hex chars))
-		(integer->char sv))
-	      (let ((digit (char->digit char 16)))
-		(if (not digit)
-		    (ill-formed-hex chars))
-		(parse-hex-escape (+ (* sv #x10) digit) chars)))))
-
-      (define (ill-formed-hex chars)
-	(error:illegal-string-escape
-	 (list->string (cons* #\\ #\x (reverse chars)))))
-
-      (define (parse-octal-escape c1 d1)
-	(let* ((c2 (%read-char/no-eof db))
-	       (d2 (char->digit c2 8))
-	       (c3 (%read-char/no-eof db))
-	       (d3 (char->digit c3 8)))
-	  (if (not (and d2 d3))
-	      (error:illegal-string-escape (list->string (list #\\ c1 c2 c3))))
-	  (integer->char (fix:+ (fix:lsh (fix:+ (fix:lsh d1 3) d2) 3) d3))))
-
-      (loop))))
+  (let ((builder (string-builder)))
+
+    (define (loop)
+      (dispatch (%read-char/no-eof db)))
+
+    (define (dispatch char)
+      (cond ((char=? delimiter char) unspecific)
+	    ((char=? #\\ char) (parse-quoted))
+	    (else (emit char))))
+
+    (define (parse-quoted)
+      (let ((char (%read-char/no-eof db)))
+	(cond ((char=? char #\a) (emit #\bel))
+	      ((char=? char #\b) (emit #\bs))
+	      ((char=? char #\n) (emit #\newline))
+	      ((char=? char #\r) (emit #\return))
+	      ((char=? char #\t) (emit #\tab))
+	      ((char=? char #\x) (emit (parse-hex-escape 0 '())))
+	      ((and allow-newline-escape?
+		    (or (char=? char #\newline)
+			(char=? char #\space)
+			(char=? char #\tab)))
+	       (if (not (char=? char #\newline))
+		   (let ((char (skip-space)))
+		     (if (not (char=? char #\newline))
+			 (error:illegal-char char))))
+	       (dispatch (skip-space)))
+	      ;; MIT/GNU extensions:
+	      ((char=? char #\f) (emit #\page))
+	      ((char=? char #\v) (emit #\vt))
+	      ((char->digit char 3)
+	       => (lambda (d) (emit (parse-octal-escape char d))))
+	      (else (emit char)))))
+
+    (define (emit char)
+      (builder char)
+      (loop))
+
+    (define (skip-space)
+      (let ((char (%read-char/no-eof db)))
+	(if (or (char=? char #\space)
+		(char=? char #\tab))
+	    (skip-space)
+	    char)))
+
+    (define (parse-hex-escape sv chars)
+      (let* ((char (%read-char/no-eof db))
+	     (chars (cons char chars)))
+	(if (char=? #\; char)
+	    (begin
+	      (if (not (unicode-scalar-value? sv))
+		  (ill-formed-hex chars))
+	      (integer->char sv))
+	    (let ((digit (char->digit char 16)))
+	      (if (not digit)
+		  (ill-formed-hex chars))
+	      (parse-hex-escape (+ (* sv #x10) digit) chars)))))
+
+    (define (ill-formed-hex chars)
+      (error:illegal-string-escape
+       (list->string (cons* #\\ #\x (reverse chars)))))
+
+    (define (parse-octal-escape c1 d1)
+      (let* ((c2 (%read-char/no-eof db))
+	     (d2 (char->digit c2 8))
+	     (c3 (%read-char/no-eof db))
+	     (d3 (char->digit c3 8)))
+	(if (not (and d2 d3))
+	    (error:illegal-string-escape (list->string (list #\\ c1 c2 c3))))
+	(integer->char (fix:+ (fix:lsh (fix:+ (fix:lsh d1 3) d2) 3) d3))))
+
+    (loop)
+    (builder)))
 
 (define (handler:false db ctx char1 char2)
   ctx char1
@@ -743,17 +743,16 @@ USA.
 	    (at-end?))
 	char
 	(name->char
-	 (call-with-output-string
-	   (lambda (port*)
-	     (write-char char port*)
-	     (let loop ()
-	       (write-char (let ((char (%read-char/no-eof db)))
-			     (if (char=? char #\\)
-				 (%read-char/no-eof db)
-				 char))
-			   port*)
-	       (if (not (at-end?))
-		   (loop)))))
+	 (let ((builder (string-builder)))
+	   (builder char)
+	   (let loop ()
+	     (builder (let ((char (%read-char/no-eof db)))
+			(if (char=? char #\\)
+			    (%read-char/no-eof db)
+			    char)))
+	     (if (not (at-end?))
+		 (loop)))
+	   (builder))
 	 (db-fold-case? db)))))
 
 (define (handler:named-constant db ctx char1 char2)
@@ -781,14 +780,14 @@ USA.
 (define (handler:uri db ctx char1 char2)
   ctx char1 char2
   (string->uri
-   (call-with-output-string
-     (lambda (port*)
-       (let loop ()
-	 (let ((char (%read-char/no-eof db)))
-	   (if (not (char=? char #\>))
-	       (begin
-		 (write-char char port*)
-		 (loop)))))))))
+   (let ((builder (string-builder)))
+     (let loop ()
+       (let ((char (%read-char/no-eof db)))
+	 (if (not (char=? char #\>))
+	     (begin
+	       (builder char)
+	       (loop)))))
+     (builder))))
 
 (define (handler:special-arg db ctx char1 char2)
   ctx char1