From: Chris Hanson Date: Sun, 19 Feb 2017 21:03:34 +0000 (-0800) Subject: Implement string-builder. X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~60 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=418f64fcc7603cb727c0ec7915be55fcf5f896d9;p=mit-scheme.git Implement string-builder. This hides most of the details of building strings, and continues to work even if we add immutable strings. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 8918a406e..61c957d93 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1127,6 +1127,7 @@ USA. string-any string-append string-append* + string-builder string-ci-hash string-ci<=? string-ci index 0) + (new-buffer!)) + (set! buffers (cons string buffers)) + unspecific) + + (define (build) + (let ((strings (reverse! (cons (string-slice buffer 0 index) buffers)))) + (set! buffer) + (set! buffers) + (set! index) + (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))) + + (lambda (#!optional object) + (cond ((default-object? object) (build)) + ((bitless-char? object) (append-char! object)) + ((string? object) (append-string! object)) + (else (error "Not a char or string:" object))))))) + (define (string-copy! to at from #!optional start end) (let* ((end (fix:end-index end (string-length from) 'string-copy!)) (start (fix:start-index start end 'string-copy!))) (guarantee index-fixnum? at 'string-copy!) - (if (not (fix:<= (fix:+ at (fix:- end start)) (string-length to))) - (error:bad-range-argument to 'string-copy!)) - (receive (to at) - (if (slice? to) - (values (slice-string to) - (fix:+ (slice-start to) at)) - (values to at)) - (receive (from start end) (translate-slice from start end) - (if (legacy-string? to) - (if (legacy-string? from) - (copy-loop legacy-string-set! to at - legacy-string-ref from start end) - (copy-loop legacy-string-set! to at - %full-string-ref from start end)) - (if (legacy-string? from) - (copy-loop %full-string-set! to at - legacy-string-ref from start end) - (%full-string-copy! to at from start end))))))) + (let ((final-at (fix:+ at (fix:- end start)))) + (if (not (fix:<= final-at (string-length to))) + (error:bad-range-argument to 'string-copy!)) + (receive (to at) + (if (slice? to) + (values (slice-string to) + (fix:+ (slice-start to) at)) + (values to at)) + (receive (from start end) (translate-slice from start end) + (if (legacy-string? to) + (if (legacy-string? from) + (copy-loop legacy-string-set! to at + legacy-string-ref from start end) + (copy-loop legacy-string-set! to at + %full-string-ref from start end)) + (if (legacy-string? from) + (copy-loop %full-string-set! to at + legacy-string-ref from start end) + (%full-string-copy! to at from start end))))) + final-at))) (define-integrable (%full-string-copy! to at from start end) (cp-vector-copy! (%full-string-cp-vector to) at diff --git a/tests/runtime/test-string.scm b/tests/runtime/test-string.scm index 597def903..ca736b80d 100644 --- a/tests/runtime/test-string.scm +++ b/tests/runtime/test-string.scm @@ -181,4 +181,71 @@ USA. (assert-string-ci= "Strasse" "Stra\xDF;e") (assert-string-ci= "STRASSE" "Stra\xDF;e") (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C2;" "\x39E;\x391;\x39F;\x3A3;") - (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C3;" "\x39E;\x391;\x39F;\x3A3;"))) \ No newline at end of file + (assert-string-ci= "\x3BE;\x3B1;\x3BF;\x3C3;" "\x39E;\x391;\x39F;\x3A3;"))) + +(define-test 'string-builder + (lambda () + (let ((end (length latin-alphabet))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i end))) + (let ((chars (list-head latin-alphabet i))) + (let ((result (build-string chars))) + (assert-true (legacy-string? result)) + (assert-string= result (chars->string chars)))) + (let ((strings (make-test-strings i latin-alphabet #f))) + (let ((result (build-string strings))) + (assert-true (legacy-string? result)) + (assert-string= result (string-append* strings)))) + (let ((strings (make-test-strings i latin-alphabet #t))) + (let ((result (build-string strings))) + (assert-true (legacy-string? result)) + (assert-string= result (string-append* strings)))))) + (let ((end (length greek-alphabet))) + (do ((i 0 (fix:+ i 1))) + ((not (fix:< i end))) + (let ((chars (list-head greek-alphabet i))) + (assert-string= (build-string chars) + (chars->string chars))) + (let ((strings (make-test-strings i greek-alphabet #f))) + (assert-string= (build-string strings) + (string-append* strings))) + (let ((strings (make-test-strings i greek-alphabet #t))) + (assert-string= (build-string strings) + (string-append* strings))))))) + +(define legacy-string? + (make-primitive-procedure 'string? 1)) + +(define latin-alphabet + '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m + #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z)) + +(define greek-alphabet + '(#\x3B1 #\x3B2 #\x3B3 #\x3B4 #\x3B5 + #\x3B6 #\x3B7 #\x3B8 #\x3B9 #\x3BA + #\x3BB #\x3BC #\x3BD #\x3BE #\x3BF + #\x3C0 #\x3C1 #\x3C2 #\x3C3 #\x3C4 + #\x3C5 #\x3C6 #\x3C7 #\x3C8 #\x3C9)) + +(define (build-string objects) + (let ((builder (string-builder))) + (for-each builder objects) + (builder))) + +(define (chars->string chars) + (let ((s (make-ustring (length chars)))) + (do ((chars chars (cdr chars)) + (i 0 (fix:+ i 1))) + ((not (pair? chars))) + (string-set! s i (car chars))) + s)) + +(define (make-test-strings n alphabet reverse?) + (let loop ((k 0) (strings '())) + (if (fix:< k n) + (loop (fix:+ k 1) + (cons (chars->string (list-head alphabet k)) + strings)) + (if reverse? + strings + (reverse! strings))))) \ No newline at end of file