lisp/nxml/rng-match.el

   1 ;;; rng-match.el --- matching of RELAX NG patterns against XML events
   2
   3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML, RelaxNG
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This uses the algorithm described in
  26 ;;   http://www.thaiopensource.com/relaxng/derivative.html
  27 ;;
  28 ;; The schema to be used is contained in the variable
  29 ;; rng-current-schema.  It has the form described in the file
  30 ;; rng-pttrn.el.
  31 ;;
  32 ;;; Code:
  33
  34 (require 'rng-pttrn)
  35 (require 'rng-util)
  36 (require 'rng-dt)
  37
  38 (defvar rng-not-allowed-ipattern nil)
  39 (defvar rng-empty-ipattern nil)
  40 (defvar rng-text-ipattern nil)
  41
  42 (defvar rng-compile-table nil)
  43
  44 (defvar rng-being-compiled nil
  45   "Contains a list of ref patterns currently being compiled.
  46 Used to detect illegal recursive references.")
  47
  48 (defvar rng-ipattern-table nil)
  49
  50 (defvar rng-last-ipattern-index nil)
  51
  52 (defvar rng-match-state nil
  53   "An ipattern representing the current state of validation.")
  54
  55 ;;; Inline functions
  56
  57 (defsubst rng-update-match-state (new-state)
  58   (if (and (eq new-state rng-not-allowed-ipattern)
  59            (not (eq rng-match-state rng-not-allowed-ipattern)))
  60       nil
  61     (setq rng-match-state new-state)
  62     t))
  63
  64 ;;; Interned patterns
  65
  66 (eval-when-compile
  67   (defun rng-ipattern-slot-accessor-name (slot-name)
  68     (intern (concat "rng-ipattern-get-"
  69                     (symbol-name slot-name))))
  70
  71   (defun rng-ipattern-slot-setter-name (slot-name)
  72     (intern (concat "rng-ipattern-set-"
  73                     (symbol-name slot-name)))))
  74
  75 (defmacro rng-ipattern-defslot (slot-name index)
  76   `(progn
  77      (defsubst ,(rng-ipattern-slot-accessor-name slot-name) (ipattern)
  78        (aref ipattern ,index))
  79      (defsubst ,(rng-ipattern-slot-setter-name slot-name) (ipattern value)
  80        (aset ipattern ,index value))))
  81
  82 (rng-ipattern-defslot type 0)
  83 (rng-ipattern-defslot index 1)
  84 (rng-ipattern-defslot name-class 2)
  85 (rng-ipattern-defslot datatype 2)
  86 (rng-ipattern-defslot after 2)
  87 (rng-ipattern-defslot child 3)
  88 (rng-ipattern-defslot value-object 3)
  89 (rng-ipattern-defslot nullable 4)
  90 (rng-ipattern-defslot memo-text-typed 5)
  91 (rng-ipattern-defslot memo-map-start-tag-open-deriv 6)
  92 (rng-ipattern-defslot memo-map-start-attribute-deriv 7)
  93 (rng-ipattern-defslot memo-start-tag-close-deriv 8)
  94 (rng-ipattern-defslot memo-text-only-deriv 9)
  95 (rng-ipattern-defslot memo-mixed-text-deriv 10)
  96 (rng-ipattern-defslot memo-map-data-deriv 11)
  97 (rng-ipattern-defslot memo-end-tag-deriv 12)
  98
  99 (defconst rng-memo-map-alist-max 10)
 100
 101 (defsubst rng-memo-map-get (key mm)
 102   "Return the value associated with KEY in memo-map MM."
 103   (let ((found (assoc key mm)))
 104     (if found
 105         (cdr found)
 106       (and mm
 107            (let ((head (car mm)))
 108              (and (hash-table-p head)
 109                   (gethash key head)))))))
 110
 111 (defun rng-memo-map-add (key value mm &optional weakness)
 112   "Associate KEY with VALUE in memo-map MM and return the new memo-map.
 113 The new memo-map may or may not be a different object from MM.
 114
 115 Alists are better for small maps. Hash tables are better for large
 116 maps.  A memo-map therefore starts off as an alist and switches to a
 117 hash table for large memo-maps. A memo-map is always a list.  An empty
 118 memo-map is represented by nil. A large memo-map is represented by a
 119 list containing just a hash-table.  A small memo map is represented by
 120 a list whose cdr is an alist and whose car is the number of entries in
 121 the alist. The complete memo-map can be passed to assoc without
 122 problems: assoc ignores any members that are not cons cells.  There is
 123 therefore minimal overhead in successful lookups on small lists
 124 \(which is the most common case)."
 125   (if (null mm)
 126       (list 1 (cons key value))
 127     (let ((head (car mm)))
 128       (cond ((hash-table-p head)
 129              (puthash key value head)
 130              mm)
 131             ((>= head rng-memo-map-alist-max)
 132              (let ((ht (make-hash-table :test 'equal
 133                                         :weakness weakness
 134                                         :size (* 2 rng-memo-map-alist-max))))
 135                (setq mm (cdr mm))
 136                (while mm
 137                  (setq head (car mm))
 138                  (puthash (car head) (cdr head) ht)
 139                  (setq mm (cdr mm)))
 140                (cons ht nil)))
 141             (t (cons (1+ head)
 142                      (cons (cons key value)
 143                            (cdr mm))))))))
 144
 145 (defsubst rng-make-ipattern (type index name-class child nullable)
 146   (vector type index name-class child nullable
 147           ;; 5 memo-text-typed
 148           'unknown
 149           ;; 6 memo-map-start-tag-open-deriv
 150           nil
 151           ;; 7 memo-map-start-attribute-deriv
 152           nil
 153           ;; 8 memo-start-tag-close-deriv
 154           nil
 155           ;; 9 memo-text-only-deriv
 156           nil
 157           ;; 10 memo-mixed-text-deriv
 158           nil
 159           ;; 11 memo-map-data-deriv
 160           nil
 161           ;; 12 memo-end-tag-deriv
 162           nil))
 163
 164 (defun rng-ipattern-maybe-init ()
 165   (unless rng-ipattern-table
 166     (setq rng-ipattern-table (make-hash-table :test 'equal))
 167     (setq rng-last-ipattern-index -1)))
 168
 169 (defun rng-ipattern-clear ()
 170   (when rng-ipattern-table
 171     (clrhash rng-ipattern-table))
 172   (setq rng-last-ipattern-index -1))
 173
 174 (defsubst rng-gen-ipattern-index ()
 175   (setq rng-last-ipattern-index (1+ rng-last-ipattern-index)))
 176
 177 (defun rng-put-ipattern (key type name-class child nullable)
 178   (let ((ipattern
 179          (rng-make-ipattern type
 180                             (rng-gen-ipattern-index)
 181                             name-class
 182                             child
 183                             nullable)))
 184     (puthash key ipattern rng-ipattern-table)
 185     ipattern))
 186
 187 (defun rng-get-ipattern (key)
 188   (gethash key rng-ipattern-table))
 189
 190 (or rng-not-allowed-ipattern
 191     (setq rng-not-allowed-ipattern
 192           (rng-make-ipattern 'not-allowed -3 nil nil nil)))
 193
 194 (or rng-empty-ipattern
 195     (setq rng-empty-ipattern
 196           (rng-make-ipattern 'empty -2 nil nil t)))
 197
 198 (or rng-text-ipattern
 199     (setq rng-text-ipattern
 200           (rng-make-ipattern 'text -1 nil nil t)))
 201
 202 (defconst rng-const-ipatterns
 203   (list rng-not-allowed-ipattern
 204         rng-empty-ipattern
 205         rng-text-ipattern))
 206
 207 (defun rng-intern-after (child after)
 208   (if (eq child rng-not-allowed-ipattern)
 209       rng-not-allowed-ipattern
 210     (let ((key (list 'after
 211                      (rng-ipattern-get-index child)
 212                      (rng-ipattern-get-index after))))
 213       (or (rng-get-ipattern key)
 214           (rng-put-ipattern key
 215                             'after
 216                             after
 217                             child
 218                             nil)))))
 219
 220 (defun rng-intern-attribute (name-class ipattern)
 221   (if (eq ipattern rng-not-allowed-ipattern)
 222       rng-not-allowed-ipattern
 223     (let ((key (list 'attribute
 224                      name-class
 225                      (rng-ipattern-get-index ipattern))))
 226       (or (rng-get-ipattern key)
 227           (rng-put-ipattern key
 228                             'attribute
 229                             name-class
 230                             ipattern
 231                             nil)))))
 232
 233 (defun rng-intern-data (dt matches-anything)
 234   (let ((key (list 'data dt)))
 235     (or (rng-get-ipattern key)
 236         (let ((ipattern (rng-put-ipattern key
 237                                           'data
 238                                           dt
 239                                           nil
 240                                           matches-anything)))
 241           (rng-ipattern-set-memo-text-typed ipattern
 242                                             (not matches-anything))
 243           ipattern))))
 244
 245 (defun rng-intern-data-except (dt ipattern)
 246   (let ((key (list 'data-except dt ipattern)))
 247     (or (rng-get-ipattern key)
 248         (rng-put-ipattern key
 249                           'data-except
 250                           dt
 251                           ipattern
 252                           nil))))
 253
 254 (defun rng-intern-value (dt obj)
 255   (let ((key (list 'value dt obj)))
 256     (or (rng-get-ipattern key)
 257         (rng-put-ipattern key
 258                           'value
 259                           dt
 260                           obj
 261                           nil))))
 262
 263 (defun rng-intern-one-or-more (ipattern)
 264   (or (rng-intern-one-or-more-shortcut ipattern)
 265       (let ((key (cons 'one-or-more
 266                        (list (rng-ipattern-get-index ipattern)))))
 267         (or (rng-get-ipattern key)
 268             (rng-put-ipattern key
 269                               'one-or-more
 270                               nil
 271                               ipattern
 272                               (rng-ipattern-get-nullable ipattern))))))
 273
 274 (defun rng-intern-one-or-more-shortcut (ipattern)
 275   (cond ((eq ipattern rng-not-allowed-ipattern)
 276          rng-not-allowed-ipattern)
 277         ((eq ipattern rng-empty-ipattern)
 278          rng-empty-ipattern)
 279         ((eq (rng-ipattern-get-type ipattern) 'one-or-more)
 280          ipattern)
 281         (t nil)))
 282
 283 (defun rng-intern-list (ipattern)
 284   (if (eq ipattern rng-not-allowed-ipattern)
 285       rng-not-allowed-ipattern
 286     (let ((key (cons 'list
 287                      (list (rng-ipattern-get-index ipattern)))))
 288       (or (rng-get-ipattern key)
 289           (rng-put-ipattern key
 290                             'list
 291                             nil
 292                             ipattern
 293                             nil)))))
 294
 295 (defun rng-intern-group (ipatterns)
 296   "Return a ipattern for the list of group members in IPATTERNS."
 297   (or (rng-intern-group-shortcut ipatterns)
 298       (let* ((tem (rng-normalize-group-list ipatterns))
 299              (normalized (cdr tem)))
 300         (or (rng-intern-group-shortcut normalized)
 301             (let ((key (cons 'group
 302                              (mapcar 'rng-ipattern-get-index normalized))))
 303               (or (rng-get-ipattern key)
 304                   (rng-put-ipattern key
 305                                     'group
 306                                     nil
 307                                     normalized
 308                                     (car tem))))))))
 309
 310 (defun rng-intern-group-shortcut (ipatterns)
 311   "Try to shortcut interning a group list.  If successful, return the
 312 interned pattern.  Otherwise return nil."
 313   (while (and ipatterns
 314               (eq (car ipatterns) rng-empty-ipattern))
 315     (setq ipatterns (cdr ipatterns)))
 316   (if ipatterns
 317       (let ((ret (car ipatterns)))
 318         (if (eq ret rng-not-allowed-ipattern)
 319             rng-not-allowed-ipattern
 320           (setq ipatterns (cdr ipatterns))
 321           (while (and ipatterns ret)
 322             (let ((tem (car ipatterns)))
 323               (cond ((eq tem rng-not-allowed-ipattern)
 324                      (setq ret tem)
 325                      (setq ipatterns nil))
 326                     ((eq tem rng-empty-ipattern)
 327                      (setq ipatterns (cdr ipatterns)))
 328                     (t
 329                      ;; Stop here rather than continuing
 330                      ;; looking for not-allowed patterns.
 331                      ;; We do a complete scan elsewhere.
 332                      (setq ret nil)))))
 333           ret))
 334     rng-empty-ipattern))
 335
 336 (defun rng-normalize-group-list (ipatterns)
 337   "Normalize a list containing members of a group.
 338 Expands nested groups, removes empty members, handles notAllowed.
 339 Returns a pair whose car says whether the list is nullable and whose
 340 cdr is the normalized list."
 341   (let ((nullable t)
 342         (result nil)
 343         member)
 344     (while ipatterns
 345       (setq member (car ipatterns))
 346       (setq ipatterns (cdr ipatterns))
 347       (when nullable
 348         (setq nullable (rng-ipattern-get-nullable member)))
 349       (cond ((eq (rng-ipattern-get-type member) 'group)
 350              (setq result
 351                    (nconc (reverse (rng-ipattern-get-child member))
 352                           result)))
 353             ((eq member rng-not-allowed-ipattern)
 354              (setq result (list rng-not-allowed-ipattern))
 355              (setq ipatterns nil))
 356             ((not (eq member rng-empty-ipattern))
 357              (setq result (cons member result)))))
 358     (cons nullable (nreverse result))))
 359
 360 (defun rng-intern-interleave (ipatterns)
 361   (or (rng-intern-group-shortcut ipatterns)
 362       (let* ((tem (rng-normalize-interleave-list ipatterns))
 363              (normalized (cdr tem)))
 364         (or (rng-intern-group-shortcut normalized)
 365             (let ((key (cons 'interleave
 366                              (mapcar 'rng-ipattern-get-index normalized))))
 367               (or (rng-get-ipattern key)
 368                   (rng-put-ipattern key
 369                                     'interleave
 370                                     nil
 371                                     normalized
 372                                     (car tem))))))))
 373
 374 (defun rng-normalize-interleave-list (ipatterns)
 375   "Normalize a list containing members of an interleave.
 376 Expands nested groups, removes empty members, handles notAllowed.
 377 Returns a pair whose car says whether the list is nullable and whose
 378 cdr is the normalized list."
 379   (let ((nullable t)
 380         (result nil)
 381         member)
 382     (while ipatterns
 383       (setq member (car ipatterns))
 384       (setq ipatterns (cdr ipatterns))
 385       (when nullable
 386         (setq nullable (rng-ipattern-get-nullable member)))
 387       (cond ((eq (rng-ipattern-get-type member) 'interleave)
 388              (setq result
 389                    (append (rng-ipattern-get-child member)
 390                             result)))
 391             ((eq member rng-not-allowed-ipattern)
 392              (setq result (list rng-not-allowed-ipattern))
 393              (setq ipatterns nil))
 394             ((not (eq member rng-empty-ipattern))
 395              (setq result (cons member result)))))
 396     (cons nullable (sort result 'rng-compare-ipattern))))
 397
 398 ;; Would be cleaner if this didn't modify IPATTERNS.
 399
 400 (defun rng-intern-choice (ipatterns)
 401   "Return a choice ipattern for the list of choices in IPATTERNS.
 402 May alter IPATTERNS."
 403   (or (rng-intern-choice-shortcut ipatterns)
 404       (let* ((tem (rng-normalize-choice-list ipatterns))
 405              (normalized (cdr tem)))
 406         (or (rng-intern-choice-shortcut normalized)
 407             (rng-intern-choice1 normalized (car tem))))))
 408
 409 (defun rng-intern-optional (ipattern)
 410   (cond ((rng-ipattern-get-nullable ipattern) ipattern)
 411         ((eq ipattern rng-not-allowed-ipattern) rng-empty-ipattern)
 412         (t (rng-intern-choice1
 413             ;; This is sorted since the empty pattern
 414             ;; is before everything except not allowed.
 415             ;; It cannot have a duplicate empty pattern,
 416             ;; since it is not nullable.
 417             (cons rng-empty-ipattern
 418                   (if (eq (rng-ipattern-get-type ipattern) 'choice)
 419                       (rng-ipattern-get-child ipattern)
 420                     (list ipattern)))
 421             t))))
 422
 423
 424 (defun rng-intern-choice1 (normalized nullable)
 425   (let ((key (cons 'choice
 426                    (mapcar 'rng-ipattern-get-index normalized))))
 427     (or (rng-get-ipattern key)
 428         (rng-put-ipattern key
 429                           'choice
 430                           nil
 431                           normalized
 432                           nullable))))
 433
 434 (defun rng-intern-choice-shortcut (ipatterns)
 435   "Try to shortcut interning a choice list.  If successful, return the
 436 interned pattern.  Otherwise return nil."
 437   (while (and ipatterns
 438               (eq (car ipatterns)
 439                   rng-not-allowed-ipattern))
 440     (setq ipatterns (cdr ipatterns)))
 441   (if ipatterns
 442       (let ((ret (car ipatterns)))
 443         (setq ipatterns (cdr ipatterns))
 444         (while (and ipatterns ret)
 445           (or (eq (car ipatterns) rng-not-allowed-ipattern)
 446               (eq (car ipatterns) ret)
 447               (setq ret nil))
 448           (setq ipatterns (cdr ipatterns)))
 449         ret)
 450     rng-not-allowed-ipattern))
 451
 452 (defun rng-normalize-choice-list (ipatterns)
 453   "Normalize a list of choices, expanding nested choices, removing
 454 not-allowed members, sorting by index and removing duplicates.  Return
 455 a pair whose car says whether the list is nullable and whose cdr is
 456 the normalized list."
 457   (let ((sorted t)
 458         (nullable nil)
 459         (head (cons nil ipatterns)))
 460     (let ((tail head)
 461           (final-tail nil)
 462           (prev-index -100)
 463           (cur ipatterns)
 464           member)
 465       ;; the cdr of tail is always cur
 466       (while cur
 467         (setq member (car cur))
 468         (or nullable
 469             (setq nullable (rng-ipattern-get-nullable member)))
 470         (cond ((eq (rng-ipattern-get-type member) 'choice)
 471                (setq final-tail
 472                      (append (rng-ipattern-get-child member)
 473                              final-tail))
 474                (setq cur (cdr cur))
 475                (setq sorted nil)
 476                (setcdr tail cur))
 477               ((eq member rng-not-allowed-ipattern)
 478                (setq cur (cdr cur))
 479                (setcdr tail cur))
 480               (t
 481                (if (and sorted
 482                         (let ((cur-index (rng-ipattern-get-index member)))
 483                           (if (>= prev-index cur-index)
 484                               (or (= prev-index cur-index) ; will remove it
 485                                   (setq sorted nil)) ; won't remove it
 486                             (setq prev-index cur-index)
 487                             ;; won't remove it
 488                             nil)))
 489                    (progn
 490                      ;; remove it
 491                      (setq cur (cdr cur))
 492                      (setcdr tail cur))
 493                  ;; don't remove it
 494                  (setq tail cur)
 495                  (setq cur (cdr cur))))))
 496       (setcdr tail final-tail))
 497     (setq head (cdr head))
 498     (cons nullable
 499           (if sorted
 500               head
 501             (rng-uniquify-eq (sort head 'rng-compare-ipattern))))))
 502
 503 (defun rng-compare-ipattern (p1 p2)
 504   (< (rng-ipattern-get-index p1)
 505      (rng-ipattern-get-index p2)))
 506
 507 ;;; Name classes
 508
 509 (defsubst rng-name-class-contains (nc nm)
 510   (if (consp nc)
 511       (equal nm nc)
 512     (rng-name-class-contains1 nc nm)))
 513
 514 (defun rng-name-class-contains1 (nc nm)
 515   (let ((type (aref nc 0)))
 516     (cond ((eq type 'any-name) t)
 517           ((eq type 'any-name-except)
 518            (not (rng-name-class-contains (aref nc 1) nm)))
 519           ((eq type 'ns-name)
 520            (eq (car nm) (aref nc 1)))
 521           ((eq type 'ns-name-except)
 522            (and (eq (car nm) (aref nc 1))
 523                 (not (rng-name-class-contains (aref nc 2) nm))))
 524           ((eq type 'choice)
 525            (let ((choices (aref nc 1))
 526                  (ret nil))
 527              (while choices
 528                (if (rng-name-class-contains (car choices) nm)
 529                    (progn
 530                      (setq choices nil)
 531                      (setq ret t))
 532                  (setq choices (cdr choices))))
 533              ret)))))
 534
 535 (defun rng-name-class-possible-names (nc accum)
 536   "Return a list of possible names that nameclass NC can match.
 537
 538 Each possible name should be returned as a (NAMESPACE . LOCAL-NAME)
 539 pair, where NAMESPACE is a symbol or nil and LOCAL-NAME is a string.
 540 nil for NAMESPACE matches the absent namespace.  ACCUM is a list of
 541 names which should be appended to the returned list. The returned list
 542 may contain duplicates."
 543   (if (consp nc)
 544       (cons nc accum)
 545     (when (eq (aref nc 0) 'choice)
 546       (let ((members (aref nc 1)) member)
 547         (while members
 548           (setq member (car members))
 549           (setq accum
 550                 (if (consp member)
 551                     (cons member accum)
 552                   (rng-name-class-possible-names member
 553                                                  accum)))
 554           (setq members (cdr members)))))
 555     accum))
 556
 557 ;;; Debugging utilities
 558
 559 (defun rng-ipattern-to-string (ipattern)
 560   (let ((type (rng-ipattern-get-type ipattern)))
 561     (cond ((eq type 'after)
 562            (concat (rng-ipattern-to-string
 563                     (rng-ipattern-get-child ipattern))
 564                    " </> "
 565                    (rng-ipattern-to-string
 566                     (rng-ipattern-get-after ipattern))))
 567           ((eq type 'element)
 568            (concat "element "
 569                    (rng-name-class-to-string
 570                     (rng-ipattern-get-name-class ipattern))
 571                    ;; we can get cycles with elements so don't print it out
 572                    " {...}"))
 573           ((eq type 'attribute)
 574            (concat "attribute "
 575                    (rng-name-class-to-string
 576                     (rng-ipattern-get-name-class ipattern))
 577                    " { "
 578                    (rng-ipattern-to-string
 579                     (rng-ipattern-get-child ipattern))
 580                    " } "))
 581           ((eq type 'empty) "empty")
 582           ((eq type 'text) "text")
 583           ((eq type 'not-allowed) "notAllowed")
 584           ((eq type 'one-or-more)
 585            (concat (rng-ipattern-to-string
 586                     (rng-ipattern-get-child ipattern))
 587                    "+"))
 588           ((eq type 'choice)
 589            (concat "("
 590                    (mapconcat 'rng-ipattern-to-string
 591                               (rng-ipattern-get-child ipattern)
 592                               " | ")
 593                    ")"))
 594           ((eq type 'group)
 595            (concat "("
 596                    (mapconcat 'rng-ipattern-to-string
 597                               (rng-ipattern-get-child ipattern)
 598                               ", ")
 599                    ")"))
 600           ((eq type 'interleave)
 601            (concat "("
 602                    (mapconcat 'rng-ipattern-to-string
 603                               (rng-ipattern-get-child ipattern)
 604                               " & ")
 605                    ")"))
 606           (t (symbol-name type)))))
 607
 608 (defun rng-name-class-to-string (nc)
 609   (if (consp nc)
 610       (cdr nc)
 611     (let ((type (aref nc 0)))
 612       (cond ((eq type 'choice)
 613              (mapconcat 'rng-name-class-to-string
 614                         (aref nc 1)
 615                         "|"))
 616             (t (concat (symbol-name type) "*"))))))
 617
 618
 619 ;;; Compiling
 620
 621 (defun rng-compile-maybe-init ()
 622   (unless rng-compile-table
 623     (setq rng-compile-table (make-hash-table :test 'eq))))
 624
 625 (defun rng-compile-clear ()
 626   (when rng-compile-table
 627     (clrhash rng-compile-table)))
 628
 629 (defun rng-compile (pattern)
 630   (or (gethash pattern rng-compile-table)
 631       (let ((ipattern (apply (get (car pattern) 'rng-compile)
 632                              (cdr pattern))))
 633         (puthash pattern ipattern rng-compile-table)
 634         ipattern)))
 635
 636 (put 'empty 'rng-compile 'rng-compile-empty)
 637 (put 'text 'rng-compile 'rng-compile-text)
 638 (put 'not-allowed 'rng-compile 'rng-compile-not-allowed)
 639 (put 'element 'rng-compile 'rng-compile-element)
 640 (put 'attribute 'rng-compile 'rng-compile-attribute)
 641 (put 'choice 'rng-compile 'rng-compile-choice)
 642 (put 'optional 'rng-compile 'rng-compile-optional)
 643 (put 'group 'rng-compile 'rng-compile-group)
 644 (put 'interleave 'rng-compile 'rng-compile-interleave)
 645 (put 'ref 'rng-compile 'rng-compile-ref)
 646 (put 'one-or-more 'rng-compile 'rng-compile-one-or-more)
 647 (put 'zero-or-more 'rng-compile 'rng-compile-zero-or-more)
 648 (put 'mixed 'rng-compile 'rng-compile-mixed)
 649 (put 'data 'rng-compile 'rng-compile-data)
 650 (put 'data-except 'rng-compile 'rng-compile-data-except)
 651 (put 'value 'rng-compile 'rng-compile-value)
 652 (put 'list 'rng-compile 'rng-compile-list)
 653
 654 (defun rng-compile-not-allowed () rng-not-allowed-ipattern)
 655 (defun rng-compile-empty () rng-empty-ipattern)
 656 (defun rng-compile-text () rng-text-ipattern)
 657
 658 (defun rng-compile-element (name-class pattern)
 659   ;; don't intern
 660   (rng-make-ipattern 'element
 661                      (rng-gen-ipattern-index)
 662                      (rng-compile-name-class name-class)
 663                      pattern            ; compile lazily
 664                      nil))
 665
 666 (defun rng-element-get-child (element)
 667   (let ((tem (rng-ipattern-get-child element)))
 668     (if (vectorp tem)
 669         tem
 670       (rng-ipattern-set-child element (rng-compile tem)))))
 671
 672 (defun rng-compile-attribute (name-class pattern)
 673   (rng-intern-attribute (rng-compile-name-class name-class)
 674                         (rng-compile pattern)))
 675
 676 (defun rng-compile-ref (pattern name)
 677   (and (memq pattern rng-being-compiled)
 678        (rng-compile-error "Reference loop on symbol %s" name))
 679   (setq rng-being-compiled
 680         (cons pattern rng-being-compiled))
 681   (unwind-protect
 682       (rng-compile pattern)
 683     (setq rng-being-compiled
 684           (cdr rng-being-compiled))))
 685
 686 (defun rng-compile-one-or-more (pattern)
 687   (rng-intern-one-or-more (rng-compile pattern)))
 688
 689 (defun rng-compile-zero-or-more (pattern)
 690   (rng-intern-optional
 691    (rng-intern-one-or-more (rng-compile pattern))))
 692
 693 (defun rng-compile-optional (pattern)
 694   (rng-intern-optional (rng-compile pattern)))
 695
 696 (defun rng-compile-mixed (pattern)
 697   (rng-intern-interleave (cons rng-text-ipattern
 698                                (list (rng-compile pattern)))))
 699
 700 (defun rng-compile-list (pattern)
 701   (rng-intern-list (rng-compile pattern)))
 702
 703 (defun rng-compile-choice (&rest patterns)
 704   (rng-intern-choice (mapcar 'rng-compile patterns)))
 705
 706 (defun rng-compile-group (&rest patterns)
 707   (rng-intern-group (mapcar 'rng-compile patterns)))
 708
 709 (defun rng-compile-interleave (&rest patterns)
 710   (rng-intern-interleave (mapcar 'rng-compile patterns)))
 711
 712 (defun rng-compile-dt (name params)
 713   (let ((rng-dt-error-reporter 'rng-compile-error))
 714     (funcall (let ((uri (car name)))
 715                (or (get uri 'rng-dt-compile)
 716                    (rng-compile-error "Unknown datatype library %s" uri)))
 717              (cdr name)
 718              params)))
 719
 720 (defun rng-compile-data (name params)
 721   (let ((dt (rng-compile-dt name params)))
 722     (rng-intern-data (cdr dt) (car dt))))
 723
 724 (defun rng-compile-data-except (name params pattern)
 725   (rng-intern-data-except (cdr (rng-compile-dt name params))
 726                           (rng-compile pattern)))
 727
 728 (defun rng-compile-value (name str context)
 729   (let* ((dt (cdr (rng-compile-dt name '())))
 730          (rng-dt-namespace-context-getter (list 'identity context))
 731          (obj (rng-dt-make-value dt str)))
 732     (if obj
 733         (rng-intern-value dt obj)
 734       (rng-compile-error "Value %s is not a valid instance of the datatype %s"
 735                          str
 736                          name))))
 737
 738 (defun rng-compile-name-class (nc)
 739   (let ((type (car nc)))
 740     (cond ((eq type 'name) (nth 1 nc))
 741           ((eq type 'any-name) [any-name])
 742           ((eq type 'any-name-except)
 743            (vector 'any-name-except
 744                    (rng-compile-name-class (nth 1 nc))))
 745           ((eq type 'ns-name)
 746            (vector 'ns-name (nth 1 nc)))
 747           ((eq type 'ns-name-except)
 748            (vector 'ns-name-except
 749                    (nth 1 nc)
 750                    (rng-compile-name-class (nth 2 nc))))
 751           ((eq type 'choice)
 752            (vector 'choice
 753                    (mapcar 'rng-compile-name-class (cdr nc))))
 754           (t (error "Bad name-class type %s" type)))))
 755
 756 ;;; Searching patterns
 757
 758 ;; We write this non-recursively to avoid hitting max-lisp-eval-depth
 759 ;; on large schemas.
 760
 761 (defun rng-map-element-attribute (function pattern accum &rest args)
 762   (let ((searched (make-hash-table :test 'eq))
 763         type todo patterns)
 764     (while (progn
 765              (setq type (car pattern))
 766              (cond ((memq type '(element attribute))
 767                     (setq accum
 768                           (apply function
 769                                  (cons pattern
 770                                        (cons accum args))))
 771                     (setq pattern (nth 2 pattern)))
 772                    ((eq type 'ref)
 773                     (setq pattern (nth 1 pattern))
 774                     (if (gethash pattern searched)
 775                         (setq pattern nil)
 776                       (puthash pattern t searched)))
 777                    ((memq type '(choice group interleave))
 778                     (setq todo (cons (cdr pattern) todo))
 779                     (setq pattern nil))
 780                    ((memq type '(one-or-more
 781                                  zero-or-more
 782                                  optional
 783                                  mixed))
 784                     (setq pattern (nth 1 pattern)))
 785                    (t (setq pattern nil)))
 786              (cond (pattern)
 787                    (patterns
 788                     (setq pattern (car patterns))
 789                     (setq patterns (cdr patterns))
 790                     t)
 791                    (todo
 792                     (setq patterns (car todo))
 793                     (setq todo (cdr todo))
 794                     (setq pattern (car patterns))
 795                     (setq patterns (cdr patterns))
 796                     t))))
 797     accum))
 798
 799 (defun rng-find-element-content-pattern (pattern accum name)
 800   (if (and (eq (car pattern) 'element)
 801            (rng-search-name name (nth 1 pattern)))
 802       (cons (rng-compile (nth 2 pattern)) accum)
 803     accum))
 804
 805 (defun rng-search-name (name nc)
 806   (let ((type (car nc)))
 807     (cond ((eq type 'name)
 808            (equal (cadr nc) name))
 809           ((eq type 'choice)
 810            (let ((choices (cdr nc))
 811                  (found nil))
 812              (while (and choices (not found))
 813                (if (rng-search-name name (car choices))
 814                    (setq found t)
 815                  (setq choices (cdr choices))))
 816              found))
 817           (t nil))))
 818
 819 (defun rng-find-name-class-uris (nc accum)
 820   (let ((type (car nc)))
 821     (cond ((eq type 'name)
 822            (rng-accum-namespace-uri (car (nth 1 nc)) accum))
 823           ((memq type '(ns-name ns-name-except))
 824            (rng-accum-namespace-uri (nth 1 nc) accum))
 825           ((eq type 'choice)
 826            (let ((choices (cdr nc)))
 827              (while choices
 828                (setq accum
 829                      (rng-find-name-class-uris (car choices) accum))
 830                (setq choices (cdr choices))))
 831            accum)
 832           (t accum))))
 833
 834 (defun rng-accum-namespace-uri (ns accum)
 835   (if (and ns (not (memq ns accum)))
 836       (cons ns accum)
 837     accum))
 838
 839 ;;; Derivatives
 840
 841 (defun rng-ipattern-text-typed-p (ipattern)
 842   (let ((memo (rng-ipattern-get-memo-text-typed ipattern)))
 843     (if (eq memo 'unknown)
 844         (rng-ipattern-set-memo-text-typed
 845          ipattern
 846          (rng-ipattern-compute-text-typed-p ipattern))
 847       memo)))
 848
 849 (defun rng-ipattern-compute-text-typed-p (ipattern)
 850   (let ((type (rng-ipattern-get-type ipattern)))
 851     (cond ((eq type 'choice)
 852            (let ((cur (rng-ipattern-get-child ipattern))
 853                  (ret nil))
 854              (while (and cur (not ret))
 855                (if (rng-ipattern-text-typed-p (car cur))
 856                    (setq ret t)
 857                  (setq cur (cdr cur))))
 858              ret))
 859           ((eq type 'group)
 860            (let ((cur (rng-ipattern-get-child ipattern))
 861                  (ret nil)
 862                  member)
 863              (while (and cur (not ret))
 864                (setq member (car cur))
 865                (if (rng-ipattern-text-typed-p member)
 866                    (setq ret t))
 867                (setq cur
 868                      (and (rng-ipattern-get-nullable member)
 869                           (cdr cur))))
 870              ret))
 871           ((eq type 'after)
 872            (rng-ipattern-text-typed-p (rng-ipattern-get-child ipattern)))
 873           (t (and (memq type '(value list data data-except)) t)))))
 874
 875 (defun rng-start-tag-open-deriv (ipattern nm)
 876   (or (rng-memo-map-get
 877        nm
 878        (rng-ipattern-get-memo-map-start-tag-open-deriv ipattern))
 879       (rng-ipattern-memo-start-tag-open-deriv
 880        ipattern
 881        nm
 882        (rng-compute-start-tag-open-deriv ipattern nm))))
 883
 884 (defun rng-ipattern-memo-start-tag-open-deriv (ipattern nm deriv)
 885   (or (memq ipattern rng-const-ipatterns)
 886       (rng-ipattern-set-memo-map-start-tag-open-deriv
 887        ipattern
 888        (rng-memo-map-add nm
 889                          deriv
 890                          (rng-ipattern-get-memo-map-start-tag-open-deriv
 891                           ipattern))))
 892   deriv)
 893
 894 (defun rng-compute-start-tag-open-deriv (ipattern nm)
 895   (let ((type (rng-ipattern-get-type ipattern)))
 896     (cond ((eq type 'choice)
 897            (rng-transform-choice `(lambda (p)
 898                                     (rng-start-tag-open-deriv p ',nm))
 899                                  ipattern))
 900           ((eq type 'element)
 901            (if (rng-name-class-contains
 902                 (rng-ipattern-get-name-class ipattern)
 903                 nm)
 904                (rng-intern-after (rng-element-get-child ipattern)
 905                                  rng-empty-ipattern)
 906              rng-not-allowed-ipattern))
 907           ((eq type 'group)
 908            (rng-transform-group-nullable
 909             `(lambda (p) (rng-start-tag-open-deriv p ',nm))
 910             'rng-cons-group-after
 911             ipattern))
 912           ((eq type 'interleave)
 913            (rng-transform-interleave-single
 914             `(lambda (p) (rng-start-tag-open-deriv p ',nm))
 915             'rng-subst-interleave-after
 916             ipattern))
 917           ((eq type 'one-or-more)
 918            (rng-apply-after
 919             `(lambda (p)
 920                (rng-intern-group (list p ,(rng-intern-optional ipattern))))
 921             (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern)
 922                                       nm)))
 923           ((eq type 'after)
 924            (rng-apply-after
 925             `(lambda (p)
 926                (rng-intern-after p
 927                                  ,(rng-ipattern-get-after ipattern)))
 928             (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern)
 929                                       nm)))
 930           (t rng-not-allowed-ipattern))))
 931
 932 (defun rng-start-attribute-deriv (ipattern nm)
 933   (or (rng-memo-map-get
 934        nm
 935        (rng-ipattern-get-memo-map-start-attribute-deriv ipattern))
 936       (rng-ipattern-memo-start-attribute-deriv
 937        ipattern
 938        nm
 939        (rng-compute-start-attribute-deriv ipattern nm))))
 940
 941 (defun rng-ipattern-memo-start-attribute-deriv (ipattern nm deriv)
 942   (or (memq ipattern rng-const-ipatterns)
 943       (rng-ipattern-set-memo-map-start-attribute-deriv
 944        ipattern
 945        (rng-memo-map-add
 946         nm
 947         deriv
 948         (rng-ipattern-get-memo-map-start-attribute-deriv ipattern))))
 949   deriv)
 950
 951 (defun rng-compute-start-attribute-deriv (ipattern nm)
 952   (let ((type (rng-ipattern-get-type ipattern)))
 953     (cond ((eq type 'choice)
 954            (rng-transform-choice `(lambda (p)
 955                                     (rng-start-attribute-deriv p ',nm))
 956                                  ipattern))
 957           ((eq type 'attribute)
 958            (if (rng-name-class-contains
 959                 (rng-ipattern-get-name-class ipattern)
 960                 nm)
 961                (rng-intern-after (rng-ipattern-get-child ipattern)
 962                                  rng-empty-ipattern)
 963              rng-not-allowed-ipattern))
 964           ((eq type 'group)
 965            (rng-transform-interleave-single
 966             `(lambda (p) (rng-start-attribute-deriv p ',nm))
 967             'rng-subst-group-after
 968             ipattern))
 969           ((eq type 'interleave)
 970            (rng-transform-interleave-single
 971             `(lambda (p) (rng-start-attribute-deriv p ',nm))
 972             'rng-subst-interleave-after
 973             ipattern))
 974           ((eq type 'one-or-more)
 975            (rng-apply-after
 976             `(lambda (p)
 977                (rng-intern-group (list p ,(rng-intern-optional ipattern))))
 978             (rng-start-attribute-deriv (rng-ipattern-get-child ipattern)
 979                                        nm)))
 980           ((eq type 'after)
 981            (rng-apply-after
 982             `(lambda (p)
 983                (rng-intern-after p ,(rng-ipattern-get-after ipattern)))
 984             (rng-start-attribute-deriv (rng-ipattern-get-child ipattern)
 985                                        nm)))
 986           (t rng-not-allowed-ipattern))))
 987
 988 (defun rng-cons-group-after (x y)
 989   (rng-apply-after `(lambda (p) (rng-intern-group (cons p ',y)))
 990                    x))
 991
 992 (defun rng-subst-group-after (new old list)
 993   (rng-apply-after `(lambda (p)
 994                       (rng-intern-group (rng-substq p ,old ',list)))
 995                    new))
 996
 997 (defun rng-subst-interleave-after (new old list)
 998   (rng-apply-after `(lambda (p)
 999                       (rng-intern-interleave (rng-substq p ,old ',list)))
1000                    new))
1001
1002 (defun rng-apply-after (f ipattern)
1003   (let ((type (rng-ipattern-get-type ipattern)))
1004     (cond ((eq type 'after)
1005            (rng-intern-after
1006             (rng-ipattern-get-child ipattern)
1007             (funcall f
1008                      (rng-ipattern-get-after ipattern))))
1009           ((eq type 'choice)
1010            (rng-transform-choice `(lambda (x) (rng-apply-after ,f x))
1011                                  ipattern))
1012           (t rng-not-allowed-ipattern))))
1013
1014 (defun rng-start-tag-close-deriv (ipattern)
1015   (or (rng-ipattern-get-memo-start-tag-close-deriv ipattern)
1016       (rng-ipattern-set-memo-start-tag-close-deriv
1017        ipattern
1018        (rng-compute-start-tag-close-deriv ipattern))))
1019
1020 (defconst rng-transform-map
1021   '((choice . rng-transform-choice)
1022     (group . rng-transform-group)
1023     (interleave . rng-transform-interleave)
1024     (one-or-more . rng-transform-one-or-more)
1025     (after . rng-transform-after-child)))
1026
1027 (defun rng-compute-start-tag-close-deriv (ipattern)
1028   (let* ((type (rng-ipattern-get-type ipattern)))
1029     (if (eq type 'attribute)
1030         rng-not-allowed-ipattern
1031       (let ((transform (assq type rng-transform-map)))
1032         (if transform
1033             (funcall (cdr transform)
1034                      'rng-start-tag-close-deriv
1035                      ipattern)
1036           ipattern)))))
1037
1038 (defun rng-ignore-attributes-deriv (ipattern)
1039   (let* ((type (rng-ipattern-get-type ipattern)))
1040     (if (eq type 'attribute)
1041         rng-empty-ipattern
1042       (let ((transform (assq type rng-transform-map)))
1043         (if transform
1044             (funcall (cdr transform)
1045                      'rng-ignore-attributes-deriv
1046                      ipattern)
1047           ipattern)))))
1048
1049 (defun rng-text-only-deriv (ipattern)
1050   (or (rng-ipattern-get-memo-text-only-deriv ipattern)
1051       (rng-ipattern-set-memo-text-only-deriv
1052        ipattern
1053        (rng-compute-text-only-deriv ipattern))))
1054
1055 (defun rng-compute-text-only-deriv (ipattern)
1056   (let* ((type (rng-ipattern-get-type ipattern)))
1057     (if (eq type 'element)
1058         rng-not-allowed-ipattern
1059       (let ((transform (assq type
1060                              '((choice . rng-transform-choice)
1061                                (group . rng-transform-group)
1062                                (interleave . rng-transform-interleave)
1063                                (one-or-more . rng-transform-one-or-more)
1064                                (after . rng-transform-after-child)))))
1065         (if transform
1066             (funcall (cdr transform)
1067                      'rng-text-only-deriv
1068                      ipattern)
1069           ipattern)))))
1070
1071 (defun rng-mixed-text-deriv (ipattern)
1072   (or (rng-ipattern-get-memo-mixed-text-deriv ipattern)
1073       (rng-ipattern-set-memo-mixed-text-deriv
1074        ipattern
1075        (rng-compute-mixed-text-deriv ipattern))))
1076
1077 (defun rng-compute-mixed-text-deriv (ipattern)
1078   (let ((type (rng-ipattern-get-type ipattern)))
1079     (cond ((eq type 'text) ipattern)
1080           ((eq type 'after)
1081            (rng-transform-after-child 'rng-mixed-text-deriv
1082                                       ipattern))
1083           ((eq type 'choice)
1084            (rng-transform-choice 'rng-mixed-text-deriv
1085                                  ipattern))
1086           ((eq type 'one-or-more)
1087            (rng-intern-group
1088             (list (rng-mixed-text-deriv
1089                    (rng-ipattern-get-child ipattern))
1090                   (rng-intern-optional ipattern))))
1091           ((eq type 'group)
1092            (rng-transform-group-nullable
1093             'rng-mixed-text-deriv
1094             (lambda (x y) (rng-intern-group (cons x y)))
1095             ipattern))
1096           ((eq type 'interleave)
1097            (rng-transform-interleave-single
1098             'rng-mixed-text-deriv
1099             (lambda (new old list) (rng-intern-interleave
1100                                     (rng-substq new old list)))
1101             ipattern))
1102           ((and (eq type 'data)
1103                 (not (rng-ipattern-get-memo-text-typed ipattern)))
1104            ipattern)
1105           (t rng-not-allowed-ipattern))))
1106
1107 (defun rng-end-tag-deriv (ipattern)
1108   (or (rng-ipattern-get-memo-end-tag-deriv ipattern)
1109       (rng-ipattern-set-memo-end-tag-deriv
1110        ipattern
1111        (rng-compute-end-tag-deriv ipattern))))
1112
1113 (defun rng-compute-end-tag-deriv (ipattern)
1114   (let ((type (rng-ipattern-get-type ipattern)))
1115     (cond ((eq type 'choice)
1116            (rng-intern-choice
1117             (mapcar 'rng-end-tag-deriv
1118                     (rng-ipattern-get-child ipattern))))
1119           ((eq type 'after)
1120            (if (rng-ipattern-get-nullable
1121                 (rng-ipattern-get-child ipattern))
1122                (rng-ipattern-get-after ipattern)
1123              rng-not-allowed-ipattern))
1124           (t rng-not-allowed-ipattern))))
1125
1126 (defun rng-data-deriv (ipattern value)
1127   (or (rng-memo-map-get value
1128                         (rng-ipattern-get-memo-map-data-deriv ipattern))
1129       (and (rng-memo-map-get
1130             (cons value (rng-namespace-context-get-no-trace))
1131             (rng-ipattern-get-memo-map-data-deriv ipattern))
1132            (rng-memo-map-get
1133             (cons value (apply (car rng-dt-namespace-context-getter)
1134                                (cdr rng-dt-namespace-context-getter)))
1135             (rng-ipattern-get-memo-map-data-deriv ipattern)))
1136       (let* ((used-context (vector nil))
1137              (rng-dt-namespace-context-getter
1138               (cons 'rng-namespace-context-tracer
1139                     (cons used-context
1140                           rng-dt-namespace-context-getter)))
1141              (deriv (rng-compute-data-deriv ipattern value)))
1142         (rng-ipattern-memo-data-deriv ipattern
1143                                       value
1144                                       (aref used-context 0)
1145                                       deriv))))
1146
1147 (defun rng-namespace-context-tracer (used getter &rest args)
1148   (let ((context (apply getter args)))
1149     (aset used 0 context)
1150     context))
1151
1152 (defun rng-namespace-context-get-no-trace ()
1153   (let ((tem rng-dt-namespace-context-getter))
1154     (while (and tem (eq (car tem) 'rng-namespace-context-tracer))
1155       (setq tem (cddr tem)))
1156     (apply (car tem) (cdr tem))))
1157
1158 (defconst rng-memo-data-deriv-max-length 80
1159   "Don't memoize data-derivs for values longer than this.")
1160
1161 (defun rng-ipattern-memo-data-deriv (ipattern value context deriv)
1162   (or (memq ipattern rng-const-ipatterns)
1163       (> (length value) rng-memo-data-deriv-max-length)
1164       (rng-ipattern-set-memo-map-data-deriv
1165        ipattern
1166        (rng-memo-map-add (if context (cons value context) value)
1167                          deriv
1168                          (rng-ipattern-get-memo-map-data-deriv ipattern)
1169                          t)))
1170   deriv)
1171
1172 (defun rng-compute-data-deriv (ipattern value)
1173   (let ((type (rng-ipattern-get-type ipattern)))
1174     (cond ((eq type 'text) ipattern)
1175           ((eq type 'choice)
1176            (rng-transform-choice `(lambda (p) (rng-data-deriv p ,value))
1177                                  ipattern))
1178           ((eq type 'group)
1179            (rng-transform-group-nullable
1180             `(lambda (p) (rng-data-deriv p ,value))
1181             (lambda (x y) (rng-intern-group (cons x y)))
1182             ipattern))
1183           ((eq type 'one-or-more)
1184            (rng-intern-group (list (rng-data-deriv
1185                                     (rng-ipattern-get-child ipattern)
1186                                     value)
1187                                    (rng-intern-optional ipattern))))
1188           ((eq type 'after)
1189            (let ((child (rng-ipattern-get-child ipattern)))
1190              (if (or (rng-ipattern-get-nullable
1191                       (rng-data-deriv child value))
1192                      (and (rng-ipattern-get-nullable child)
1193                           (rng-blank-p value)))
1194                  (rng-ipattern-get-after ipattern)
1195                rng-not-allowed-ipattern)))
1196           ((eq type 'data)
1197            (if (rng-dt-make-value (rng-ipattern-get-datatype ipattern)
1198                                   value)
1199                rng-empty-ipattern
1200              rng-not-allowed-ipattern))
1201           ((eq type 'data-except)
1202            (if (and (rng-dt-make-value (rng-ipattern-get-datatype ipattern)
1203                                        value)
1204                     (not (rng-ipattern-get-nullable
1205                           (rng-data-deriv
1206                            (rng-ipattern-get-child ipattern)
1207                            value))))
1208                rng-empty-ipattern
1209              rng-not-allowed-ipattern))
1210           ((eq type 'value)
1211            (if (equal (rng-dt-make-value (rng-ipattern-get-datatype ipattern)
1212                                          value)
1213                       (rng-ipattern-get-value-object ipattern))
1214                rng-empty-ipattern
1215              rng-not-allowed-ipattern))
1216           ((eq type 'list)
1217            (let ((tokens (split-string value))
1218                  (state (rng-ipattern-get-child ipattern)))
1219              (while (and tokens
1220                          (not (eq state rng-not-allowed-ipattern)))
1221                (setq state (rng-data-deriv state (car tokens)))
1222                (setq tokens (cdr tokens)))
1223              (if (rng-ipattern-get-nullable state)
1224                  rng-empty-ipattern
1225                rng-not-allowed-ipattern)))
1226           ;; don't think interleave can occur
1227           ;; since we do text-only-deriv first
1228           (t rng-not-allowed-ipattern))))
1229
1230 (defun rng-transform-multi (f ipattern interner)
1231   (let* ((members (rng-ipattern-get-child ipattern))
1232          (transformed (mapcar f members)))
1233     (if (rng-members-eq members transformed)
1234         ipattern
1235       (funcall interner transformed))))
1236
1237 (defun rng-transform-choice (f ipattern)
1238   (rng-transform-multi f ipattern 'rng-intern-choice))
1239
1240 (defun rng-transform-group (f ipattern)
1241   (rng-transform-multi f ipattern 'rng-intern-group))
1242
1243 (defun rng-transform-interleave (f ipattern)
1244   (rng-transform-multi f ipattern 'rng-intern-interleave))
1245
1246 (defun rng-transform-one-or-more (f ipattern)
1247   (let* ((child (rng-ipattern-get-child ipattern))
1248          (transformed (funcall f child)))
1249     (if (eq child transformed)
1250         ipattern
1251       (rng-intern-one-or-more transformed))))
1252
1253 (defun rng-transform-after-child (f ipattern)
1254   (let* ((child (rng-ipattern-get-child ipattern))
1255          (transformed (funcall f child)))
1256     (if (eq child transformed)
1257         ipattern
1258       (rng-intern-after transformed
1259                         (rng-ipattern-get-after ipattern)))))
1260
1261 (defun rng-transform-interleave-single (f subster ipattern)
1262   (let ((children (rng-ipattern-get-child ipattern))
1263         found)
1264     (while (and children (not found))
1265       (let* ((child (car children))
1266              (transformed (funcall f child)))
1267         (if (eq transformed rng-not-allowed-ipattern)
1268             (setq children (cdr children))
1269           (setq found
1270                 (funcall subster
1271                          transformed
1272                          child
1273                          (rng-ipattern-get-child ipattern))))))
1274     (or found
1275         rng-not-allowed-ipattern)))
1276
1277 (defun rng-transform-group-nullable (f conser ipattern)
1278   "Given a group x1,...,xn,y1,...,yn where the xs are all
1279 nullable and y1 isn't, return a choice
1280   (conser f(x1) x2,...,xm,y1,...,yn)
1281   |(conser f(x2) x3,...,xm,y1,...,yn)
1282   |...
1283   |(conser f(xm) y1,...,yn)
1284   |(conser f(y1) y2,...,yn)"
1285   (rng-intern-choice
1286    (rng-transform-group-nullable-gen-choices
1287     f
1288     conser
1289     (rng-ipattern-get-child ipattern))))
1290
1291 (defun rng-transform-group-nullable-gen-choices (f conser members)
1292   (let ((head (car members))
1293         (tail (cdr members)))
1294     (if tail
1295         (cons (funcall conser (funcall f head) tail)
1296               (if (rng-ipattern-get-nullable head)
1297                   (rng-transform-group-nullable-gen-choices f conser tail)
1298                 nil))
1299       (list (funcall f head)))))
1300
1301 (defun rng-members-eq (list1 list2)
1302   (while (and list1
1303               list2
1304               (eq (car list1) (car list2)))
1305     (setq list1 (cdr list1))
1306     (setq list2 (cdr list2)))
1307   (and (null list1) (null list2)))
1308
1309
1310 (defun rng-ipattern-after (ipattern)
1311   (let ((type (rng-ipattern-get-type ipattern)))
1312     (cond ((eq type 'choice)
1313            (rng-transform-choice 'rng-ipattern-after ipattern))
1314           ((eq type 'after)
1315            (rng-ipattern-get-after ipattern))
1316           ((eq  type 'not-allowed)
1317            ipattern)
1318           (t (error "Internal error in rng-ipattern-after: unexpected type %s" type)))))
1319
1320 (defun rng-unknown-start-tag-open-deriv (ipattern)
1321   (rng-intern-after (rng-compile rng-any-content) ipattern))
1322
1323 (defun rng-ipattern-optionalize-elements (ipattern)
1324   (let* ((type (rng-ipattern-get-type ipattern))
1325          (transform (assq type rng-transform-map)))
1326     (cond (transform
1327            (funcall (cdr transform)
1328                     'rng-ipattern-optionalize-elements
1329                     ipattern))
1330           ((eq type 'element)
1331            (rng-intern-optional ipattern))
1332           (t ipattern))))
1333
1334 (defun rng-ipattern-empty-before-p (ipattern)
1335   (let ((type (rng-ipattern-get-type ipattern)))
1336     (cond ((eq type 'after)
1337            (eq (rng-ipattern-get-child ipattern) rng-empty-ipattern))
1338           ((eq type 'choice)
1339            (let ((members (rng-ipattern-get-child ipattern))
1340                  (ret t))
1341              (while (and members ret)
1342                (or (rng-ipattern-empty-before-p (car members))
1343                    (setq ret nil))
1344                (setq members (cdr members)))
1345              ret))
1346           (t nil))))
1347
1348 (defun rng-ipattern-possible-start-tags (ipattern accum)
1349   (let ((type (rng-ipattern-get-type ipattern)))
1350     (cond ((eq type 'after)
1351            (rng-ipattern-possible-start-tags
1352             (rng-ipattern-get-child ipattern)
1353             accum))
1354           ((memq type '(choice interleave))
1355            (let ((members (rng-ipattern-get-child ipattern)))
1356              (while members
1357                (setq accum
1358                      (rng-ipattern-possible-start-tags (car members)
1359                                                        accum))
1360                (setq members (cdr members))))
1361            accum)
1362           ((eq type 'group)
1363            (let ((members (rng-ipattern-get-child ipattern)))
1364              (while members
1365                (setq accum
1366                      (rng-ipattern-possible-start-tags (car members)
1367                                                        accum))
1368                (setq members
1369                      (and (rng-ipattern-get-nullable (car members))
1370                           (cdr members)))))
1371            accum)
1372           ((eq type 'element)
1373            (if (eq (rng-element-get-child ipattern) rng-not-allowed-ipattern)
1374                accum
1375              (rng-name-class-possible-names
1376               (rng-ipattern-get-name-class ipattern)
1377               accum)))
1378           ((eq type 'one-or-more)
1379            (rng-ipattern-possible-start-tags
1380             (rng-ipattern-get-child ipattern)
1381             accum))
1382           (t accum))))
1383
1384 (defun rng-ipattern-start-tag-possible-p (ipattern)
1385   (let ((type (rng-ipattern-get-type ipattern)))
1386     (cond ((memq type '(after one-or-more))
1387            (rng-ipattern-start-tag-possible-p
1388             (rng-ipattern-get-child ipattern)))
1389           ((memq type '(choice interleave))
1390            (let ((members (rng-ipattern-get-child ipattern))
1391                  (possible nil))
1392              (while (and members (not possible))
1393                (setq possible
1394                      (rng-ipattern-start-tag-possible-p (car members)))
1395                (setq members (cdr members)))
1396              possible))
1397           ((eq type 'group)
1398            (let ((members (rng-ipattern-get-child ipattern))
1399                  (possible nil))
1400              (while (and members (not possible))
1401                (setq possible
1402                      (rng-ipattern-start-tag-possible-p (car members)))
1403                (setq members
1404                      (and (rng-ipattern-get-nullable (car members))
1405                           (cdr members))))
1406              possible))
1407           ((eq type 'element)
1408            (not (eq (rng-element-get-child ipattern)
1409                     rng-not-allowed-ipattern)))
1410           (t nil))))
1411
1412 (defun rng-ipattern-possible-attributes (ipattern accum)
1413   (let ((type (rng-ipattern-get-type ipattern)))
1414     (cond ((eq type 'after)
1415            (rng-ipattern-possible-attributes (rng-ipattern-get-child ipattern)
1416                                              accum))
1417           ((memq type '(choice interleave group))
1418            (let ((members (rng-ipattern-get-child ipattern)))
1419              (while members
1420                (setq accum
1421                      (rng-ipattern-possible-attributes (car members)
1422                                                        accum))
1423                (setq members (cdr members))))
1424            accum)
1425           ((eq type 'attribute)
1426            (rng-name-class-possible-names
1427             (rng-ipattern-get-name-class ipattern)
1428             accum))
1429           ((eq type 'one-or-more)
1430            (rng-ipattern-possible-attributes
1431             (rng-ipattern-get-child ipattern)
1432             accum))
1433           (t accum))))
1434
1435 (defun rng-ipattern-possible-values (ipattern accum)
1436   (let ((type (rng-ipattern-get-type ipattern)))
1437     (cond ((eq type 'after)
1438            (rng-ipattern-possible-values (rng-ipattern-get-child ipattern)
1439                                          accum))
1440           ((eq type 'choice)
1441            (let ((members (rng-ipattern-get-child ipattern)))
1442              (while members
1443                (setq accum
1444                      (rng-ipattern-possible-values (car members)
1445                                                    accum))
1446                (setq members (cdr members))))
1447            accum)
1448           ((eq type 'value)
1449            (let ((value-object (rng-ipattern-get-value-object ipattern)))
1450              (if (stringp value-object)
1451                  (cons value-object accum)
1452                accum)))
1453           (t accum))))
1454
1455 (defun rng-ipattern-required-element (ipattern)
1456   (let ((type (rng-ipattern-get-type ipattern)))
1457     (cond ((memq type '(after one-or-more))
1458            (rng-ipattern-required-element (rng-ipattern-get-child ipattern)))
1459           ((eq type 'choice)
1460            (let* ((members (rng-ipattern-get-child ipattern))
1461                   (required (rng-ipattern-required-element (car members))))
1462              (while (and required
1463                          (setq members (cdr members)))
1464                (unless (equal required
1465                               (rng-ipattern-required-element (car members)))
1466                    (setq required nil)))
1467              required))
1468           ((eq type 'group)
1469            (let ((members (rng-ipattern-get-child ipattern))
1470                  required)
1471              (while (and (not (setq required
1472                                     (rng-ipattern-required-element
1473                                      (car members))))
1474                          (rng-ipattern-get-nullable (car members))
1475                          (setq members (cdr members))))
1476              required))
1477           ((eq type 'interleave)
1478            (let ((members (rng-ipattern-get-child ipattern))
1479                  required)
1480              (while members
1481                (let ((tem (rng-ipattern-required-element (car members))))
1482                  (cond ((not tem)
1483                         (setq members (cdr members)))
1484                        ((not required)
1485                         (setq required tem)
1486                         (setq members (cdr members)))
1487                        ((equal required tem)
1488                         (setq members (cdr members)))
1489                        (t
1490                         (setq required nil)
1491                         (setq members nil)))))
1492              required))
1493           ((eq type 'element)
1494            (let ((nc (rng-ipattern-get-name-class ipattern)))
1495              (and (consp nc)
1496                   (not (eq (rng-element-get-child ipattern)
1497                            rng-not-allowed-ipattern))
1498                   nc))))))
1499
1500 (defun rng-ipattern-required-attributes (ipattern accum)
1501   (let ((type (rng-ipattern-get-type ipattern)))
1502     (cond ((eq type 'after)
1503            (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern)
1504                                              accum))
1505           ((memq type '(interleave group))
1506            (let ((members (rng-ipattern-get-child ipattern)))
1507              (while members
1508                (setq accum
1509                      (rng-ipattern-required-attributes (car members)
1510                                                        accum))
1511                (setq members (cdr members))))
1512            accum)
1513           ((eq type 'choice)
1514            (let ((members (rng-ipattern-get-child ipattern))
1515                  in-all in-this new-in-all)
1516              (setq in-all
1517                    (rng-ipattern-required-attributes (car members)
1518                                                      nil))
1519              (while (and in-all (setq members (cdr members)))
1520                (setq in-this
1521                      (rng-ipattern-required-attributes (car members) nil))
1522                (setq new-in-all nil)
1523                (while in-this
1524                  (when (member (car in-this) in-all)
1525                    (setq new-in-all
1526                          (cons (car in-this) new-in-all)))
1527                  (setq in-this (cdr in-this)))
1528                (setq in-all new-in-all))
1529              (append in-all accum)))
1530           ((eq type 'attribute)
1531            (let ((nc (rng-ipattern-get-name-class ipattern)))
1532              (if (consp nc)
1533                  (cons nc accum)
1534                accum)))
1535           ((eq type 'one-or-more)
1536            (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern)
1537                                              accum))
1538           (t accum))))
1539
1540 (defun rng-compile-error (&rest args)
1541   (signal 'rng-compile-error
1542           (list (apply 'format args))))
1543
1544 (put 'rng-compile-error
1545      'error-conditions
1546      '(error rng-error rng-compile-error))
1547
1548 (put 'rng-compile-error
1549      'error-message
1550      "Incorrect schema")
1551
1552
1553 ;;; External API
1554
1555 (defsubst rng-match-state () rng-match-state)
1556
1557 (defsubst rng-set-match-state (state)
1558   (setq rng-match-state state))
1559
1560 (defsubst rng-match-state-equal (state)
1561   (eq state rng-match-state))
1562
1563 (defun rng-schema-changed ()
1564   (rng-ipattern-clear)
1565   (rng-compile-clear))
1566
1567 (defun rng-match-init-buffer ()
1568   (make-local-variable 'rng-compile-table)
1569   (make-local-variable 'rng-ipattern-table)
1570   (make-local-variable 'rng-last-ipattern-index))
1571
1572 (defun rng-match-start-document ()
1573   (rng-ipattern-maybe-init)
1574   (rng-compile-maybe-init)
1575   (add-hook 'rng-schema-change-hook 'rng-schema-changed nil t)
1576   (setq rng-match-state (rng-compile rng-current-schema)))
1577
1578 (defun rng-match-start-tag-open (name)
1579   (rng-update-match-state (rng-start-tag-open-deriv rng-match-state
1580                                                     name)))
1581
1582 (defun rng-match-attribute-name (name)
1583   (rng-update-match-state (rng-start-attribute-deriv rng-match-state
1584                                                      name)))
1585
1586 (defun rng-match-attribute-value (value)
1587   (rng-update-match-state (rng-data-deriv rng-match-state
1588                                           value)))
1589
1590 (defun rng-match-element-value (value)
1591   (and (rng-update-match-state (rng-text-only-deriv rng-match-state))
1592        (rng-update-match-state (rng-data-deriv rng-match-state
1593                                                value))))
1594
1595 (defun rng-match-start-tag-close ()
1596   (rng-update-match-state (rng-start-tag-close-deriv rng-match-state)))
1597
1598 (defun rng-match-mixed-text ()
1599   (rng-update-match-state (rng-mixed-text-deriv rng-match-state)))
1600
1601 (defun rng-match-end-tag ()
1602   (rng-update-match-state (rng-end-tag-deriv rng-match-state)))
1603
1604 (defun rng-match-after ()
1605   (rng-update-match-state
1606    (rng-ipattern-after rng-match-state)))
1607
1608 (defun rng-match-out-of-context-start-tag-open (name)
1609   (let* ((found (rng-map-element-attribute 'rng-find-element-content-pattern
1610                                            rng-current-schema
1611                                            nil
1612                                            name))
1613          (content-pattern (if found
1614                               (rng-intern-choice found)
1615                             rng-not-allowed-ipattern)))
1616     (rng-update-match-state
1617      (rng-intern-after content-pattern rng-match-state))))
1618
1619 (defun rng-match-possible-namespace-uris ()
1620   "Return a list of all the namespace URIs used in the current schema.
1621 The absent URI is not included, so the result is always list of symbols."
1622   (rng-map-element-attribute (lambda (pattern accum)
1623                                (rng-find-name-class-uris (nth 1 pattern)
1624                                                          accum))
1625                              rng-current-schema
1626                              nil))
1627
1628 (defun rng-match-unknown-start-tag-open ()
1629   (rng-update-match-state
1630    (rng-unknown-start-tag-open-deriv rng-match-state)))
1631
1632 (defun rng-match-optionalize-elements ()
1633   (rng-update-match-state
1634    (rng-ipattern-optionalize-elements rng-match-state)))
1635
1636 (defun rng-match-ignore-attributes ()
1637   (rng-update-match-state
1638    (rng-ignore-attributes-deriv rng-match-state)))
1639
1640 (defun rng-match-text-typed-p ()
1641   (rng-ipattern-text-typed-p rng-match-state))
1642
1643 (defun rng-match-empty-content ()
1644   (if (rng-match-text-typed-p)
1645       (rng-match-element-value "")
1646     (rng-match-end-tag)))
1647
1648 (defun rng-match-empty-before-p ()
1649   "Return non-nil if what can be matched before an end-tag is empty.
1650 In other words, return non-nil if the pattern for what can be matched
1651 for an end-tag is equivalent to empty."
1652   (rng-ipattern-empty-before-p rng-match-state))
1653
1654 (defun rng-match-infer-start-tag-namespace (local-name)
1655   (let ((ncs (rng-ipattern-possible-start-tags rng-match-state nil))
1656         (nc nil)
1657         (ns nil))
1658     (while ncs
1659       (setq nc (car ncs))
1660       (if (and (equal (cdr nc) local-name)
1661                (symbolp (car nc)))
1662           (cond ((not ns)
1663                  ;; first possible namespace
1664                  (setq ns (car nc))
1665                  (setq ncs (cdr ncs)))
1666                 ((equal ns (car nc))
1667                  ;; same as first namespace
1668                  (setq ncs (cdr ncs)))
1669                 (t
1670                  ;; more than one possible namespace
1671                  (setq ns nil)
1672                  (setq ncs nil)))
1673         (setq ncs (cdr ncs))))
1674     ns))
1675
1676 (defun rng-match-nullable-p ()
1677   (rng-ipattern-get-nullable rng-match-state))
1678
1679 (defun rng-match-possible-start-tag-names ()
1680   "Return a list of possible names that would be valid for start-tags.
1681
1682 Each possible name is returned as a (NAMESPACE . LOCAL-NAME) pair,
1683 where NAMESPACE is a symbol or nil (meaning the absent namespace) and
1684 LOCAL-NAME is a string. The returned list may contain duplicates."
1685   (rng-ipattern-possible-start-tags rng-match-state nil))
1686
1687 ;; This is no longer used.  It might be useful so leave it in for now.
1688 (defun rng-match-start-tag-possible-p ()
1689   "Return non-nil if a start-tag is possible."
1690   (rng-ipattern-start-tag-possible-p rng-match-state))
1691
1692 (defun rng-match-possible-attribute-names ()
1693   "Return a list of possible names that would be valid for attributes.
1694
1695 See the function `rng-match-possible-start-tag-names' for
1696 more information."
1697   (rng-ipattern-possible-attributes rng-match-state nil))
1698
1699 (defun rng-match-possible-value-strings ()
1700   "Return a list of strings that would be valid as content.
1701 The list may contain duplicates. Typically, the list will not
1702 be exhaustive."
1703   (rng-ipattern-possible-values rng-match-state nil))
1704
1705 (defun rng-match-required-element-name ()
1706   "Return the name of an element which must occur, or nil if none."
1707   (rng-ipattern-required-element rng-match-state))
1708
1709 (defun rng-match-required-attribute-names ()
1710   "Return a list of names of attributes which must all occur."
1711   (rng-ipattern-required-attributes rng-match-state nil))
1712
1713 (defmacro rng-match-save (&rest body)
1714   (let ((state (make-symbol "state")))
1715     `(let ((,state rng-match-state))
1716        (unwind-protect
1717            (progn ,@body)
1718          (setq rng-match-state ,state)))))
1719
1720 (put 'rng-match-save 'lisp-indent-function 0)
1721 (def-edebug-spec rng-match-save t)
1722
1723 (defmacro rng-match-with-schema (schema &rest body)
1724   `(let ((rng-current-schema ,schema)
1725          rng-match-state
1726          rng-compile-table
1727          rng-ipattern-table
1728          rng-last-ipattern-index)
1729      (rng-ipattern-maybe-init)
1730      (rng-compile-maybe-init)
1731      (setq rng-match-state (rng-compile rng-current-schema))
1732      ,@body))
1733
1734 (put 'rng-match-with-schema 'lisp-indent-function 1)
1735 (def-edebug-spec rng-match-with-schema t)
1736
1737 (provide 'rng-match)
1738
1739 ;; arch-tag: c8c50733-edcf-49fb-85e2-0aac8749b7f8
1740 ;;; rng-match.el ends here