aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2013-10-07 09:54:48 -0400
committerStefan Monnier2013-10-07 09:54:48 -0400
commitda3e5ebb8d6b69f82191ac6e6dc63926f210db68 (patch)
tree2b4d370db8fdab4446469051f7f284c6ab44b7c1
parent2f84ba10862ccbd5fb70044b160c43e4c00b5822 (diff)
downloademacs-da3e5ebb8d6b69f82191ac6e6dc63926f210db68.tar.gz
emacs-da3e5ebb8d6b69f82191ac6e6dc63926f210db68.zip
* lisp/nxml/nxml-mode.el: Use lexical-binding and syntax-propertize.
(font-lock-beg, font-lock-end): Move before first use. (nxml-mode): Use syntax-propertize-function. (nxml-after-change, nxml-after-change1): Adjust accordingly. (nxml-extend-after-change-region): Remove. * lisp/nxml/nxml-ns.el: Use lexical-binding. (nxml-ns-save): Use `declare'. (nxml-ns-prefixes-for): Avoid add-to-list. * lisp/nxml/nxml-util.el: Use lexical-binding. (nxml-with-degradation-on-error, nxml-with-invisible-motion): Use `declare'. * lisp/nxml/rng-match.el: Use lexical-binding. (rng--ipattern): Use cl-defstruct. (rng-compute-start-tag-open-deriv, rng-compute-start-attribute-deriv) (rng-cons-group-after, rng-subst-group-after) (rng-subst-interleave-after, rng-apply-after, rng-compute-data-deriv): Use closures instead of `(lambda...). * lisp/nxml/xmltok.el: Use lexical-binding. (xmltok-save): Use `declare'. (xmltok-unclosed-reparse-p, xmltok-semi-closed-reparse-p): Remove.
-rw-r--r--lisp/ChangeLog34
-rw-r--r--lisp/nxml/nxml-mode.el75
-rw-r--r--lisp/nxml/nxml-ns.el17
-rw-r--r--lisp/nxml/nxml-util.el7
-rw-r--r--lisp/nxml/rng-match.el491
-rw-r--r--lisp/nxml/xmltok.el38
6 files changed, 292 insertions, 370 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 1cad30c0214..17ba29fd0ae 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,14 +1,37 @@
12013-10-07 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * nxml/nxml-mode.el: Use lexical-binding and syntax-propertize.
4 (font-lock-beg, font-lock-end): Move before first use.
5 (nxml-mode): Use syntax-propertize-function.
6 (nxml-after-change, nxml-after-change1): Adjust accordingly.
7 (nxml-extend-after-change-region): Remove.
8 * nxml/xmltok.el: Use lexical-binding.
9 (xmltok-save): Use `declare'.
10 (xmltok-unclosed-reparse-p, xmltok-semi-closed-reparse-p): Remove.
11 * nxml/nxml-util.el: Use lexical-binding.
12 (nxml-with-degradation-on-error, nxml-with-invisible-motion):
13 Use `declare'.
14 * nxml/nxml-ns.el: Use lexical-binding.
15 (nxml-ns-save): Use `declare'.
16 (nxml-ns-prefixes-for): Avoid add-to-list.
17 * nxml/rng-match.el: Use lexical-binding.
18 (rng--ipattern): Use cl-defstruct.
19 (rng-compute-start-tag-open-deriv, rng-compute-start-attribute-deriv)
20 (rng-cons-group-after, rng-subst-group-after)
21 (rng-subst-interleave-after, rng-apply-after, rng-compute-data-deriv):
22 Use closures instead of `(lambda...).
23
12013-10-07 Michael Albinus <michael.albinus@gmx.de> 242013-10-07 Michael Albinus <michael.albinus@gmx.de>
2 25
3 * net/tramp.el (tramp-handle-insert-file-contents): Improve handling 26 * net/tramp.el (tramp-handle-insert-file-contents): Improve handling
4 of BEG and END. 27 of BEG and END.
5 28
6 * net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist): Use 29 * net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist):
7 `tramp-handle-insert-file-contents'. 30 Use `tramp-handle-insert-file-contents'.
8 (tramp-gvfs-handle-insert-file-contents): Remove function. 31 (tramp-gvfs-handle-insert-file-contents): Remove function.
9 32
10 * net/tramp-sh.el (tramp-sh-handle-insert-directory): Use 33 * net/tramp-sh.el (tramp-sh-handle-insert-directory):
11 `save-restriction' in order to keep markers. 34 Use `save-restriction' in order to keep markers.
12 35
13 * net/trampver.el: Update release number. 36 * net/trampver.el: Update release number.
14 37
@@ -20,7 +43,8 @@
20 43
21 * emacs-lisp/easymenu.el (easy-menu-create-menu): Use closures. 44 * emacs-lisp/easymenu.el (easy-menu-create-menu): Use closures.
22 45
23 * emacs-lisp/lisp-mode.el (eval-defun-2): Simplify, using lexical-binding. 46 * emacs-lisp/lisp-mode.el (eval-defun-2): Simplify, using
47 lexical-binding.
24 48
25 * emacs-lisp/tq.el (tq-create): Use a closure instead of `(lambda...). 49 * emacs-lisp/tq.el (tq-create): Use a closure instead of `(lambda...).
26 50
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index c45196f0316..da3c034b5ff 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -1,4 +1,4 @@
1;;; nxml-mode.el --- a new XML mode 1;;; nxml-mode.el --- a new XML mode -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2003-2004, 2007-2013 Free Software Foundation, Inc. 3;; Copyright (C) 2003-2004, 2007-2013 Free Software Foundation, Inc.
4 4
@@ -540,14 +540,14 @@ Many aspects this mode can be customized using
540 (nxml-scan-prolog))))) 540 (nxml-scan-prolog)))))
541 (add-hook 'completion-at-point-functions 541 (add-hook 'completion-at-point-functions
542 #'nxml-completion-at-point-function nil t) 542 #'nxml-completion-at-point-function nil t)
543 (add-hook 'after-change-functions 'nxml-after-change nil t) 543 (setq-local syntax-propertize-function #'nxml-after-change)
544 (add-hook 'change-major-mode-hook 'nxml-cleanup nil t) 544 (add-hook 'change-major-mode-hook 'nxml-cleanup nil t)
545 545
546 ;; Emacs 23 handles the encoding attribute on the xml declaration 546 ;; Emacs 23 handles the encoding attribute on the xml declaration
547 ;; transparently to nxml-mode, so there is no longer a need for the below 547 ;; transparently to nxml-mode, so there is no longer a need for the below
548 ;; hook. The hook also had the drawback of overriding explicit user 548 ;; hook. The hook also had the drawback of overriding explicit user
549 ;; instruction to save as some encoding other than utf-8. 549 ;; instruction to save as some encoding other than utf-8.
550;;; (add-hook 'write-contents-hooks 'nxml-prepare-to-save) 550 ;;(add-hook 'write-contents-hooks 'nxml-prepare-to-save)
551 (when (not (and (buffer-file-name) (file-exists-p (buffer-file-name)))) 551 (when (not (and (buffer-file-name) (file-exists-p (buffer-file-name))))
552 (when (and nxml-default-buffer-file-coding-system 552 (when (and nxml-default-buffer-file-coding-system
553 (not (local-variable-p 'buffer-file-coding-system))) 553 (not (local-variable-p 'buffer-file-coding-system)))
@@ -561,8 +561,6 @@ Many aspects this mode can be customized using
561 nil ; font-lock-keywords-case-fold-search. XML is case sensitive 561 nil ; font-lock-keywords-case-fold-search. XML is case sensitive
562 nil ; no special syntax table 562 nil ; no special syntax table
563 nil ; no automatic syntactic fontification 563 nil ; no automatic syntactic fontification
564 (font-lock-extend-after-change-region-function
565 . nxml-extend-after-change-region)
566 (font-lock-extend-region-functions . (nxml-extend-region)) 564 (font-lock-extend-region-functions . (nxml-extend-region))
567 (jit-lock-contextually . t) 565 (jit-lock-contextually . t)
568 (font-lock-unfontify-region-function . nxml-unfontify-region))) 566 (font-lock-unfontify-region-function . nxml-unfontify-region)))
@@ -597,6 +595,7 @@ Many aspects this mode can be customized using
597 595
598;;; Change management 596;;; Change management
599 597
598(defvar font-lock-beg) (defvar font-lock-end)
600(defun nxml-debug-region (start end) 599(defun nxml-debug-region (start end)
601 (interactive "r") 600 (interactive "r")
602 (let ((font-lock-beg start) 601 (let ((font-lock-beg start)
@@ -605,22 +604,16 @@ Many aspects this mode can be customized using
605 (goto-char font-lock-beg) 604 (goto-char font-lock-beg)
606 (set-mark font-lock-end))) 605 (set-mark font-lock-end)))
607 606
608(defun nxml-after-change (start end pre-change-length) 607(defun nxml-after-change (start end)
609 ; In font-lock mode, nxml-after-change1 is called via 608 ;; Called via syntax-propertize-function.
610 ; nxml-extend-after-change-region instead so that the updated 609 (unless nxml-degraded
611 ; book-keeping information is available for fontification.
612 (unless (or font-lock-mode nxml-degraded)
613 (nxml-with-degradation-on-error 'nxml-after-change 610 (nxml-with-degradation-on-error 'nxml-after-change
614 (save-excursion 611 (save-restriction
615 (save-restriction 612 (widen)
616 (widen) 613 (nxml-with-invisible-motion
617 (save-match-data 614 (nxml-after-change1 start end))))))
618 (nxml-with-invisible-motion 615
619 (with-silent-modifications 616(defun nxml-after-change1 (start end)
620 (nxml-after-change1
621 start end pre-change-length)))))))))
622
623(defun nxml-after-change1 (start end pre-change-length)
624 "After-change bookkeeping. 617 "After-change bookkeeping.
625Returns a cons cell containing a possibly-enlarged change region. 618Returns a cons cell containing a possibly-enlarged change region.
626You must call `nxml-extend-region' on this expanded region to obtain 619You must call `nxml-extend-region' on this expanded region to obtain
@@ -628,23 +621,14 @@ the full extent of the area needing refontification.
628 621
629For bookkeeping, call this function even when fontification is 622For bookkeeping, call this function even when fontification is
630disabled." 623disabled."
631 (let ((pre-change-end (+ start pre-change-length))) 624 ;; If the prolog might have changed, rescan the prolog.
632 ;; If the prolog might have changed, rescan the prolog 625 (when (<= start
633 (when (<= start 626 ;; Add 2 so as to include the < and following char that
634 ;; Add 2 so as to include the < and following char that 627 ;; start the instance (document element), since changing
635 ;; start the instance (document element), since changing 628 ;; these can change where the prolog ends.
636 ;; these can change where the prolog ends. 629 (+ nxml-prolog-end 2))
637 (+ nxml-prolog-end 2)) 630 (nxml-scan-prolog)
638 ;; end must be extended to at least the end of the old prolog in 631 (setq start (point-min)))
639 ;; case the new prolog is shorter
640 (when (< pre-change-end nxml-prolog-end)
641 (setq end
642 ;; don't let end get out of range even if pre-change-length
643 ;; is bogus
644 (min (point-max)
645 (+ end (- nxml-prolog-end pre-change-end)))))
646 (nxml-scan-prolog)
647 (setq start (point-min))))
648 632
649 (when (> end nxml-prolog-end) 633 (when (> end nxml-prolog-end)
650 (goto-char start) 634 (goto-char start)
@@ -653,8 +637,7 @@ disabled."
653 (setq end (max (nxml-scan-after-change start end) 637 (setq end (max (nxml-scan-after-change start end)
654 end))) 638 end)))
655 639
656 (nxml-debug-change "nxml-after-change1" start end) 640 (nxml-debug-change "nxml-after-change1" start end))
657 (cons start end))
658 641
659;;; Encodings 642;;; Encodings
660 643
@@ -845,7 +828,6 @@ The XML declaration will declare an encoding depending on the buffer's
845 (font-lock-default-unfontify-region start end) 828 (font-lock-default-unfontify-region start end)
846 (nxml-clear-char-ref-extra-display start end)) 829 (nxml-clear-char-ref-extra-display start end))
847 830
848(defvar font-lock-beg) (defvar font-lock-end)
849(defun nxml-extend-region () 831(defun nxml-extend-region ()
850 "Extend the region to hold the minimum area we can fontify with nXML. 832 "Extend the region to hold the minimum area we can fontify with nXML.
851Called with `font-lock-beg' and `font-lock-end' dynamically bound." 833Called with `font-lock-beg' and `font-lock-end' dynamically bound."
@@ -887,19 +869,6 @@ Called with `font-lock-beg' and `font-lock-end' dynamically bound."
887 (nxml-debug-change "nxml-extend-region" start end) 869 (nxml-debug-change "nxml-extend-region" start end)
888 t))) 870 t)))
889 871
890(defun nxml-extend-after-change-region (start end pre-change-length)
891 (unless nxml-degraded
892 (nxml-with-degradation-on-error
893 'nxml-extend-after-change-region
894 (save-excursion
895 (save-restriction
896 (widen)
897 (save-match-data
898 (nxml-with-invisible-motion
899 (with-silent-modifications
900 (nxml-after-change1
901 start end pre-change-length)))))))))
902
903(defun nxml-fontify-matcher (bound) 872(defun nxml-fontify-matcher (bound)
904 "Called as font-lock keyword matcher." 873 "Called as font-lock keyword matcher."
905 874
diff --git a/lisp/nxml/nxml-ns.el b/lisp/nxml/nxml-ns.el
index cadb5e6adab..a3a05c262d8 100644
--- a/lisp/nxml/nxml-ns.el
+++ b/lisp/nxml/nxml-ns.el
@@ -1,4 +1,4 @@
1;;; nxml-ns.el --- XML namespace processing 1;;; nxml-ns.el --- XML namespace processing -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc. 3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc.
4 4
@@ -56,12 +56,10 @@ namespace bindings (no default namespace and only the xml prefix bound).")
56 (equal nxml-ns-state state)) 56 (equal nxml-ns-state state))
57 57
58(defmacro nxml-ns-save (&rest body) 58(defmacro nxml-ns-save (&rest body)
59 (declare (indent 0) (debug t))
59 `(let ((nxml-ns-state nxml-ns-initial-state)) 60 `(let ((nxml-ns-state nxml-ns-initial-state))
60 ,@body)) 61 ,@body))
61 62
62(put 'nxml-ns-save 'lisp-indent-function 0)
63(def-edebug-spec nxml-ns-save t)
64
65(defun nxml-ns-init () 63(defun nxml-ns-init ()
66 (setq nxml-ns-state nxml-ns-initial-state)) 64 (setq nxml-ns-state nxml-ns-initial-state))
67 65
@@ -117,11 +115,12 @@ NS is a symbol or nil."
117 (setq current (cdr current)) 115 (setq current (cdr current))
118 (while (let ((binding (rassq ns current))) 116 (while (let ((binding (rassq ns current)))
119 (when binding 117 (when binding
120 (when (eq (nxml-ns-get-prefix (car binding)) ns) 118 (let ((prefix (car binding)))
121 (add-to-list 'prefixes 119 (when (eq (nxml-ns-get-prefix prefix) ns)
122 (car binding))) 120 (unless (member prefix prefixes)
123 (setq current 121 (push prefix prefixes))))
124 (cdr (member binding current)))))) 122 (setq current
123 (cdr (member binding current))))))
125 prefixes)) 124 prefixes))
126 125
127(defun nxml-ns-prefix-for (ns) 126(defun nxml-ns-prefix-for (ns)
diff --git a/lisp/nxml/nxml-util.el b/lisp/nxml/nxml-util.el
index c410aa12c83..6ab425a420e 100644
--- a/lisp/nxml/nxml-util.el
+++ b/lisp/nxml/nxml-util.el
@@ -1,4 +1,4 @@
1;;; nxml-util.el --- utility functions for nxml-*.el 1;;; nxml-util.el --- utility functions for nxml-*.el -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc. 3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc.
4 4
@@ -70,6 +70,7 @@ This is the inverse of `nxml-make-namespace'."
70 (nxml-make-namespace "http://www.w3.org/2000/xmlns/")) 70 (nxml-make-namespace "http://www.w3.org/2000/xmlns/"))
71 71
72(defmacro nxml-with-degradation-on-error (context &rest body) 72(defmacro nxml-with-degradation-on-error (context &rest body)
73 (declare (indent 1) (debug t))
73 (if (not nxml-debug) 74 (if (not nxml-debug)
74 (let ((error-symbol (make-symbol "err"))) 75 (let ((error-symbol (make-symbol "err")))
75 `(condition-case ,error-symbol 76 `(condition-case ,error-symbol
@@ -80,12 +81,10 @@ This is the inverse of `nxml-make-namespace'."
80 81
81(defmacro nxml-with-invisible-motion (&rest body) 82(defmacro nxml-with-invisible-motion (&rest body)
82 "Evaluate body without calling any point motion hooks." 83 "Evaluate body without calling any point motion hooks."
84 (declare (indent 0) (debug t))
83 `(let ((inhibit-point-motion-hooks t)) 85 `(let ((inhibit-point-motion-hooks t))
84 ,@body)) 86 ,@body))
85 87
86(put 'nxml-with-invisible-motion 'lisp-indent-function 0)
87(def-edebug-spec nxml-with-invisible-motion t)
88
89(defun nxml-display-file-parse-error (err) 88(defun nxml-display-file-parse-error (err)
90 (let* ((filename (nth 1 err)) 89 (let* ((filename (nth 1 err))
91 (buffer (find-file-noselect filename)) 90 (buffer (find-file-noselect filename))
diff --git a/lisp/nxml/rng-match.el b/lisp/nxml/rng-match.el
index 36bd23b3768..10b8f2b0b4c 100644
--- a/lisp/nxml/rng-match.el
+++ b/lisp/nxml/rng-match.el
@@ -1,4 +1,4 @@
1;;; rng-match.el --- matching of RELAX NG patterns against XML events 1;;; rng-match.el --- matching of RELAX NG patterns against XML events -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc. 3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc.
4 4
@@ -34,6 +34,7 @@
34(require 'rng-pttrn) 34(require 'rng-pttrn)
35(require 'rng-util) 35(require 'rng-util)
36(require 'rng-dt) 36(require 'rng-dt)
37(eval-when-compile (require 'cl-lib))
37 38
38(defvar rng-not-allowed-ipattern nil) 39(defvar rng-not-allowed-ipattern nil)
39(defvar rng-empty-ipattern nil) 40(defvar rng-empty-ipattern nil)
@@ -63,38 +64,31 @@ Used to detect invalid recursive references.")
63 64
64;;; Interned patterns 65;;; Interned patterns
65 66
66(eval-when-compile 67(cl-defstruct (rng--ipattern
67 (defun rng-ipattern-slot-accessor-name (slot-name) 68 (:constructor nil)
68 (intern (concat "rng-ipattern-get-" 69 (:type vector)
69 (symbol-name slot-name)))) 70 (:copier nil)
70 71 (:constructor rng-make-ipattern
71 (defun rng-ipattern-slot-setter-name (slot-name) 72 (type index name-class child nullable)))
72 (intern (concat "rng-ipattern-set-" 73 type
73 (symbol-name slot-name))))) 74 index
74 75 name-class ;; Field also known as: `datatype' and `after'.
75(defmacro rng-ipattern-defslot (slot-name index) 76 child ;; Field also known as: `value-object'.
76 `(progn 77 nullable
77 (defsubst ,(rng-ipattern-slot-accessor-name slot-name) (ipattern) 78 (memo-text-typed 'unknown)
78 (aref ipattern ,index)) 79 memo-map-start-tag-open-deriv
79 (defsubst ,(rng-ipattern-slot-setter-name slot-name) (ipattern value) 80 memo-map-start-attribute-deriv
80 (aset ipattern ,index value)))) 81 memo-start-tag-close-deriv
81 82 memo-text-only-deriv
82(rng-ipattern-defslot type 0) 83 memo-mixed-text-deriv
83(rng-ipattern-defslot index 1) 84 memo-map-data-deriv
84(rng-ipattern-defslot name-class 2) 85 memo-end-tag-deriv)
85(rng-ipattern-defslot datatype 2) 86
86(rng-ipattern-defslot after 2) 87;; I think depending on the value of `type' the two fields after `index'
87(rng-ipattern-defslot child 3) 88;; are used sometimes for different purposes, hence the aliases here:
88(rng-ipattern-defslot value-object 3) 89(defalias 'rng--ipattern-datatype 'rng--ipattern-name-class)
89(rng-ipattern-defslot nullable 4) 90(defalias 'rng--ipattern-after 'rng--ipattern-name-class)
90(rng-ipattern-defslot memo-text-typed 5) 91(defalias 'rng--ipattern-value-object 'rng--ipattern-child)
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 92
99(defconst rng-memo-map-alist-max 10) 93(defconst rng-memo-map-alist-max 10)
100 94
@@ -142,25 +136,6 @@ therefore minimal overhead in successful lookups on small lists
142 (cons (cons key value) 136 (cons (cons key value)
143 (cdr mm)))))))) 137 (cdr mm))))))))
144 138
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 () 139(defun rng-ipattern-maybe-init ()
165 (unless rng-ipattern-table 140 (unless rng-ipattern-table
166 (setq rng-ipattern-table (make-hash-table :test 'equal)) 141 (setq rng-ipattern-table (make-hash-table :test 'equal))
@@ -208,8 +183,8 @@ therefore minimal overhead in successful lookups on small lists
208 (if (eq child rng-not-allowed-ipattern) 183 (if (eq child rng-not-allowed-ipattern)
209 rng-not-allowed-ipattern 184 rng-not-allowed-ipattern
210 (let ((key (list 'after 185 (let ((key (list 'after
211 (rng-ipattern-get-index child) 186 (rng--ipattern-index child)
212 (rng-ipattern-get-index after)))) 187 (rng--ipattern-index after))))
213 (or (rng-get-ipattern key) 188 (or (rng-get-ipattern key)
214 (rng-put-ipattern key 189 (rng-put-ipattern key
215 'after 190 'after
@@ -222,7 +197,7 @@ therefore minimal overhead in successful lookups on small lists
222 rng-not-allowed-ipattern 197 rng-not-allowed-ipattern
223 (let ((key (list 'attribute 198 (let ((key (list 'attribute
224 name-class 199 name-class
225 (rng-ipattern-get-index ipattern)))) 200 (rng--ipattern-index ipattern))))
226 (or (rng-get-ipattern key) 201 (or (rng-get-ipattern key)
227 (rng-put-ipattern key 202 (rng-put-ipattern key
228 'attribute 203 'attribute
@@ -238,8 +213,8 @@ therefore minimal overhead in successful lookups on small lists
238 dt 213 dt
239 nil 214 nil
240 matches-anything))) 215 matches-anything)))
241 (rng-ipattern-set-memo-text-typed ipattern 216 (setf (rng--ipattern-memo-text-typed ipattern)
242 (not matches-anything)) 217 (not matches-anything))
243 ipattern)))) 218 ipattern))))
244 219
245(defun rng-intern-data-except (dt ipattern) 220(defun rng-intern-data-except (dt ipattern)
@@ -263,20 +238,20 @@ therefore minimal overhead in successful lookups on small lists
263(defun rng-intern-one-or-more (ipattern) 238(defun rng-intern-one-or-more (ipattern)
264 (or (rng-intern-one-or-more-shortcut ipattern) 239 (or (rng-intern-one-or-more-shortcut ipattern)
265 (let ((key (cons 'one-or-more 240 (let ((key (cons 'one-or-more
266 (list (rng-ipattern-get-index ipattern))))) 241 (list (rng--ipattern-index ipattern)))))
267 (or (rng-get-ipattern key) 242 (or (rng-get-ipattern key)
268 (rng-put-ipattern key 243 (rng-put-ipattern key
269 'one-or-more 244 'one-or-more
270 nil 245 nil
271 ipattern 246 ipattern
272 (rng-ipattern-get-nullable ipattern)))))) 247 (rng--ipattern-nullable ipattern))))))
273 248
274(defun rng-intern-one-or-more-shortcut (ipattern) 249(defun rng-intern-one-or-more-shortcut (ipattern)
275 (cond ((eq ipattern rng-not-allowed-ipattern) 250 (cond ((eq ipattern rng-not-allowed-ipattern)
276 rng-not-allowed-ipattern) 251 rng-not-allowed-ipattern)
277 ((eq ipattern rng-empty-ipattern) 252 ((eq ipattern rng-empty-ipattern)
278 rng-empty-ipattern) 253 rng-empty-ipattern)
279 ((eq (rng-ipattern-get-type ipattern) 'one-or-more) 254 ((eq (rng--ipattern-type ipattern) 'one-or-more)
280 ipattern) 255 ipattern)
281 (t nil))) 256 (t nil)))
282 257
@@ -284,7 +259,7 @@ therefore minimal overhead in successful lookups on small lists
284 (if (eq ipattern rng-not-allowed-ipattern) 259 (if (eq ipattern rng-not-allowed-ipattern)
285 rng-not-allowed-ipattern 260 rng-not-allowed-ipattern
286 (let ((key (cons 'list 261 (let ((key (cons 'list
287 (list (rng-ipattern-get-index ipattern))))) 262 (list (rng--ipattern-index ipattern)))))
288 (or (rng-get-ipattern key) 263 (or (rng-get-ipattern key)
289 (rng-put-ipattern key 264 (rng-put-ipattern key
290 'list 265 'list
@@ -299,7 +274,7 @@ therefore minimal overhead in successful lookups on small lists
299 (normalized (cdr tem))) 274 (normalized (cdr tem)))
300 (or (rng-intern-group-shortcut normalized) 275 (or (rng-intern-group-shortcut normalized)
301 (let ((key (cons 'group 276 (let ((key (cons 'group
302 (mapcar 'rng-ipattern-get-index normalized)))) 277 (mapcar #'rng--ipattern-index normalized))))
303 (or (rng-get-ipattern key) 278 (or (rng-get-ipattern key)
304 (rng-put-ipattern key 279 (rng-put-ipattern key
305 'group 280 'group
@@ -345,10 +320,10 @@ cdr is the normalized list."
345 (setq member (car ipatterns)) 320 (setq member (car ipatterns))
346 (setq ipatterns (cdr ipatterns)) 321 (setq ipatterns (cdr ipatterns))
347 (when nullable 322 (when nullable
348 (setq nullable (rng-ipattern-get-nullable member))) 323 (setq nullable (rng--ipattern-nullable member)))
349 (cond ((eq (rng-ipattern-get-type member) 'group) 324 (cond ((eq (rng--ipattern-type member) 'group)
350 (setq result 325 (setq result
351 (nconc (reverse (rng-ipattern-get-child member)) 326 (nconc (reverse (rng--ipattern-child member))
352 result))) 327 result)))
353 ((eq member rng-not-allowed-ipattern) 328 ((eq member rng-not-allowed-ipattern)
354 (setq result (list rng-not-allowed-ipattern)) 329 (setq result (list rng-not-allowed-ipattern))
@@ -363,7 +338,7 @@ cdr is the normalized list."
363 (normalized (cdr tem))) 338 (normalized (cdr tem)))
364 (or (rng-intern-group-shortcut normalized) 339 (or (rng-intern-group-shortcut normalized)
365 (let ((key (cons 'interleave 340 (let ((key (cons 'interleave
366 (mapcar 'rng-ipattern-get-index normalized)))) 341 (mapcar #'rng--ipattern-index normalized))))
367 (or (rng-get-ipattern key) 342 (or (rng-get-ipattern key)
368 (rng-put-ipattern key 343 (rng-put-ipattern key
369 'interleave 344 'interleave
@@ -383,10 +358,10 @@ cdr is the normalized list."
383 (setq member (car ipatterns)) 358 (setq member (car ipatterns))
384 (setq ipatterns (cdr ipatterns)) 359 (setq ipatterns (cdr ipatterns))
385 (when nullable 360 (when nullable
386 (setq nullable (rng-ipattern-get-nullable member))) 361 (setq nullable (rng--ipattern-nullable member)))
387 (cond ((eq (rng-ipattern-get-type member) 'interleave) 362 (cond ((eq (rng--ipattern-type member) 'interleave)
388 (setq result 363 (setq result
389 (append (rng-ipattern-get-child member) 364 (append (rng--ipattern-child member)
390 result))) 365 result)))
391 ((eq member rng-not-allowed-ipattern) 366 ((eq member rng-not-allowed-ipattern)
392 (setq result (list rng-not-allowed-ipattern)) 367 (setq result (list rng-not-allowed-ipattern))
@@ -407,7 +382,7 @@ May alter IPATTERNS."
407 (rng-intern-choice1 normalized (car tem)))))) 382 (rng-intern-choice1 normalized (car tem))))))
408 383
409(defun rng-intern-optional (ipattern) 384(defun rng-intern-optional (ipattern)
410 (cond ((rng-ipattern-get-nullable ipattern) ipattern) 385 (cond ((rng--ipattern-nullable ipattern) ipattern)
411 ((eq ipattern rng-not-allowed-ipattern) rng-empty-ipattern) 386 ((eq ipattern rng-not-allowed-ipattern) rng-empty-ipattern)
412 (t (rng-intern-choice1 387 (t (rng-intern-choice1
413 ;; This is sorted since the empty pattern 388 ;; This is sorted since the empty pattern
@@ -415,15 +390,15 @@ May alter IPATTERNS."
415 ;; It cannot have a duplicate empty pattern, 390 ;; It cannot have a duplicate empty pattern,
416 ;; since it is not nullable. 391 ;; since it is not nullable.
417 (cons rng-empty-ipattern 392 (cons rng-empty-ipattern
418 (if (eq (rng-ipattern-get-type ipattern) 'choice) 393 (if (eq (rng--ipattern-type ipattern) 'choice)
419 (rng-ipattern-get-child ipattern) 394 (rng--ipattern-child ipattern)
420 (list ipattern))) 395 (list ipattern)))
421 t)))) 396 t))))
422 397
423 398
424(defun rng-intern-choice1 (normalized nullable) 399(defun rng-intern-choice1 (normalized nullable)
425 (let ((key (cons 'choice 400 (let ((key (cons 'choice
426 (mapcar 'rng-ipattern-get-index normalized)))) 401 (mapcar #'rng--ipattern-index normalized))))
427 (or (rng-get-ipattern key) 402 (or (rng-get-ipattern key)
428 (rng-put-ipattern key 403 (rng-put-ipattern key
429 'choice 404 'choice
@@ -466,10 +441,10 @@ list is nullable and whose cdr is the normalized list."
466 (while cur 441 (while cur
467 (setq member (car cur)) 442 (setq member (car cur))
468 (or nullable 443 (or nullable
469 (setq nullable (rng-ipattern-get-nullable member))) 444 (setq nullable (rng--ipattern-nullable member)))
470 (cond ((eq (rng-ipattern-get-type member) 'choice) 445 (cond ((eq (rng--ipattern-type member) 'choice)
471 (setq final-tail 446 (setq final-tail
472 (append (rng-ipattern-get-child member) 447 (append (rng--ipattern-child member)
473 final-tail)) 448 final-tail))
474 (setq cur (cdr cur)) 449 (setq cur (cdr cur))
475 (setq sorted nil) 450 (setq sorted nil)
@@ -479,7 +454,7 @@ list is nullable and whose cdr is the normalized list."
479 (setcdr tail cur)) 454 (setcdr tail cur))
480 (t 455 (t
481 (if (and sorted 456 (if (and sorted
482 (let ((cur-index (rng-ipattern-get-index member))) 457 (let ((cur-index (rng--ipattern-index member)))
483 (if (>= prev-index cur-index) 458 (if (>= prev-index cur-index)
484 (or (= prev-index cur-index) ; will remove it 459 (or (= prev-index cur-index) ; will remove it
485 (setq sorted nil)) ; won't remove it 460 (setq sorted nil)) ; won't remove it
@@ -501,8 +476,8 @@ list is nullable and whose cdr is the normalized list."
501 (rng-uniquify-eq (sort head 'rng-compare-ipattern)))))) 476 (rng-uniquify-eq (sort head 'rng-compare-ipattern))))))
502 477
503(defun rng-compare-ipattern (p1 p2) 478(defun rng-compare-ipattern (p1 p2)
504 (< (rng-ipattern-get-index p1) 479 (< (rng--ipattern-index p1)
505 (rng-ipattern-get-index p2))) 480 (rng--ipattern-index p2)))
506 481
507;;; Name classes 482;;; Name classes
508 483
@@ -557,50 +532,50 @@ list may contain duplicates."
557;;; Debugging utilities 532;;; Debugging utilities
558 533
559(defun rng-ipattern-to-string (ipattern) 534(defun rng-ipattern-to-string (ipattern)
560 (let ((type (rng-ipattern-get-type ipattern))) 535 (let ((type (rng--ipattern-type ipattern)))
561 (cond ((eq type 'after) 536 (cond ((eq type 'after)
562 (concat (rng-ipattern-to-string 537 (concat (rng-ipattern-to-string
563 (rng-ipattern-get-child ipattern)) 538 (rng--ipattern-child ipattern))
564 " </> " 539 " </> "
565 (rng-ipattern-to-string 540 (rng-ipattern-to-string
566 (rng-ipattern-get-after ipattern)))) 541 (rng--ipattern-after ipattern))))
567 ((eq type 'element) 542 ((eq type 'element)
568 (concat "element " 543 (concat "element "
569 (rng-name-class-to-string 544 (rng-name-class-to-string
570 (rng-ipattern-get-name-class ipattern)) 545 (rng--ipattern-name-class ipattern))
571 ;; we can get cycles with elements so don't print it out 546 ;; we can get cycles with elements so don't print it out
572 " {...}")) 547 " {...}"))
573 ((eq type 'attribute) 548 ((eq type 'attribute)
574 (concat "attribute " 549 (concat "attribute "
575 (rng-name-class-to-string 550 (rng-name-class-to-string
576 (rng-ipattern-get-name-class ipattern)) 551 (rng--ipattern-name-class ipattern))
577 " { " 552 " { "
578 (rng-ipattern-to-string 553 (rng-ipattern-to-string
579 (rng-ipattern-get-child ipattern)) 554 (rng--ipattern-child ipattern))
580 " } ")) 555 " } "))
581 ((eq type 'empty) "empty") 556 ((eq type 'empty) "empty")
582 ((eq type 'text) "text") 557 ((eq type 'text) "text")
583 ((eq type 'not-allowed) "notAllowed") 558 ((eq type 'not-allowed) "notAllowed")
584 ((eq type 'one-or-more) 559 ((eq type 'one-or-more)
585 (concat (rng-ipattern-to-string 560 (concat (rng-ipattern-to-string
586 (rng-ipattern-get-child ipattern)) 561 (rng--ipattern-child ipattern))
587 "+")) 562 "+"))
588 ((eq type 'choice) 563 ((eq type 'choice)
589 (concat "(" 564 (concat "("
590 (mapconcat 'rng-ipattern-to-string 565 (mapconcat 'rng-ipattern-to-string
591 (rng-ipattern-get-child ipattern) 566 (rng--ipattern-child ipattern)
592 " | ") 567 " | ")
593 ")")) 568 ")"))
594 ((eq type 'group) 569 ((eq type 'group)
595 (concat "(" 570 (concat "("
596 (mapconcat 'rng-ipattern-to-string 571 (mapconcat 'rng-ipattern-to-string
597 (rng-ipattern-get-child ipattern) 572 (rng--ipattern-child ipattern)
598 ", ") 573 ", ")
599 ")")) 574 ")"))
600 ((eq type 'interleave) 575 ((eq type 'interleave)
601 (concat "(" 576 (concat "("
602 (mapconcat 'rng-ipattern-to-string 577 (mapconcat 'rng-ipattern-to-string
603 (rng-ipattern-get-child ipattern) 578 (rng--ipattern-child ipattern)
604 " & ") 579 " & ")
605 ")")) 580 ")"))
606 (t (symbol-name type))))) 581 (t (symbol-name type)))))
@@ -664,10 +639,10 @@ list may contain duplicates."
664 nil)) 639 nil))
665 640
666(defun rng-element-get-child (element) 641(defun rng-element-get-child (element)
667 (let ((tem (rng-ipattern-get-child element))) 642 (let ((tem (rng--ipattern-child element)))
668 (if (vectorp tem) 643 (if (vectorp tem)
669 tem 644 tem
670 (rng-ipattern-set-child element (rng-compile tem))))) 645 (setf (rng--ipattern-child element) (rng-compile tem)))))
671 646
672(defun rng-compile-attribute (name-class pattern) 647(defun rng-compile-attribute (name-class pattern)
673 (rng-intern-attribute (rng-compile-name-class name-class) 648 (rng-intern-attribute (rng-compile-name-class name-class)
@@ -839,17 +814,16 @@ list may contain duplicates."
839;;; Derivatives 814;;; Derivatives
840 815
841(defun rng-ipattern-text-typed-p (ipattern) 816(defun rng-ipattern-text-typed-p (ipattern)
842 (let ((memo (rng-ipattern-get-memo-text-typed ipattern))) 817 (let ((memo (rng--ipattern-memo-text-typed ipattern)))
843 (if (eq memo 'unknown) 818 (if (eq memo 'unknown)
844 (rng-ipattern-set-memo-text-typed 819 (setf (rng--ipattern-memo-text-typed ipattern)
845 ipattern 820 (rng-ipattern-compute-text-typed-p ipattern))
846 (rng-ipattern-compute-text-typed-p ipattern))
847 memo))) 821 memo)))
848 822
849(defun rng-ipattern-compute-text-typed-p (ipattern) 823(defun rng-ipattern-compute-text-typed-p (ipattern)
850 (let ((type (rng-ipattern-get-type ipattern))) 824 (let ((type (rng--ipattern-type ipattern)))
851 (cond ((eq type 'choice) 825 (cond ((eq type 'choice)
852 (let ((cur (rng-ipattern-get-child ipattern)) 826 (let ((cur (rng--ipattern-child ipattern))
853 (ret nil)) 827 (ret nil))
854 (while (and cur (not ret)) 828 (while (and cur (not ret))
855 (if (rng-ipattern-text-typed-p (car cur)) 829 (if (rng-ipattern-text-typed-p (car cur))
@@ -857,7 +831,7 @@ list may contain duplicates."
857 (setq cur (cdr cur)))) 831 (setq cur (cdr cur))))
858 ret)) 832 ret))
859 ((eq type 'group) 833 ((eq type 'group)
860 (let ((cur (rng-ipattern-get-child ipattern)) 834 (let ((cur (rng--ipattern-child ipattern))
861 (ret nil) 835 (ret nil)
862 member) 836 member)
863 (while (and cur (not ret)) 837 (while (and cur (not ret))
@@ -865,17 +839,17 @@ list may contain duplicates."
865 (if (rng-ipattern-text-typed-p member) 839 (if (rng-ipattern-text-typed-p member)
866 (setq ret t)) 840 (setq ret t))
867 (setq cur 841 (setq cur
868 (and (rng-ipattern-get-nullable member) 842 (and (rng--ipattern-nullable member)
869 (cdr cur)))) 843 (cdr cur))))
870 ret)) 844 ret))
871 ((eq type 'after) 845 ((eq type 'after)
872 (rng-ipattern-text-typed-p (rng-ipattern-get-child ipattern))) 846 (rng-ipattern-text-typed-p (rng--ipattern-child ipattern)))
873 (t (and (memq type '(value list data data-except)) t))))) 847 (t (and (memq type '(value list data data-except)) t)))))
874 848
875(defun rng-start-tag-open-deriv (ipattern nm) 849(defun rng-start-tag-open-deriv (ipattern nm)
876 (or (rng-memo-map-get 850 (or (rng-memo-map-get
877 nm 851 nm
878 (rng-ipattern-get-memo-map-start-tag-open-deriv ipattern)) 852 (rng--ipattern-memo-map-start-tag-open-deriv ipattern))
879 (rng-ipattern-memo-start-tag-open-deriv 853 (rng-ipattern-memo-start-tag-open-deriv
880 ipattern 854 ipattern
881 nm 855 nm
@@ -883,56 +857,54 @@ list may contain duplicates."
883 857
884(defun rng-ipattern-memo-start-tag-open-deriv (ipattern nm deriv) 858(defun rng-ipattern-memo-start-tag-open-deriv (ipattern nm deriv)
885 (or (memq ipattern rng-const-ipatterns) 859 (or (memq ipattern rng-const-ipatterns)
886 (rng-ipattern-set-memo-map-start-tag-open-deriv 860 (setf (rng--ipattern-memo-map-start-tag-open-deriv ipattern)
887 ipattern 861 (rng-memo-map-add nm
888 (rng-memo-map-add nm 862 deriv
889 deriv 863 (rng--ipattern-memo-map-start-tag-open-deriv
890 (rng-ipattern-get-memo-map-start-tag-open-deriv 864 ipattern))))
891 ipattern))))
892 deriv) 865 deriv)
893 866
894(defun rng-compute-start-tag-open-deriv (ipattern nm) 867(defun rng-compute-start-tag-open-deriv (ipattern nm)
895 (let ((type (rng-ipattern-get-type ipattern))) 868 (let ((type (rng--ipattern-type ipattern)))
896 (cond ((eq type 'choice) 869 (cond ((eq type 'choice)
897 (rng-transform-choice `(lambda (p) 870 (rng-transform-choice (lambda (p)
898 (rng-start-tag-open-deriv p ',nm)) 871 (rng-start-tag-open-deriv p nm))
899 ipattern)) 872 ipattern))
900 ((eq type 'element) 873 ((eq type 'element)
901 (if (rng-name-class-contains 874 (if (rng-name-class-contains
902 (rng-ipattern-get-name-class ipattern) 875 (rng--ipattern-name-class ipattern)
903 nm) 876 nm)
904 (rng-intern-after (rng-element-get-child ipattern) 877 (rng-intern-after (rng-element-get-child ipattern)
905 rng-empty-ipattern) 878 rng-empty-ipattern)
906 rng-not-allowed-ipattern)) 879 rng-not-allowed-ipattern))
907 ((eq type 'group) 880 ((eq type 'group)
908 (rng-transform-group-nullable 881 (rng-transform-group-nullable
909 `(lambda (p) (rng-start-tag-open-deriv p ',nm)) 882 (lambda (p) (rng-start-tag-open-deriv p nm))
910 'rng-cons-group-after 883 'rng-cons-group-after
911 ipattern)) 884 ipattern))
912 ((eq type 'interleave) 885 ((eq type 'interleave)
913 (rng-transform-interleave-single 886 (rng-transform-interleave-single
914 `(lambda (p) (rng-start-tag-open-deriv p ',nm)) 887 (lambda (p) (rng-start-tag-open-deriv p nm))
915 'rng-subst-interleave-after 888 'rng-subst-interleave-after
916 ipattern)) 889 ipattern))
917 ((eq type 'one-or-more) 890 ((eq type 'one-or-more)
918 (rng-apply-after 891 (let ((ip (rng-intern-optional ipattern)))
919 `(lambda (p) 892 (rng-apply-after
920 (rng-intern-group (list p ,(rng-intern-optional ipattern)))) 893 (lambda (p) (rng-intern-group (list p ip)))
921 (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern) 894 (rng-start-tag-open-deriv (rng--ipattern-child ipattern)
922 nm))) 895 nm))))
923 ((eq type 'after) 896 ((eq type 'after)
924 (rng-apply-after 897 (let ((nip (rng--ipattern-after ipattern)))
925 `(lambda (p) 898 (rng-apply-after
926 (rng-intern-after p 899 (lambda (p) (rng-intern-after p nip))
927 ,(rng-ipattern-get-after ipattern))) 900 (rng-start-tag-open-deriv (rng--ipattern-child ipattern)
928 (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern) 901 nm))))
929 nm)))
930 (t rng-not-allowed-ipattern)))) 902 (t rng-not-allowed-ipattern))))
931 903
932(defun rng-start-attribute-deriv (ipattern nm) 904(defun rng-start-attribute-deriv (ipattern nm)
933 (or (rng-memo-map-get 905 (or (rng-memo-map-get
934 nm 906 nm
935 (rng-ipattern-get-memo-map-start-attribute-deriv ipattern)) 907 (rng--ipattern-memo-map-start-attribute-deriv ipattern))
936 (rng-ipattern-memo-start-attribute-deriv 908 (rng-ipattern-memo-start-attribute-deriv
937 ipattern 909 ipattern
938 nm 910 nm
@@ -940,82 +912,79 @@ list may contain duplicates."
940 912
941(defun rng-ipattern-memo-start-attribute-deriv (ipattern nm deriv) 913(defun rng-ipattern-memo-start-attribute-deriv (ipattern nm deriv)
942 (or (memq ipattern rng-const-ipatterns) 914 (or (memq ipattern rng-const-ipatterns)
943 (rng-ipattern-set-memo-map-start-attribute-deriv 915 (setf (rng--ipattern-memo-map-start-attribute-deriv ipattern)
944 ipattern 916 (rng-memo-map-add
945 (rng-memo-map-add 917 nm
946 nm 918 deriv
947 deriv 919 (rng--ipattern-memo-map-start-attribute-deriv ipattern))))
948 (rng-ipattern-get-memo-map-start-attribute-deriv ipattern))))
949 deriv) 920 deriv)
950 921
951(defun rng-compute-start-attribute-deriv (ipattern nm) 922(defun rng-compute-start-attribute-deriv (ipattern nm)
952 (let ((type (rng-ipattern-get-type ipattern))) 923 (let ((type (rng--ipattern-type ipattern)))
953 (cond ((eq type 'choice) 924 (cond ((eq type 'choice)
954 (rng-transform-choice `(lambda (p) 925 (rng-transform-choice (lambda (p)
955 (rng-start-attribute-deriv p ',nm)) 926 (rng-start-attribute-deriv p nm))
956 ipattern)) 927 ipattern))
957 ((eq type 'attribute) 928 ((eq type 'attribute)
958 (if (rng-name-class-contains 929 (if (rng-name-class-contains
959 (rng-ipattern-get-name-class ipattern) 930 (rng--ipattern-name-class ipattern)
960 nm) 931 nm)
961 (rng-intern-after (rng-ipattern-get-child ipattern) 932 (rng-intern-after (rng--ipattern-child ipattern)
962 rng-empty-ipattern) 933 rng-empty-ipattern)
963 rng-not-allowed-ipattern)) 934 rng-not-allowed-ipattern))
964 ((eq type 'group) 935 ((eq type 'group)
965 (rng-transform-interleave-single 936 (rng-transform-interleave-single
966 `(lambda (p) (rng-start-attribute-deriv p ',nm)) 937 (lambda (p) (rng-start-attribute-deriv p nm))
967 'rng-subst-group-after 938 'rng-subst-group-after
968 ipattern)) 939 ipattern))
969 ((eq type 'interleave) 940 ((eq type 'interleave)
970 (rng-transform-interleave-single 941 (rng-transform-interleave-single
971 `(lambda (p) (rng-start-attribute-deriv p ',nm)) 942 (lambda (p) (rng-start-attribute-deriv p nm))
972 'rng-subst-interleave-after 943 'rng-subst-interleave-after
973 ipattern)) 944 ipattern))
974 ((eq type 'one-or-more) 945 ((eq type 'one-or-more)
975 (rng-apply-after 946 (let ((ip (rng-intern-optional ipattern)))
976 `(lambda (p) 947 (rng-apply-after
977 (rng-intern-group (list p ,(rng-intern-optional ipattern)))) 948 (lambda (p) (rng-intern-group (list p ip)))
978 (rng-start-attribute-deriv (rng-ipattern-get-child ipattern) 949 (rng-start-attribute-deriv (rng--ipattern-child ipattern)
979 nm))) 950 nm))))
980 ((eq type 'after) 951 ((eq type 'after)
981 (rng-apply-after 952 (let ((nip (rng--ipattern-after ipattern)))
982 `(lambda (p) 953 (rng-apply-after
983 (rng-intern-after p ,(rng-ipattern-get-after ipattern))) 954 (lambda (p) (rng-intern-after p nip))
984 (rng-start-attribute-deriv (rng-ipattern-get-child ipattern) 955 (rng-start-attribute-deriv (rng--ipattern-child ipattern)
985 nm))) 956 nm))))
986 (t rng-not-allowed-ipattern)))) 957 (t rng-not-allowed-ipattern))))
987 958
988(defun rng-cons-group-after (x y) 959(defun rng-cons-group-after (x y)
989 (rng-apply-after `(lambda (p) (rng-intern-group (cons p ',y))) 960 (rng-apply-after (lambda (p) (rng-intern-group (cons p y)))
990 x)) 961 x))
991 962
992(defun rng-subst-group-after (new old list) 963(defun rng-subst-group-after (new old list)
993 (rng-apply-after `(lambda (p) 964 (rng-apply-after (lambda (p)
994 (rng-intern-group (rng-substq p ,old ',list))) 965 (rng-intern-group (rng-substq p old list)))
995 new)) 966 new))
996 967
997(defun rng-subst-interleave-after (new old list) 968(defun rng-subst-interleave-after (new old list)
998 (rng-apply-after `(lambda (p) 969 (rng-apply-after (lambda (p)
999 (rng-intern-interleave (rng-substq p ,old ',list))) 970 (rng-intern-interleave (rng-substq p old list)))
1000 new)) 971 new))
1001 972
1002(defun rng-apply-after (f ipattern) 973(defun rng-apply-after (f ipattern)
1003 (let ((type (rng-ipattern-get-type ipattern))) 974 (let ((type (rng--ipattern-type ipattern)))
1004 (cond ((eq type 'after) 975 (cond ((eq type 'after)
1005 (rng-intern-after 976 (rng-intern-after
1006 (rng-ipattern-get-child ipattern) 977 (rng--ipattern-child ipattern)
1007 (funcall f 978 (funcall f (rng--ipattern-after ipattern))))
1008 (rng-ipattern-get-after ipattern))))
1009 ((eq type 'choice) 979 ((eq type 'choice)
1010 (rng-transform-choice `(lambda (x) (rng-apply-after ,f x)) 980 (rng-transform-choice (lambda (x) (rng-apply-after f x))
1011 ipattern)) 981 ipattern))
1012 (t rng-not-allowed-ipattern)))) 982 (t rng-not-allowed-ipattern))))
1013 983
1014(defun rng-start-tag-close-deriv (ipattern) 984(defun rng-start-tag-close-deriv (ipattern)
1015 (or (rng-ipattern-get-memo-start-tag-close-deriv ipattern) 985 (or (rng--ipattern-memo-start-tag-close-deriv ipattern)
1016 (rng-ipattern-set-memo-start-tag-close-deriv 986 (setf (rng--ipattern-memo-start-tag-close-deriv ipattern)
1017 ipattern 987 (rng-compute-start-tag-close-deriv ipattern))))
1018 (rng-compute-start-tag-close-deriv ipattern))))
1019 988
1020(defconst rng-transform-map 989(defconst rng-transform-map
1021 '((choice . rng-transform-choice) 990 '((choice . rng-transform-choice)
@@ -1025,7 +994,7 @@ list may contain duplicates."
1025 (after . rng-transform-after-child))) 994 (after . rng-transform-after-child)))
1026 995
1027(defun rng-compute-start-tag-close-deriv (ipattern) 996(defun rng-compute-start-tag-close-deriv (ipattern)
1028 (let* ((type (rng-ipattern-get-type ipattern))) 997 (let* ((type (rng--ipattern-type ipattern)))
1029 (if (eq type 'attribute) 998 (if (eq type 'attribute)
1030 rng-not-allowed-ipattern 999 rng-not-allowed-ipattern
1031 (let ((transform (assq type rng-transform-map))) 1000 (let ((transform (assq type rng-transform-map)))
@@ -1036,7 +1005,7 @@ list may contain duplicates."
1036 ipattern))))) 1005 ipattern)))))
1037 1006
1038(defun rng-ignore-attributes-deriv (ipattern) 1007(defun rng-ignore-attributes-deriv (ipattern)
1039 (let* ((type (rng-ipattern-get-type ipattern))) 1008 (let* ((type (rng--ipattern-type ipattern)))
1040 (if (eq type 'attribute) 1009 (if (eq type 'attribute)
1041 rng-empty-ipattern 1010 rng-empty-ipattern
1042 (let ((transform (assq type rng-transform-map))) 1011 (let ((transform (assq type rng-transform-map)))
@@ -1047,13 +1016,12 @@ list may contain duplicates."
1047 ipattern))))) 1016 ipattern)))))
1048 1017
1049(defun rng-text-only-deriv (ipattern) 1018(defun rng-text-only-deriv (ipattern)
1050 (or (rng-ipattern-get-memo-text-only-deriv ipattern) 1019 (or (rng--ipattern-memo-text-only-deriv ipattern)
1051 (rng-ipattern-set-memo-text-only-deriv 1020 (setf (rng--ipattern-memo-text-only-deriv ipattern)
1052 ipattern 1021 (rng-compute-text-only-deriv ipattern))))
1053 (rng-compute-text-only-deriv ipattern))))
1054 1022
1055(defun rng-compute-text-only-deriv (ipattern) 1023(defun rng-compute-text-only-deriv (ipattern)
1056 (let* ((type (rng-ipattern-get-type ipattern))) 1024 (let* ((type (rng--ipattern-type ipattern)))
1057 (if (eq type 'element) 1025 (if (eq type 'element)
1058 rng-not-allowed-ipattern 1026 rng-not-allowed-ipattern
1059 (let ((transform (assq type 1027 (let ((transform (assq type
@@ -1069,13 +1037,12 @@ list may contain duplicates."
1069 ipattern))))) 1037 ipattern)))))
1070 1038
1071(defun rng-mixed-text-deriv (ipattern) 1039(defun rng-mixed-text-deriv (ipattern)
1072 (or (rng-ipattern-get-memo-mixed-text-deriv ipattern) 1040 (or (rng--ipattern-memo-mixed-text-deriv ipattern)
1073 (rng-ipattern-set-memo-mixed-text-deriv 1041 (setf (rng--ipattern-memo-mixed-text-deriv ipattern)
1074 ipattern 1042 (rng-compute-mixed-text-deriv ipattern))))
1075 (rng-compute-mixed-text-deriv ipattern))))
1076 1043
1077(defun rng-compute-mixed-text-deriv (ipattern) 1044(defun rng-compute-mixed-text-deriv (ipattern)
1078 (let ((type (rng-ipattern-get-type ipattern))) 1045 (let ((type (rng--ipattern-type ipattern)))
1079 (cond ((eq type 'text) ipattern) 1046 (cond ((eq type 'text) ipattern)
1080 ((eq type 'after) 1047 ((eq type 'after)
1081 (rng-transform-after-child 'rng-mixed-text-deriv 1048 (rng-transform-after-child 'rng-mixed-text-deriv
@@ -1086,7 +1053,7 @@ list may contain duplicates."
1086 ((eq type 'one-or-more) 1053 ((eq type 'one-or-more)
1087 (rng-intern-group 1054 (rng-intern-group
1088 (list (rng-mixed-text-deriv 1055 (list (rng-mixed-text-deriv
1089 (rng-ipattern-get-child ipattern)) 1056 (rng--ipattern-child ipattern))
1090 (rng-intern-optional ipattern)))) 1057 (rng-intern-optional ipattern))))
1091 ((eq type 'group) 1058 ((eq type 'group)
1092 (rng-transform-group-nullable 1059 (rng-transform-group-nullable
@@ -1100,39 +1067,38 @@ list may contain duplicates."
1100 (rng-substq new old list))) 1067 (rng-substq new old list)))
1101 ipattern)) 1068 ipattern))
1102 ((and (eq type 'data) 1069 ((and (eq type 'data)
1103 (not (rng-ipattern-get-memo-text-typed ipattern))) 1070 (not (rng--ipattern-memo-text-typed ipattern)))
1104 ipattern) 1071 ipattern)
1105 (t rng-not-allowed-ipattern)))) 1072 (t rng-not-allowed-ipattern))))
1106 1073
1107(defun rng-end-tag-deriv (ipattern) 1074(defun rng-end-tag-deriv (ipattern)
1108 (or (rng-ipattern-get-memo-end-tag-deriv ipattern) 1075 (or (rng--ipattern-memo-end-tag-deriv ipattern)
1109 (rng-ipattern-set-memo-end-tag-deriv 1076 (setf (rng--ipattern-memo-end-tag-deriv ipattern)
1110 ipattern 1077 (rng-compute-end-tag-deriv ipattern))))
1111 (rng-compute-end-tag-deriv ipattern))))
1112 1078
1113(defun rng-compute-end-tag-deriv (ipattern) 1079(defun rng-compute-end-tag-deriv (ipattern)
1114 (let ((type (rng-ipattern-get-type ipattern))) 1080 (let ((type (rng--ipattern-type ipattern)))
1115 (cond ((eq type 'choice) 1081 (cond ((eq type 'choice)
1116 (rng-intern-choice 1082 (rng-intern-choice
1117 (mapcar 'rng-end-tag-deriv 1083 (mapcar 'rng-end-tag-deriv
1118 (rng-ipattern-get-child ipattern)))) 1084 (rng--ipattern-child ipattern))))
1119 ((eq type 'after) 1085 ((eq type 'after)
1120 (if (rng-ipattern-get-nullable 1086 (if (rng--ipattern-nullable
1121 (rng-ipattern-get-child ipattern)) 1087 (rng--ipattern-child ipattern))
1122 (rng-ipattern-get-after ipattern) 1088 (rng--ipattern-after ipattern)
1123 rng-not-allowed-ipattern)) 1089 rng-not-allowed-ipattern))
1124 (t rng-not-allowed-ipattern)))) 1090 (t rng-not-allowed-ipattern))))
1125 1091
1126(defun rng-data-deriv (ipattern value) 1092(defun rng-data-deriv (ipattern value)
1127 (or (rng-memo-map-get value 1093 (or (rng-memo-map-get value
1128 (rng-ipattern-get-memo-map-data-deriv ipattern)) 1094 (rng--ipattern-memo-map-data-deriv ipattern))
1129 (and (rng-memo-map-get 1095 (and (rng-memo-map-get
1130 (cons value (rng-namespace-context-get-no-trace)) 1096 (cons value (rng-namespace-context-get-no-trace))
1131 (rng-ipattern-get-memo-map-data-deriv ipattern)) 1097 (rng--ipattern-memo-map-data-deriv ipattern))
1132 (rng-memo-map-get 1098 (rng-memo-map-get
1133 (cons value (apply (car rng-dt-namespace-context-getter) 1099 (cons value (apply (car rng-dt-namespace-context-getter)
1134 (cdr rng-dt-namespace-context-getter))) 1100 (cdr rng-dt-namespace-context-getter)))
1135 (rng-ipattern-get-memo-map-data-deriv ipattern))) 1101 (rng--ipattern-memo-map-data-deriv ipattern)))
1136 (let* ((used-context (vector nil)) 1102 (let* ((used-context (vector nil))
1137 (rng-dt-namespace-context-getter 1103 (rng-dt-namespace-context-getter
1138 (cons 'rng-namespace-context-tracer 1104 (cons 'rng-namespace-context-tracer
@@ -1161,66 +1127,65 @@ list may contain duplicates."
1161(defun rng-ipattern-memo-data-deriv (ipattern value context deriv) 1127(defun rng-ipattern-memo-data-deriv (ipattern value context deriv)
1162 (or (memq ipattern rng-const-ipatterns) 1128 (or (memq ipattern rng-const-ipatterns)
1163 (> (length value) rng-memo-data-deriv-max-length) 1129 (> (length value) rng-memo-data-deriv-max-length)
1164 (rng-ipattern-set-memo-map-data-deriv 1130 (setf (rng--ipattern-memo-map-data-deriv ipattern)
1165 ipattern 1131 (rng-memo-map-add (if context (cons value context) value)
1166 (rng-memo-map-add (if context (cons value context) value) 1132 deriv
1167 deriv 1133 (rng--ipattern-memo-map-data-deriv ipattern)
1168 (rng-ipattern-get-memo-map-data-deriv ipattern) 1134 t)))
1169 t)))
1170 deriv) 1135 deriv)
1171 1136
1172(defun rng-compute-data-deriv (ipattern value) 1137(defun rng-compute-data-deriv (ipattern value)
1173 (let ((type (rng-ipattern-get-type ipattern))) 1138 (let ((type (rng--ipattern-type ipattern)))
1174 (cond ((eq type 'text) ipattern) 1139 (cond ((eq type 'text) ipattern)
1175 ((eq type 'choice) 1140 ((eq type 'choice)
1176 (rng-transform-choice `(lambda (p) (rng-data-deriv p ,value)) 1141 (rng-transform-choice (lambda (p) (rng-data-deriv p value))
1177 ipattern)) 1142 ipattern))
1178 ((eq type 'group) 1143 ((eq type 'group)
1179 (rng-transform-group-nullable 1144 (rng-transform-group-nullable
1180 `(lambda (p) (rng-data-deriv p ,value)) 1145 (lambda (p) (rng-data-deriv p value))
1181 (lambda (x y) (rng-intern-group (cons x y))) 1146 (lambda (x y) (rng-intern-group (cons x y)))
1182 ipattern)) 1147 ipattern))
1183 ((eq type 'one-or-more) 1148 ((eq type 'one-or-more)
1184 (rng-intern-group (list (rng-data-deriv 1149 (rng-intern-group (list (rng-data-deriv
1185 (rng-ipattern-get-child ipattern) 1150 (rng--ipattern-child ipattern)
1186 value) 1151 value)
1187 (rng-intern-optional ipattern)))) 1152 (rng-intern-optional ipattern))))
1188 ((eq type 'after) 1153 ((eq type 'after)
1189 (let ((child (rng-ipattern-get-child ipattern))) 1154 (let ((child (rng--ipattern-child ipattern)))
1190 (if (or (rng-ipattern-get-nullable 1155 (if (or (rng--ipattern-nullable
1191 (rng-data-deriv child value)) 1156 (rng-data-deriv child value))
1192 (and (rng-ipattern-get-nullable child) 1157 (and (rng--ipattern-nullable child)
1193 (rng-blank-p value))) 1158 (rng-blank-p value)))
1194 (rng-ipattern-get-after ipattern) 1159 (rng--ipattern-after ipattern)
1195 rng-not-allowed-ipattern))) 1160 rng-not-allowed-ipattern)))
1196 ((eq type 'data) 1161 ((eq type 'data)
1197 (if (rng-dt-make-value (rng-ipattern-get-datatype ipattern) 1162 (if (rng-dt-make-value (rng--ipattern-datatype ipattern)
1198 value) 1163 value)
1199 rng-empty-ipattern 1164 rng-empty-ipattern
1200 rng-not-allowed-ipattern)) 1165 rng-not-allowed-ipattern))
1201 ((eq type 'data-except) 1166 ((eq type 'data-except)
1202 (if (and (rng-dt-make-value (rng-ipattern-get-datatype ipattern) 1167 (if (and (rng-dt-make-value (rng--ipattern-datatype ipattern)
1203 value) 1168 value)
1204 (not (rng-ipattern-get-nullable 1169 (not (rng--ipattern-nullable
1205 (rng-data-deriv 1170 (rng-data-deriv
1206 (rng-ipattern-get-child ipattern) 1171 (rng--ipattern-child ipattern)
1207 value)))) 1172 value))))
1208 rng-empty-ipattern 1173 rng-empty-ipattern
1209 rng-not-allowed-ipattern)) 1174 rng-not-allowed-ipattern))
1210 ((eq type 'value) 1175 ((eq type 'value)
1211 (if (equal (rng-dt-make-value (rng-ipattern-get-datatype ipattern) 1176 (if (equal (rng-dt-make-value (rng--ipattern-datatype ipattern)
1212 value) 1177 value)
1213 (rng-ipattern-get-value-object ipattern)) 1178 (rng--ipattern-value-object ipattern))
1214 rng-empty-ipattern 1179 rng-empty-ipattern
1215 rng-not-allowed-ipattern)) 1180 rng-not-allowed-ipattern))
1216 ((eq type 'list) 1181 ((eq type 'list)
1217 (let ((tokens (split-string value)) 1182 (let ((tokens (split-string value))
1218 (state (rng-ipattern-get-child ipattern))) 1183 (state (rng--ipattern-child ipattern)))
1219 (while (and tokens 1184 (while (and tokens
1220 (not (eq state rng-not-allowed-ipattern))) 1185 (not (eq state rng-not-allowed-ipattern)))
1221 (setq state (rng-data-deriv state (car tokens))) 1186 (setq state (rng-data-deriv state (car tokens)))
1222 (setq tokens (cdr tokens))) 1187 (setq tokens (cdr tokens)))
1223 (if (rng-ipattern-get-nullable state) 1188 (if (rng--ipattern-nullable state)
1224 rng-empty-ipattern 1189 rng-empty-ipattern
1225 rng-not-allowed-ipattern))) 1190 rng-not-allowed-ipattern)))
1226 ;; don't think interleave can occur 1191 ;; don't think interleave can occur
@@ -1228,7 +1193,7 @@ list may contain duplicates."
1228 (t rng-not-allowed-ipattern)))) 1193 (t rng-not-allowed-ipattern))))
1229 1194
1230(defun rng-transform-multi (f ipattern interner) 1195(defun rng-transform-multi (f ipattern interner)
1231 (let* ((members (rng-ipattern-get-child ipattern)) 1196 (let* ((members (rng--ipattern-child ipattern))
1232 (transformed (mapcar f members))) 1197 (transformed (mapcar f members)))
1233 (if (rng-members-eq members transformed) 1198 (if (rng-members-eq members transformed)
1234 ipattern 1199 ipattern
@@ -1244,22 +1209,22 @@ list may contain duplicates."
1244 (rng-transform-multi f ipattern 'rng-intern-interleave)) 1209 (rng-transform-multi f ipattern 'rng-intern-interleave))
1245 1210
1246(defun rng-transform-one-or-more (f ipattern) 1211(defun rng-transform-one-or-more (f ipattern)
1247 (let* ((child (rng-ipattern-get-child ipattern)) 1212 (let* ((child (rng--ipattern-child ipattern))
1248 (transformed (funcall f child))) 1213 (transformed (funcall f child)))
1249 (if (eq child transformed) 1214 (if (eq child transformed)
1250 ipattern 1215 ipattern
1251 (rng-intern-one-or-more transformed)))) 1216 (rng-intern-one-or-more transformed))))
1252 1217
1253(defun rng-transform-after-child (f ipattern) 1218(defun rng-transform-after-child (f ipattern)
1254 (let* ((child (rng-ipattern-get-child ipattern)) 1219 (let* ((child (rng--ipattern-child ipattern))
1255 (transformed (funcall f child))) 1220 (transformed (funcall f child)))
1256 (if (eq child transformed) 1221 (if (eq child transformed)
1257 ipattern 1222 ipattern
1258 (rng-intern-after transformed 1223 (rng-intern-after transformed
1259 (rng-ipattern-get-after ipattern))))) 1224 (rng--ipattern-after ipattern)))))
1260 1225
1261(defun rng-transform-interleave-single (f subster ipattern) 1226(defun rng-transform-interleave-single (f subster ipattern)
1262 (let ((children (rng-ipattern-get-child ipattern)) 1227 (let ((children (rng--ipattern-child ipattern))
1263 found) 1228 found)
1264 (while (and children (not found)) 1229 (while (and children (not found))
1265 (let* ((child (car children)) 1230 (let* ((child (car children))
@@ -1270,7 +1235,7 @@ list may contain duplicates."
1270 (funcall subster 1235 (funcall subster
1271 transformed 1236 transformed
1272 child 1237 child
1273 (rng-ipattern-get-child ipattern)))))) 1238 (rng--ipattern-child ipattern))))))
1274 (or found 1239 (or found
1275 rng-not-allowed-ipattern))) 1240 rng-not-allowed-ipattern)))
1276 1241
@@ -1286,14 +1251,14 @@ nullable and y1 isn't, return a choice
1286 (rng-transform-group-nullable-gen-choices 1251 (rng-transform-group-nullable-gen-choices
1287 f 1252 f
1288 conser 1253 conser
1289 (rng-ipattern-get-child ipattern)))) 1254 (rng--ipattern-child ipattern))))
1290 1255
1291(defun rng-transform-group-nullable-gen-choices (f conser members) 1256(defun rng-transform-group-nullable-gen-choices (f conser members)
1292 (let ((head (car members)) 1257 (let ((head (car members))
1293 (tail (cdr members))) 1258 (tail (cdr members)))
1294 (if tail 1259 (if tail
1295 (cons (funcall conser (funcall f head) tail) 1260 (cons (funcall conser (funcall f head) tail)
1296 (if (rng-ipattern-get-nullable head) 1261 (if (rng--ipattern-nullable head)
1297 (rng-transform-group-nullable-gen-choices f conser tail) 1262 (rng-transform-group-nullable-gen-choices f conser tail)
1298 nil)) 1263 nil))
1299 (list (funcall f head))))) 1264 (list (funcall f head)))))
@@ -1308,11 +1273,11 @@ nullable and y1 isn't, return a choice
1308 1273
1309 1274
1310(defun rng-ipattern-after (ipattern) 1275(defun rng-ipattern-after (ipattern)
1311 (let ((type (rng-ipattern-get-type ipattern))) 1276 (let ((type (rng--ipattern-type ipattern)))
1312 (cond ((eq type 'choice) 1277 (cond ((eq type 'choice)
1313 (rng-transform-choice 'rng-ipattern-after ipattern)) 1278 (rng-transform-choice 'rng-ipattern-after ipattern))
1314 ((eq type 'after) 1279 ((eq type 'after)
1315 (rng-ipattern-get-after ipattern)) 1280 (rng--ipattern-after ipattern))
1316 ((eq type 'not-allowed) 1281 ((eq type 'not-allowed)
1317 ipattern) 1282 ipattern)
1318 (t (error "Internal error in rng-ipattern-after: unexpected type %s" type))))) 1283 (t (error "Internal error in rng-ipattern-after: unexpected type %s" type)))))
@@ -1321,7 +1286,7 @@ nullable and y1 isn't, return a choice
1321 (rng-intern-after (rng-compile rng-any-content) ipattern)) 1286 (rng-intern-after (rng-compile rng-any-content) ipattern))
1322 1287
1323(defun rng-ipattern-optionalize-elements (ipattern) 1288(defun rng-ipattern-optionalize-elements (ipattern)
1324 (let* ((type (rng-ipattern-get-type ipattern)) 1289 (let* ((type (rng--ipattern-type ipattern))
1325 (transform (assq type rng-transform-map))) 1290 (transform (assq type rng-transform-map)))
1326 (cond (transform 1291 (cond (transform
1327 (funcall (cdr transform) 1292 (funcall (cdr transform)
@@ -1332,11 +1297,11 @@ nullable and y1 isn't, return a choice
1332 (t ipattern)))) 1297 (t ipattern))))
1333 1298
1334(defun rng-ipattern-empty-before-p (ipattern) 1299(defun rng-ipattern-empty-before-p (ipattern)
1335 (let ((type (rng-ipattern-get-type ipattern))) 1300 (let ((type (rng--ipattern-type ipattern)))
1336 (cond ((eq type 'after) 1301 (cond ((eq type 'after)
1337 (eq (rng-ipattern-get-child ipattern) rng-empty-ipattern)) 1302 (eq (rng--ipattern-child ipattern) rng-empty-ipattern))
1338 ((eq type 'choice) 1303 ((eq type 'choice)
1339 (let ((members (rng-ipattern-get-child ipattern)) 1304 (let ((members (rng--ipattern-child ipattern))
1340 (ret t)) 1305 (ret t))
1341 (while (and members ret) 1306 (while (and members ret)
1342 (or (rng-ipattern-empty-before-p (car members)) 1307 (or (rng-ipattern-empty-before-p (car members))
@@ -1346,13 +1311,13 @@ nullable and y1 isn't, return a choice
1346 (t nil)))) 1311 (t nil))))
1347 1312
1348(defun rng-ipattern-possible-start-tags (ipattern accum) 1313(defun rng-ipattern-possible-start-tags (ipattern accum)
1349 (let ((type (rng-ipattern-get-type ipattern))) 1314 (let ((type (rng--ipattern-type ipattern)))
1350 (cond ((eq type 'after) 1315 (cond ((eq type 'after)
1351 (rng-ipattern-possible-start-tags 1316 (rng-ipattern-possible-start-tags
1352 (rng-ipattern-get-child ipattern) 1317 (rng--ipattern-child ipattern)
1353 accum)) 1318 accum))
1354 ((memq type '(choice interleave)) 1319 ((memq type '(choice interleave))
1355 (let ((members (rng-ipattern-get-child ipattern))) 1320 (let ((members (rng--ipattern-child ipattern)))
1356 (while members 1321 (while members
1357 (setq accum 1322 (setq accum
1358 (rng-ipattern-possible-start-tags (car members) 1323 (rng-ipattern-possible-start-tags (car members)
@@ -1360,34 +1325,34 @@ nullable and y1 isn't, return a choice
1360 (setq members (cdr members)))) 1325 (setq members (cdr members))))
1361 accum) 1326 accum)
1362 ((eq type 'group) 1327 ((eq type 'group)
1363 (let ((members (rng-ipattern-get-child ipattern))) 1328 (let ((members (rng--ipattern-child ipattern)))
1364 (while members 1329 (while members
1365 (setq accum 1330 (setq accum
1366 (rng-ipattern-possible-start-tags (car members) 1331 (rng-ipattern-possible-start-tags (car members)
1367 accum)) 1332 accum))
1368 (setq members 1333 (setq members
1369 (and (rng-ipattern-get-nullable (car members)) 1334 (and (rng--ipattern-nullable (car members))
1370 (cdr members))))) 1335 (cdr members)))))
1371 accum) 1336 accum)
1372 ((eq type 'element) 1337 ((eq type 'element)
1373 (if (eq (rng-element-get-child ipattern) rng-not-allowed-ipattern) 1338 (if (eq (rng-element-get-child ipattern) rng-not-allowed-ipattern)
1374 accum 1339 accum
1375 (rng-name-class-possible-names 1340 (rng-name-class-possible-names
1376 (rng-ipattern-get-name-class ipattern) 1341 (rng--ipattern-name-class ipattern)
1377 accum))) 1342 accum)))
1378 ((eq type 'one-or-more) 1343 ((eq type 'one-or-more)
1379 (rng-ipattern-possible-start-tags 1344 (rng-ipattern-possible-start-tags
1380 (rng-ipattern-get-child ipattern) 1345 (rng--ipattern-child ipattern)
1381 accum)) 1346 accum))
1382 (t accum)))) 1347 (t accum))))
1383 1348
1384(defun rng-ipattern-start-tag-possible-p (ipattern) 1349(defun rng-ipattern-start-tag-possible-p (ipattern)
1385 (let ((type (rng-ipattern-get-type ipattern))) 1350 (let ((type (rng--ipattern-type ipattern)))
1386 (cond ((memq type '(after one-or-more)) 1351 (cond ((memq type '(after one-or-more))
1387 (rng-ipattern-start-tag-possible-p 1352 (rng-ipattern-start-tag-possible-p
1388 (rng-ipattern-get-child ipattern))) 1353 (rng--ipattern-child ipattern)))
1389 ((memq type '(choice interleave)) 1354 ((memq type '(choice interleave))
1390 (let ((members (rng-ipattern-get-child ipattern)) 1355 (let ((members (rng--ipattern-child ipattern))
1391 (possible nil)) 1356 (possible nil))
1392 (while (and members (not possible)) 1357 (while (and members (not possible))
1393 (setq possible 1358 (setq possible
@@ -1395,13 +1360,13 @@ nullable and y1 isn't, return a choice
1395 (setq members (cdr members))) 1360 (setq members (cdr members)))
1396 possible)) 1361 possible))
1397 ((eq type 'group) 1362 ((eq type 'group)
1398 (let ((members (rng-ipattern-get-child ipattern)) 1363 (let ((members (rng--ipattern-child ipattern))
1399 (possible nil)) 1364 (possible nil))
1400 (while (and members (not possible)) 1365 (while (and members (not possible))
1401 (setq possible 1366 (setq possible
1402 (rng-ipattern-start-tag-possible-p (car members))) 1367 (rng-ipattern-start-tag-possible-p (car members)))
1403 (setq members 1368 (setq members
1404 (and (rng-ipattern-get-nullable (car members)) 1369 (and (rng--ipattern-nullable (car members))
1405 (cdr members)))) 1370 (cdr members))))
1406 possible)) 1371 possible))
1407 ((eq type 'element) 1372 ((eq type 'element)
@@ -1410,12 +1375,12 @@ nullable and y1 isn't, return a choice
1410 (t nil)))) 1375 (t nil))))
1411 1376
1412(defun rng-ipattern-possible-attributes (ipattern accum) 1377(defun rng-ipattern-possible-attributes (ipattern accum)
1413 (let ((type (rng-ipattern-get-type ipattern))) 1378 (let ((type (rng--ipattern-type ipattern)))
1414 (cond ((eq type 'after) 1379 (cond ((eq type 'after)
1415 (rng-ipattern-possible-attributes (rng-ipattern-get-child ipattern) 1380 (rng-ipattern-possible-attributes (rng--ipattern-child ipattern)
1416 accum)) 1381 accum))
1417 ((memq type '(choice interleave group)) 1382 ((memq type '(choice interleave group))
1418 (let ((members (rng-ipattern-get-child ipattern))) 1383 (let ((members (rng--ipattern-child ipattern)))
1419 (while members 1384 (while members
1420 (setq accum 1385 (setq accum
1421 (rng-ipattern-possible-attributes (car members) 1386 (rng-ipattern-possible-attributes (car members)
@@ -1424,21 +1389,21 @@ nullable and y1 isn't, return a choice
1424 accum) 1389 accum)
1425 ((eq type 'attribute) 1390 ((eq type 'attribute)
1426 (rng-name-class-possible-names 1391 (rng-name-class-possible-names
1427 (rng-ipattern-get-name-class ipattern) 1392 (rng--ipattern-name-class ipattern)
1428 accum)) 1393 accum))
1429 ((eq type 'one-or-more) 1394 ((eq type 'one-or-more)
1430 (rng-ipattern-possible-attributes 1395 (rng-ipattern-possible-attributes
1431 (rng-ipattern-get-child ipattern) 1396 (rng--ipattern-child ipattern)
1432 accum)) 1397 accum))
1433 (t accum)))) 1398 (t accum))))
1434 1399
1435(defun rng-ipattern-possible-values (ipattern accum) 1400(defun rng-ipattern-possible-values (ipattern accum)
1436 (let ((type (rng-ipattern-get-type ipattern))) 1401 (let ((type (rng--ipattern-type ipattern)))
1437 (cond ((eq type 'after) 1402 (cond ((eq type 'after)
1438 (rng-ipattern-possible-values (rng-ipattern-get-child ipattern) 1403 (rng-ipattern-possible-values (rng--ipattern-child ipattern)
1439 accum)) 1404 accum))
1440 ((eq type 'choice) 1405 ((eq type 'choice)
1441 (let ((members (rng-ipattern-get-child ipattern))) 1406 (let ((members (rng--ipattern-child ipattern)))
1442 (while members 1407 (while members
1443 (setq accum 1408 (setq accum
1444 (rng-ipattern-possible-values (car members) 1409 (rng-ipattern-possible-values (car members)
@@ -1446,18 +1411,18 @@ nullable and y1 isn't, return a choice
1446 (setq members (cdr members)))) 1411 (setq members (cdr members))))
1447 accum) 1412 accum)
1448 ((eq type 'value) 1413 ((eq type 'value)
1449 (let ((value-object (rng-ipattern-get-value-object ipattern))) 1414 (let ((value-object (rng--ipattern-value-object ipattern)))
1450 (if (stringp value-object) 1415 (if (stringp value-object)
1451 (cons value-object accum) 1416 (cons value-object accum)
1452 accum))) 1417 accum)))
1453 (t accum)))) 1418 (t accum))))
1454 1419
1455(defun rng-ipattern-required-element (ipattern) 1420(defun rng-ipattern-required-element (ipattern)
1456 (let ((type (rng-ipattern-get-type ipattern))) 1421 (let ((type (rng--ipattern-type ipattern)))
1457 (cond ((memq type '(after one-or-more)) 1422 (cond ((memq type '(after one-or-more))
1458 (rng-ipattern-required-element (rng-ipattern-get-child ipattern))) 1423 (rng-ipattern-required-element (rng--ipattern-child ipattern)))
1459 ((eq type 'choice) 1424 ((eq type 'choice)
1460 (let* ((members (rng-ipattern-get-child ipattern)) 1425 (let* ((members (rng--ipattern-child ipattern))
1461 (required (rng-ipattern-required-element (car members)))) 1426 (required (rng-ipattern-required-element (car members))))
1462 (while (and required 1427 (while (and required
1463 (setq members (cdr members))) 1428 (setq members (cdr members)))
@@ -1466,16 +1431,16 @@ nullable and y1 isn't, return a choice
1466 (setq required nil))) 1431 (setq required nil)))
1467 required)) 1432 required))
1468 ((eq type 'group) 1433 ((eq type 'group)
1469 (let ((members (rng-ipattern-get-child ipattern)) 1434 (let ((members (rng--ipattern-child ipattern))
1470 required) 1435 required)
1471 (while (and (not (setq required 1436 (while (and (not (setq required
1472 (rng-ipattern-required-element 1437 (rng-ipattern-required-element
1473 (car members)))) 1438 (car members))))
1474 (rng-ipattern-get-nullable (car members)) 1439 (rng--ipattern-nullable (car members))
1475 (setq members (cdr members)))) 1440 (setq members (cdr members))))
1476 required)) 1441 required))
1477 ((eq type 'interleave) 1442 ((eq type 'interleave)
1478 (let ((members (rng-ipattern-get-child ipattern)) 1443 (let ((members (rng--ipattern-child ipattern))
1479 required) 1444 required)
1480 (while members 1445 (while members
1481 (let ((tem (rng-ipattern-required-element (car members)))) 1446 (let ((tem (rng-ipattern-required-element (car members))))
@@ -1491,19 +1456,19 @@ nullable and y1 isn't, return a choice
1491 (setq members nil))))) 1456 (setq members nil)))))
1492 required)) 1457 required))
1493 ((eq type 'element) 1458 ((eq type 'element)
1494 (let ((nc (rng-ipattern-get-name-class ipattern))) 1459 (let ((nc (rng--ipattern-name-class ipattern)))
1495 (and (consp nc) 1460 (and (consp nc)
1496 (not (eq (rng-element-get-child ipattern) 1461 (not (eq (rng-element-get-child ipattern)
1497 rng-not-allowed-ipattern)) 1462 rng-not-allowed-ipattern))
1498 nc)))))) 1463 nc))))))
1499 1464
1500(defun rng-ipattern-required-attributes (ipattern accum) 1465(defun rng-ipattern-required-attributes (ipattern accum)
1501 (let ((type (rng-ipattern-get-type ipattern))) 1466 (let ((type (rng--ipattern-type ipattern)))
1502 (cond ((eq type 'after) 1467 (cond ((eq type 'after)
1503 (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern) 1468 (rng-ipattern-required-attributes (rng--ipattern-child ipattern)
1504 accum)) 1469 accum))
1505 ((memq type '(interleave group)) 1470 ((memq type '(interleave group))
1506 (let ((members (rng-ipattern-get-child ipattern))) 1471 (let ((members (rng--ipattern-child ipattern)))
1507 (while members 1472 (while members
1508 (setq accum 1473 (setq accum
1509 (rng-ipattern-required-attributes (car members) 1474 (rng-ipattern-required-attributes (car members)
@@ -1511,7 +1476,7 @@ nullable and y1 isn't, return a choice
1511 (setq members (cdr members)))) 1476 (setq members (cdr members))))
1512 accum) 1477 accum)
1513 ((eq type 'choice) 1478 ((eq type 'choice)
1514 (let ((members (rng-ipattern-get-child ipattern)) 1479 (let ((members (rng--ipattern-child ipattern))
1515 in-all in-this new-in-all) 1480 in-all in-this new-in-all)
1516 (setq in-all 1481 (setq in-all
1517 (rng-ipattern-required-attributes (car members) 1482 (rng-ipattern-required-attributes (car members)
@@ -1528,12 +1493,12 @@ nullable and y1 isn't, return a choice
1528 (setq in-all new-in-all)) 1493 (setq in-all new-in-all))
1529 (append in-all accum))) 1494 (append in-all accum)))
1530 ((eq type 'attribute) 1495 ((eq type 'attribute)
1531 (let ((nc (rng-ipattern-get-name-class ipattern))) 1496 (let ((nc (rng--ipattern-name-class ipattern)))
1532 (if (consp nc) 1497 (if (consp nc)
1533 (cons nc accum) 1498 (cons nc accum)
1534 accum))) 1499 accum)))
1535 ((eq type 'one-or-more) 1500 ((eq type 'one-or-more)
1536 (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern) 1501 (rng-ipattern-required-attributes (rng--ipattern-child ipattern)
1537 accum)) 1502 accum))
1538 (t accum)))) 1503 (t accum))))
1539 1504
@@ -1667,7 +1632,7 @@ for an end-tag is equivalent to empty."
1667 ns)) 1632 ns))
1668 1633
1669(defun rng-match-nullable-p () 1634(defun rng-match-nullable-p ()
1670 (rng-ipattern-get-nullable rng-match-state)) 1635 (rng--ipattern-nullable rng-match-state))
1671 1636
1672(defun rng-match-possible-start-tag-names () 1637(defun rng-match-possible-start-tag-names ()
1673 "Return a list of possible names that would be valid for start-tags. 1638 "Return a list of possible names that would be valid for start-tags.
@@ -1704,16 +1669,15 @@ be exhaustive."
1704 (rng-ipattern-required-attributes rng-match-state nil)) 1669 (rng-ipattern-required-attributes rng-match-state nil))
1705 1670
1706(defmacro rng-match-save (&rest body) 1671(defmacro rng-match-save (&rest body)
1672 (declare (indent 0) (debug t))
1707 (let ((state (make-symbol "state"))) 1673 (let ((state (make-symbol "state")))
1708 `(let ((,state rng-match-state)) 1674 `(let ((,state rng-match-state))
1709 (unwind-protect 1675 (unwind-protect
1710 (progn ,@body) 1676 (progn ,@body)
1711 (setq rng-match-state ,state))))) 1677 (setq rng-match-state ,state)))))
1712 1678
1713(put 'rng-match-save 'lisp-indent-function 0)
1714(def-edebug-spec rng-match-save t)
1715
1716(defmacro rng-match-with-schema (schema &rest body) 1679(defmacro rng-match-with-schema (schema &rest body)
1680 (declare (indent 1) (debug t))
1717 `(let ((rng-current-schema ,schema) 1681 `(let ((rng-current-schema ,schema)
1718 rng-match-state 1682 rng-match-state
1719 rng-compile-table 1683 rng-compile-table
@@ -1724,9 +1688,6 @@ be exhaustive."
1724 (setq rng-match-state (rng-compile rng-current-schema)) 1688 (setq rng-match-state (rng-compile rng-current-schema))
1725 ,@body)) 1689 ,@body))
1726 1690
1727(put 'rng-match-with-schema 'lisp-indent-function 1)
1728(def-edebug-spec rng-match-with-schema t)
1729
1730(provide 'rng-match) 1691(provide 'rng-match)
1731 1692
1732;;; rng-match.el ends here 1693;;; rng-match.el ends here
diff --git a/lisp/nxml/xmltok.el b/lisp/nxml/xmltok.el
index 9bfcd21618d..a4ad0de853e 100644
--- a/lisp/nxml/xmltok.el
+++ b/lisp/nxml/xmltok.el
@@ -1,4 +1,4 @@
1;;; xmltok.el --- XML tokenization 1;;; xmltok.el --- XML tokenization -*- lexical-binding:t -*-
2 2
3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc. 3;; Copyright (C) 2003, 2007-2013 Free Software Foundation, Inc.
4 4
@@ -142,6 +142,7 @@ string giving the error message and START and END are integers
142indicating the position of the error.") 142indicating the position of the error.")
143 143
144(defmacro xmltok-save (&rest body) 144(defmacro xmltok-save (&rest body)
145 (declare (indent 0) (debug t))
145 `(let (xmltok-type 146 `(let (xmltok-type
146 xmltok-start 147 xmltok-start
147 xmltok-name-colon 148 xmltok-name-colon
@@ -152,9 +153,6 @@ indicating the position of the error.")
152 xmltok-errors) 153 xmltok-errors)
153 ,@body)) 154 ,@body))
154 155
155(put 'xmltok-save 'lisp-indent-function 0)
156(def-edebug-spec xmltok-save t)
157
158(defsubst xmltok-attribute-name-start (att) 156(defsubst xmltok-attribute-name-start (att)
159 (aref att 0)) 157 (aref att 0))
160 158
@@ -411,7 +409,6 @@ Return the type of the token."
411(eval-when-compile 409(eval-when-compile
412 (let* ((or "\\|") 410 (let* ((or "\\|")
413 (open "\\(?:") 411 (open "\\(?:")
414 (gopen "\\(")
415 (close "\\)") 412 (close "\\)")
416 (name-start-char "[_[:alpha:]]") 413 (name-start-char "[_[:alpha:]]")
417 (name-continue-not-start-char "[-.[:digit:]]") 414 (name-continue-not-start-char "[-.[:digit:]]")
@@ -988,33 +985,6 @@ Return the type of the token."
988 (xmltok-valid-char-p n) 985 (xmltok-valid-char-p n)
989 n))) 986 n)))
990 987
991(defun xmltok-unclosed-reparse-p (change-start
992 change-end
993 pre-change-length
994 start
995 end
996 delimiter)
997 (let ((len-1 (1- (length delimiter))))
998 (goto-char (max start (- change-start len-1)))
999 (search-forward delimiter (min end (+ change-end len-1)) t)))
1000
1001;; Handles a <!-- with the next -- not followed by >
1002
1003(defun xmltok-semi-closed-reparse-p (change-start
1004 change-end
1005 pre-change-length
1006 start
1007 end
1008 delimiter
1009 delimiter-length)
1010 (or (<= (- end delimiter-length) change-end)
1011 (xmltok-unclosed-reparse-p change-start
1012 change-end
1013 pre-change-length
1014 start
1015 end
1016 delimiter)))
1017
1018(defun xmltok-valid-char-p (n) 988(defun xmltok-valid-char-p (n)
1019 "Return non-nil if N is the Unicode code of a valid XML character." 989 "Return non-nil if N is the Unicode code of a valid XML character."
1020 (cond ((< n #x20) (memq n '(#xA #xD #x9))) 990 (cond ((< n #x20) (memq n '(#xA #xD #x9)))
@@ -1072,7 +1042,7 @@ Adds to `xmltok-errors' as appropriate."
1072 (setq xmltok-dtd xmltok-predefined-entity-alist) 1042 (setq xmltok-dtd xmltok-predefined-entity-alist)
1073 (xmltok-scan-xml-declaration) 1043 (xmltok-scan-xml-declaration)
1074 (xmltok-next-prolog-token) 1044 (xmltok-next-prolog-token)
1075 (while (condition-case err 1045 (while (condition-case nil
1076 (when (xmltok-parse-prolog-item) 1046 (when (xmltok-parse-prolog-item)
1077 (xmltok-next-prolog-token)) 1047 (xmltok-next-prolog-token))
1078 (xmltok-markup-declaration-parse-error 1048 (xmltok-markup-declaration-parse-error
@@ -1371,7 +1341,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT."
1371 (t 1341 (t
1372 (let ((xmltok-start (1- (point))) 1342 (let ((xmltok-start (1- (point)))
1373 xmltok-type xmltok-replacement) 1343 xmltok-type xmltok-replacement)
1374 (xmltok-scan-after-amp (lambda (start end))) 1344 (xmltok-scan-after-amp (lambda (_start _end)))
1375 (cond ((eq xmltok-type 'char-ref) 1345 (cond ((eq xmltok-type 'char-ref)
1376 (setq value-parts 1346 (setq value-parts
1377 (cons (buffer-substring-no-properties 1347 (cons (buffer-substring-no-properties