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