Major update to rationalize naming structure. The implementation of

names has been moved to its own file.  There are now fully fleshed-out
XML-QNAME and XML-NMTOKEN abstractions, so that it's possible to talk
about all those names that aren't affected by namespaces (e.g.
everything in the DTD).

diff --git a/v7/src/xml/compile.scm b/v7/src/xml/compile.scm
index 16d9fd3835322d045a5447091872433f4e20b112..5f08bd7cf9109c2ec0f913ca72246a7ab1658521 100644 (file)
--- a/v7/src/xml/compile.scm
+++ b/v7/src/xml/compile.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: compile.scm,v 1.11 2003/02/14 18:28:38 cph Exp $
+$Id: compile.scm,v 1.12 2003/09/26 03:56:38 cph Exp $
 
-Copyright 2001 Massachusetts Institute of Technology
+Copyright 2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -38,7 +38,8 @@ USA.
       (lambda ()
        (load "parser-macro")
        (for-each compile-file
-                 '("xml-struct"
+                 '("xml-names"
+                   "xml-struct"
                    "xml-chars"
                    "xml-output"
                    "xml-parser"))))

diff --git a/v7/src/xml/load.scm b/v7/src/xml/load.scm
index 52c86038c598cff75f066951a0d805fba63f3b02..4663d053f5a1ba6d53d360ec83a7538201f06e1c 100644 (file)
--- a/v7/src/xml/load.scm
+++ b/v7/src/xml/load.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 1.10 2003/02/14 18:28:38 cph Exp $
+$Id: load.scm,v 1.11 2003/09/26 03:56:41 cph Exp $
 
-Copyright 2001,2002 Massachusetts Institute of Technology
+Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -28,4 +28,4 @@ USA.
 (with-working-directory-pathname (directory-pathname (current-load-pathname))
   (lambda ()
     (package/system-loader "xml" '() 'QUERY)))
