Canonicalize character data as UTF-8 strings.

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 8b68d0eb5a7a8f37408ee8f0703ed2c6070f26c4..f62e1eb63f69c51974bffbaa9a4685a8ef700a5b 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.20 2003/07/15 02:33:10 cph Exp $
+$Id: xml-output.scm,v 1.21 2003/07/25 17:24:22 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -317,8 +317,7 @@ USA.
     (write-xml-external-id (xml-!notation-id decl) col ctx)
     (emit-string ">" ctx)))
 
-(define-method %write-xml
-    ((string (union-specializer <string> <wide-string>)) ctx)
+(define-method %write-xml ((string <string>) ctx)
   (write-escaped-string string
                        '((#\< . "&lt;")
                          (#\& . "&amp;"))
@@ -478,18 +477,10 @@ USA.
            (emit-char char ctx))))))
 
 (define (for-each-wide-char string procedure)
-  (if (wide-string? string)
-      (let ((port (open-wide-input-string string)))
-       (let loop ()
-         (let ((char (read-char port)))
-           (if (not (eof-object? char))
-               (begin
-                 (procedure char)
-                 (loop))))))
-      (let ((port (open-input-string string)))
-       (let loop ()
-         (let ((char (read-utf8-char port)))
-           (if (not (eof-object? char))
-               (begin
-                 (procedure char)
-                 (loop))))))))
\ No newline at end of file
+  (let ((port (open-input-string string)))
+    (let loop ()
+      (let ((char (read-utf8-char port)))
+       (if (not (eof-object? char))
+           (begin
+             (procedure char)
+             (loop)))))))
\ No newline at end of file

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index ccc144cfde5808409e39b70e3391e22abce9c78a..4a7a81b70aa5443b40359d6d5a0ed42142ae08b7 100644 (file)
--- a/v7/src/xml/xml-struct.scm
+++ b/v7/src/xml/xml-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-struct.scm,v 1.15 2003/07/13 03:45:04 cph Exp $
+$Id: xml-struct.scm,v 1.16 2003/07/25 17:23:42 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -74,7 +74,8 @@ USA.
 (define-syntax define-xml-type
   (sc-macro-transformer
    (lambda (form environment)
-     (if (syntax-match? '(IDENTIFIER * (IDENTIFIER EXPRESSION)) (cdr form))
+     (if (syntax-match? '(IDENTIFIER * (IDENTIFIER EXPRESSION ? EXPRESSION))
+                       (cdr form))
         (let ((root (symbol-append 'XML- (cadr form)))
               (slots (cddr form)))
           (let ((rtd (symbol-append '< root '>))
@@ -99,7 +100,13 @@ USA.
                      (NAMED-LAMBDA (,constructor ,@slot-vars)
                        ,@(map (lambda (slot var) (test slot var constructor))
                               slots slot-vars)
-                       (CONSTRUCTOR ,@slot-vars))))
+                       (CONSTRUCTOR
+                        ,@(map (lambda (slot var)
+                                 (if (pair? (cddr slot))
+                                     `(,(caddr slot) ,var)
+                                     var))
+                               slots
+                               slot-vars)))))
                  ,@(map (lambda (slot var)
                           (let* ((accessor (symbol-append root '- (car slot)))
                                  (modifier (symbol-append 'SET- accessor '!)))
@@ -159,7 +166,7 @@ USA.
 \f
 (define-xml-type element
   (name xml-name?)
-  (attributes xml-attribute-list?)
+  (attributes xml-attribute-list? canonicalize-attributes)
   (contents xml-content?))
 
 (define (xml-attribute-list? object)
@@ -188,19 +195,57 @@ USA.
       (xml-processing-instructions? object)
       (xml-entity-ref? object)))
 
-(define (xml-char-data? object)
-  (or (string? object)
-      (wide-string? object)))
-
 (define-xml-type comment
-  (text xml-char-data?))
+  (text xml-char-data? canonicalize-char-data))
 
 (define-xml-type processing-instructions
   (name
    (lambda (object)
      (and (xml-name? object)
          (not (string-ci=? "xml" (symbol-name object))))))
-  (text xml-char-data?))
+  (text xml-char-data? canonicalize-char-data))
+\f
+(define (xml-char-data? object)
+  (or (string? object)
+      (wide-char? object)
+      (wide-string? object)))
+
+(define (canonicalize-attributes attributes)
+  (map (lambda (a)
+        (cons (car a)
+              (canonicalize-content (cdr a))))
+       attributes))
+
+(define (canonicalize-content content)
+  (coalesce-adjacent-strings
+   (map (lambda (item) (canonicalize-char-data item #f))
+       content)))
+
+(define (canonicalize-char-data object)
+  (cond ((wide-char? object)
+        (call-with-output-string
+          (lambda (port)
+            (write-utf8-char object port))))
+       ((wide-string? object) (wide-string->utf8-string object))
+       (else object)))
+
+(define (coalesce-adjacent-strings items)
+  (letrec
+      ((search
+       (lambda (items)
+         (if (pair? items)
+             (if (string? (car items))
+                 (append (car items) (cdr items))
+                 (cons (car items) (search (cdr items))))
+             '())))
+       (append
+       (lambda (string items)
+         (if (pair? items)
+             (if (string? (car items))
+                 (append (string-append string (car items)) (cdr items))
+                 (cons* string (car items) (search (cdr items))))
+             '()))))
+    (search items)))
 \f
 (define-xml-type dtd
   (root xml-name?)
@@ -323,7 +368,11 @@ USA.
 
 (define-xml-type parameter-!entity
   (name xml-name?)
-  (value entity-value?))
+  (value entity-value?
+        (lambda (v)
+          (if (pair? v)
+              (canonicalize-content v)
+              v))))
 
 (define (entity-value? object)
   (or (and (pair? object)