Allow XML I/O on ports that don't support coding.

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 73a478f1f93dd928c58d198814e57f8dc76667e0..a0bc27910aa5caac41e51b674bf05e8075bcb66f 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.46 2008/08/24 06:27:20 cph Exp $
+$Id: xml-output.scm,v 1.47 2008/10/26 23:35:16 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -51,15 +51,16 @@ USA.
      (write-xml-1 xml port options))))
 
 (define (set-coding xml port)
-  (let ((coding
-        (or (normalize-coding port
-                              (and (xml-document? xml)
-                                   (xml-document-declaration xml)))
-            'UTF-8)))
-    (port/set-coding port coding)
-    (port/set-line-ending port 'TEXT)
-    (if (coding-requires-bom? coding)
-       (write-char #\U+FEFF port))))
+  (if (port/supports-coding? port)
+      (let ((coding
+            (or (normalize-coding port
+                                  (and (xml-document? xml)
+                                       (xml-document-declaration xml)))
+                'UTF-8)))
+       (port/set-coding port coding)
+       (port/set-line-ending port 'TEXT)
+       (if (coding-requires-bom? coding)
+           (write-char #\U+FEFF port)))))
 
 (define (write-xml-1 xml port options)
   (%write-xml xml

diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index b027592803197e4a96fa1a0c12c0efd2361a658d..44d5848d0656696e6db4230e6b6ac5abf23e63c8 100644 (file)
--- a/v7/src/xml/xml-parser.scm
+++ b/v7/src/xml/xml-parser.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-parser.scm,v 1.81 2008/08/18 06:59:42 cph Exp $
+$Id: xml-parser.scm,v 1.82 2008/10/26 23:35:24 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -118,12 +118,15 @@ USA.
 ;;;; Character coding
 
 (define (determine-coding port)
-  (port/set-coding port 'BINARY)
-  (port/set-line-ending port 'BINARY)
-  (receive (coding name prefix) (determine-coding-1 port)
-    (port/set-coding port coding)
-    (port/set-line-ending port 'XML-1.0)
-    (values name prefix)))
+  (if (port/supports-coding? port)
+      (begin
+       (port/set-coding port 'BINARY)
+       (port/set-line-ending port 'BINARY)
+       (receive (coding name prefix) (determine-coding-1 port)
+         (port/set-coding port coding)
+         (port/set-line-ending port 'XML-1.0)
+         (values name prefix)))
+      (values #f #f)))
 
 (define (determine-coding-1 port)
   (let ((rb
@@ -177,25 +180,26 @@ USA.
                 (prefix b0)))))))
 \f
 (define (finish-coding buffer coding declaration)
-  (let ((port (parser-buffer-port buffer)))
-    (if port
-       (let* ((declared (normalize-coding port declaration))
-              (lose
-               (lambda ()
-                 (error "Incorrect encoding declaration:" declared))))
-         (case coding
-           ((UTF-8 UTF-16)
-            (if (not (or (not declared) (eq? declared coding)))
-                (lose)))
-           ((UTF-32)
-            (if (not (eq? declared coding))
-                (lose)))
-           ((NO-BOM)
-            (if (coding-requires-bom? declared)
-                (lose))
-            (port/set-coding port (or declared 'UTF-8)))
-           ((ANY) unspecific)
-           (else (error:bad-range-argument coding #f)))))))
+  (if coding
+      (let ((port (parser-buffer-port buffer)))
+       (if port
+           (let* ((declared (normalize-coding port declaration))
+                  (lose
+                   (lambda ()
+                     (error "Incorrect encoding declaration:" declared))))
+             (case coding
+               ((UTF-8 UTF-16)
+                (if (not (or (not declared) (eq? declared coding)))
+                    (lose)))
+               ((UTF-32)
+                (if (not (eq? declared coding))
+                    (lose)))
+               ((NO-BOM)
+                (if (coding-requires-bom? declared)
+                    (lose))
+                (port/set-coding port (or declared 'UTF-8)))
+               ((ANY) unspecific)
+               (else (error:bad-range-argument coding #f))))))))
 
 (define (normalize-coding port declaration)
   (let ((coding
@@ -204,8 +208,7 @@ USA.
                (and coding
                     (intern coding))))))
     (if (and coding
-            (not (port/known-coding? port coding))
-            (port/supports-coding? port))
+            (not (port/known-coding? port coding)))
        (error:bad-range-argument coding #f))
     coding))