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