lisp/nxml/rng-match.el

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