From 99a3ae6b8979d680ea537739676aa34390a6fa4b Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 25 Feb 2004 21:00:52 +0000
Subject: [PATCH] Generate BOM on output for those encodings that require it.

---
 v7/src/xml/xml-output.scm | 17 ++++++++++-------
 v7/src/xml/xml-parser.scm | 12 +++++++-----
 v7/src/xml/xml.pkg        |  3 ++-
 3 files changed, 19 insertions(+), 13 deletions(-)

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 8009307ce..c5d442b5e 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.31 2004/02/24 20:48:32 cph Exp $
+$Id: xml-output.scm,v 1.32 2004/02/25 21:00:49 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -38,12 +38,15 @@ USA.
       (write-xml-1 xml port options))))
 
 (define (set-coding xml port)
-  (port/set-coding port
-		   (or (normalize-coding port
-					 (and (xml-document? xml)
-					      (xml-document-declaration xml)))
-		       'UTF-8))
-  (port/set-line-ending port 'TEXT))
+  (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 (xml->wide-string xml . options)
   (call-with-wide-output-string
diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index e7216817d..b52fc9f41 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.57 2004/02/24 20:36:42 cph Exp $
+$Id: xml-parser.scm,v 1.58 2004/02/25 21:00:52 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -170,7 +170,7 @@ USA.
 			    0)))
 	       (lose c0 c1 c2 c3))))
 	((#\U+3C)
-	 (values #f '8-BIT #\<))
+	 (values #f 'NO-BOM #\<))
 	(else
 	 (values 'UTF-8 'UTF-8 c0))))))
 
@@ -188,9 +188,8 @@ USA.
 	    ((UTF-32)
 	     (if (not (eq? declared coding))
 		 (lose)))
-	    ((8-BIT)
-	     (if (memq declared
-		       '(UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE))
+	    ((NO-BOM)
+	     (if (coding-requires-bom? declared)
 		 (lose))
 	     (port/set-coding port (or declared 'UTF-8)))
 	    ((ANY) unspecific)
@@ -205,6 +204,9 @@ USA.
     (if (and coding (not (port/known-coding? port coding)))
 	(error:bad-range-argument coding #f))
     coding))
+
+(define (coding-requires-bom? coding)
+  (memq coding '(UTF-16 UTF-16BE UTF-16LE UTF-32 UTF-32BE UTF-32LE)))
 
 ;;;; Top level
 
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index aaaa67b0a..a5098eddb 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.38 2004/02/24 20:36:23 cph Exp $
+$Id: xml.pkg,v 1.39 2004/02/25 21:00:45 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -278,6 +278,7 @@ USA.
   (export (runtime xml)
 	  alphabet:name-initial
 	  alphabet:name-subsequent
+	  coding-requires-bom?
 	  normalize-coding))
 
 (define-package (runtime xml output)
-- 
2.25.1