From 50dfb8e0cafe3a8527006aa3c39b254689b36905 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 14 Apr 2000 01:30:10 +0000 Subject: [PATCH] Implement DECORATED-STRING-APPEND. --- v7/src/runtime/runtime.pkg | 3 +- v7/src/runtime/string.scm | 114 ++++++++++++++++++++++++++----------- 2 files changed, 83 insertions(+), 34 deletions(-) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 13fd2c34c..3cc6d65fd 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.346 2000/04/13 20:11:32 cph Exp $ +$Id: runtime.pkg,v 14.347 2000/04/14 01:29:52 cph Exp $ Copyright (c) 1988-2000 Massachusetts Institute of Technology @@ -79,6 +79,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (export () burst-string char->string + decorated-string-append list->string guarantee-string make-string diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index 85a8deef8..d238f0574 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: string.scm,v 14.32 2000/04/13 22:23:03 cph Exp $ +$Id: string.scm,v 14.33 2000/04/14 01:30:10 cph Exp $ Copyright (c) 1988-2000 Massachusetts Institute of Technology @@ -259,43 +259,25 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (substring-move-left! string 0 size result 0) result))) -(define (string-append . strings) - (%string-append strings)) - -(define (%string-append strings) - (let ((result - (string-allocate - (let loop ((strings strings) (length 0)) - (if (pair? strings) - (begin - (guarantee-string (car strings) 'STRING-APPEND) - (loop (cdr strings) - (fix:+ (string-length (car strings)) length))) - length))))) - (let loop ((strings strings) (index 0)) - (if (pair? strings) - (let ((size (string-length (car strings)))) - (substring-move-left! (car strings) 0 size result index) - (loop (cdr strings) (fix:+ index size))) - result)))) - (define (string-move! string1 string2 start2) (guarantee-string string1 'STRING-MOVE!) - (%substring-move! string1 0 (string-length string1) string2 start2 - 'STRING-MOVE!)) + (guarantee-string string2 procedure) + (guarantee-index/string start2 procedure) + (let ((end1 (string-length string1))) + (if (not (fix:<= (fix:+ start2 end1) (string-length string2))) + (error:bad-range-argument start2 procedure)) + (%substring-move! string1 0 end1 string2 start2))) (define (substring-move! string1 start1 end1 string2 start2) (guarantee-substring string1 start1 end1 'SUBSTRING-MOVE!) - (%substring-move! string1 start1 end1 string2 start2 - 'SUBSTRING-MOVE!)) - -(define (%substring-move! string1 start1 end1 string2 start2 procedure) (guarantee-string string2 procedure) (guarantee-index/string start2 procedure) - (let* ((n (fix:- end1 start1)) - (end2 (fix:+ start2 n))) - (if (not (fix:<= end2 (string-length string2))) - (error:bad-range-argument start2 procedure)) + (if (not (fix:<= (fix:+ start2 (fix:- end1 start1)) (string-length string2))) + (error:bad-range-argument start2 procedure)) + (%substring-move! string1 start1 end1 string2 start2)) + +(define (%substring-move! string1 start1 end1 string2 start2) + (let ((n (fix:- end1 start1))) (if (fix:< n 32) ;; When transferring less than 32 bytes, it's faster to do ;; inline than to call the primitive. @@ -305,7 +287,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (begin (string-set! string2 i2 (string-ref string1 i1)) (loop (fix:+ i1 1) (fix:+ i2 1))))) - (let loop ((i1 end2) (i2 end2)) + (let loop ((i1 end1) (i2 (fix:+ start2 n))) (if (fix:> i1 start1) (let ((i1 (fix:+ i1 1)) (i2 (fix:+ i2 1))) @@ -314,7 +296,73 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. (if (or (not (eq? string2 string1)) (fix:< start2 start1)) (substring-move-left! string1 start1 end1 string2 start2) (substring-move-right! string1 start1 end1 string2 start2))) - end2)) + (fix:+ start2 n))) + +(define (string-append . strings) + (%string-append strings)) + +(define (%string-append strings) + (let ((result + (string-allocate + (let loop ((strings strings) (length 0)) + (if (pair? strings) + (begin + (guarantee-string (car strings) 'STRING-APPEND) + (loop (cdr strings) + (fix:+ (string-length (car strings)) length))) + length))))) + (let loop ((strings strings) (index 0)) + (if (pair? strings) + (let ((size (string-length (car strings)))) + (substring-move-left! (car strings) 0 size result index) + (loop (cdr strings) (fix:+ index size))) + result)))) + +(define (decorated-string-append prefix infix suffix strings) + (guarantee-string prefix 'DECORATED-STRING-APPEND) + (guarantee-string infix 'DECORATED-STRING-APPEND) + (guarantee-string suffix 'DECORATED-STRING-APPEND) + (%decorated-string-append prefix infix suffix strings + 'DECORATED-STRING-APPEND)) + +(define (%decorated-string-append prefix infix suffix strings procedure) + (if (pair? strings) + (let ((np (string-length prefix)) + (ni (string-length infix)) + (ns (string-length suffix))) + (guarantee-string (car strings) procedure) + (let ((string + (make-string + (let ((ni* (fix:+ np (fix:+ ni ns)))) + (do ((strings (cdr strings) (cdr strings)) + (count (fix:+ np (string-length (car strings))) + (fix:+ count + (fix:+ ni* + (string-length (car strings)))))) + ((not (pair? strings)) + (fix:+ count ns)) + (guarantee-string (car strings) procedure)))))) + (let ((mp + (lambda (index) + (%substring-move! prefix 0 np string index))) + (mi + (lambda (index) + (%substring-move! infix 0 ni string index))) + (ms + (lambda (index) + (%substring-move! suffix 0 ns string index))) + (mv + (lambda (s index) + (%substring-move! s 0 (string-length s) string index)))) + (let loop + ((strings (cdr strings)) + (index (mv (car strings) (mp 0)))) + (if (pair? strings) + (loop (cdr strings) + (mv (car strings) (mp (mi (ms index))))) + (ms index)))) + string)) + (make-string 0))) (define (burst-string string delimiter allow-runs?) (guarantee-string string 'BURST-STRING) -- 2.25.1