-eduni/namespaces/1.0/012.xml [not validating:] FAILED:

-  well-formedness violation not detected
-[
-Namespace inequality test: equal after attribute value normalization
-]

XMLCONF

@@ -1796,11 +1796,7 @@ eduni/namespaces/1.0/008.xml [not validating:] input [validating:] input
 eduni/namespaces/1.0/009.xml [not validating:] not-wf [validating:] not-wf
 eduni/namespaces/1.0/010.xml [not validating:] not-wf [validating:] not-wf
 eduni/namespaces/1.0/011.xml [not validating:] not-wf [validating:] not-wf
-eduni/namespaces/1.0/012.xml [not validating:] FAILED:
+eduni/namespaces/1.0/012.xml [not validating:] not-wf [validating:] not-wf
-  well-formedness violation not detected
-[
-Namespace inequality test: equal after attribute value normalization
-]
 eduni/namespaces/1.0/013.xml [not validating:] FAILED:
   #(98 58 97 116 116 114) fell through ETYPECASE expression.
   Wanted one of (STRING SIMPLE-STRING).
@@ -1868,4 +1864,4 @@ eduni/namespaces/1.0/046.xml [not validating:] input [validating:] FAILED:
 [
 Colon in ID attribute name
 ]
-9/1829 tests failed; 333 tests were skipped
+8/1829 tests failed; 333 tests were skipped

test/xmlconf.lisp

@@ -70,7 +70,7 @@
     (with-open-file (*standard-output*
 		     (merge-pathnames "XMLCONF" base)
 		     :direction :output
-		     :external-format :iso-8859-1
+;;;		     :external-format :iso-8859-1
 		     :if-exists :supersede)
       (run-all-tests directory))))
 
@@ -195,9 +195,4 @@
       t)))
 
 #+(or)
-(xmlconf::run-all-tests "/mnt/debian/space/xmlconf/")
+(xmlconf::dribble-tests "/home/david/2001/XML-Test-Suite/xmlconf/")
-
-#+(or)
-(progn
-  (#+allegro mp:with-timeout #+allegro (60) #-allegro progn
-             ))

xml/xml-parse.lisp

@@ -183,12 +183,8 @@
 
 (defvar *ctx*)
 
