From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 9 Dec 2002 05:47:33 +0000 (+0000)
Subject: Use new column-tracking feature of output ports to do a better job of
X-Git-Tag: 20090517-FFI~2114
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b1d51de911ee2ca0daabac3312dcb807b34f172e;p=mit-scheme.git

Use new column-tracking feature of output ports to do a better job of
indenting.
---

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 656e11736..e210906f1 100644
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: xml-output.scm,v 1.5 2002/12/07 04:57:05 cph Exp $
+;;; $Id: xml-output.scm,v 1.6 2002/12/09 05:47:33 cph Exp $
 ;;;
 ;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
 ;;;
@@ -53,7 +53,7 @@
 	       (list (cons (xml-intern "standalone")
 			   (xml-declaration-standalone declaration)))
 	       '()))
-   5 2
+   2
    port)
   (write-string "?>" port))
 
@@ -63,7 +63,6 @@
     (write-string "<" port)
     (write-xml-name name port)
     (write-xml-attributes (xml-element-attributes element)
-			  (+ 1 (xml-name-columns name))
 			  (if (pair? contents) 1 3)
 			  port)
     (if (pair? contents)
@@ -96,19 +95,20 @@
 (define-method write-xml ((dtd xml-dtd-rtd) port)
   ;;root external internal
   (write-string "<!DOCTYPE " port)
-  (write-xml-name (xml-dtd-root dtd) port)
-  (if (xml-dtd-external dtd)
-      (write-xml-external-id (xml-dtd-external dtd) 10 port))
-  (if (pair? (xml-dtd-internal dtd))
-      (begin
-	(write-string " [" port)
-	(newline port)
-	(for-each (lambda (element)
-		    (write-xml element port)
-		    (newline port))
-		  (xml-dtd-internal dtd))
-	(write-string "]" port)))
-  (write-string ">" port))
+  (let ((indent (output-port/column port)))
+    (write-xml-name (xml-dtd-root dtd) port)
+    (if (xml-dtd-external dtd)
+	(write-xml-external-id (xml-dtd-external dtd) indent port))
+    (if (pair? (xml-dtd-internal dtd))
+	(begin
+	  (write-string " [" port)
+	  (newline port)
+	  (for-each (lambda (element)
+		      (write-xml element port)
+		      (newline port))
+		    (xml-dtd-internal dtd))
+	  (write-string "]" port)))
+    (write-string ">" port)))
 
 (define-method write-xml ((decl xml-!element-rtd) port)
   (write-string "<!ELEMENT " port)
@@ -227,37 +227,42 @@
 
 (define-method write-xml ((decl xml-!entity-rtd) port)
   (write-string "<!ENTITY " port)
-  (write-xml-name (xml-!entity-name decl) port)
-  (write-string " " port)
-  (if (xml-external-id? (xml-!entity-value decl))
-      (write-xml-external-id (xml-!entity-value decl) 9 port)
-      (write-entity-value (xml-!entity-value decl) port))
-  (write-string ">" port))
+  (let ((indent (output-port/column port)))
+    (write-xml-name (xml-!entity-name decl) port)
+    (write-string " " port)
+    (if (xml-external-id? (xml-!entity-value decl))
+	(write-xml-external-id (xml-!entity-value decl) indent port)
+	(write-entity-value (xml-!entity-value decl) port))
+    (write-string ">" port)))
 
 (define-method write-xml ((decl xml-unparsed-!entity-rtd) port)
   (write-string "<!ENTITY " port)
-  (write-xml-name (xml-unparsed-!entity-name decl) port)
-  (write-string " " port)
-  (write-xml-external-id (xml-unparsed-!entity-id decl) 9 port)
-  (write-string " NDATA " port)
-  (write-xml-name (xml-unparsed-!entity-notation decl) port)
-  (write-string ">" port))
+  (let ((indent (output-port/column port)))
+    (write-xml-name (xml-unparsed-!entity-name decl) port)
+    (write-string " " port)
+    (write-xml-external-id (xml-unparsed-!entity-id decl) indent port)
+    (write-string " NDATA " port)
+    (write-xml-name (xml-unparsed-!entity-notation decl) port)
+    (write-string ">" port)))
 
 (define-method write-xml ((decl xml-parameter-!entity-rtd) port)
-  (write-string "<!ENTITY % " port)
-  (write-xml-name (xml-parameter-!entity-name decl) port)
-  (write-string " " port)
-  (if (xml-external-id? (xml-parameter-!entity-value decl))
-      (write-xml-external-id (xml-parameter-!entity-value decl) 11 port)
-      (write-entity-value (xml-parameter-!entity-value decl) port))
-  (write-string ">" port))
+  (write-string "<!ENTITY " port)
+  (let ((indent (output-port/column port)))
+    (write-string "% " port)
+    (write-xml-name (xml-parameter-!entity-name decl) port)
+    (write-string " " port)
+    (if (xml-external-id? (xml-parameter-!entity-value decl))
+	(write-xml-external-id (xml-parameter-!entity-value decl) indent port)
+	(write-entity-value (xml-parameter-!entity-value decl) port))
+    (write-string ">" port)))
 
 (define-method write-xml ((decl xml-!notation-rtd) port)
   (write-string "<!NOTATION " port)
-  (write-xml-name (xml-!notation-name decl) port)
-  (write-string " " port)
-  (write-xml-external-id (xml-!notation-id decl) 11 port)
-  (write-string ">" port))
+  (let ((indent (output-port/column port)))
+    (write-xml-name (xml-!notation-name decl) port)
+    (write-string " " port)
+    (write-xml-external-id (xml-!notation-id decl) indent port)
+    (write-string ">" port)))
 
 (define-method write-xml ((string <string>) port)
   (let ((end (string-length string)))
@@ -277,24 +282,25 @@
 (define (xml-name-columns name)
   (string-length (symbol-name name)))
 
-(define (write-xml-attributes attributes prefix-cols suffix-cols port)
-  (if (and (pair? attributes)
-	   (pair? (cdr attributes))
-	   (>= (+ prefix-cols
-		  (xml-attributes-columns attributes)
-		  suffix-cols)
-	       (output-port/x-size port)))
-      (begin
-	(write-string " " port)
-	(write-xml-attribute (car attributes) port)
+(define (write-xml-attributes attributes suffix-cols port)
+  (let ((start-col (output-port/column port)))
+    (if (and (pair? attributes)
+	     (pair? (cdr attributes))
+	     (>= (+ start-col
+		    (xml-attributes-columns attributes)
+		    suffix-cols)
+		 (output-port/x-size port)))
+	(begin
+	  (write-char #\space port)
+	  (write-xml-attribute (car attributes) port)
+	  (for-each (lambda (attribute)
+		      (write-indent (+ start-col 1) port)
+		      (write-xml-attribute attribute port))
+		    (cdr attributes)))
 	(for-each (lambda (attribute)
-		    (write-indent (+ prefix-cols 1) port)
+		    (write-char #\space port)
 		    (write-xml-attribute attribute port))
-		  (cdr attributes)))
-      (for-each (lambda (attribute)
-		  (write-string " " port)
-		  (write-xml-attribute attribute port))
-		attributes)))
+		  attributes))))
 
 (define (xml-attributes-columns attributes)
   (let loop ((attributes attributes) (n-cols 0))
@@ -361,13 +367,13 @@
 	       (write-char char port)))))
     (write-char quote-char port)))
 
-(define (write-xml-external-id id prefix-cols port)
+(define (write-xml-external-id id indent port)
   (if (xml-external-id-id id)
       (begin
-	(write-indent prefix-cols port)
+	(write-indent indent port)
 	(write-string "PUBLIC " port)
 	(write-xml-string (xml-external-id-id id) port)
-	(write-indent prefix-cols port)
+	(write-indent indent port)
 	(write-xml-string (xml-external-id-uri id) port))
       (begin
 	(write-string "SYSTEM" port)
@@ -376,6 +382,10 @@
 
 (define (write-indent n port)
   (newline port)
-  (do ((i 0 (fix:+ i 1)))
-      ((fix:= i n))
-    (write-char #\space port)))
\ No newline at end of file
+  (let ((q.r (integer-divide n 8)))
+    (do ((i 0 (fix:+ i 1)))
+	((fix:= i (car q.r)))
+      (write-char #\tab port))
+    (do ((i 0 (fix:+ i 1)))
+	((fix:= i (cdr q.r)))
+      (write-char #\space port))))
\ No newline at end of file