1 ;;; rng-match.el --- matching of RELAX NG patterns against XML events -*- lexical-binding:t -*-
3 ;; Copyright (C) 2003, 2007-2015 Free Software Foundation, Inc.
6 ;; Keywords: wp, hypermedia, languages, XML, RelaxNG
8 ;; This file is part of GNU Emacs.
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.
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.
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/>.
25 ;; This uses the algorithm described in
26 ;; http://www.thaiopensource.com/relaxng/derivative.html
28 ;; The schema to be used is contained in the variable
29 ;; rng-current-schema. It has the form described in the file
37 (eval-when-compile (require 'cl-lib
))
39 (defvar rng-not-allowed-ipattern nil
)
40 (defvar rng-empty-ipattern nil
)
41 (defvar rng-text-ipattern nil
)
43 (defvar rng-compile-table nil
)
45 (defvar rng-being-compiled nil
46 "Contains a list of ref patterns currently being compiled.
47 Used to detect invalid recursive references.")
49 (defvar rng-ipattern-table nil
)
51 (defvar rng-last-ipattern-index nil
)
53 (defvar rng-match-state nil
54 "An ipattern representing the current state of validation.")
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
)))
62 (setq rng-match-state new-state
)
67 (cl-defstruct (rng--ipattern
71 (:constructor rng-make-ipattern
72 (type index name-class child nullable
)))
75 name-class
;; Field also known as: `datatype' and `after'.
76 child
;; Field also known as: `value-object'.
78 (memo-text-typed 'unknown
)
79 memo-map-start-tag-open-deriv
80 memo-map-start-attribute-deriv
81 memo-start-tag-close-deriv
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
)
93 (defconst rng-memo-map-alist-max
10)
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
)))
101 (let ((head (car mm
)))
102 (and (hash-table-p head
)
103 (gethash key head
)))))))
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.
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)."
120 (list 1 (cons key value
))
121 (let ((head (car mm
)))
122 (cond ((hash-table-p head
)
123 (puthash key value head
)
125 ((>= head rng-memo-map-alist-max
)
126 (let ((ht (make-hash-table :test
'equal
128 :size
(* 2 rng-memo-map-alist-max
))))
132 (puthash (car head
) (cdr head
) ht
)
136 (cons (cons key value
)
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)))
144 (defun rng-ipattern-clear ()
145 (when rng-ipattern-table
146 (clrhash rng-ipattern-table
))
147 (setq rng-last-ipattern-index -
1))
149 (defsubst rng-gen-ipattern-index
()
150 (setq rng-last-ipattern-index
(1+ rng-last-ipattern-index
)))
152 (defun rng-put-ipattern (key type name-class child nullable
)
154 (rng-make-ipattern type
155 (rng-gen-ipattern-index)
159 (puthash key ipattern rng-ipattern-table
)
162 (defun rng-get-ipattern (key)
163 (gethash key rng-ipattern-table
))
165 (or rng-not-allowed-ipattern
166 (setq rng-not-allowed-ipattern
167 (rng-make-ipattern 'not-allowed -
3 nil nil nil
)))
169 (or rng-empty-ipattern
170 (setq rng-empty-ipattern
171 (rng-make-ipattern 'empty -
2 nil nil t
)))
173 (or rng-text-ipattern
174 (setq rng-text-ipattern
175 (rng-make-ipattern 'text -
1 nil nil t
)))
177 (defconst rng-const-ipatterns
178 (list rng-not-allowed-ipattern
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
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
200 (rng--ipattern-index ipattern
))))
201 (or (rng-get-ipattern key
)
202 (rng-put-ipattern key
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
216 (setf (rng--ipattern-memo-text-typed ipattern
)
217 (not matches-anything
))
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
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
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
247 (rng--ipattern-nullable ipattern
))))))
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
)
254 ((eq (rng--ipattern-type ipattern
) 'one-or-more
)
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
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
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
)))
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
)
300 (setq ipatterns nil
))
301 ((eq tem rng-empty-ipattern
)
302 (setq ipatterns
(cdr ipatterns
)))
304 ;; Stop here rather than continuing
305 ;; looking for not-allowed patterns.
306 ;; We do a complete scan elsewhere.
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."
320 (setq member
(car ipatterns
))
321 (setq ipatterns
(cdr ipatterns
))
323 (setq nullable
(rng--ipattern-nullable member
)))
324 (cond ((eq (rng--ipattern-type member
) 'group
)
326 (nconc (reverse (rng--ipattern-child member
))
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
))))
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
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."
358 (setq member
(car ipatterns
))
359 (setq ipatterns
(cdr ipatterns
))
361 (setq nullable
(rng--ipattern-nullable member
)))
362 (cond ((eq (rng--ipattern-type member
) 'interleave
)
364 (append (rng--ipattern-child member
)
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
))))
373 ;; Would be cleaner if this didn't modify IPATTERNS.
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
))))))
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
)
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
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
414 rng-not-allowed-ipattern
))
415 (setq ipatterns
(cdr 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
)
423 (setq ipatterns
(cdr ipatterns
)))
425 rng-not-allowed-ipattern
))
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."
434 (head (cons nil ipatterns
)))
440 ;; the cdr of tail is always cur
442 (setq member
(car cur
))
444 (setq nullable
(rng--ipattern-nullable member
)))
445 (cond ((eq (rng--ipattern-type member
) 'choice
)
447 (append (rng--ipattern-child member
)
452 ((eq member rng-not-allowed-ipattern
)
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
)
470 (setq cur
(cdr cur
))))))
471 (setcdr tail final-tail
))
472 (setq head
(cdr head
))
476 (rng-uniquify-eq (sort head
'rng-compare-ipattern
))))))
478 (defun rng-compare-ipattern (p1 p2
)
479 (< (rng--ipattern-index p1
)
480 (rng--ipattern-index p2
)))
484 (defsubst rng-name-class-contains
(nc nm
)
487 (rng-name-class-contains1 nc nm
)))
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
)))
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
))))
500 (let ((choices (aref nc
1))
503 (if (rng-name-class-contains (car choices
) nm
)
507 (setq choices
(cdr choices
))))
510 (defun rng-name-class-possible-names (nc accum
)
511 "Return a list of possible names that nameclass NC can match.
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."
520 (when (eq (aref nc
0) 'choice
)
521 (let ((members (aref nc
1)) member
)
523 (setq member
(car members
))
527 (rng-name-class-possible-names member
529 (setq members
(cdr members
)))))
532 ;;; Debugging utilities
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
))
540 (rng-ipattern-to-string
541 (rng--ipattern-after ipattern
))))
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
548 ((eq type
'attribute
)
550 (rng-name-class-to-string
551 (rng--ipattern-name-class ipattern
))
553 (rng-ipattern-to-string
554 (rng--ipattern-child ipattern
))
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
))
565 (mapconcat 'rng-ipattern-to-string
566 (rng--ipattern-child ipattern
)
571 (mapconcat 'rng-ipattern-to-string
572 (rng--ipattern-child ipattern
)
575 ((eq type
'interleave
)
577 (mapconcat 'rng-ipattern-to-string
578 (rng--ipattern-child ipattern
)
581 (t (symbol-name type
)))))
583 (defun rng-name-class-to-string (nc)
586 (let ((type (aref nc
0)))
587 (cond ((eq type
'choice
)
588 (mapconcat 'rng-name-class-to-string
591 (t (concat (symbol-name type
) "*"))))))
596 (defun rng-compile-maybe-init ()
597 (unless rng-compile-table
598 (setq rng-compile-table
(make-hash-table :test
'eq
))))
600 (defun rng-compile-clear ()
601 (when rng-compile-table
602 (clrhash rng-compile-table
)))
604 (defun rng-compile (pattern)
605 (or (gethash pattern rng-compile-table
)
606 (let ((ipattern (apply (get (car pattern
) 'rng-compile
)
608 (puthash pattern ipattern rng-compile-table
)
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
)
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
)
633 (defun rng-compile-element (name-class pattern
)
635 (rng-make-ipattern 'element
636 (rng-gen-ipattern-index)
637 (rng-compile-name-class name-class
)
638 pattern
; compile lazily
641 (defun rng-element-get-child (element)
642 (let ((tem (rng--ipattern-child element
)))
645 (setf (rng--ipattern-child element
) (rng-compile tem
)))))
647 (defun rng-compile-attribute (name-class pattern
)
648 (rng-intern-attribute (rng-compile-name-class name-class
)
649 (rng-compile pattern
)))
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
))
657 (rng-compile pattern
)
658 (setq rng-being-compiled
659 (cdr rng-being-compiled
))))
661 (defun rng-compile-one-or-more (pattern)
662 (rng-intern-one-or-more (rng-compile pattern
)))
664 (defun rng-compile-zero-or-more (pattern)
666 (rng-intern-one-or-more (rng-compile pattern
))))
668 (defun rng-compile-optional (pattern)
669 (rng-intern-optional (rng-compile pattern
)))
671 (defun rng-compile-mixed (pattern)
672 (rng-intern-interleave (cons rng-text-ipattern
673 (list (rng-compile pattern
)))))
675 (defun rng-compile-list (pattern)
676 (rng-intern-list (rng-compile pattern
)))
678 (defun rng-compile-choice (&rest patterns
)
679 (rng-intern-choice (mapcar 'rng-compile patterns
)))
681 (defun rng-compile-group (&rest patterns
)
682 (rng-intern-group (mapcar 'rng-compile patterns
)))
684 (defun rng-compile-interleave (&rest patterns
)
685 (rng-intern-interleave (mapcar 'rng-compile patterns
)))
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
)))
695 (defun rng-compile-data (name params
)
696 (let ((dt (rng-compile-dt name params
)))
697 (rng-intern-data (cdr dt
) (car dt
))))
699 (defun rng-compile-data-except (name params pattern
)
700 (rng-intern-data-except (cdr (rng-compile-dt name params
))
701 (rng-compile pattern
)))
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
)))
708 (rng-intern-value dt obj
)
709 (rng-compile-error "Value %s is not a valid instance of the datatype %s"
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
))))
721 (vector 'ns-name
(nth 1 nc
)))
722 ((eq type
'ns-name-except
)
723 (vector 'ns-name-except
725 (rng-compile-name-class (nth 2 nc
))))
728 (mapcar 'rng-compile-name-class
(cdr nc
))))
729 (t (error "Bad name-class type %s" type
)))))
731 ;;; Searching patterns
733 ;; We write this non-recursively to avoid hitting max-lisp-eval-depth
736 (defun rng-map-element-attribute (function pattern accum
&rest args
)
737 (let ((searched (make-hash-table :test
'eq
))
740 (setq type
(car pattern
))
741 (cond ((memq type
'(element attribute
))
746 (setq pattern
(nth 2 pattern
)))
748 (setq pattern
(nth 1 pattern
))
749 (if (gethash pattern searched
)
751 (puthash pattern t searched
)))
752 ((memq type
'(choice group interleave
))
753 (setq todo
(cons (cdr pattern
) todo
))
755 ((memq type
'(one-or-more
759 (setq pattern
(nth 1 pattern
)))
760 (t (setq pattern nil
)))
763 (setq pattern
(car patterns
))
764 (setq patterns
(cdr patterns
))
767 (setq patterns
(car todo
))
768 (setq todo
(cdr todo
))
769 (setq pattern
(car patterns
))
770 (setq patterns
(cdr patterns
))
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
)
780 (defun rng-search-name (name nc
)
781 (let ((type (car nc
)))
782 (cond ((eq type
'name
)
783 (equal (cadr nc
) name
))
785 (let ((choices (cdr nc
))
787 (while (and choices
(not found
))
788 (if (rng-search-name name
(car choices
))
790 (setq choices
(cdr choices
))))
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
))
801 (let ((choices (cdr nc
)))
804 (rng-find-name-class-uris (car choices
) accum
))
805 (setq choices
(cdr choices
))))
809 (defun rng-accum-namespace-uri (ns accum
)
810 (if (and ns
(not (memq ns accum
)))
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
))
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
))
828 (while (and cur
(not ret
))
829 (if (rng-ipattern-text-typed-p (car cur
))
831 (setq cur
(cdr cur
))))
834 (let ((cur (rng--ipattern-child ipattern
))
837 (while (and cur
(not ret
))
838 (setq member
(car cur
))
839 (if (rng-ipattern-text-typed-p member
)
842 (and (rng--ipattern-nullable member
)
846 (rng-ipattern-text-typed-p (rng--ipattern-child ipattern
)))
847 (t (and (memq type
'(value list data data-except
)) t
)))))
849 (defun rng-start-tag-open-deriv (ipattern nm
)
850 (or (rng-memo-map-get
852 (rng--ipattern-memo-map-start-tag-open-deriv ipattern
))
853 (rng-ipattern-memo-start-tag-open-deriv
856 (rng-compute-start-tag-open-deriv ipattern nm
))))
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
)
863 (rng--ipattern-memo-map-start-tag-open-deriv
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
))
874 (if (rng-name-class-contains
875 (rng--ipattern-name-class ipattern
)
877 (rng-intern-after (rng-element-get-child ipattern
)
879 rng-not-allowed-ipattern
))
881 (rng-transform-group-nullable
882 (lambda (p) (rng-start-tag-open-deriv p nm
))
883 'rng-cons-group-after
885 ((eq type
'interleave
)
886 (rng-transform-interleave-single
887 (lambda (p) (rng-start-tag-open-deriv p nm
))
888 'rng-subst-interleave-after
890 ((eq type
'one-or-more
)
891 (let ((ip (rng-intern-optional ipattern
)))
893 (lambda (p) (rng-intern-group (list p ip
)))
894 (rng-start-tag-open-deriv (rng--ipattern-child ipattern
)
897 (let ((nip (rng--ipattern-after ipattern
)))
899 (lambda (p) (rng-intern-after p nip
))
900 (rng-start-tag-open-deriv (rng--ipattern-child ipattern
)
902 (t rng-not-allowed-ipattern
))))
904 (defun rng-start-attribute-deriv (ipattern nm
)
905 (or (rng-memo-map-get
907 (rng--ipattern-memo-map-start-attribute-deriv ipattern
))
908 (rng-ipattern-memo-start-attribute-deriv
911 (rng-compute-start-attribute-deriv ipattern nm
))))
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
)
919 (rng--ipattern-memo-map-start-attribute-deriv ipattern
))))
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
))
928 ((eq type
'attribute
)
929 (if (rng-name-class-contains
930 (rng--ipattern-name-class ipattern
)
932 (rng-intern-after (rng--ipattern-child ipattern
)
934 rng-not-allowed-ipattern
))
936 (rng-transform-interleave-single
937 (lambda (p) (rng-start-attribute-deriv p nm
))
938 'rng-subst-group-after
940 ((eq type
'interleave
)
941 (rng-transform-interleave-single
942 (lambda (p) (rng-start-attribute-deriv p nm
))
943 'rng-subst-interleave-after
945 ((eq type
'one-or-more
)
946 (let ((ip (rng-intern-optional ipattern
)))
948 (lambda (p) (rng-intern-group (list p ip
)))
949 (rng-start-attribute-deriv (rng--ipattern-child ipattern
)
952 (let ((nip (rng--ipattern-after ipattern
)))
954 (lambda (p) (rng-intern-after p nip
))
955 (rng-start-attribute-deriv (rng--ipattern-child ipattern
)
957 (t rng-not-allowed-ipattern
))))
959 (defun rng-cons-group-after (x y
)
960 (rng-apply-after (lambda (p) (rng-intern-group (cons p y
)))
963 (defun rng-subst-group-after (new old list
)
964 (rng-apply-after (lambda (p)
965 (rng-intern-group (rng-substq p old list
)))
968 (defun rng-subst-interleave-after (new old list
)
969 (rng-apply-after (lambda (p)
970 (rng-intern-interleave (rng-substq p old list
)))
973 (defun rng-apply-after (f ipattern
)
974 (let ((type (rng--ipattern-type ipattern
)))
975 (cond ((eq type
'after
)
977 (rng--ipattern-child ipattern
)
978 (funcall f
(rng--ipattern-after ipattern
))))
980 (rng-transform-choice (lambda (x) (rng-apply-after f x
))
982 (t rng-not-allowed-ipattern
))))
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
))))
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
)))
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
)))
1002 (funcall (cdr transform
)
1003 'rng-start-tag-close-deriv
1007 (defun rng-ignore-attributes-deriv (ipattern)
1008 (let* ((type (rng--ipattern-type ipattern
)))
1009 (if (eq type
'attribute
)
1011 (let ((transform (assq type rng-transform-map
)))
1013 (funcall (cdr transform
)
1014 'rng-ignore-attributes-deriv
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
))))
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
)))))
1034 (funcall (cdr transform
)
1035 'rng-text-only-deriv
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
))))
1044 (defun rng-compute-mixed-text-deriv (ipattern)
1045 (let ((type (rng--ipattern-type ipattern
)))
1046 (cond ((eq type
'text
) ipattern
)
1048 (rng-transform-after-child 'rng-mixed-text-deriv
1051 (rng-transform-choice 'rng-mixed-text-deriv
1053 ((eq type
'one-or-more
)
1055 (list (rng-mixed-text-deriv
1056 (rng--ipattern-child ipattern
))
1057 (rng-intern-optional ipattern
))))
1059 (rng-transform-group-nullable
1060 'rng-mixed-text-deriv
1061 (lambda (x y
) (rng-intern-group (cons x y
)))
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
)))
1069 ((and (eq type
'data
)
1070 (not (rng--ipattern-memo-text-typed ipattern
)))
1072 (t rng-not-allowed-ipattern
))))
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
))))
1079 (defun rng-compute-end-tag-deriv (ipattern)
1080 (let ((type (rng--ipattern-type ipattern
)))
1081 (cond ((eq type
'choice
)
1083 (mapcar 'rng-end-tag-deriv
1084 (rng--ipattern-child ipattern
))))
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
))))
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
))
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
1106 rng-dt-namespace-context-getter
)))
1107 (deriv (rng-compute-data-deriv ipattern value
)))
1108 (rng-ipattern-memo-data-deriv ipattern
1110 (aref used-context
0)
1113 (defun rng-namespace-context-tracer (used getter
&rest args
)
1114 (let ((context (apply getter args
)))
1115 (aset used
0 context
)
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
))))
1124 (defconst rng-memo-data-deriv-max-length
80
1125 "Don't memoize data-derivs for values longer than this.")
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
)
1133 (rng--ipattern-memo-map-data-deriv ipattern
)
1137 (defun rng-compute-data-deriv (ipattern value
)
1138 (let ((type (rng--ipattern-type ipattern
)))
1139 (cond ((eq type
'text
) ipattern
)
1141 (rng-transform-choice (lambda (p) (rng-data-deriv p value
))
1144 (rng-transform-group-nullable
1145 (lambda (p) (rng-data-deriv p value
))
1146 (lambda (x y
) (rng-intern-group (cons x y
)))
1148 ((eq type
'one-or-more
)
1149 (rng-intern-group (list (rng-data-deriv
1150 (rng--ipattern-child ipattern
)
1152 (rng-intern-optional ipattern
))))
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
)))
1162 (if (rng-dt-make-value (rng--ipattern-datatype ipattern
)
1165 rng-not-allowed-ipattern
))
1166 ((eq type
'data-except
)
1167 (if (and (rng-dt-make-value (rng--ipattern-datatype ipattern
)
1169 (not (rng--ipattern-nullable
1171 (rng--ipattern-child ipattern
)
1174 rng-not-allowed-ipattern
))
1176 (if (equal (rng-dt-make-value (rng--ipattern-datatype ipattern
)
1178 (rng--ipattern-value-object ipattern
))
1180 rng-not-allowed-ipattern
))
1182 (let ((tokens (split-string value
))
1183 (state (rng--ipattern-child ipattern
)))
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
)
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
))))
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
)
1200 (funcall interner transformed
))))
1202 (defun rng-transform-choice (f ipattern
)
1203 (rng-transform-multi f ipattern
'rng-intern-choice
))
1205 (defun rng-transform-group (f ipattern
)
1206 (rng-transform-multi f ipattern
'rng-intern-group
))
1208 (defun rng-transform-interleave (f ipattern
)
1209 (rng-transform-multi f ipattern
'rng-intern-interleave
))
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
)
1216 (rng-intern-one-or-more transformed
))))
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
)
1223 (rng-intern-after transformed
1224 (rng--ipattern-after ipattern
)))))
1226 (defun rng-transform-interleave-single (f subster ipattern
)
1227 (let ((children (rng--ipattern-child ipattern
))
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
))
1238 (rng--ipattern-child ipattern
))))))
1240 rng-not-allowed-ipattern
)))
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)
1248 |(conser f(xm) y1,...,yn)
1249 |(conser f(y1) y2,...,yn)"
1251 (rng-transform-group-nullable-gen-choices
1254 (rng--ipattern-child ipattern
))))
1256 (defun rng-transform-group-nullable-gen-choices (f conser members
)
1257 (let ((head (car members
))
1258 (tail (cdr members
)))
1260 (cons (funcall conser
(funcall f head
) tail
)
1261 (if (rng--ipattern-nullable head
)
1262 (rng-transform-group-nullable-gen-choices f conser tail
)
1264 (list (funcall f head
)))))
1266 (defun rng-members-eq (list1 list2
)
1269 (eq (car list1
) (car list2
)))
1270 (setq list1
(cdr list1
))
1271 (setq list2
(cdr list2
)))
1272 (and (null list1
) (null list2
)))
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
))
1280 (rng--ipattern-after ipattern
))
1281 ((eq type
'not-allowed
)
1283 (t (error "Internal error in rng-ipattern-after: unexpected type %s" type
)))))
1285 (defun rng-unknown-start-tag-open-deriv (ipattern)
1286 (rng-intern-after (rng-compile rng-any-content
) ipattern
))
1288 (defun rng-ipattern-optionalize-elements (ipattern)
1289 (let* ((type (rng--ipattern-type ipattern
))
1290 (transform (assq type rng-transform-map
)))
1292 (funcall (cdr transform
)
1293 'rng-ipattern-optionalize-elements
1296 (rng-intern-optional ipattern
))
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
))
1304 (let ((members (rng--ipattern-child ipattern
))
1306 (while (and members ret
)
1307 (or (rng-ipattern-empty-before-p (car members
))
1309 (setq members
(cdr members
)))
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
)
1319 ((memq type
'(choice interleave
))
1320 (let ((members (rng--ipattern-child ipattern
)))
1323 (rng-ipattern-possible-start-tags (car members
)
1325 (setq members
(cdr members
))))
1328 (let ((members (rng--ipattern-child ipattern
)))
1331 (rng-ipattern-possible-start-tags (car members
)
1334 (and (rng--ipattern-nullable (car members
))
1338 (if (eq (rng-element-get-child ipattern
) rng-not-allowed-ipattern
)
1340 (rng-name-class-possible-names
1341 (rng--ipattern-name-class ipattern
)
1343 ((eq type
'one-or-more
)
1344 (rng-ipattern-possible-start-tags
1345 (rng--ipattern-child ipattern
)
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
))
1357 (while (and members
(not possible
))
1359 (rng-ipattern-start-tag-possible-p (car members
)))
1360 (setq members
(cdr members
)))
1363 (let ((members (rng--ipattern-child ipattern
))
1365 (while (and members
(not possible
))
1367 (rng-ipattern-start-tag-possible-p (car members
)))
1369 (and (rng--ipattern-nullable (car members
))
1373 (not (eq (rng-element-get-child ipattern
)
1374 rng-not-allowed-ipattern
)))
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
)
1382 ((memq type
'(choice interleave group
))
1383 (let ((members (rng--ipattern-child ipattern
)))
1386 (rng-ipattern-possible-attributes (car members
)
1388 (setq members
(cdr members
))))
1390 ((eq type
'attribute
)
1391 (rng-name-class-possible-names
1392 (rng--ipattern-name-class ipattern
)
1394 ((eq type
'one-or-more
)
1395 (rng-ipattern-possible-attributes
1396 (rng--ipattern-child ipattern
)
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
)
1406 (let ((members (rng--ipattern-child ipattern
)))
1409 (rng-ipattern-possible-values (car members
)
1411 (setq members
(cdr members
))))
1414 (let ((value-object (rng--ipattern-value-object ipattern
)))
1415 (if (stringp value-object
)
1416 (cons value-object accum
)
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
)))
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
)))
1434 (let ((members (rng--ipattern-child ipattern
))
1436 (while (and (not (setq required
1437 (rng-ipattern-required-element
1439 (rng--ipattern-nullable (car members
))
1440 (setq members
(cdr members
))))
1442 ((eq type
'interleave
)
1443 (let ((members (rng--ipattern-child ipattern
))
1446 (let ((tem (rng-ipattern-required-element (car members
))))
1448 (setq members
(cdr members
)))
1451 (setq members
(cdr members
)))
1452 ((equal required tem
)
1453 (setq members
(cdr members
)))
1456 (setq members nil
)))))
1459 (let ((nc (rng--ipattern-name-class ipattern
)))
1461 (not (eq (rng-element-get-child ipattern
)
1462 rng-not-allowed-ipattern
))
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
)
1470 ((memq type
'(interleave group
))
1471 (let ((members (rng--ipattern-child ipattern
)))
1474 (rng-ipattern-required-attributes (car members
)
1476 (setq members
(cdr members
))))
1479 (let ((members (rng--ipattern-child ipattern
))
1480 in-all in-this new-in-all
)
1482 (rng-ipattern-required-attributes (car members
)
1484 (while (and in-all
(setq members
(cdr members
)))
1486 (rng-ipattern-required-attributes (car members
) nil
))
1487 (setq new-in-all nil
)
1489 (when (member (car in-this
) 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
)))
1500 ((eq type
'one-or-more
)
1501 (rng-ipattern-required-attributes (rng--ipattern-child ipattern
)
1505 (defun rng-compile-error (&rest args
)
1506 (signal 'rng-compile-error
1507 (list (apply #'format-message args
))))
1509 (define-error 'rng-compile-error
"Incorrect schema" 'rng-error
)
1513 (defsubst rng-match-state
() rng-match-state
)
1515 (defsubst rng-set-match-state
(state)
1516 (setq rng-match-state state
))
1518 (defsubst rng-match-state-equal
(state)
1519 (eq state rng-match-state
))
1521 (defun rng-schema-changed ()
1522 (rng-ipattern-clear)
1523 (rng-compile-clear))
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
))
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
)))
1536 (defun rng-match-start-tag-open (name)
1537 (rng-update-match-state (rng-start-tag-open-deriv rng-match-state
1540 (defun rng-match-attribute-name (name)
1541 (rng-update-match-state (rng-start-attribute-deriv rng-match-state
1544 (defun rng-match-attribute-value (value)
1545 (rng-update-match-state (rng-data-deriv rng-match-state
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
1553 (defun rng-match-start-tag-close ()
1554 (rng-update-match-state (rng-start-tag-close-deriv rng-match-state
)))
1556 (defun rng-match-mixed-text ()
1557 (rng-update-match-state (rng-mixed-text-deriv rng-match-state
)))
1559 (defun rng-match-end-tag ()
1560 (rng-update-match-state (rng-end-tag-deriv rng-match-state
)))
1562 (defun rng-match-after ()
1563 (rng-update-match-state
1564 (rng-ipattern-after rng-match-state
)))
1566 (defun rng-match-out-of-context-start-tag-open (name)
1567 (let* ((found (rng-map-element-attribute 'rng-find-element-content-pattern
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
))))
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
)
1586 (defun rng-match-unknown-start-tag-open ()
1587 (rng-update-match-state
1588 (rng-unknown-start-tag-open-deriv rng-match-state
)))
1590 (defun rng-match-optionalize-elements ()
1591 (rng-update-match-state
1592 (rng-ipattern-optionalize-elements rng-match-state
)))
1594 (defun rng-match-ignore-attributes ()
1595 (rng-update-match-state
1596 (rng-ignore-attributes-deriv rng-match-state
)))
1598 (defun rng-match-text-typed-p ()
1599 (rng-ipattern-text-typed-p rng-match-state
))
1601 (defun rng-match-empty-content ()
1602 (if (rng-match-text-typed-p)
1603 (rng-match-element-value "")
1604 (rng-match-end-tag)))
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
))
1612 (defun rng-match-infer-start-tag-namespace (local-name)
1613 (let ((ncs (rng-ipattern-possible-start-tags rng-match-state nil
))
1618 (if (and (equal (cdr nc
) local-name
)
1621 ;; first possible namespace
1623 (setq ncs
(cdr ncs
)))
1624 ((equal ns
(car nc
))
1625 ;; same as first namespace
1626 (setq ncs
(cdr ncs
)))
1628 ;; more than one possible namespace
1631 (setq ncs
(cdr ncs
))))
1634 (defun rng-match-nullable-p ()
1635 (rng--ipattern-nullable rng-match-state
))
1637 (defun rng-match-possible-start-tag-names ()
1638 "Return a list of possible names that would be valid for start-tags.
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
))
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
))
1650 (defun rng-match-possible-attribute-names ()
1651 "Return a list of possible names that would be valid for attributes.
1653 See the function `rng-match-possible-start-tag-names' for
1655 (rng-ipattern-possible-attributes rng-match-state nil
))
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
1661 (rng-ipattern-possible-values rng-match-state nil
))
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
))
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
))
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
))
1677 (setq rng-match-state
,state
)))))
1679 (defmacro rng-match-with-schema
(schema &rest body
)
1680 (declare (indent 1) (debug t
))
1681 `(let ((rng-current-schema ,schema
)
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
))
1691 (provide 'rng-match
)
1693 ;;; rng-match.el ends here