From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 19 Jul 2004 04:45:20 +0000 (+0000)
Subject: Update list of element names to cover exactly those elements defined
X-Git-Tag: 20090517-FFI~1615
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d61ef3a459bcd97bdcad71eddd77ec1db9cf363;p=mit-scheme.git

Update list of element names to cover exactly those elements defined
by XHTML 1.0 strict, and no others.  Add some context information, for
use in styling and analysis.

New procedures GUARANTEE-HTML-ELEMENT, HTML-ELEMENT-NAME?,
GUARANTEE-HTML-ELEMENT-NAME, HTML-ELEMENT-CONTEXT,
HTML-ELEMENT-NAME-CONTEXT, HTML-ELEMENT-NAMES.  Rename HTML-ATTRS to
XML-ATTRS.  Rename HTML:COMMENT to XML-COMMENT and move it to
"xml-struct".
---

diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm
index a2f3921ad..bb701a268 100644
--- a/v7/src/xml/xhtml.scm
+++ b/v7/src/xml/xhtml.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xhtml.scm,v 1.5 2004/07/18 04:34:00 cph Exp $
+$Id: xhtml.scm,v 1.6 2004/07/19 04:45:11 cph Exp $
 
 Copyright 2002,2003,2004 Massachusetts Institute of Technology
 
@@ -41,144 +41,66 @@ USA.
   (and (xml-element? object)
        (xml-name-iri=? (xml-element-name object) html-iri)))
 
