parse.lisp

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