Move generic XML convenience procedures from "xhtml.scm" to

"xml-struct.scm".  Add new procedures STANDARD-XML-ELEMENT-CONSTRUCTOR
and STANDARD-XML-ELEMENT-PREDICATE.

diff --git a/v7/src/xml/xhtml.scm b/v7/src/xml/xhtml.scm
index bb701a268d1b35b078ffcb35367473fc5cf37797..04973afcf77d2afb310e6a3bc2e92d4115840ff8 100644 (file)
--- a/v7/src/xml/xhtml.scm
+++ b/v7/src/xml/xhtml.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xhtml.scm,v 1.6 2004/07/19 04:45:11 cph Exp $
+$Id: xhtml.scm,v 1.7 2004/07/19 17:36:28 cph Exp $
 
 Copyright 2002,2003,2004 Massachusetts Institute of Technology
 
@@ -63,28 +63,17 @@ USA.
               (empty? (pair? (cdddr form))))
           `(BEGIN
              (DEFINE ,(symbol-append 'HTML: name)
-               (STANDARD-HTML-CONSTRUCTOR ',name ',context ,empty?))
+               (STANDARD-XML-ELEMENT-CONSTRUCTOR ',name HTML-IRI ,empty?))
              (DEFINE ,(symbol-append 'HTML: name '?)
-               (STANDARD-HTML-PREDICATE ',name))
-             ',name))
+               (STANDARD-XML-ELEMENT-PREDICATE ',name HTML-IRI))
+             (DEFINE-HTML-ELEMENT-CONTEXT ',name ',context)))
         (ill-formed-syntax form)))))
 
-(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-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 (define-html-element-context qname context)
+  (hash-table/put! element-context-map
+                  (make-xml-name qname html-iri)
+                  context)
+  qname)
 
 (define (html-element-context elt)
   (guarantee-html-element elt 'HTML-ELEMENT-CONTEXT)
@@ -100,78 +89,6 @@ USA.
 (define element-context-map
   (make-eq-hash-table))
 \f
-(define (xml-attrs . items)
-  (let loop ((items items))
-    (if (pair? items)
-       (let ((item (car items))
-             (items (cdr items)))
-         (cond ((and (xml-name? item)
-                     (pair? items))
-                (let ((value (car items))
-                      (attrs (loop (cdr items))))
-                  (if value
-                      (cons (make-xml-attribute
-                             item
-                             (if (eq? value #t)
-                                 (symbol-name item)
-                                 (convert-xml-string-value value)))
-                            attrs)
-                      attrs)))
-               ((xml-attribute? item)
-                (cons item (loop items)))
-               ((list-of-type? item xml-attribute?)
-                (append item (loop items)))
-               (else
-                (error "Unknown item passed to xml-attrs:" item))))
-       '())))
-
-(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))
-       ((xml-namespace-iri? value) (xml-namespace-iri-string value))
-       ((list-of-type? value xml-nmtoken?) (nmtokens->string value))
-       (else (error:wrong-type-datum value "string value"))))
-
-(define (nmtokens->string nmtokens)
-  (if (pair? nmtokens)
-      (let ((nmtoken-length
-            (lambda (nmtoken)
-              (string-length (symbol-name nmtoken)))))
-       (let ((s
-              (make-string
-               (let loop ((nmtokens nmtokens) (n 0))
-                 (let ((n (fix:+ n (nmtoken-length (car nmtokens)))))
-                   (if (pair? (cdr nmtokens))
-                       (loop (cdr nmtokens) (fix:+ n 1))
-                       n))))))
-         (let loop ((nmtokens nmtokens) (index 0))
-           (string-move! (symbol-name (car nmtokens)) s index)
-           (if (pair? (cdr nmtokens))
-               (let ((index (fix:+ index (nmtoken-length (car nmtokens)))))
-                 (string-set! s index #\space)
-                 (loop (cdr nmtokens) (fix:+ index 1)))))
-         s))
-      (make-string 0)))
-\f
 (define-html-element a         inline)
 (define-html-element abbr      inline)
 (define-html-element acronym   inline)

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 20ebaa6c63f96a3f808e4a0ec87c25b2ef3dc909..eb77c770a5cb03ba640cbaeea639cd256208a810 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.43 2004/07/19 04:45:20 cph Exp $
+$Id: xml-struct.scm,v 1.44 2004/07/19 17:36:48 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -453,8 +453,9 @@ USA.
             (if (xml-name=? name 'xmlns)
                 (null-xml-name-prefix)
                 (xml-name-local name)))))))
+\f
+;;;; Convenience procedures
 
-;; Convenience procedure
 (define (xml-comment . strings)
   (make-xml-comment
    (let* ((s (apply string-append (map canonicalize-char-data strings)))
@@ -465,4 +466,92 @@ USA.
          (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
+        " "))))
+
+(define (standard-xml-element-constructor qname iri empty?)
+  (let ((name (make-xml-name qname iri)))
+    (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-xml-element-predicate qname iri)
+  (let ((name (make-xml-name qname iri)))
+    (lambda (object)
+      (and (xml-element? object)
+          (xml-name=? (xml-element-name object) name)))))
+
+(define (xml-attrs . items)
+  (let loop ((items items))
+    (if (pair? items)
+       (let ((item (car items))
+             (items (cdr items)))
+         (cond ((and (xml-name? item)
+                     (pair? items))
+                (let ((value (car items))
+                      (attrs (loop (cdr items))))
+                  (if value
+                      (cons (make-xml-attribute
+                             item
+                             (if (eq? value #t)
+                                 (symbol-name item)
+                                 (convert-xml-string-value value)))
+                            attrs)
+                      attrs)))
+               ((xml-attribute? item)
+                (cons item (loop items)))
+               ((list-of-type? item xml-attribute?)
+                (append item (loop items)))
+               (else
+                (error "Unknown item passed to xml-attrs:" item))))
+       '())))
+\f
+(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))
+       ((xml-namespace-iri? value) (xml-namespace-iri-string value))
+       ((list-of-type? value xml-nmtoken?) (nmtokens->string value))
+       (else (error:wrong-type-datum value "string value"))))
+
+(define (nmtokens->string nmtokens)
+  (if (pair? nmtokens)
+      (let ((nmtoken-length
+            (lambda (nmtoken)
+              (string-length (symbol-name nmtoken)))))
+       (let ((s
+              (make-string
+               (let loop ((nmtokens nmtokens) (n 0))
+                 (let ((n (fix:+ n (nmtoken-length (car nmtokens)))))
+                   (if (pair? (cdr nmtokens))
+                       (loop (cdr nmtokens) (fix:+ n 1))
+                       n))))))
+         (let loop ((nmtokens nmtokens) (index 0))
+           (string-move! (symbol-name (car nmtokens)) s index)
+           (if (pair? (cdr nmtokens))
+               (let ((index (fix:+ index (nmtoken-length (car nmtokens)))))
+                 (string-set! s index #\space)
+                 (loop (cdr nmtokens) (fix:+ index 1)))))
+         s))
+      (make-string 0)))
\ No newline at end of file

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 94718c2913b8828595f41e48161e9fa331d3b79d..d48510333fcb6350e2a2a2ca3e53ee6b38636964 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.46 2004/07/19 17:20:40 cph Exp $
+$Id: xml.pkg,v 1.47 2004/07/19 17:36:35 cph Exp $
 
 Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
 
@@ -188,6 +188,8 @@ USA.
          set-xml-unparsed-!entity-id!
          set-xml-unparsed-!entity-name!
          set-xml-unparsed-!entity-notation!
+         standard-xml-element-constructor
+         standard-xml-element-predicate
          xml-!attlist-definitions
          xml-!attlist-name
          xml-!attlist?
@@ -205,6 +207,7 @@ USA.
          xml-attribute-namespace-decl?
          xml-attribute-value
          xml-attribute?
+         xml-attrs
          xml-char-data?
          xml-comment
          xml-comment-text
@@ -298,7 +301,6 @@ USA.
   (files "xhtml")
   (parent (runtime xml))
   (export ()
-         flatten-xml-element-contents
          guarantee-html-element
          guarantee-html-element-name
          html-dtd
@@ -469,5 +471,4 @@ USA.
          html:ul
          html:ul?
          html:var
-         html:var?
-         xml-attrs))
\ No newline at end of file
+         html:var?))
\ No newline at end of file