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