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