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