From 43007070e852f01723eea6ef5bc28b4ead8c5621 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 24 Jul 2004 03:19:23 +0000
Subject: [PATCH] Add predicates to identify XHTML DTDs.

---
 v7/src/xml/xhtml.scm | 101 +++++++++++++++++++++++++++----------------
 v7/src/xml/xml.pkg   |   4 +-
 2 files changed, 67 insertions(+), 38 deletions(-)

diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm
index 8fd107ba8..5fce26d95 100644
--- a/v7/src/xml/xhtml.scm
+++ b/v7/src/xml/xhtml.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xhtml.scm,v 1.10 2004/07/24 03:03:14 cph Exp $
+$Id: xhtml.scm,v 1.11 2004/07/24 03:19:18 cph Exp $
 
 Copyright 2002,2003,2004 Massachusetts Institute of Technology
 
@@ -27,42 +27,8 @@ USA.
 
 (declare (usual-integrations))
 
-(define (html-1.0-document attrs . items)
-  (%make-document html-1.0-dtd attrs items))
-
-(define html-1.0-external-id
-  (make-xml-external-id "-//W3C//DTD XHTML 1.0 Strict//EN"
-			"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"))
-
-(define html-1.0-dtd
-  (make-xml-dtd 'html html-1.0-external-id '()))
-
-(define (html-1.1-document attrs . items)
-  (%make-document html-1.1-dtd attrs items))
-
-(define html-1.1-external-id
-  (make-xml-external-id "-//W3C//DTD XHTML 1.1//EN"
-			"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"))
-
-(define html-1.1-dtd
-  (make-xml-dtd 'html html-1.1-external-id '()))
-
-(define (%make-document dtd attrs items)
-  (make-xml-document (make-xml-declaration "1.0" "UTF-8" #f)
-		     '("\n")
-		     dtd
-		     '("\n")
-		     (html:html (if (there-exists? attrs
-				      (lambda (attr)
-					(eq? (xml-attribute-name attr)
-					     'xmlns)))
-				    attrs
-				    (xml-attrs 'xmlns html-iri attrs))
-				items)
-		     '()))
-
-(define html-iri
-  (make-xml-namespace-iri "http://www.w3.org/1999/xhtml"))
+(define html-iri-string "http://www.w3.org/1999/xhtml")
+(define html-iri (make-xml-namespace-iri html-iri-string))
 
 (define (html-element? object)
   (and (xml-element? object)
@@ -79,6 +45,67 @@ USA.
 (define (guarantee-html-element-name object caller)
   (if (not (html-element-name? object))
       (error:wrong-type-argument object "XHTML element name" caller)))
+
+(define (html-external-id? object)
+  (and (xml-external-id? object)
+       (let ((id (xml-external-id-id object))
+	     (iri (xml-external-id-iri object)))
+	 (and id
+	      iri
+	      (or (and (string=? id html-1.0-public-id)
+		       (string=? iri html-1.0-system-id))
+		  (and (string=? id html-1.1-public-id)
+		       (string=? iri html-1.1-system-id)))))))
+
+(define html-1.0-public-id "-//W3C//DTD XHTML 1.0 Strict//EN")
+(define html-1.0-system-id "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd")
+
+(define html-1.0-external-id
+  (make-xml-external-id html-1.0-public-id html-1.0-system-id))
+
+(define html-1.1-public-id "-//W3C//DTD XHTML 1.1//EN")
+(define html-1.1-system-id "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
+
+(define html-1.1-external-id
+  (make-xml-external-id html-1.1-public-id html-1.1-system-id))
+
+(define (html-dtd? object)
+  (and (xml-dtd? object)
+       (html:html? (xml-dtd-root object))
+       (html-external-id? (xml-dtd-external object))
+       (null? (xml-dtd-internal object))))
+
+(define html-root-name
+  (make-xml-name 'html html-iri))
+
+(define html-1.0-dtd
+  (make-xml-dtd html-root-name html-1.0-external-id '()))
+
+(define html-1.1-dtd
+  (make-xml-dtd html-root-name html-1.1-external-id '()))
+
+(define (html-1.0-document attrs . items)
+  (%make-document html-1.0-dtd attrs items))
+
+(define (html-1.1-document attrs . items)
+  (%make-document html-1.1-dtd attrs items))
+
+(define (%make-document dtd attrs items)
+  (let ((attr
+	 (find-matching-item attrs
+	   (lambda (attr)
+	     (xml-name=? (xml-attribute-name attr) 'xmlns)))))
+    (if (and attr (not (string=? (xml-attribute-value attr) html-iri-string)))
+	(error "Default namespace must be HTML:" (xml-attribute-value attr)))
+    (make-xml-document (make-xml-declaration "1.0" "UTF-8" #f)
+		       '("\n")
+		       dtd
+		       '("\n")
+		       (html:html (if attr
+				      attrs
+				      (xml-attrs 'xmlns html-iri attrs))
+				  items)
+		       '())))
 
 (define-syntax define-html-element
   (sc-macro-transformer
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index f7c503fac..2ce4a418a 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.50 2004/07/24 03:03:24 cph Exp $
+$Id: xml.pkg,v 1.51 2004/07/24 03:19:23 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -312,11 +312,13 @@ USA.
 	  html-1.1-document
 	  html-1.1-dtd
 	  html-1.1-external-id
+	  html-dtd?
 	  html-element-context
 	  html-element-name-context
 	  html-element-name?
 	  html-element-names
 	  html-element?
+	  html-external-id?
 	  html-iri
 	  html:a
 	  html:a?
-- 
2.25.1