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