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 a2f3921ad20ad51516af90a1a959e2360eb516b0..bb701a268d1b35b078ffcb35367473fc5cf37797 100644 (file)
--- 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 '())))
-\f
-(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)
-\f
-(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))
+\f
+(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)))
 \f
+(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)
+\f
 (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 e68a128243538a83ffab639421da04027cb32a7f..20ebaa6c63f96a3f808e4a0ec87c25b2ef3dc909 100644 (file)
--- 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 8fedd0f680f9fbed918e8118fb0fd187c8b509d6..97a453243f2320e251bad34a68ada9e15796317e 100644 (file)
--- 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