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