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
  32 (defvar *debug* nil)
  33
  34 (defun invoke-with-klacks-handler (fn source)
  35   (if *debug*
  36       (funcall fn)
  37       (handler-case
  38           (funcall fn)
  39         (cxml:xml-parse-error (c)
  40           (rng-error source "Cannot parse schema: ~A" c)))))
  41
  42 (defun parse-relax-ng (input &key entity-resolver)
  43   (klacks:with-open-source (source (cxml:make-source input))
  44     (invoke-with-klacks-handler
  45      (lambda ()
  46        (klacks:find-event source :start-element)
  47        (let ((*datatype-library* "")
  48              (*namespace-uri* "")
  49              (*entity-resolver* entity-resolver)
  50              (*external-href-stack* '())
  51              (*include-uri-stack* '()))
  52          (p/pattern source)))
  53       source)))
  54
  55
  56 ;;;; pattern structures
  57
  58 (defstruct pattern)
  59
  60 (defstruct (%parent (:include pattern) (:conc-name "PATTERN-"))
  61   child)
  62
  63 (defstruct (%named-pattern (:include %parent) (:conc-name "PATTERN-"))
  64   name)
  65 (defstruct (element (:include %named-pattern) (:conc-name "PATTERN-")))
  66 (defstruct (attribute (:include %named-pattern) (:conc-name "PATTERN-")))
  67
  68 (defstruct (%combination (:include pattern) (:conc-name "PATTERN-"))
  69   a b)
  70 (defstruct (group
  71             (:include %combination)
  72             (:constructor make-group (a b))))
  73 (defstruct (interleave
  74             (:include %combination)
  75             (:constructor make-interleave (a b))))
  76 (defstruct (choice
  77             (:include %combination)
  78             (:constructor make-choice (a b))))
  79
  80 (defstruct (one-or-more
  81             (:include %parent)
  82             (:constructor make-one-or-more (child))))
  83 (defstruct (list-pattern
  84             (:include %parent)
  85             (:constructor make-list-pattern (child))))
  86
  87 (defstruct (%ref (:include pattern) (:conc-name "PATTERN-"))
  88   ref-name)
  89 (defstruct (ref (:include %ref) (:conc-name "PATTERN-")))
  90 (defstruct (parent-ref (:include %ref) (:conc-name "PATTERN-")))
  91
  92 (defstruct (empty (:include pattern) (:conc-name "PATTERN-")))
  93 (defstruct (text (:include pattern) (:conc-name "PATTERN-")))
  94
  95 (defstruct (%typed-pattern (:include pattern) (:conc-name "PATTERN-"))
  96   datatype-library
  97   type)
  98
  99 (defstruct (value (:include %typed-pattern) (:conc-name "PATTERN-"))
 100   ns
 101   string)
 102
 103 (defstruct (data (:include %typed-pattern) (:conc-name "PATTERN-"))
 104   params
 105   except)
 106
 107 (defstruct (not-allowed (:include pattern) (:conc-name "PATTERN-")))
 108
 109 (defstruct (grammar (:include pattern) (:conc-name "PATTERN-"))
 110   content)
 111
 112
 113 ;;;; non-pattern
 114
 115 (defstruct param
 116   name
 117   string)
 118
 119 (defstruct start
 120   combine
 121   child)
 122
 123 (defstruct define
 124   name
 125   combine
 126   child)
 127
 128
 129 ;;;; parser
 130
 131 (defvar *rng-namespace* "http://relaxng.org/ns/structure/1.0")
 132
 133 (defun skip-foreign* (source)
 134   (loop
 135     (case (klacks:peek-next source)
 136       (:start-element (skip-foreign source))
 137       (:end-element (return)))))
 138
 139 (defun skip-to-native (source)
 140   (loop
 141     (case (klacks:peek source)
 142       (:start-element
 143         (when (equal (klacks:current-uri source) *rng-namespace*)
 144           (return))
 145         (klacks:serialize-element source nil))
 146       (:end-element (return)))
 147     (klacks:consume source)))
 148
 149 (defun consume-and-skip-to-native (source)
 150   (klacks:consume source)
 151   (skip-to-native source))
 152
 153 (defun skip-foreign (source)
 154   (when (equal (klacks:current-uri source) *rng-namespace*)
 155     (rng-error source
 156                "invalid schema: ~A not allowed here"
 157                (klacks:current-lname source)))
 158   (klacks:serialize-element source nil))
 159
 160 (defun attribute (lname attrs)
 161   (let ((a (sax:find-attribute-ns "" lname attrs)))
 162     (if a
 163         (sax:attribute-value a)
 164         nil)))
 165
 166 (defvar *whitespace*
 167     (format nil "~C~C~C"
 168             (code-char 9)
 169             (code-char 32)
 170             (code-char 13)
 171             (code-char 10)))
 172
 173 (defun ntc (lname source-or-attrs)
 174   ;; used for (n)ame, (t)ype, and (c)ombine, this also strings whitespace
 175   (let* ((attrs
 176           (if (listp source-or-attrs)
 177               source-or-attrs
 178               (klacks:list-attributes source-or-attrs)))
 179          (a (sax:find-attribute-ns "" lname attrs)))
 180     (if a
 181         (string-trim *whitespace* (sax:attribute-value a))
 182         nil)))
 183
 184 (defmacro with-library-and-ns (attrs &body body)
 185   `(invoke-with-library-and-ns (lambda () ,@body) ,attrs))
 186
 187 (defun invoke-with-library-and-ns (fn attrs)
 188   (let* ((dl (attribute "datatypeLibrary" attrs))
 189          (ns (attribute "ns" attrs))
 190          (*datatype-library* (if dl (escape-uri dl) *datatype-library*))
 191          (*namespace-uri* (or ns *namespace-uri*)))
 192     (funcall fn)))
 193
 194 (defun p/pattern (source)
 195   (let* ((lname (klacks:current-lname source))
 196          (attrs (klacks:list-attributes source)))
 197     (with-library-and-ns attrs
 198       (case (find-symbol lname :keyword)
 199         (:|element|     (p/element source (ntc "name" attrs)))
 200         (:|attribute|   (p/attribute source (ntc "name" attrs)))
 201         (:|group|       (p/combination #'groupify source))
 202         (:|interleave|  (p/combination #'interleave-ify source))
 203         (:|choice|      (p/combination #'choice-ify source))
 204         (:|optional|    (p/optional source))
 205         (:|zeroOrMore|  (p/zero-or-more source))
 206         (:|oneOrMore|   (p/one-or-more source))
 207         (:|list|        (p/list source))
 208         (:|mixed|       (p/mixed source))
 209         (:|ref|         (p/ref source))
 210         (:|parentRef|   (p/parent-ref source))
 211         (:|empty|       (p/empty source))
 212         (:|text|        (p/text source))
 213         (:|value|       (p/value source))
 214         (:|data|        (p/data source))
 215         (:|notAllowed|  (p/not-allowed source))
 216         (:|externalRef| (p/external-ref source))
 217         (:|grammar|     (p/grammar source))
 218         (t (skip-foreign source))))))
 219
 220 (defun p/pattern+ (source)
 221   (let ((children nil))
 222     (loop
 223       (case (klacks:peek source)
 224         (:start-element
 225           (let ((p (p/pattern source))) (when p (push p children))))
 226         (:end-element
 227           (return))
 228         (t
 229           (klacks:consume source))))
 230     (unless children
 231       (rng-error source "empty element"))
 232     (nreverse children)))
 233
 234 (defun p/pattern? (source)
 235   (let ((result nil))
 236     (loop
 237       (skip-to-native source)
 238       (case (klacks:peek source)
 239         (:start-element
 240           (when result
 241             (rng-error source "at most one pattern expected here"))
 242           (setf result (p/pattern source)))
 243         (:end-element
 244           (return))
 245         (t
 246           (klacks:consume source))))
 247     result))
 248
 249 (defun p/element (source name)
 250   (klacks:expecting-element (source "element")
 251     (let ((result (make-element)))
 252       (consume-and-skip-to-native source)
 253       (if name
 254           (setf (pattern-name result)
 255                 (list :name name :uri *namespace-uri*))
 256           (setf (pattern-name result) (p/name-class source)))
 257       (skip-to-native source)
 258       (setf (pattern-child result) (groupify (p/pattern+ source)))
 259       result)))
 260
 261 (defvar *attribute-namespace-p* nil)
 262
 263 (defun p/attribute (source name)
 264   (klacks:expecting-element (source "attribute")
 265     (let ((result (make-attribute)))
 266       (consume-and-skip-to-native source)
 267       (if name
 268           (setf (pattern-name result)
 269                 (list :name name :uri ""))
 270           (setf (pattern-name result)
 271                 (let ((*attribute-namespace-p* t))
 272                   (p/name-class source))))
 273       (skip-to-native source)
 274       (setf (pattern-child result)
 275             (or (p/pattern? source) (make-text)))
 276       result)))
 277
 278 (defun p/combination (zipper source)
 279   (klacks:expecting-element (source)
 280     (consume-and-skip-to-native source)
 281     (funcall zipper (p/pattern+ source))))
 282
 283 (defun p/one-or-more (source)
 284   (klacks:expecting-element (source "oneOrMore")
 285     (consume-and-skip-to-native source)
 286     (let ((children (p/pattern+ source)))
 287       (make-one-or-more (groupify children)))))
 288
 289 (defun p/zero-or-more (source)
 290   (klacks:expecting-element (source "zeroOrMore")
 291     (consume-and-skip-to-native source)
 292     (let ((children (p/pattern+ source)))
 293       (make-choice (make-one-or-more (groupify children))
 294                    (make-empty)))))
 295
 296 (defun p/optional (source)
 297   (klacks:expecting-element (source "optional")
 298     (consume-and-skip-to-native source)
 299     (let ((children (p/pattern+ source)))
 300       (make-choice (groupify children) (make-empty)))))
 301
 302 (defun p/list (source)
 303   (klacks:expecting-element (source "list")
 304     (consume-and-skip-to-native source)
 305     (let ((children (p/pattern+ source)))
 306       (make-list-pattern (groupify children)))))
 307
 308 (defun p/mixed (source)
 309   (klacks:expecting-element (source "mixed")
 310     (consume-and-skip-to-native source)
 311     (let ((children (p/pattern+ source)))
 312       (make-interleave (groupify children) (make-text)))))
 313
 314 (defun p/ref (source)
 315   (klacks:expecting-element (source "ref")
 316     (prog1
 317         (make-ref :ref-name (ntc "name" source))
 318       (skip-foreign* source))))
 319
 320 (defun p/parent-ref (source)
 321   (klacks:expecting-element (source "parentRef")
 322     (prog1
 323         (make-parent-ref :ref-name (ntc "name" source))
 324       (skip-foreign* source))))
 325
 326 (defun p/empty (source)
 327   (klacks:expecting-element (source "empty")
 328     (skip-foreign* source)
 329     (make-empty)))
 330
 331 (defun p/text (source)
 332   (klacks:expecting-element (source "text")
 333     (skip-foreign* source)
 334     (make-text)))
 335
 336 (defun consume-and-parse-characters (source)
 337   ;; fixme
 338   (let ((tmp ""))
 339     (loop
 340       (multiple-value-bind (key data) (klacks:peek-next source)
 341         (case key
 342           (:characters
 343             (setf tmp (concatenate 'string tmp data)))
 344           (:end-element (return)))))
 345     tmp))
 346
 347 (defun p/value (source)
 348   (klacks:expecting-element (source "value")
 349     (let* ((type (ntc "type" source))
 350            (string (consume-and-parse-characters source))
 351            (ns *namespace-uri*)
 352            (dl *datatype-library*))
 353       (unless type
 354         (setf type "token")
 355         (setf dl ""))
 356       (make-value :string string :type type :ns ns :datatype-library dl))))
 357
 358 (defun p/data (source)
 359   (klacks:expecting-element (source "data")
 360     (let* ((type (ntc "type" source))
 361            (result (make-data :type type
 362                               :datatype-library *datatype-library*
 363                              ))
 364            (params '()))
 365       (loop
 366         (multiple-value-bind (key uri lname)
 367             (klacks:peek-next source)
 368           uri
 369           (case key
 370             (:start-element
 371               (case (find-symbol lname :keyword)
 372                 (:|param| (push (p/param source) params))
 373                 (:|except|
 374                   (setf (pattern-except result) (p/except-pattern source))
 375                   (skip-to-native source)
 376                   (return))
 377                 (t (skip-foreign source))))
 378             (:end-element
 379               (return)))))
 380       (setf (pattern-params result) (nreverse params))
 381       result)))
 382
 383 (defun p/param (source)
 384   (klacks:expecting-element (source "param")
 385     (let ((name (ntc "name" source))
 386           (string (consume-and-parse-characters source)))
 387       (make-param :name name :string string))))
 388
 389 (defun p/except-pattern (source)
 390   (klacks:expecting-element (source "except")
 391     (with-library-and-ns (klacks:list-attributes source)
 392       (klacks:consume source)
 393       (choice-ify (p/pattern+ source)))))
 394
 395 (defun p/not-allowed (source)
 396   (klacks:expecting-element (source "notAllowed")
 397     (consume-and-skip-to-native source)
 398     (make-not-allowed)))
 399
 400 (defun safe-parse-uri (source str &optional base)
 401   (when (zerop (length str))
 402     (rng-error source "missing URI"))
 403   (handler-case
 404       (if base
 405           (puri:merge-uris str base)
 406           (puri:parse-uri str))
 407     (puri:uri-parse-error ()
 408       (rng-error source "invalid URI: ~A" str))))
 409
 410 (defun p/external-ref (source)
 411   (klacks:expecting-element (source "externalRef")
 412     (let* ((href
 413             (escape-uri (attribute "href" (klacks:list-attributes source))))
 414            (base (klacks:current-xml-base source))
 415            (uri (safe-parse-uri source href base)))
 416       (when (find uri *include-uri-stack* :test #'puri:uri=)
 417         (rng-error source "looping include"))
 418       (prog1
 419           (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 420                  (xstream
 421                   (cxml::xstream-open-extid* *entity-resolver* nil uri)))
 422             (klacks:with-open-source (source (cxml:make-source xstream))
 423               (invoke-with-klacks-handler
 424                (lambda ()
 425                  (klacks:find-event source :start-element)
 426                  (let ((*datatype-library* ""))
 427                    (p/pattern source)))
 428                source)))
 429         (skip-foreign* source)))))
 430
 431 (defun p/grammar (source)
 432   (klacks:expecting-element (source "grammar")
 433     (consume-and-skip-to-native source)
 434     (make-grammar :content (p/grammar-content* source))))
 435
 436 (defun p/grammar-content* (source &key disallow-include)
 437   (loop
 438       append
 439         (prog1
 440             (multiple-value-bind (key uri lname) (klacks:peek source)
 441               uri
 442               (case key
 443                 (:start-element
 444                   (with-library-and-ns (klacks:list-attributes source)
 445                     (case (find-symbol lname :keyword)
 446                       (:|start| (list (p/start source)))
 447                       (:|define| (list (p/define source)))
 448                       (:|div| (p/div source))
 449                       (:|include|
 450                         (when disallow-include
 451                           (rng-error source "nested include not permitted"))
 452                         (p/include source))
 453                       (t
 454                         (skip-foreign source)
 455                         nil))))
 456                 (:end-element
 457                   (loop-finish))))
 458           (klacks:consume source))))
 459
 460 (defun p/start (source)
 461   (klacks:expecting-element (source "start")
 462     (let ((combine (ntc "combine" source))
 463           (child
 464            (progn
 465              (consume-and-skip-to-native source)
 466              (p/pattern source))))
 467       (skip-foreign* source)
 468       (make-start :combine (find-symbol (string-upcase combine) :keyword)
 469                   :child child))))
 470
 471 (defun zip (constructor children)
 472   (cond
 473     ((null children)
 474       (rng-error nil "empty choice?"))
 475     ((null (cdr children))
 476       (car children))
 477     (t
 478       (destructuring-bind (a b &rest rest)
 479           children
 480         (zip constructor (cons (funcall constructor a b) rest))))))
 481
 482 (defun choice-ify (children) (zip #'make-choice children))
 483 (defun groupify (children) (zip #'make-group children))
 484 (defun interleave-ify (children) (zip #'make-interleave children))
 485
 486 (defun p/define (source)
 487   (klacks:expecting-element (source "define")
 488     (let ((name (ntc "name" source))
 489           (combine (ntc "combine" source))
 490           (children (progn
 491                       (consume-and-skip-to-native source)
 492                       (p/pattern+ source))))
 493       (make-define :name name
 494                    :combine (find-symbol (string-upcase combine) :keyword)
 495                    :child (groupify children)))))
 496
 497 (defun p/div (source)
 498   (klacks:expecting-element (source "div")
 499     (consume-and-skip-to-native source)
 500     (p/grammar-content* source)))
 501
 502 (defun p/include (source)
 503   (klacks:expecting-element (source "include")
 504     (let* ((href
 505             (escape-uri (attribute "href" (klacks:list-attributes source))))
 506            (base (klacks:current-xml-base source))
 507            (uri (safe-parse-uri source href base))
 508            (include-content
 509             (progn
 510               (consume-and-skip-to-native source)
 511               (p/grammar-content* source :disallow-include t))))
 512       (when (find uri *include-uri-stack* :test #'puri:uri=)
 513         (rng-error source "looping include"))
 514       (let* ((*include-uri-stack* (cons uri *include-uri-stack*))
 515              (xstream (cxml::xstream-open-extid* *entity-resolver* nil uri))
 516              (grammar
 517               (klacks:with-open-source (source (cxml:make-source xstream))
 518                 (invoke-with-klacks-handler
 519                  (lambda ()
 520                    (klacks:find-event source :start-element)
 521                    (let ((*datatype-library* ""))
 522                      (p/grammar source)))
 523                  source)))
 524              (grammar-content (pattern-content grammar)))
 525         (append
 526          (simplify-include source grammar-content include-content)
 527          include-content)))))
 528
 529 (defun simplify-include/map (fn l)
 530   (remove nil (mapcar fn l)))
 531
 532 (defun simplify-include/start (source grammar-content include-content)
 533   (let ((startp (some (lambda (x) (typep x 'start)) include-content)))
 534     (if startp
 535         (let ((ok nil))
 536           (prog1
 537               (remove-if (lambda (x)
 538                            (when (typep x 'start)
 539                              (setf ok t)
 540                              t))
 541                          grammar-content)
 542             (unless ok
 543               (rng-error source "expected start in grammar"))))
 544         grammar-content)))
 545
 546 (defun simplify-include/define (source grammar-content include-content)
 547   (let ((defines '()))
 548     (dolist (x include-content)
 549       (when (typep x 'define)
 550         (push (cons x nil) defines)))
 551     (prog1
 552         (remove-if (lambda (x)
 553                      (when (typep x 'define)
 554                        (let ((cons (find (define-name x)
 555                                          defines
 556                                          :key (lambda (y)
 557                                                 (define-name (car y)))
 558                                          :test #'equal)))
 559                          (when cons
 560                            (setf (cdr cons) t)
 561                            t))))
 562                    grammar-content)
 563       (loop for (define . okp) in defines do
 564             (unless okp
 565               (rng-error source "expected matching ~A in grammar" define))))))
 566
 567 (defun simplify-include (source grammar-content include-content)
 568   (simplify-include/define
 569    source
 570    (simplify-include/start source grammar-content include-content)
 571    include-content))
 572
 573 (defvar *any-name-allowed-p* t)
 574 (defvar *ns-name-allowed-p* t)
 575
 576 (defun p/name-class (source)
 577   (klacks:expecting-element (source)
 578     (with-library-and-ns (klacks:list-attributes source)
 579       (case (find-symbol (klacks:current-lname source) :keyword)
 580         (:|name|
 581           (let ((qname (string-trim *whitespace*
 582                                     (consume-and-parse-characters source))))
 583             (multiple-value-bind (uri lname)
 584                 (klacks:decode-qname qname source)
 585               (setf uri (or uri *namespace-uri*))
 586               (when (and *attribute-namespace-p*
 587                          (or (and (equal lname "xmlns") (equal uri ""))
 588                              (equal uri "http://www.w3.org/2000/xmlns")))
 589                 (rng-error source "namespace attribute not permitted"))
 590               (list :name lname :uri uri))))
 591         (:|anyName|
 592           (unless *any-name-allowed-p*
 593             (rng-error source "anyname now permitted in except"))
 594           (klacks:consume source)
 595           (prog1
 596               (let ((*any-name-allowed-p* nil))
 597                 (cons :any (p/except-name-class? source)))
 598             (skip-to-native source)))
 599         (:|nsName|
 600           (unless *ns-name-allowed-p*
 601             (rng-error source "nsname now permitted in except"))
 602           (let ((uri *namespace-uri*)
 603                 (*any-name-allowed-p* nil)
 604                 (*ns-name-allowed-p* nil))
 605             (when (and *attribute-namespace-p*
 606                        (equal uri "http://www.w3.org/2000/xmlns"))
 607               (rng-error source "namespace attribute not permitted"))
 608             (klacks:consume source)
 609             (prog1
 610                 (list :nsname (p/except-name-class? source) :uri uri)
 611               (skip-to-native source))))
 612         (:|choice|
 613           (klacks:consume source)
 614           (cons :choice (p/name-class* source)))
 615         (t
 616           (rng-error source "invalid child in except"))))))
 617
 618 (defun p/name-class* (source)
 619   (let ((results nil))
 620     (loop
 621       (skip-to-native source)
 622       (case (klacks:peek source)
 623         (:start-element (push (p/name-class source) results))
 624         (:end-element (return)))
 625       (klacks:consume source))
 626     (nreverse results)))
 627
 628 (defun p/except-name-class? (source)
 629   (skip-to-native source)
 630   (multiple-value-bind (key uri lname)
 631       (klacks:peek source)
 632     uri
 633     (if (and (eq key :start-element)
 634              (string= (find-symbol lname :keyword) "except"))
 635         (p/except-name-class source)
 636         nil)))
 637
 638 (defun p/except-name-class (source)
 639   (klacks:expecting-element (source "except")
 640     (with-library-and-ns (klacks:list-attributes source)
 641       (klacks:consume source)
 642       (cons :except (p/name-class* source)))))
 643
 644 (defun escape-uri (string)
 645   (with-output-to-string (out)
 646     (loop for c across (cxml::rod-to-utf8-string string) do
 647           (let ((code (char-code c)))
 648             ;; http://www.w3.org/TR/xlink/#link-locators
 649             (if (or (>= code 127) (<= code 32) (find c "<>\"{}|\\^`"))
 650                 (format out "%~2,'0X" code)
 651                 (write-char c out))))))
 652
 653
 654 ;;;; simplification
 655
 656 ;;; 4.1 Annotations
 657 ;;;   Foreign attributes and elements are removed implicitly while parsing.
 658
 659 ;;; 4.2 Whitespace
 660 ;;;   All character data is discarded while parsing (which can only be
 661 ;;;   whitespace after validation).
 662 ;;;
 663 ;;;   Whitespace in name, type, and combine attributes is stripped while
 664 ;;;   parsing.  Ditto for <name/>.
 665
 666 ;;; 4.3. datatypeLibrary attribute
 667 ;;;   Escaping is done by p/pattern.
 668 ;;;   Attribute value defaulting is done using *datatype-library*; only
 669 ;;;   p/data and p/value record the computed value.
 670
 671 ;;; 4.4. type attribute of value element
 672 ;;;   Done by p/value.
 673
 674 ;;; 4.5. href attribute
 675 ;;;   Escaping is done by p/include and p/external-ref.
 676 ;;;
 677 ;;;   FIXME: Mime-type handling should be the job of the entity resolver,
 678 ;;;   but that requires xstream hacking.
 679
 680 ;;; 4.6. externalRef element
 681 ;;;   Done by p/external-ref.
 682
 683 ;;; 4.7. include element
 684 ;;;   Done by p/include.
 685
 686 ;;; 4.8. name attribute of element and attribute elements
 687 ;;;   `name' is stored as a slot, not a child.  Done by p/element and
 688 ;;;    p/attribute.
 689
 690 ;;; 4.9. ns attribute
 691 ;;;    done by p/name-class, p/value, p/element, p/attribute
 692
 693 ;;; 4.10. QNames
 694 ;;;    done by p/name-class
 695
 696 ;;; 4.11. div element
 697 ;;;    Legen wir gar nicht erst an.
 698
 699 ;;; 4.12. 4.13 4.14 4.15
 700 ;;;    beim anlegen
 701
 702 ;;; 4.16
 703 ;;;    p/name-class
 704 ;;;    -- ausser der sache mit den datentypen
 705
 706 ;;;; tests
 707
 708 (defun run-tests (&optional (p "/home/david/src/lisp/cxml-rng/spec-split/*"))
 709   (dribble "/home/david/src/lisp/cxml-rng/TEST" :if-exists :rename-and-delete)
 710   (let ((pass 0)
 711         (total 0)
 712         (*package* (find-package :cxml-rng)))
 713     (dolist (d (directory p))
 714       (let ((name (car (last (pathname-directory d)))))
 715         (when (parse-integer name :junk-allowed t)
 716           (incf total)
 717           (when (test1 d)
 718             (incf pass)))))
 719     (format t "Passed ~D/~D tests.~%" pass total))
 720   (dribble))
 721
 722 (defun run-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 723   (test1 (merge-pathnames (format nil "~3,'0D/" n) p)))
 724
 725 (defun parse-test (n &optional (p "/home/david/src/lisp/cxml-rng/spec-split/"))
 726   (let* ((*debug* t)
 727          (d (merge-pathnames (format nil "~3,'0D/" n) p))
 728          (i (merge-pathnames "i.rng" d))
 729          (c (merge-pathnames "c.rng" d))
 730          (rng (if (probe-file c) c i)))
 731     (format t "~A: " (car (last (pathname-directory d))))
 732     (print rng)
 733     (parse-relax-ng rng)))
 734
 735 (defun test1 (d)
 736   (let* ((i (merge-pathnames "i.rng" d))
 737          (c (merge-pathnames "c.rng" d)))
 738     (format t "~A: " (car (last (pathname-directory d))))
 739     (if (probe-file c)
 740         (handler-case
 741             (progn
 742               (parse-relax-ng c)
 743               (format t " PASS~%")
 744               t)
 745           (error (c)
 746             (format t " FAIL: ~A~%" c)
 747             nil))
 748         (handler-case
 749             (progn
 750               (parse-relax-ng i)
 751               (format t " FAIL: didn't detect invalid schema~%")
 752               nil)
 753           (rng-error (c)
 754             (format t " PASS: ~S~%" (type-of c))
 755             t)
 756           (error (c)
 757             (format t " FAIL: incorrect condition type: ~A~%" c)
 758             nil)))))