From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Fri, 15 Jan 2016 00:53:59 +0000 (-0700)
Subject: src/runtime/output.scm (write-strings-in-paragraph): Add.
X-Git-Tag: mit-scheme-pucked-9.2.12~373^2~5
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f0b3edd524757e3327aa29d89feea3d276783ae5;p=mit-scheme.git

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

diff --git a/src/runtime/output.scm b/src/runtime/output.scm
index f937a2f7c..6072628c1 100644
--- 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))))
 
 ;;;; Output truncation
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 10a558c8c..9129ea3d3 100644
--- 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!)))