parse.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :cxml-rng)
  30
  31 #+sbcl
  32 (declaim (optimize (debug 2)))
  33
  34
  35 ;;;; Errors
  36
  37 (define-condition rng-error (simple-error)
  38   ((line-number :initarg :line-number :accessor rng-error-line-number)
  39    (column-number :initarg :column-number :accessor rng-error-column-number)
  40    (system-id :initarg :system-id :accessor rng-error-system-id))
  41   (:documentation
  42    "@short{The class of all validation and schema parsing errors.}
  43
  44     Signalled while parsing a schema, this error signifies that the schema
  45     is incorrect (or not compatible with DTD Compatibility).  Signalled
  46     during validation, this error signifies that the document is invalid
  47     (or not sound).
  48
  49     When parsing or validating with DTD Compatibility, check for
  50     @code{dtd-compatibility-error} to distinguish between
  51     correctness and compatibility or validity and soundness.
  52
  53     @see-slot{rng-error-line-number}
  54     @see-slot{rng-error-column-number}
  55     @see-slot{rng-error-system-id}"))
  56
  57 (define-condition dtd-compatibility-error (rng-error)
  58   ()
  59   (:documentation
  60    "@short{The class of DTD compatibility errors.}
  61
  62     Signalled while parsing a schema, this error signifies that the schema
  63     is not compatible (as opposed to incorrect).
  64
  65     Signalled during validation, this error signifies that the document
  66     is not sound (as opposed to invalid)."))
  67
  68 (setf (documentation 'rng-error-line-number 'function)
  69       "@arg[instance]{an instance of @class{rng-error}}
  70        @return{an integer, or nil}
  71        Return the line number reported by the parser when the Relax NG error
  72        was detected, or NIL if not available.")
  73
  74 (setf (documentation 'rng-error-column-number 'function)
  75       "@arg[instance]{an instance of @class{rng-error}}
  76        @return{an integer, or nil}
  77        Return the column number reported by the parser when the Relax NG error
  78        was detected, or NIL if not available.")
  79
  80 (setf (documentation 'rng-error-system-id 'function)
  81       "@arg[instance]{an instance of @class{rng-error}}
  82        @return{a puri:uri, or nil}
  83        Return the System ID of the document being parsed when the Relax NG
  84        error was detected, or NIL if not available.")
  85
  86 (defvar *error-class* 'rng-error)
  87
  88 (defun rng-error (source fmt &rest args)
  89   "@unexport{}"
  90   (let ((s (make-string-output-stream)))
  91     (apply #'format s fmt args)
  92     (multiple-value-bind (line-number column-number system-id)
  93         (etypecase source
  94           (null)
  95           (klacks:source
  96            (values (klacks:current-line-number source)
  97                    (klacks:current-column-number source)
  98                    (klacks:current-system-id source)))
  99           (sax:sax-parser-mixin
 100            (values (sax:line-number source)
 101                    (sax:column-number source)
 102                    (sax:system-id source))))
 103       (when (or line-number column-number system-id)
 104         (format s "~&  [ Error at line ~D, column ~D in ~S ]"
 105                 line-number
 106                 column-number
 107                 system-id))
 108       (error *error-class*
 109              :format-control "~A"
 110              :format-arguments (list (get-output-stream-string s))
 111              :line-number line-number
 112              :column-number column-number
 113              :system-id system-id))))
 114
 115
 116 ;;;; Parser
 117
 118 (defvar *datatype-library*)
 119 (defvar *namespace-uri*)
 120 (defvar *ns*)
 121 (defvar *entity-resolver*)
 122 (defvar *external-href-stack*)
 123 (defvar *include-uri-stack*)
 124 (defvar *include-body-p* nil)
 125 (defvar *grammar*)
 126
 127 (defvar *debug* nil)
 128
 129 (defstruct (schema
 130              (:constructor make-schema (start definitions)))
 131   "An instance of this class represents a Relax NG grammar that has
 132    been parsed and simplified.
 133    @see-slot{schema-start}
 134    @see-constructor{parse-schema}
 135    @see{make-validator}
 136    @see{serialize-schema} "
 137   (start (missing) :type pattern)
 138   (definitions (missing) :type list)
 139   (interned-start nil :type (or null pattern))
 140   (registratur nil :type (or null hash-table))
 141   (compatibility-table nil :type (or null compatibility-table)))
 142
 143 (setf (documentation 'schema-start 'function)
 144       "@arg[instance]{an instance of @class{schema}}
 145        @return{the start pattern, an instance of @class{pattern}}
 146        Reader function for the grammar's start pattern, from which all
 147        of the grammar's patters are reachable.")
 148
 149 (defmethod print-object ((object schema) stream)
 150   (print-unreadable-object (object stream :type t :identity t)))
 151
 152 (defun invoke-with-klacks-handler (fn source)
 153   (if *debug*
 154       (funcall fn)
 155       (handler-case
 156           (funcall fn)
 157         (cxml:xml-parse-error (c)
 158           (rng-error source "Cannot parse schema: ~A" c)))))
 159
 160 (defvar *validate-grammar* t)
 161 (defvar *process-dtd-compatibility*)
 162 (defparameter *relax-ng-grammar* nil)
 163 (defparameter *compatibility-grammar* nil)
 164
 165 (defun flush ()
 166   (setf *relax-ng-grammar* nil)
 167   (setf *compatibility-grammar* nil))
 168
 169 (defun make-validating-source (input schema)
 170   "@arg[input]{a @code{source} or a stream designator}
 171    @arg[schema]{the parsed Relax NG @class{schema} object}
 172    @return{a klacks source}
 173    @short{This function creates a klacks source for @code{input} that validates
 174    events against @code{schema}.}
 175
 176    Input can be a klacks source or any argument applicable to
 177    @code{cxml:make-source}.
 178
 179    @see{parse-schema}
 180    @see{make-validator}"
 181   (klacks:make-tapping-source (if (typep input 'klacks:source)
 182                                   input
 183                                   (cxml:make-source input))
 184                               (make-validator schema)))
 185
 186 (defun make-schema-source (input)
 187   (let ((upstream (cxml:make-source input)))
 188     (if *validate-grammar*
 189         (let ((handler (make-validator *relax-ng-grammar*)))
 190           (when *process-dtd-compatibility*
 191             (setf handler
 192                   (cxml:make-broadcast-handler
 193                    handler
 194                    (multiple-value-bind (h v)
 195                        (make-validator *compatibility-grammar*)
 196                      (setf (validation-error-class v) 'dtd-compatibility-error)
 197                      h))))
 198           (klacks:make-tapping-source upstream handler))
 199         upstream)))
 200
 201 (defun parse-schema (input &key entity-resolver (process-dtd-compatibility t))
 202   "@arg[input]{a string, pathname, stream, or xstream}
 203    @arg[entity-resolver]{a function of two arguments, or NIL}
 204    @arg[process-dtd-compatibility]{a boolean}
 205    @return{a parsed @class{schema}}
 206    @short{This function parses a Relax NG schema file in XML syntax}
 207    and returns a parsed representation of that schema.
 208
 209    @code{input} can be any stream designator as understood by
 210    @code{cxml:make-source}.
 211
 212    Note that namestrings are not valid arguments,
 213    because they would be interpreted as XML source code.  Use pathnames
 214    instead.
 215
 216    @code{entity-resolver} can be passed as a function of two arguments.
 217    It is invoked for every entity referenced by the
 218    document with the entity's Public ID (a rod) and System ID (an
 219    URI object) as arguments.  The function may either return
 220    nil, CXML will then try to resolve the entity as usual.
 221    Alternatively it may return a Common Lisp stream specialized on
 222    @code{(unsigned-byte 8)} which will be used instead.
 223
 224    If @code{process-dtd-compatibility} is true, the schema will be checked
 225    for @em{compatibility} with Relax NG DTD Compatibility, and default values
 226    will be recorded.  (Without @code{process-dtd-compatibility}, the schema
 227    will not be checked @em{compatibility}, and annotations for
 228    DTD Compatibility will be ignored like any other foreign element.)
 229
 230    @see{parse-compact}
 231    @see{make-validator}"
 232   (when *validate-grammar*
 233     (unless *relax-ng-grammar*
 234       (let* ((*validate-grammar* nil)
 235              (d (slot-value (asdf:find-system :cxml-rng)
 236                             'asdf::relative-pathname)))
 237         #+(or) (parse-compact (merge-pathnames "rng.rnc" d))
 238         (setf *relax-ng-grammar*
 239               (parse-schema (merge-pathnames "rng.rng" d)))
 240         (setf *compatibility-grammar*
 241               (parse-schema (merge-pathnames "compatibility.rng" d))))))
 242   (let ((*process-dtd-compatibility* process-dtd-compatibility))
 243     (klacks:with-open-source (source (make-schema-source input))
 244       (invoke-with-klacks-handler
 245        (lambda ()
 246          (klacks:find-event source :start-element)
 247          (let* ((*datatype-library* "")
 248                 (*namespace-uri* "")
 249                 (*entity-resolver* entity-resolver)
 250                 (*external-href-stack* '())
 251                 (*include-uri-stack* '())
 252                 (*grammar* (make-grammar nil))
 253                 (start (p/pattern source)))
 254            (unless start
 255              (rng-error nil "empty grammar"))
 256            (setf (grammar-start *grammar*)
 257                  (make-definition :name :start :child start))
 258            (check-pattern-definitions source *grammar*)
 259            (check-recursion start 0)
 260            (multiple-value-bind (new-start defns)
 261                (finalize-definitions start)
 262              (setf start (fold-not-allowed new-start))
 263              (dolist (defn defns)
 264                (setf (defn-child defn) (fold-not-allowed (defn-child defn))))
 265              (setf start (fold-empty start))
 266              (dolist (defn defns)
 267                (setf (defn-child defn) (fold-empty (defn-child defn)))))
 268            (multiple-value-bind (new-start defns)
 269                (finalize-definitions start)
 270              (check-start-restrictions new-start)
 271              (dolist (defn defns)
 272                (check-restrictions (defn-child defn)))
 273              (let ((schema (make-schema new-start defns)))
 274                (when *process-dtd-compatibility*
 275                  (check-schema-compatibility schema defns))
 276                schema))))
 277        source))))
 278
 279
 280 ;;;; pattern structures
 281
 282 (defstruct pattern
 283   "@short{The superclass of all patterns.}
 284    Instances of this class represent elements in the \"simplified syntax\"
 285    of Relax NG.
 286
 287    Patterns are documented for introspective purposes and are not meant to
 288    be modified by user code.
 289
 290    The start pattern of a schema is available through @fun{schema-start}.
 291
 292    @see{schema}"
 293   (nullable :uninitialized))
 294
 295 (defmethod print-object :around ((object pattern) stream)
 296   (if *debug*
 297       (let ((*print-circle* t))
 298         (call-next-method))
 299       (print-unreadable-object (object stream :type t :identity t))))
 300
 301 (defstruct (%parent (:include pattern) (:conc-name "PATTERN-"))
 302   child)
 303
 304 (defstruct (%named-pattern (:include %parent) (:conc-name "PATTERN-"))
 305   name)
 306
 307 (setf (documentation 'pattern-name 'function)
 308       "@arg[instance]{an instance of @class{pattern}}
 309        @return{a @class{name-class}}
 310        @short{Returns the @code{pattern}'s name class.}
 311
 312        This slot describes the name allowed for the current element or
 313        attribute.
 314
 315        @see{element}
 316        @see{attribute}")
 317
 318 (setf (documentation 'pattern-child 'function)
 319       "@arg[instance]{an instance of @class{pattern}}
 320        @return{an instance of @class{pattern}}
 321        @short{Returns the pattern's sub-pattern.}
 322
 323        (Elements in the full Relax NG syntax allow more than one child
 324        pattern, but simplification normalizes the representation so that
 325        any such element has exactly one child.)
 326
 327        @see{element}
 328        @see{attribute}
 329        @see{one-or-more}
 330        @see{list-pattern}
 331        @see{choice}")
 332
 333 (defstruct (element (:include %named-pattern))
 334   "@short{This pattern specifies that an element of a certain name class
 335    is required.}
 336
 337    Its child pattern describes the attributes and child nodes
 338    of this element.
 339    @see-slot{pattern-name}
 340    @see-slot{pattern-child}")
 341
 342 (defstruct (attribute (:include %named-pattern)
 343                       (:conc-name "PATTERN-")
 344                       (:constructor make-attribute (default-value)))
 345   "@short{This pattern specifies that an attribute of a certain name class
 346    is required.}
 347
 348    Its child pattern describes the type of the attribute's
 349    contents.
 350    @see-slot{pattern-name}
 351    @see-slot{pattern-child}"
 352   default-value)
 353
 354 (defstruct (%combination (:include pattern) (:conc-name "PATTERN-"))
 355   a b)
 356
 357 (setf (documentation 'pattern-a 'function)
 358       "@arg[instance]{an instance of @class{pattern}}
 359        @return{an instance of @class{pattern}}
 360        @short{Returns the first of two sub-patterns the pattern instance has.}
 361
 362        (Elements in the full Relax NG syntax allow more than two child
 363        patterns, but simplification normalizes the representation so that
 364        any such element has exactly two children.)
 365
 366        @see{pattern-b}
 367        @see{group}
 368        @see{interleave}
 369        @see{choice}")
 370
 371 (setf (documentation 'pattern-b 'function)
 372       "@arg[instance]{an instance of @class{pattern}}
 373        @return{an instance of @class{pattern}}
 374        @short{Returns the second of two sub-patterns the pattern instance has.}
 375
 376        (Elements in the full Relax NG syntax allow more than two child
 377        patterns, but simplification normalizes the representation so that
 378        any such element has exactly two children.)
 379
 380        @see{pattern-a}
 381        @see{group}
 382        @see{interleave}
 383        @see{choice}")
 384
 385 (defstruct (group
 386             (:include %combination)
 387             (:constructor make-group (a b)))
 388   "@short{This pattern specifies that two subpatterns are
 389    required at the current position in a specific order.}
 390
 391    @see-slot{pattern-a}
 392    @see-slot{pattern-b}")
 393 (defstruct (interleave
 394             (:include %combination)
 395             (:constructor make-interleave (a b)))
 396   "@short{This pattern specifies that two possible subpatterns are
 397    allowed to occur in any order at the current position.}
 398
 399    @see-slot{pattern-a}
 400    @see-slot{pattern-b}")
 401 (defstruct (choice
 402             (:include %combination)
 403             (:constructor make-choice (a b)))
 404   "@short{This pattern specifies that one of two possible subpatterns are
 405    allowed at the current position, given as its children.}
 406
 407    @see-slot{pattern-a}
 408    @see-slot{pattern-b}")
 409 (defstruct (after
 410             (:include %combination)
 411             (:constructor make-after (a b))))
 412
 413 (defstruct (one-or-more
 414             (:include %parent)
 415             (:constructor make-one-or-more (child)))
 416   "@short{This pattern specifies that its subpattern is
 417    allowed to occur at the current position one or more times.}
 418
 419    @see-slot{pattern-child}")
 420 (defstruct (list-pattern
 421             (:include %parent)
 422             (:constructor make-list-pattern (child)))
 423   "@short{This pattern specifies that a subpatterns is allowed multiple
 424    times a the current position, with whitespace as a separator.}
 425
 426    @see-slot{pattern-child}")
 427
 428 (defstruct (ref
 429             (:include pattern)
 430             (:conc-name "PATTERN-")
 431             (:constructor make-ref (target)))
 432   "@short{This pattern references another part of the pattern graph.}
 433
 434    @code{ref} is the only pattern to introduce shared structure and
 435    circularity into the pattern graph, by referring to elements defined
 436    elsewhere.
 437
 438    (@code{ref} patterns in the full Relax NG syntax can be used to refer
 439    to any pattern definition in the grammar.  Simplification normalizes
 440    the schema so that ref patterns only refer to definitions which have
 441    an @code{element} as their child.)
 442
 443    @see-slot{pattern-element}"
 444   crdepth
 445   target)
 446
 447 (defun pattern-element (ref)
 448   "@arg[ref]{an instance of @class{ref}}
 449    @return{an instance of @class{element}}
 450    @short{Returns the ref pattern's target.}
 451
 452    @code{ref} is the only pattern to introduce shared structure and
 453    circularity into the pattern graph, by referring to elements defined
 454    elsewhere.
 455
 456    (@code{ref} patterns in the full Relax NG syntax can be used to refer
 457    to any pattern definition in the grammar.  Simplification normalizes
 458    the schema so that ref patterns only refer to definitions which have
 459    an @code{element} as their child.)"
 460   (defn-child (pattern-target ref)))
 461
 462 (defstruct (%leaf (:include pattern)))
 463
 464 (defstruct (empty (:include %leaf))
 465   "@short{This pattern specifies that nothing more is expected at the current
 466    position.}")
 467
 468 (defstruct (text (:include %leaf))
 469   "@short{This pattern specifies that text is expected here.}")
 470
 471 (defstruct (%typed-pattern (:include %leaf) (:conc-name "PATTERN-"))
 472   type)
 473
 474 (setf (documentation 'pattern-type 'function)
 475       "@arg[instance]{an instance of @class{pattern}}
 476        @return{a @class{cxml-types:data-type}}
 477        @short{Returns the data type expected at this position.}
 478
 479        This type has already been parsed into an object.  Its name and
 480        the URI of its library can be queried from that object.
 481
 482        @see{data}
 483        @see{value}
 484        @see{cxml-types:type-name}
 485        @see{cxml-types:type-library}")
 486
 487 (defstruct (value (:include %typed-pattern) (:conc-name "PATTERN-"))
 488   "@short{This pattern specifies that a specific value is expected as text
 489    here.}
 490
 491    The value expected is @code{pattern-value}, parsed from
 492    @code{pattern-string} using @code{pattern-type}.
 493
 494    @see-slot{pattern-type}
 495    @see-slot{pattern-value}
 496    @see-slot{pattern-string}"
 497   ns
 498   string
 499   value)
 500
 501 (setf (documentation 'pattern-string 'function)
 502       "@arg[instance]{an instance of @class{value}}
 503        @return{a string}
 504        @short{Returns the string expected at this position.}
 505
 506        This string is the lexical representation expected, not parsed into
 507        a value object yet.  The parsed object is available as
 508        @fun{pattern-value}.
 509
 510        @see{pattern-type}")
 511
 512 (setf (documentation 'pattern-value 'function)
 513       "@arg[instance]{an instance of @class{value}}
 514        @return{an object as returned by @fun{cxml-types:parse}}
 515        @short{Returns the value expected at this position.}
 516
 517        This object is the result of parsing @fun{pattern-string} using
 518        @fun{pattern-type}.")
 519
 520 (defstruct (data (:include %typed-pattern) (:conc-name "PATTERN-"))
 521   "@short{This pattern specifies that text of a specific data type is
 522    expected.}
 523
 524    The data type instance stored in the @code{pattern-type} slot takes into
 525    account additional paramaters, which can be retrieved using
 526    @code{pattern-params} in their original form.
 527
 528    @see-slot{pattern-type}
 529    @see-slot{pattern-params}
 530    @see-slot{pattern-except}"
 531   params
 532   except)
 533
 534 (setf (documentation 'pattern-except 'function)
 535       "@arg[instance]{an instance of @class{data}}
 536        @return{a @class{pattern}, or @code{nil}}
 537        @short{Returns the @code{data} instance's @code{except} pattern.}
 538
 539        In addition to a data type, @code{data} can specify that certain
 540        values are @em{not} permitted.  They are described using a pattern.
 541
 542        If this slot is @code{nil}, no exception is defined.")
 543
 544 (setf (documentation 'pattern-params 'function)
 545       "@arg[instance]{an instance of @class{data}}
 546        @return{a list of @fun{cxml-types:param}}
 547        @short{The data type parameters for this data pattern.}
 548
 549        (With the XSD type library, these are known as restricting facets.)")
 550
 551 (defstruct (not-allowed (:include %leaf))
 552   "@short{This pattern specifies that the part of the schema reached at
 553    this point is not valid.}")
 554
 555
 556 ;;;; non-pattern
 557
 558 (defstruct (grammar (:constructor make-grammar (parent)))
 559   (start nil)
 560   parent
 561   (definitions (make-hash-table :test 'equal)))
 562
 563 ;; Clark calls this structure "RefPattern"
 564 (defstruct (definition (:conc-name "DEFN-"))
 565   name
 566   combine-method
 567   head-p
 568   redefinition
 569   child)
 570
 571 (defstruct (compatibility-table (:conc-name "DTD-"))
 572   (elements (make-hash-table :test 'equal) :type hash-table))
 573
 574 (defstruct (dtd-member (:conc-name "DTD-"))
 575   (name (error "missing") :type name))
 576
 577 (defstruct (dtd-element
 578              (:include dtd-member)
 579              (:conc-name "DTD-")
 580              (:constructor make-dtd-element (name)))
 581   (attributes (make-hash-table :test 'equal) :type hash-table))
 582
 583 (defstruct (dtd-attribute
 584              (:include dtd-member)
 585              (:conc-name "DTD-")
 586              (:constructor make-dtd-attribute (name)))
 587   (default-value nil :type (or null string))
 588   (id-type :unknown :type (member :unknown nil :id :idref :idrefs))
 589   (value-declared-by nil :type list)
 590   (id-type-declared-by nil :type list))
 591
 592 (defun getname (name table)
 593   (gethash (list (name-uri name) (name-lname name)) table))
 594
 595 (defun (setf getname) (newval name table)
 596   (setf (gethash (list (name-uri name) (name-lname name)) table) newval))
 597
 598 (defun ensure-dtd-element (element compatibility-table)
 599   (let ((elements (dtd-elements compatibility-table))
 600         (element-name (pattern-name element)))
 601     (or (getname element-name elements)
 602         (setf (getname element-name elements)
 603               (make-dtd-element element-name)))))
 604
 605 (defun ensure-dtd-attribute (attribute-name element table)
 606   (let* ((dtd-element (ensure-dtd-element element table))
 607          (attributes (dtd-attributes dtd-element))
 608          (a (getname attribute-name attributes)))
 609     (cond
 610       (a
 611        (values a t))
 612       (t
 613        (setf a (make-dtd-attribute attribute-name))
 614        (setf (getname attribute-name attributes) a)
 615        (values a nil)))))
 616
 617
 618 ;;; name-class
 619
 620 (defun missing ()
 621   (error "missing arg"))
 622
 623 (defstruct name-class
 624   "@short{The abstract superclass of all name-related classes.}
 625
 626    Name classes represent sets of permissible names for an element or
 627    attribute.
 628
 629    Names are pairs of namespace URI and local-name.
 630
 631    @see{attribute}
 632    @see{element}")
 633
 634 (defstruct (any-name (:include name-class)
 635                      (:constructor make-any-name (except)))
 636   "@short{This name class allows any name.}
 637
 638    Exceptions are given as @code{any-name-except}.
 639
 640    @see-slot{any-name-except}"
 641   (except (missing) :type (or null name-class)))
 642
 643 (setf (documentation 'any-name-except 'function)
 644       "@arg[instance]{an instance of @class{any-name}}
 645        @return{a @class{name-class} or @code{nil}}
 646
 647        Return the name class @em{not} allowed by this @code{any-name},
 648        or @code{nil} if there is no such exception.")
 649
 650 (defstruct (name (:include name-class)
 651                  (:constructor make-name (uri lname)))
 652   "@short{This name class allows only a specific name.}
 653
 654    A specific namespace URI and local name are expected.
 655
 656    @see-slot{name-uri}
 657    @see-slot{name-lname}"
 658   (uri (missing) :type string)
 659   (lname (missing) :type string))
 660
 661 (setf (documentation 'name-uri 'function)
 662       "@arg[instance]{an instance of @class{name}}
 663        @return{a string}
 664        Return the expected namespace URI.")
 665
 666 (setf (documentation 'name-lname 'function)
 667       "@arg[instance]{an instance of @class{name}}
 668        @return{a string}
 669        Return the expected local name.")
 670
 671 (defstruct (ns-name (:include name-class)
 672                     (:constructor make-ns-name (uri except)))
 673   "@short{This name class allows all names in a specific namespace}, with
 674    possible exceptions.
 675
 676    A specific namespace URI is expected.
 677
 678    Exceptions are given as @code{ns-name-except}.
 679
 680    @see-slot{ns-name-uri}
 681    @see-slot{ns-name-except}"
 682   (uri (missing) :type string)
 683   (except (missing) :type (or null name-class)))
 684
 685 (setf (documentation 'ns-name-uri 'function)
 686       "@arg[instance]{an instance of @class{ns-name}}
 687        @return{a string}
 688        Return the expected namespace URI.")
 689
 690 (setf (documentation 'ns-name-except 'function)
 691       "@arg[instance]{an instance of @class{ns-name}}
 692        @return{a @class{name-class} or @code{nil}}
 693
 694        Return the name class @em{not} allowed by this @code{ns-name},
 695        or @code{nil} if there is no such exception.")
 696
 697 (defstruct (name-class-choice (:include name-class)
 698                               (:constructor make-name-class-choice (a b)))
 699   "@short{This name class represents the union of two other name classes.}
 700
 701    @see-slot{name-class-choice-a}
 702    @see-slot{name-class-choice-b}"
 703   (a (missing) :type name-class)
 704   (b (missing) :type name-class))
 705
 706 (setf (documentation 'name-class-choice-a 'function)
 707       "@arg[instance]{an instance of @class{name-class-choice}}
 708        @return{a @class{name-class}}
 709        Returns the 'first' of two name classes that are allowed.
 710        @see{name-class-choice-b}")
 711
 712 (setf (documentation 'name-class-choice-b 'function)
 713       "@arg[instance]{an instance of @class{name-class-choice}}
 714        @return{a @class{name-class}}
 715        Returns the 'second' of two name classes that are allowed.
 716        @see{name-class-choice-a}")
 717
 718 (defun simplify-nc-choice (values)
 719   (zip #'make-name-class-choice values))
 720
 721
 722 ;;;; parser
 723
 724 (defvar *rng-namespace* "http://relaxng.org/ns/structure/1.0")
 725
 726 (defun skip-foreign* (source)
 727   (loop
 728     (case (klacks:peek-next source)
 729       (:start-element (skip-foreign source))
 730       (:end-element (return)))))
 731
 732 (defun skip-to-native (source)
 733   (loop
 734     (case (klacks:peek source)
 735       (:start-element
 736         (when (equal (klacks:current-uri source) *rng-namespace*)
 737           (return))
 738         (klacks:serialize-element source nil))
 739       (:end-element (return)))
 740     (klacks:consume source)))
 741
 742 (defun consume-and-skip-to-native (source)
 743   (klacks:consume source)
 744   (skip-to-native source))
 745
 746 (defun skip-foreign (source)
 747   (when (equal (klacks:current-uri source) *rng-namespace*)
 748     (rng-error source
 749                "invalid schema: ~A not allowed here"
 750                (klacks:current-lname source)))
 751   (klacks:serialize-element source nil))
 752
 753 (defun attribute (lname attrs)
 754   "@unexport{}"
 755   (let ((a (sax:find-attribute-ns "" lname attrs)))
 756     (if a
 757         (sax:attribute-value a)
 758         nil)))
 759
 760 (defparameter *whitespace*
 761     (format nil "~C~C~C~C"
 762             (code-char 9)
 763             (code-char 32)
 764             (code-char 13)
 765             (code-char 10)))
 766
 767 (defun ntc (lname source-or-attrs)
 768   ;; used for (n)ame, (t)ype, and (c)ombine, this also strips whitespace
 769   (let* ((attrs
 770           (if (listp source-or-attrs)
 771               source-or-attrs
 772               (klacks:list-attributes source-or-attrs)))
 773          (a (sax:find-attribute-ns "" lname attrs)))
 774     (if a
 775         (string-trim *whitespace* (sax:attribute-value a))
 776         nil)))
 777
 778 (defmacro with-library-and-ns (attrs &body body)
 779   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 780
 781 (defun invoke-with-library-and-ns (fn attrs)
 782   (let* ((dl (attribute "datatypeLibrary" attrs))
 783          (ns (attribute "ns" attrs))
 784          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 785          (*namespace-uri* (or ns *namespace-uri*))
 786          (*ns* ns))
 787     ;; FIXME: Ganz boese gehackt -- gerade so, dass wir die Relax NG
 788     ;; Test-Suite bestehen.
 789     (when (and dl
 790                (not (zerop (length *datatype-library*)))
 791                ;; scheme pruefen, und es muss was folgen
 792                (or (not (cl-ppcre:all-matches
 793                          "^[a-zA-Z][a-zA-Z0-9+.-]*:.+"
 794                          *datatype-library*))
 795                    ;; keine kaputten %te, keine #
 796                    (cl-ppcre:all-matches
 797                     "(%$|%.$|%[^0-9A-Fa-f][^0-9A-Fa-f]|#)"
 798                     *datatype-library*)))
 799       (rng-error nil "malformed datatypeLibrary: ~A" *datatype-library*))
 800     (funcall fn)))
 801
 802 (defun p/pattern (source)
 803   (let* ((lname (klacks:current-lname source))
 804          (attrs (klacks:list-attributes source)))
 805     (with-library-and-ns attrs
 806       (case (find-symbol lname :keyword)
 807         (:|element|     (p/element source (ntc "name" attrs)))
 808         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 809         (:|group|       (p/combination #'groupify source))
 810         (:|interleave|  (p/combination #'interleave-ify source))
 811         (:|choice|      (p/combination #'choice-ify source))
 812         (:|optional|    (p/optional source))
 813         (:|zeroOrMore|  (p/zero-or-more source))
 814         (:|oneOrMore|   (p/one-or-more source))
 815         (:|list|        (p/list source))
 816         (:|mixed|       (p/mixed source))
 817         (:|ref|         (p/ref source))
 818         (:|parentRef|   (p/parent-ref source))
 819         (:|empty|       (p/empty source))
 820         (:|text|        (p/text source))
 821         (:|value|       (p/value source))
 822         (:|data|        (p/data source))
 823         (:|notAllowed|  (p/not-allowed source))
 824         (:|externalRef| (p/external-ref source))
 825         (:|grammar|     (p/grammar source))
 826         (t (skip-foreign source))))))
 827
 828 (defun p/pattern+ (source)
 829   (let ((children nil))
 830     (loop
 831       (case (klacks:peek source)
 832         (:start-element
 833           (let ((p (p/pattern source))) (when p (push p children))))
 834         (:end-element
 835           (return))
 836         (t
 837           (klacks:consume source))))
 838     (unless children
 839       (rng-error source "empty element"))
 840     (nreverse children)))
 841
 842 (defun p/pattern? (source)
 843   (let ((result nil))
 844     (loop
 845       (skip-to-native source)
 846       (case (klacks:peek source)
 847         (:start-element
 848           (when result
 849             (rng-error source "at most one pattern expected here"))
 850           (setf result (p/pattern source)))
 851         (:end-element
 852           (return))
 853         (t
 854           (klacks:consume source))))
 855     result))
 856
 857 (defun p/element (source name)
 858   (klacks:expecting-element (source "element")
 859     (let ((elt (make-element)))
 860       (consume-and-skip-to-native source)
 861       (if name
 862           (setf (pattern-name elt) (destructure-name source name))
 863           (setf (pattern-name elt) (p/name-class source)))
 864       (skip-to-native source)
 865       (setf (pattern-child elt) (groupify (p/pattern+ source)))
 866       (make-ref (make-definition :name (gensym "ANONYMOUS") :child elt)))))
 867
 868 (defvar *attribute-namespace-p* nil)
 869
 870 (defun p/attribute (source name)
 871   (klacks:expecting-element (source "attribute")
 872     (let* ((dv
 873             (when *process-dtd-compatibility*
 874               (sax:find-attribute-ns
 875                "http://relaxng.org/ns/compatibility/annotations/1.0"
 876                "defaultValue"
 877                (klacks:list-attributes source))))
 878            (result (make-attribute (when dv (sax:attribute-value dv)))))
 879       (consume-and-skip-to-native source)
 880       (if name
 881           (setf (pattern-name result)
 882                 (let ((*namespace-uri* (or *ns* ""))
 883                       (*attribute-namespace-p* t))
 884                   (destructure-name source name)))
 885           (setf (pattern-name result)
 886                 (let ((*attribute-namespace-p* t))
 887                   (p/name-class source))))
 888       (skip-to-native source)
 889       (setf (pattern-child result)
 890             (or (p/pattern? source) (make-text)))
 891       result)))
 892
 893 (defun p/combination (zipper source)
 894   (klacks:expecting-element (source)
 895     (consume-and-skip-to-native source)
 896     (funcall zipper (p/pattern+ source))))
 897
 898 (defun p/one-or-more (source)
 899   (klacks:expecting-element (source "oneOrMore")
 900     (consume-and-skip-to-native source)
 901     (let ((children (p/pattern+ source)))
 902       (make-one-or-more (groupify children)))))
 903
 904 (defun p/zero-or-more (source)
 905   (klacks:expecting-element (source "zeroOrMore")
 906     (consume-and-skip-to-native source)
 907     (let ((children (p/pattern+ source)))
 908       (make-choice (make-one-or-more (groupify children))
 909                    (make-empty)))))
 910
 911 (defun p/optional (source)
 912   (klacks:expecting-element (source "optional")
 913     (consume-and-skip-to-native source)
 914     (let ((children (p/pattern+ source)))
 915       (make-choice (groupify children) (make-empty)))))
 916
 917 (defun p/list (source)
 918   (klacks:expecting-element (source "list")
 919     (consume-and-skip-to-native source)
 920     (let ((children (p/pattern+ source)))
 921       (make-list-pattern (groupify children)))))
 922
 923 (defun p/mixed (source)
 924   (klacks:expecting-element (source "mixed")
 925     (consume-and-skip-to-native source)
 926     (let ((children (p/pattern+ source)))
 927       (make-interleave (groupify children) (make-text)))))
 928
 929 (defun p/ref (source)
 930   (klacks:expecting-element (source "ref")
 931     (prog1
 932         (let* ((name (ntc "name" source))
 933                (pdefinition
 934                 (or (find-definition name)
 935                     (setf (find-definition name)
 936                           (make-definition :name name :child nil)))))
 937           (make-ref pdefinition))
 938       (skip-foreign* source))))
 939
 940 (defun p/parent-ref (source)
 941   (klacks:expecting-element (source "parentRef")
 942     (prog1
 943         (let* ((name (ntc "name" source))
 944                (grammar (grammar-parent *grammar*))
 945                (pdefinition
 946                 (or (find-definition name grammar)
 947                     (setf (find-definition name grammar)
 948                           (make-definition :name name :child nil)))))
 949           (make-ref pdefinition))
 950       (skip-foreign* source))))
 951
 952 (defun p/empty (source)
 953   (klacks:expecting-element (source "empty")
 954     (skip-foreign* source)
 955     (make-empty)))
 956
 957 (defun p/text (source)
 958   (klacks:expecting-element (source "text")
 959     (skip-foreign* source)
 960     (make-text)))
 961
 962 (defun consume-and-parse-characters (source)
 963   ;; fixme
 964   (let ((tmp ""))
 965     (loop
 966       (multiple-value-bind (key data) (klacks:peek-next source)
 967         (case key
 968           (:characters
 969             (setf tmp (concatenate 'string tmp data)))
 970           (:end-element (return)))))
 971     tmp))
 972
 973 (defun p/value (source)
 974   (klacks:expecting-element (source "value")
 975     (let* ((type (ntc "type" source))
 976            (string (consume-and-parse-characters source))
 977            (ns *namespace-uri*)
 978            (dl *datatype-library*))
 979       (unless type
 980         (setf type "token")
 981         (setf dl ""))
 982       (let ((data-type
 983              (cxml-types:find-type (and dl (find-symbol dl :keyword))
 984                                    type
 985                                    nil))
 986             (vc (cxml-types:make-klacks-validation-context source)))
 987         (unless data-type
 988           (rng-error source "type not found: ~A/~A" type dl))
 989         (make-value :string string
 990                     :value (cxml-types:parse data-type string vc)
 991                     :type data-type
 992                     :ns ns)))))
 993
 994 (defun p/data (source)
 995   (klacks:expecting-element (source "data")
 996     (let* ((type (ntc "type" source))
 997            (params '())
 998            (except nil))
 999       (loop
1000          (multiple-value-bind (key uri lname)
1001              (klacks:peek-next source)
1002            uri
1003            (case key
1004              (:start-element
1005               (case (find-symbol lname :keyword)
1006                 (:|param| (push (p/param source) params))
1007                 (:|except|
1008                   (setf except (p/except-pattern source))
1009                   (skip-to-native source)
1010                   (return))
1011                 (t (skip-foreign source))))
1012              (:end-element
1013               (return)))))
1014       (setf params (nreverse params))
1015       (let* ((dl *datatype-library*)
1016              (data-type (cxml-types:find-type
1017                          (and dl (find-symbol dl :keyword))
1018                          type
1019                          params)))
1020         (unless data-type
1021           (rng-error source "type not found: ~A/~A" type dl))
1022         (when (eq data-type :error)
1023           (rng-error source "params not valid for type: ~A/~A/~A"
1024                      type dl params))
1025         (make-data
1026          :type data-type
1027          :params params
1028          :except except)))))
1029
1030 (defun p/param (source)
1031   (klacks:expecting-element (source "param")
1032     (let ((name (ntc "name" source))
1033           (string (consume-and-parse-characters source)))
1034       (cxml-types:make-param name string))))
1035
1036 (defun p/except-pattern (source)
1037   (klacks:expecting-element (source "except")
1038     (with-library-and-ns (klacks:list-attributes source)
1039       (klacks:consume source)
1040       (choice-ify (p/pattern+ source)))))
1041
1042 (defun p/not-allowed (source)
1043   (klacks:expecting-element (source "notAllowed")
1044     (consume-and-skip-to-native source)
1045     (make-not-allowed)))
1046
1047 (defun safe-parse-uri (source str &optional base)
1048   (when (zerop (length str))
1049     (rng-error source "missing URI"))
1050   (let* ((compactp (rnc-uri-p str))
1051          (str (if compactp (follow-rnc-uri str) str))
1052          (uri
1053           (handler-case
1054               (if base
1055                   (puri:merge-uris str base)
1056                   (puri:parse-uri str))
1057             (puri:uri-parse-error ()
1058               (rng-error source "invalid URI: ~A" str)))))
1059     (when (and (eq (puri:uri-scheme uri) :file)
1060                (puri:uri-fragment uri))
1061       (rng-error source "Forbidden fragment in URI: ~A" str))
1062     (values uri compactp)))
1063
1064 (defun named-string-xstream (str uri)
1065   (let ((xstream (cxml::string->xstream str)))
1066     (setf (cxml::xstream-name xstream)
1067           (cxml::make-stream-name
1068            :entity-name "main document"
1069            :entity-kind :main
1070            :uri uri))
1071     xstream))
1072
1073 (defun xstream-open-schema (uri compactp)
1074   (if compactp
1075       (named-string-xstream
1076        (uncompact-file
1077         ;; fixme: Hier waere es schon, mit *entity-resolver* arbeiten
1078         ;; zu koennen, aber der liefert binaere Streams.
1079         (open (cxml::uri-to-pathname uri)
1080               :element-type 'character
1081               :direction :input))
1082        uri)
1083       (cxml::xstream-open-extid* *entity-resolver* nil uri)))
1084
1085 (defun p/external-ref (source)
1086   (klacks:expecting-element (source "externalRef")
1087     (let* ((href
1088             (escape-uri (attribute "href" (klacks:list-attributes source))))
1089            (base (klacks:current-xml-base source)))
1090       (multiple-value-bind (uri compactp)
1091           (safe-parse-uri source href base)
1092         (when (find uri *include-uri-stack* :test #'puri:uri=)
1093           (rng-error source "looping include"))
1094         (prog1
1095             (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
1096                    (xstream (xstream-open-schema uri compactp)))
1097               (klacks:with-open-source
1098                   (source (make-schema-source xstream))
1099                 (invoke-with-klacks-handler
1100                  (lambda ()
1101                    (klacks:find-event source :start-element)
1102                    (let ((*datatype-library* ""))
1103                      (p/pattern source)))
1104                  source)))
1105           (skip-foreign* source))))))
1106
1107 (defun p/grammar (source &optional grammar)
1108   (klacks:expecting-element (source "grammar")
1109     (consume-and-skip-to-native source)
1110     (let ((*grammar* (or grammar (make-grammar *grammar*)))
1111           (includep grammar))
1112       (process-grammar-content* source)
1113       (unless (or includep (grammar-start *grammar*))
1114         (rng-error source "no <start> in grammar"))
1115       (unless includep
1116         (check-pattern-definitions source *grammar*)
1117         (defn-child (grammar-start *grammar*))))))
1118
1119 (defvar *include-start*)
1120 (defvar *include-definitions*)
1121
1122 (defun process-grammar-content* (source &key disallow-include)
1123   (loop
1124     (multiple-value-bind (key uri lname) (klacks:peek source)
1125       uri
1126       (ecase key
1127         (:characters
1128          (klacks:consume source))
1129         (:start-element
1130          (with-library-and-ns (klacks:list-attributes source)
1131            (case (find-symbol lname :keyword)
1132              (:|start|
1133                (process-start source))
1134              (:|define| (process-define source))
1135              (:|div| (process-div source))
1136              (:|include|
1137                (when disallow-include
1138                  (rng-error source "nested include not permitted"))
1139                (process-include source))
1140              (t
1141               (skip-foreign source)))))
1142         (:end-element
1143          (return))))))
1144
1145 (defun process-start (source)
1146   (klacks:expecting-element (source "start")
1147     (let* ((combine0 (ntc "combine" source))
1148            (combine
1149             (when combine0
1150               (find-symbol (string-upcase combine0) :keyword)))
1151            (child
1152             (progn
1153               (consume-and-skip-to-native source)
1154               (p/pattern source)))
1155            (pdefinition (grammar-start *grammar*)))
1156       (skip-foreign* source)
1157       ;; fixme: shared code with process-define
1158       (unless pdefinition
1159         (setf pdefinition (make-definition :name :start :child nil))
1160         (setf (grammar-start *grammar*) pdefinition))
1161       (when *include-body-p*
1162         (setf *include-start* pdefinition))
1163       (cond
1164         ((defn-child pdefinition)
1165          (ecase (defn-redefinition pdefinition)
1166            (:not-being-redefined
1167              (when (and combine
1168                         (defn-combine-method pdefinition)
1169                         (not (eq combine
1170                                  (defn-combine-method pdefinition))))
1171                (rng-error source "conflicting combine values for <start>"))
1172              (unless combine
1173                (when (defn-head-p pdefinition)
1174                  (rng-error source "multiple definitions for <start>"))
1175                (setf (defn-head-p pdefinition) t))
1176              (unless (defn-combine-method pdefinition)
1177                (setf (defn-combine-method pdefinition) combine))
1178              (setf (defn-child pdefinition)
1179                    (case (defn-combine-method pdefinition)
1180                      (:choice
1181                        (make-choice (defn-child pdefinition) child))
1182                      (:interleave
1183                        (make-interleave (defn-child pdefinition) child)))))
1184            (:being-redefined-and-no-original
1185              (setf (defn-redefinition pdefinition)
1186                    :being-redefined-and-original))
1187            (:being-redefined-and-original)))
1188         (t
1189           (setf (defn-child pdefinition) child)
1190           (setf (defn-combine-method pdefinition) combine)
1191           (setf (defn-head-p pdefinition) (null combine))
1192           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
1193
1194 (defun zip (constructor children)
1195   (cond
1196     ((null children)
1197       (rng-error nil "empty choice?"))
1198     ((null (cdr children))
1199       (car children))
1200     (t
1201       (destructuring-bind (a b &rest rest)
1202           children
1203         (zip constructor (cons (funcall constructor a b) rest))))))
1204
1205 (defun choice-ify (children) (zip #'make-choice children))
1206 (defun groupify (children) (zip #'make-group children))
1207 (defun interleave-ify (children) (zip #'make-interleave children))
1208
1209 (defun find-definition (name &optional (grammar *grammar*))
1210   (gethash name (grammar-definitions grammar)))
1211
1212 (defun (setf find-definition) (newval name &optional (grammar *grammar*))
1213   (setf (gethash name (grammar-definitions grammar)) newval))
1214
1215 (defun process-define (source)
1216   (klacks:expecting-element (source "define")
1217     (let* ((name (ntc "name" source))
1218            (combine0 (ntc "combine" source))
1219            (combine (when combine0
1220                       (find-symbol (string-upcase combine0) :keyword)))
1221            (child (groupify
1222                    (progn
1223                      (consume-and-skip-to-native source)
1224                      (p/pattern+ source))))
1225            (pdefinition (find-definition name)))
1226       (unless pdefinition
1227         (setf pdefinition (make-definition :name name :child nil))
1228         (setf (find-definition name) pdefinition))
1229       (when *include-body-p*
1230         (push pdefinition *include-definitions*))
1231       (cond
1232         ((defn-child pdefinition)
1233           (case (defn-redefinition pdefinition)
1234             (:not-being-redefined
1235               (when (and combine
1236                          (defn-combine-method pdefinition)
1237                          (not (eq combine
1238                                   (defn-combine-method pdefinition))))
1239                 (rng-error source "conflicting combine values for ~A" name))
1240               (unless combine
1241                 (when (defn-head-p pdefinition)
1242                   (rng-error source "multiple definitions for ~A" name))
1243                 (setf (defn-head-p pdefinition) t))
1244               (unless (defn-combine-method pdefinition)
1245                 (setf (defn-combine-method pdefinition) combine))
1246               (setf (defn-child pdefinition)
1247                     (case (defn-combine-method pdefinition)
1248                       (:choice
1249                         (make-choice (defn-child pdefinition) child))
1250                       (:interleave
1251                         (make-interleave (defn-child pdefinition) child)))))
1252             (:being-redefined-and-no-original
1253               (setf (defn-redefinition pdefinition)
1254                     :being-redefined-and-original))
1255             (:being-redefined-and-original)))
1256         (t
1257           (setf (defn-child pdefinition) child)
1258           (setf (defn-combine-method pdefinition) combine)
1259           (setf (defn-head-p pdefinition) (null combine))
1260           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
1261
1262 (defun process-div (source)
1263   (klacks:expecting-element (source "div")
1264     (consume-and-skip-to-native source)
1265     (process-grammar-content* source)))
1266
1267 (defun reset-definition-for-include (defn)
1268   (setf (defn-combine-method defn) nil)
1269   (setf (defn-redefinition defn) :being-redefined-and-no-original)
1270   (setf (defn-head-p defn) nil))
1271
1272 (defun restore-definition (defn original)
1273   (setf (defn-combine-method defn) (defn-combine-method original))
1274   (setf (defn-redefinition defn) (defn-redefinition original))
1275   (setf (defn-head-p defn) (defn-head-p original)))
1276
1277 (defun process-include (source)
1278   (klacks:expecting-element (source "include")
1279     (let* ((href
1280             (escape-uri (attribute "href" (klacks:list-attributes source))))
1281            (base (klacks:current-xml-base source))
1282            (*include-start* nil)
1283            (*include-definitions* '()))
1284       (multiple-value-bind (uri compactp)
1285           (safe-parse-uri source href base)
1286         (consume-and-skip-to-native source)
1287         (let ((*include-body-p* t))
1288           (process-grammar-content* source :disallow-include t))
1289         (let ((tmp-start
1290                (when *include-start*
1291                  (prog1
1292                      (copy-structure *include-start*)
1293                    (reset-definition-for-include *include-start*))))
1294               (tmp-defns
1295                (loop
1296                   for defn in *include-definitions*
1297                   collect
1298                   (prog1
1299                       (copy-structure defn)
1300                     (reset-definition-for-include defn)))))
1301           (when (find uri *include-uri-stack* :test #'puri:uri=)
1302             (rng-error source "looping include"))
1303           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
1304                  (xstream (xstream-open-schema uri compactp)))
1305             (klacks:with-open-source (source (make-schema-source xstream))
1306               (invoke-with-klacks-handler
1307                (lambda ()
1308                  (klacks:find-event source :start-element)
1309                  (let ((*datatype-library* ""))
1310                    (p/grammar source *grammar*)))
1311                source))
1312             (when tmp-start
1313               (when (eq (defn-redefinition *include-start*)
1314                         :being-redefined-and-no-original)
1315                 (rng-error source "start not found in redefinition of grammar"))
1316               (restore-definition *include-start* tmp-start))
1317             (dolist (copy tmp-defns)
1318               (let ((defn (gethash (defn-name copy)
1319                                    (grammar-definitions *grammar*))))
1320                 (when (eq (defn-redefinition defn)
1321                           :being-redefined-and-no-original)
1322                   (rng-error source "redefinition not found in grammar"))
1323                 (restore-definition defn copy)))
1324             nil))))))
1325
1326 (defun check-pattern-definitions (source grammar)
1327   (when (and (grammar-start grammar)
1328              (eq (defn-redefinition (grammar-start grammar))
1329                  :being-redefined-and-no-original))
1330     (rng-error source "start not found in redefinition of grammar"))
1331   (loop for defn being each hash-value in (grammar-definitions grammar) do
1332         (when (eq (defn-redefinition defn) :being-redefined-and-no-original)
1333           (rng-error source "redefinition not found in grammar"))
1334         (unless (defn-child defn)
1335           (rng-error source "unresolved reference to ~A" (defn-name defn)))))
1336
1337 (defvar *any-name-allowed-p* t)
1338 (defvar *ns-name-allowed-p* t)
1339
1340 (defun destructure-name (source qname)
1341   (multiple-value-bind (uri lname)
1342       (klacks:decode-qname qname source)
1343     (setf uri (or uri *namespace-uri*))
1344     (when (and *attribute-namespace-p*
1345                (or (and (equal lname "xmlns") (equal uri ""))
1346                    (equal uri "http://www.w3.org/2000/xmlns")))
1347       (rng-error source "namespace attribute not permitted"))
1348     (make-name uri lname)))
1349
1350 (defun p/name-class (source)
1351   (klacks:expecting-element (source)
1352     (with-library-and-ns (klacks:list-attributes source)
1353       (case (find-symbol (klacks:current-lname source) :keyword)
1354         (:|name|
1355           (let ((qname (string-trim *whitespace*
1356                                     (consume-and-parse-characters source))))
1357             (destructure-name source qname)))
1358         (:|anyName|
1359           (unless *any-name-allowed-p*
1360             (rng-error source "anyname not permitted in except"))
1361           (klacks:consume source)
1362           (prog1
1363               (let ((*any-name-allowed-p* nil))
1364                 (make-any-name (p/except-name-class? source)))
1365             (skip-to-native source)))
1366         (:|nsName|
1367           (unless *ns-name-allowed-p*
1368             (rng-error source "nsname not permitted in except"))
1369           (let ((uri *namespace-uri*)
1370                 (*any-name-allowed-p* nil)
1371                 (*ns-name-allowed-p* nil))
1372             (when (and *attribute-namespace-p*
1373                        (equal uri "http://www.w3.org/2000/xmlns"))
1374               (rng-error source "namespace attribute not permitted"))
1375             (klacks:consume source)
1376             (prog1
1377                 (make-ns-name uri (p/except-name-class? source))
1378               (skip-to-native source))))
1379         (:|choice|
1380           (klacks:consume source)
1381           (simplify-nc-choice (p/name-class* source)))
1382         (t
1383           (rng-error source "invalid child in except"))))))
1384
1385 (defun p/name-class* (source)
1386   (let ((results nil))
1387     (loop
1388       (skip-to-native source)
1389       (case (klacks:peek source)
1390         (:characters
1391          (klacks:consume source))
1392         (:start-element
1393          (push (p/name-class source) results))
1394         (:end-element
1395          (return))))
1396     (nreverse results)))
1397
1398 (defun p/except-name-class? (source)
1399   (skip-to-native source)
1400   (multiple-value-bind (key uri lname)
1401       (klacks:peek source)
1402     uri
1403     (if (and (eq key :start-element)
1404              (string= (find-symbol lname :keyword) "except"))
1405         (p/except-name-class source)
1406         nil)))
1407
1408 (defun p/except-name-class (source)
1409   (klacks:expecting-element (source "except")
1410     (with-library-and-ns (klacks:list-attributes source)
1411       (klacks:consume source)
1412       (let ((x (p/name-class* source)))
1413         (if (cdr x)
1414             (simplify-nc-choice x)
1415             (car x))))))
1416
1417 (defun escape-uri (string)
1418   (with-output-to-string (out)
1419     (loop for c across (cxml::rod-to-utf8-string string) do
1420           (let ((code (char-code c)))
1421             ;; http://www.w3.org/TR/xlink/#link-locators
1422             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
1423                 (format out "%~2,'0X" code)
1424                 (write-char c out))))))
1425
1426
1427 ;;;; unparsing
1428
1429 (defvar *definitions-to-names*)
1430 (defvar *seen-names*)
1431
1432 (defun serialization-name (defn)
1433   (or (gethash defn *definitions-to-names*)
1434       (setf (gethash defn *definitions-to-names*)
1435             (let ((name (if (gethash (defn-name defn) *seen-names*)
1436                             (format nil "~A-~D"
1437                                     (defn-name defn)
1438                                     (hash-table-count *seen-names*))
1439                             (defn-name defn))))
1440               (setf (gethash name *seen-names*) defn)
1441               name))))
1442
1443 (defun serialize-schema (schema sink)
1444   "@arg[schema]{a Relax NG @class{schema}}
1445    @arg[sink]{a SAX handler}
1446    @return{the result of @code{sax:end-document}}
1447    @short{This function serializes a parsed Relax NG back into XML syntax.}
1448
1449    Note that the schema represented in memory has gone through simplification
1450    as is textually different from the original XML document.
1451
1452    @see{parse-schema}"
1453   (cxml:with-xml-output sink
1454     (let ((*definitions-to-names* (make-hash-table))
1455           (*seen-names* (make-hash-table :test 'equal)))
1456       (cxml:with-element "grammar"
1457         (cxml:with-element "start"
1458           (serialize-pattern (schema-start schema)))
1459         (loop for defn being each hash-key in *definitions-to-names* do
1460               (serialize-definition defn))))))
1461
1462 (defun serialize-pattern (pattern)
1463   (etypecase pattern
1464     (element
1465       (cxml:with-element "element"
1466         (serialize-name (pattern-name pattern))
1467         (serialize-pattern (pattern-child pattern))))
1468     (attribute
1469       (cxml:with-element "attribute"
1470         (serialize-name (pattern-name pattern))
1471         (serialize-pattern (pattern-child pattern))))
1472     (%combination
1473       (cxml:with-element
1474           (etypecase pattern
1475             (group "group")
1476             (interleave "interleave")
1477             (choice "choice"))
1478         (serialize-pattern (pattern-a pattern))
1479         (serialize-pattern (pattern-b pattern))))
1480     (one-or-more
1481       (cxml:with-element "oneOrMore"
1482         (serialize-pattern (pattern-child pattern))))
1483     (list-pattern
1484       (cxml:with-element "list"
1485         (serialize-pattern (pattern-child pattern))))
1486     (ref
1487       (cxml:with-element "ref"
1488         (cxml:attribute "name" (serialization-name (pattern-target pattern)))))
1489     (empty
1490       (cxml:with-element "empty"))
1491     (not-allowed
1492       (cxml:with-element "notAllowed"))
1493     (text
1494       (cxml:with-element "text"))
1495     (value
1496       (cxml:with-element "value"
1497         (let ((type (pattern-type pattern)))
1498           (cxml:attribute "datatype-library"
1499                           (symbol-name (cxml-types:type-library type)))
1500           (cxml:attribute "type" (cxml-types:type-name type)))
1501         (cxml:attribute "ns" (pattern-ns pattern))
1502         (cxml:text (pattern-string pattern))))
1503     (data
1504       (cxml:with-element "value"
1505         (let ((type (pattern-type pattern)))
1506           (cxml:attribute "datatype-library"
1507                           (symbol-name (cxml-types:type-library type)))
1508           (cxml:attribute "type" (cxml-types:type-name type)))
1509         (dolist (param (pattern-params pattern))
1510           (cxml:with-element "param"
1511             (cxml:attribute "name" (cxml-types:param-name param))
1512             (cxml:text (cxml-types:param-value param))))
1513         (when (pattern-except pattern)
1514           (cxml:with-element "except"
1515             (serialize-pattern (pattern-except pattern))))))))
1516
1517 (defun serialize-definition (defn)
1518   (cxml:with-element "define"
1519     (cxml:attribute "name" (serialization-name defn))
1520     (serialize-pattern (defn-child defn))))
1521
1522 (defun serialize-name (name)
1523   (etypecase name
1524     (name
1525      (cxml:with-element "name"
1526        (cxml:attribute "ns" (name-uri name))
1527        (cxml:text (name-lname name))))
1528     (any-name
1529      (cxml:with-element "anyName"
1530        (when (any-name-except name)
1531          (serialize-except-name (any-name-except name)))))
1532     (ns-name
1533      (cxml:with-element "anyName"
1534        (cxml:attribute "ns" (ns-name-uri name))
1535        (when (ns-name-except name)
1536          (serialize-except-name (ns-name-except name)))))
1537     (name-class-choice
1538      (cxml:with-element "choice"
1539        (serialize-name (name-class-choice-a name))
1540        (serialize-name (name-class-choice-b name))))))
1541
1542 (defun serialize-except-name (spec)
1543   (cxml:with-element "except"
1544     (serialize-name spec)))
1545
1546
1547 ;;;; simplification
1548
1549 ;;; 4.1 Annotations
1550 ;;;   Foreign attributes and elements are removed implicitly while parsing.
1551
1552 ;;; 4.2 Whitespace
1553 ;;;   All character data is discarded while parsing (which can only be
1554 ;;;   whitespace after validation).
1555 ;;;
1556 ;;;   Whitespace in name, type, and combine attributes is stripped while
1557 ;;;   parsing.  Ditto for <name/>.
1558
1559 ;;; 4.3. datatypeLibrary attribute
1560 ;;;   Escaping is done by p/pattern.
1561 ;;;   Attribute value defaulting is done using *datatype-library*; only
1562 ;;;   p/data and p/value record the computed value.
1563
1564 ;;; 4.4. type attribute of value element
1565 ;;;   Done by p/value.
1566
1567 ;;; 4.5. href attribute
1568 ;;;   Escaping is done by process-include and p/external-ref.
1569 ;;;
1570 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
1571 ;;;   but that requires xstream hacking.
1572
1573 ;;; 4.6. externalRef element
1574 ;;;   Done by p/external-ref.
1575
1576 ;;; 4.7. include element
1577 ;;;   Done by process-include.
1578
1579 ;;; 4.8. name attribute of element and attribute elements
1580 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
1581 ;;;    p/attribute.
1582
1583 ;;; 4.9. ns attribute
1584 ;;;    done by p/name-class, p/value, p/element, p/attribute
1585
1586 ;;; 4.10. QNames
1587 ;;;    done by p/name-class
1588
1589 ;;; 4.11. div element
1590 ;;;    Legen wir gar nicht erst an.
1591
1592 ;;; 4.12. 4.13 4.14 4.15
1593 ;;;    beim anlegen
1594
1595 ;;; 4.16
1596 ;;;    p/name-class
1597 ;;;    -- ausser der sache mit den datentypen
1598
1599 ;;; 4.17, 4.18, 4.19
1600 ;;;    Ueber die Grammar-und Definition Objekte, wie von James Clark
1601 ;;;    beschrieben.
1602 ;;;
1603 ;;;    Dabei werden keine Umbenennungen vorgenommen, weil Referenzierung
1604 ;;;    durch Aufbei der Graphenstruktur zwischen ref und Definition
1605 ;;;    erfolgt und Namen dann bereits aufgeloest sind.  Wir benennen
1606 ;;;    dafuer beim Serialisieren um.
1607
1608 (defmethod check-recursion ((pattern element) depth)
1609   (check-recursion (pattern-child pattern) (1+ depth)))
1610
1611 (defmethod check-recursion ((pattern ref) depth)
1612   (when (eql (pattern-crdepth pattern) depth)
1613     (rng-error nil "infinite recursion in ~A"
1614                (defn-name (pattern-target pattern))))
1615   (when (null (pattern-crdepth pattern))
1616     (setf (pattern-crdepth pattern) depth)
1617     (check-recursion (defn-child (pattern-target pattern)) depth)
1618     (setf (pattern-crdepth pattern) t)))
1619
1620 (defmethod check-recursion ((pattern %parent) depth)
1621   (check-recursion (pattern-child pattern) depth))
1622
1623 (defmethod check-recursion ((pattern %combination) depth)
1624   (check-recursion (pattern-a pattern) depth)
1625   (check-recursion (pattern-b pattern) depth))
1626
1627 (defmethod check-recursion ((pattern %leaf) depth)
1628   (declare (ignore depth)))
1629
1630 (defmethod check-recursion ((pattern data) depth)
1631   (when (pattern-except pattern)
1632     (check-recursion (pattern-except pattern) depth)))
1633
1634
1635 ;;;; 4.20
1636
1637 ;;; %PARENT
1638
1639 (defmethod fold-not-allowed ((pattern element))
1640   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1641   pattern)
1642
1643 (defmethod fold-not-allowed ((pattern %parent))
1644   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1645   (if (typep (pattern-child pattern) 'not-allowed)
1646       (pattern-child pattern)
1647       pattern))
1648
1649 ;;; %COMBINATION
1650
1651 (defmethod fold-not-allowed ((pattern %combination))
1652   (setf (pattern-a pattern) (fold-not-allowed (pattern-a pattern)))
1653   (setf (pattern-b pattern) (fold-not-allowed (pattern-b pattern)))
1654   pattern)
1655
1656 (defmethod fold-not-allowed ((pattern group))
1657   (call-next-method)
1658   (cond
1659     ;; remove if any child is not allowed
1660     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1661     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1662     (t pattern)))
1663
1664 (defmethod fold-not-allowed ((pattern interleave))
1665   (call-next-method)
1666   (cond
1667     ;; remove if any child is not allowed
1668     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1669     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1670     (t pattern)))
1671
1672 (defmethod fold-not-allowed ((pattern choice))
1673   (call-next-method)
1674   (cond
1675     ;; if any child is not allowed, choose the other
1676     ((typep (pattern-a pattern) 'not-allowed) (pattern-b pattern))
1677     ((typep (pattern-b pattern) 'not-allowed) (pattern-a pattern))
1678     (t pattern)))
1679
1680 ;;; LEAF
1681
1682 (defmethod fold-not-allowed ((pattern %leaf))
1683   pattern)
1684
1685 (defmethod fold-not-allowed ((pattern data))
1686   (when (pattern-except pattern)
1687     (setf (pattern-except pattern) (fold-not-allowed (pattern-except pattern)))
1688     (when (typep (pattern-except pattern) 'not-allowed)
1689       (setf (pattern-except pattern) nil)))
1690   pattern)
1691
1692 ;;; REF
1693
1694 (defmethod fold-not-allowed ((pattern ref))
1695   pattern)
1696
1697
1698 ;;;; 4.21
1699
1700 ;;; %PARENT
1701
1702 (defmethod fold-empty ((pattern one-or-more))
1703   (call-next-method)
1704   (if (typep (pattern-child pattern) 'empty)
1705       (pattern-child pattern)
1706       pattern))
1707
1708 (defmethod fold-empty ((pattern %parent))
1709   (setf (pattern-child pattern) (fold-empty (pattern-child pattern)))
1710   pattern)
1711
1712 ;;; %COMBINATION
1713
1714 (defmethod fold-empty ((pattern %combination))
1715   (setf (pattern-a pattern) (fold-empty (pattern-a pattern)))
1716   (setf (pattern-b pattern) (fold-empty (pattern-b pattern)))
1717   pattern)
1718
1719 (defmethod fold-empty ((pattern group))
1720   (call-next-method)
1721   (cond
1722     ;; if any child is empty, choose the other
1723     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1724     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1725     (t pattern)))
1726
1727 (defmethod fold-empty ((pattern interleave))
1728   (call-next-method)
1729   (cond
1730     ;; if any child is empty, choose the other
1731     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1732     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1733     (t pattern)))
1734
1735 (defmethod fold-empty ((pattern choice))
1736   (call-next-method)
1737   (if (typep (pattern-b pattern) 'empty)
1738       (cond
1739         ((typep (pattern-a pattern) 'empty)
1740           (pattern-a pattern))
1741         (t
1742           (rotatef (pattern-a pattern) (pattern-b pattern))
1743           pattern))
1744       pattern))
1745
1746 ;;; LEAF
1747
1748 (defmethod fold-empty ((pattern %leaf))
1749   pattern)
1750
1751 (defmethod fold-empty ((pattern data))
1752   (when (pattern-except pattern)
1753     (setf (pattern-except pattern) (fold-empty (pattern-except pattern))))
1754   pattern)
1755
1756 ;;; REF
1757
1758 (defmethod fold-empty ((pattern ref))
1759   pattern)
1760
1761
1762 ;;;; name class overlap
1763
1764 ;;; fixme: memorize this stuff?
1765
1766 (defparameter !uri (string (code-char 1)))
1767 (defparameter !lname "")
1768
1769 (defun classes-overlap-p (nc1 nc2)
1770   (flet ((both-contain (x)
1771            (and (contains nc1 (car x) (cdr x))
1772                 (contains nc2 (car x) (cdr x)))))
1773     (or (some #'both-contain (representatives nc1))
1774         (some #'both-contain (representatives nc2)))))
1775
1776 (defmethod representatives ((nc any-name))
1777   (cons (cons !uri !lname)
1778         (if (any-name-except nc)
1779             (representatives (any-name-except nc))
1780             nil)))
1781
1782 (defmethod representatives ((nc ns-name))
1783   (cons (cons (ns-name-uri nc) !lname)
1784         (if (ns-name-except nc)
1785             (representatives (ns-name-except nc))
1786             nil)))
1787
1788 (defmethod representatives ((nc name))
1789   (list (cons (name-uri nc) (name-lname nc))))
1790
1791 (defmethod representatives ((nc name-class-choice))
1792   (nconc (representatives (name-class-choice-a nc))
1793          (representatives (name-class-choice-b nc))))
1794
1795
1796 ;;;; 7.1
1797
1798 (defun finalize-definitions (pattern)
1799   (let ((defns (make-hash-table)))
1800     (labels ((recurse (p)
1801                (cond
1802                  ((typep p 'ref)
1803                   (let ((target (pattern-target p)))
1804                     (unless (gethash target defns)
1805                       (setf (gethash target defns) t)
1806                       (setf (defn-child target) (recurse (defn-child target))))
1807                     (if (typep (defn-child target) 'element)
1808                         p
1809                         (copy-pattern-tree (defn-child target)))))
1810                  (t
1811                   (etypecase p
1812                     (data
1813                      (when (pattern-except p)
1814                        (setf (pattern-except p) (recurse (pattern-except p)))))
1815                     (%parent
1816                      (setf (pattern-child p) (recurse (pattern-child p))))
1817                     (%combination
1818                      (setf (pattern-a p) (recurse (pattern-a p)))
1819                      (setf (pattern-b p) (recurse (pattern-b p))))
1820                     (%leaf))
1821                   p))))
1822       (values
1823        (recurse pattern)
1824        (loop
1825           for defn being each hash-key in defns
1826           collect defn)))))
1827
1828 (defun copy-pattern-tree (pattern)
1829   (labels ((recurse (p)
1830              (let ((q (copy-structure p)))
1831                (etypecase p
1832                  (data
1833                   (when (pattern-except p)
1834                     (setf (pattern-except q) (recurse (pattern-except p)))))
1835                  (%parent
1836                   (setf (pattern-child q) (recurse (pattern-child p))))
1837                  (%combination
1838                   (setf (pattern-a q) (recurse (pattern-a p)))
1839                   (setf (pattern-b q) (recurse (pattern-b p))))
1840                  ((or %leaf ref)))
1841                q)))
1842     (recurse pattern)))
1843
1844 (defparameter *in-attribute-p* nil)
1845 (defparameter *in-one-or-more-p* nil)
1846 (defparameter *in-one-or-more//group-or-interleave-p* nil)
1847 (defparameter *in-list-p* nil)
1848 (defparameter *in-data-except-p* nil)
1849 (defparameter *in-start-p* nil)
1850
1851 (defun check-start-restrictions (pattern)
1852   (let ((*in-start-p* t))
1853     (check-restrictions pattern)))
1854
1855 (defun content-type-max (a b)
1856   (if (and a b)
1857       (cond
1858         ((eq a :empty) b)
1859         ((eq b :empty) a)
1860         ((eq a :complex) b)
1861         (:simple))
1862       nil))
1863
1864 (defun groupable-max (a b)
1865   (if (or (eq a :empty)
1866           (eq b :empty)
1867           (and (eq a :complex)
1868                (eq b :complex)))
1869       (content-type-max a b)
1870       nil))
1871
1872 (defun assert-name-class-finite (nc)
1873   (etypecase nc
1874     ((or any-name ns-name)
1875      (rng-error nil "infinite attribute name class outside of one-or-more"))
1876     (name)
1877     (name-class-choice
1878      (assert-name-class-finite (name-class-choice-a nc))
1879      (assert-name-class-finite (name-class-choice-b nc)))))
1880
1881 (defmethod check-restrictions ((pattern attribute))
1882   (when *in-attribute-p*
1883     (rng-error nil "nested attribute not allowed"))
1884   (when *in-one-or-more//group-or-interleave-p*
1885     (rng-error nil "attribute not allowed in oneOrMore//group, oneOrMore//interleave"))
1886   (when *in-list-p*
1887     (rng-error nil "attribute in list not allowed"))
1888   (when *in-data-except-p*
1889     (rng-error nil "attribute in data/except not allowed"))
1890   (when *in-start-p*
1891     (rng-error nil "attribute in start not allowed"))
1892   (let ((*in-attribute-p* t))
1893     (unless *in-one-or-more-p*
1894       (assert-name-class-finite (pattern-name pattern)))
1895     (values (if (check-restrictions (pattern-child pattern))
1896                 :empty
1897                 nil)
1898             (list (pattern-name pattern))
1899             nil)))
1900
1901 (defmethod check-restrictions ((pattern ref))
1902   (when *in-attribute-p*
1903     (rng-error nil "ref in attribute not allowed"))
1904   (when *in-list-p*
1905     (rng-error nil "ref in list not allowed"))
1906   (when *in-data-except-p*
1907     (rng-error nil "ref in data/except not allowed"))
1908   (values :complex
1909           nil
1910           (list (pattern-name (defn-child (pattern-target pattern))))
1911           nil))
1912
1913 (defmethod check-restrictions ((pattern one-or-more))
1914   (when *in-data-except-p*
1915     (rng-error nil "oneOrMore in data/except not allowed"))
1916   (when *in-start-p*
1917     (rng-error nil "one-or-more in start not allowed"))
1918   (let* ((*in-one-or-more-p* t))
1919     (multiple-value-bind (x a e textp)
1920         (check-restrictions (pattern-child pattern))
1921       (values (groupable-max x x) a e textp))))
1922
1923 (defmethod check-restrictions ((pattern group))
1924   (when *in-data-except-p*
1925     (rng-error nil "group in data/except not allowed"))
1926   (when *in-start-p*
1927     (rng-error nil "group in start not allowed"))
1928   (let ((*in-one-or-more//group-or-interleave-p*
1929          *in-one-or-more-p*))
1930     (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1931       (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1932         (dolist (nc1 a)
1933           (dolist (nc2 b)
1934             (when (classes-overlap-p nc1 nc2)
1935               (rng-error nil "attribute name overlap in group: ~A ~A"
1936                          nc1 nc2))))
1937         (values (groupable-max x y)
1938                 (append a b)
1939                 (append e f)
1940                 (or tp tq))))))
1941
1942 (defmethod check-restrictions ((pattern interleave))
1943   (when *in-list-p*
1944     (rng-error nil "interleave in list not allowed"))
1945   (when *in-data-except-p*
1946     (rng-error nil "interleave in data/except not allowed"))
1947   (when *in-start-p*
1948     (rng-error nil "interleave in start not allowed"))
1949   (let ((*in-one-or-more//group-or-interleave-p*
1950          *in-one-or-more-p*))
1951     (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1952       (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1953         (dolist (nc1 a)
1954           (dolist (nc2 b)
1955             (when (classes-overlap-p nc1 nc2)
1956               (rng-error nil "attribute name overlap in interleave: ~A ~A"
1957                          nc1 nc2))))
1958         (dolist (nc1 e)
1959           (dolist (nc2 f)
1960             (when (classes-overlap-p nc1 nc2)
1961               (rng-error nil "element name overlap in interleave: ~A ~A"
1962                          nc1 nc2))))
1963         (when (and tp tq)
1964           (rng-error nil "multiple text permitted by interleave"))
1965         (values (groupable-max x y)
1966                 (append a b)
1967                 (append e f)
1968                 (or tp tq))))))
1969
1970 (defmethod check-restrictions ((pattern choice))
1971   (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1972     (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1973       (values (content-type-max x y)
1974               (append a b)
1975               (append e f)
1976               (or tp tq)))))
1977
1978 (defmethod check-restrictions ((pattern list-pattern))
1979   (when *in-list-p*
1980     (rng-error nil "nested list not allowed"))
1981   (when *in-data-except-p*
1982     (rng-error nil "list in data/except not allowed"))
1983   (let ((*in-list-p* t))
1984     (check-restrictions (pattern-child pattern)))
1985   (when *in-start-p*
1986     (rng-error nil "list in start not allowed"))
1987   :simple)
1988
1989 (defmethod check-restrictions ((pattern text))
1990   (when *in-list-p*
1991     (rng-error nil "text in list not allowed"))
1992   (when *in-data-except-p*
1993     (rng-error nil "text in data/except not allowed"))
1994   (when *in-start-p*
1995     (rng-error nil "text in start not allowed"))
1996   (values :complex nil nil t))
1997
1998 (defmethod check-restrictions ((pattern data))
1999   (when *in-start-p*
2000     (rng-error nil "data in start not allowed"))
2001   (when (pattern-except pattern)
2002     (let ((*in-data-except-p* t))
2003       (check-restrictions (pattern-except pattern))))
2004   :simple)
2005
2006 (defmethod check-restrictions ((pattern value))
2007   (when *in-start-p*
2008     (rng-error nil "value in start not allowed"))
2009   :simple)
2010
2011 (defmethod check-restrictions ((pattern empty))
2012   (when *in-data-except-p*
2013     (rng-error nil "empty in data/except not allowed"))
2014   (when *in-start-p*
2015     (rng-error nil "empty in start not allowed"))
2016   :empty)
2017
2018 (defmethod check-restrictions ((pattern element))
2019   (unless (check-restrictions (pattern-child pattern))
2020     (rng-error nil "restrictions on string sequences violated")))
2021
2022 (defmethod check-restrictions ((pattern not-allowed))
2023   nil)
2024
2025
2026 ;;; compatibility restrictions
2027
2028 (defvar *in-element* nil)
2029 (defvar *in-attribute* nil)
2030 (defvar *in-choices* nil)
2031 (defvar *in-default-value-p* nil)
2032 (defvar *compatibility-table*)
2033 (defvar *dtd-restriction-validator*)
2034
2035 (defun check-schema-compatibility (schema defns)
2036   (let* ((*error-class* 'dtd-compatibility-error)
2037          (elements (mapcar #'defn-child defns))
2038          (table (make-compatibility-table))
2039          (*dtd-restriction-validator* (nth-value 1 (make-validator schema))))
2040     (setf (schema-compatibility-table schema) table)
2041     (let ((*compatibility-table* table))
2042       (mapc #'check-pattern-compatibility elements))
2043     (loop for elt1 being each hash-value in (dtd-elements table) do
2044           (let ((nc1 (dtd-name elt1)))
2045             (dolist (elt2 elements)
2046               (let ((nc2 (pattern-name elt2)))
2047                 (when (classes-overlap-p nc1 nc2)
2048                   (check-element-overlap-compatibility elt1 elt2)))))
2049          ;; clean out ID type bookkeeping:
2050          (let ((attributes (dtd-attributes elt1)))
2051            (maphash (lambda (k v)
2052                       (when (eq (dtd-id-type v) :unknown)
2053                         (if (dtd-default-value v)
2054                             (setf (dtd-id-type v) nil)
2055                             (remhash k attributes))))
2056                     attributes)))))
2057
2058 (defun check-element-overlap-compatibility (elt1 elt2)
2059   (unless
2060       (if (typep (pattern-name elt2) 'name)
2061           ;; must both declare the same defaulted attributes
2062           (loop
2063              for a being each hash-value in (dtd-attributes elt1)
2064              always (or (null (dtd-default-value a))
2065                         (find elt2 (dtd-value-declared-by a))))
2066           ;; elt1 has an attribute with defaultValue
2067           ;; elt2 cannot have any defaultValue  ##
2068           (loop
2069              for a being each hash-value in (dtd-attributes elt1)
2070              never (dtd-default-value a)))
2071     (rng-error nil "overlapping elements with and without defaultValue"))
2072   (unless
2073       (if (typep (pattern-name elt2) 'name)
2074           ;; must both declare the same attributes with ID-type
2075           (loop
2076              for a being each hash-value in (dtd-attributes elt1)
2077              always (or (eq (dtd-id-type a) :unknown)
2078                         (find elt2 (dtd-id-type-declared-by a))))
2079           ;; elt1 has an attribute with ID-type
2080           ;; elt2 cannot have any ID-type  ##
2081           (loop
2082              for a being each hash-value in (dtd-attributes elt1)
2083              always (eq (dtd-id-type a) :unknown)))
2084     (rng-error nil "overlapping elements with and without ID-type")))
2085
2086 (defun check-attribute-compatibility/default (pattern default-value)
2087   (unless (typep (pattern-name pattern) 'name)
2088     (rng-error nil "defaultValue declared in attribute without <name>"))
2089   (unless (typep (pattern-name *in-element*) 'name)
2090     (rng-error nil "defaultValue declared in element without <name>"))
2091   (let* ((hsx *dtd-restriction-validator*)
2092          (derivation
2093           (intern-pattern (pattern-child pattern) (registratur hsx))))
2094     (unless (value-matches-p hsx derivation default-value)
2095       (rng-error nil "defaultValue not valid")))
2096   (unless *in-choices*
2097     (rng-error nil "defaultValue declared outside of <choice>"))
2098   (dolist (choice *in-choices*
2099            (rng-error nil "defaultValue in <choice>, but no <empty> found"))
2100     (when (or (typep (pattern-a choice) 'empty)
2101               (typep (pattern-b choice) 'empty))
2102       (return)))
2103   (let ((a (ensure-dtd-attribute (pattern-name pattern)
2104                                  *in-element*
2105                                  *compatibility-table*)))
2106     (cond
2107       ((null (dtd-default-value a))
2108        (setf (dtd-default-value a) default-value))
2109       ((not (equal (dtd-default-value a) default-value))
2110        (rng-error nil "inconsistent defaultValue declarations")))
2111     (push *in-element* (dtd-value-declared-by a))))
2112
2113 (defun check-attribute-compatibility/id (pattern default-value)
2114   (let* ((dt (pattern-type (pattern-child pattern)))
2115          (id-type (cxml-types:type-id-type dt)))
2116     (when (and default-value (cxml-types:type-context-dependent-p dt))
2117       (rng-error nil
2118                  "defaultValue declared with context dependent type"))
2119     (when id-type
2120       (unless (typep (pattern-name pattern) 'name)
2121         (rng-error nil "defaultValue declared in attribute without <name>"))
2122       (unless (typep (pattern-name *in-element*) 'name)
2123         (rng-error nil "defaultValue declared in element without <name>"))
2124       (let ((a (ensure-dtd-attribute (pattern-name pattern)
2125                                      *in-element*
2126                                      *compatibility-table*)))
2127         (cond
2128           ((eq (dtd-id-type a) :unknown)
2129            (setf (dtd-id-type a) id-type))
2130           ((not (eq id-type (dtd-id-type a)))
2131            (rng-error nil "inconsistent ID type attributes")))
2132         (push *in-element* (dtd-id-type-declared-by a))))))
2133
2134 (defmethod check-pattern-compatibility ((pattern attribute))
2135   (declare (optimize debug (speed 0) (space 0)))
2136   (let* ((*in-attribute* pattern)
2137          (default-value (pattern-default-value pattern))
2138          (*in-default-value-p* t))
2139     (when default-value
2140       (check-attribute-compatibility/default pattern default-value))
2141     (if (typep (pattern-child pattern) '(or data value))
2142         (check-attribute-compatibility/id pattern default-value)
2143         (check-pattern-compatibility (pattern-child pattern)))))
2144
2145 (defmethod check-pattern-compatibility ((pattern ref))
2146   nil)
2147
2148 (defmethod check-pattern-compatibility ((pattern one-or-more))
2149   (check-pattern-compatibility (pattern-child pattern)))
2150
2151 (defmethod check-pattern-compatibility ((pattern %combination))
2152   (check-pattern-compatibility (pattern-a pattern))
2153   (check-pattern-compatibility (pattern-b pattern)))
2154
2155 (defmethod check-pattern-compatibility ((pattern choice))
2156   (let ((*in-choices* (cons pattern *in-choices*)))
2157     (check-pattern-compatibility (pattern-a pattern))
2158     (check-pattern-compatibility (pattern-b pattern))))
2159
2160 (defmethod check-pattern-compatibility ((pattern list-pattern))
2161   (check-pattern-compatibility (pattern-child pattern)))
2162
2163 (defmethod check-pattern-compatibility ((pattern %leaf))
2164   nil)
2165
2166 (defmethod check-pattern-compatibility ((pattern data))
2167   (when (and *in-default-value-p*
2168              (cxml-types:type-context-dependent-p (pattern-type pattern)))
2169     (rng-error nil "defaultValue declared with context dependent type"))
2170   (when (cxml-types:type-id-type (pattern-type pattern))
2171     (rng-error nil "ID type not a child of attribute")))
2172
2173 (defmethod check-pattern-compatibility ((pattern value))
2174   (when (and *in-default-value-p*
2175              (cxml-types:type-context-dependent-p (pattern-type pattern)))
2176     (rng-error nil "defaultValue declared with context dependent type"))
2177   (when (cxml-types:type-id-type (pattern-type pattern))
2178     (rng-error nil "ID type not a child of attribute")))
2179
2180 (defmethod check-pattern-compatibility ((pattern element))
2181   (assert (null *in-element*))
2182   (let ((*in-element* pattern))
2183     (check-pattern-compatibility (pattern-child pattern))))