parse.lisp

   1 (in-package :cxml-rng)
   2
   3 #+sbcl
   4 (declaim (optimize (debug 2)))
   5
   6
   7 ;;;; Errors
   8
   9 (define-condition rng-error (simple-error) ())
  10
  11 (defun rng-error (source fmt &rest args)
  12   (let ((s (make-string-output-stream)))
  13     (apply #'format s fmt args)
  14     (when source
  15       (format s "~&  [ Error at line ~D, column ~D in ~S ]"
  16               (klacks:current-line-number source)
  17               (klacks:current-column-number source)
  18               (klacks:current-system-id source)))
  19     (error 'rng-error
  20            :format-control "~A"
  21            :format-arguments (list (get-output-stream-string s)))))
  22
  23
  24 ;;;; Parser
  25
  26 (defvar *datatype-library*)
  27 (defvar *namespace-uri*)
  28 (defvar *entity-resolver*)
  29 (defvar *external-href-stack*)
  30 (defvar *include-uri-stack*)
  31 (defvar *include-body-p* nil)
  32 (defvar *grammar*)
  33
  34 (defvar *debug* nil)
  35
  36 (defun invoke-with-klacks-handler (fn source)
  37   (if *debug*
  38       (funcall fn)
  39       (handler-case
  40           (funcall fn)
  41         (cxml:xml-parse-error (c)
  42           (rng-error source "Cannot parse schema: ~A" c)))))
  43
  44 (defun parse-relax-ng (input &key entity-resolver)
  45   (klacks:with-open-source (source (cxml:make-source input))
  46     (invoke-with-klacks-handler
  47      (lambda ()
  48        (klacks:find-event source :start-element)
  49        (let* ((*datatype-library* "")
  50               (*namespace-uri* "")
  51               (*entity-resolver* entity-resolver)
  52               (*external-href-stack* '())
  53               (*include-uri-stack* '())
  54               (*grammar* (make-grammar nil))
  55               (result (p/pattern source)))
  56          (unless result
  57            (rng-error nil "empty grammar"))
  58          (setf (grammar-start *grammar*)
  59                (make-definition :name :start :child result))
  60          (check-pattern-definitions source *grammar*)
  61          (check-recursion result 0)
  62          result))
  63       source)))
  64
  65
  66 ;;;; pattern structures
  67
  68 (defstruct pattern)
  69
  70 (defstruct (%parent (:include pattern) (:conc-name "PATTERN-"))
  71   child)
  72
  73 (defstruct (%named-pattern (:include %parent) (:conc-name "PATTERN-"))
  74   name)
  75 (defstruct (element (:include %named-pattern) (:conc-name "PATTERN-")))
  76 (defstruct (attribute (:include %named-pattern) (:conc-name "PATTERN-")))
  77
  78 (defstruct (%combination (:include pattern) (:conc-name "PATTERN-"))
  79   a b)
  80 (defstruct (group
  81             (:include %combination)
  82             (:constructor make-group (a b))))
  83 (defstruct (interleave
  84             (:include %combination)
  85             (:constructor make-interleave (a b))))
  86 (defstruct (choice
  87             (:include %combination)
  88             (:constructor make-choice (a b))))
  89
  90 (defstruct (one-or-more
  91             (:include %parent)
  92             (:constructor make-one-or-more (child))))
  93 (defstruct (list-pattern
  94             (:include %parent)
  95             (:constructor make-list-pattern (child))))
  96
  97 (defstruct (ref
  98             (:include pattern)
  99             (:conc-name "PATTERN-")
 100             (:constructor make-ref (target)))
 101   crdepth
 102   target)
 103
 104 (defstruct (%leaf (:include pattern)))
 105
 106 (defstruct (empty (:include %leaf) (:conc-name "PATTERN-")))
 107 (defstruct (text (:include %leaf) (:conc-name "PATTERN-")))
 108
 109 (defstruct (%typed-pattern (:include %leaf) (:conc-name "PATTERN-"))
 110   datatype-library
 111   type)
 112
 113 (defstruct (value (:include %typed-pattern) (:conc-name "PATTERN-"))
 114   ns
 115   string)
 116
 117 (defstruct (data (:include %typed-pattern) (:conc-name "PATTERN-"))
 118   params
 119   except)
 120
 121 (defstruct (not-allowed (:include %leaf) (:conc-name "PATTERN-")))
 122
 123
 124 ;;;; non-pattern
 125
 126 (defstruct (grammar (:constructor make-grammar (parent)))
 127   (start nil)
 128   parent
 129   (definitions (make-hash-table :test 'equal)))
 130
 131 (defstruct param
 132   name
 133   string)
 134
 135 ;; Clark calls this structure "RefPattern"
 136 (defstruct (definition (:conc-name "DEFN-"))
 137   name
 138   combine-method
 139   head-p
 140   redefinition
 141   child)
 142
 143
 144 ;;;; parser
 145
 146 (defvar *rng-namespace* "http://relaxng.org/ns/structure/1.0")
 147
 148 (defun skip-foreign* (source)
 149   (loop
 150     (case (klacks:peek-next source)
 151       (:start-element (skip-foreign source))
 152       (:end-element (return)))))
 153
 154 (defun skip-to-native (source)
 155   (loop
 156     (case (klacks:peek source)
 157       (:start-element
 158         (when (equal (klacks:current-uri source) *rng-namespace*)
 159           (return))
 160         (klacks:serialize-element source nil))
 161       (:end-element (return)))
 162     (klacks:consume source)))
 163
 164 (defun consume-and-skip-to-native (source)
 165   (klacks:consume source)
 166   (skip-to-native source))
 167
 168 (defun skip-foreign (source)
 169   (when (equal (klacks:current-uri source) *rng-namespace*)
 170     (rng-error source
 171                "invalid schema: ~A not allowed here"
 172                (klacks:current-lname source)))
 173   (klacks:serialize-element source nil))
 174
 175 (defun attribute (lname attrs)
 176   (let ((a (sax:find-attribute-ns "" lname attrs)))
 177     (if a
 178         (sax:attribute-value a)
 179         nil)))
 180
 181 (defparameter *whitespace*
 182     (format nil "~C~C~C~C"
 183             (code-char 9)
 184             (code-char 32)
 185             (code-char 13)
 186             (code-char 10)))
 187
 188 (defun ntc (lname source-or-attrs)
 189   ;; used for (n)ame, (t)ype, and (c)ombine, this also strings whitespace
 190   (let* ((attrs
 191           (if (listp source-or-attrs)
 192               source-or-attrs
 193               (klacks:list-attributes source-or-attrs)))
 194          (a (sax:find-attribute-ns "" lname attrs)))
 195     (if a
 196         (string-trim *whitespace* (sax:attribute-value a))
 197         nil)))
 198
 199 (defmacro with-library-and-ns (attrs &body body)
 200   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 201
 202 (defun invoke-with-library-and-ns (fn attrs)
 203   (let* ((dl (attribute "datatypeLibrary" attrs))
 204          (ns (attribute "ns" attrs))
 205          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 206          (*namespace-uri* (or ns *namespace-uri*)))
 207     (funcall fn)))
 208
 209 (defun p/pattern (source)
 210   (let* ((lname (klacks:current-lname source))
 211          (attrs (klacks:list-attributes source)))
 212     (with-library-and-ns attrs
 213       (case (find-symbol lname :keyword)
 214         (:|element|     (p/element source (ntc "name" attrs)))
 215         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 216         (:|group|       (p/combination #'groupify source))
 217         (:|interleave|  (p/combination #'interleave-ify source))
 218         (:|choice|      (p/combination #'choice-ify source))
 219         (:|optional|    (p/optional source))
 220         (:|zeroOrMore|  (p/zero-or-more source))
 221         (:|oneOrMore|   (p/one-or-more source))
 222         (:|list|        (p/list source))
 223         (:|mixed|       (p/mixed source))
 224         (:|ref|         (p/ref source))
 225         (:|parentRef|   (p/parent-ref source))
 226         (:|empty|       (p/empty source))
 227         (:|text|        (p/text source))
 228         (:|value|       (p/value source))
 229         (:|data|        (p/data source))
 230         (:|notAllowed|  (p/not-allowed source))
 231         (:|externalRef| (p/external-ref source))
 232         (:|grammar|     (p/grammar source))
 233         (t (skip-foreign source))))))
 234
 235 (defun p/pattern+ (source)
 236   (let ((children nil))
 237     (loop
 238       (case (klacks:peek source)
 239         (:start-element
 240           (let ((p (p/pattern source))) (when p (push p children))))
 241         (:end-element
 242           (return))
 243         (t
 244           (klacks:consume source))))
 245     (unless children
 246       (rng-error source "empty element"))
 247     (nreverse children)))
 248
 249 (defun p/pattern? (source)
 250   (let ((result nil))
 251     (loop
 252       (skip-to-native source)
 253       (case (klacks:peek source)
 254         (:start-element
 255           (when result
 256             (rng-error source "at most one pattern expected here"))
 257           (setf result (p/pattern source)))
 258         (:end-element
 259           (return))
 260         (t
 261           (klacks:consume source))))
 262     result))
 263
 264 (defun p/element (source name)
 265   (klacks:expecting-element (source "element")
 266     (let ((result (make-element)))
 267       (consume-and-skip-to-native source)
 268       (if name
 269           (setf (pattern-name result) (destructure-name source name))
 270           (setf (pattern-name result) (p/name-class source)))
 271       (skip-to-native source)
 272       (setf (pattern-child result) (groupify (p/pattern+ source)))
 273       result)))
 274
 275 (defvar *attribute-namespace-p* nil)
 276
 277 (defun p/attribute (source name)
 278   (klacks:expecting-element (source "attribute")
 279     (let ((result (make-attribute)))
 280       (consume-and-skip-to-native source)
 281       (if name
 282           (setf (pattern-name result)
 283                 (let ((*namespace-uri* ""))
 284                   (destructure-name source name)))
 285           (setf (pattern-name result)
 286                 (let ((*attribute-namespace-p* t))
 287                   (p/name-class source))))
 288       (skip-to-native source)
 289       (setf (pattern-child result)
 290             (or (p/pattern? source) (make-text)))
 291       result)))
 292
 293 (defun p/combination (zipper source)
 294   (klacks:expecting-element (source)
 295     (consume-and-skip-to-native source)
 296     (funcall zipper (p/pattern+ source))))
 297
 298 (defun p/one-or-more (source)
 299   (klacks:expecting-element (source "oneOrMore")
 300     (consume-and-skip-to-native source)
 301     (let ((children (p/pattern+ source)))
 302       (make-one-or-more (groupify children)))))
 303
 304 (defun p/zero-or-more (source)
 305   (klacks:expecting-element (source "zeroOrMore")
 306     (consume-and-skip-to-native source)
 307     (let ((children (p/pattern+ source)))
 308       (make-choice (make-one-or-more (groupify children))
 309                    (make-empty)))))
 310
 311 (defun p/optional (source)
 312   (klacks:expecting-element (source "optional")
 313     (consume-and-skip-to-native source)
 314     (let ((children (p/pattern+ source)))
 315       (make-choice (groupify children) (make-empty)))))
 316
 317 (defun p/list (source)
 318   (klacks:expecting-element (source "list")
 319     (consume-and-skip-to-native source)
 320     (let ((children (p/pattern+ source)))
 321       (make-list-pattern (groupify children)))))
 322
 323 (defun p/mixed (source)
 324   (klacks:expecting-element (source "mixed")
 325     (consume-and-skip-to-native source)
 326     (let ((children (p/pattern+ source)))
 327       (make-interleave (groupify children) (make-text)))))
 328
 329 (defun p/ref (source)
 330   (klacks:expecting-element (source "ref")
 331     (prog1
 332         (let* ((name (ntc "name" source))
 333                (pdefinition
 334                 (or (find-definition name)
 335                     (setf (find-definition name)
 336                           (make-definition :name name :child nil)))))
 337           (make-ref pdefinition))
 338       (skip-foreign* source))))
 339
 340 (defun p/parent-ref (source)
 341   (klacks:expecting-element (source "parentRef")
 342     (prog1
 343         (let* ((name (ntc "name" source))
 344                (grammar (grammar-parent *grammar*))
 345                (pdefinition
 346                 (or (find-definition name grammar)
 347                     (setf (find-definition name grammar)
 348                           (make-definition :name name :child nil)))))
 349           (make-ref pdefinition))
 350       (skip-foreign* source))))
 351
 352 (defun p/empty (source)
 353   (klacks:expecting-element (source "empty")
 354     (skip-foreign* source)
 355     (make-empty)))
 356
 357 (defun p/text (source)
 358   (klacks:expecting-element (source "text")
 359     (skip-foreign* source)
 360     (make-text)))
 361
 362 (defun consume-and-parse-characters (source)
 363   ;; fixme
 364   (let ((tmp ""))
 365     (loop
 366       (multiple-value-bind (key data) (klacks:peek-next source)
 367         (case key
 368           (:characters
 369             (setf tmp (concatenate 'string tmp data)))
 370           (:end-element (return)))))
 371     tmp))
 372
 373 (defun p/value (source)
 374   (klacks:expecting-element (source "value")
 375     (let* ((type (ntc "type" source))
 376            (string (consume-and-parse-characters source))
 377            (ns *namespace-uri*)
 378            (dl *datatype-library*))
 379       (unless type
 380         (setf type "token")
 381         (setf dl ""))
 382       (make-value :string string :type type :ns ns :datatype-library dl))))
 383
 384 (defun p/data (source)
 385   (klacks:expecting-element (source "data")
 386     (let* ((type (ntc "type" source))
 387            (result (make-data :type type
 388                               :datatype-library *datatype-library*
 389                              ))
 390            (params '()))
 391       (loop
 392         (multiple-value-bind (key uri lname)
 393             (klacks:peek-next source)
 394           uri
 395           (case key
 396             (:start-element
 397               (case (find-symbol lname :keyword)
 398                 (:|param| (push (p/param source) params))
 399                 (:|except|
 400                   (setf (pattern-except result) (p/except-pattern source))
 401                   (skip-to-native source)
 402                   (return))
 403                 (t (skip-foreign source))))
 404             (:end-element
 405               (return)))))
 406       (setf (pattern-params result) (nreverse params))
 407       result)))
 408
 409 (defun p/param (source)
 410   (klacks:expecting-element (source "param")
 411     (let ((name (ntc "name" source))
 412           (string (consume-and-parse-characters source)))
 413       (make-param :name name :string string))))
 414
 415 (defun p/except-pattern (source)
 416   (klacks:expecting-element (source "except")
 417     (with-library-and-ns (klacks:list-attributes source)
 418       (klacks:consume source)
 419       (choice-ify (p/pattern+ source)))))
 420
 421 (defun p/not-allowed (source)
 422   (klacks:expecting-element (source "notAllowed")
 423     (consume-and-skip-to-native source)
 424     (make-not-allowed)))
 425
 426 (defun safe-parse-uri (source str &optional base)
 427   (when (zerop (length str))
 428     (rng-error source "missing URI"))
 429   (handler-case
 430       (if base
 431           (puri:merge-uris str base)
 432           (puri:parse-uri str))
 433     (puri:uri-parse-error ()
 434       (rng-error source "invalid URI: ~A" str))))
 435
 436 (defun p/external-ref (source)
 437   (klacks:expecting-element (source "externalRef")
 438     (let* ((href
 439             (escape-uri (attribute "href" (klacks:list-attributes source))))
 440            (base (klacks:current-xml-base source))
 441            (uri (safe-parse-uri source href base)))
 442       (when (find uri *include-uri-stack* :test #'puri:uri=)
 443         (rng-error source "looping include"))
 444       (prog1
 445           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 446                  (xstream
 447                   (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 448             (klacks:with-open-source (source (cxml:make-source xstream))
 449               (invoke-with-klacks-handler
 450                (lambda ()
 451                  (klacks:find-event source :start-element)
 452                  (let ((*datatype-library* ""))
 453                    (p/pattern source)))
 454                source)))
 455         (skip-foreign* source)))))
 456
 457 (defun p/grammar (source &optional grammar)
 458   (klacks:expecting-element (source "grammar")
 459     (consume-and-skip-to-native source)
 460     (let ((*grammar* (or grammar (make-grammar *grammar*))))
 461       (process-grammar-content* source)
 462       (unless (grammar-start *grammar*)
 463         (rng-error source "no <start> in grammar"))
 464       (check-pattern-definitions source *grammar*)
 465       (defn-child (grammar-start *grammar*)))))
 466
 467 (defvar *include-start*)
 468 (defvar *include-definitions*)
 469
 470 (defun process-grammar-content* (source &key disallow-include)
 471   (loop
 472     (multiple-value-bind (key uri lname) (klacks:peek source)
 473       uri
 474       (case key
 475         (:start-element
 476           (with-library-and-ns (klacks:list-attributes source)
 477             (case (find-symbol lname :keyword)
 478               (:|start| (process-start source))
 479               (:|define| (process-define source))
 480               (:|div| (process-div source))
 481               (:|include|
 482                 (when disallow-include
 483                   (rng-error source "nested include not permitted"))
 484                 (process-include source))
 485               (t
 486                 (skip-foreign source)))))
 487         (:end-element
 488           (return))))
 489     (klacks:consume source)))
 490
 491 (defun process-start (source)
 492   (klacks:expecting-element (source "start")
 493     (let* ((combine0 (ntc "combine" source))
 494            (combine
 495             (when combine0
 496               (find-symbol (string-upcase combine0) :keyword)))
 497            (child
 498             (progn
 499               (consume-and-skip-to-native source)
 500               (p/pattern source)))
 501            (pdefinition (grammar-start *grammar*)))
 502       (skip-foreign* source)
 503       ;; fixme: shared code with process-define
 504       (unless pdefinition
 505         (setf pdefinition (make-definition :name :start :child nil))
 506         (setf (grammar-start *grammar*) pdefinition))
 507       (when *include-body-p*
 508         (setf *include-start* pdefinition))
 509       (cond
 510         ((defn-child pdefinition)
 511          (ecase (defn-redefinition pdefinition)
 512            (:not-being-redefined
 513              (when (and combine
 514                         (defn-combine-method pdefinition)
 515                         (not (eq combine
 516                                  (defn-combine-method pdefinition))))
 517                (rng-error source "conflicting combine values for <start>"))
 518              (unless combine
 519                (when (defn-head-p pdefinition)
 520                  (rng-error source "multiple definitions for <start>"))
 521                (setf (defn-head-p pdefinition) t))
 522              (unless (defn-combine-method pdefinition)
 523                (setf (defn-combine-method pdefinition) combine))
 524              (setf (defn-child pdefinition)
 525                    (case (defn-combine-method pdefinition)
 526                      (:choice
 527                        (make-choice (defn-child pdefinition) child))
 528                      (:interleave
 529                        (make-interleave (defn-child pdefinition) child)))))
 530            (:being-redefined-and-no-original
 531              (setf (defn-redefinition pdefinition)
 532                    :being-redefined-and-original))
 533            (:being-redefined-and-original)))
 534         (t
 535           (setf (defn-child pdefinition) child)
 536           (setf (defn-combine-method pdefinition) combine)
 537           (setf (defn-head-p pdefinition) (null combine))
 538           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
 539
 540 (defun zip (constructor children)
 541   (cond
 542     ((null children)
 543       (rng-error nil "empty choice?"))
 544     ((null (cdr children))
 545       (car children))
 546     (t
 547       (destructuring-bind (a b &rest rest)
 548           children
 549         (zip constructor (cons (funcall constructor a b) rest))))))
 550
 551 (defun choice-ify (children) (zip #'make-choice children))
 552 (defun groupify (children) (zip #'make-group children))
 553 (defun interleave-ify (children) (zip #'make-interleave children))
 554
 555 (defun find-definition (name &optional (grammar *grammar*))
 556   (gethash name (grammar-definitions grammar)))
 557
 558 (defun (setf find-definition) (newval name &optional (grammar *grammar*))
 559   (setf (gethash name (grammar-definitions grammar)) newval))
 560
 561 (defun process-define (source)
 562   (klacks:expecting-element (source "define")
 563     (let* ((name (ntc "name" source))
 564            (combine0 (ntc "combine" source))
 565            (combine (when combine0
 566                       (find-symbol (string-upcase combine0) :keyword)))
 567            (child (groupify
 568                    (progn
 569                      (consume-and-skip-to-native source)
 570                      (p/pattern+ source))))
 571            (pdefinition (find-definition name)))
 572       (unless pdefinition
 573         (setf pdefinition (make-definition :name name :child nil))
 574         (setf (find-definition name) pdefinition))
 575       (when *include-body-p*
 576         (push pdefinition *include-definitions*))
 577       (cond
 578         ((defn-child pdefinition)
 579           (case (defn-redefinition pdefinition)
 580             (:not-being-redefined
 581               (when (and combine
 582                          (defn-combine-method pdefinition)
 583                          (not (eq combine
 584                                   (defn-combine-method pdefinition))))
 585                 (rng-error source "conflicting combine values for ~A" name))
 586               (unless combine
 587                 (when (defn-head-p pdefinition)
 588                   (rng-error source "multiple definitions for ~A" name))
 589                 (setf (defn-head-p pdefinition) t))
 590               (unless (defn-combine-method pdefinition)
 591                 (setf (defn-combine-method pdefinition) combine))
 592               (setf (defn-child pdefinition)
 593                     (case (defn-combine-method pdefinition)
 594                       (:choice
 595                         (make-choice (defn-child pdefinition) child))
 596                       (:interleave
 597                         (make-interleave (defn-child pdefinition) child)))))
 598             (:being-redefined-and-no-original
 599               (setf (defn-redefinition pdefinition)
 600                     :being-redefined-and-original))
 601             (:being-redefined-and-original)))
 602         (t
 603           (setf (defn-child pdefinition) child)
 604           (setf (defn-combine-method pdefinition) combine)
 605           (setf (defn-head-p pdefinition) (null combine))
 606           (setf (defn-redefinition pdefinition) :not-being-redefined))))))
 607
 608 (defun process-div (source)
 609   (klacks:expecting-element (source "div")
 610     (consume-and-skip-to-native source)
 611     (process-grammar-content* source)))
 612
 613 (defun reset-definition-for-include (defn)
 614   (setf (defn-combine-method defn) nil)
 615   (setf (defn-redefinition defn) :being-redefined-and-no-original)
 616   (setf (defn-head-p defn) nil))
 617
 618 (defun restore-definition (defn original)
 619   (setf (defn-combine-method defn) (defn-combine-method original))
 620   (setf (defn-redefinition defn) (defn-redefinition original))
 621   (setf (defn-head-p defn) (defn-head-p original)))
 622
 623 (defun process-include (source)
 624   (klacks:expecting-element (source "include")
 625     (let* ((href
 626             (escape-uri (attribute "href" (klacks:list-attributes source))))
 627            (base (klacks:current-xml-base source))
 628            (uri (safe-parse-uri source href base))
 629            (*include-start* nil)
 630            (*include-definitions* '()))
 631       (consume-and-skip-to-native source)
 632       (let ((*include-body-p* t))
 633         (process-grammar-content* source :disallow-include t))
 634       (let ((tmp-start
 635              (when *include-start*
 636                (prog1
 637                    (copy-structure *include-start*)
 638                  (reset-definition-for-include *include-start*))))
 639             (tmp-defns
 640              (loop
 641                  for defn in *include-definitions*
 642                  collect
 643                    (prog1
 644                        (copy-structure defn)
 645                      (reset-definition-for-include defn)))))
 646         (when (find uri *include-uri-stack* :test #'puri:uri=)
 647           (rng-error source "looping include"))
 648         (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 649                (xstream (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 650           (klacks:with-open-source (source (cxml:make-source xstream))
 651             (invoke-with-klacks-handler
 652              (lambda ()
 653                (klacks:find-event source :start-element)
 654                (let ((*datatype-library* ""))
 655                  (p/grammar source *grammar*)))
 656              source))
 657           (check-pattern-definitions source *grammar*)
 658           (when tmp-start
 659             (restore-definition *include-start* tmp-start))
 660           (dolist (copy tmp-defns)
 661             (let ((defn (gethash (defn-name copy)
 662                                  (grammar-definitions *grammar*))))
 663               (restore-definition defn copy)))
 664           (defn-child (grammar-start *grammar*)))))))
 665
 666 (defun check-pattern-definitions (source grammar)
 667   (when (eq (defn-redefinition (grammar-start grammar))
 668             :being-redefined-and-no-original)
 669     (rng-error source "start not found in redefinition of grammar"))
 670   (loop for defn being each hash-value in (grammar-definitions grammar) do
 671         (when (eq (defn-redefinition defn) :being-redefined-and-no-original)
 672           (rng-error source "redefinition not found in grammar"))
 673         (unless (defn-child defn)
 674           (rng-error source "unresolved reference to ~A" (defn-name defn)))))
 675
 676 (defvar *any-name-allowed-p* t)
 677 (defvar *ns-name-allowed-p* t)
 678
 679 (defun destructure-name (source qname)
 680   (multiple-value-bind (uri lname)
 681       (klacks:decode-qname qname source)
 682     (setf uri (or uri *namespace-uri*))
 683     (when (and *attribute-namespace-p*
 684                (or (and (equal lname "xmlns") (equal uri ""))
 685                    (equal uri "http://www.w3.org/2000/xmlns")))
 686       (rng-error source "namespace attribute not permitted"))
 687     (list :name lname uri)))
 688
 689 (defun p/name-class (source)
 690   (klacks:expecting-element (source)
 691     (with-library-and-ns (klacks:list-attributes source)
 692       (case (find-symbol (klacks:current-lname source) :keyword)
 693         (:|name|
 694           (let ((qname (string-trim *whitespace*
 695                                     (consume-and-parse-characters source))))
 696             (destructure-name source qname)))
 697         (:|anyName|
 698           (unless *any-name-allowed-p*
 699             (rng-error source "anyname now permitted in except"))
 700           (klacks:consume source)
 701           (prog1
 702               (let ((*any-name-allowed-p* nil))
 703                 (cons :any (p/except-name-class? source)))
 704             (skip-to-native source)))
 705         (:|nsName|
 706           (unless *ns-name-allowed-p*
 707             (rng-error source "nsname now permitted in except"))
 708           (let ((uri *namespace-uri*)
 709                 (*any-name-allowed-p* nil)
 710                 (*ns-name-allowed-p* nil))
 711             (when (and *attribute-namespace-p*
 712                        (equal uri "http://www.w3.org/2000/xmlns"))
 713               (rng-error source "namespace attribute not permitted"))
 714             (klacks:consume source)
 715             (prog1
 716                 (list :nsname uri (p/except-name-class? source))
 717               (skip-to-native source))))
 718         (:|choice|
 719           (klacks:consume source)
 720           (cons :choice (p/name-class* source)))
 721         (t
 722           (rng-error source "invalid child in except"))))))
 723
 724 (defun p/name-class* (source)
 725   (let ((results nil))
 726     (loop
 727       (skip-to-native source)
 728       (case (klacks:peek source)
 729         (:start-element (push (p/name-class source) results))
 730         (:end-element (return)))
 731       (klacks:consume source))
 732     (nreverse results)))
 733
 734 (defun p/except-name-class? (source)
 735   (skip-to-native source)
 736   (multiple-value-bind (key uri lname)
 737       (klacks:peek source)
 738     uri
 739     (if (and (eq key :start-element)
 740              (string= (find-symbol lname :keyword) "except"))
 741         (p/except-name-class source)
 742         nil)))
 743
 744 (defun p/except-name-class (source)
 745   (klacks:expecting-element (source "except")
 746     (with-library-and-ns (klacks:list-attributes source)
 747       (klacks:consume source)
 748       (cons :except (p/name-class* source)))))
 749
 750 (defun escape-uri (string)
 751   (with-output-to-string (out)
 752     (loop for c across (cxml::rod-to-utf8-string string) do
 753           (let ((code (char-code c)))
 754             ;; http://www.w3.org/TR/xlink/#link-locators
 755             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
 756                 (format out "%~2,'0X" code)
 757                 (write-char c out))))))
 758
 759
 760 ;;;; unparsing
 761
 762 (defvar *definitions-to-names*)
 763 (defvar *seen-names*)
 764
 765 (defun serialization-name (defn)
 766   (or (gethash defn *definitions-to-names*)
 767       (setf (gethash defn *definitions-to-names*)
 768             (let ((name (if (gethash (defn-name defn) *seen-names*)
 769                             (format nil "~A-~D"
 770                                     (defn-name defn)
 771                                     (hash-table-count *seen-names*))
 772                             (defn-name defn))))
 773               (setf (gethash name *seen-names*) defn)
 774               name))))
 775
 776 (defun serialize-grammar (grammar sink)
 777   (cxml:with-xml-output sink
 778     (let ((*definitions-to-names* (make-hash-table))
 779           (*seen-names* (make-hash-table :test 'equal)))
 780       (cxml:with-element "grammar"
 781         (cxml:with-element "start"
 782           (serialize-pattern grammar))
 783         (loop for defn being each hash-key in *definitions-to-names* do
 784               (serialize-definition defn))))))
 785
 786 (defun serialize-pattern (pattern)
 787   (etypecase pattern
 788     (element
 789       (cxml:with-element "element"
 790         (serialize-name (pattern-name pattern))
 791         (serialize-pattern (pattern-child pattern))))
 792     (attribute
 793       (cxml:with-element "attribute"
 794         (serialize-name (pattern-name pattern))
 795         (serialize-pattern (pattern-child pattern))))
 796     (%combination
 797       (cxml:with-element
 798           (etypecase pattern
 799             (group "group")
 800             (interleave "interleave")
 801             (choice "choice"))
 802         (serialize-pattern (pattern-a pattern))
 803         (serialize-pattern (pattern-b pattern))))
 804     (one-or-more
 805       (cxml:with-element "oneOrmore"
 806         (serialize-pattern (pattern-child pattern))))
 807     (list-pattern
 808       (cxml:with-element "list"
 809         (serialize-pattern (pattern-child pattern))))
 810     (ref
 811       (cxml:with-element "ref"
 812         (cxml:attribute "name" (serialization-name (pattern-target pattern)))))
 813     (empty
 814       (cxml:with-element "empty"))
 815     (not-allowed
 816       (cxml:with-element "notAllowed"))
 817     (text
 818       (cxml:with-element "text"))
 819     (value
 820       (cxml:with-element "value"
 821         (cxml:attribute "datatype-library"
 822                         (pattern-datatype-library pattern))
 823         (cxml:attribute "type" (pattern-type pattern))
 824         (cxml:attribute "ns" (pattern-ns pattern))
 825         (cxml:text (pattern-string pattern))))
 826     (data
 827       (cxml:with-element "value"
 828         (cxml:attribute "datatype-library"
 829                         (pattern-datatype-library pattern))
 830         (cxml:attribute "type" (pattern-type pattern))
 831         (dolist (param (pattern-params pattern))
 832           (cxml:with-element "param"
 833             (cxml:attribute "name" (param-name param))
 834             (cxml:text (param-string param))))
 835         (when (pattern-except pattern)
 836           (cxml:with-element "except"
 837             (serialize-pattern (pattern-except pattern))))))))
 838
 839 (defun serialize-definition (defn)
 840   (cxml:with-element "define"
 841     (cxml:attribute "name" (serialization-name defn))
 842     (serialize-pattern (defn-child defn))))
 843
 844 (defun serialize-name (name)
 845   (ecase (car name)
 846     (:name
 847       (cxml:with-element "name"
 848         (destructuring-bind (lname uri)
 849             (cdr name)
 850           (cxml:attribute "ns" uri)
 851           (cxml:text lname))))
 852     (:any
 853       (cxml:with-element "anyName"
 854         (when (cdr name)
 855           (serialize-except-name name))))
 856     (:nsname
 857       (cxml:with-element "anyName"
 858         (destructuring-bind (uri except)
 859             (cdr name)
 860           (cxml:attribute "ns" uri)
 861           (when except
 862             (serialize-except-name name)))))
 863     (:choice
 864       (cxml:with-element "choice"
 865         (mapc #'serialize-name (cdr name))))))
 866
 867 (defun serialize-except-name (spec)
 868   (cxml:with-element "except"
 869     (mapc #'serialize-name (cdr spec))))
 870
 871
 872 ;;;; simplification
 873
 874 ;;; 4.1 Annotations
 875 ;;;   Foreign attributes and elements are removed implicitly while parsing.
 876
 877 ;;; 4.2 Whitespace
 878 ;;;   All character data is discarded while parsing (which can only be
 879 ;;;   whitespace after validation).
 880 ;;;
 881 ;;;   Whitespace in name, type, and combine attributes is stripped while
 882 ;;;   parsing.  Ditto for <name/>.
 883
 884 ;;; 4.3. datatypeLibrary attribute
 885 ;;;   Escaping is done by p/pattern.
 886 ;;;   Attribute value defaulting is done using *datatype-library*; only
 887 ;;;   p/data and p/value record the computed value.
 888
 889 ;;; 4.4. type attribute of value element
 890 ;;;   Done by p/value.
 891
 892 ;;; 4.5. href attribute
 893 ;;;   Escaping is done by process-include and p/external-ref.
 894 ;;;
 895 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
 896 ;;;   but that requires xstream hacking.
 897
 898 ;;; 4.6. externalRef element
 899 ;;;   Done by p/external-ref.
 900
 901 ;;; 4.7. include element
 902 ;;;   Done by process-include.
 903
 904 ;;; 4.8. name attribute of element and attribute elements
 905 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
 906 ;;;    p/attribute.
 907
 908 ;;; 4.9. ns attribute
 909 ;;;    done by p/name-class, p/value, p/element, p/attribute
 910
 911 ;;; 4.10. QNames
 912 ;;;    done by p/name-class
 913
 914 ;;; 4.11. div element
 915 ;;;    Legen wir gar nicht erst an.
 916
 917 ;;; 4.12. 4.13 4.14 4.15
 918 ;;;    beim anlegen
 919
 920 ;;; 4.16
 921 ;;;    p/name-class
 922 ;;;    -- ausser der sache mit den datentypen
 923
 924 ;;; 4.17, 4.18, 4.19
 925 ;;;    Ueber die Grammar-und Definition Objekte, wie von James Clark
 926 ;;;    beschrieben.
 927 ;;;
 928 ;;;    Dabei werden keine Umbenennungen vorgenommen, weil Referenzierung
 929 ;;;    durch Aufbei der Graphenstruktur zwischen ref und Definition
 930 ;;;    erfolgt und Namen dann bereits aufgeloest sind.  Wir benennen
 931 ;;;    dafuer beim Serialisieren um.
 932
 933 (defmethod check-recursion ((pattern element) depth)
 934   (check-recursion (pattern-child pattern) (1+ depth)))
 935
 936 (defmethod check-recursion ((pattern ref) depth)
 937   (when (eql (pattern-crdepth pattern) depth)
 938     (rng-error nil "infinite recursion in ~A"
 939                (defn-name (pattern-target pattern))))
 940   (when (null (pattern-crdepth pattern))
 941     (setf (pattern-crdepth pattern) depth)
 942     (check-recursion (defn-child (pattern-target pattern)) depth)
 943     (setf (pattern-crdepth pattern) t)))
 944
 945 (defmethod check-recursion ((pattern %parent) depth)
 946   (check-recursion (pattern-child pattern) depth))
 947
 948 (defmethod check-recursion ((pattern %combination) depth)
 949   (check-recursion (pattern-a pattern) depth)
 950   (check-recursion (pattern-b pattern) depth))
 951
 952 (defmethod check-recursion ((pattern %leaf) depth)
 953   (declare (ignore depth)))
 954
 955
 956 ;;;; tests
 957
 958 (defun run-tests (&optional (p "/home/david/src/lisp/cxml-rng/spec-split/*"))
 959   (dribble "/home/david/src/lisp/cxml-rng/TEST" :if-exists :rename-and-delete)
 960   (let ((pass 0)
 961         (total 0)
 962         (*package* (find-package :cxml-rng)))
 963     (dolist (d (directory p))
 964       (let ((name (car (last (pathname-directory d)))))
 965         (when (parse-integer name :junk-allowed t)
 966           (incf total)
 967           (when (test1 d)
 968             (incf pass)))))
 969     (format t "Passed ~D/~D tests.~%" pass total))
 970   (dribble))
 971
 972 (defun run-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 973   (test1 (merge-pathnames (format nil "~3,'0D/" n) p)))
 974
 975 (defun parse-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 976   (let* ((*debug* t)
 977          (d (merge-pathnames (format nil "~3,'0D/" n) p))
 978          (i (merge-pathnames "i.rng" d))
 979          (c (merge-pathnames "c.rng" d))
 980          (rng (if (probe-file c) c i)))
 981     (format t "~A: " (car (last (pathname-directory d))))
 982     (print rng)
 983     (parse-relax-ng rng)))
 984
 985 (defun test1 (d)
 986   (let* ((i (merge-pathnames "i.rng" d))
 987          (c (merge-pathnames "c.rng" d)))
 988     (format t "~A: " (car (last (pathname-directory d))))
 989     (if (probe-file c)
 990         (handler-case
 991             (progn
 992               (parse-relax-ng c)
 993               (format t " PASS~%")
 994               t)
 995           (error (c)
 996             (format t " FAIL: ~A~%" c)
 997             nil))
 998         (handler-case
 999             (progn
1000               (parse-relax-ng i)
1001               (format t " FAIL: didn't detect invalid schema~%")
1002               nil)
1003           (rng-error (c)
1004             (format t " PASS: ~S~%" (type-of c))
1005             t)
1006           (error (c)
1007             (format t " FAIL: incorrect condition type: ~A~%" c)
1008             nil)))))