src/runtime/output.scm (write-strings-in-paragraph): Add.

diff --git a/src/runtime/output.scm b/src/runtime/output.scm
index f937a2f7cd6d0c9f805c3deb519ec997403e504b..6072628c1c0e890fde55bf1a17a777c260324311 100644 (file)
--- a/src/runtime/output.scm
+++ b/src/runtime/output.scm
@@ -268,7 +268,7 @@ USA.
                  (let ((strings (car cols)))
                    (if (pair? strings)
                        (begin
-                         (write-spaces pending-spaces)
+                         (write-spaces pending-spaces port)
                          (write-string prefix port)
                          (write-string (car strings) port)
                          (set-car! cols (cdr strings))
@@ -282,13 +282,47 @@ USA.
                    (newline port)
                    (per-row)))))))
 
-    (define (write-spaces n)
-      (if (> n 0)
-         (begin
-           (write-char #\space port)
-           (write-spaces (- n 1)))))
-
     (if row-major? (do-row-major) (do-col-major))))
+
+(define (write-spaces n port)
+  (if (> n 0)
+      (begin
+       (write-char #\space port)
+       (write-spaces (- n 1) port))))
+
+(define (write-strings-in-paragraph strings port width indent first)
+  (if (and (not (list-of-type? strings string?))
+          (pair? strings))
+      (error:wrong-type-argument strings "non-empty list of strings"
+                                'WRITE-STRINGS-IN-PARAGRAPH))
+  (guarantee-output-port port 'WRITE-STRINGS-IN-PARAGRAPH)
+  (guarantee-exact-positive-integer width 'WRITE-STRINGS-IN-PARAGRAPH)
+  (guarantee-exact-nonnegative-integer indent 'WRITE-STRINGS-IN-PARAGRAPH)
+  (guarantee-exact-nonnegative-integer first 'WRITE-STRINGS-IN-PARAGRAPH)
+  (if (< width (+ indent first (string-length (car strings))))
+      (error:bad-range-argument width 'WRITE-STRINGS-IN-PARAGRAPH))
+
+  (fresh-line port)
+  (write-spaces indent port)
+  (write-spaces first port)
+  (write-string (car strings) port)
+  (let loop ((column (+ indent first (string-length (car strings))))
+            (strings (cdr strings)))
+    (if (pair? strings)
+       (let* ((string (car strings))
+              (length (string-length string))
+              (new (+ column 1 length)))
+         (if (<= new width)
+             (begin
+               (write-char #\space port)
+               (write-string string port)
+               (loop new (cdr strings)))
+             (begin
+               (newline port)
+               (write-spaces indent port)
+               (write-string string port)
+               (loop (+ indent (string-length string)) (cdr strings)))))
+       (newline port))))
 \f
 ;;;; Output truncation
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 10a558c8cde408ad9f3d3585dc3e652511aa1705..9129ea3d36014442bee1450c5e687217cb6d6fff 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2464,6 +2464,7 @@ USA.
          write-line
          write-string
          write-strings-in-columns
+         write-strings-in-paragraph
          write-substring)
   (initialization (initialize-package!)))