-(define-syntax define-standard-element
+(define (guarantee-html-element object caller)
+  (if (not (html-element? object))
+      (error:wrong-type-argument object "XHTML element" caller)))
+
+(define (html-element-name? object)
+  (and (xml-name? object)
+       (xml-name-iri=? object html-iri)))
+
+(define (guarantee-html-element-name object caller)
+  (if (not (html-element-name? object))
+      (error:wrong-type-argument object "XHTML element name" caller)))
+
+(define-syntax define-html-element
   (sc-macro-transformer
    (lambda (form environment)
      environment
-     (if (syntax-match? '(IDENTIFIER) (cdr form))
-	 (let ((name (cadr form)))
+     (if (syntax-match? '(SYMBOL SYMBOL ? 'EMPTY) (cdr form))
+	 (let ((name (cadr form))
+	       (context (caddr form))
+	       (empty? (pair? (cdddr form))))
 	   `(BEGIN
 	      (DEFINE ,(symbol-append 'HTML: name)
-		(STANDARD-ELEMENT-CONSTRUCTOR ',name HTML-IRI))
+		(STANDARD-HTML-CONSTRUCTOR ',name ',context ,empty?))
 	      (DEFINE ,(symbol-append 'HTML: name '?)
-		(STANDARD-ELEMENT-PREDICATE ',name HTML-IRI))))
+		(STANDARD-HTML-PREDICATE ',name))
+	      ',name))
 	 (ill-formed-syntax form)))))
 
-(define (standard-element-constructor simple iri)
-  (let ((name (make-xml-name simple iri)))
-    (lambda (attrs . items)
-      (make-xml-element name
-			(if (not attrs)
-			    '()
-			    attrs)
-			(flatten-xml-element-contents items)))))
+(define (standard-html-constructor simple context empty?)
+  (let ((name (make-xml-name simple html-iri)))
+    (hash-table/put! element-context-map name context)
+    (if empty?
+	(lambda items
+	  (make-xml-element name (apply xml-attrs items) '()))
+	(lambda (attrs . items)
+	  (make-xml-element name
+			    (if (not attrs) '() attrs)
+			    (flatten-xml-element-contents items))))))
 
-(define (standard-element-predicate simple iri)
-  (let ((name (make-xml-name simple iri)))
+(define (standard-html-predicate simple)
+  (let ((name (make-xml-name simple html-iri)))
     (lambda (object)
       (and (xml-element? object)
 	   (xml-name=? (xml-element-name object) name)))))
 
-(define (flatten-xml-element-contents item)
-  (letrec
-      ((scan-item
-	(lambda (item tail)
-	  (cond ((pair? item) (scan-list item tail))
-		((or (not item) (null? item)) tail)
-		(else (cons (convert-html-string-value item) tail)))))
-       (scan-list
-	(lambda (items tail)
-	  (if (pair? items)
-	      (scan-item (car items)
-			 (scan-list (cdr items) tail))
-	      (begin
-		(if (not (null? items))
-		    (error:wrong-type-datum items "list"))
-		tail)))))
-    (scan-item item '())))
-
-(define-standard-element a)
-(define-standard-element abbr)
-(define-standard-element acronym)
-(define-standard-element address)
-(define-standard-element b)
-(define-standard-element big)
-(define-standard-element blockquote)
-(define-standard-element body)
-(define-standard-element button)
-(define-standard-element caption)
-(define-standard-element cite)
-(define-standard-element code)
-(define-standard-element col)
-(define-standard-element colgroup)
-(define-standard-element dd)
-(define-standard-element defn)
-(define-standard-element del)
-(define-standard-element dir)
-(define-standard-element div)
-(define-standard-element dl)
-(define-standard-element dt)
-(define-standard-element em)
-(define-standard-element form)
-(define-standard-element h1)
-(define-standard-element h2)
-(define-standard-element h3)
-(define-standard-element h4)
-(define-standard-element h5)
-(define-standard-element head)
-(define-standard-element html)
-(define-standard-element i)
-(define-standard-element ins)
-(define-standard-element kbd)
-(define-standard-element li)
-(define-standard-element listing)
-(define-standard-element menu)
-(define-standard-element ol)
-(define-standard-element optgroup)
-(define-standard-element option)
-(define-standard-element p)
-(define-standard-element pre)
-(define-standard-element q)
-(define-standard-element s)
-(define-standard-element samp)
-(define-standard-element script)
-(define-standard-element select)
-(define-standard-element small)
-(define-standard-element span)
-(define-standard-element strike)
-(define-standard-element strong)
-(define-standard-element sub)
-(define-standard-element sup)
-(define-standard-element table)
-(define-standard-element tbody)
-(define-standard-element td)
-(define-standard-element textarea)
-(define-standard-element tfoot)
-(define-standard-element th)
-(define-standard-element thead)
-(define-standard-element title)
-(define-standard-element tr)
-(define-standard-element tt)
-(define-standard-element u)
-(define-standard-element ul)
-(define-standard-element var)
-
-(define-syntax define-empty-element
-  (sc-macro-transformer
-   (lambda (form environment)
-     environment
-     (if (syntax-match? '(IDENTIFIER) (cdr form))
-	 (let ((name (cadr form)))
-	   `(BEGIN
-	      (DEFINE ,(symbol-append 'HTML: name)
-		(EMPTY-ELEMENT-CONSTRUCTOR ',name HTML-IRI))
-	      (DEFINE ,(symbol-append 'HTML: name '?)
-		(STANDARD-ELEMENT-PREDICATE ',name HTML-IRI))))
-	 (ill-formed-syntax form)))))
+(define (html-element-context elt)
+  (guarantee-html-element elt 'HTML-ELEMENT-CONTEXT)
+  (hash-table/get element-context-map (xml-element-name elt) #f))
 
-(define (empty-element-constructor simple iri)
-  (let ((name (make-xml-name simple iri)))
-    (lambda items
-      (make-xml-element name (apply html-attrs items) '()))))
+(define (html-element-name-context name)
+  (guarantee-html-element-name name 'HTML-ELEMENT-NAME-CONTEXT)
+  (hash-table/get element-context-map name #f))
 
-(define-empty-element br)
-(define-empty-element hr)
-(define-empty-element img)
-(define-empty-element input)
-(define-empty-element link)
-(define-empty-element meta)
+(define (html-element-names)
+  (hash-table/key-list element-context-map))
 
-(define (html-attrs . items)
+(define element-context-map
+  (make-eq-hash-table))
+
+(define (xml-attrs . items)
   (let loop ((items items))
     (if (pair? items)
 	(let ((item (car items))
@@ -192,7 +114,7 @@ USA.
 			      item
 			      (if (eq? value #t)
 				  (symbol-name item)
-				  (convert-html-string-value value)))
+				  (convert-xml-string-value value)))
 			     attrs)
 		       attrs)))
 		((xml-attribute? item)
@@ -200,10 +122,28 @@ USA.
 		((list-of-type? item xml-attribute?)
 		 (append item (loop items)))
 		(else
-		 (error "Unknown item passed to html-attrs:" item))))
+		 (error "Unknown item passed to xml-attrs:" item))))
 	'())))
 
-(define (convert-html-string-value value)
+(define (flatten-xml-element-contents item)
+  (letrec
+      ((scan-item
+	(lambda (item tail)
+	  (cond ((pair? item) (scan-list item tail))
+		((or (not item) (null? item)) tail)
+		(else (cons (convert-xml-string-value item) tail)))))
+       (scan-list
+	(lambda (items tail)
+	  (if (pair? items)
+	      (scan-item (car items)
+			 (scan-list (cdr items) tail))
+	      (begin
+		(if (not (null? items))
+		    (error:wrong-type-datum items "list"))
+		tail)))))
+    (scan-item item '())))
+
+(define (convert-xml-string-value value)
   (cond ((xml-content-item? value) value)
 	((symbol? value) (symbol-name value))
 	((number? value) (number->string value))
@@ -232,15 +172,93 @@ USA.
 	  s))
       (make-string 0)))
 
+(define-html-element a		inline)
+(define-html-element abbr	inline)
+(define-html-element acronym	inline)
+(define-html-element address	block)
+(define-html-element area	map empty)
+(define-html-element b		inline)
+(define-html-element base	head empty)
+(define-html-element bdo	inline)
+(define-html-element big	inline)
+(define-html-element blockquote	block)
+(define-html-element body	html)
+(define-html-element br		inline empty)
+(define-html-element button	inline)
+(define-html-element caption	table)
+(define-html-element cite	inline)
+(define-html-element code	inline)
+(define-html-element col	table empty)
+(define-html-element colgroup	table)
+(define-html-element dd		dl)
+(define-html-element del	hybrid)
+(define-html-element dfn	inline)
+(define-html-element div	block)
+(define-html-element dl		block)
+(define-html-element dt		dl)
+(define-html-element em		inline)
+(define-html-element fieldset	block)
+(define-html-element form	block)
+(define-html-element h1		block)
+(define-html-element h2		block)
+(define-html-element h3		block)
+(define-html-element h4		block)
+(define-html-element h5		block)
+(define-html-element h6		block)
+(define-html-element head	html)
+(define-html-element hr		block empty)
+(define-html-element html	root)
+(define-html-element i		inline)
+(define-html-element img	inline empty)
+(define-html-element input	inline empty)
+(define-html-element ins	hybrid)
+(define-html-element kbd	inline)
+(define-html-element label	inline)
+(define-html-element legend	fieldset)
+(define-html-element li		list)
+(define-html-element link	head empty)
+(define-html-element map	inline)
+(define-html-element meta	head empty)
+(define-html-element noscript	block)
+(define-html-element object	inline)
+(define-html-element ol		block)
+(define-html-element optgroup	select)
+(define-html-element option	select)
+(define-html-element p		block)
+(define-html-element param	object empty)
+(define-html-element pre	block)
+(define-html-element q		inline)
+(define-html-element samp	inline)
+(define-html-element script	hybrid)
+(define-html-element select	inline)
+(define-html-element small	inline)
+(define-html-element span	inline)
+(define-html-element strong	inline)
+(define-html-element style	head)
+(define-html-element sub	inline)
+(define-html-element sup	inline)
+(define-html-element table	block)
+(define-html-element tbody	table)
+(define-html-element td		table)
+(define-html-element textarea	inline)
+(define-html-element tfoot	table)
+(define-html-element th		table)
+(define-html-element thead	table)
+(define-html-element title	head)
+(define-html-element tr		table)
+(define-html-element tt		inline)
+(define-html-element ul		block)
+(define-html-element var	inline)
+
 (define (html:href iri . contents)
   (apply html:a
-	 (html-attrs 'href iri)
+	 (xml-attrs 'href iri)
 	 contents))
 
 (define (html:id-def tag . contents)
   (apply html:a
-	 (html-attrs 'id tag
-		     'name tag)
+	 (xml-attrs 'id tag
+		    'name tag)
 	 contents))
 
 (define (html:id-ref tag . contents)
@@ -259,7 +277,7 @@ USA.
   (html:meta 'http-equiv name
 	     'content value))
 
-(define (html:style . keyword-list)
+(define (html:style-attr . keyword-list)
   (let loop ((bindings keyword-list))
     (if (and (pair? bindings)
 	     (symbol? (car bindings))
@@ -274,16 +292,4 @@ USA.
 	(begin
 	  (if (not (null? bindings))
 	      (error:wrong-type-argument keyword-list "keyword list" 'STYLE))
-	  ""))))
-
-(define (html:comment . strings)
-  (make-xml-comment
-   (let* ((s (apply string-append (map canonicalize-char-data strings)))
-	  (ws (utf8-string->wide-string s))
-	  (n (wide-string-length ws)))
-     (if (fix:> n 0)
-	 (string-append
-	  (if (char-whitespace? (wide-string-ref ws 0)) "" " ")
-	  s
-	  (if (char-whitespace? (wide-string-ref ws (fix:- n 1))) "" " "))
-	 " "))))
\ No newline at end of file
+	  ""))))
\ No newline at end of file
diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index e68a12824..20ebaa6c6 100644
--- a/v7/src/xml/xml-struct.scm
+++ b/v7/src/xml/xml-struct.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-struct.scm,v 1.42 2004/06/28 03:26:20 cph Exp $
+$Id: xml-struct.scm,v 1.43 2004/07/19 04:45:20 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -452,4 +452,17 @@ USA.
 	   (let ((name (xml-attribute-name attr)))
 	     (if (xml-name=? name 'xmlns)
 		 (null-xml-name-prefix)
-		 (xml-name-local name)))))))
\ No newline at end of file
+		 (xml-name-local name)))))))
+
+;; Convenience procedure
+(define (xml-comment . strings)
+  (make-xml-comment
+   (let* ((s (apply string-append (map canonicalize-char-data strings)))
+	  (ws (utf8-string->wide-string s))
+	  (n (wide-string-length ws)))
+     (if (fix:> n 0)
+	 (string-append
+	  (if (char-whitespace? (wide-string-ref ws 0)) "" " ")
+	  s
+	  (if (char-whitespace? (wide-string-ref ws (fix:- n 1))) "" " "))
+	 " "))))
\ No newline at end of file
diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 8fedd0f68..97a453243 100644
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.44 2004/07/18 04:34:06 cph Exp $
+$Id: xml.pkg,v 1.45 2004/07/19 04:45:15 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -206,6 +206,7 @@ USA.
 	  xml-attribute-value
 	  xml-attribute?
 	  xml-char-data?
+	  xml-comment
 	  xml-comment-text
 	  xml-comment?
 	  xml-content-item?
@@ -266,9 +267,7 @@ USA.
 	  %make-xml-parameter-!entity
 	  %make-xml-parameter-entity-ref
 	  %make-xml-processing-instructions
-	  %make-xml-unparsed-!entity)
-  (export (runtime xml html)
-	  canonicalize-char-data))
+	  %make-xml-unparsed-!entity))
 
 (define-package (runtime xml parser)
   (files "xml-chars" "xml-parser")
@@ -299,9 +298,14 @@ USA.
   (files "xhtml")
   (parent (runtime xml))
   (export ()
-	  html-attrs
+	  guarantee-html-element
+	  guarantee-html-element-name
 	  html-dtd
 	  html-element?
+	  html-element-context
+	  html-element-name?
+	  html-element-name-context
+	  html-element-names
 	  html-external-dtd
 	  html-iri
 	  html:a
@@ -312,8 +316,14 @@ USA.
 	  html:acronym?
 	  html:address
 	  html:address?
+	  html:area
+	  html:area?
 	  html:b
 	  html:b?
+	  html:base
+	  html:base?
+	  html:bdo
+	  html:bdo?
 	  html:big
 	  html:big?
 	  html:blockquote
@@ -334,15 +344,12 @@ USA.
 	  html:col?
 	  html:colgroup
 	  html:colgroup?
-	  html:comment
 	  html:dd
 	  html:dd?
-	  html:defn
-	  html:defn?
 	  html:del
 	  html:del?
-	  html:dir
-	  html:dir?
+	  html:dfn
+	  html:dfn?
 	  html:div
 	  html:div?
 	  html:dl
@@ -351,6 +358,8 @@ USA.
 	  html:dt?
 	  html:em
 	  html:em?
+	  html:fieldset
+	  html:fieldset?
 	  html:form
 	  html:form?
 	  html:h1
@@ -363,6 +372,8 @@ USA.
 	  html:h4?
 	  html:h5
 	  html:h5?
+	  html:h6
+	  html:h6?
 	  html:head
 	  html:head?
 	  html:hr
@@ -383,16 +394,22 @@ USA.
 	  html:ins?
 	  html:kbd
 	  html:kbd?
+	  html:label
+	  html:label?
+	  html:legend
+	  html:legend?
 	  html:li
 	  html:li?
 	  html:link
 	  html:link?
-	  html:listing
-	  html:listing?
-	  html:menu
-	  html:menu?
+	  html:map
+	  html:map?
 	  html:meta
 	  html:meta?
+	  html:noscript
+	  html:noscript?
+	  html:object
+	  html:object?
 	  html:ol
 	  html:ol?
 	  html:optgroup
@@ -401,13 +418,13 @@ USA.
 	  html:option?
 	  html:p
 	  html:p?
+	  html:param
+	  html:param?
 	  html:pre
 	  html:pre?
 	  html:q
 	  html:q?
 	  html:rel-link
-	  html:s
-	  html:s?
 	  html:samp
 	  html:samp?
 	  html:script
@@ -418,12 +435,12 @@ USA.
 	  html:small?
 	  html:span
 	  html:span?
-	  html:strike
-	  html:strike?
 	  html:strong
 	  html:strong?
 	  html:style
+	  html:style-attr
 	  html:style-link
+	  html:style?
 	  html:sub
 	  html:sub?
 	  html:sup
@@ -448,9 +465,8 @@ USA.
 	  html:tr?
 	  html:tt
 	  html:tt?
-	  html:u
-	  html:u?
 	  html:ul
 	  html:ul?
 	  html:var
-	  html:var?))
\ No newline at end of file
+	  html:var?
+	  xml-attrs))
\ No newline at end of file