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 656e117367b18ce9406bf1f56a435c3c14393680..e210906f141b4e4ed854ff96bc0c5add60be7d87 100644 (file)
--- 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 @@
 \f
 (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