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