From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 26 Oct 2008 23:35:24 +0000 (+0000)
Subject: Allow XML I/O on ports that don't support coding.
X-Git-Tag: 20090517-FFI~93
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e98f686485bc26c543e962efe50e2c22601c29b8;p=mit-scheme.git

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 73a478f1f..a0bc27910 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.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 b02759280..44d5848d0 100644
--- 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)))))))
 
 (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))