parse.lisp

   1 (in-package :cxml-rng)
   2
   3 #+sbcl
   4 (declaim (optimize (debug 2)))
   5
   6
   7 ;;;; Errors
   8
   9 (define-condition rng-error (simple-error) ())
  10
  11 (defun rng-error (source fmt &rest args)
  12   (let ((s (make-string-output-stream)))
  13     (apply #'format s fmt args)
  14     (when source
  15       (format s "~&  [ Error at line ~D, column ~D in ~S ]"
  16               (klacks:current-line-number source)
  17               (klacks:current-column-number source)
  18               (klacks:current-system-id source)))
  19     (error 'rng-error
  20            :format-control "~A"
  21            :format-arguments (list (get-output-stream-string s)))))
  22
  23
  24 ;;;; Parser
  25
  26 (defvar *datatype-library*)
  27 (defvar *namespace-uri*)
  28 (defvar *entity-resolver*)
  29 (defvar *external-href-stack*)
  30 (defvar *include-uri-stack*)
  31
  32 (defvar *debug* nil)
  33
  34 (defun invoke-with-klacks-handler (fn source)
  35   (if *debug*
  36       (funcall fn)
  37       (handler-case
  38           (funcall fn)
  39         (cxml:xml-parse-error (c)
  40           (rng-error source "Cannot parse schema: ~A" c)))))
  41
  42 (defun parse-relax-ng (input &key entity-resolver)
  43   (klacks:with-open-source (source (cxml:make-source input))
  44     (invoke-with-klacks-handler
  45      (lambda ()
  46        (klacks:find-event source :start-element)
  47        (let ((*datatype-library* "")
  48              (*namespace-uri* "")
  49              (*entity-resolver* entity-resolver)
  50              (*external-href-stack* '())
  51              (*include-uri-stack* '()))
  52          (p/pattern source)))
  53       source)))
  54
  55
  56 ;;;; pattern structures
  57 ;;;;
  58 ;;;; Before final simplification, all patterns are allowed.
  59 ;;;;
  60 ;;;; Afterwards, parent-ref has been removed, element appears only in define,
  61 ;;;; and define only in grammar, notallowed only in start or element, and
  62 ;;;; empty only in selected situations.
  63
  64 (defstruct pattern)
  65
  66 (defstruct (%parent (:include pattern) (:conc-name "PATTERN-"))
  67   child)
  68
  69 (defstruct (%named-pattern (:include %parent) (:conc-name "PATTERN-"))
  70   name)
  71 (defstruct (element (:include %named-pattern) (:conc-name "PATTERN-")))
  72 (defstruct (attribute (:include %named-pattern) (:conc-name "PATTERN-")))
  73
  74 (defstruct (%combination (:include pattern) (:conc-name "PATTERN-"))
  75   a b)
  76 (defstruct (group
  77             (:include %combination)
  78             (:constructor make-group (a b))))
  79 (defstruct (interleave
  80             (:include %combination)
  81             (:constructor make-interleave (a b))))
  82 (defstruct (choice
  83             (:include %combination)
  84             (:constructor make-choice (a b))))
  85
  86 (defstruct (one-or-more
  87             (:include %parent)
  88             (:constructor make-one-or-more (child))))
  89 (defstruct (list-pattern
  90             (:include %parent)
  91             (:constructor make-list-pattern (child))))
  92
  93 (defstruct (%ref (:include pattern) (:conc-name "PATTERN-"))
  94   ref-name)
  95 (defstruct (ref (:include %ref) (:conc-name "PATTERN-")))
  96 (defstruct (parent-ref (:include %ref) (:conc-name "PATTERN-")))
  97
  98 (defstruct (empty (:include pattern) (:conc-name "PATTERN-")))
  99 (defstruct (text (:include pattern) (:conc-name "PATTERN-")))
 100
 101 (defstruct (%typed-pattern (:include pattern) (:conc-name "PATTERN-"))
 102   datatype-library
 103   type)
 104
 105 (defstruct (value (:include %typed-pattern) (:conc-name "PATTERN-"))
 106   ns
 107   string)
 108
 109 (defstruct (data (:include %typed-pattern) (:conc-name "PATTERN-"))
 110   params
 111   except)
 112
 113 (defstruct (not-allowed (:include pattern) (:conc-name "PATTERN-")))
 114
 115 (defstruct (grammar (:include pattern) (:conc-name "PATTERN-"))
 116   content)
 117
 118
 119 ;;;; non-pattern
 120
 121 (defstruct param
 122   name
 123   string)
 124
 125 (defstruct start
 126   combine
 127   child)
 128
 129 (defstruct define
 130   name
 131   combine
 132   child)
 133
 134
 135 ;;;; parser
 136
 137 (defvar *rng-namespace* "http://relaxng.org/ns/structure/1.0")
 138
 139 (defun skip-foreign* (source)
 140   (loop
 141     (case (klacks:peek-next source)
 142       (:start-element (skip-foreign source))
 143       (:end-element (return)))))
 144
 145 (defun skip-to-native (source)
 146   (loop
 147     (case (klacks:peek source)
 148       (:start-element
 149         (when (equal (klacks:current-uri source) *rng-namespace*)
 150           (return))
 151         (klacks:serialize-element source nil))
 152       (:end-element (return)))
 153     (klacks:consume source)))
 154
 155 (defun consume-and-skip-to-native (source)
 156   (klacks:consume source)
 157   (skip-to-native source))
 158
 159 (defun skip-foreign (source)
 160   (when (equal (klacks:current-uri source) *rng-namespace*)
 161     (rng-error source
 162                "invalid schema: ~A not allowed here"
 163                (klacks:current-lname source)))
 164   (klacks:serialize-element source nil))
 165
 166 (defun attribute (lname attrs)
 167   (let ((a (sax:find-attribute-ns "" lname attrs)))
 168     (if a
 169         (sax:attribute-value a)
 170         nil)))
 171
 172 (defvar *whitespace*
 173     (format nil "~C~C~C"
 174             (code-char 9)
 175             (code-char 32)
 176             (code-char 13)
 177             (code-char 10)))
 178
 179 (defun ntc (lname source-or-attrs)
 180   ;; used for (n)ame, (t)ype, and (c)ombine, this also strings whitespace
 181   (let* ((attrs
 182           (if (listp source-or-attrs)
 183               source-or-attrs
 184               (klacks:list-attributes source-or-attrs)))
 185          (a (sax:find-attribute-ns "" lname attrs)))
 186     (if a
 187         (string-trim *whitespace* (sax:attribute-value a))
 188         nil)))
 189
 190 (defmacro with-library-and-ns (attrs &body body)
 191   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 192
 193 (defun invoke-with-library-and-ns (fn attrs)
 194   (let* ((dl (attribute "datatypeLibrary" attrs))
 195          (ns (attribute "ns" attrs))
 196          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 197          (*namespace-uri* (or ns *namespace-uri*)))
 198     (funcall fn)))
 199
 200 (defun p/pattern (source)
 201   (let* ((lname (klacks:current-lname source))
 202          (attrs (klacks:list-attributes source)))
 203     (with-library-and-ns attrs
 204       (case (find-symbol lname :keyword)
 205         (:|element|     (p/element source (ntc "name" attrs)))
 206         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 207         (:|group|       (p/combination #'groupify source))
 208         (:|interleave|  (p/combination #'interleave-ify source))
 209         (:|choice|      (p/combination #'choice-ify source))
 210         (:|optional|    (p/optional source))
 211         (:|zeroOrMore|  (p/zero-or-more source))
 212         (:|oneOrMore|   (p/one-or-more source))
 213         (:|list|        (p/list source))
 214         (:|mixed|       (p/mixed source))
 215         (:|ref|         (p/ref source))
 216         (:|parentRef|   (p/parent-ref source))
 217         (:|empty|       (p/empty source))
 218         (:|text|        (p/text source))
 219         (:|value|       (p/value source))
 220         (:|data|        (p/data source))
 221         (:|notAllowed|  (p/not-allowed source))
 222         (:|externalRef| (p/external-ref source))
 223         (:|grammar|     (p/grammar source))
 224         (t (skip-foreign source))))))
 225
 226 (defun p/pattern+ (source)
 227   (let ((children nil))
 228     (loop
 229       (case (klacks:peek source)
 230         (:start-element
 231           (let ((p (p/pattern source))) (when p (push p children))))
 232         (:end-element
 233           (return))
 234         (t
 235           (klacks:consume source))))
 236     (unless children
 237       (rng-error source "empty element"))
 238     (nreverse children)))
 239
 240 (defun p/pattern? (source)
 241   (let ((result nil))
 242     (loop
 243       (skip-to-native source)
 244       (case (klacks:peek source)
 245         (:start-element
 246           (when result
 247             (rng-error source "at most one pattern expected here"))
 248           (setf result (p/pattern source)))
 249         (:end-element
 250           (return))
 251         (t
 252           (klacks:consume source))))
 253     result))
 254
 255 (defun p/element (source name)
 256   (klacks:expecting-element (source "element")
 257     (let ((result (make-element)))
 258       (consume-and-skip-to-native source)
 259       (if name
 260           (setf (pattern-name result) (destructure-name source name))
 261           (setf (pattern-name result) (p/name-class source)))
 262       (skip-to-native source)
 263       (setf (pattern-child result) (groupify (p/pattern+ source)))
 264       result)))
 265
 266 (defvar *attribute-namespace-p* nil)
 267
 268 (defun p/attribute (source name)
 269   (klacks:expecting-element (source "attribute")
 270     (let ((result (make-attribute)))
 271       (consume-and-skip-to-native source)
 272       (if name
 273           (setf (pattern-name result)
 274                 (let ((*namespace-uri* ""))
 275                   (destructure-name source name)))
 276           (setf (pattern-name result)
 277                 (let ((*attribute-namespace-p* t))
 278                   (p/name-class source))))
 279       (skip-to-native source)
 280       (setf (pattern-child result)
 281             (or (p/pattern? source) (make-text)))
 282       result)))
 283
 284 (defun p/combination (zipper source)
 285   (klacks:expecting-element (source)
 286     (consume-and-skip-to-native source)
 287     (funcall zipper (p/pattern+ source))))
 288
 289 (defun p/one-or-more (source)
 290   (klacks:expecting-element (source "oneOrMore")
 291     (consume-and-skip-to-native source)
 292     (let ((children (p/pattern+ source)))
 293       (make-one-or-more (groupify children)))))
 294
 295 (defun p/zero-or-more (source)
 296   (klacks:expecting-element (source "zeroOrMore")
 297     (consume-and-skip-to-native source)
 298     (let ((children (p/pattern+ source)))
 299       (make-choice (make-one-or-more (groupify children))
 300                    (make-empty)))))
 301
 302 (defun p/optional (source)
 303   (klacks:expecting-element (source "optional")
 304     (consume-and-skip-to-native source)
 305     (let ((children (p/pattern+ source)))
 306       (make-choice (groupify children) (make-empty)))))
 307
 308 (defun p/list (source)
 309   (klacks:expecting-element (source "list")
 310     (consume-and-skip-to-native source)
 311     (let ((children (p/pattern+ source)))
 312       (make-list-pattern (groupify children)))))
 313
 314 (defun p/mixed (source)
 315   (klacks:expecting-element (source "mixed")
 316     (consume-and-skip-to-native source)
 317     (let ((children (p/pattern+ source)))
 318       (make-interleave (groupify children) (make-text)))))
 319
 320 (defun p/ref (source)
 321   (klacks:expecting-element (source "ref")
 322     (prog1
 323         (make-ref :ref-name (ntc "name" source))
 324       (skip-foreign* source))))
 325
 326 (defun p/parent-ref (source)
 327   (klacks:expecting-element (source "parentRef")
 328     (prog1
 329         (make-parent-ref :ref-name (ntc "name" source))
 330       (skip-foreign* source))))
 331
 332 (defun p/empty (source)
 333   (klacks:expecting-element (source "empty")
 334     (skip-foreign* source)
 335     (make-empty)))
 336
 337 (defun p/text (source)
 338   (klacks:expecting-element (source "text")
 339     (skip-foreign* source)
 340     (make-text)))
 341
 342 (defun consume-and-parse-characters (source)
 343   ;; fixme
 344   (let ((tmp ""))
 345     (loop
 346       (multiple-value-bind (key data) (klacks:peek-next source)
 347         (case key
 348           (:characters
 349             (setf tmp (concatenate 'string tmp data)))
 350           (:end-element (return)))))
 351     tmp))
 352
 353 (defun p/value (source)
 354   (klacks:expecting-element (source "value")
 355     (let* ((type (ntc "type" source))
 356            (string (consume-and-parse-characters source))
 357            (ns *namespace-uri*)
 358            (dl *datatype-library*))
 359       (unless type
 360         (setf type "token")
 361         (setf dl ""))
 362       (make-value :string string :type type :ns ns :datatype-library dl))))
 363
 364 (defun p/data (source)
 365   (klacks:expecting-element (source "data")
 366     (let* ((type (ntc "type" source))
 367            (result (make-data :type type
 368                               :datatype-library *datatype-library*
 369                              ))
 370            (params '()))
 371       (loop
 372         (multiple-value-bind (key uri lname)
 373             (klacks:peek-next source)
 374           uri
 375           (case key
 376             (:start-element
 377               (case (find-symbol lname :keyword)
 378                 (:|param| (push (p/param source) params))
 379                 (:|except|
 380                   (setf (pattern-except result) (p/except-pattern source))
 381                   (skip-to-native source)
 382                   (return))
 383                 (t (skip-foreign source))))
 384             (:end-element
 385               (return)))))
 386       (setf (pattern-params result) (nreverse params))
 387       result)))
 388
 389 (defun p/param (source)
 390   (klacks:expecting-element (source "param")
 391     (let ((name (ntc "name" source))
 392           (string (consume-and-parse-characters source)))
 393       (make-param :name name :string string))))
 394
 395 (defun p/except-pattern (source)
 396   (klacks:expecting-element (source "except")
 397     (with-library-and-ns (klacks:list-attributes source)
 398       (klacks:consume source)
 399       (choice-ify (p/pattern+ source)))))
 400
 401 (defun p/not-allowed (source)
 402   (klacks:expecting-element (source "notAllowed")
 403     (consume-and-skip-to-native source)
 404     (make-not-allowed)))
 405
 406 (defun safe-parse-uri (source str &optional base)
 407   (when (zerop (length str))
 408     (rng-error source "missing URI"))
 409   (handler-case
 410       (if base
 411           (puri:merge-uris str base)
 412           (puri:parse-uri str))
 413     (puri:uri-parse-error ()
 414       (rng-error source "invalid URI: ~A" str))))
 415
 416 (defun p/external-ref (source)
 417   (klacks:expecting-element (source "externalRef")
 418     (let* ((href
 419             (escape-uri (attribute "href" (klacks:list-attributes source))))
 420            (base (klacks:current-xml-base source))
 421            (uri (safe-parse-uri source href base)))
 422       (when (find uri *include-uri-stack* :test #'puri:uri=)
 423         (rng-error source "looping include"))
 424       (prog1
 425           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 426                  (xstream
 427                   (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 428             (klacks:with-open-source (source (cxml:make-source xstream))
 429               (invoke-with-klacks-handler
 430                (lambda ()
 431                  (klacks:find-event source :start-element)
 432                  (let ((*datatype-library* ""))
 433                    (p/pattern source)))
 434                source)))
 435         (skip-foreign* source)))))
 436
 437 (defun p/grammar (source)
 438   (klacks:expecting-element (source "grammar")
 439     (consume-and-skip-to-native source)
 440     (make-grammar :content (p/grammar-content* source))))
 441
 442 (defun p/grammar-content* (source &key disallow-include)
 443   (loop
 444       append
 445         (prog1
 446             (multiple-value-bind (key uri lname) (klacks:peek source)
 447               uri
 448               (case key
 449                 (:start-element
 450                   (with-library-and-ns (klacks:list-attributes source)
 451                     (case (find-symbol lname :keyword)
 452                       (:|start| (list (p/start source)))
 453                       (:|define| (list (p/define source)))
 454                       (:|div| (p/div source))
 455                       (:|include|
 456                         (when disallow-include
 457                           (rng-error source "nested include not permitted"))
 458                         (p/include source))
 459                       (t
 460                         (skip-foreign source)
 461                         nil))))
 462                 (:end-element
 463                   (loop-finish))))
 464           (klacks:consume source))))
 465
 466 (defun p/start (source)
 467   (klacks:expecting-element (source "start")
 468     (let ((combine (ntc "combine" source))
 469           (child
 470            (progn
 471              (consume-and-skip-to-native source)
 472              (p/pattern source))))
 473       (skip-foreign* source)
 474       (make-start :combine (find-symbol (string-upcase combine) :keyword)
 475                   :child child))))
 476
 477 (defun zip (constructor children)
 478   (cond
 479     ((null children)
 480       (rng-error nil "empty choice?"))
 481     ((null (cdr children))
 482       (car children))
 483     (t
 484       (destructuring-bind (a b &rest rest)
 485           children
 486         (zip constructor (cons (funcall constructor a b) rest))))))
 487
 488 (defun choice-ify (children) (zip #'make-choice children))
 489 (defun groupify (children) (zip #'make-group children))
 490 (defun interleave-ify (children) (zip #'make-interleave children))
 491
 492 (defun p/define (source)
 493   (klacks:expecting-element (source "define")
 494     (let ((name (ntc "name" source))
 495           (combine (ntc "combine" source))
 496           (children (progn
 497                       (consume-and-skip-to-native source)
 498                       (p/pattern+ source))))
 499       (make-define :name name
 500                    :combine (find-symbol (string-upcase combine) :keyword)
 501                    :child (groupify children)))))
 502
 503 (defun p/div (source)
 504   (klacks:expecting-element (source "div")
 505     (consume-and-skip-to-native source)
 506     (p/grammar-content* source)))
 507
 508 (defun p/include (source)
 509   (klacks:expecting-element (source "include")
 510     (let* ((href
 511             (escape-uri (attribute "href" (klacks:list-attributes source))))
 512            (base (klacks:current-xml-base source))
 513            (uri (safe-parse-uri source href base))
 514            (include-content
 515             (progn
 516               (consume-and-skip-to-native source)
 517               (p/grammar-content* source :disallow-include t))))
 518       (when (find uri *include-uri-stack* :test #'puri:uri=)
 519         (rng-error source "looping include"))
 520       (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 521              (xstream (cxml::xstream-open-extid* *entity-resolver* nil uri))
 522              (grammar
 523               (klacks:with-open-source (source (cxml:make-source xstream))
 524                 (invoke-with-klacks-handler
 525                  (lambda ()
 526                    (klacks:find-event source :start-element)
 527                    (let ((*datatype-library* ""))
 528                      (p/grammar source)))
 529                  source)))
 530              (grammar-content (pattern-content grammar)))
 531         (append
 532          (simplify-include source grammar-content include-content)
 533          include-content)))))
 534
 535 (defun simplify-include/map (fn l)
 536   (remove nil (mapcar fn l)))
 537
 538 (defun simplify-include/start (source grammar-content include-content)
 539   (let ((startp (some (lambda (x) (typep x 'start)) include-content)))
 540     (if startp
 541         (let ((ok nil))
 542           (prog1
 543               (remove-if (lambda (x)
 544                            (when (typep x 'start)
 545                              (setf ok t)
 546                              t))
 547                          grammar-content)
 548             (unless ok
 549               (rng-error source "expected start in grammar"))))
 550         grammar-content)))
 551
 552 (defun simplify-include/define (source grammar-content include-content)
 553   (let ((defines '()))
 554     (dolist (x include-content)
 555       (when (typep x 'define)
 556         (push (cons x nil) defines)))
 557     (prog1
 558         (remove-if (lambda (x)
 559                      (when (typep x 'define)
 560                        (let ((cons (find (define-name x)
 561                                          defines
 562                                          :key (lambda (y)
 563                                                 (define-name (car y)))
 564                                          :test #'equal)))
 565                          (when cons
 566                            (setf (cdr cons) t)
 567                            t))))
 568                    grammar-content)
 569       (loop for (define . okp) in defines do
 570             (unless okp
 571               (rng-error source "expected matching ~A in grammar" define))))))
 572
 573 (defun simplify-include (source grammar-content include-content)
 574   (simplify-include/define
 575    source
 576    (simplify-include/start source grammar-content include-content)
 577    include-content))
 578
 579 (defvar *any-name-allowed-p* t)
 580 (defvar *ns-name-allowed-p* t)
 581
 582 (defun destructure-name (source qname)
 583   (multiple-value-bind (uri lname)
 584       (klacks:decode-qname qname source)
 585     (setf uri (or uri *namespace-uri*))
 586     (when (and *attribute-namespace-p*
 587                (or (and (equal lname "xmlns") (equal uri ""))
 588                    (equal uri "http://www.w3.org/2000/xmlns")))
 589       (rng-error source "namespace attribute not permitted"))
 590     (list :name lname uri)))
 591
 592 (defun p/name-class (source)
 593   (klacks:expecting-element (source)
 594     (with-library-and-ns (klacks:list-attributes source)
 595       (case (find-symbol (klacks:current-lname source) :keyword)
 596         (:|name|
 597           (let ((qname (string-trim *whitespace*
 598                                     (consume-and-parse-characters source))))
 599             (destructure-name source qname)))
 600         (:|anyName|
 601           (unless *any-name-allowed-p*
 602             (rng-error source "anyname now permitted in except"))
 603           (klacks:consume source)
 604           (prog1
 605               (let ((*any-name-allowed-p* nil))
 606                 (cons :any (p/except-name-class? source)))
 607             (skip-to-native source)))
 608         (:|nsName|
 609           (unless *ns-name-allowed-p*
 610             (rng-error source "nsname now permitted in except"))
 611           (let ((uri *namespace-uri*)
 612                 (*any-name-allowed-p* nil)
 613                 (*ns-name-allowed-p* nil))
 614             (when (and *attribute-namespace-p*
 615                        (equal uri "http://www.w3.org/2000/xmlns"))
 616               (rng-error source "namespace attribute not permitted"))
 617             (klacks:consume source)
 618             (prog1
 619                 (list :nsname uri (p/except-name-class? source))
 620               (skip-to-native source))))
 621         (:|choice|
 622           (klacks:consume source)
 623           (cons :choice (p/name-class* source)))
 624         (t
 625           (rng-error source "invalid child in except"))))))
 626
 627 (defun p/name-class* (source)
 628   (let ((results nil))
 629     (loop
 630       (skip-to-native source)
 631       (case (klacks:peek source)
 632         (:start-element (push (p/name-class source) results))
 633         (:end-element (return)))
 634       (klacks:consume source))
 635     (nreverse results)))
 636
 637 (defun p/except-name-class? (source)
 638   (skip-to-native source)
 639   (multiple-value-bind (key uri lname)
 640       (klacks:peek source)
 641     uri
 642     (if (and (eq key :start-element)
 643              (string= (find-symbol lname :keyword) "except"))
 644         (p/except-name-class source)
 645         nil)))
 646
 647 (defun p/except-name-class (source)
 648   (klacks:expecting-element (source "except")
 649     (with-library-and-ns (klacks:list-attributes source)
 650       (klacks:consume source)
 651       (cons :except (p/name-class* source)))))
 652
 653 (defun escape-uri (string)
 654   (with-output-to-string (out)
 655     (loop for c across (cxml::rod-to-utf8-string string) do
 656           (let ((code (char-code c)))
 657             ;; http://www.w3.org/TR/xlink/#link-locators
 658             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
 659                 (format out "%~2,'0X" code)
 660                 (write-char c out))))))
 661
 662
 663 ;;;; unparsing
 664
 665 (defun serialize-grammar (grammar sink)
 666   (cxml:with-xml-output sink
 667     (serialize-pattern grammar)))
 668
 669 (defun serialize-pattern (pattern)
 670   (etypecase pattern
 671     (element
 672       (cxml:with-element "element"
 673         (serialize-name (pattern-name pattern))
 674         (serialize-pattern (pattern-child pattern))))
 675     (attribute
 676       (cxml:with-element "attribute"
 677         (serialize-name (pattern-name pattern))
 678         (serialize-pattern (pattern-child pattern))))
 679     (%combination
 680       (cxml:with-element
 681           (etypecase pattern
 682             (group "group")
 683             (interleave "interleave")
 684             (choice "choice"))
 685         (serialize-pattern (pattern-a pattern))
 686         (serialize-pattern (pattern-b pattern))))
 687     (one-or-more
 688       (cxml:with-element "oneOrmore"
 689         (serialize-pattern (pattern-child pattern))))
 690     (list-pattern
 691       (cxml:with-element "list"
 692         (serialize-pattern (pattern-child pattern))))
 693     (ref
 694       (cxml:with-element "ref"
 695         (cxml:attribute "name" (pattern-ref-name pattern))))
 696     (parent-ref
 697       (cxml:with-element "parentRef"
 698         (cxml:attribute "name" (pattern-ref-name pattern))))
 699     (empty
 700       (cxml:with-element "empty"))
 701     (not-allowed
 702       (cxml:with-element "notAllowed"))
 703     (text
 704       (cxml:with-element "text"))
 705     (value
 706       (cxml:with-element "value"
 707         (cxml:attribute "datatype-library"
 708                         (pattern-datatype-library pattern))
 709         (cxml:attribute "type" (pattern-type pattern))
 710         (cxml:attribute "ns" (pattern-ns pattern))
 711         (cxml:text (pattern-string pattern))))
 712     (data
 713       (cxml:with-element "value"
 714         (cxml:attribute "datatype-library"
 715                         (pattern-datatype-library pattern))
 716         (cxml:attribute "type" (pattern-type pattern))
 717         (dolist (param (pattern-params pattern))
 718           (cxml:with-element "param"
 719             (cxml:attribute "name" (param-name param))
 720             (cxml:text (param-string param))))
 721         (when (pattern-except pattern)
 722           (cxml:with-element "except"
 723             (serialize-pattern (pattern-except pattern))))))))
 724
 725 (defun serialize-name (name)
 726   (ecase (car name)
 727     (:name
 728       (cxml:with-element "name"
 729         (destructuring-bind (lname uri)
 730             (cdr name)
 731           (cxml:attribute "ns" uri)
 732           (cxml:text lname))))
 733     (:any
 734       (cxml:with-element "anyName"
 735         (when (cdr name)
 736           (serialize-except-name name))))
 737     (:nsname
 738       (cxml:with-element "anyName"
 739         (destructuring-bind (uri except)
 740             (cdr name)
 741           (cxml:attribute "ns" uri)
 742           (when except
 743             (serialize-except-name name)))))
 744     (:choice
 745       (cxml:with-element "choice"
 746         (mapc #'serialize-name (cdr name))))))
 747
 748 (defun serialize-except-name (spec)
 749   (cxml:with-element "except"
 750     (mapc #'serialize-name (cdr spec))))
 751
 752
 753 ;;;; simplification
 754
 755 ;;; 4.1 Annotations
 756 ;;;   Foreign attributes and elements are removed implicitly while parsing.
 757
 758 ;;; 4.2 Whitespace
 759 ;;;   All character data is discarded while parsing (which can only be
 760 ;;;   whitespace after validation).
 761 ;;;
 762 ;;;   Whitespace in name, type, and combine attributes is stripped while
 763 ;;;   parsing.  Ditto for <name/>.
 764
 765 ;;; 4.3. datatypeLibrary attribute
 766 ;;;   Escaping is done by p/pattern.
 767 ;;;   Attribute value defaulting is done using *datatype-library*; only
 768 ;;;   p/data and p/value record the computed value.
 769
 770 ;;; 4.4. type attribute of value element
 771 ;;;   Done by p/value.
 772
 773 ;;; 4.5. href attribute
 774 ;;;   Escaping is done by p/include and p/external-ref.
 775 ;;;
 776 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
 777 ;;;   but that requires xstream hacking.
 778
 779 ;;; 4.6. externalRef element
 780 ;;;   Done by p/external-ref.
 781
 782 ;;; 4.7. include element
 783 ;;;   Done by p/include.
 784
 785 ;;; 4.8. name attribute of element and attribute elements
 786 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
 787 ;;;    p/attribute.
 788
 789 ;;; 4.9. ns attribute
 790 ;;;    done by p/name-class, p/value, p/element, p/attribute
 791
 792 ;;; 4.10. QNames
 793 ;;;    done by p/name-class
 794
 795 ;;; 4.11. div element
 796 ;;;    Legen wir gar nicht erst an.
 797
 798 ;;; 4.12. 4.13 4.14 4.15
 799 ;;;    beim anlegen
 800
 801 ;;; 4.16
 802 ;;;    p/name-class
 803 ;;;    -- ausser der sache mit den datentypen
 804
 805 ;;;; tests
 806
 807 (defun run-tests (&optional (p "/home/david/src/lisp/cxml-rng/spec-split/*"))
 808   (dribble "/home/david/src/lisp/cxml-rng/TEST" :if-exists :rename-and-delete)
 809   (let ((pass 0)
 810         (total 0)
 811         (*package* (find-package :cxml-rng)))
 812     (dolist (d (directory p))
 813       (let ((name (car (last (pathname-directory d)))))
 814         (when (parse-integer name :junk-allowed t)
 815           (incf total)
 816           (when (test1 d)
 817             (incf pass)))))
 818     (format t "Passed ~D/~D tests.~%" pass total))
 819   (dribble))
 820
 821 (defun run-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 822   (test1 (merge-pathnames (format nil "~3,'0D/" n) p)))
 823
 824 (defun parse-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 825   (let* ((*debug* t)
 826          (d (merge-pathnames (format nil "~3,'0D/" n) p))
 827          (i (merge-pathnames "i.rng" d))
 828          (c (merge-pathnames "c.rng" d))
 829          (rng (if (probe-file c) c i)))
 830     (format t "~A: " (car (last (pathname-directory d))))
 831     (print rng)
 832     (parse-relax-ng rng)))
 833
 834 (defun test1 (d)
 835   (let* ((i (merge-pathnames "i.rng" d))
 836          (c (merge-pathnames "c.rng" d)))
 837     (format t "~A: " (car (last (pathname-directory d))))
 838     (if (probe-file c)
 839         (handler-case
 840             (progn
 841               (parse-relax-ng c)
 842               (format t " PASS~%")
 843               t)
 844           (error (c)
 845             (format t " FAIL: ~A~%" c)
 846             nil))
 847         (handler-case
 848             (progn
 849               (parse-relax-ng i)
 850               (format t " FAIL: didn't detect invalid schema~%")
 851               nil)
 852           (rng-error (c)
 853             (format t " PASS: ~S~%" (type-of c))
 854             t)
 855           (error (c)
 856             (format t " FAIL: incorrect condition type: ~A~%" c)
 857             nil)))))