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