parse.lisp

   1 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   2
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26
  27 (in-package :cxml-rng)
  28
  29 #+sbcl
  30 (declaim (optimize (debug 2)))
  31
  32
  33 ;;;; Errors
  34
  35 (define-condition rng-error (simple-error) ())
  36
  37 (defun rng-error (source fmt &rest args)
  38   (let ((s (make-string-output-stream)))
  39     (apply #'format s fmt args)
  40     (when source
  41       (etypecase source
  42         (klacks:source
  43          (format s "~&  [ Error at line ~D, column ~D in ~S ]"
  44                  (klacks:current-line-number source)
  45                  (klacks:current-column-number source)
  46                  (klacks:current-system-id source)))
  47         (sax:sax-parser-mixin
  48          (format s "~&  [ Error at line ~D, column ~D in ~S ]"
  49                  (sax:line-number source)
  50                  (sax:column-number source)
  51                  (sax:system-id source))) ))
  52     (error 'rng-error
  53            :format-control "~A"
  54            :format-arguments (list (get-output-stream-string s)))))
  55
  56
  57 ;;;; Parser
  58
  59 (defvar *datatype-library*)
  60 (defvar *namespace-uri*)
  61 (defvar *ns*)
  62 (defvar *entity-resolver*)
  63 (defvar *external-href-stack*)
  64 (defvar *include-uri-stack*)
  65 (defvar *include-body-p* nil)
  66 (defvar *grammar*)
  67
  68 (defvar *debug* nil)
  69
  70 (defstruct (parsed-grammar
  71              (:constructor make-parsed-grammar (pattern definitions)))
  72   (pattern (missing) :type pattern)
  73   (definitions (missing) :type list)
  74   (interned-start nil :type (or null pattern))
  75   (registratur nil :type (or null hash-table)))
  76
  77 (defmethod print-object ((object parsed-grammar) stream)
  78   (print-unreadable-object (object stream :type t :identity t)))
  79
  80 (defun invoke-with-klacks-handler (fn source)
  81   (if *debug*
  82       (funcall fn)
  83       (handler-case
  84           (funcall fn)
  85         (cxml:xml-parse-error (c)
  86           (rng-error source "Cannot parse schema: ~A" c)))))
  87
  88 (defvar *validate-grammar* t)
  89 (defparameter *relax-ng-grammar* nil)
  90
  91 (defun make-validating-source (input)
  92   (let ((upstream (cxml:make-source input)))
  93     (if *validate-grammar*
  94         (klacks:make-tapping-source upstream
  95                                     (make-validator *relax-ng-grammar*))
  96         upstream)))
  97
  98 (defun parse-relax-ng (input &key entity-resolver)
  99   (when *validate-grammar*
 100     (unless *relax-ng-grammar*
 101       (setf *relax-ng-grammar*
 102             (let* ((*validate-grammar* nil)
 103                    (d (slot-value (asdf:find-system :cxml-rng)
 104                                   'asdf::relative-pathname)))
 105               (parse-relax-ng (merge-pathnames "rng.rng" d))))))
 106   (klacks:with-open-source (source (make-validating-source input))
 107     (invoke-with-klacks-handler
 108      (lambda ()
 109        (klacks:find-event source :start-element)
 110        (let* ((*datatype-library* "")
 111               (*namespace-uri* "")
 112               (*entity-resolver* entity-resolver)
 113               (*external-href-stack* '())
 114               (*include-uri-stack* '())
 115               (*grammar* (make-grammar nil))
 116               (result (p/pattern source)))
 117          (unless result
 118            (rng-error nil "empty grammar"))
 119          (setf (grammar-start *grammar*)
 120                (make-definition :name :start :child result))
 121          (check-pattern-definitions source *grammar*)
 122          (check-recursion result 0)
 123          (let ((defns (finalize-definitions result)))
 124            (setf result (fold-not-allowed result))
 125            (dolist (defn defns)
 126              (setf (defn-child defn) (fold-not-allowed (defn-child defn))))
 127            (setf result (fold-empty result))
 128            (dolist (defn defns)
 129              (setf (defn-child defn) (fold-empty (defn-child defn))))
 130            (check-start-restrictions result)
 131            (dolist (defn defns)
 132              (check-restrictions (defn-child defn)))
 133            (make-parsed-grammar result defns))))
 134      source)))
 135
 136
 137 ;;;; pattern structures
 138
 139 (defstruct pattern)
 140
 141 (defmethod print-object :around ((object pattern) stream)
 142   (let ((*print-circle* t))
 143     (call-next-method)))
 144
 145 (defstruct (%parent (:include pattern) (:conc-name "PATTERN-"))
 146   child)
 147
 148 (defstruct (%named-pattern (:include %parent) (:conc-name "PATTERN-"))
 149   name)
 150 (defstruct (element (:include %named-pattern) (:conc-name "PATTERN-")))
 151 (defstruct (attribute (:include %named-pattern) (:conc-name "PATTERN-")))
 152
 153 (defstruct (%combination (:include pattern) (:conc-name "PATTERN-"))
 154   a b)
 155 (defstruct (group
 156             (:include %combination)
 157             (:constructor make-group (a b))))
 158 (defstruct (interleave
 159             (:include %combination)
 160             (:constructor make-interleave (a b))))
 161 (defstruct (choice
 162             (:include %combination)
 163             (:constructor make-choice (a b))))
 164 (defstruct (after
 165             (:include %combination)
 166             (:constructor make-after (a b))))
 167
 168 (defstruct (one-or-more
 169             (:include %parent)
 170             (:constructor make-one-or-more (child))))
 171 (defstruct (list-pattern
 172             (:include %parent)
 173             (:constructor make-list-pattern (child))))
 174
 175 (defstruct (ref
 176             (:include pattern)
 177             (:conc-name "PATTERN-")
 178             (:constructor make-ref (target)))
 179   crdepth
 180   target)
 181
 182 (defstruct (%leaf (:include pattern)))
 183
 184 (defstruct (empty (:include %leaf) (:conc-name "PATTERN-")))
 185 (defstruct (text (:include %leaf) (:conc-name "PATTERN-")))
 186
 187 (defstruct (%typed-pattern (:include %leaf) (:conc-name "PATTERN-"))
 188   type)
 189
 190 (defstruct (value (:include %typed-pattern) (:conc-name "PATTERN-"))
 191   ns
 192   string
 193   value)
 194
 195 (defstruct (data (:include %typed-pattern) (:conc-name "PATTERN-"))
 196   params
 197   except)
 198
 199 (defstruct (not-allowed (:include %leaf) (:conc-name "PATTERN-")))
 200
 201
 202 ;;;; non-pattern
 203
 204 (defstruct (grammar (:constructor make-grammar (parent)))
 205   (start nil)
 206   parent
 207   (definitions (make-hash-table :test 'equal)))
 208
 209 (defstruct param
 210   name
 211   string)
 212
 213 ;; Clark calls this structure "RefPattern"
 214 (defstruct (definition (:conc-name "DEFN-"))
 215   name
 216   combine-method
 217   head-p
 218   redefinition
 219   child)
 220
 221
 222 ;;; name-class
 223
 224 (defun missing ()
 225   (error "missing arg"))
 226
 227 (defstruct name-class)
 228
 229 (defstruct (any-name (:include name-class)
 230                      (:constructor make-any-name (except)))
 231   (except (missing) :type (or null name-class)))
 232
 233 (defstruct (name (:include name-class)
 234                  (:constructor make-name (uri lname)))
 235   (uri (missing) :type string)
 236   (lname (missing) :type string))
 237
 238 (defstruct (ns-name (:include name-class)
 239                     (:constructor make-ns-name (uri except)))
 240   (uri (missing) :type string)
 241   (except (missing) :type (or null name-class)))
 242
 243 (defstruct (name-class-choice (:include name-class)
 244                               (:constructor make-name-class-choice (a b)))
 245   (a (missing) :type name-class)
 246   (b (missing) :type name-class))
 247
 248 (defun simplify-nc-choice (values)
 249   (zip #'make-name-class-choice values))
 250
 251
 252 ;;;; parser
 253
 254 (defvar *rng-namespace* "http://relaxng.org/ns/structure/1.0")
 255
 256 (defun skip-foreign* (source)
 257   (loop
 258     (case (klacks:peek-next source)
 259       (:start-element (skip-foreign source))
 260       (:end-element (return)))))
 261
 262 (defun skip-to-native (source)
 263   (loop
 264     (case (klacks:peek source)
 265       (:start-element
 266         (when (equal (klacks:current-uri source) *rng-namespace*)
 267           (return))
 268         (klacks:serialize-element source nil))
 269       (:end-element (return)))
 270     (klacks:consume source)))
 271
 272 (defun consume-and-skip-to-native (source)
 273   (klacks:consume source)
 274   (skip-to-native source))
 275
 276 (defun skip-foreign (source)
 277   (when (equal (klacks:current-uri source) *rng-namespace*)
 278     (rng-error source
 279                "invalid schema: ~A not allowed here"
 280                (klacks:current-lname source)))
 281   (klacks:serialize-element source nil))
 282
 283 (defun attribute (lname attrs)
 284   (let ((a (sax:find-attribute-ns "" lname attrs)))
 285     (if a
 286         (sax:attribute-value a)
 287         nil)))
 288
 289 (defparameter *whitespace*
 290     (format nil "~C~C~C~C"
 291             (code-char 9)
 292             (code-char 32)
 293             (code-char 13)
 294             (code-char 10)))
 295
 296 (defun ntc (lname source-or-attrs)
 297   ;; used for (n)ame, (t)ype, and (c)ombine, this also strings whitespace
 298   (let* ((attrs
 299           (if (listp source-or-attrs)
 300               source-or-attrs
 301               (klacks:list-attributes source-or-attrs)))
 302          (a (sax:find-attribute-ns "" lname attrs)))
 303     (if a
 304         (string-trim *whitespace* (sax:attribute-value a))
 305         nil)))
 306
 307 (defmacro with-library-and-ns (attrs &body body)
 308   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 309
 310 (defun invoke-with-library-and-ns (fn attrs)
 311   (let* ((dl (attribute "datatypeLibrary" attrs))
 312          (ns (attribute "ns" attrs))
 313          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 314          (*namespace-uri* (or ns *namespace-uri*))
 315          (*ns* ns))
 316     (funcall fn)))
 317
 318 (defun p/pattern (source)
 319   (let* ((lname (klacks:current-lname source))
 320          (attrs (klacks:list-attributes source)))
 321     (with-library-and-ns attrs
 322       (case (find-symbol lname :keyword)
 323         (:|element|     (p/element source (ntc "name" attrs)))
 324         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 325         (:|group|       (p/combination #'groupify source))
 326         (:|interleave|  (p/combination #'interleave-ify source))
 327         (:|choice|      (p/combination #'choice-ify source))
 328         (:|optional|    (p/optional source))
 329         (:|zeroOrMore|  (p/zero-or-more source))
 330         (:|oneOrMore|   (p/one-or-more source))
 331         (:|list|        (p/list source))
 332         (:|mixed|       (p/mixed source))
 333         (:|ref|         (p/ref source))
 334         (:|parentRef|   (p/parent-ref source))
 335         (:|empty|       (p/empty source))
 336         (:|text|        (p/text source))
 337         (:|value|       (p/value source))
 338         (:|data|        (p/data source))
 339         (:|notAllowed|  (p/not-allowed source))
 340         (:|externalRef| (p/external-ref source))
 341         (:|grammar|     (p/grammar source))
 342         (t (skip-foreign source))))))
 343
 344 (defun p/pattern+ (source)
 345   (let ((children nil))
 346     (loop
 347       (case (klacks:peek source)
 348         (:start-element
 349           (let ((p (p/pattern source))) (when p (push p children))))
 350         (:end-element
 351           (return))
 352         (t
 353           (klacks:consume source))))
 354     (unless children
 355       (rng-error source "empty element"))
 356     (nreverse children)))
 357
 358 (defun p/pattern? (source)
 359   (let ((result nil))
 360     (loop
 361       (skip-to-native source)
 362       (case (klacks:peek source)
 363         (:start-element
 364           (when result
 365             (rng-error source "at most one pattern expected here"))
 366           (setf result (p/pattern source)))
 367         (:end-element
 368           (return))
 369         (t
 370           (klacks:consume source))))
 371     result))
 372
 373 (defun p/element (source name)
 374   (klacks:expecting-element (source "element")
 375     (let ((elt (make-element)))
 376       (consume-and-skip-to-native source)
 377       (if name
 378           (setf (pattern-name elt) (destructure-name source name))
 379           (setf (pattern-name elt) (p/name-class source)))
 380       (skip-to-native source)
 381       (setf (pattern-child elt) (groupify (p/pattern+ source)))
 382       (make-ref (make-definition :name (gensym "ANONYMOUS") :child elt)))))
 383
 384 (defvar *attribute-namespace-p* nil)
 385
 386 (defun p/attribute (source name)
 387   (klacks:expecting-element (source "attribute")
 388     (let ((result (make-attribute)))
 389       (consume-and-skip-to-native source)
 390       (if name
 391           (setf (pattern-name result)
 392                 (let ((*namespace-uri* (or *ns* "")))
 393                   (destructure-name source name)))
 394           (setf (pattern-name result)
 395                 (let ((*attribute-namespace-p* t))
 396                   (p/name-class source))))
 397       (skip-to-native source)
 398       (setf (pattern-child result)
 399             (or (p/pattern? source) (make-text)))
 400       result)))
 401
 402 (defun p/combination (zipper source)
 403   (klacks:expecting-element (source)
 404     (consume-and-skip-to-native source)
 405     (funcall zipper (p/pattern+ source))))
 406
 407 (defun p/one-or-more (source)
 408   (klacks:expecting-element (source "oneOrMore")
 409     (consume-and-skip-to-native source)
 410     (let ((children (p/pattern+ source)))
 411       (make-one-or-more (groupify children)))))
 412
 413 (defun p/zero-or-more (source)
 414   (klacks:expecting-element (source "zeroOrMore")
 415     (consume-and-skip-to-native source)
 416     (let ((children (p/pattern+ source)))
 417       (make-choice (make-one-or-more (groupify children))
 418                    (make-empty)))))
 419
 420 (defun p/optional (source)
 421   (klacks:expecting-element (source "optional")
 422     (consume-and-skip-to-native source)
 423     (let ((children (p/pattern+ source)))
 424       (make-choice (groupify children) (make-empty)))))
 425
 426 (defun p/list (source)
 427   (klacks:expecting-element (source "list")
 428     (consume-and-skip-to-native source)
 429     (let ((children (p/pattern+ source)))
 430       (make-list-pattern (groupify children)))))
 431
 432 (defun p/mixed (source)
 433   (klacks:expecting-element (source "mixed")
 434     (consume-and-skip-to-native source)
 435     (let ((children (p/pattern+ source)))
 436       (make-interleave (groupify children) (make-text)))))
 437
 438 (defun p/ref (source)
 439   (klacks:expecting-element (source "ref")
 440     (prog1
 441         (let* ((name (ntc "name" source))
 442                (pdefinition
 443                 (or (find-definition name)
 444                     (setf (find-definition name)
 445                           (make-definition :name name :child nil)))))
 446           (make-ref pdefinition))
 447       (skip-foreign* source))))
 448
 449 (defun p/parent-ref (source)
 450   (klacks:expecting-element (source "parentRef")
 451     (prog1
 452         (let* ((name (ntc "name" source))
 453                (grammar (grammar-parent *grammar*))
 454                (pdefinition
 455                 (or (find-definition name grammar)
 456                     (setf (find-definition name grammar)
 457                           (make-definition :name name :child nil)))))
 458           (make-ref pdefinition))
 459       (skip-foreign* source))))
 460
 461 (defun p/empty (source)
 462   (klacks:expecting-element (source "empty")
 463     (skip-foreign* source)
 464     (make-empty)))
 465
 466 (defun p/text (source)
 467   (klacks:expecting-element (source "text")
 468     (skip-foreign* source)
 469     (make-text)))
 470
 471 (defun consume-and-parse-characters (source)
 472   ;; fixme
 473   (let ((tmp ""))
 474     (loop
 475       (multiple-value-bind (key data) (klacks:peek-next source)
 476         (case key
 477           (:characters
 478             (setf tmp (concatenate 'string tmp data)))
 479           (:end-element (return)))))
 480     tmp))
 481
 482 (defun p/value (source)
 483   (klacks:expecting-element (source "value")
 484     (let* ((type (ntc "type" source))
 485            (string (consume-and-parse-characters source))
 486            (ns *namespace-uri*)
 487            (dl *datatype-library*))
 488       (unless type
 489         (setf type "token")
 490         (setf dl ""))
 491       (let ((data-type
 492              (cxml-types:find-type (and dl (find-symbol dl :keyword)) type))
 493             (vc (cxml-types:make-klacks-validation-context source)))
 494         (unless data-type
 495           (rng-error source "type not found: ~A/~A" type dl))
 496         (make-value :string string
 497                     :value (cxml-types:parse data-type string vc)
 498                     :type data-type
 499                     :ns ns)))))
 500
 501 (defun p/data (source)
 502   (klacks:expecting-element (source "data")
 503     (let* ((type (ntc "type" source))
 504            (params '())
 505            (except nil))
 506       (loop
 507          (multiple-value-bind (key uri lname)
 508              (klacks:peek-next source)
 509            uri
 510            (case key
 511              (:start-element
 512               (case (find-symbol lname :keyword)
 513                 (:|param| (push (p/param source) params))
 514                 (:|except|
 515                   (setf except (p/except-pattern source))
 516                   (skip-to-native source)
 517                   (return))
 518                 (t (skip-foreign source))))
 519              (:end-element
 520               (return)))))
 521       (setf params (nreverse params))
 522       (let* ((dl *datatype-library*)
 523              (data-type (apply #'cxml-types:find-type
 524                                (and dl (find-symbol dl :keyword))
 525                                type
 526                                (loop
 527                                   for p in params
 528                                   collect (find-symbol (param-name p)
 529                                                        :keyword)
 530                                   collect (param-string p)))))
 531         (unless data-type
 532           (rng-error source "type not found: ~A/~A" type dl))
 533         (make-data
 534          :type data-type
 535          :params params
 536          :except except)))))
 537
 538 (defun p/param (source)
 539   (klacks:expecting-element (source "param")
 540     (let ((name (ntc "name" source))
 541           (string (consume-and-parse-characters source)))
 542       (make-param :name name :string string))))
 543
 544 (defun p/except-pattern (source)
 545   (klacks:expecting-element (source "except")
 546     (with-library-and-ns (klacks:list-attributes source)
 547       (klacks:consume source)
 548       (choice-ify (p/pattern+ source)))))
 549
 550 (defun p/not-allowed (source)
 551   (klacks:expecting-element (source "notAllowed")
 552     (consume-and-skip-to-native source)
 553     (make-not-allowed)))
 554
 555 (defun safe-parse-uri (source str &optional base)
 556   (when (zerop (length str))
 557     (rng-error source "missing URI"))
 558   (handler-case
 559       (if base
 560           (puri:merge-uris str base)
 561           (puri:parse-uri str))
 562     (puri:uri-parse-error ()
 563       (rng-error source "invalid URI: ~A" str))))
 564
 565 (defun p/external-ref (source)
 566   (klacks:expecting-element (source "externalRef")
 567     (let* ((href
 568             (escape-uri (attribute "href" (klacks:list-attributes source))))
 569            (base (klacks:current-xml-base source))
 570            (uri (safe-parse-uri source href base)))
 571       (when (find uri *include-uri-stack* :test #'puri:uri=)
 572         (rng-error source "looping include"))
 573       (prog1
 574           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 575                  (xstream
 576                   (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 577             (klacks:with-open-source (source (make-validating-source xstream))
 578               (invoke-with-klacks-handler
 579                (lambda ()
 580                  (klacks:find-event source :start-element)
 581                  (let ((*datatype-library* ""))
 582                    (p/pattern source)))
 583                source)))
 584         (skip-foreign* source)))))
 585
 586 (defun p/grammar (source &optional grammar)
 587   (klacks:expecting-element (source "grammar")
 588     (consume-and-skip-to-native source)
 589     (let ((*grammar* (or grammar (make-grammar *grammar*)))
 590           (includep grammar))
 591       (process-grammar-content* source)
 592       (unless (or includep (grammar-start *grammar*))
 593         (rng-error source "no <start> in grammar"))
 594       (unless includep
 595         (check-pattern-definitions source *grammar*)
 596         (defn-child (grammar-start *grammar*))))))
 597
 598 (defvar *include-start*)
 599 (defvar *include-definitions*)
 600
 601 (defun process-grammar-content* (source &key disallow-include)
 602   (loop
 603     (multiple-value-bind (key uri lname) (klacks:peek source)
 604       uri
 605       (case key
 606         (:start-element
 607           (with-library-and-ns (klacks:list-attributes source)
 608             (case (find-symbol lname :keyword)
 609               (:|start| (process-start source))
 610               (:|define| (process-define source))
 611               (:|div| (process-div source))
 612               (:|include|
 613                 (when disallow-include
 614                   (rng-error source "nested include not permitted"))
 615                 (process-include source))
 616               (t
 617                 (skip-foreign source)))))
 618         (:end-element
 619           (return))))
 620     (klacks:consume source)))
 621
 622 (defun process-start (source)
 623   (klacks:expecting-element (source "start")
 624     (let* ((combine0 (ntc "combine" source))
 625            (combine
 626             (when combine0
 627               (find-symbol (string-upcase combine0) :keyword)))
 628            (child
 629             (progn
 630               (consume-and-skip-to-native source)
 631               (p/pattern source)))
 632            (pdefinition (grammar-start *grammar*)))
 633       (skip-foreign* source)
 634       ;; fixme: shared code with process-define
 635       (unless pdefinition
 636         (setf pdefinition (make-definition :name :start :child nil))
 637         (setf (grammar-start *grammar*) pdefinition))
 638       (when *include-body-p*
 639         (setf *include-start* pdefinition))
 640       (cond
 641         ((defn-child pdefinition)
 642          (ecase (defn-redefinition pdefinition)
 643            (:not-being-redefined
 644              (when (and combine
 645                         (defn-combine-method pdefinition)
 646                         (not (eq combine
 647                                  (defn-combine-method pdefinition))))
 648                (rng-error source "conflicting combine values for <start>"))
 649              (unless combine
 650                (when (defn-head-p pdefinition)
 651                  (rng-error source "multiple definitions for <start>"))
 652                (setf (defn-head-p pdefinition) t))
 653              (unless (defn-combine-method pdefinition)
 654                (setf (defn-combine-method pdefinition) combine))
 655              (setf (defn-child pdefinition)
 656                    (case (defn-combine-method pdefinition)
 657                      (:choice
 658                        (make-choice (defn-child pdefinition) child))
 659                      (:interleave
 660                        (make-interleave (defn-child pdefinition) child)))))
 661            (:being-redefined-and-no-original
 662              (setf (defn-redefinition pdefinition)
 663                    :being-redefined-and-original))
 664            (:being-redefined-and-original)))
 665         (t
 666           (setf (defn-child pdefinition) child)
 667           (setf (defn-combine-method pdefinition) combine)
 668           (setf (defn-head-p pdefinition) (null combine))
 669           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
 670
 671 (defun zip (constructor children)
 672   (cond
 673     ((null children)
 674       (rng-error nil "empty choice?"))
 675     ((null (cdr children))
 676       (car children))
 677     (t
 678       (destructuring-bind (a b &rest rest)
 679           children
 680         (zip constructor (cons (funcall constructor a b) rest))))))
 681
 682 (defun choice-ify (children) (zip #'make-choice children))
 683 (defun groupify (children) (zip #'make-group children))
 684 (defun interleave-ify (children) (zip #'make-interleave children))
 685
 686 (defun find-definition (name &optional (grammar *grammar*))
 687   (gethash name (grammar-definitions grammar)))
 688
 689 (defun (setf find-definition) (newval name &optional (grammar *grammar*))
 690   (setf (gethash name (grammar-definitions grammar)) newval))
 691
 692 (defun process-define (source)
 693   (klacks:expecting-element (source "define")
 694     (let* ((name (ntc "name" source))
 695            (combine0 (ntc "combine" source))
 696            (combine (when combine0
 697                       (find-symbol (string-upcase combine0) :keyword)))
 698            (child (groupify
 699                    (progn
 700                      (consume-and-skip-to-native source)
 701                      (p/pattern+ source))))
 702            (pdefinition (find-definition name)))
 703       (unless pdefinition
 704         (setf pdefinition (make-definition :name name :child nil))
 705         (setf (find-definition name) pdefinition))
 706       (when *include-body-p*
 707         (push pdefinition *include-definitions*))
 708       (cond
 709         ((defn-child pdefinition)
 710           (case (defn-redefinition pdefinition)
 711             (:not-being-redefined
 712               (when (and combine
 713                          (defn-combine-method pdefinition)
 714                          (not (eq combine
 715                                   (defn-combine-method pdefinition))))
 716                 (rng-error source "conflicting combine values for ~A" name))
 717               (unless combine
 718                 (when (defn-head-p pdefinition)
 719                   (rng-error source "multiple definitions for ~A" name))
 720                 (setf (defn-head-p pdefinition) t))
 721               (unless (defn-combine-method pdefinition)
 722                 (setf (defn-combine-method pdefinition) combine))
 723               (setf (defn-child pdefinition)
 724                     (case (defn-combine-method pdefinition)
 725                       (:choice
 726                         (make-choice (defn-child pdefinition) child))
 727                       (:interleave
 728                         (make-interleave (defn-child pdefinition) child)))))
 729             (:being-redefined-and-no-original
 730               (setf (defn-redefinition pdefinition)
 731                     :being-redefined-and-original))
 732             (:being-redefined-and-original)))
 733         (t
 734           (setf (defn-child pdefinition) child)
 735           (setf (defn-combine-method pdefinition) combine)
 736           (setf (defn-head-p pdefinition) (null combine))
 737           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
 738
 739 (defun process-div (source)
 740   (klacks:expecting-element (source "div")
 741     (consume-and-skip-to-native source)
 742     (process-grammar-content* source)))
 743
 744 (defun reset-definition-for-include (defn)
 745   (setf (defn-combine-method defn) nil)
 746   (setf (defn-redefinition defn) :being-redefined-and-no-original)
 747   (setf (defn-head-p defn) nil))
 748
 749 (defun restore-definition (defn original)
 750   (setf (defn-combine-method defn) (defn-combine-method original))
 751   (setf (defn-redefinition defn) (defn-redefinition original))
 752   (setf (defn-head-p defn) (defn-head-p original)))
 753
 754 (defun process-include (source)
 755   (klacks:expecting-element (source "include")
 756     (let* ((href
 757             (escape-uri (attribute "href" (klacks:list-attributes source))))
 758            (base (klacks:current-xml-base source))
 759            (uri (safe-parse-uri source href base))
 760            (*include-start* nil)
 761            (*include-definitions* '()))
 762       (consume-and-skip-to-native source)
 763       (let ((*include-body-p* t))
 764         (process-grammar-content* source :disallow-include t))
 765       (let ((tmp-start
 766              (when *include-start*
 767                (prog1
 768                    (copy-structure *include-start*)
 769                  (reset-definition-for-include *include-start*))))
 770             (tmp-defns
 771              (loop
 772                  for defn in *include-definitions*
 773                  collect
 774                    (prog1
 775                        (copy-structure defn)
 776                      (reset-definition-for-include defn)))))
 777         (when (find uri *include-uri-stack* :test #'puri:uri=)
 778           (rng-error source "looping include"))
 779         (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 780                (xstream (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 781           (klacks:with-open-source (source (make-validating-source xstream))
 782             (invoke-with-klacks-handler
 783              (lambda ()
 784                (klacks:find-event source :start-element)
 785                (let ((*datatype-library* ""))
 786                  (p/grammar source *grammar*)))
 787              source))
 788           (when tmp-start
 789             (when (eq (defn-redefinition *include-start*)
 790                       :being-redefined-and-no-original)
 791               (rng-error source "start not found in redefinition of grammar"))
 792             (restore-definition *include-start* tmp-start))
 793           (dolist (copy tmp-defns)
 794             (let ((defn (gethash (defn-name copy)
 795                                  (grammar-definitions *grammar*))))
 796               (when (eq (defn-redefinition defn)
 797                         :being-redefined-and-no-original)
 798                 (rng-error source "redefinition not found in grammar"))
 799               (restore-definition defn copy)))
 800           nil)))))
 801
 802 (defun check-pattern-definitions (source grammar)
 803   (when (and (grammar-start grammar)
 804              (eq (defn-redefinition (grammar-start grammar))
 805                  :being-redefined-and-no-original))
 806     (rng-error source "start not found in redefinition of grammar"))
 807   (loop for defn being each hash-value in (grammar-definitions grammar) do
 808         (when (eq (defn-redefinition defn) :being-redefined-and-no-original)
 809           (rng-error source "redefinition not found in grammar"))
 810         (unless (defn-child defn)
 811           (rng-error source "unresolved reference to ~A" (defn-name defn)))))
 812
 813 (defvar *any-name-allowed-p* t)
 814 (defvar *ns-name-allowed-p* t)
 815
 816 (defun destructure-name (source qname)
 817   (multiple-value-bind (uri lname)
 818       (klacks:decode-qname qname source)
 819     (setf uri (or uri *namespace-uri*))
 820     (when (and *attribute-namespace-p*
 821                (or (and (equal lname "xmlns") (equal uri ""))
 822                    (equal uri "http://www.w3.org/2000/xmlns")))
 823       (rng-error source "namespace attribute not permitted"))
 824     (make-name uri lname)))
 825
 826 (defun p/name-class (source)
 827   (klacks:expecting-element (source)
 828     (with-library-and-ns (klacks:list-attributes source)
 829       (case (find-symbol (klacks:current-lname source) :keyword)
 830         (:|name|
 831           (let ((qname (string-trim *whitespace*
 832                                     (consume-and-parse-characters source))))
 833             (destructure-name source qname)))
 834         (:|anyName|
 835           (unless *any-name-allowed-p*
 836             (rng-error source "anyname now permitted in except"))
 837           (klacks:consume source)
 838           (prog1
 839               (let ((*any-name-allowed-p* nil))
 840                 (make-any-name (p/except-name-class? source)))
 841             (skip-to-native source)))
 842         (:|nsName|
 843           (unless *ns-name-allowed-p*
 844             (rng-error source "nsname now permitted in except"))
 845           (let ((uri *namespace-uri*)
 846                 (*any-name-allowed-p* nil)
 847                 (*ns-name-allowed-p* nil))
 848             (when (and *attribute-namespace-p*
 849                        (equal uri "http://www.w3.org/2000/xmlns"))
 850               (rng-error source "namespace attribute not permitted"))
 851             (klacks:consume source)
 852             (prog1
 853                 (make-ns-name uri (p/except-name-class? source))
 854               (skip-to-native source))))
 855         (:|choice|
 856           (klacks:consume source)
 857           (simplify-nc-choice (p/name-class* source)))
 858         (t
 859           (rng-error source "invalid child in except"))))))
 860
 861 (defun p/name-class* (source)
 862   (let ((results nil))
 863     (loop
 864       (skip-to-native source)
 865       (case (klacks:peek source)
 866         (:start-element (push (p/name-class source) results))
 867         (:end-element (return)))
 868       (klacks:consume source))
 869     (nreverse results)))
 870
 871 (defun p/except-name-class? (source)
 872   (skip-to-native source)
 873   (multiple-value-bind (key uri lname)
 874       (klacks:peek source)
 875     uri
 876     (if (and (eq key :start-element)
 877              (string= (find-symbol lname :keyword) "except"))
 878         (p/except-name-class source)
 879         nil)))
 880
 881 (defun p/except-name-class (source)
 882   (klacks:expecting-element (source "except")
 883     (with-library-and-ns (klacks:list-attributes source)
 884       (klacks:consume source)
 885       (let ((x (p/name-class* source)))
 886         (if (cdr x)
 887             (simplify-nc-choice x)
 888             (car x))))))
 889
 890 (defun escape-uri (string)
 891   (with-output-to-string (out)
 892     (loop for c across (cxml::rod-to-utf8-string string) do
 893           (let ((code (char-code c)))
 894             ;; http://www.w3.org/TR/xlink/#link-locators
 895             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
 896                 (format out "%~2,'0X" code)
 897                 (write-char c out))))))
 898
 899
 900 ;;;; unparsing
 901
 902 (defvar *definitions-to-names*)
 903 (defvar *seen-names*)
 904
 905 (defun serialization-name (defn)
 906   (or (gethash defn *definitions-to-names*)
 907       (setf (gethash defn *definitions-to-names*)
 908             (let ((name (if (gethash (defn-name defn) *seen-names*)
 909                             (format nil "~A-~D"
 910                                     (defn-name defn)
 911                                     (hash-table-count *seen-names*))
 912                             (defn-name defn))))
 913               (setf (gethash name *seen-names*) defn)
 914               name))))
 915
 916 (defun serialize-grammar (grammar sink)
 917   (cxml:with-xml-output sink
 918     (let ((*definitions-to-names* (make-hash-table))
 919           (*seen-names* (make-hash-table :test 'equal)))
 920       (cxml:with-element "grammar"
 921         (cxml:with-element "start"
 922           (serialize-pattern (parsed-grammar-pattern grammar)))
 923         (loop for defn being each hash-key in *definitions-to-names* do
 924               (serialize-definition defn))))))
 925
 926 (defun serialize-pattern (pattern)
 927   (etypecase pattern
 928     (element
 929       (cxml:with-element "element"
 930         (serialize-name (pattern-name pattern))
 931         (serialize-pattern (pattern-child pattern))))
 932     (attribute
 933       (cxml:with-element "attribute"
 934         (serialize-name (pattern-name pattern))
 935         (serialize-pattern (pattern-child pattern))))
 936     (%combination
 937       (cxml:with-element
 938           (etypecase pattern
 939             (group "group")
 940             (interleave "interleave")
 941             (choice "choice"))
 942         (serialize-pattern (pattern-a pattern))
 943         (serialize-pattern (pattern-b pattern))))
 944     (one-or-more
 945       (cxml:with-element "oneOrMore"
 946         (serialize-pattern (pattern-child pattern))))
 947     (list-pattern
 948       (cxml:with-element "list"
 949         (serialize-pattern (pattern-child pattern))))
 950     (ref
 951       (cxml:with-element "ref"
 952         (cxml:attribute "name" (serialization-name (pattern-target pattern)))))
 953     (empty
 954       (cxml:with-element "empty"))
 955     (not-allowed
 956       (cxml:with-element "notAllowed"))
 957     (text
 958       (cxml:with-element "text"))
 959     (value
 960       (cxml:with-element "value"
 961         (let ((type (pattern-type pattern)))
 962           (cxml:attribute "datatype-library"
 963                           (symbol-name (cxml-types:type-library type)))
 964           (cxml:attribute "type" (cxml-types:type-name type)))
 965         (cxml:attribute "ns" (pattern-ns pattern))
 966         (cxml:text (pattern-string pattern))))
 967     (data
 968       (cxml:with-element "value"
 969         (let ((type (pattern-type pattern)))
 970           (cxml:attribute "datatype-library"
 971                           (symbol-name (cxml-types:type-library type)))
 972           (cxml:attribute "type" (cxml-types:type-name type)))
 973         (dolist (param (pattern-params pattern))
 974           (cxml:with-element "param"
 975             (cxml:attribute "name" (param-name param))
 976             (cxml:text (param-string param))))
 977         (when (pattern-except pattern)
 978           (cxml:with-element "except"
 979             (serialize-pattern (pattern-except pattern))))))))
 980
 981 (defun serialize-definition (defn)
 982   (cxml:with-element "define"
 983     (cxml:attribute "name" (serialization-name defn))
 984     (serialize-pattern (defn-child defn))))
 985
 986 (defun serialize-name (name)
 987   (etypecase name
 988     (name
 989      (cxml:with-element "name"
 990        (cxml:attribute "ns" (name-uri name))
 991        (cxml:text (name-lname name))))
 992     (any-name
 993      (cxml:with-element "anyName"
 994        (when (any-name-except name)
 995          (serialize-except-name (any-name-except name)))))
 996     (ns-name
 997      (cxml:with-element "anyName"
 998        (cxml:attribute "ns" (ns-name-uri name))
 999        (when (ns-name-except name)
1000          (serialize-except-name (ns-name-except name)))))
1001     (name-class-choice
1002      (cxml:with-element "choice"
1003        (serialize-name (name-class-choice-a name))
1004        (serialize-name (name-class-choice-b name))))))
1005
1006 (defun serialize-except-name (spec)
1007   (cxml:with-element "except"
1008     (serialize-name spec)))
1009
1010
1011 ;;;; simplification
1012
1013 ;;; 4.1 Annotations
1014 ;;;   Foreign attributes and elements are removed implicitly while parsing.
1015
1016 ;;; 4.2 Whitespace
1017 ;;;   All character data is discarded while parsing (which can only be
1018 ;;;   whitespace after validation).
1019 ;;;
1020 ;;;   Whitespace in name, type, and combine attributes is stripped while
1021 ;;;   parsing.  Ditto for <name/>.
1022
1023 ;;; 4.3. datatypeLibrary attribute
1024 ;;;   Escaping is done by p/pattern.
1025 ;;;   Attribute value defaulting is done using *datatype-library*; only
1026 ;;;   p/data and p/value record the computed value.
1027
1028 ;;; 4.4. type attribute of value element
1029 ;;;   Done by p/value.
1030
1031 ;;; 4.5. href attribute
1032 ;;;   Escaping is done by process-include and p/external-ref.
1033 ;;;
1034 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
1035 ;;;   but that requires xstream hacking.
1036
1037 ;;; 4.6. externalRef element
1038 ;;;   Done by p/external-ref.
1039
1040 ;;; 4.7. include element
1041 ;;;   Done by process-include.
1042
1043 ;;; 4.8. name attribute of element and attribute elements
1044 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
1045 ;;;    p/attribute.
1046
1047 ;;; 4.9. ns attribute
1048 ;;;    done by p/name-class, p/value, p/element, p/attribute
1049
1050 ;;; 4.10. QNames
1051 ;;;    done by p/name-class
1052
1053 ;;; 4.11. div element
1054 ;;;    Legen wir gar nicht erst an.
1055
1056 ;;; 4.12. 4.13 4.14 4.15
1057 ;;;    beim anlegen
1058
1059 ;;; 4.16
1060 ;;;    p/name-class
1061 ;;;    -- ausser der sache mit den datentypen
1062
1063 ;;; 4.17, 4.18, 4.19
1064 ;;;    Ueber die Grammar-und Definition Objekte, wie von James Clark
1065 ;;;    beschrieben.
1066 ;;;
1067 ;;;    Dabei werden keine Umbenennungen vorgenommen, weil Referenzierung
1068 ;;;    durch Aufbei der Graphenstruktur zwischen ref und Definition
1069 ;;;    erfolgt und Namen dann bereits aufgeloest sind.  Wir benennen
1070 ;;;    dafuer beim Serialisieren um.
1071
1072 (defmethod check-recursion ((pattern element) depth)
1073   (check-recursion (pattern-child pattern) (1+ depth)))
1074
1075 (defmethod check-recursion ((pattern ref) depth)
1076   (when (eql (pattern-crdepth pattern) depth)
1077     (rng-error nil "infinite recursion in ~A"
1078                (defn-name (pattern-target pattern))))
1079   (when (null (pattern-crdepth pattern))
1080     (setf (pattern-crdepth pattern) depth)
1081     (check-recursion (defn-child (pattern-target pattern)) depth)
1082     (setf (pattern-crdepth pattern) t)))
1083
1084 (defmethod check-recursion ((pattern %parent) depth)
1085   (check-recursion (pattern-child pattern) depth))
1086
1087 (defmethod check-recursion ((pattern %combination) depth)
1088   (check-recursion (pattern-a pattern) depth)
1089   (check-recursion (pattern-b pattern) depth))
1090
1091 (defmethod check-recursion ((pattern %leaf) depth)
1092   (declare (ignore depth)))
1093
1094 (defmethod check-recursion ((pattern data) depth)
1095   (when (pattern-except pattern)
1096     (check-recursion (pattern-except pattern) depth)))
1097
1098
1099 ;;;; 4.20
1100
1101 ;;; %PARENT
1102
1103 (defmethod fold-not-allowed ((pattern element))
1104   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1105   pattern)
1106
1107 (defmethod fold-not-allowed ((pattern %parent))
1108   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1109   (if (typep (pattern-child pattern) 'not-allowed)
1110       (pattern-child pattern)
1111       pattern))
1112
1113 ;;; %COMBINATION
1114
1115 (defmethod fold-not-allowed ((pattern %combination))
1116   (setf (pattern-a pattern) (fold-not-allowed (pattern-a pattern)))
1117   (setf (pattern-b pattern) (fold-not-allowed (pattern-b pattern)))
1118   pattern)
1119
1120 (defmethod fold-not-allowed ((pattern group))
1121   (call-next-method)
1122   (cond
1123     ;; remove if any child is not allowed
1124     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1125     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1126     (t pattern)))
1127
1128 (defmethod fold-not-allowed ((pattern interleave))
1129   (call-next-method)
1130   (cond
1131     ;; remove if any child is not allowed
1132     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1133     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1134     (t pattern)))
1135
1136 (defmethod fold-not-allowed ((pattern choice))
1137   (call-next-method)
1138   (cond
1139     ;; if any child is not allowed, choose the other
1140     ((typep (pattern-a pattern) 'not-allowed) (pattern-b pattern))
1141     ((typep (pattern-b pattern) 'not-allowed) (pattern-a pattern))
1142     (t pattern)))
1143
1144 ;;; LEAF
1145
1146 (defmethod fold-not-allowed ((pattern %leaf))
1147   pattern)
1148
1149 (defmethod fold-not-allowed ((pattern data))
1150   (when (pattern-except pattern)
1151     (setf (pattern-except pattern) (fold-not-allowed (pattern-except pattern)))
1152     (when (typep (pattern-except pattern) 'not-allowed)
1153       (setf (pattern-except pattern) nil)))
1154   pattern)
1155
1156 ;;; REF
1157
1158 (defmethod fold-not-allowed ((pattern ref))
1159   pattern)
1160
1161
1162 ;;;; 4.21
1163
1164 ;;; %PARENT
1165
1166 (defmethod fold-empty ((pattern one-or-more))
1167   (call-next-method)
1168   (if (typep (pattern-child pattern) 'empty)
1169       (pattern-child pattern)
1170       pattern))
1171
1172 (defmethod fold-empty ((pattern %parent))
1173   (setf (pattern-child pattern) (fold-empty (pattern-child pattern)))
1174   pattern)
1175
1176 ;;; %COMBINATION
1177
1178 (defmethod fold-empty ((pattern %combination))
1179   (setf (pattern-a pattern) (fold-empty (pattern-a pattern)))
1180   (setf (pattern-b pattern) (fold-empty (pattern-b pattern)))
1181   pattern)
1182
1183 (defmethod fold-empty ((pattern group))
1184   (call-next-method)
1185   (cond
1186     ;; if any child is empty, choose the other
1187     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1188     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1189     (t pattern)))
1190
1191 (defmethod fold-empty ((pattern interleave))
1192   (call-next-method)
1193   (cond
1194     ;; if any child is empty, choose the other
1195     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1196     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1197     (t pattern)))
1198
1199 (defmethod fold-empty ((pattern choice))
1200   (call-next-method)
1201   (if (typep (pattern-b pattern) 'empty)
1202       (cond
1203         ((typep (pattern-a pattern) 'empty)
1204           (pattern-a pattern))
1205         (t
1206           (rotatef (pattern-a pattern) (pattern-b pattern))
1207           pattern))
1208       pattern))
1209
1210 ;;; LEAF
1211
1212 (defmethod fold-empty ((pattern %leaf))
1213   pattern)
1214
1215 (defmethod fold-empty ((pattern data))
1216   (when (pattern-except pattern)
1217     (setf (pattern-except pattern) (fold-empty (pattern-except pattern))))
1218   pattern)
1219
1220 ;;; REF
1221
1222 (defmethod fold-empty ((pattern ref))
1223   pattern)
1224
1225
1226 ;;;; 7.1
1227
1228 (defun finalize-definitions (pattern)
1229   (let ((defns (make-hash-table)))
1230     (labels ((recurse (p)
1231                (cond
1232                  ((typep p 'ref)
1233                   (let ((target (pattern-target p)))
1234                     (unless (gethash target defns)
1235                       (setf (gethash target defns) t)
1236                       (setf (defn-child target) (recurse (defn-child target))))
1237                     (if (typep (defn-child target) 'element)
1238                         p
1239                         (copy-pattern-tree (defn-child target)))))
1240                  (t
1241                   (etypecase p
1242                     (data
1243                      (when (pattern-except p)
1244                        (setf (pattern-except p) (recurse (pattern-except p)))))
1245                     (%parent
1246                      (setf (pattern-child p) (recurse (pattern-child p))))
1247                     (%combination
1248                      (setf (pattern-a p) (recurse (pattern-a p)))
1249                      (setf (pattern-b p) (recurse (pattern-b p))))
1250                     (%leaf))
1251                   p))))
1252       (recurse pattern))
1253     (loop
1254        for defn being each hash-key in defns
1255        collect defn)))
1256
1257 (defun copy-pattern-tree (pattern)
1258   (labels ((recurse (p)
1259              (let ((q (copy-structure p)))
1260                (etypecase p
1261                  (data
1262                   (when (pattern-except p)
1263                     (setf (pattern-except q) (recurse (pattern-except p)))))
1264                  (%parent
1265                   (setf (pattern-child q) (recurse (pattern-child p))))
1266                  (%combination
1267                   (setf (pattern-a q) (recurse (pattern-a p)))
1268                   (setf (pattern-b q) (recurse (pattern-b p))))
1269                  ((or %leaf ref)))
1270                q)))
1271     (recurse pattern)))
1272
1273 (defparameter *in-attribute-p* nil)
1274 (defparameter *in-one-or-more-p* nil)
1275 (defparameter *in-one-or-more//group-or-interleave-p* nil)
1276 (defparameter *in-list-p* nil)
1277 (defparameter *in-data-except-p* nil)
1278 (defparameter *in-start-p* nil)
1279
1280 (defun check-start-restrictions (pattern)
1281   (let ((*in-start-p* t))
1282     (check-restrictions pattern)))
1283
1284 (defmethod check-restrictions ((pattern attribute))
1285   (when *in-attribute-p*
1286     (rng-error nil "nested attribute not allowed"))
1287   (when *in-one-or-more//group-or-interleave-p*
1288     (rng-error nil "attribute not allowed in oneOrMore//group, oneOrMore//interleave"))
1289   (when *in-list-p*
1290     (rng-error nil "attribute in list not allowed"))
1291   (when *in-data-except-p*
1292     (rng-error nil "attribute in data/except not allowed"))
1293   (when *in-start-p*
1294     (rng-error nil "attribute in start not allowed"))
1295   (let ((*in-attribute-p* t))
1296     (check-restrictions (pattern-child pattern))))
1297
1298 (defmethod check-restrictions ((pattern ref))
1299   (when *in-attribute-p*
1300     (rng-error nil "ref in attribute not allowed"))
1301   (when *in-list-p*
1302     (rng-error nil "ref in list not allowed"))
1303   (when *in-data-except-p*
1304     (rng-error nil "ref in data/except not allowed")))
1305
1306 (defmethod check-restrictions ((pattern one-or-more))
1307   (when *in-data-except-p*
1308     (rng-error nil "oneOrMore in data/except not allowed"))
1309   (when *in-start-p*
1310     (rng-error nil "one-or-more in start not allowed"))
1311   (let ((*in-one-or-more-p* t))
1312     (check-restrictions (pattern-child pattern))))
1313
1314 (defmethod check-restrictions ((pattern group))
1315   (when *in-data-except-p*
1316     (rng-error nil "group in data/except not allowed"))
1317   (when *in-start-p*
1318     (rng-error nil "group in start not allowed"))
1319   (when *in-start-p*
1320     (rng-error nil "interleave in start not allowed"))
1321   (let ((*in-one-or-more//group-or-interleave-p*
1322          *in-one-or-more-p*))
1323     (check-restrictions (pattern-a pattern))
1324     (check-restrictions (pattern-b pattern))))
1325
1326 (defmethod check-restrictions ((pattern interleave))
1327   (when *in-list-p*
1328     (rng-error nil "interleave in list not allowed"))
1329   (when *in-data-except-p*
1330     (rng-error nil "interleave in data/except not allowed"))
1331   (let ((*in-one-or-more//group-or-interleave-p*
1332          *in-one-or-more-p*))
1333     (check-restrictions (pattern-a pattern))
1334     (check-restrictions (pattern-b pattern))))
1335
1336 (defmethod check-restrictions ((pattern list-pattern))
1337   (when *in-list-p*
1338     (rng-error nil "nested list not allowed"))
1339   (when *in-data-except-p*
1340     (rng-error nil "list in data/except not allowed"))
1341   (let ((*in-list-p* t))
1342     (check-restrictions (pattern-child pattern)))
1343   (when *in-start-p*
1344     (rng-error nil "list in start not allowed")))
1345
1346 (defmethod check-restrictions ((pattern text))
1347   (when *in-list-p*
1348     (rng-error nil "text in list not allowed"))
1349   (when *in-data-except-p*
1350     (rng-error nil "text in data/except not allowed"))
1351   (when *in-start-p*
1352     (rng-error nil "text in start not allowed")))
1353
1354 (defmethod check-restrictions ((pattern data))
1355   (when *in-start-p*
1356     (rng-error nil "data in start not allowed"))
1357   (when (pattern-except pattern)
1358     (let ((*in-data-except-p* t))
1359       (check-restrictions (pattern-except pattern)))))
1360
1361 (defmethod check-restrictions ((pattern value))
1362   (when *in-start-p*
1363     (rng-error nil "value in start not allowed")))
1364
1365 (defmethod check-restrictions ((pattern empty))
1366   (when *in-data-except-p*
1367     (rng-error nil "empty in data/except not allowed"))
1368   (when *in-start-p*
1369     (rng-error nil "empty in start not allowed")))
1370
1371 (defmethod check-restrictions ((pattern %parent))
1372   (check-restrictions (pattern-child pattern)))
1373
1374 (defmethod check-restrictions ((pattern %leaf)))
1375
1376 (defmethod check-restrictions ((pattern %combination))
1377   (check-restrictions (pattern-a pattern))
1378   (check-restrictions (pattern-b pattern)))
1379