-;; forward declaration for DEFVAR
-(declaim (special *default-namespace-bindings*))
-
 (defstruct (context (:conc-name nil))
   handler
-  (namespace-bindings *default-namespace-bindings*)
   (dtd nil)
   model-stack
   (referenced-notations '())
@@ -202,6 +198,11 @@
 
 (defvar *expand-pe-p* nil)
 
+(defparameter *namespace-bindings*
+  '((#"" . nil)
+    (#"xmlns" . #"http://www.w3.org/2000/xmlns/")
+    (#"xml" . #"http://www.w3.org/XML/1998/namespace")))
+
 ;;;; ---------------------------------------------------------------------------
 ;;;; xstreams
 ;;;;
@@ -701,6 +702,8 @@
          (elmdef (elmdef-external-p def))
          (attdef (attdef-external-p def)))))
 
+;; attribute validation, defaulting, and normalization -- except for for
+;; uniqueness checks, which are done after namespaces have been declared
 (defun process-attributes (ctx name attlist)
   (let ((e (find-element name (dtd ctx))))
     (cond
@@ -716,11 +719,11 @@
               (t
                 (when (standalone-check-necessary-p ad)
                   (validity-error "(02) Standalone Document Declaration: missing attribute value"))
-                (push (build-attribute (attdef-name ad)
+                (push (sax:make-attribute :qname (attdef-name ad)
-                                       (cadr (attdef-default ad))
+					  :value (cadr (attdef-default ad))
-                                       nil)
+					  :specified-p nil)
                       attlist)))))
-        (dolist (a attlist)             ;normalize non-CDATA values
+        (dolist (a attlist)		;normalize non-CDATA values
           (let* ((qname (sax:attribute-qname a))
                  (adef (find-attribute e qname)))
             (when (and adef (not (eq (attdef-type adef) :CDATA)))
@@ -729,7 +732,7 @@
                            (not (rod= (sax:attribute-value a) canon)))
                   (validity-error "(02) Standalone Document Declaration: attribute value not normalized"))
                 (setf (sax:attribute-value a) canon)))))
-        (when *validate*                ;maybe validate attribute values
+        (when *validate*		;maybe validate attribute values
           (dolist (a attlist)
             (validate-attribute ctx e a))))
       ((and *validate* attlist)
@@ -2607,66 +2610,52 @@
       (sax:end-document handler))))
 
 (defun p/element (input)
-  (if sax:*namespace-processing*
-      (p/element-ns input)
-      (p/element-no-ns input)))
-
-(defun p/element-no-ns (input)
-  ;;    [39] element ::= EmptyElemTag | STag content ETag
-  (error "sorry, bitrot")
-  (multiple-value-bind (cat sem) (read-token input)
-    (cond ((eq cat :ztag)
-	   (sax:start-element (handler *ctx*) nil nil (car sem) (build-attribute-list-no-ns (cdr sem)))
-	   (sax:end-element (handler *ctx*) nil nil (car sem)))
-
-          ((eq cat :stag)
-	   (sax:start-element (handler *ctx*) nil nil (car sem) (build-attribute-list-no-ns (cdr sem)))
-	   (p/content input)
-	   (multiple-value-bind (cat2 sem2) (read-token input)
-               (unless (and (eq cat2 :etag)
-                            (eq (car sem2) (car sem)))
-                 (wf-error input "Bad nesting. ~S / ~S" (mu sem) (mu (cons cat2 sem2)))))
-	   (sax:end-element (handler *ctx*) nil nil (car sem)))
-
-          (t
-           (wf-error input "Expecting element.")))))
-
-
-(defun p/element-ns (input)
   (multiple-value-bind (cat sem) (read-token input)
     (case cat
       ((:stag :ztag))
       (:eof (eox input))
       (t (wf-error input "element expected")))
-    (destructuring-bind (&optional name &rest attrs) sem
+    (destructuring-bind (&optional name &rest raw-attrs) sem
       (validate-start-element *ctx* name)
-      (let ((ns-decls (declare-namespaces name attrs)))
+      (let* ((attrs
-	(multiple-value-bind (ns-uri prefix local-name) (decode-qname name)
+	      (process-attributes *ctx* name (build-attribute-list raw-attrs)))
+	     (*namespace-bindings* *namespace-bindings*)
+	     new-namespaces)
+	(when sax:*namespace-processing*
+	  (setf new-namespaces (declare-namespaces attrs))
+	  (mapc #'set-attribute-namespace attrs))
+	(multiple-value-bind (uri prefix local-name)
+	    (if sax:*namespace-processing*
+		(decode-qname name)
+		(values nil nil nil))
 	  (declare (ignore prefix))
-	  (let* ((raw-attlist (build-attribute-list-ns attrs))
+	  (check-attribute-uniqueness attrs)
-		 (attlist
+	  (unless (or sax:*include-xmlns-attributes*
-		  (remove-if-not (lambda (a)
+		      (null sax:*namespace-processing*))
-				   (or sax:*include-xmlns-attributes*
+	    (setf attrs
-				       (not (xmlns-attr-p (sax:attribute-qname a)))))
+		  (remove-if (compose #'xmlns-attr-p #'sax:attribute-qname)
-				 (process-attributes *ctx* name raw-attlist))))
+			     attrs))) 
-	    (cond ((eq cat :ztag)
+	  (cond
-		    (sax:start-element (handler *ctx*) ns-uri local-name name attlist)
+	    ((eq cat :ztag)
-		    (sax:end-element (handler *ctx*) ns-uri local-name name))
+	      (sax:start-element (handler *ctx*) uri local-name name attrs)
+	      (sax:end-element (handler *ctx*) uri local-name name))
 		
-	      ((eq cat :stag)
+	    ((eq cat :stag)
-		(sax:start-element (handler *ctx*) ns-uri local-name name attlist)
+	      (sax:start-element (handler *ctx*) uri local-name name attrs)
-		(p/content input)
+	      (p/content input)
-		(multiple-value-bind (cat2 sem2) (read-token input)
+	      (multiple-value-bind (cat2 sem2) (read-token input)
-		  (unless (and (eq cat2 :etag)
+		(unless (and (eq cat2 :etag)
-			       (eq (car sem2) name))
+			     (eq (car sem2) name))
-		    (wf-error input "Bad nesting. ~S / ~S" (mu name) (mu (cons cat2 sem2))))
+		  (wf-error input "Bad nesting. ~S / ~S"
-		  (when (cdr sem2)
+			    (mu name)
-		    (wf-error input "no attributes allowed in end tag")))
+			    (mu (cons cat2 sem2))))
-		(sax:end-element (handler *ctx*) ns-uri local-name name))
+		(when (cdr sem2)
+		  (wf-error input "no attributes allowed in end tag")))
+	      (sax:end-element (handler *ctx*) uri local-name name))
 		
-	      (t
+	    (t
-		(wf-error input "Expecting element, got ~S." cat)))))
+	      (wf-error input "Expecting element, got ~S." cat))))
-	(undeclare-namespaces ns-decls))
+	(undeclare-namespaces new-namespaces))
       (validate-end-element *ctx* name))))
 
 (defun p/content (input)
@@ -3323,11 +3312,6 @@
 
 ;;; Namespace stuff
 
-(defvar *default-namespace-bindings*
-  '((#"" . nil)
-    (#"xmlns" . #"http://www.w3.org/2000/xmlns/")
-    (#"xml" . #"http://www.w3.org/XML/1998/namespace")))
-
 ;; We already know that name is part of a valid XML name, so all we
 ;; have to check is that the first rune is a name-start-rune and that
 ;; there is not colon in it.
@@ -3357,7 +3341,7 @@
 
 
 (defun find-namespace-binding (prefix)
-  (cdr (or (assoc (or prefix #"") (namespace-bindings *ctx*) :test #'rod=)
+  (cdr (or (assoc (or prefix #"") *namespace-bindings* :test #'rod=)
 	   (wf-error nil "Undeclared namespace prefix: ~A" (rod-string prefix)))))
 
 ;; FIXME: Should probably be refactored by adding :start and :end to rod=/rod-equal
@@ -3375,33 +3359,17 @@
       (subseq attrname 6)
       nil))
 
-(defun find-namespace-declarations (element attr-alist)
+(defun find-namespace-declarations (attributes)
-  (let ((result
+  (loop
-         (mapcar #'(lambda (attr)
+      for attribute in attributes
-                     (cons (attrname->prefix (car attr)) (cdr attr)))
+      for qname = (sax:attribute-qname attribute)
-                 (remove-if-not #'xmlns-attr-p attr-alist :key #'car))))
+      when (xmlns-attr-p qname)
-    ;; Argh!  PROCESS-ATTRIBUTES needs to know the attributes' namespaces
+      collect (cons (attrname->prefix qname) (sax:attribute-value attribute))))
-    ;; already.  But namespace declarations can be done using default values
-    ;; in the DTD.  So we need to handle defaulting of attribute values twice,
-    ;; once for xmlns attributes, then for all others.  (I really hope I'm
-    ;; wrong on this one, but I don't see how.)
-    (let ((e (find-element element (dtd *ctx*))))
-      (when e
-        (dolist (ad (elmdef-attributes e)) ;handle default values
-          (let* ((name (attdef-name ad))
-                 (prefix (attrname->prefix name)))
-            (when (and (xmlns-attr-p name)
-                       (not (member prefix result :key #'car :test #'rod=))
-                       (listp (attdef-default ad)) ;:DEFAULT or :FIXED
-                       )
-              (push (cons prefix (cadr (attdef-default ad))) result))))))
-    result))
 
-(defun declare-namespaces (element attr-alist)
+(defun declare-namespaces (attributes)
-  (let ((ns-decls (find-namespace-declarations element attr-alist)))
+  (let ((ns-decls (find-namespace-declarations attributes)))
-    (dolist (ns-decl ns-decls )
+    (dolist (ns-decl ns-decls)
       ;; check some namespace validity constraints
-      ;; FIXME: Would be nice to add "this is insane, go ahead" restarts
       (let ((prefix (car ns-decl))
 	    (uri (if (rod= #"" (cdr ns-decl))
 		     nil
@@ -3438,7 +3406,7 @@
                       may be bound to an empty namespace URI, thus ~
                       undeclaring it."))
 	  (t
-	   (push (cons prefix uri) (namespace-bindings *ctx*))
+	   (push (cons prefix uri) *namespace-bindings*)
 	   (sax:start-prefix-mapping (handler *ctx*)
 				     (car ns-decl)
 				     (cdr ns-decl))))))
@@ -3446,62 +3414,53 @@
 
 (defun undeclare-namespaces (ns-decls)
   (dolist (ns-decl ns-decls)
-    (setf (namespace-bindings *ctx*) (delete ns-decl (namespace-bindings *ctx*)))
     (sax:end-prefix-mapping (handler *ctx*) (car ns-decl))))
 
-(defun build-attribute-list-no-ns (attr-alist)
+(defun build-attribute-list (attr-alist)
-  (mapcar #'(lambda (pair)
+  ;; fixme: if there is a reason this function reverses attribute order,
-              (sax:make-attribute :qname (car pair)
+  ;; it should be documented.
-                                  :value (cdr pair)
-                                  :specified-p t))
-	  attr-alist))
-
-;; FIXME: Use a non-braindead way to enforce attribute uniqueness
-(defun build-attribute-list-ns (attr-alist)
   (let (attributes)
     (dolist (pair attr-alist)
-      (push (build-attribute (car pair) (cdr pair) t) attributes))
+      (push (sax:make-attribute :qname (car pair)
+				:value (cdr pair)
+				:specified-p t)
+	    attributes))
+    attributes))
 
-    ;; 5.3 Uniqueness of Attributes
+(defun check-attribute-uniqueness (attributes)
-    ;; In XML documents conforming to [the xmlns] specification, no
+  ;; 5.3 Uniqueness of Attributes
-    ;; tag may contain two attributes which:
+  ;; In XML documents conforming to [the xmlns] specification, no
-    ;; 1. have identical names, or
+  ;; tag may contain two attributes which:
-    ;; 2. have qualified names with the same local part and with
+  ;; 1. have identical names, or
-    ;; prefixes which have been bound to namespace names that are
+  ;; 2. have qualified names with the same local part and with
-    ;; identical.
+  ;; prefixes which have been bound to namespace names that are
-    ;;
+  ;; identical.
-    ;; 1. is checked by read-tag-2, so we only deal with 2 here
+  ;;
-    (do ((sublist attributes (cdr sublist)))
+  ;; 1. is checked by read-tag-2, so we only deal with 2 here
-	((null sublist) attributes)
+  (loop for (attr-1 . rest) on attributes do
-      (let ((attr-1 (car sublist)))
 	(when (and (sax:attribute-namespace-uri attr-1)
-		   (find-if #'(lambda (attr-2)
+		   (find-if (lambda (attr-2)
-				(and (rod= (sax:attribute-namespace-uri attr-1)
+			      (and (rod= (sax:attribute-namespace-uri attr-1)
-					   (sax:attribute-namespace-uri attr-2))
+					 (sax:attribute-namespace-uri attr-2))
-				     (rod= (sax:attribute-local-name attr-1)
+				   (rod= (sax:attribute-local-name attr-1)
-					   (sax:attribute-local-name attr-2))))
+					 (sax:attribute-local-name attr-2))))
-		       (cdr sublist)))
+			    rest))
 	  (wf-error nil
 		    "Multiple definitions of attribute ~S in namespace ~S."
 		    (mu (sax:attribute-local-name attr-1))
-		    (mu (sax:attribute-namespace-uri attr-1))))))))
+		    (mu (sax:attribute-namespace-uri attr-1))))))
 
-(defun build-attribute (name value specified-p)
+(defun set-attribute-namespace (attribute)
-  (multiple-value-bind (prefix local-name) (split-qname name)
+  (let ((qname (sax:attribute-qname attribute)))
-    (declare (ignorable local-name))
+    (multiple-value-bind (prefix local-name) (split-qname qname)
-    (if (or (not prefix) ;; default namespace doesn't apply to attributes
+      (declare (ignorable local-name))
-	    (and (rod= #"xmlns" prefix) (not sax:*use-xmlns-namespace*)))
+      (when (and prefix ;; default namespace doesn't apply to attributes
-	(sax:make-attribute :qname name
+		 (or (not (rod= #"xmlns" prefix)) sax:*use-xmlns-namespace*))
-                            :value value
-                            :specified-p specified-p)
 	(multiple-value-bind (uri prefix local-name)
-	    (decode-qname name)
+	    (decode-qname qname)
 	  (declare (ignore prefix))
-	  (sax:make-attribute :qname name
+	  (setf (sax:attribute-namespace-uri attribute) uri)
-                              :value value
+	  (setf (sax:attribute-local-name attribute) local-name))))))
-                              :namespace-uri uri
-                              :local-name local-name
-                              :specified-p specified-p)))))
 
 ;;;;;;;;;;;;;;;;;