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
 740        (return))
 741       (t
 742        (klacks:consume source)))))
 743
 744 (defun consume-and-skip-to-native (source)
 745   (klacks:consume source)
 746   (skip-to-native source))
 747
 748 (defun skip-foreign (source)
 749   (when (equal (klacks:current-uri source) *rng-namespace*)
 750     (rng-error source
 751                "invalid schema: ~A not allowed here"
 752                (klacks:current-lname source)))
 753   (klacks:serialize-element source nil))
 754
 755 (defun attribute (lname attrs)
 756   "@unexport{}"
 757   (let ((a (sax:find-attribute-ns "" lname attrs)))
 758     (if a
 759         (sax:attribute-value a)
 760         nil)))
 761
 762 (defparameter *whitespace*
 763     (format nil "~C~C~C~C"
 764             (code-char 9)
 765             (code-char 32)
 766             (code-char 13)
 767             (code-char 10)))
 768
 769 (defun ntc (lname source-or-attrs)
 770   ;; used for (n)ame, (t)ype, and (c)ombine, this also strips whitespace
 771   (let* ((attrs
 772           (if (listp source-or-attrs)
 773               source-or-attrs
 774               (klacks:list-attributes source-or-attrs)))
 775          (a (sax:find-attribute-ns "" lname attrs)))
 776     (if a
 777         (string-trim *whitespace* (sax:attribute-value a))
 778         nil)))
 779
 780 (defmacro with-library-and-ns (attrs &body body)
 781   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 782
 783 (defun invoke-with-library-and-ns (fn attrs)
 784   (let* ((dl (attribute "datatypeLibrary" attrs))
 785          (ns (attribute "ns" attrs))
 786          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 787          (*namespace-uri* (or ns *namespace-uri*))
 788          (*ns* ns))
 789     ;; FIXME: Ganz boese gehackt -- gerade so, dass wir die Relax NG
 790     ;; Test-Suite bestehen.
 791     (when (and dl
 792                (not (zerop (length *datatype-library*)))
 793                ;; scheme pruefen, und es muss was folgen
 794                (or (not (cl-ppcre:all-matches
 795                          "^[a-zA-Z][a-zA-Z0-9+.-]*:.+"
 796                          *datatype-library*))
 797                    ;; keine kaputten %te, keine #
 798                    (cl-ppcre:all-matches
 799                     "(%$|%.$|%[^0-9A-Fa-f][^0-9A-Fa-f]|#)"
 800                     *datatype-library*)))
 801       (rng-error nil "malformed datatypeLibrary: ~A" *datatype-library*))
 802     (funcall fn)))
 803
 804 (defun p/pattern (source)
 805   (let* ((lname (klacks:current-lname source))
 806          (attrs (klacks:list-attributes source)))
 807     (with-library-and-ns attrs
 808       (case (find-symbol lname :keyword)
 809         (:|element|     (p/element source (ntc "name" attrs)))
 810         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 811         (:|group|       (p/combination #'groupify source))
 812         (:|interleave|  (p/combination #'interleave-ify source))
 813         (:|choice|      (p/combination #'choice-ify source))
 814         (:|optional|    (p/optional source))
 815         (:|zeroOrMore|  (p/zero-or-more source))
 816         (:|oneOrMore|   (p/one-or-more source))
 817         (:|list|        (p/list source))
 818         (:|mixed|       (p/mixed source))
 819         (:|ref|         (p/ref source))
 820         (:|parentRef|   (p/parent-ref source))
 821         (:|empty|       (p/empty source))
 822         (:|text|        (p/text source))
 823         (:|value|       (p/value source))
 824         (:|data|        (p/data source))
 825         (:|notAllowed|  (p/not-allowed source))
 826         (:|externalRef| (p/external-ref source))
 827         (:|grammar|     (p/grammar source))
 828         (t (skip-foreign source))))))
 829
 830 (defun p/pattern+ (source)
 831   (let ((children nil))
 832     (loop
 833       (case (klacks:peek source)
 834         (:start-element
 835           (let ((p (p/pattern source))) (when p (push p children))))
 836         (:end-element
 837           (return))
 838         (t
 839           (klacks:consume source))))
 840     (unless children
 841       (rng-error source "empty element"))
 842     (nreverse children)))
 843
 844 (defun p/pattern? (source)
 845   (let ((result nil))
 846     (loop
 847       (skip-to-native source)
 848       (case (klacks:peek source)
 849         (:start-element
 850           (when result
 851             (rng-error source "at most one pattern expected here"))
 852           (setf result (p/pattern source)))
 853         (:end-element
 854           (return))
 855         (t
 856           (klacks:consume source))))
 857     result))
 858
 859 (defun p/element (source name)
 860   (klacks:expecting-element (source "element")
 861     (let ((elt (make-element)))
 862       (consume-and-skip-to-native source)
 863       (if name
 864           (setf (pattern-name elt) (destructure-name source name))
 865           (setf (pattern-name elt) (p/name-class source)))
 866       (skip-to-native source)
 867       (setf (pattern-child elt) (groupify (p/pattern+ source)))
 868       (make-ref (make-definition :name (gensym "ANONYMOUS") :child elt)))))
 869
 870 (defvar *attribute-namespace-p* nil)
 871
 872 (defun p/attribute (source name)
 873   (klacks:expecting-element (source "attribute")
 874     (let* ((dv
 875             (when *process-dtd-compatibility*
 876               (sax:find-attribute-ns
 877                "http://relaxng.org/ns/compatibility/annotations/1.0"
 878                "defaultValue"
 879                (klacks:list-attributes source))))
 880            (result (make-attribute (when dv (sax:attribute-value dv)))))
 881       (consume-and-skip-to-native source)
 882       (if name
 883           (setf (pattern-name result)
 884                 (let ((*namespace-uri* (or *ns* ""))
 885                       (*attribute-namespace-p* t))
 886                   (destructure-name source name)))
 887           (setf (pattern-name result)
 888                 (let ((*attribute-namespace-p* t))
 889                   (p/name-class source))))
 890       (skip-to-native source)
 891       (setf (pattern-child result)
 892             (or (p/pattern? source) (make-text)))
 893       result)))
 894
 895 (defun p/combination (zipper source)
 896   (klacks:expecting-element (source)
 897     (consume-and-skip-to-native source)
 898     (funcall zipper (p/pattern+ source))))
 899
 900 (defun p/one-or-more (source)
 901   (klacks:expecting-element (source "oneOrMore")
 902     (consume-and-skip-to-native source)
 903     (let ((children (p/pattern+ source)))
 904       (make-one-or-more (groupify children)))))
 905
 906 (defun p/zero-or-more (source)
 907   (klacks:expecting-element (source "zeroOrMore")
 908     (consume-and-skip-to-native source)
 909     (let ((children (p/pattern+ source)))
 910       (make-choice (make-one-or-more (groupify children))
 911                    (make-empty)))))
 912
 913 (defun p/optional (source)
 914   (klacks:expecting-element (source "optional")
 915     (consume-and-skip-to-native source)
 916     (let ((children (p/pattern+ source)))
 917       (make-choice (groupify children) (make-empty)))))
 918
 919 (defun p/list (source)
 920   (klacks:expecting-element (source "list")
 921     (consume-and-skip-to-native source)
 922     (let ((children (p/pattern+ source)))
 923       (make-list-pattern (groupify children)))))
 924
 925 (defun p/mixed (source)
 926   (klacks:expecting-element (source "mixed")
 927     (consume-and-skip-to-native source)
 928     (let ((children (p/pattern+ source)))
 929       (make-interleave (groupify children) (make-text)))))
 930
 931 (defun p/ref (source)
 932   (klacks:expecting-element (source "ref")
 933     (prog1
 934         (let* ((name (ntc "name" source))
 935                (pdefinition
 936                 (or (find-definition name)
 937                     (setf (find-definition name)
 938                           (make-definition :name name :child nil)))))
 939           (make-ref pdefinition))
 940       (skip-foreign* source))))
 941
 942 (defun p/parent-ref (source)
 943   (klacks:expecting-element (source "parentRef")
 944     (prog1
 945         (let* ((name (ntc "name" source))
 946                (grammar (grammar-parent *grammar*))
 947                (pdefinition
 948                 (or (find-definition name grammar)
 949                     (setf (find-definition name grammar)
 950                           (make-definition :name name :child nil)))))
 951           (make-ref pdefinition))
 952       (skip-foreign* source))))
 953
 954 (defun p/empty (source)
 955   (klacks:expecting-element (source "empty")
 956     (skip-foreign* source)
 957     (make-empty)))
 958
 959 (defun p/text (source)
 960   (klacks:expecting-element (source "text")
 961     (skip-foreign* source)
 962     (make-text)))
 963
 964 (defun consume-and-parse-characters (source)
 965   ;; fixme
 966   (let ((tmp ""))
 967     (loop
 968       (multiple-value-bind (key data) (klacks:peek-next source)
 969         (case key
 970           (:characters
 971             (setf tmp (concatenate 'string tmp data)))
 972           (:end-element (return)))))
 973     tmp))
 974
 975 (defun p/value (source)
 976   (klacks:expecting-element (source "value")
 977     (let* ((type (ntc "type" source))
 978            (string (consume-and-parse-characters source))
 979            (ns *namespace-uri*)
 980            (dl *datatype-library*))
 981       (unless type
 982         (setf type "token")
 983         (setf dl ""))
 984       (let ((data-type
 985              (cxml-types:find-type (and dl (find-symbol dl :keyword))
 986                                    type
 987                                    nil))
 988             (vc (cxml-types:make-klacks-validation-context source)))
 989         (unless data-type
 990           (rng-error source "type not found: ~A/~A" type dl))
 991         (make-value :string string
 992                     :value (cxml-types:parse data-type string vc)
 993                     :type data-type
 994                     :ns ns)))))
 995
 996 (defun p/data (source)
 997   (klacks:expecting-element (source "data")
 998     (let* ((type (ntc "type" source))
 999            (params '())
1000            (except nil))
1001       (loop
1002          (multiple-value-bind (key uri lname)
1003              (klacks:peek-next source)
1004            uri
1005            (case key
1006              (:start-element
1007               (case (find-symbol lname :keyword)
1008                 (:|param| (push (p/param source) params))
1009                 (:|except|
1010                   (setf except (p/except-pattern source))
1011                   (skip-to-native source)
1012                   (return))
1013                 (t (skip-foreign source))))
1014              (:end-element
1015               (return)))))
1016       (setf params (nreverse params))
1017       (let* ((dl *datatype-library*)
1018              (data-type (cxml-types:find-type
1019                          (and dl (find-symbol dl :keyword))
1020                          type
1021                          params)))
1022         (unless data-type
1023           (rng-error source "type not found: ~A/~A" type dl))
1024         (when (eq data-type :error)
1025           (rng-error source "params not valid for type: ~A/~A/~A"
1026                      type dl params))
1027         (make-data
1028          :type data-type
1029          :params params
1030          :except except)))))
1031
1032 (defun p/param (source)
1033   (klacks:expecting-element (source "param")
1034     (let ((name (ntc "name" source))
1035           (string (consume-and-parse-characters source)))
1036       (cxml-types:make-param name string))))
1037
1038 (defun p/except-pattern (source)
1039   (klacks:expecting-element (source "except")
1040     (with-library-and-ns (klacks:list-attributes source)
1041       (klacks:consume source)
1042       (choice-ify (p/pattern+ source)))))
1043
1044 (defun p/not-allowed (source)
1045   (klacks:expecting-element (source "notAllowed")
1046     (consume-and-skip-to-native source)
1047     (make-not-allowed)))
1048
1049 (defun safe-parse-uri (source str &optional base)
1050   (when (zerop (length str))
1051     (rng-error source "missing URI"))
1052   (let* ((compactp (rnc-uri-p str))
1053          (str (if compactp (follow-rnc-uri str) str))
1054          (uri
1055           (handler-case
1056               (if base
1057                   (puri:merge-uris str base)
1058                   (puri:parse-uri str))
1059             (puri:uri-parse-error ()
1060               (rng-error source "invalid URI: ~A" str)))))
1061     (when (and (eq (puri:uri-scheme uri) :file)
1062                (puri:uri-fragment uri))
1063       (rng-error source "Forbidden fragment in URI: ~A" str))
1064     (values uri compactp)))
1065
1066 (defun named-string-xstream (str uri)
1067   (let ((xstream (cxml::string->xstream str)))
1068     (setf (cxml::xstream-name xstream)
1069           (cxml::make-stream-name
1070            :entity-name "main document"
1071            :entity-kind :main
1072            :uri uri))
1073     xstream))
1074
1075 (defun xstream-open-schema (uri compactp)
1076   (if compactp
1077       (named-string-xstream
1078        (uncompact-file
1079         ;; fixme: Hier waere es schon, mit *entity-resolver* arbeiten
1080         ;; zu koennen, aber der liefert binaere Streams.
1081         (open (cxml::uri-to-pathname uri)
1082               :element-type 'character
1083               :direction :input))
1084        uri)
1085       (cxml::xstream-open-extid* *entity-resolver* nil uri)))
1086
1087 (defun p/external-ref (source)
1088   (klacks:expecting-element (source "externalRef")
1089     (let* ((href
1090             (escape-uri (attribute "href" (klacks:list-attributes source))))
1091            (base (klacks:current-xml-base source)))
1092       (multiple-value-bind (uri compactp)
1093           (safe-parse-uri source href base)
1094         (when (find uri *include-uri-stack* :test #'puri:uri=)
1095           (rng-error source "looping include"))
1096         (prog1
1097             (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
1098                    (xstream (xstream-open-schema uri compactp)))
1099               (klacks:with-open-source
1100                   (source (make-schema-source xstream))
1101                 (invoke-with-klacks-handler
1102                  (lambda ()
1103                    (klacks:find-event source :start-element)
1104                    (let ((*datatype-library* ""))
1105                      (p/pattern source)))
1106                  source)))
1107           (skip-foreign* source))))))
1108
1109 (defun p/grammar (source &optional grammar)
1110   (klacks:expecting-element (source "grammar")
1111     (consume-and-skip-to-native source)
1112     (let ((*grammar* (or grammar (make-grammar *grammar*)))
1113           (includep grammar))
1114       (process-grammar-content* source)
1115       (unless (or includep (grammar-start *grammar*))
1116         (rng-error source "no <start> in grammar"))
1117       (unless includep
1118         (check-pattern-definitions source *grammar*)
1119         (defn-child (grammar-start *grammar*))))))
1120
1121 (defvar *include-start*)
1122 (defvar *include-definitions*)
1123
1124 (defun process-grammar-content* (source &key disallow-include)
1125   (loop
1126     (multiple-value-bind (key uri lname) (klacks:peek source)
1127       uri
1128       (ecase key
1129         ((:characters :comment)
1130          (klacks:consume source))
1131         (:start-element
1132          (with-library-and-ns (klacks:list-attributes source)
1133            (case (find-symbol lname :keyword)
1134              (:|start|
1135                (process-start source))
1136              (:|define| (process-define source))
1137              (:|div| (process-div source))
1138              (:|include|
1139                (when disallow-include
1140                  (rng-error source "nested include not permitted"))
1141                (process-include source))
1142              (t
1143               (skip-foreign source)))))
1144         (:end-element
1145          (return))))))
1146
1147 (defun process-start (source)
1148   (klacks:expecting-element (source "start")
1149     (let* ((combine0 (ntc "combine" source))
1150            (combine
1151             (when combine0
1152               (find-symbol (string-upcase combine0) :keyword)))
1153            (child
1154             (progn
1155               (consume-and-skip-to-native source)
1156               (p/pattern source)))
1157            (pdefinition (grammar-start *grammar*)))
1158       (skip-foreign* source)
1159       ;; fixme: shared code with process-define
1160       (unless pdefinition
1161         (setf pdefinition (make-definition :name :start :child nil))
1162         (setf (grammar-start *grammar*) pdefinition))
1163       (when *include-body-p*
1164         (setf *include-start* pdefinition))
1165       (cond
1166         ((defn-child pdefinition)
1167          (ecase (defn-redefinition pdefinition)
1168            (:not-being-redefined
1169              (when (and combine
1170                         (defn-combine-method pdefinition)
1171                         (not (eq combine
1172                                  (defn-combine-method pdefinition))))
1173                (rng-error source "conflicting combine values for <start>"))
1174              (unless combine
1175                (when (defn-head-p pdefinition)
1176                  (rng-error source "multiple definitions for <start>"))
1177                (setf (defn-head-p pdefinition) t))
1178              (unless (defn-combine-method pdefinition)
1179                (setf (defn-combine-method pdefinition) combine))
1180              (setf (defn-child pdefinition)
1181                    (case (defn-combine-method pdefinition)
1182                      (:choice
1183                        (make-choice (defn-child pdefinition) child))
1184                      (:interleave
1185                        (make-interleave (defn-child pdefinition) child)))))
1186            (:being-redefined-and-no-original
1187              (setf (defn-redefinition pdefinition)
1188                    :being-redefined-and-original))
1189            (:being-redefined-and-original)))
1190         (t
1191           (setf (defn-child pdefinition) child)
1192           (setf (defn-combine-method pdefinition) combine)
1193           (setf (defn-head-p pdefinition) (null combine))
1194           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
1195
1196 (defun zip (constructor children)
1197   (cond
1198     ((null children)
1199       (rng-error nil "empty choice?"))
1200     ((null (cdr children))
1201       (car children))
1202     (t
1203       (destructuring-bind (a b &rest rest)
1204           children
1205         (zip constructor (cons (funcall constructor a b) rest))))))
1206
1207 (defun choice-ify (children) (zip #'make-choice children))
1208 (defun groupify (children) (zip #'make-group children))
1209 (defun interleave-ify (children) (zip #'make-interleave children))
1210
1211 (defun find-definition (name &optional (grammar *grammar*))
1212   (gethash name (grammar-definitions grammar)))
1213
1214 (defun (setf find-definition) (newval name &optional (grammar *grammar*))
1215   (setf (gethash name (grammar-definitions grammar)) newval))
1216
1217 (defun process-define (source)
1218   (klacks:expecting-element (source "define")
1219     (let* ((name (ntc "name" source))
1220            (combine0 (ntc "combine" source))
1221            (combine (when combine0
1222                       (find-symbol (string-upcase combine0) :keyword)))
1223            (child (groupify
1224                    (progn
1225                      (consume-and-skip-to-native source)
1226                      (p/pattern+ source))))
1227            (pdefinition (find-definition name)))
1228       (unless pdefinition
1229         (setf pdefinition (make-definition :name name :child nil))
1230         (setf (find-definition name) pdefinition))
1231       (when *include-body-p*
1232         (push pdefinition *include-definitions*))
1233       (cond
1234         ((defn-child pdefinition)
1235           (case (defn-redefinition pdefinition)
1236             (:not-being-redefined
1237               (when (and combine
1238                          (defn-combine-method pdefinition)
1239                          (not (eq combine
1240                                   (defn-combine-method pdefinition))))
1241                 (rng-error source "conflicting combine values for ~A" name))
1242               (unless combine
1243                 (when (defn-head-p pdefinition)
1244                   (rng-error source "multiple definitions for ~A" name))
1245                 (setf (defn-head-p pdefinition) t))
1246               (unless (defn-combine-method pdefinition)
1247                 (setf (defn-combine-method pdefinition) combine))
1248               (setf (defn-child pdefinition)
1249                     (case (defn-combine-method pdefinition)
1250                       (:choice
1251                         (make-choice (defn-child pdefinition) child))
1252                       (:interleave
1253                         (make-interleave (defn-child pdefinition) child)))))
1254             (:being-redefined-and-no-original
1255               (setf (defn-redefinition pdefinition)
1256                     :being-redefined-and-original))
1257             (:being-redefined-and-original)))
1258         (t
1259           (setf (defn-child pdefinition) child)
1260           (setf (defn-combine-method pdefinition) combine)
1261           (setf (defn-head-p pdefinition) (null combine))
1262           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
1263
1264 (defun process-div (source)
1265   (klacks:expecting-element (source "div")
1266     (consume-and-skip-to-native source)
1267     (process-grammar-content* source)))
1268
1269 (defun reset-definition-for-include (defn)
1270   (setf (defn-combine-method defn) nil)
1271   (setf (defn-redefinition defn) :being-redefined-and-no-original)
1272   (setf (defn-head-p defn) nil))
1273
1274 (defun restore-definition (defn original)
1275   (setf (defn-combine-method defn) (defn-combine-method original))
1276   (setf (defn-redefinition defn) (defn-redefinition original))
1277   (setf (defn-head-p defn) (defn-head-p original)))
1278
1279 (defun process-include (source)
1280   (klacks:expecting-element (source "include")
1281     (let* ((href
1282             (escape-uri (attribute "href" (klacks:list-attributes source))))
1283            (base (klacks:current-xml-base source))
1284            (*include-start* nil)
1285            (*include-definitions* '()))
1286       (multiple-value-bind (uri compactp)
1287           (safe-parse-uri source href base)
1288         (consume-and-skip-to-native source)
1289         (let ((*include-body-p* t))
1290           (process-grammar-content* source :disallow-include t))
1291         (let ((tmp-start
1292                (when *include-start*
1293                  (prog1
1294                      (copy-structure *include-start*)
1295                    (reset-definition-for-include *include-start*))))
1296               (tmp-defns
1297                (loop
1298                   for defn in *include-definitions*
1299                   collect
1300                   (prog1
1301                       (copy-structure defn)
1302                     (reset-definition-for-include defn)))))
1303           (when (find uri *include-uri-stack* :test #'puri:uri=)
1304             (rng-error source "looping include"))
1305           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
1306                  (xstream (xstream-open-schema uri compactp)))
1307             (klacks:with-open-source (source (make-schema-source xstream))
1308               (invoke-with-klacks-handler
1309                (lambda ()
1310                  (klacks:find-event source :start-element)
1311                  (let ((*datatype-library* ""))
1312                    (p/grammar source *grammar*)))
1313                source))
1314             (when tmp-start
1315               (when (eq (defn-redefinition *include-start*)
1316                         :being-redefined-and-no-original)
1317                 (rng-error source "start not found in redefinition of grammar"))
1318               (restore-definition *include-start* tmp-start))
1319             (dolist (copy tmp-defns)
1320               (let ((defn (gethash (defn-name copy)
1321                                    (grammar-definitions *grammar*))))
1322                 (when (eq (defn-redefinition defn)
1323                           :being-redefined-and-no-original)
1324                   (rng-error source "redefinition not found in grammar"))
1325                 (restore-definition defn copy)))
1326             nil))))))
1327
1328 (defun check-pattern-definitions (source grammar)
1329   (when (and (grammar-start grammar)
1330              (eq (defn-redefinition (grammar-start grammar))
1331                  :being-redefined-and-no-original))
1332     (rng-error source "start not found in redefinition of grammar"))
1333   (loop for defn being each hash-value in (grammar-definitions grammar) do
1334         (when (eq (defn-redefinition defn) :being-redefined-and-no-original)
1335           (rng-error source "redefinition not found in grammar"))
1336         (unless (defn-child defn)
1337           (rng-error source "unresolved reference to ~A" (defn-name defn)))))
1338
1339 (defvar *any-name-allowed-p* t)
1340 (defvar *ns-name-allowed-p* t)
1341
1342 (defun destructure-name (source qname)
1343   (multiple-value-bind (uri lname)
1344       (klacks:decode-qname qname source)
1345     (setf uri (or uri *namespace-uri*))
1346     (when (and *attribute-namespace-p*
1347                (or (and (equal lname "xmlns") (equal uri ""))
1348                    (equal uri "http://www.w3.org/2000/xmlns")))
1349       (rng-error source "namespace attribute not permitted"))
1350     (make-name uri lname)))
1351
1352 (defun p/name-class (source)
1353   (klacks:expecting-element (source)
1354     (with-library-and-ns (klacks:list-attributes source)
1355       (case (find-symbol (klacks:current-lname source) :keyword)
1356         (:|name|
1357           (let ((qname (string-trim *whitespace*
1358                                     (consume-and-parse-characters source))))
1359             (destructure-name source qname)))
1360         (:|anyName|
1361           (unless *any-name-allowed-p*
1362             (rng-error source "anyname not permitted in except"))
1363           (klacks:consume source)
1364           (prog1
1365               (let ((*any-name-allowed-p* nil))
1366                 (make-any-name (p/except-name-class? source)))
1367             (skip-to-native source)))
1368         (:|nsName|
1369           (unless *ns-name-allowed-p*
1370             (rng-error source "nsname not permitted in except"))
1371           (let ((uri *namespace-uri*)
1372                 (*any-name-allowed-p* nil)
1373                 (*ns-name-allowed-p* nil))
1374             (when (and *attribute-namespace-p*
1375                        (equal uri "http://www.w3.org/2000/xmlns"))
1376               (rng-error source "namespace attribute not permitted"))
1377             (klacks:consume source)
1378             (prog1
1379                 (make-ns-name uri (p/except-name-class? source))
1380               (skip-to-native source))))
1381         (:|choice|
1382           (klacks:consume source)
1383           (simplify-nc-choice (p/name-class* source)))
1384         (t
1385           (rng-error source "invalid child in except"))))))
1386
1387 (defun p/name-class* (source)
1388   (let ((results nil))
1389     (loop
1390       (skip-to-native source)
1391       (case (klacks:peek source)
1392         (:characters
1393          (klacks:consume source))
1394         (:start-element
1395          (push (p/name-class source) results))
1396         (:end-element
1397          (return))))
1398     (nreverse results)))
1399
1400 (defun p/except-name-class? (source)
1401   (skip-to-native source)
1402   (multiple-value-bind (key uri lname)
1403       (klacks:peek source)
1404     uri
1405     (if (and (eq key :start-element)
1406              (string= (find-symbol lname :keyword) "except"))
1407         (p/except-name-class source)
1408         nil)))
1409
1410 (defun p/except-name-class (source)
1411   (klacks:expecting-element (source "except")
1412     (with-library-and-ns (klacks:list-attributes source)
1413       (klacks:consume source)
1414       (let ((x (p/name-class* source)))
1415         (if (cdr x)
1416             (simplify-nc-choice x)
1417             (car x))))))
1418
1419 (defun escape-uri (string)
1420   (with-output-to-string (out)
1421     (loop for c across (cxml::rod-to-utf8-string string) do
1422           (let ((code (char-code c)))
1423             ;; http://www.w3.org/TR/xlink/#link-locators
1424             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
1425                 (format out "%~2,'0X" code)
1426                 (write-char c out))))))
1427
1428
1429 ;;;; unparsing
1430
1431 (defvar *definitions-to-names*)
1432 (defvar *seen-names*)
1433 (defvar *newly-seen-definitions*)
1434
1435 (defun serialization-name (defn)
1436   (or (gethash defn *definitions-to-names*)
1437       (setf (gethash defn *definitions-to-names*)
1438             (let ((name (if (gethash (defn-name defn) *seen-names*)
1439                             (format nil "~A-~D"
1440                                     (defn-name defn)
1441                                     (hash-table-count *seen-names*))
1442                             (string (defn-name defn)))))
1443               (push defn *newly-seen-definitions*)
1444               (setf (gethash name *seen-names*) defn)
1445               name))))
1446
1447 (defun serialize-schema (schema sink)
1448   "@arg[schema]{a Relax NG @class{schema}}
1449    @arg[sink]{a SAX handler}
1450    @return{the result of @code{sax:end-document}}
1451    @short{This function serializes a parsed Relax NG back into XML syntax.}
1452
1453    Note that the schema represented in memory has gone through simplification
1454    as is textually different from the original XML document.
1455
1456    @see{parse-schema}"
1457   (cxml:with-xml-output sink
1458     (let ((*definitions-to-names* (make-hash-table))
1459           (*newly-seen-definitions* '())
1460           (*seen-names* (make-hash-table :test 'equal)))
1461       (cxml:with-namespace ("" "http://relaxng.org/ns/structure/1.0")
1462         (cxml:with-element "grammar"
1463           (cxml:with-element "start"
1464             (serialize-pattern (schema-start schema)))
1465           (do () ((null *newly-seen-definitions*))
1466             (mapc #'serialize-definition
1467                   (prog1
1468                       *newly-seen-definitions*
1469                     (setf *newly-seen-definitions* '())))))))))
1470
1471 (defun serialize-pattern (pattern)
1472   (etypecase pattern
1473     (element
1474       (cxml:with-element "element"
1475         (serialize-name (pattern-name pattern))
1476         (serialize-pattern (pattern-child pattern))))
1477     (attribute
1478       (cxml:with-element "attribute"
1479         (serialize-name (pattern-name pattern))
1480         (serialize-pattern (pattern-child pattern))))
1481     (%combination
1482       (cxml:with-element
1483           (etypecase pattern
1484             (group "group")
1485             (interleave "interleave")
1486             (choice "choice"))
1487         (serialize-pattern (pattern-a pattern))
1488         (serialize-pattern (pattern-b pattern))))
1489     (one-or-more
1490       (cxml:with-element "oneOrMore"
1491         (serialize-pattern (pattern-child pattern))))
1492     (list-pattern
1493       (cxml:with-element "list"
1494         (serialize-pattern (pattern-child pattern))))
1495     (ref
1496       (cxml:with-element "ref"
1497         (cxml:attribute "name" (serialization-name (pattern-target pattern)))))
1498     (empty
1499       (cxml:with-element "empty"))
1500     (not-allowed
1501       (cxml:with-element "notAllowed"))
1502     (text
1503       (cxml:with-element "text"))
1504     (value
1505       (cxml:with-element "value"
1506         (let ((type (pattern-type pattern)))
1507           (cxml:attribute "datatypeLibrary"
1508                           (symbol-name (cxml-types:type-library type)))
1509           (cxml:attribute "type" (cxml-types:type-name type)))
1510         (cxml:attribute "ns" (pattern-ns pattern))
1511         (cxml:text (pattern-string pattern))))
1512     (data
1513       (cxml:with-element "data"
1514         (let ((type (pattern-type pattern)))
1515           (cxml:attribute "datatypeLibrary"
1516                           (symbol-name (cxml-types:type-library type)))
1517           (cxml:attribute "type" (cxml-types:type-name type)))
1518         (dolist (param (pattern-params pattern))
1519           (cxml:with-element "param"
1520             (cxml:attribute "name" (cxml-types:param-name param))
1521             (cxml:text (cxml-types:param-value param))))
1522         (when (pattern-except pattern)
1523           (cxml:with-element "except"
1524             (serialize-pattern (pattern-except pattern))))))))
1525
1526 (defun serialize-definition (defn)
1527   (cxml:with-element "define"
1528     (cxml:attribute "name" (serialization-name defn))
1529     (serialize-pattern (defn-child defn))))
1530
1531 (defun serialize-name (name)
1532   (etypecase name
1533     (name
1534      (cxml:with-element "name"
1535        (cxml:attribute "ns" (name-uri name))
1536        (cxml:text (name-lname name))))
1537     (any-name
1538      (cxml:with-element "anyName"
1539        (when (any-name-except name)
1540          (serialize-except-name (any-name-except name)))))
1541     (ns-name
1542      (cxml:with-element "anyName"
1543        (cxml:attribute "ns" (ns-name-uri name))
1544        (when (ns-name-except name)
1545          (serialize-except-name (ns-name-except name)))))
1546     (name-class-choice
1547      (cxml:with-element "choice"
1548        (serialize-name (name-class-choice-a name))
1549        (serialize-name (name-class-choice-b name))))))
1550
1551 (defun serialize-except-name (spec)
1552   (cxml:with-element "except"
1553     (serialize-name spec)))
1554
1555
1556 ;;;; simplification
1557
1558 ;;; 4.1 Annotations
1559 ;;;   Foreign attributes and elements are removed implicitly while parsing.
1560
1561 ;;; 4.2 Whitespace
1562 ;;;   All character data is discarded while parsing (which can only be
1563 ;;;   whitespace after validation).
1564 ;;;
1565 ;;;   Whitespace in name, type, and combine attributes is stripped while
1566 ;;;   parsing.  Ditto for <name/>.
1567
1568 ;;; 4.3. datatypeLibrary attribute
1569 ;;;   Escaping is done by p/pattern.
1570 ;;;   Attribute value defaulting is done using *datatype-library*; only
1571 ;;;   p/data and p/value record the computed value.
1572
1573 ;;; 4.4. type attribute of value element
1574 ;;;   Done by p/value.
1575
1576 ;;; 4.5. href attribute
1577 ;;;   Escaping is done by process-include and p/external-ref.
1578 ;;;
1579 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
1580 ;;;   but that requires xstream hacking.
1581
1582 ;;; 4.6. externalRef element
1583 ;;;   Done by p/external-ref.
1584
1585 ;;; 4.7. include element
1586 ;;;   Done by process-include.
1587
1588 ;;; 4.8. name attribute of element and attribute elements
1589 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
1590 ;;;    p/attribute.
1591
1592 ;;; 4.9. ns attribute
1593 ;;;    done by p/name-class, p/value, p/element, p/attribute
1594
1595 ;;; 4.10. QNames
1596 ;;;    done by p/name-class
1597
1598 ;;; 4.11. div element
1599 ;;;    Legen wir gar nicht erst an.
1600
1601 ;;; 4.12. 4.13 4.14 4.15
1602 ;;;    beim anlegen
1603
1604 ;;; 4.16
1605 ;;;    p/name-class
1606 ;;;    -- ausser der sache mit den datentypen
1607
1608 ;;; 4.17, 4.18, 4.19
1609 ;;;    Ueber die Grammar-und Definition Objekte, wie von James Clark
1610 ;;;    beschrieben.
1611 ;;;
1612 ;;;    Dabei werden keine Umbenennungen vorgenommen, weil Referenzierung
1613 ;;;    durch Aufbei der Graphenstruktur zwischen ref und Definition
1614 ;;;    erfolgt und Namen dann bereits aufgeloest sind.  Wir benennen
1615 ;;;    dafuer beim Serialisieren um.
1616
1617 (defmethod check-recursion ((pattern element) depth)
1618   (check-recursion (pattern-child pattern) (1+ depth)))
1619
1620 (defmethod check-recursion ((pattern ref) depth)
1621   (when (eql (pattern-crdepth pattern) depth)
1622     (rng-error nil "infinite recursion in ~A"
1623                (defn-name (pattern-target pattern))))
1624   (when (null (pattern-crdepth pattern))
1625     (setf (pattern-crdepth pattern) depth)
1626     (check-recursion (defn-child (pattern-target pattern)) depth)
1627     (setf (pattern-crdepth pattern) t)))
1628
1629 (defmethod check-recursion ((pattern %parent) depth)
1630   (check-recursion (pattern-child pattern) depth))
1631
1632 (defmethod check-recursion ((pattern %combination) depth)
1633   (check-recursion (pattern-a pattern) depth)
1634   (check-recursion (pattern-b pattern) depth))
1635
1636 (defmethod check-recursion ((pattern %leaf) depth)
1637   (declare (ignore depth)))
1638
1639 (defmethod check-recursion ((pattern data) depth)
1640   (when (pattern-except pattern)
1641     (check-recursion (pattern-except pattern) depth)))
1642
1643
1644 ;;;; 4.20
1645
1646 ;;; %PARENT
1647
1648 (defmethod fold-not-allowed ((pattern element))
1649   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1650   pattern)
1651
1652 (defmethod fold-not-allowed ((pattern %parent))
1653   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1654   (if (typep (pattern-child pattern) 'not-allowed)
1655       (pattern-child pattern)
1656       pattern))
1657
1658 ;;; %COMBINATION
1659
1660 (defmethod fold-not-allowed ((pattern %combination))
1661   (setf (pattern-a pattern) (fold-not-allowed (pattern-a pattern)))
1662   (setf (pattern-b pattern) (fold-not-allowed (pattern-b pattern)))
1663   pattern)
1664
1665 (defmethod fold-not-allowed ((pattern group))
1666   (call-next-method)
1667   (cond
1668     ;; remove if any child is not allowed
1669     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1670     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1671     (t pattern)))
1672
1673 (defmethod fold-not-allowed ((pattern interleave))
1674   (call-next-method)
1675   (cond
1676     ;; remove if any child is not allowed
1677     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1678     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1679     (t pattern)))
1680
1681 (defmethod fold-not-allowed ((pattern choice))
1682   (call-next-method)
1683   (cond
1684     ;; if any child is not allowed, choose the other
1685     ((typep (pattern-a pattern) 'not-allowed) (pattern-b pattern))
1686     ((typep (pattern-b pattern) 'not-allowed) (pattern-a pattern))
1687     (t pattern)))
1688
1689 ;;; LEAF
1690
1691 (defmethod fold-not-allowed ((pattern %leaf))
1692   pattern)
1693
1694 (defmethod fold-not-allowed ((pattern data))
1695   (when (pattern-except pattern)
1696     (setf (pattern-except pattern) (fold-not-allowed (pattern-except pattern)))
1697     (when (typep (pattern-except pattern) 'not-allowed)
1698       (setf (pattern-except pattern) nil)))
1699   pattern)
1700
1701 ;;; REF
1702
1703 (defmethod fold-not-allowed ((pattern ref))
1704   pattern)
1705
1706
1707 ;;;; 4.21
1708
1709 ;;; %PARENT
1710
1711 (defmethod fold-empty ((pattern one-or-more))
1712   (call-next-method)
1713   (if (typep (pattern-child pattern) 'empty)
1714       (pattern-child pattern)
1715       pattern))
1716
1717 (defmethod fold-empty ((pattern %parent))
1718   (setf (pattern-child pattern) (fold-empty (pattern-child pattern)))
1719   pattern)
1720
1721 ;;; %COMBINATION
1722
1723 (defmethod fold-empty ((pattern %combination))
1724   (setf (pattern-a pattern) (fold-empty (pattern-a pattern)))
1725   (setf (pattern-b pattern) (fold-empty (pattern-b pattern)))
1726   pattern)
1727
1728 (defmethod fold-empty ((pattern group))
1729   (call-next-method)
1730   (cond
1731     ;; if any child is empty, choose the other
1732     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1733     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1734     (t pattern)))
1735
1736 (defmethod fold-empty ((pattern interleave))
1737   (call-next-method)
1738   (cond
1739     ;; if any child is empty, choose the other
1740     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1741     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1742     (t pattern)))
1743
1744 (defmethod fold-empty ((pattern choice))
1745   (call-next-method)
1746   (if (typep (pattern-b pattern) 'empty)
1747       (cond
1748         ((typep (pattern-a pattern) 'empty)
1749           (pattern-a pattern))
1750         (t
1751           (rotatef (pattern-a pattern) (pattern-b pattern))
1752           pattern))
1753       pattern))
1754
1755 ;;; LEAF
1756
1757 (defmethod fold-empty ((pattern %leaf))
1758   pattern)
1759
1760 (defmethod fold-empty ((pattern data))
1761   (when (pattern-except pattern)
1762     (setf (pattern-except pattern) (fold-empty (pattern-except pattern))))
1763   pattern)
1764
1765 ;;; REF
1766
1767 (defmethod fold-empty ((pattern ref))
1768   pattern)
1769
1770
1771 ;;;; name class overlap
1772
1773 ;;; fixme: memorize this stuff?
1774
1775 (defparameter !uri (string (code-char 1)))
1776 (defparameter !lname "")
1777
1778 (defun classes-overlap-p (nc1 nc2)
1779   (flet ((both-contain (x)
1780            (and (contains nc1 (car x) (cdr x))
1781                 (contains nc2 (car x) (cdr x)))))
1782     (or (some #'both-contain (representatives nc1))
1783         (some #'both-contain (representatives nc2)))))
1784
1785 (defmethod representatives ((nc any-name))
1786   (cons (cons !uri !lname)
1787         (if (any-name-except nc)
1788             (representatives (any-name-except nc))
1789             nil)))
1790
1791 (defmethod representatives ((nc ns-name))
1792   (cons (cons (ns-name-uri nc) !lname)
1793         (if (ns-name-except nc)
1794             (representatives (ns-name-except nc))
1795             nil)))
1796
1797 (defmethod representatives ((nc name))
1798   (list (cons (name-uri nc) (name-lname nc))))
1799
1800 (defmethod representatives ((nc name-class-choice))
1801   (nconc (representatives (name-class-choice-a nc))
1802          (representatives (name-class-choice-b nc))))
1803
1804
1805 ;;;; 7.1
1806
1807 (defun finalize-definitions (pattern)
1808   (let ((defns (make-hash-table)))
1809     (labels ((recurse (p)
1810                (cond
1811                  ((typep p 'ref)
1812                   (let ((target (pattern-target p)))
1813                     (unless (gethash target defns)
1814                       (setf (gethash target defns) t)
1815                       (setf (defn-child target) (recurse (defn-child target))))
1816                     (if (typep (defn-child target) 'element)
1817                         p
1818                         (copy-pattern-tree (defn-child target)))))
1819                  (t
1820                   (etypecase p
1821                     (data
1822                      (when (pattern-except p)
1823                        (setf (pattern-except p) (recurse (pattern-except p)))))
1824                     (%parent
1825                      (setf (pattern-child p) (recurse (pattern-child p))))
1826                     (%combination
1827                      (setf (pattern-a p) (recurse (pattern-a p)))
1828                      (setf (pattern-b p) (recurse (pattern-b p))))
1829                     (%leaf))
1830                   p))))
1831       (values
1832        (recurse pattern)
1833        (loop
1834           for defn being each hash-key in defns
1835           collect defn)))))
1836
1837 (defun copy-pattern-tree (pattern)
1838   (labels ((recurse (p)
1839              (let ((q (copy-structure p)))
1840                (etypecase p
1841                  (data
1842                   (when (pattern-except p)
1843                     (setf (pattern-except q) (recurse (pattern-except p)))))
1844                  (%parent
1845                   (setf (pattern-child q) (recurse (pattern-child p))))
1846                  (%combination
1847                   (setf (pattern-a q) (recurse (pattern-a p)))
1848                   (setf (pattern-b q) (recurse (pattern-b p))))
1849                  ((or %leaf ref)))
1850                q)))
1851     (recurse pattern)))
1852
1853 (defparameter *in-attribute-p* nil)
1854 (defparameter *in-one-or-more-p* nil)
1855 (defparameter *in-one-or-more//group-or-interleave-p* nil)
1856 (defparameter *in-list-p* nil)
1857 (defparameter *in-data-except-p* nil)
1858 (defparameter *in-start-p* nil)
1859
1860 (defun check-start-restrictions (pattern)
1861   (let ((*in-start-p* t))
1862     (check-restrictions pattern)))
1863
1864 (defun content-type-max (a b)
1865   (if (and a b)
1866       (cond
1867         ((eq a :empty) b)
1868         ((eq b :empty) a)
1869         ((eq a :complex) b)
1870         (:simple))
1871       nil))
1872
1873 (defun groupable-max (a b)
1874   (if (or (eq a :empty)
1875           (eq b :empty)
1876           (and (eq a :complex)
1877                (eq b :complex)))
1878       (content-type-max a b)
1879       nil))
1880
1881 (defun assert-name-class-finite (nc)
1882   (etypecase nc
1883     ((or any-name ns-name)
1884      (rng-error nil "infinite attribute name class outside of one-or-more"))
1885     (name)
1886     (name-class-choice
1887      (assert-name-class-finite (name-class-choice-a nc))
1888      (assert-name-class-finite (name-class-choice-b nc)))))
1889
1890 (defmethod check-restrictions ((pattern attribute))
1891   (when *in-attribute-p*
1892     (rng-error nil "nested attribute not allowed"))
1893   (when *in-one-or-more//group-or-interleave-p*
1894     (rng-error nil "attribute not allowed in oneOrMore//group, oneOrMore//interleave"))
1895   (when *in-list-p*
1896     (rng-error nil "attribute in list not allowed"))
1897   (when *in-data-except-p*
1898     (rng-error nil "attribute in data/except not allowed"))
1899   (when *in-start-p*
1900     (rng-error nil "attribute in start not allowed"))
1901   (let ((*in-attribute-p* t))
1902     (unless *in-one-or-more-p*
1903       (assert-name-class-finite (pattern-name pattern)))
1904     (values (if (check-restrictions (pattern-child pattern))
1905                 :empty
1906                 nil)
1907             (list (pattern-name pattern))
1908             nil)))
1909
1910 (defmethod check-restrictions ((pattern ref))
1911   (when *in-attribute-p*
1912     (rng-error nil "ref in attribute not allowed"))
1913   (when *in-list-p*
1914     (rng-error nil "ref in list not allowed"))
1915   (when *in-data-except-p*
1916     (rng-error nil "ref in data/except not allowed"))
1917   (values :complex
1918           nil
1919           (list (pattern-name (defn-child (pattern-target pattern))))
1920           nil))
1921
1922 (defmethod check-restrictions ((pattern one-or-more))
1923   (when *in-data-except-p*
1924     (rng-error nil "oneOrMore in data/except not allowed"))
1925   (when *in-start-p*
1926     (rng-error nil "one-or-more in start not allowed"))
1927   (let* ((*in-one-or-more-p* t))
1928     (multiple-value-bind (x a e textp)
1929         (check-restrictions (pattern-child pattern))
1930       (values (groupable-max x x) a e textp))))
1931
1932 (defmethod check-restrictions ((pattern group))
1933   (when *in-data-except-p*
1934     (rng-error nil "group in data/except not allowed"))
1935   (when *in-start-p*
1936     (rng-error nil "group in start not allowed"))
1937   (let ((*in-one-or-more//group-or-interleave-p*
1938          *in-one-or-more-p*))
1939     (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1940       (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1941         (dolist (nc1 a)
1942           (dolist (nc2 b)
1943             (when (classes-overlap-p nc1 nc2)
1944               (rng-error nil "attribute name overlap in group: ~A ~A"
1945                          nc1 nc2))))
1946         (values (groupable-max x y)
1947                 (append a b)
1948                 (append e f)
1949                 (or tp tq))))))
1950
1951 (defmethod check-restrictions ((pattern interleave))
1952   (when *in-list-p*
1953     (rng-error nil "interleave in list not allowed"))
1954   (when *in-data-except-p*
1955     (rng-error nil "interleave in data/except not allowed"))
1956   (when *in-start-p*
1957     (rng-error nil "interleave in start not allowed"))
1958   (let ((*in-one-or-more//group-or-interleave-p*
1959          *in-one-or-more-p*))
1960     (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1961       (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1962         (dolist (nc1 a)
1963           (dolist (nc2 b)
1964             (when (classes-overlap-p nc1 nc2)
1965               (rng-error nil "attribute name overlap in interleave: ~A ~A"
1966                          nc1 nc2))))
1967         (dolist (nc1 e)
1968           (dolist (nc2 f)
1969             (when (classes-overlap-p nc1 nc2)
1970               (rng-error nil "element name overlap in interleave: ~A ~A"
1971                          nc1 nc2))))
1972         (when (and tp tq)
1973           (rng-error nil "multiple text permitted by interleave"))
1974         (values (groupable-max x y)
1975                 (append a b)
1976                 (append e f)
1977                 (or tp tq))))))
1978
1979 (defmethod check-restrictions ((pattern choice))
1980   (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1981     (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1982       (values (content-type-max x y)
1983               (append a b)
1984               (append e f)
1985               (or tp tq)))))
1986
1987 (defmethod check-restrictions ((pattern list-pattern))
1988   (when *in-list-p*
1989     (rng-error nil "nested list not allowed"))
1990   (when *in-data-except-p*
1991     (rng-error nil "list in data/except not allowed"))
1992   (let ((*in-list-p* t))
1993     (check-restrictions (pattern-child pattern)))
1994   (when *in-start-p*
1995     (rng-error nil "list in start not allowed"))
1996   :simple)
1997
1998 (defmethod check-restrictions ((pattern text))
1999   (when *in-list-p*
2000     (rng-error nil "text in list not allowed"))
2001   (when *in-data-except-p*
2002     (rng-error nil "text in data/except not allowed"))
2003   (when *in-start-p*
2004     (rng-error nil "text in start not allowed"))
2005   (values :complex nil nil t))
2006
2007 (defmethod check-restrictions ((pattern data))
2008   (when *in-start-p*
2009     (rng-error nil "data in start not allowed"))
2010   (when (pattern-except pattern)
2011     (let ((*in-data-except-p* t))
2012       (check-restrictions (pattern-except pattern))))
2013   :simple)
2014
2015 (defmethod check-restrictions ((pattern value))
2016   (when *in-start-p*
2017     (rng-error nil "value in start not allowed"))
2018   :simple)
2019
2020 (defmethod check-restrictions ((pattern empty))
2021   (when *in-data-except-p*
2022     (rng-error nil "empty in data/except not allowed"))
2023   (when *in-start-p*
2024     (rng-error nil "empty in start not allowed"))
2025   :empty)
2026
2027 (defmethod check-restrictions ((pattern element))
2028   (unless (check-restrictions (pattern-child pattern))
2029     (rng-error nil "restrictions on string sequences violated")))
2030
2031 (defmethod check-restrictions ((pattern not-allowed))
2032   nil)
2033
2034
2035 ;;; compatibility restrictions
2036
2037 (defvar *in-element* nil)
2038 (defvar *in-attribute* nil)
2039 (defvar *in-choices* nil)
2040 (defvar *in-default-value-p* nil)
2041 (defvar *compatibility-table*)
2042 (defvar *dtd-restriction-validator*)
2043
2044 (defun check-schema-compatibility (schema defns)
2045   (let* ((*error-class* 'dtd-compatibility-error)
2046          (elements (mapcar #'defn-child defns))
2047          (table (make-compatibility-table))
2048          (*dtd-restriction-validator* (nth-value 1 (make-validator schema))))
2049     (setf (schema-compatibility-table schema) table)
2050     (let ((*compatibility-table* table))
2051       (mapc #'check-pattern-compatibility elements))
2052     (loop for elt1 being each hash-value in (dtd-elements table) do
2053           (let ((nc1 (dtd-name elt1)))
2054             (dolist (elt2 elements)
2055               (let ((nc2 (pattern-name elt2)))
2056                 (when (classes-overlap-p nc1 nc2)
2057                   (check-element-overlap-compatibility elt1 elt2)))))
2058          ;; clean out ID type bookkeeping:
2059          (let ((attributes (dtd-attributes elt1)))
2060            (maphash (lambda (k v)
2061                       (when (eq (dtd-id-type v) :unknown)
2062                         (if (dtd-default-value v)
2063                             (setf (dtd-id-type v) nil)
2064                             (remhash k attributes))))
2065                     attributes)))))
2066
2067 (defun check-element-overlap-compatibility (elt1 elt2)
2068   (unless
2069       (if (typep (pattern-name elt2) 'name)
2070           ;; must both declare the same defaulted attributes
2071           (loop
2072              for a being each hash-value in (dtd-attributes elt1)
2073              always (or (null (dtd-default-value a))
2074                         (find elt2 (dtd-value-declared-by a))))
2075           ;; elt1 has an attribute with defaultValue
2076           ;; elt2 cannot have any defaultValue  ##
2077           (loop
2078              for a being each hash-value in (dtd-attributes elt1)
2079              never (dtd-default-value a)))
2080     (rng-error nil "overlapping elements with and without defaultValue"))
2081   (unless
2082       (if (typep (pattern-name elt2) 'name)
2083           ;; must both declare the same attributes with ID-type
2084           (loop
2085              for a being each hash-value in (dtd-attributes elt1)
2086              always (or (eq (dtd-id-type a) :unknown)
2087                         (find elt2 (dtd-id-type-declared-by a))))
2088           ;; elt1 has an attribute with ID-type
2089           ;; elt2 cannot have any ID-type  ##
2090           (loop
2091              for a being each hash-value in (dtd-attributes elt1)
2092              always (eq (dtd-id-type a) :unknown)))
2093     (rng-error nil "overlapping elements with and without ID-type")))
2094
2095 (defun check-attribute-compatibility/default (pattern default-value)
2096   (unless (typep (pattern-name pattern) 'name)
2097     (rng-error nil "defaultValue declared in attribute without <name>"))
2098   (unless (typep (pattern-name *in-element*) 'name)
2099     (rng-error nil "defaultValue declared in element without <name>"))
2100   (let* ((hsx *dtd-restriction-validator*)
2101          (derivation
2102           (intern-pattern (pattern-child pattern) (registratur hsx))))
2103     (unless (value-matches-p hsx derivation default-value)
2104       (rng-error nil "defaultValue not valid")))
2105   (unless *in-choices*
2106     (rng-error nil "defaultValue declared outside of <choice>"))
2107   (dolist (choice *in-choices*
2108            (rng-error nil "defaultValue in <choice>, but no <empty> found"))
2109     (when (or (typep (pattern-a choice) 'empty)
2110               (typep (pattern-b choice) 'empty))
2111       (return)))
2112   (let ((a (ensure-dtd-attribute (pattern-name pattern)
2113                                  *in-element*
2114                                  *compatibility-table*)))
2115     (cond
2116       ((null (dtd-default-value a))
2117        (setf (dtd-default-value a) default-value))
2118       ((not (equal (dtd-default-value a) default-value))
2119        (rng-error nil "inconsistent defaultValue declarations")))
2120     (push *in-element* (dtd-value-declared-by a))))
2121
2122 (defun check-attribute-compatibility/id (pattern default-value)
2123   (let* ((dt (pattern-type (pattern-child pattern)))
2124          (id-type (cxml-types:type-id-type dt)))
2125     (when (and default-value (cxml-types:type-context-dependent-p dt))
2126       (rng-error nil
2127                  "defaultValue declared with context dependent type"))
2128     (when id-type
2129       (unless (typep (pattern-name pattern) 'name)
2130         (rng-error nil "defaultValue declared in attribute without <name>"))
2131       (unless (typep (pattern-name *in-element*) 'name)
2132         (rng-error nil "defaultValue declared in element without <name>"))
2133       (let ((a (ensure-dtd-attribute (pattern-name pattern)
2134                                      *in-element*
2135                                      *compatibility-table*)))
2136         (cond
2137           ((eq (dtd-id-type a) :unknown)
2138            (setf (dtd-id-type a) id-type))
2139           ((not (eq id-type (dtd-id-type a)))
2140            (rng-error nil "inconsistent ID type attributes")))
2141         (push *in-element* (dtd-id-type-declared-by a))))))
2142
2143 (defmethod check-pattern-compatibility ((pattern attribute))
2144   (declare (optimize debug (speed 0) (space 0)))
2145   (let* ((*in-attribute* pattern)
2146          (default-value (pattern-default-value pattern))
2147          (*in-default-value-p* t))
2148     (when default-value
2149       (check-attribute-compatibility/default pattern default-value))
2150     (if (typep (pattern-child pattern) '(or data value))
2151         (check-attribute-compatibility/id pattern default-value)
2152         (check-pattern-compatibility (pattern-child pattern)))))
2153
2154 (defmethod check-pattern-compatibility ((pattern ref))
2155   nil)
2156
2157 (defmethod check-pattern-compatibility ((pattern one-or-more))
2158   (check-pattern-compatibility (pattern-child pattern)))
2159
2160 (defmethod check-pattern-compatibility ((pattern %combination))
2161   (check-pattern-compatibility (pattern-a pattern))
2162   (check-pattern-compatibility (pattern-b pattern)))
2163
2164 (defmethod check-pattern-compatibility ((pattern choice))
2165   (let ((*in-choices* (cons pattern *in-choices*)))
2166     (check-pattern-compatibility (pattern-a pattern))
2167     (check-pattern-compatibility (pattern-b pattern))))
2168
2169 (defmethod check-pattern-compatibility ((pattern list-pattern))
2170   (check-pattern-compatibility (pattern-child pattern)))
2171
2172 (defmethod check-pattern-compatibility ((pattern %leaf))
2173   nil)
2174
2175 (defmethod check-pattern-compatibility ((pattern data))
2176   (when (and *in-default-value-p*
2177              (cxml-types:type-context-dependent-p (pattern-type pattern)))
2178     (rng-error nil "defaultValue declared with context dependent type"))
2179   (when (cxml-types:type-id-type (pattern-type pattern))
2180     (rng-error nil "ID type not a child of attribute")))
2181
2182 (defmethod check-pattern-compatibility ((pattern value))
2183   (when (and *in-default-value-p*
2184              (cxml-types:type-context-dependent-p (pattern-type pattern)))
2185     (rng-error nil "defaultValue declared with context dependent type"))
2186   (when (cxml-types:type-id-type (pattern-type pattern))
2187     (rng-error nil "ID type not a child of attribute")))
2188
2189 (defmethod check-pattern-compatibility ((pattern element))
2190   (assert (null *in-element*))
2191   (let ((*in-element* pattern))
2192     (check-pattern-compatibility (pattern-child pattern))))