-(add-subsystem-identification! "XML" '(0 3))
\ No newline at end of file
+(add-subsystem-identification! "XML" '(0 4))
\ No newline at end of file

diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm
new file mode 100644 (file)
index 0000000..064cc21
--- /dev/null
+++ b/v7/src/xml/xml-names.scm
@@ -0,0 +1,317 @@
+#| -*-Scheme-*-
+
+$Id: xml-names.scm,v 1.1 2003/09/26 03:56:48 cph Exp $
+
+Copyright 2003 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+|#
+
+;;;; XML name structures
+
+(declare (usual-integrations))
+\f
+(define (make-xml-name qname iri)
+  (let ((qname (make-xml-qname qname))
+       (iri (make-xml-namespace-iri iri)))
+    (if (null-xml-namespace-iri? iri)
+       qname
+       (begin
+         (check-prefix+iri qname iri)
+         (%make-xml-name qname iri)))))
+
+(define (check-prefix+iri qname iri)
+  (let ((s (symbol-name qname)))
+    (let ((c (string-find-next-char s #\:)))
+      (if (and c
+              (let ((prefix (string-head->symbol s c)))
+                (or (and (eq? prefix 'xml)
+                         (not (eq? iri xml-iri)))
+                    (and (eq? prefix 'xmlns)
+                         (not (eq? iri xmlns-iri))))))
+         (error:bad-range-argument iri 'MAKE-XML-NAME)))))
+
+(define (%make-xml-name qname iri)
+  (let ((uname
+        (let ((local (xml-qname-local qname)))
+          (hash-table/intern! (hash-table/intern! expanded-names
+                                                  iri
+                                                  make-eq-hash-table)
+                              local
+                              (lambda ()
+                                (make-expanded-name iri
+                                                    local
+                                                    (make-eq-hash-table)))))))
+    (hash-table/intern! (expanded-name-combos uname)
+                       qname
+                       (lambda () (make-combo-name qname uname)))))
+
+(define expanded-names
+  (make-eq-hash-table))
+
+(define (xml-name? object)
+  (or (xml-qname? object)
+      (combo-name? object)))
+
+(define (guarantee-xml-name object caller)
+  (if (not (xml-name? object))
+      (error:not-xml-name object caller)))
+
+(define (error:not-xml-name object caller)
+  (error:wrong-type-argument object "an XML Name" caller))
+\f
+(define (make-xml-nmtoken object)
+  (if (string? object)
+      (begin
+       (if (not (string-is-xml-nmtoken? object))
+           (error:bad-range-argument object 'MAKE-XML-NMTOKEN))
+       (string->symbol object))
+      (begin
+       (guarantee-xml-nmtoken object 'MAKE-XML-NMTOKEN)
+       object)))
+
+(define (xml-nmtoken? object)
+  (and (symbol? object)
+       (string-is-xml-nmtoken? (symbol-name object))))
+
+(define (guarantee-xml-nmtoken object caller)
+  (if (not (xml-nmtoken? object))
+      (error:not-xml-nmtoken object caller)))
+
+(define (error:not-xml-nmtoken object caller)
+  (error:wrong-type-argument object "an XML name token" caller))
+
+(define (xml-nmtoken-string nmtoken)
+  (guarantee-xml-nmtoken nmtoken 'XML-NMTOKEN-STRING)
+  (symbol-name nmtoken))
+
+(define (string-is-xml-name? string)
+  (eq? (string-is-xml-nmtoken? string) 'NAME))
+
+(define (string-is-xml-nmtoken? string)
+  (let ((buffer (string->parser-buffer string)))
+    (let ((check-char
+          (lambda ()
+            (match-utf8-char-in-alphabet buffer alphabet:name-subsequent))))
+      (letrec
+         ((no-colon
+           (lambda ()
+             (cond ((match-parser-buffer-char buffer #\:)
+                    (colon))
+                   ((peek-parser-buffer-char buffer)
+                    (and (check-char)
+                         (no-colon)))
+                   (else 'NAME))))
+          (colon
+           (lambda ()
+             (cond ((match-parser-buffer-char buffer #\:)
+                    (nmtoken?))
+                   ((peek-parser-buffer-char buffer)
+                    (and (check-char)
+                         (colon)))
+                   (else 'NAME))))
+          (nmtoken?
+           (lambda ()
+             (if (peek-parser-buffer-char buffer)
+                 (and (check-char)
+                      (nmtoken?))
+                 'NMTOKEN))))
+       (if (match-utf8-char-in-alphabet buffer alphabet:name-initial)
+           (no-colon)
+           (and (check-char)
+                (nmtoken?)))))))
+
+(define (string-composed-of? string char-set)
+  (and (string? string)
+       (substring-composed-of? string 0 (string-length string) char-set)))
+
+(define (substring-composed-of? string start end char-set)
+  (let loop ((index start))
+    (or (fix:= index end)
+       (and (char-set-member? char-set (string-ref string index))
+            (loop (fix:+ index 1))))))
+\f
+(define (xml-name-string name)
+  (symbol-name (xml-name-qname name)))
+
+(define (xml-name-qname name)
+  (cond ((xml-qname? name) name)
+       ((combo-name? name) (combo-name-qname name))
+       (else (error:not-xml-name name 'XML-NAME-QNAME))))
+
+(define (xml-name-qname=? name qname)
+  (eq? (xml-name-qname name) qname))
+
+(define (xml-name-iri name)
+  (cond ((xml-qname? name) (null-xml-namespace-iri))
+       ((combo-name? name) (expanded-name-iri (combo-name-expanded name)))
+       (else (error:not-xml-name name 'XML-NAME-IRI))))
+
+(define (xml-name-iri=? name iri)
+  (eq? (xml-name-iri name) iri))
+
+(define (xml-name-prefix name)
+  (xml-qname-prefix
+   (cond ((xml-qname? name) name)
+        ((combo-name? name) (combo-name-qname name))
+        (else (error:not-xml-name name 'XML-NAME-PREFIX)))))
+
+(define (null-xml-name-prefix? object)
+  (eq? object '||))
+
+(define (null-xml-name-prefix)
+  '||)
+
+(define (xml-name-prefix=? name prefix)
+  (eq? (xml-name-prefix name) prefix))
+
+(define (xml-name-local name)
+  (cond ((xml-qname? name) (xml-qname-local name))
+       ((combo-name? name) (expanded-name-local (combo-name-expanded name)))
+       (else (error:not-xml-name name 'XML-NAME-LOCAL))))
+
+(define (xml-name-local=? name local)
+  (eq? (xml-name-local name) local))
+
+(define (xml-name=? n1 n2)
+  (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?))))
+    (cond ((xml-qname? n1)
+          (cond ((xml-qname? n2) (eq? n1 n2))
+                ((combo-name? n2) (eq? n1 (combo-name-qname n2)))
+                (else (lose n2))))
+         ((combo-name? n1)
+          (cond ((xml-qname? n2)
+                 (eq? (combo-name-qname n1) n2))
+                ((combo-name? n2)
+                 (eq? (combo-name-expanded n1)
+                      (combo-name-expanded n2)))
+                (else (lose n2))))
+         (else (lose n1)))))
+
+(define (xml-name-hash name modulus)
+  (eq-hash-mod (xml-name-local name) modulus))
+
+(define make-xml-name-hash-table
+  (strong-hash-table/constructor xml-name-hash xml-name=? #t))
+\f
+(define (make-xml-qname object)
+  (if (string? object)
+      (begin
+       (if (not (string-is-xml-name? object))
+           (error:bad-range-argument object 'MAKE-XML-QNAME))
+       (string->symbol object))
+      (begin
+       (guarantee-xml-qname object 'MAKE-XML-QNAME)
+       object)))
+
+(define (xml-qname? object)
+  (and (interned-symbol? object)
+       (string-is-xml-name? (symbol-name object))))
+
+(define (guarantee-xml-qname object caller)
+  (if (not (xml-qname? object))
+      (error:not-xml-qname object caller)))
+
+(define (error:not-xml-qname object caller)
+  (error:wrong-type-argument object "an XML QName" caller))
+
+(define (xml-qname-string qname)
+  (guarantee-xml-qname qname 'XML-QNAME-STRING)
+  (symbol-name qname))
+
+(define (xml-qname-local qname)
+  (let ((s (symbol-name qname)))
+    (let ((c (string-find-next-char s #\:)))
+      (if c
+         (string-tail->symbol s (fix:+ c 1))
+         qname))))
+
+(define (xml-qname-prefix qname)
+  (let ((s (symbol-name qname)))
+    (let ((c (string-find-next-char s #\:)))
+      (if c
+         (string-head->symbol s c)
+         (null-xml-name-prefix)))))
+
+(define-record-type <combo-name>
+    (make-combo-name qname expanded)
+    combo-name?
+  (qname combo-name-qname)
+  (expanded combo-name-expanded))
+
+(set-record-type-unparser-method! <combo-name>
+  (standard-unparser-method 'XML-NAME
+    (lambda (name port)
+      (write-char #\space port)
+      (write (combo-name-qname name) port))))
+
+(define-record-type <expanded-name>
+    (make-expanded-name iri local combos)
+    expanded-name?
+  (iri expanded-name-iri)
+  (local expanded-name-local)
+  (combos expanded-name-combos))
+\f
+;;;; Namespace IRI
+
+(define (make-xml-namespace-iri object)
+  (if (string? object)
+      (begin
+       (if (not (string-is-namespace-iri? object))
+           (error:bad-range-argument object 'MAKE-XML-NAMESPACE-IRI))
+       (hash-table/intern! namespace-iris object
+         (lambda ()
+           (%make-xml-namespace-iri object))))
+      (begin
+       (guarantee-xml-namespace-iri object 'MAKE-XML-NAMESPACE-IRI)
+       object)))
+
+(define (string-is-namespace-iri? object)
+  ;; See RFC 1630 for correct syntax.
+  (utf8-string-valid? object))
+
+(define namespace-iris
+  (make-string-hash-table))
+
+(define-record-type <xml-namespace-iri>
+    (%make-xml-namespace-iri string)
+    xml-namespace-iri?
+  (string xml-namespace-iri-string))
+
+(define (guarantee-xml-namespace-iri object caller)
+  (if (not (xml-namespace-iri? object))
+      (error:not-xml-namespace-iri object caller)))
+
+(define (null-xml-namespace-iri? object)
+  (eq? object null-namespace-iri))
+
+(define (null-xml-namespace-iri)
+  null-namespace-iri)
+
+(define null-namespace-iri
+  (make-xml-namespace-iri ""))
+
+(define (error:not-xml-namespace-iri object caller)
+  (error:wrong-type-argument object "an XML namespace IRI" caller))
+
+(define xml-iri
+  (make-xml-namespace-iri "http://www.w3.org/XML/1998/namespace"))
+
+(define xmlns-iri
+  (make-xml-namespace-iri "http://www.w3.org/2000/xmlns/"))
\ No newline at end of file

diff --git a/v7/src/xml/xml-output.scm b/v7/src/xml/xml-output.scm
index 5cbc7a5875cfb2081ca823df6c08ada220c2e278..979c4b35a8d8890257315bffe35435e89cb3ad79 100644 (file)
--- a/v7/src/xml/xml-output.scm
+++ b/v7/src/xml/xml-output.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-output.scm,v 1.25 2003/09/25 16:51:15 cph Exp $
+$Id: xml-output.scm,v 1.26 2003/09/26 03:56:51 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -249,10 +249,10 @@ USA.
                    (emit-string "(" ctx)
                    (if (pair? (cdr type))
                        (begin
-                         (write-xml-name (cadr type) ctx)
-                         (for-each (lambda (name)
+                         (write-xml-nmtoken (cadr type) ctx)
+                         (for-each (lambda (nmtoken)
                                      (emit-string "|" ctx)
-                                     (write-xml-name name ctx))
+                                     (write-xml-nmtoken nmtoken ctx))
                                    (cddr type))))
                    (emit-string ")" ctx))
                   (else
@@ -417,6 +417,9 @@ USA.
 (define (xml-name-columns name)
   (utf8-string-length (xml-name-string name)))
 
+(define (write-xml-nmtoken nmtoken ctx)
+  (emit-string (xml-nmtoken-string nmtoken) ctx))
+
 (define (write-entity-value value col ctx)
   (if (xml-external-id? value)
       (write-xml-external-id value col ctx)

diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index 9377c640297f1436111471e775d1cc227284f86b..ed08bfbb378f4f1391072877addb044cb043c4f3 100644 (file)
--- a/v7/src/xml/xml-parser.scm
+++ b/v7/src/xml/xml-parser.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml-parser.scm,v 1.45 2003/09/26 01:00:11 cph Exp $
+$Id: xml-parser.scm,v 1.46 2003/09/26 03:56:54 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -436,7 +436,7 @@ USA.
 
 (define (simple-name-parser type)
   (let ((m (string-append "Malformed " type " name")))
-    (*parser (require-success m (map xml-intern (match match-name))))))
+    (*parser (require-success m (map make-xml-qname (match match-name))))))
 
 (define parse-entity-name (simple-name-parser "entity"))
 (define parse-pi-name (simple-name-parser "processing-instructions"))
@@ -452,7 +452,7 @@ USA.
 (define parse-required-name-token      ;[7]
   (*parser
    (require-success "Malformed XML name token"
-     (map xml-intern (match match-name-token)))))
+     (map make-xml-nmtoken (match match-name-token)))))
 
 (define (match-name-token buffer)
   (and (match-utf8-char-in-alphabet buffer alphabet:name-subsequent)
@@ -504,40 +504,36 @@ USA.
              *prefix-bindings*)))
   unspecific)
 
-(define (intern-element-name n) (intern-name n #t))
-(define (intern-attribute-name n) (intern-name n #f))
+(define (intern-element-name n) (intern-name n #f))
+(define (intern-attribute-name n) (intern-name n #t))
 
-(define (intern-name n element-name?)
-  (let ((s (car n))
+(define (intern-name n attribute-name?)
+  (let ((qname (string->symbol (car n)))
        (p (cdr n)))
-    (let ((qname (string->symbol s))
-         (c (string-find-next-char s #\:)))
-      (let ((iri
-            (if (and (not *in-dtd?*)
-                     (or element-name? c))
-                (let ((prefix
-                       (if c
-                           (string-head->symbol s c)
-                           (null-xml-name-prefix))))
-                  (case prefix
-                    ((xmlns) xmlns-iri)
-                    ((xml) xml-iri)
-                    (else
-                     (let ((entry (assq prefix *prefix-bindings*)))
-                       (if entry
-                           (cdr entry)
-                           (begin
-                             (if (not (null-xml-name-prefix? prefix))
-                                 (perror p "Unknown XML prefix" prefix))
-                             (null-xml-namespace-iri)))))))
-                (null-xml-namespace-iri? iri))))
-       (if (null-xml-namespace-iri? iri)
-           qname
-           (%make-xml-name qname
-                           iri
-                           (if c
-                               (string-tail->symbol s (fix:+ c 1))
-                               qname)))))))
+    (if *in-dtd?*
+       qname
+       (let ((iri (lookup-namespace-prefix qname p attribute-name?)))
+         (if (null-xml-namespace-iri? iri)
+             qname
+             (%make-xml-name qname iri))))))
+
+(define (lookup-namespace-prefix qname p attribute-name?)
+  (let ((prefix (xml-qname-prefix qname)))
+    (cond ((eq? prefix 'xmlns)
+          xmlns-iri)
+         ((eq? prefix 'xml)
+          xml-iri)
+         ((and attribute-name?
+               (null-xml-name-prefix? prefix))
+          (null-xml-namespace-iri))
+         (else
+          (let ((entry (assq prefix *prefix-bindings*)))
+            (if entry
+                (cdr entry)
+                (begin
+                  (if (not (null-xml-name-prefix? prefix))
+                      (perror p "Undeclared XML prefix" prefix))
+                  (null-xml-namespace-iri))))))))
 \f
 ;;;; Processing instructions
 
@@ -695,7 +691,7 @@ USA.
          parse-attribute-value))))
 
 (define parse-declaration-attributes
-  (attribute-list-parser (*parser (map xml-intern (match match-name)))))
+  (attribute-list-parser (*parser (map make-xml-qname (match match-name)))))
 
 (define parse-attribute-list
   (attribute-list-parser parse-uninterned-name))
@@ -1069,8 +1065,8 @@ USA.
         parse-required-element-name
         S
         ;;[46]
-        (alt (map xml-intern (match "EMPTY"))
-             (map xml-intern (match "ANY"))
+        (alt (map make-xml-qname (match "EMPTY"))
+             (map make-xml-qname (match "ANY"))
              ;;[51]
              (encapsulate vector->list
                (with-pointer p
@@ -1124,14 +1120,14 @@ USA.
 
 (define parse-!attlist-type            ;[54,57]
   (*parser
-   (alt (map xml-intern
+   (alt (map make-xml-qname
             ;;[55,56]
             (match (alt "CDATA" "IDREFS" "IDREF" "ID"
                         "ENTITY" "ENTITIES" "NMTOKENS" "NMTOKEN")))
        ;;[58]
        (encapsulate vector->list
          (bracket "notation type"
-             (seq (map xml-intern (match "NOTATION"))
+             (seq (map make-xml-qname (match "NOTATION"))
                   S
                   "(")
              ")"

diff --git a/v7/src/xml/xml-struct.scm b/v7/src/xml/xml-struct.scm
index 0d50f334b1544283039b94dc0fa7c1ef3a52a075..ea860bf99de34af48671f6e908846127d9e869ca 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.34 2003/09/26 01:00:14 cph Exp $
+$Id: xml-struct.scm,v 1.35 2003/09/26 03:56:58 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -27,259 +27,6 @@ USA.
 
 (declare (usual-integrations))
 \f
-(define-record-type <combo-name>
-    (make-combo-name qname expanded)
-    combo-name?
-  (qname combo-name-qname)
-  (expanded combo-name-expanded))
-
-(set-record-type-unparser-method! <combo-name>
-  (standard-unparser-method 'XML-NAME
-    (lambda (name port)
-      (write-char #\space port)
-      (write (combo-name-qname name) port))))
-
-(define-record-type <expanded-name>
-    (make-expanded-name iri local combos)
-    expanded-name?
-  (iri expanded-name-iri)
-  (local expanded-name-local)
-  (combos expanded-name-combos))
-
-(define (xml-name? object)
-  (or (and (interned-symbol? object)
-          (string-is-xml-name? (symbol-name object)))
-      (combo-name? object)))
-
-(define (guarantee-xml-name object caller)
-  (if (not (xml-name? object))
-      (error:not-xml-name object caller)))
-
-(define (error:not-xml-name object caller)
-  (error:wrong-type-argument object "an XML name" caller))
-
-(define (make-xml-namespace-iri iri)
-  (if (string? iri)
-      (begin
-       (if (not (namespace-iri-string? iri))
-           (error:not-xml-namespace-iri iri 'MAKE-XML-NAMESPACE-IRI))
-       (string->symbol iri))
-      (begin
-       (guarantee-xml-namespace-iri iri 'MAKE-XML-NAMESPACE-IRI)
-       iri)))
-
-(define (xml-namespace-iri? object)
-  (and (interned-symbol? object)
-       (namespace-iri-string? (symbol-name object))))
-
-(define (namespace-iri-string? object)
-  ;; See RFC 1630 for correct syntax.
-  (utf8-string-valid? object))
-
-(define (null-xml-namespace-iri? object)
-  (eq? object '||))
-
-(define (null-xml-namespace-iri)
-  '||)
-
-(define (guarantee-xml-namespace-iri object caller)
-  (if (not (xml-namespace-iri? object))
-      (error:not-xml-namespace-iri object caller)))
-
-(define (error:not-xml-namespace-iri object caller)
-  (error:wrong-type-argument object "an XML namespace IRI" caller))
-
-(define (xml-namespace-iri->string iri)
-  (guarantee-xml-namespace-iri iri 'XML-NAMESPACE-IRI->STRING)
-  (symbol->string iri))
-\f
-(define (xml-intern qname #!optional iri)
-  (make-xml-name qname
-                (if (default-object? iri)
-                    (null-xml-namespace-iri)
-                    iri)))
-
-(define (make-xml-name qname iri)
-  (let ((bad-name
-        (lambda ()
-          (error:wrong-type-argument qname "an XML name" 'MAKE-XML-NAME)))
-       (bad-iri
-        (lambda ()
-          (error:wrong-type-argument iri "IRI" 'MAKE-XML-NAME))))
-    (receive (string symbol)
-       (cond ((symbol? qname) (values (symbol-name qname) qname))
-             ((string? qname) (values qname (string->symbol qname)))
-             (else (bad-name)))
-      (let ((type (string-is-xml-nmtoken? string)))
-       (cond ((and type (null-xml-namespace-iri? iri))
-              symbol)
-             ((eq? type 'NAME)
-              (let ((iri (make-xml-namespace-iri iri)))
-                (%make-xml-name
-                 symbol
-                 iri
-                 (let ((c (string-find-next-char string #\:)))
-                   (if c
-                       (let ((prefix (string-head->symbol string c))
-                             (local (string-tail->symbol string (fix:+ c 1))))
-                         (if (or (and (eq? prefix 'xml)
-                                      (not (eq? iri xml-iri)))
-                                 (and (eq? prefix 'xmlns)
-                                      (not (eq? iri xmlns-iri))))
-                             (bad-iri))
-                         local)
-                       symbol)))))
-             (else (bad-name)))))))
-
-(define (%make-xml-name qname iri local)
-  (let ((uname
-        (hash-table/intern! (hash-table/intern! expanded-names
-                                                iri
-                                                make-eq-hash-table)
-                            local
-                            (lambda ()
-                              (make-expanded-name iri
-                                                  local
-                                                  (make-eq-hash-table))))))
-    (hash-table/intern! (expanded-name-combos uname)
-                       qname
-                       (lambda () (make-combo-name qname uname)))))
-
-(define expanded-names
-  (make-eq-hash-table))
-
-(define xml-iri
-  (make-xml-namespace-iri "http://www.w3.org/XML/1998/namespace"))
-
-(define xmlns-iri
-  (make-xml-namespace-iri "http://www.w3.org/2000/xmlns/"))
-\f
-(define (xml-name-qname name)
-  (cond ((xml-nmtoken? name) name)
-       ((combo-name? name) (combo-name-qname name))
-       (else (error:not-xml-name name 'XML-NAME-QNAME))))
-
-(define (xml-name-qname=? name qname)
-  (eq? (xml-name-qname name) qname))
-
-(define (xml-name-string name)
-  (symbol-name (xml-name-qname name)))
-
-(define (xml-name-iri name)
-  (cond ((xml-nmtoken? name) (null-xml-namespace-iri))
-       ((combo-name? name) (expanded-name-iri (combo-name-expanded name)))
-       (else (error:not-xml-name name 'XML-NAME-IRI))))
-
-(define (xml-name-iri=? name iri)
-  (eq? (xml-name-iri name) iri))
-
-(define (xml-name-prefix name)
-  (let ((s
-        (symbol-name
-         (cond ((xml-nmtoken? name) name)
-               ((combo-name? name) (combo-name-qname name))
-               (else (error:not-xml-name name 'XML-NAME-PREFIX))))))
-    (let ((c (string-find-next-char s #\:)))
-      (if c
-         (string-head->symbol s c)
-         (null-xml-name-prefix)))))
-
-(define (null-xml-name-prefix? object)
-  (eq? object '||))
-
-(define (null-xml-name-prefix)
-  '||)
-
-(define (xml-name-prefix=? name prefix)
-  (eq? (xml-name-prefix name) prefix))
-
-(define (xml-name-local name)
-  (cond ((xml-nmtoken? name)
-        (let ((s (symbol-name name)))
-          (let ((c (string-find-next-char s #\:)))
-            (if c
-                (string-tail->symbol s (fix:+ c 1))
-                name))))
-       ((combo-name? name) (expanded-name-local (combo-name-expanded name)))
-       (else (error:not-xml-name name 'XML-NAME-LOCAL))))
-
-(define (xml-name-local=? name local)
-  (eq? (xml-name-local name) local))
-
-(define (xml-name=? n1 n2)
-  (let ((lose (lambda (n) (error:not-xml-name n 'XML-NAME=?))))
-    (cond ((xml-nmtoken? n1)
-          (cond ((xml-nmtoken? n2) (eq? n1 n2))
-                ((combo-name? n2) (eq? n1 (combo-name-qname n2)))
-                (else (lose n2))))
-         ((combo-name? n1)
-          (cond ((xml-nmtoken? n2)
-                 (eq? (combo-name-qname n1) n2))
-                ((combo-name? n2)
-                 (eq? (combo-name-expanded n1)
-                      (combo-name-expanded n2)))
-                (else (lose n2))))
-         (else (lose n1)))))
-
-(define (xml-name-hash name modulus)
-  (eq-hash-mod (xml-name-local name) modulus))
-
-(define make-xml-name-hash-table
-  (strong-hash-table/constructor xml-name-hash xml-name=? #t))
-\f
-(define (xml-nmtoken? object)
-  (and (symbol? object)
-       (string-is-xml-nmtoken? (symbol-name object))))
-
-(define (string-is-xml-name? string)
-  (eq? (string-is-xml-nmtoken? string) 'NAME))
-
-(define (string-is-xml-nmtoken? string)
-  (let ((buffer (string->parser-buffer string)))
-    (let ((check-char
-          (lambda ()
-            (match-utf8-char-in-alphabet buffer alphabet:name-subsequent))))
-      (letrec
-         ((no-colon
-           (lambda ()
-             (cond ((match-parser-buffer-char buffer #\:)
-                    (colon))
-                   ((peek-parser-buffer-char buffer)
-                    (and (check-char)
-                         (no-colon)))
-                   (else 'NAME))))
-          (colon
-           (lambda ()
-             (cond ((match-parser-buffer-char buffer #\:)
-                    (nmtoken?))
-                   ((peek-parser-buffer-char buffer)
-                    (and (check-char)
-                         (colon)))
-                   (else 'NAME))))
-          (nmtoken?
-           (lambda ()
-             (if (peek-parser-buffer-char buffer)
-                 (and (check-char)
-                      (nmtoken?))
-                 'NMTOKEN))))
-       (if (match-utf8-char-in-alphabet buffer alphabet:name-initial)
-           (no-colon)
-           (and (check-char)
-                (nmtoken?)))))))
-
-(define (xml-whitespace-string? object)
-  (string-composed-of? object char-set:xml-whitespace))
-
-(define (string-composed-of? string char-set)
-  (and (string? string)
-       (substring-composed-of? string 0 (string-length string) char-set)))
-
-(define (substring-composed-of? string start end char-set)
-  (let loop ((index start))
-    (or (fix:= index end)
-       (and (char-set-member? char-set (string-ref string index))
-            (loop (fix:+ index 1))))))
-\f
 (define-syntax define-xml-type
   (sc-macro-transformer
    (lambda (form environment)
@@ -360,6 +107,9 @@ USA.
          (xml-whitespace-string? object)
          (xml-processing-instructions? object)))))
 
+(define (xml-whitespace-string? object)
+  (string-composed-of? object char-set:xml-whitespace))
+
 (define-xml-type declaration
   (version xml-version?)
   (encoding xml-encoding?)
@@ -431,7 +181,7 @@ USA.
 (define-xml-type processing-instructions
   (name
    (lambda (object)
-     (and (xml-name? object)
+     (and (xml-qname? object)
          (not (string-ci=? "xml" (symbol-name object))))))
   (text xml-char-data? canonicalize-char-data))
 \f
@@ -520,14 +270,14 @@ USA.
                  (string->char-set " \r\n-'()+,./:=?;!*#@$_%")))
 
 (define-xml-type !element
-  (name xml-name?)
+  (name xml-qname?)
   (content-type
    (lambda (object)
      (or (eq? object '|EMPTY|)
         (eq? object '|ANY|)
         (and (pair? object)
              (eq? '|#PCDATA| (car object))
-             (list-of-type? (cdr object) xml-name?))
+             (list-of-type? (cdr object) xml-qname?))
         (letrec
             ((children?
               (lambda (object)
@@ -539,7 +289,7 @@ USA.
                          (list-of-type? (cdr object) cp?))))))
              (cp?
               (lambda (object)
-                (or (maybe-wrapped object xml-name?)
+                (or (maybe-wrapped object xml-qname?)
                     (children? object))))
              (maybe-wrapped
               (lambda (object pred)
@@ -554,13 +304,13 @@ USA.
           (children? object))))))
 \f
 (define-xml-type !attlist
-  (name xml-name?)
+  (name xml-qname?)
   (definitions
     (lambda (object)
       (list-of-type? object
        (lambda (item)
          (and (pair? item)
-              (xml-name? (car item))
+              (xml-qname? (car item))
               (pair? (cdr item))
               (!attlist-type? (cadr item))
               (pair? (cddr item))
@@ -587,7 +337,7 @@ USA.
       (eq? object '|NMTOKEN|)
       (and (pair? object)
           (eq? '|NOTATION| (car object))
-          (list-of-type? (cdr object) xml-name?))
+          (list-of-type? (cdr object) xml-qname?))
       (and (pair? object)
           (eq? 'enumerated (car object))
           (list-of-type? (cdr object) xml-nmtoken?))))
@@ -603,16 +353,16 @@ USA.
           (xml-attribute-value? (cdr object)))))
 \f
 (define-xml-type !entity
-  (name xml-name?)
+  (name xml-qname?)
   (value entity-value? canonicalize-entity-value))
 
 (define-xml-type unparsed-!entity
-  (name xml-name?)
+  (name xml-qname?)
   (id xml-external-id?)
-  (notation xml-name?))
+  (notation xml-qname?))
 
 (define-xml-type parameter-!entity
-  (name xml-name?)
+  (name xml-qname?)
   (value entity-value? canonicalize-entity-value))
 
 (define (entity-value? object)
@@ -625,14 +375,14 @@ USA.
       (xml-external-id? object)))
 
 (define-xml-type !notation
-  (name xml-name?)
+  (name xml-qname?)
   (id xml-external-id?))
 
 (define-xml-type entity-ref
-  (name xml-name?))
+  (name xml-qname?))
 
 (define-xml-type parameter-entity-ref
-  (name xml-name?))
+  (name xml-qname?))
 
 (define-syntax define-xml-printer
   (sc-macro-transformer
@@ -707,7 +457,7 @@ USA.
         (make-xml-namespace-iri (guarantee-xml-attribute-value attr)))))
 
 (define (xml-element-namespace-prefix elt iri)
-  (let ((iri (xml-namespace-iri->string iri)))
+  (let ((iri (xml-namespace-iri-string iri)))
     (let ((attr
           (find-matching-item (xml-element-attributes elt)
             (lambda (attr)

diff --git a/v7/src/xml/xml.pkg b/v7/src/xml/xml.pkg
index 414ec0f2e1228410be2d9ae4634750d41088f657..088f3fb4d43b5da558a0c4d1c298f8196e47b1d3 100644 (file)
--- a/v7/src/xml/xml.pkg
+++ b/v7/src/xml/xml.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: xml.pkg,v 1.32 2003/09/26 01:00:07 cph Exp $
+$Id: xml.pkg,v 1.33 2003/09/26 03:56:45 cph Exp $
 
 Copyright 2001,2002,2003 Massachusetts Institute of Technology
 
@@ -32,6 +32,55 @@ USA.
 (define-package (runtime xml)
   (parent (runtime)))
 
+(define-package (runtime xml names)
+  (files "xml-names")
+  (parent (runtime xml))
+  (export ()
+         <xml-namespace-iri>
+         error:not-xml-name
+         error:not-xml-namespace-iri
+         error:not-xml-nmtoken
+         error:not-xml-qname
+         guarantee-xml-name
+         guarantee-xml-namespace-iri
+         guarantee-xml-nmtoken
+         guarantee-xml-qname
+         make-xml-name
+         make-xml-name-hash-table
+         make-xml-namespace-iri
+         make-xml-nmtoken
+         make-xml-qname
+         null-xml-name-prefix
+         null-xml-name-prefix?
+         null-xml-namespace-iri
+         null-xml-namespace-iri?
+         xml-iri
+         xml-name-hash
+         xml-name-iri
+         xml-name-iri=?
+         xml-name-local
+         xml-name-local=?
+         xml-name-prefix
+         xml-name-prefix=?
+         xml-name-qname
+         xml-name-qname=?
+         xml-name-string
+         xml-name=?
+         xml-name?
+         xml-namespace-iri-string
+         xml-namespace-iri?
+         xml-nmtoken-string
+         xml-nmtoken?
+         xml-qname-local
+         xml-qname-prefix
+         xml-qname-string
+         xml-qname?
+         xmlns-iri)
+  (export (runtime xml)
+         %make-xml-name
+         string-composed-of?
+         substring-composed-of?))
+
 (define-package (runtime xml structure)
   (files "xml-struct")
   (parent (runtime xml))
@@ -63,8 +112,6 @@ USA.
          error:not-xml-element
          error:not-xml-entity-ref
          error:not-xml-external-id
-         error:not-xml-name
-         error:not-xml-namespace-iri
          error:not-xml-parameter-!entity
          error:not-xml-parameter-entity-ref
          error:not-xml-processing-instructions
@@ -81,8 +128,6 @@ USA.
          guarantee-xml-element
          guarantee-xml-entity-ref
          guarantee-xml-external-id
-         guarantee-xml-name
-         guarantee-xml-namespace-iri
          guarantee-xml-parameter-!entity
          guarantee-xml-parameter-entity-ref
          guarantee-xml-processing-instructions
@@ -98,17 +143,10 @@ USA.
          make-xml-element
          make-xml-entity-ref
          make-xml-external-id
-         make-xml-name
-         make-xml-name-hash-table
-         make-xml-namespace-iri
          make-xml-parameter-!entity
          make-xml-parameter-entity-ref
          make-xml-processing-instructions
          make-xml-unparsed-!entity
-         null-xml-name-prefix
-         null-xml-name-prefix?
-         null-xml-namespace-iri
-         null-xml-namespace-iri?
          set-xml-!attlist-definitions!
          set-xml-!attlist-name!
          set-xml-!element-content-type!
@@ -136,7 +174,6 @@ USA.
          set-xml-entity-ref-name!
          set-xml-external-id-id!
          set-xml-external-id-iri!
-         (set-xml-external-id-uri! set-xml-external-id-iri!)
          set-xml-parameter-!entity-name!
          set-xml-parameter-!entity-value!
          set-xml-parameter-entity-ref-name!
@@ -192,25 +229,7 @@ USA.
          xml-entity-ref?
          xml-external-id-id
          xml-external-id-iri
-         (xml-external-id-uri xml-external-id-iri)
          xml-external-id?
-         xml-intern
-         xml-iri
-         xml-name-hash
-         xml-name-local
-         xml-name-local=?
-         xml-name-prefix
-         xml-name-prefix=?
-         xml-name-qname
-         xml-name-qname=?
-         xml-name-string
-         xml-name-iri
-         xml-name-iri=?
-         xml-name=?
-         xml-name?
-         xml-namespace-iri->string
-         xml-namespace-iri?
-         xml-nmtoken?
          xml-parameter-!entity-name
          xml-parameter-!entity-value
          xml-parameter-!entity?
@@ -223,10 +242,7 @@ USA.
          xml-unparsed-!entity-name
          xml-unparsed-!entity-notation
          xml-unparsed-!entity?
-         xml-whitespace-string?
-         xmlns-iri)
-  (export (runtime xml parser)
-         %make-xml-name))
+         xml-whitespace-string?))
 
 (define-package (runtime xml parser)
   (files "xml-chars" "xml-parser")