Implement DECORATED-STRING-APPEND.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 13fd2c34c9ff654d39f5e9702e44911981b8f92e..3cc6d65fd04804d5d3ce3e55547463700875bfc9 100644 (file)
--- 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 85a8deef865d9a2e98b9d08ddca670b34786a518..d238f057470e4984c287393cdf1837e8522a2854 100644 (file)
--- 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)))
+\f
+(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)))
 \f
 (define (burst-string string delimiter allow-runs?)
   (guarantee-string string 'BURST-STRING)