From 856ad54b0b5155148fe0b1d313e4a05b8f587901 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 11 Mar 2017 00:42:21 -0800 Subject: [PATCH] Use string-builder instead of call-with-output-string. --- src/runtime/parse.scm | 183 +++++++++++++++++++++--------------------- 1 file changed, 91 insertions(+), 92 deletions(-) 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 -- 2.25.1