From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 Nov 2004 05:48:43 +0000 (+0000)
Subject: Use new keyword-list support.  Add ERROR:NOT-xxx procedures to xhtml.scm.
X-Git-Tag: 20090517-FFI~1476
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=dcf16f9f5c150caad837db4bd4eacd958353ce10;p=mit-scheme.git

Use new keyword-list support.  Add ERROR:NOT-xxx procedures to xhtml.scm.
---

diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm
index eab3333bb..e5b16da60 100644
--- a/v7/src/xml/xhtml.scm
+++ b/v7/src/xml/xhtml.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xhtml.scm,v 1.13 2004/08/12 06:31:43 cph Exp $
+$Id: xhtml.scm,v 1.14 2004/11/17 05:48:35 cph Exp $
 
 Copyright 2002,2003,2004 Massachusetts Institute of Technology
 
@@ -36,7 +36,10 @@ USA.
 
 (define (guarantee-html-element object caller)
   (if (not (html-element? object))
-      (error:wrong-type-argument object "XHTML element" caller)))
+      (error:not-html-element object caller)))
+
+(define (error:not-html-element object caller)
+  (error:wrong-type-argument object "HTML element" caller))
 
 (define (html-element-name? object)
   (and (xml-name? object)
@@ -44,7 +47,10 @@ USA.
 
 (define (guarantee-html-element-name object caller)
   (if (not (html-element-name? object))
-      (error:wrong-type-argument object "XHTML element name" caller)))
+      (error:not-html-element-name object caller)))
+
+(define (error:not-html-element-name object caller)
+  (error:wrong-type-argument object "HTML element name" caller))
 
 (define (html-external-id? object)
   (and (xml-external-id? object)
@@ -75,11 +81,8 @@ USA.
        (html-external-id? (xml-dtd-external object))
        (null? (xml-dtd-internal object))))
 
-(define html-1.0-dtd
-  (make-xml-dtd 'html html-1.0-external-id '()))
-
-(define html-1.1-dtd
-  (make-xml-dtd 'html html-1.1-external-id '()))
+(define html-1.0-dtd (make-xml-dtd 'html html-1.0-external-id '()))
+(define html-1.1-dtd (make-xml-dtd 'html html-1.1-external-id '()))
 
 (define (html-1.0-document attrs . items)
   (%make-document html-1.0-dtd attrs items))
@@ -253,18 +256,13 @@ USA.
 	     'content value))
 
 (define (html:style-attr . keyword-list)
-  (let loop ((bindings keyword-list))
-    (if (and (pair? bindings)
-	     (symbol? (car bindings))
-	     (pair? (cdr bindings))
-	     (string? (cadr bindings)))
+  (guarantee-keyword-list keyword-list 'HTML:STYLE-ATTR)
+  (if (pair? bindings)
+      (let loop ((bindings keyword-list))
 	(string-append (symbol-name (car bindings))
 		       ": "
 		       (cadr bindings)
 		       (if (pair? (cddr bindings))
 			   (string-append "; " (loop (cddr bindings)))
-			   ";"))
-	(begin
-	  (if (not (null? bindings))
-	      (error:wrong-type-argument keyword-list "keyword list" 'STYLE))
-	  ""))))
\ No newline at end of file
+			   ";")))
+      ""))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index fbb9f2d06..c112d9f9d 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.54 2004/10/15 18:34:13 cph Exp $
+$Id: xml.pkg,v 1.55 2004/11/17 05:48:43 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -308,6 +308,8 @@ USA.
 	  (html-document html-1.0-document)
 	  (html-dtd html-1.0-dtd)
 	  (html-external-id html-1.0-external-id)
+	  error:not-html-element
+	  error:not-html-element-name
 	  guarantee-html-element
 	  guarantee-html-element-name
 	  html-1.0-document