parse.lisp

   1 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   2
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26
  27 (in-package :cxml-rng)
  28
  29 #+sbcl
  30 (declaim (optimize (debug 2)))
  31
  32
  33 ;;;; Errors
  34
  35 (define-condition rng-error (simple-error) ()
  36   (:documentation "The class of all validation errors."))
  37
  38 (defun rng-error (source fmt &rest args)
  39   (let ((s (make-string-output-stream)))
  40     (apply #'format s fmt args)
  41     (when source
  42       (etypecase source
  43         (klacks:source
  44          (format s "~&  [ Error at line ~D, column ~D in ~S ]"
  45                  (klacks:current-line-number source)
  46                  (klacks:current-column-number source)
  47                  (klacks:current-system-id source)))
  48         (sax:sax-parser-mixin
  49          (format s "~&  [ Error at line ~D, column ~D in ~S ]"
  50                  (sax:line-number source)
  51                  (sax:column-number source)
  52                  (sax:system-id source))) ))
  53     (error 'rng-error
  54            :format-control "~A"
  55            :format-arguments (list (get-output-stream-string s)))))
  56
  57
  58 ;;;; Parser
  59
  60 (defvar *datatype-library*)
  61 (defvar *namespace-uri*)
  62 (defvar *ns*)
  63 (defvar *entity-resolver*)
  64 (defvar *external-href-stack*)
  65 (defvar *include-uri-stack*)
  66 (defvar *include-body-p* nil)
  67 (defvar *grammar*)
  68
  69 (defvar *debug* nil)
  70
  71 (defstruct (parsed-grammar
  72              (:constructor make-parsed-grammar (pattern definitions)))
  73   "An instance of this class represents a Relax NG grammar that has
  74    been parsed and simplified.
  75    @see-slot{parsed-grammar-pattern}
  76    @see-constructor{parse-relax-ng}
  77    @see{make-validator}
  78    @see{serialize-grammar} "
  79   (pattern (missing) :type pattern)
  80   (definitions (missing) :type list)
  81   (interned-start nil :type (or null pattern))
  82   (registratur nil :type (or null hash-table)))
  83
  84 (setf (documentation 'parsed-grammar-pattern 'function)
  85       "@arg[instance]{an instance of @class{parsed-grammar}}
  86        @return{the start pattern, an instance of @class{pattern}}
  87        Reader function for the grammar's start pattern, from which all
  88        of the grammar's patters are reachable.")
  89
  90 (defmethod print-object ((object parsed-grammar) stream)
  91   (print-unreadable-object (object stream :type t :identity t)))
  92
  93 (defun invoke-with-klacks-handler (fn source)
  94   (if *debug*
  95       (funcall fn)
  96       (handler-case
  97           (funcall fn)
  98         (cxml:xml-parse-error (c)
  99           (rng-error source "Cannot parse schema: ~A" c)))))
 100
 101 (defvar *validate-grammar* t)
 102 (defparameter *relax-ng-grammar* nil)
 103
 104 (defun make-validating-source (input)
 105   (let ((upstream (cxml:make-source input)))
 106     (if *validate-grammar*
 107         (klacks:make-tapping-source upstream
 108                                     (make-validator *relax-ng-grammar*))
 109         upstream)))
 110
 111 (defun parse-relax-ng (input &key entity-resolver)
 112   (when *validate-grammar*
 113     (unless *relax-ng-grammar*
 114       (setf *relax-ng-grammar*
 115             (let* ((*validate-grammar* nil)
 116                    (d (slot-value (asdf:find-system :cxml-rng)
 117                                   'asdf::relative-pathname)))
 118               (parse-relax-ng (merge-pathnames "rng.rng" d))))))
 119   (klacks:with-open-source (source (make-validating-source input))
 120     (invoke-with-klacks-handler
 121      (lambda ()
 122        (klacks:find-event source :start-element)
 123        (let* ((*datatype-library* "")
 124               (*namespace-uri* "")
 125               (*entity-resolver* entity-resolver)
 126               (*external-href-stack* '())
 127               (*include-uri-stack* '())
 128               (*grammar* (make-grammar nil))
 129               (start (p/pattern source)))
 130          (unless start
 131            (rng-error nil "empty grammar"))
 132          (setf (grammar-start *grammar*)
 133                (make-definition :name :start :child start))
 134          (check-pattern-definitions source *grammar*)
 135          (check-recursion start 0)
 136          (multiple-value-bind (new-start defns)
 137              (finalize-definitions start)
 138            (setf start (fold-not-allowed new-start))
 139            (dolist (defn defns)
 140              (setf (defn-child defn) (fold-not-allowed (defn-child defn))))
 141            (setf start (fold-empty start))
 142            (dolist (defn defns)
 143              (setf (defn-child defn) (fold-empty (defn-child defn)))))
 144          (multiple-value-bind (new-start defns)
 145              (finalize-definitions start)
 146            (check-start-restrictions new-start)
 147            (dolist (defn defns)
 148              (check-restrictions (defn-child defn)))
 149            (make-parsed-grammar new-start defns))))
 150      source)))
 151
 152
 153 ;;;; pattern structures
 154
 155 (defstruct pattern)
 156
 157 (defmethod print-object :around ((object pattern) stream)
 158   (if *debug*
 159       (let ((*print-circle* t))
 160         (call-next-method))
 161       (print-unreadable-object (object stream :type t :identity t))))
 162
 163 (defstruct (%parent (:include pattern) (:conc-name "PATTERN-"))
 164   child)
 165
 166 (defstruct (%named-pattern (:include %parent) (:conc-name "PATTERN-"))
 167   name)
 168 (defstruct (element (:include %named-pattern) (:conc-name "PATTERN-")))
 169 (defstruct (attribute (:include %named-pattern) (:conc-name "PATTERN-")))
 170
 171 (defstruct (%combination (:include pattern) (:conc-name "PATTERN-"))
 172   a b)
 173 (defstruct (group
 174             (:include %combination)
 175             (:constructor make-group (a b))))
 176 (defstruct (interleave
 177             (:include %combination)
 178             (:constructor make-interleave (a b))))
 179 (defstruct (choice
 180             (:include %combination)
 181             (:constructor make-choice (a b))))
 182 (defstruct (after
 183             (:include %combination)
 184             (:constructor make-after (a b))))
 185
 186 (defstruct (one-or-more
 187             (:include %parent)
 188             (:constructor make-one-or-more (child))))
 189 (defstruct (list-pattern
 190             (:include %parent)
 191             (:constructor make-list-pattern (child))))
 192
 193 (defstruct (ref
 194             (:include pattern)
 195             (:conc-name "PATTERN-")
 196             (:constructor make-ref (target)))
 197   crdepth
 198   target)
 199
 200 (defstruct (%leaf (:include pattern)))
 201
 202 (defstruct (empty (:include %leaf) (:conc-name "PATTERN-")))
 203 (defstruct (text (:include %leaf) (:conc-name "PATTERN-")))
 204
 205 (defstruct (%typed-pattern (:include %leaf) (:conc-name "PATTERN-"))
 206   type)
 207
 208 (defstruct (value (:include %typed-pattern) (:conc-name "PATTERN-"))
 209   ns
 210   string
 211   value)
 212
 213 (defstruct (data (:include %typed-pattern) (:conc-name "PATTERN-"))
 214   params
 215   except)
 216
 217 (defstruct (not-allowed (:include %leaf) (:conc-name "PATTERN-")))
 218
 219
 220 ;;;; non-pattern
 221
 222 (defstruct (grammar (:constructor make-grammar (parent)))
 223   (start nil)
 224   parent
 225   (definitions (make-hash-table :test 'equal)))
 226
 227 (defstruct param
 228   name
 229   string)
 230
 231 ;; Clark calls this structure "RefPattern"
 232 (defstruct (definition (:conc-name "DEFN-"))
 233   name
 234   combine-method
 235   head-p
 236   redefinition
 237   child)
 238
 239
 240 ;;; name-class
 241
 242 (defun missing ()
 243   (error "missing arg"))
 244
 245 (defstruct name-class)
 246
 247 (defstruct (any-name (:include name-class)
 248                      (:constructor make-any-name (except)))
 249   (except (missing) :type (or null name-class)))
 250
 251 (defstruct (name (:include name-class)
 252                  (:constructor make-name (uri lname)))
 253   (uri (missing) :type string)
 254   (lname (missing) :type string))
 255
 256 (defstruct (ns-name (:include name-class)
 257                     (:constructor make-ns-name (uri except)))
 258   (uri (missing) :type string)
 259   (except (missing) :type (or null name-class)))
 260
 261 (defstruct (name-class-choice (:include name-class)
 262                               (:constructor make-name-class-choice (a b)))
 263   (a (missing) :type name-class)
 264   (b (missing) :type name-class))
 265
 266 (defun simplify-nc-choice (values)
 267   (zip #'make-name-class-choice values))
 268
 269
 270 ;;;; parser
 271
 272 (defvar *rng-namespace* "http://relaxng.org/ns/structure/1.0")
 273
 274 (defun skip-foreign* (source)
 275   (loop
 276     (case (klacks:peek-next source)
 277       (:start-element (skip-foreign source))
 278       (:end-element (return)))))
 279
 280 (defun skip-to-native (source)
 281   (loop
 282     (case (klacks:peek source)
 283       (:start-element
 284         (when (equal (klacks:current-uri source) *rng-namespace*)
 285           (return))
 286         (klacks:serialize-element source nil))
 287       (:end-element (return)))
 288     (klacks:consume source)))
 289
 290 (defun consume-and-skip-to-native (source)
 291   (klacks:consume source)
 292   (skip-to-native source))
 293
 294 (defun skip-foreign (source)
 295   (when (equal (klacks:current-uri source) *rng-namespace*)
 296     (rng-error source
 297                "invalid schema: ~A not allowed here"
 298                (klacks:current-lname source)))
 299   (klacks:serialize-element source nil))
 300
 301 (defun attribute (lname attrs)
 302   (let ((a (sax:find-attribute-ns "" lname attrs)))
 303     (if a
 304         (sax:attribute-value a)
 305         nil)))
 306
 307 (defparameter *whitespace*
 308     (format nil "~C~C~C~C"
 309             (code-char 9)
 310             (code-char 32)
 311             (code-char 13)
 312             (code-char 10)))
 313
 314 (defun ntc (lname source-or-attrs)
 315   ;; used for (n)ame, (t)ype, and (c)ombine, this also strings whitespace
 316   (let* ((attrs
 317           (if (listp source-or-attrs)
 318               source-or-attrs
 319               (klacks:list-attributes source-or-attrs)))
 320          (a (sax:find-attribute-ns "" lname attrs)))
 321     (if a
 322         (string-trim *whitespace* (sax:attribute-value a))
 323         nil)))
 324
 325 (defmacro with-library-and-ns (attrs &body body)
 326   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 327
 328 (defun invoke-with-library-and-ns (fn attrs)
 329   (let* ((dl (attribute "datatypeLibrary" attrs))
 330          (ns (attribute "ns" attrs))
 331          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 332          (*namespace-uri* (or ns *namespace-uri*))
 333          (*ns* ns))
 334     ;; FIXME: Ganz boese gehackt -- gerade so, dass wir die Relax NG
 335     ;; Test-Suite bestehen.
 336     (when (and dl
 337                (not (zerop (length *datatype-library*)))
 338                ;; scheme pruefen, und es muss was folgen
 339                (or (not (cl-ppcre:all-matches
 340                          "^[a-zA-Z][a-zA-Z0-9+.-]*:.+"
 341                          *datatype-library*))
 342                    ;; keine kaputten %te, keine #
 343                    (cl-ppcre:all-matches
 344                     "(%$|%.$|%[^0-9A-Fa-f][^0-9A-Fa-f]|#)"
 345                     *datatype-library*)))
 346       (rng-error nil "malformed datatypeLibrary: ~A" *datatype-library*))
 347     (funcall fn)))
 348
 349 (defun p/pattern (source)
 350   (let* ((lname (klacks:current-lname source))
 351          (attrs (klacks:list-attributes source)))
 352     (with-library-and-ns attrs
 353       (case (find-symbol lname :keyword)
 354         (:|element|     (p/element source (ntc "name" attrs)))
 355         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 356         (:|group|       (p/combination #'groupify source))
 357         (:|interleave|  (p/combination #'interleave-ify source))
 358         (:|choice|      (p/combination #'choice-ify source))
 359         (:|optional|    (p/optional source))
 360         (:|zeroOrMore|  (p/zero-or-more source))
 361         (:|oneOrMore|   (p/one-or-more source))
 362         (:|list|        (p/list source))
 363         (:|mixed|       (p/mixed source))
 364         (:|ref|         (p/ref source))
 365         (:|parentRef|   (p/parent-ref source))
 366         (:|empty|       (p/empty source))
 367         (:|text|        (p/text source))
 368         (:|value|       (p/value source))
 369         (:|data|        (p/data source))
 370         (:|notAllowed|  (p/not-allowed source))
 371         (:|externalRef| (p/external-ref source))
 372         (:|grammar|     (p/grammar source))
 373         (t (skip-foreign source))))))
 374
 375 (defun p/pattern+ (source)
 376   (let ((children nil))
 377     (loop
 378       (case (klacks:peek source)
 379         (:start-element
 380           (let ((p (p/pattern source))) (when p (push p children))))
 381         (:end-element
 382           (return))
 383         (t
 384           (klacks:consume source))))
 385     (unless children
 386       (rng-error source "empty element"))
 387     (nreverse children)))
 388
 389 (defun p/pattern? (source)
 390   (let ((result nil))
 391     (loop
 392       (skip-to-native source)
 393       (case (klacks:peek source)
 394         (:start-element
 395           (when result
 396             (rng-error source "at most one pattern expected here"))
 397           (setf result (p/pattern source)))
 398         (:end-element
 399           (return))
 400         (t
 401           (klacks:consume source))))
 402     result))
 403
 404 (defun p/element (source name)
 405   (klacks:expecting-element (source "element")
 406     (let ((elt (make-element)))
 407       (consume-and-skip-to-native source)
 408       (if name
 409           (setf (pattern-name elt) (destructure-name source name))
 410           (setf (pattern-name elt) (p/name-class source)))
 411       (skip-to-native source)
 412       (setf (pattern-child elt) (groupify (p/pattern+ source)))
 413       (make-ref (make-definition :name (gensym "ANONYMOUS") :child elt)))))
 414
 415 (defvar *attribute-namespace-p* nil)
 416
 417 (defun p/attribute (source name)
 418   (klacks:expecting-element (source "attribute")
 419     (let ((result (make-attribute)))
 420       (consume-and-skip-to-native source)
 421       (if name
 422           (setf (pattern-name result)
 423                 (let ((*namespace-uri* (or *ns* ""))
 424                       (*attribute-namespace-p* t))
 425                   (destructure-name source name)))
 426           (setf (pattern-name result)
 427                 (let ((*attribute-namespace-p* t))
 428                   (p/name-class source))))
 429       (skip-to-native source)
 430       (setf (pattern-child result)
 431             (or (p/pattern? source) (make-text)))
 432       result)))
 433
 434 (defun p/combination (zipper source)
 435   (klacks:expecting-element (source)
 436     (consume-and-skip-to-native source)
 437     (funcall zipper (p/pattern+ source))))
 438
 439 (defun p/one-or-more (source)
 440   (klacks:expecting-element (source "oneOrMore")
 441     (consume-and-skip-to-native source)
 442     (let ((children (p/pattern+ source)))
 443       (make-one-or-more (groupify children)))))
 444
 445 (defun p/zero-or-more (source)
 446   (klacks:expecting-element (source "zeroOrMore")
 447     (consume-and-skip-to-native source)
 448     (let ((children (p/pattern+ source)))
 449       (make-choice (make-one-or-more (groupify children))
 450                    (make-empty)))))
 451
 452 (defun p/optional (source)
 453   (klacks:expecting-element (source "optional")
 454     (consume-and-skip-to-native source)
 455     (let ((children (p/pattern+ source)))
 456       (make-choice (groupify children) (make-empty)))))
 457
 458 (defun p/list (source)
 459   (klacks:expecting-element (source "list")
 460     (consume-and-skip-to-native source)
 461     (let ((children (p/pattern+ source)))
 462       (make-list-pattern (groupify children)))))
 463
 464 (defun p/mixed (source)
 465   (klacks:expecting-element (source "mixed")
 466     (consume-and-skip-to-native source)
 467     (let ((children (p/pattern+ source)))
 468       (make-interleave (groupify children) (make-text)))))
 469
 470 (defun p/ref (source)
 471   (klacks:expecting-element (source "ref")
 472     (prog1
 473         (let* ((name (ntc "name" source))
 474                (pdefinition
 475                 (or (find-definition name)
 476                     (setf (find-definition name)
 477                           (make-definition :name name :child nil)))))
 478           (make-ref pdefinition))
 479       (skip-foreign* source))))
 480
 481 (defun p/parent-ref (source)
 482   (klacks:expecting-element (source "parentRef")
 483     (prog1
 484         (let* ((name (ntc "name" source))
 485                (grammar (grammar-parent *grammar*))
 486                (pdefinition
 487                 (or (find-definition name grammar)
 488                     (setf (find-definition name grammar)
 489                           (make-definition :name name :child nil)))))
 490           (make-ref pdefinition))
 491       (skip-foreign* source))))
 492
 493 (defun p/empty (source)
 494   (klacks:expecting-element (source "empty")
 495     (skip-foreign* source)
 496     (make-empty)))
 497
 498 (defun p/text (source)
 499   (klacks:expecting-element (source "text")
 500     (skip-foreign* source)
 501     (make-text)))
 502
 503 (defun consume-and-parse-characters (source)
 504   ;; fixme
 505   (let ((tmp ""))
 506     (loop
 507       (multiple-value-bind (key data) (klacks:peek-next source)
 508         (case key
 509           (:characters
 510             (setf tmp (concatenate 'string tmp data)))
 511           (:end-element (return)))))
 512     tmp))
 513
 514 (defun p/value (source)
 515   (klacks:expecting-element (source "value")
 516     (let* ((type (ntc "type" source))
 517            (string (consume-and-parse-characters source))
 518            (ns *namespace-uri*)
 519            (dl *datatype-library*))
 520       (unless type
 521         (setf type "token")
 522         (setf dl ""))
 523       (let ((data-type
 524              (cxml-types:find-type (and dl (find-symbol dl :keyword)) type))
 525             (vc (cxml-types:make-klacks-validation-context source)))
 526         (unless data-type
 527           (rng-error source "type not found: ~A/~A" type dl))
 528         (make-value :string string
 529                     :value (cxml-types:parse data-type string vc)
 530                     :type data-type
 531                     :ns ns)))))
 532
 533 (defun p/data (source)
 534   (klacks:expecting-element (source "data")
 535     (let* ((type (ntc "type" source))
 536            (params '())
 537            (except nil))
 538       (loop
 539          (multiple-value-bind (key uri lname)
 540              (klacks:peek-next source)
 541            uri
 542            (case key
 543              (:start-element
 544               (case (find-symbol lname :keyword)
 545                 (:|param| (push (p/param source) params))
 546                 (:|except|
 547                   (setf except (p/except-pattern source))
 548                   (skip-to-native source)
 549                   (return))
 550                 (t (skip-foreign source))))
 551              (:end-element
 552               (return)))))
 553       (setf params (nreverse params))
 554       (let* ((dl *datatype-library*)
 555              (data-type (apply #'cxml-types:find-type
 556                                (and dl (find-symbol dl :keyword))
 557                                type
 558                                (loop
 559                                   for p in params
 560                                   collect (find-symbol (param-name p)
 561                                                        :keyword)
 562                                   collect (param-string p)))))
 563         (unless data-type
 564           (rng-error source "type not found: ~A/~A" type dl))
 565         (make-data
 566          :type data-type
 567          :params params
 568          :except except)))))
 569
 570 (defun p/param (source)
 571   (klacks:expecting-element (source "param")
 572     (let ((name (ntc "name" source))
 573           (string (consume-and-parse-characters source)))
 574       (make-param :name name :string string))))
 575
 576 (defun p/except-pattern (source)
 577   (klacks:expecting-element (source "except")
 578     (with-library-and-ns (klacks:list-attributes source)
 579       (klacks:consume source)
 580       (choice-ify (p/pattern+ source)))))
 581
 582 (defun p/not-allowed (source)
 583   (klacks:expecting-element (source "notAllowed")
 584     (consume-and-skip-to-native source)
 585     (make-not-allowed)))
 586
 587 (defun safe-parse-uri (source str &optional base)
 588   (when (zerop (length str))
 589     (rng-error source "missing URI"))
 590   (let ((uri
 591          (handler-case
 592              (if base
 593                  (puri:merge-uris str base)
 594                  (puri:parse-uri str))
 595            (puri:uri-parse-error ()
 596              (rng-error source "invalid URI: ~A" str)))))
 597     (when (and (eq (puri:uri-scheme uri) :file)
 598                (puri:uri-fragment uri))
 599       (rng-error source "Forbidden fragment in URI: ~A" str))
 600     uri))
 601
 602 (defun p/external-ref (source)
 603   (klacks:expecting-element (source "externalRef")
 604     (let* ((href
 605             (escape-uri (attribute "href" (klacks:list-attributes source))))
 606            (base (klacks:current-xml-base source))
 607            (uri (safe-parse-uri source href base)))
 608       (when (find uri *include-uri-stack* :test #'puri:uri=)
 609         (rng-error source "looping include"))
 610       (prog1
 611           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 612                  (xstream
 613                   (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 614             (klacks:with-open-source (source (make-validating-source xstream))
 615               (invoke-with-klacks-handler
 616                (lambda ()
 617                  (klacks:find-event source :start-element)
 618                  (let ((*datatype-library* ""))
 619                    (p/pattern source)))
 620                source)))
 621         (skip-foreign* source)))))
 622
 623 (defun p/grammar (source &optional grammar)
 624   (klacks:expecting-element (source "grammar")
 625     (consume-and-skip-to-native source)
 626     (let ((*grammar* (or grammar (make-grammar *grammar*)))
 627           (includep grammar))
 628       (process-grammar-content* source)
 629       (unless (or includep (grammar-start *grammar*))
 630         (rng-error source "no <start> in grammar"))
 631       (unless includep
 632         (check-pattern-definitions source *grammar*)
 633         (defn-child (grammar-start *grammar*))))))
 634
 635 (defvar *include-start*)
 636 (defvar *include-definitions*)
 637
 638 (defun process-grammar-content* (source &key disallow-include)
 639   (loop
 640     (multiple-value-bind (key uri lname) (klacks:peek source)
 641       uri
 642       (case key
 643         (:start-element
 644           (with-library-and-ns (klacks:list-attributes source)
 645             (case (find-symbol lname :keyword)
 646               (:|start| (process-start source))
 647               (:|define| (process-define source))
 648               (:|div| (process-div source))
 649               (:|include|
 650                 (when disallow-include
 651                   (rng-error source "nested include not permitted"))
 652                 (process-include source))
 653               (t
 654                 (skip-foreign source)))))
 655         (:end-element
 656           (return))))
 657     (klacks:consume source)))
 658
 659 (defun process-start (source)
 660   (klacks:expecting-element (source "start")
 661     (let* ((combine0 (ntc "combine" source))
 662            (combine
 663             (when combine0
 664               (find-symbol (string-upcase combine0) :keyword)))
 665            (child
 666             (progn
 667               (consume-and-skip-to-native source)
 668               (p/pattern source)))
 669            (pdefinition (grammar-start *grammar*)))
 670       (skip-foreign* source)
 671       ;; fixme: shared code with process-define
 672       (unless pdefinition
 673         (setf pdefinition (make-definition :name :start :child nil))
 674         (setf (grammar-start *grammar*) pdefinition))
 675       (when *include-body-p*
 676         (setf *include-start* pdefinition))
 677       (cond
 678         ((defn-child pdefinition)
 679          (ecase (defn-redefinition pdefinition)
 680            (:not-being-redefined
 681              (when (and combine
 682                         (defn-combine-method pdefinition)
 683                         (not (eq combine
 684                                  (defn-combine-method pdefinition))))
 685                (rng-error source "conflicting combine values for <start>"))
 686              (unless combine
 687                (when (defn-head-p pdefinition)
 688                  (rng-error source "multiple definitions for <start>"))
 689                (setf (defn-head-p pdefinition) t))
 690              (unless (defn-combine-method pdefinition)
 691                (setf (defn-combine-method pdefinition) combine))
 692              (setf (defn-child pdefinition)
 693                    (case (defn-combine-method pdefinition)
 694                      (:choice
 695                        (make-choice (defn-child pdefinition) child))
 696                      (:interleave
 697                        (make-interleave (defn-child pdefinition) child)))))
 698            (:being-redefined-and-no-original
 699              (setf (defn-redefinition pdefinition)
 700                    :being-redefined-and-original))
 701            (:being-redefined-and-original)))
 702         (t
 703           (setf (defn-child pdefinition) child)
 704           (setf (defn-combine-method pdefinition) combine)
 705           (setf (defn-head-p pdefinition) (null combine))
 706           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
 707
 708 (defun zip (constructor children)
 709   (cond
 710     ((null children)
 711       (rng-error nil "empty choice?"))
 712     ((null (cdr children))
 713       (car children))
 714     (t
 715       (destructuring-bind (a b &rest rest)
 716           children
 717         (zip constructor (cons (funcall constructor a b) rest))))))
 718
 719 (defun choice-ify (children) (zip #'make-choice children))
 720 (defun groupify (children) (zip #'make-group children))
 721 (defun interleave-ify (children) (zip #'make-interleave children))
 722
 723 (defun find-definition (name &optional (grammar *grammar*))
 724   (gethash name (grammar-definitions grammar)))
 725
 726 (defun (setf find-definition) (newval name &optional (grammar *grammar*))
 727   (setf (gethash name (grammar-definitions grammar)) newval))
 728
 729 (defun process-define (source)
 730   (klacks:expecting-element (source "define")
 731     (let* ((name (ntc "name" source))
 732            (combine0 (ntc "combine" source))
 733            (combine (when combine0
 734                       (find-symbol (string-upcase combine0) :keyword)))
 735            (child (groupify
 736                    (progn
 737                      (consume-and-skip-to-native source)
 738                      (p/pattern+ source))))
 739            (pdefinition (find-definition name)))
 740       (unless pdefinition
 741         (setf pdefinition (make-definition :name name :child nil))
 742         (setf (find-definition name) pdefinition))
 743       (when *include-body-p*
 744         (push pdefinition *include-definitions*))
 745       (cond
 746         ((defn-child pdefinition)
 747           (case (defn-redefinition pdefinition)
 748             (:not-being-redefined
 749               (when (and combine
 750                          (defn-combine-method pdefinition)
 751                          (not (eq combine
 752                                   (defn-combine-method pdefinition))))
 753                 (rng-error source "conflicting combine values for ~A" name))
 754               (unless combine
 755                 (when (defn-head-p pdefinition)
 756                   (rng-error source "multiple definitions for ~A" name))
 757                 (setf (defn-head-p pdefinition) t))
 758               (unless (defn-combine-method pdefinition)
 759                 (setf (defn-combine-method pdefinition) combine))
 760               (setf (defn-child pdefinition)
 761                     (case (defn-combine-method pdefinition)
 762                       (:choice
 763                         (make-choice (defn-child pdefinition) child))
 764                       (:interleave
 765                         (make-interleave (defn-child pdefinition) child)))))
 766             (:being-redefined-and-no-original
 767               (setf (defn-redefinition pdefinition)
 768                     :being-redefined-and-original))
 769             (:being-redefined-and-original)))
 770         (t
 771           (setf (defn-child pdefinition) child)
 772           (setf (defn-combine-method pdefinition) combine)
 773           (setf (defn-head-p pdefinition) (null combine))
 774           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
 775
 776 (defun process-div (source)
 777   (klacks:expecting-element (source "div")
 778     (consume-and-skip-to-native source)
 779     (process-grammar-content* source)))
 780
 781 (defun reset-definition-for-include (defn)
 782   (setf (defn-combine-method defn) nil)
 783   (setf (defn-redefinition defn) :being-redefined-and-no-original)
 784   (setf (defn-head-p defn) nil))
 785
 786 (defun restore-definition (defn original)
 787   (setf (defn-combine-method defn) (defn-combine-method original))
 788   (setf (defn-redefinition defn) (defn-redefinition original))
 789   (setf (defn-head-p defn) (defn-head-p original)))
 790
 791 (defun process-include (source)
 792   (klacks:expecting-element (source "include")
 793     (let* ((href
 794             (escape-uri (attribute "href" (klacks:list-attributes source))))
 795            (base (klacks:current-xml-base source))
 796            (uri (safe-parse-uri source href base))
 797            (*include-start* nil)
 798            (*include-definitions* '()))
 799       (consume-and-skip-to-native source)
 800       (let ((*include-body-p* t))
 801         (process-grammar-content* source :disallow-include t))
 802       (let ((tmp-start
 803              (when *include-start*
 804                (prog1
 805                    (copy-structure *include-start*)
 806                  (reset-definition-for-include *include-start*))))
 807             (tmp-defns
 808              (loop
 809                  for defn in *include-definitions*
 810                  collect
 811                    (prog1
 812                        (copy-structure defn)
 813                      (reset-definition-for-include defn)))))
 814         (when (find uri *include-uri-stack* :test #'puri:uri=)
 815           (rng-error source "looping include"))
 816         (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 817                (xstream (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 818           (klacks:with-open-source (source (make-validating-source xstream))
 819             (invoke-with-klacks-handler
 820              (lambda ()
 821                (klacks:find-event source :start-element)
 822                (let ((*datatype-library* ""))
 823                  (p/grammar source *grammar*)))
 824              source))
 825           (when tmp-start
 826             (when (eq (defn-redefinition *include-start*)
 827                       :being-redefined-and-no-original)
 828               (rng-error source "start not found in redefinition of grammar"))
 829             (restore-definition *include-start* tmp-start))
 830           (dolist (copy tmp-defns)
 831             (let ((defn (gethash (defn-name copy)
 832                                  (grammar-definitions *grammar*))))
 833               (when (eq (defn-redefinition defn)
 834                         :being-redefined-and-no-original)
 835                 (rng-error source "redefinition not found in grammar"))
 836               (restore-definition defn copy)))
 837           nil)))))
 838
 839 (defun check-pattern-definitions (source grammar)
 840   (when (and (grammar-start grammar)
 841              (eq (defn-redefinition (grammar-start grammar))
 842                  :being-redefined-and-no-original))
 843     (rng-error source "start not found in redefinition of grammar"))
 844   (loop for defn being each hash-value in (grammar-definitions grammar) do
 845         (when (eq (defn-redefinition defn) :being-redefined-and-no-original)
 846           (rng-error source "redefinition not found in grammar"))
 847         (unless (defn-child defn)
 848           (rng-error source "unresolved reference to ~A" (defn-name defn)))))
 849
 850 (defvar *any-name-allowed-p* t)
 851 (defvar *ns-name-allowed-p* t)
 852
 853 (defun destructure-name (source qname)
 854   (multiple-value-bind (uri lname)
 855       (klacks:decode-qname qname source)
 856     (setf uri (or uri *namespace-uri*))
 857     (when (and *attribute-namespace-p*
 858                (or (and (equal lname "xmlns") (equal uri ""))
 859                    (equal uri "http://www.w3.org/2000/xmlns")))
 860       (rng-error source "namespace attribute not permitted"))
 861     (make-name uri lname)))
 862
 863 (defun p/name-class (source)
 864   (klacks:expecting-element (source)
 865     (with-library-and-ns (klacks:list-attributes source)
 866       (case (find-symbol (klacks:current-lname source) :keyword)
 867         (:|name|
 868           (let ((qname (string-trim *whitespace*
 869                                     (consume-and-parse-characters source))))
 870             (destructure-name source qname)))
 871         (:|anyName|
 872           (unless *any-name-allowed-p*
 873             (rng-error source "anyname now permitted in except"))
 874           (klacks:consume source)
 875           (prog1
 876               (let ((*any-name-allowed-p* nil))
 877                 (make-any-name (p/except-name-class? source)))
 878             (skip-to-native source)))
 879         (:|nsName|
 880           (unless *ns-name-allowed-p*
 881             (rng-error source "nsname now permitted in except"))
 882           (let ((uri *namespace-uri*)
 883                 (*any-name-allowed-p* nil)
 884                 (*ns-name-allowed-p* nil))
 885             (when (and *attribute-namespace-p*
 886                        (equal uri "http://www.w3.org/2000/xmlns"))
 887               (rng-error source "namespace attribute not permitted"))
 888             (klacks:consume source)
 889             (prog1
 890                 (make-ns-name uri (p/except-name-class? source))
 891               (skip-to-native source))))
 892         (:|choice|
 893           (klacks:consume source)
 894           (simplify-nc-choice (p/name-class* source)))
 895         (t
 896           (rng-error source "invalid child in except"))))))
 897
 898 (defun p/name-class* (source)
 899   (let ((results nil))
 900     (loop
 901       (skip-to-native source)
 902       (case (klacks:peek source)
 903         (:start-element (push (p/name-class source) results))
 904         (:end-element (return)))
 905       (klacks:consume source))
 906     (nreverse results)))
 907
 908 (defun p/except-name-class? (source)
 909   (skip-to-native source)
 910   (multiple-value-bind (key uri lname)
 911       (klacks:peek source)
 912     uri
 913     (if (and (eq key :start-element)
 914              (string= (find-symbol lname :keyword) "except"))
 915         (p/except-name-class source)
 916         nil)))
 917
 918 (defun p/except-name-class (source)
 919   (klacks:expecting-element (source "except")
 920     (with-library-and-ns (klacks:list-attributes source)
 921       (klacks:consume source)
 922       (let ((x (p/name-class* source)))
 923         (if (cdr x)
 924             (simplify-nc-choice x)
 925             (car x))))))
 926
 927 (defun escape-uri (string)
 928   (with-output-to-string (out)
 929     (loop for c across (cxml::rod-to-utf8-string string) do
 930           (let ((code (char-code c)))
 931             ;; http://www.w3.org/TR/xlink/#link-locators
 932             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
 933                 (format out "%~2,'0X" code)
 934                 (write-char c out))))))
 935
 936
 937 ;;;; unparsing
 938
 939 (defvar *definitions-to-names*)
 940 (defvar *seen-names*)
 941
 942 (defun serialization-name (defn)
 943   (or (gethash defn *definitions-to-names*)
 944       (setf (gethash defn *definitions-to-names*)
 945             (let ((name (if (gethash (defn-name defn) *seen-names*)
 946                             (format nil "~A-~D"
 947                                     (defn-name defn)
 948                                     (hash-table-count *seen-names*))
 949                             (defn-name defn))))
 950               (setf (gethash name *seen-names*) defn)
 951               name))))
 952
 953 (defun serialize-grammar (grammar sink)
 954   (cxml:with-xml-output sink
 955     (let ((*definitions-to-names* (make-hash-table))
 956           (*seen-names* (make-hash-table :test 'equal)))
 957       (cxml:with-element "grammar"
 958         (cxml:with-element "start"
 959           (serialize-pattern (parsed-grammar-pattern grammar)))
 960         (loop for defn being each hash-key in *definitions-to-names* do
 961               (serialize-definition defn))))))
 962
 963 (defun serialize-pattern (pattern)
 964   (etypecase pattern
 965     (element
 966       (cxml:with-element "element"
 967         (serialize-name (pattern-name pattern))
 968         (serialize-pattern (pattern-child pattern))))
 969     (attribute
 970       (cxml:with-element "attribute"
 971         (serialize-name (pattern-name pattern))
 972         (serialize-pattern (pattern-child pattern))))
 973     (%combination
 974       (cxml:with-element
 975           (etypecase pattern
 976             (group "group")
 977             (interleave "interleave")
 978             (choice "choice"))
 979         (serialize-pattern (pattern-a pattern))
 980         (serialize-pattern (pattern-b pattern))))
 981     (one-or-more
 982       (cxml:with-element "oneOrMore"
 983         (serialize-pattern (pattern-child pattern))))
 984     (list-pattern
 985       (cxml:with-element "list"
 986         (serialize-pattern (pattern-child pattern))))
 987     (ref
 988       (cxml:with-element "ref"
 989         (cxml:attribute "name" (serialization-name (pattern-target pattern)))))
 990     (empty
 991       (cxml:with-element "empty"))
 992     (not-allowed
 993       (cxml:with-element "notAllowed"))
 994     (text
 995       (cxml:with-element "text"))
 996     (value
 997       (cxml:with-element "value"
 998         (let ((type (pattern-type pattern)))
 999           (cxml:attribute "datatype-library"
1000                           (symbol-name (cxml-types:type-library type)))
1001           (cxml:attribute "type" (cxml-types:type-name type)))
1002         (cxml:attribute "ns" (pattern-ns pattern))
1003         (cxml:text (pattern-string pattern))))
1004     (data
1005       (cxml:with-element "value"
1006         (let ((type (pattern-type pattern)))
1007           (cxml:attribute "datatype-library"
1008                           (symbol-name (cxml-types:type-library type)))
1009           (cxml:attribute "type" (cxml-types:type-name type)))
1010         (dolist (param (pattern-params pattern))
1011           (cxml:with-element "param"
1012             (cxml:attribute "name" (param-name param))
1013             (cxml:text (param-string param))))
1014         (when (pattern-except pattern)
1015           (cxml:with-element "except"
1016             (serialize-pattern (pattern-except pattern))))))))
1017
1018 (defun serialize-definition (defn)
1019   (cxml:with-element "define"
1020     (cxml:attribute "name" (serialization-name defn))
1021     (serialize-pattern (defn-child defn))))
1022
1023 (defun serialize-name (name)
1024   (etypecase name
1025     (name
1026      (cxml:with-element "name"
1027        (cxml:attribute "ns" (name-uri name))
1028        (cxml:text (name-lname name))))
1029     (any-name
1030      (cxml:with-element "anyName"
1031        (when (any-name-except name)
1032          (serialize-except-name (any-name-except name)))))
1033     (ns-name
1034      (cxml:with-element "anyName"
1035        (cxml:attribute "ns" (ns-name-uri name))
1036        (when (ns-name-except name)
1037          (serialize-except-name (ns-name-except name)))))
1038     (name-class-choice
1039      (cxml:with-element "choice"
1040        (serialize-name (name-class-choice-a name))
1041        (serialize-name (name-class-choice-b name))))))
1042
1043 (defun serialize-except-name (spec)
1044   (cxml:with-element "except"
1045     (serialize-name spec)))
1046
1047
1048 ;;;; simplification
1049
1050 ;;; 4.1 Annotations
1051 ;;;   Foreign attributes and elements are removed implicitly while parsing.
1052
1053 ;;; 4.2 Whitespace
1054 ;;;   All character data is discarded while parsing (which can only be
1055 ;;;   whitespace after validation).
1056 ;;;
1057 ;;;   Whitespace in name, type, and combine attributes is stripped while
1058 ;;;   parsing.  Ditto for <name/>.
1059
1060 ;;; 4.3. datatypeLibrary attribute
1061 ;;;   Escaping is done by p/pattern.
1062 ;;;   Attribute value defaulting is done using *datatype-library*; only
1063 ;;;   p/data and p/value record the computed value.
1064
1065 ;;; 4.4. type attribute of value element
1066 ;;;   Done by p/value.
1067
1068 ;;; 4.5. href attribute
1069 ;;;   Escaping is done by process-include and p/external-ref.
1070 ;;;
1071 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
1072 ;;;   but that requires xstream hacking.
1073
1074 ;;; 4.6. externalRef element
1075 ;;;   Done by p/external-ref.
1076
1077 ;;; 4.7. include element
1078 ;;;   Done by process-include.
1079
1080 ;;; 4.8. name attribute of element and attribute elements
1081 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
1082 ;;;    p/attribute.
1083
1084 ;;; 4.9. ns attribute
1085 ;;;    done by p/name-class, p/value, p/element, p/attribute
1086
1087 ;;; 4.10. QNames
1088 ;;;    done by p/name-class
1089
1090 ;;; 4.11. div element
1091 ;;;    Legen wir gar nicht erst an.
1092
1093 ;;; 4.12. 4.13 4.14 4.15
1094 ;;;    beim anlegen
1095
1096 ;;; 4.16
1097 ;;;    p/name-class
1098 ;;;    -- ausser der sache mit den datentypen
1099
1100 ;;; 4.17, 4.18, 4.19
1101 ;;;    Ueber die Grammar-und Definition Objekte, wie von James Clark
1102 ;;;    beschrieben.
1103 ;;;
1104 ;;;    Dabei werden keine Umbenennungen vorgenommen, weil Referenzierung
1105 ;;;    durch Aufbei der Graphenstruktur zwischen ref und Definition
1106 ;;;    erfolgt und Namen dann bereits aufgeloest sind.  Wir benennen
1107 ;;;    dafuer beim Serialisieren um.
1108
1109 (defmethod check-recursion ((pattern element) depth)
1110   (check-recursion (pattern-child pattern) (1+ depth)))
1111
1112 (defmethod check-recursion ((pattern ref) depth)
1113   (when (eql (pattern-crdepth pattern) depth)
1114     (rng-error nil "infinite recursion in ~A"
1115                (defn-name (pattern-target pattern))))
1116   (when (null (pattern-crdepth pattern))
1117     (setf (pattern-crdepth pattern) depth)
1118     (check-recursion (defn-child (pattern-target pattern)) depth)
1119     (setf (pattern-crdepth pattern) t)))
1120
1121 (defmethod check-recursion ((pattern %parent) depth)
1122   (check-recursion (pattern-child pattern) depth))
1123
1124 (defmethod check-recursion ((pattern %combination) depth)
1125   (check-recursion (pattern-a pattern) depth)
1126   (check-recursion (pattern-b pattern) depth))
1127
1128 (defmethod check-recursion ((pattern %leaf) depth)
1129   (declare (ignore depth)))
1130
1131 (defmethod check-recursion ((pattern data) depth)
1132   (when (pattern-except pattern)
1133     (check-recursion (pattern-except pattern) depth)))
1134
1135
1136 ;;;; 4.20
1137
1138 ;;; %PARENT
1139
1140 (defmethod fold-not-allowed ((pattern element))
1141   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1142   pattern)
1143
1144 (defmethod fold-not-allowed ((pattern %parent))
1145   (setf (pattern-child pattern) (fold-not-allowed (pattern-child pattern)))
1146   (if (typep (pattern-child pattern) 'not-allowed)
1147       (pattern-child pattern)
1148       pattern))
1149
1150 ;;; %COMBINATION
1151
1152 (defmethod fold-not-allowed ((pattern %combination))
1153   (setf (pattern-a pattern) (fold-not-allowed (pattern-a pattern)))
1154   (setf (pattern-b pattern) (fold-not-allowed (pattern-b pattern)))
1155   pattern)
1156
1157 (defmethod fold-not-allowed ((pattern group))
1158   (call-next-method)
1159   (cond
1160     ;; remove if any child is not allowed
1161     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1162     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1163     (t pattern)))
1164
1165 (defmethod fold-not-allowed ((pattern interleave))
1166   (call-next-method)
1167   (cond
1168     ;; remove if any child is not allowed
1169     ((typep (pattern-a pattern) 'not-allowed) (pattern-a pattern))
1170     ((typep (pattern-b pattern) 'not-allowed) (pattern-b pattern))
1171     (t pattern)))
1172
1173 (defmethod fold-not-allowed ((pattern choice))
1174   (call-next-method)
1175   (cond
1176     ;; if any child is not allowed, choose the other
1177     ((typep (pattern-a pattern) 'not-allowed) (pattern-b pattern))
1178     ((typep (pattern-b pattern) 'not-allowed) (pattern-a pattern))
1179     (t pattern)))
1180
1181 ;;; LEAF
1182
1183 (defmethod fold-not-allowed ((pattern %leaf))
1184   pattern)
1185
1186 (defmethod fold-not-allowed ((pattern data))
1187   (when (pattern-except pattern)
1188     (setf (pattern-except pattern) (fold-not-allowed (pattern-except pattern)))
1189     (when (typep (pattern-except pattern) 'not-allowed)
1190       (setf (pattern-except pattern) nil)))
1191   pattern)
1192
1193 ;;; REF
1194
1195 (defmethod fold-not-allowed ((pattern ref))
1196   pattern)
1197
1198
1199 ;;;; 4.21
1200
1201 ;;; %PARENT
1202
1203 (defmethod fold-empty ((pattern one-or-more))
1204   (call-next-method)
1205   (if (typep (pattern-child pattern) 'empty)
1206       (pattern-child pattern)
1207       pattern))
1208
1209 (defmethod fold-empty ((pattern %parent))
1210   (setf (pattern-child pattern) (fold-empty (pattern-child pattern)))
1211   pattern)
1212
1213 ;;; %COMBINATION
1214
1215 (defmethod fold-empty ((pattern %combination))
1216   (setf (pattern-a pattern) (fold-empty (pattern-a pattern)))
1217   (setf (pattern-b pattern) (fold-empty (pattern-b pattern)))
1218   pattern)
1219
1220 (defmethod fold-empty ((pattern group))
1221   (call-next-method)
1222   (cond
1223     ;; if any child is empty, choose the other
1224     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1225     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1226     (t pattern)))
1227
1228 (defmethod fold-empty ((pattern interleave))
1229   (call-next-method)
1230   (cond
1231     ;; if any child is empty, choose the other
1232     ((typep (pattern-a pattern) 'empty) (pattern-b pattern))
1233     ((typep (pattern-b pattern) 'empty) (pattern-a pattern))
1234     (t pattern)))
1235
1236 (defmethod fold-empty ((pattern choice))
1237   (call-next-method)
1238   (if (typep (pattern-b pattern) 'empty)
1239       (cond
1240         ((typep (pattern-a pattern) 'empty)
1241           (pattern-a pattern))
1242         (t
1243           (rotatef (pattern-a pattern) (pattern-b pattern))
1244           pattern))
1245       pattern))
1246
1247 ;;; LEAF
1248
1249 (defmethod fold-empty ((pattern %leaf))
1250   pattern)
1251
1252 (defmethod fold-empty ((pattern data))
1253   (when (pattern-except pattern)
1254     (setf (pattern-except pattern) (fold-empty (pattern-except pattern))))
1255   pattern)
1256
1257 ;;; REF
1258
1259 (defmethod fold-empty ((pattern ref))
1260   pattern)
1261
1262
1263 ;;;; name class overlap
1264
1265 ;;; fixme: memorize this stuff?
1266
1267 (defparameter !uri (string (code-char 1)))
1268 (defparameter !lname "")
1269
1270 (defun classes-overlap-p (nc1 nc2)
1271   (flet ((both-contain (x)
1272            (and (contains nc1 (car x) (cdr x))
1273                 (contains nc2 (car x) (cdr x)))))
1274     (or (some #'both-contain (representatives nc1))
1275         (some #'both-contain (representatives nc2)))))
1276
1277 (defmethod representatives ((nc any-name))
1278   (cons (cons !uri !lname)
1279         (if (any-name-except nc)
1280             (representatives (any-name-except nc))
1281             nil)))
1282
1283 (defmethod representatives ((nc ns-name))
1284   (cons (cons (ns-name-uri nc) !lname)
1285         (if (ns-name-except nc)
1286             (representatives (ns-name-except nc))
1287             nil)))
1288
1289 (defmethod representatives ((nc name))
1290   (list (cons (name-uri nc) (name-lname nc))))
1291
1292 (defmethod representatives ((nc name-class-choice))
1293   (nconc (representatives (name-class-choice-a nc))
1294          (representatives (name-class-choice-b nc))))
1295
1296
1297 ;;;; 7.1
1298
1299 (defun finalize-definitions (pattern)
1300   (let ((defns (make-hash-table)))
1301     (labels ((recurse (p)
1302                (cond
1303                  ((typep p 'ref)
1304                   (let ((target (pattern-target p)))
1305                     (unless (gethash target defns)
1306                       (setf (gethash target defns) t)
1307                       (setf (defn-child target) (recurse (defn-child target))))
1308                     (if (typep (defn-child target) 'element)
1309                         p
1310                         (copy-pattern-tree (defn-child target)))))
1311                  (t
1312                   (etypecase p
1313                     (data
1314                      (when (pattern-except p)
1315                        (setf (pattern-except p) (recurse (pattern-except p)))))
1316                     (%parent
1317                      (setf (pattern-child p) (recurse (pattern-child p))))
1318                     (%combination
1319                      (setf (pattern-a p) (recurse (pattern-a p)))
1320                      (setf (pattern-b p) (recurse (pattern-b p))))
1321                     (%leaf))
1322                   p))))
1323       (values
1324        (recurse pattern)
1325        (loop
1326           for defn being each hash-key in defns
1327           collect defn)))))
1328
1329 (defun copy-pattern-tree (pattern)
1330   (labels ((recurse (p)
1331              (let ((q (copy-structure p)))
1332                (etypecase p
1333                  (data
1334                   (when (pattern-except p)
1335                     (setf (pattern-except q) (recurse (pattern-except p)))))
1336                  (%parent
1337                   (setf (pattern-child q) (recurse (pattern-child p))))
1338                  (%combination
1339                   (setf (pattern-a q) (recurse (pattern-a p)))
1340                   (setf (pattern-b q) (recurse (pattern-b p))))
1341                  ((or %leaf ref)))
1342                q)))
1343     (recurse pattern)))
1344
1345 (defparameter *in-attribute-p* nil)
1346 (defparameter *in-one-or-more-p* nil)
1347 (defparameter *in-one-or-more//group-or-interleave-p* nil)
1348 (defparameter *in-list-p* nil)
1349 (defparameter *in-data-except-p* nil)
1350 (defparameter *in-start-p* nil)
1351
1352 (defun check-start-restrictions (pattern)
1353   (let ((*in-start-p* t))
1354     (check-restrictions pattern)))
1355
1356 (defun content-type-max (a b)
1357   (if (and a b)
1358       (cond
1359         ((eq a :empty) b)
1360         ((eq b :empty) a)
1361         ((eq a :complex) b)
1362         (:simple))
1363       nil))
1364
1365 (defun groupable-max (a b)
1366   (if (or (eq a :empty)
1367           (eq b :empty)
1368           (and (eq a :complex)
1369                (eq b :complex)))
1370       (content-type-max a b)
1371       nil))
1372
1373 (defun assert-name-class-finite (nc)
1374   (etypecase nc
1375     ((or any-name ns-name)
1376      (rng-error nil "infinite attribute name class outside of one-or-more"))
1377     (name)
1378     (name-class-choice
1379      (assert-name-class-finite (name-class-choice-a nc))
1380      (assert-name-class-finite (name-class-choice-b nc)))))
1381
1382 (defmethod check-restrictions ((pattern attribute))
1383   (when *in-attribute-p*
1384     (rng-error nil "nested attribute not allowed"))
1385   (when *in-one-or-more//group-or-interleave-p*
1386     (rng-error nil "attribute not allowed in oneOrMore//group, oneOrMore//interleave"))
1387   (when *in-list-p*
1388     (rng-error nil "attribute in list not allowed"))
1389   (when *in-data-except-p*
1390     (rng-error nil "attribute in data/except not allowed"))
1391   (when *in-start-p*
1392     (rng-error nil "attribute in start not allowed"))
1393   (let ((*in-attribute-p* t))
1394     (unless *in-one-or-more-p*
1395       (assert-name-class-finite (pattern-name pattern)))
1396     (values (if (check-restrictions (pattern-child pattern))
1397                 :empty
1398                 nil)
1399             (list (pattern-name pattern))
1400             nil)))
1401
1402 (defmethod check-restrictions ((pattern ref))
1403   (when *in-attribute-p*
1404     (rng-error nil "ref in attribute not allowed"))
1405   (when *in-list-p*
1406     (rng-error nil "ref in list not allowed"))
1407   (when *in-data-except-p*
1408     (rng-error nil "ref in data/except not allowed"))
1409   (values :complex
1410           nil
1411           (list (pattern-name (defn-child (pattern-target pattern))))
1412           nil))
1413
1414 (defmethod check-restrictions ((pattern one-or-more))
1415   (when *in-data-except-p*
1416     (rng-error nil "oneOrMore in data/except not allowed"))
1417   (when *in-start-p*
1418     (rng-error nil "one-or-more in start not allowed"))
1419   (let* ((*in-one-or-more-p* t))
1420     (multiple-value-bind (x a e textp)
1421         (check-restrictions (pattern-child pattern))
1422       (values (groupable-max x x) a e textp))))
1423
1424 (defmethod check-restrictions ((pattern group))
1425   (when *in-data-except-p*
1426     (rng-error nil "group in data/except not allowed"))
1427   (when *in-start-p*
1428     (rng-error nil "group in start not allowed"))
1429   (let ((*in-one-or-more//group-or-interleave-p*
1430          *in-one-or-more-p*))
1431     (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1432       (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1433         (dolist (nc1 a)
1434           (dolist (nc2 b)
1435             (when (classes-overlap-p nc1 nc2)
1436               (rng-error nil "attribute name overlap in group: ~A ~A"
1437                          nc1 nc2))))
1438         (values (groupable-max x y)
1439                 (append a b)
1440                 (append e f)
1441                 (or tp tq))))))
1442
1443 (defmethod check-restrictions ((pattern interleave))
1444   (when *in-list-p*
1445     (rng-error nil "interleave in list not allowed"))
1446   (when *in-data-except-p*
1447     (rng-error nil "interleave in data/except not allowed"))
1448   (when *in-start-p*
1449     (rng-error nil "interleave in start not allowed"))
1450   (let ((*in-one-or-more//group-or-interleave-p*
1451          *in-one-or-more-p*))
1452     (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1453       (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1454         (dolist (nc1 a)
1455           (dolist (nc2 b)
1456             (when (classes-overlap-p nc1 nc2)
1457               (rng-error nil "attribute name overlap in interleave: ~A ~A"
1458                          nc1 nc2))))
1459         (dolist (nc1 e)
1460           (dolist (nc2 f)
1461             (when (classes-overlap-p nc1 nc2)
1462               (rng-error nil "element name overlap in interleave: ~A ~A"
1463                          nc1 nc2))))
1464         (when (and tp tq)
1465           (rng-error nil "multiple text permitted by interleave"))
1466         (values (groupable-max x y)
1467                 (append a b)
1468                 (append e f)
1469                 (or tp tq))))))
1470
1471 (defmethod check-restrictions ((pattern choice))
1472   (multiple-value-bind (x a e tp) (check-restrictions (pattern-a pattern))
1473     (multiple-value-bind (y b f tq) (check-restrictions (pattern-b pattern))
1474       (values (content-type-max x y)
1475               (append a b)
1476               (append e f)
1477               (or tp tq)))))
1478
1479 (defmethod check-restrictions ((pattern list-pattern))
1480   (when *in-list-p*
1481     (rng-error nil "nested list not allowed"))
1482   (when *in-data-except-p*
1483     (rng-error nil "list in data/except not allowed"))
1484   (let ((*in-list-p* t))
1485     (check-restrictions (pattern-child pattern)))
1486   (when *in-start-p*
1487     (rng-error nil "list in start not allowed"))
1488   :simple)
1489
1490 (defmethod check-restrictions ((pattern text))
1491   (when *in-list-p*
1492     (rng-error nil "text in list not allowed"))
1493   (when *in-data-except-p*
1494     (rng-error nil "text in data/except not allowed"))
1495   (when *in-start-p*
1496     (rng-error nil "text in start not allowed"))
1497   (values :complex nil nil t))
1498
1499 (defmethod check-restrictions ((pattern data))
1500   (when *in-start-p*
1501     (rng-error nil "data in start not allowed"))
1502   (when (pattern-except pattern)
1503     (let ((*in-data-except-p* t))
1504       (check-restrictions (pattern-except pattern))))
1505   :simple)
1506
1507 (defmethod check-restrictions ((pattern value))
1508   (when *in-start-p*
1509     (rng-error nil "value in start not allowed"))
1510   :simple)
1511
1512 (defmethod check-restrictions ((pattern empty))
1513   (when *in-data-except-p*
1514     (rng-error nil "empty in data/except not allowed"))
1515   (when *in-start-p*
1516     (rng-error nil "empty in start not allowed"))
1517   :empty)
1518
1519 (defmethod check-restrictions ((pattern element))
1520   (unless (check-restrictions (pattern-child pattern))
1521     (rng-error nil "restrictions on string sequences violated")))
1522
1523 (defmethod check-restrictions ((pattern not-allowed))
1524   nil)