[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to lisp/nxml/rng-match.el
|
From: |
Mark A. Hershberger |
|
Subject: |
[Emacs-diffs] Changes to lisp/nxml/rng-match.el |
|
Date: |
Fri, 23 Nov 2007 06:58:20 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Mark A. Hershberger <hexmode> 07/11/23 06:58:00
Index: lisp/nxml/rng-match.el
===================================================================
RCS file: lisp/nxml/rng-match.el
diff -N lisp/nxml/rng-match.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ lisp/nxml/rng-match.el 23 Nov 2007 06:57:51 -0000 1.1
@@ -0,0 +1,1739 @@
+;;; rng-match.el --- matching of RELAX NG patterns against XML events
+
+;; Copyright (C) 2003 Free Software Foundation, Inc.
+
+;; Author: James Clark
+;; Keywords: XML, RelaxNG
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be
+;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE. See the GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+;; MA 02111-1307 USA
+
+;;; Commentary:
+
+;; This uses the algorithm described in
+;; http://www.thaiopensource.com/relaxng/derivative.html
+;;
+;; The schema to be used is contained in the variable
+;; rng-current-schema. It has the form described in the file
+;; rng-pttrn.el.
+;;
+;;; Code:
+
+(require 'rng-pttrn)
+(require 'rng-util)
+(require 'rng-dt)
+
+(defvar rng-not-allowed-ipattern nil)
+(defvar rng-empty-ipattern nil)
+(defvar rng-text-ipattern nil)
+
+(defvar rng-compile-table nil)
+
+(defvar rng-being-compiled nil
+ "Contains a list of ref patterns currently being compiled.
+Used to detect illegal recursive references.")
+
+(defvar rng-ipattern-table nil)
+
+(defvar rng-last-ipattern-index nil)
+
+(defvar rng-match-state nil
+ "An ipattern representing the current state of validation.")
+
+;;; Inline functions
+
+(defsubst rng-update-match-state (new-state)
+ (if (and (eq new-state rng-not-allowed-ipattern)
+ (not (eq rng-match-state rng-not-allowed-ipattern)))
+ nil
+ (setq rng-match-state new-state)
+ t))
+
+;;; Interned patterns
+
+(eval-when-compile
+ (defun rng-ipattern-slot-accessor-name (slot-name)
+ (intern (concat "rng-ipattern-get-"
+ (symbol-name slot-name))))
+
+ (defun rng-ipattern-slot-setter-name (slot-name)
+ (intern (concat "rng-ipattern-set-"
+ (symbol-name slot-name)))))
+
+(defmacro rng-ipattern-defslot (slot-name index)
+ `(progn
+ (defsubst ,(rng-ipattern-slot-accessor-name slot-name) (ipattern)
+ (aref ipattern ,index))
+ (defsubst ,(rng-ipattern-slot-setter-name slot-name) (ipattern value)
+ (aset ipattern ,index value))))
+
+(rng-ipattern-defslot type 0)
+(rng-ipattern-defslot index 1)
+(rng-ipattern-defslot name-class 2)
+(rng-ipattern-defslot datatype 2)
+(rng-ipattern-defslot after 2)
+(rng-ipattern-defslot child 3)
+(rng-ipattern-defslot value-object 3)
+(rng-ipattern-defslot nullable 4)
+(rng-ipattern-defslot memo-text-typed 5)
+(rng-ipattern-defslot memo-map-start-tag-open-deriv 6)
+(rng-ipattern-defslot memo-map-start-attribute-deriv 7)
+(rng-ipattern-defslot memo-start-tag-close-deriv 8)
+(rng-ipattern-defslot memo-text-only-deriv 9)
+(rng-ipattern-defslot memo-mixed-text-deriv 10)
+(rng-ipattern-defslot memo-map-data-deriv 11)
+(rng-ipattern-defslot memo-end-tag-deriv 12)
+
+(defconst rng-memo-map-alist-max 10)
+
+(defsubst rng-memo-map-get (key mm)
+ "Return the value associated with KEY in memo-map MM."
+ (let ((found (assoc key mm)))
+ (if found
+ (cdr found)
+ (and mm
+ (let ((head (car mm)))
+ (and (hash-table-p head)
+ (gethash key head)))))))
+
+(defun rng-memo-map-add (key value mm &optional weakness)
+ "Associate KEY with VALUE in memo-map MM and return the new memo-map.
+The new memo-map may or may not be a different object from MM.
+
+Alists are better for small maps. Hash tables are better for large
+maps. A memo-map therefore starts off as an alist and switches to a
+hash table for large memo-maps. A memo-map is always a list. An empty
+memo-map is represented by nil. A large memo-map is represented by a
+list containing just a hash-table. A small memo map is represented by
+a list whose cdr is an alist and whose car is the number of entries in
+the alist. The complete memo-map can be passed to assoc without
+problems: assoc ignores any members that are not cons cells. There is
+therefore minimal overhead in successful lookups on small lists
+\(which is the most common case)."
+ (if (null mm)
+ (list 1 (cons key value))
+ (let ((head (car mm)))
+ (cond ((hash-table-p head)
+ (puthash key value head)
+ mm)
+ ((>= head rng-memo-map-alist-max)
+ (let ((ht (make-hash-table :test 'equal
+ :weakness weakness
+ :size (* 2 rng-memo-map-alist-max))))
+ (setq mm (cdr mm))
+ (while mm
+ (setq head (car mm))
+ (puthash (car head) (cdr head) ht)
+ (setq mm (cdr mm)))
+ (cons ht nil)))
+ (t (cons (1+ head)
+ (cons (cons key value)
+ (cdr mm))))))))
+
+(defsubst rng-make-ipattern (type index name-class child nullable)
+ (vector type index name-class child nullable
+ ;; 5 memo-text-typed
+ 'unknown
+ ;; 6 memo-map-start-tag-open-deriv
+ nil
+ ;; 7 memo-map-start-attribute-deriv
+ nil
+ ;; 8 memo-start-tag-close-deriv
+ nil
+ ;; 9 memo-text-only-deriv
+ nil
+ ;; 10 memo-mixed-text-deriv
+ nil
+ ;; 11 memo-map-data-deriv
+ nil
+ ;; 12 memo-end-tag-deriv
+ nil))
+
+(defun rng-ipattern-maybe-init ()
+ (unless rng-ipattern-table
+ (setq rng-ipattern-table (make-hash-table :test 'equal))
+ (setq rng-last-ipattern-index -1)))
+
+(defun rng-ipattern-clear ()
+ (when rng-ipattern-table
+ (clrhash rng-ipattern-table))
+ (setq rng-last-ipattern-index -1))
+
+(defsubst rng-gen-ipattern-index ()
+ (setq rng-last-ipattern-index (1+ rng-last-ipattern-index)))
+
+(defun rng-put-ipattern (key type name-class child nullable)
+ (let ((ipattern
+ (rng-make-ipattern type
+ (rng-gen-ipattern-index)
+ name-class
+ child
+ nullable)))
+ (puthash key ipattern rng-ipattern-table)
+ ipattern))
+
+(defun rng-get-ipattern (key)
+ (gethash key rng-ipattern-table))
+
+(or rng-not-allowed-ipattern
+ (setq rng-not-allowed-ipattern
+ (rng-make-ipattern 'not-allowed -3 nil nil nil)))
+
+(or rng-empty-ipattern
+ (setq rng-empty-ipattern
+ (rng-make-ipattern 'empty -2 nil nil t)))
+
+(or rng-text-ipattern
+ (setq rng-text-ipattern
+ (rng-make-ipattern 'text -1 nil nil t)))
+
+(defconst rng-const-ipatterns
+ (list rng-not-allowed-ipattern
+ rng-empty-ipattern
+ rng-text-ipattern))
+
+(defun rng-intern-after (child after)
+ (if (eq child rng-not-allowed-ipattern)
+ rng-not-allowed-ipattern
+ (let ((key (list 'after
+ (rng-ipattern-get-index child)
+ (rng-ipattern-get-index after))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'after
+ after
+ child
+ nil)))))
+
+(defun rng-intern-attribute (name-class ipattern)
+ (if (eq ipattern rng-not-allowed-ipattern)
+ rng-not-allowed-ipattern
+ (let ((key (list 'attribute
+ name-class
+ (rng-ipattern-get-index ipattern))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'attribute
+ name-class
+ ipattern
+ nil)))))
+
+(defun rng-intern-data (dt matches-anything)
+ (let ((key (list 'data dt)))
+ (or (rng-get-ipattern key)
+ (let ((ipattern (rng-put-ipattern key
+ 'data
+ dt
+ nil
+ matches-anything)))
+ (rng-ipattern-set-memo-text-typed ipattern
+ (not matches-anything))
+ ipattern))))
+
+(defun rng-intern-data-except (dt ipattern)
+ (let ((key (list 'data-except dt ipattern)))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'data-except
+ dt
+ ipattern
+ nil))))
+
+(defun rng-intern-value (dt obj)
+ (let ((key (list 'value dt obj)))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'value
+ dt
+ obj
+ nil))))
+
+(defun rng-intern-one-or-more (ipattern)
+ (or (rng-intern-one-or-more-shortcut ipattern)
+ (let ((key (cons 'one-or-more
+ (list (rng-ipattern-get-index ipattern)))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'one-or-more
+ nil
+ ipattern
+ (rng-ipattern-get-nullable ipattern))))))
+
+(defun rng-intern-one-or-more-shortcut (ipattern)
+ (cond ((eq ipattern rng-not-allowed-ipattern)
+ rng-not-allowed-ipattern)
+ ((eq ipattern rng-empty-ipattern)
+ rng-empty-ipattern)
+ ((eq (rng-ipattern-get-type ipattern) 'one-or-more)
+ ipattern)
+ (t nil)))
+
+(defun rng-intern-list (ipattern)
+ (if (eq ipattern rng-not-allowed-ipattern)
+ rng-not-allowed-ipattern
+ (let ((key (cons 'list
+ (list (rng-ipattern-get-index ipattern)))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'list
+ nil
+ ipattern
+ nil)))))
+
+(defun rng-intern-group (ipatterns)
+ "Return a ipattern for the list of group members in IPATTERNS."
+ (or (rng-intern-group-shortcut ipatterns)
+ (let* ((tem (rng-normalize-group-list ipatterns))
+ (normalized (cdr tem)))
+ (or (rng-intern-group-shortcut normalized)
+ (let ((key (cons 'group
+ (mapcar 'rng-ipattern-get-index normalized))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'group
+ nil
+ normalized
+ (car tem))))))))
+
+(defun rng-intern-group-shortcut (ipatterns)
+ "Try to shortcut interning a group list. If successful, return the
+interned pattern. Otherwise return nil."
+ (while (and ipatterns
+ (eq (car ipatterns) rng-empty-ipattern))
+ (setq ipatterns (cdr ipatterns)))
+ (if ipatterns
+ (let ((ret (car ipatterns)))
+ (if (eq ret rng-not-allowed-ipattern)
+ rng-not-allowed-ipattern
+ (setq ipatterns (cdr ipatterns))
+ (while (and ipatterns ret)
+ (let ((tem (car ipatterns)))
+ (cond ((eq tem rng-not-allowed-ipattern)
+ (setq ret tem)
+ (setq ipatterns nil))
+ ((eq tem rng-empty-ipattern)
+ (setq ipatterns (cdr ipatterns)))
+ (t
+ ;; Stop here rather than continuing
+ ;; looking for not-allowed patterns.
+ ;; We do a complete scan elsewhere.
+ (setq ret nil)))))
+ ret))
+ rng-empty-ipattern))
+
+(defun rng-normalize-group-list (ipatterns)
+ "Normalize a list containing members of a group.
+Expands nested groups, removes empty members, handles notAllowed.
+Returns a pair whose car says whether the list is nullable and whose
+cdr is the normalized list."
+ (let ((nullable t)
+ (result nil)
+ member)
+ (while ipatterns
+ (setq member (car ipatterns))
+ (setq ipatterns (cdr ipatterns))
+ (when nullable
+ (setq nullable (rng-ipattern-get-nullable member)))
+ (cond ((eq (rng-ipattern-get-type member) 'group)
+ (setq result
+ (nconc (reverse (rng-ipattern-get-child member))
+ result)))
+ ((eq member rng-not-allowed-ipattern)
+ (setq result (list rng-not-allowed-ipattern))
+ (setq ipatterns nil))
+ ((not (eq member rng-empty-ipattern))
+ (setq result (cons member result)))))
+ (cons nullable (nreverse result))))
+
+(defun rng-intern-interleave (ipatterns)
+ (or (rng-intern-group-shortcut ipatterns)
+ (let* ((tem (rng-normalize-interleave-list ipatterns))
+ (normalized (cdr tem)))
+ (or (rng-intern-group-shortcut normalized)
+ (let ((key (cons 'interleave
+ (mapcar 'rng-ipattern-get-index normalized))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'interleave
+ nil
+ normalized
+ (car tem))))))))
+
+(defun rng-normalize-interleave-list (ipatterns)
+ "Normalize a list containing members of an interleave.
+Expands nested groups, removes empty members, handles notAllowed.
+Returns a pair whose car says whether the list is nullable and whose
+cdr is the normalized list."
+ (let ((nullable t)
+ (result nil)
+ member)
+ (while ipatterns
+ (setq member (car ipatterns))
+ (setq ipatterns (cdr ipatterns))
+ (when nullable
+ (setq nullable (rng-ipattern-get-nullable member)))
+ (cond ((eq (rng-ipattern-get-type member) 'interleave)
+ (setq result
+ (append (rng-ipattern-get-child member)
+ result)))
+ ((eq member rng-not-allowed-ipattern)
+ (setq result (list rng-not-allowed-ipattern))
+ (setq ipatterns nil))
+ ((not (eq member rng-empty-ipattern))
+ (setq result (cons member result)))))
+ (cons nullable (sort result 'rng-compare-ipattern))))
+
+;; Would be cleaner if this didn't modify IPATTERNS.
+
+(defun rng-intern-choice (ipatterns)
+ "Return a choice ipattern for the list of choices in IPATTERNS.
+May alter IPATTERNS."
+ (or (rng-intern-choice-shortcut ipatterns)
+ (let* ((tem (rng-normalize-choice-list ipatterns))
+ (normalized (cdr tem)))
+ (or (rng-intern-choice-shortcut normalized)
+ (rng-intern-choice1 normalized (car tem))))))
+
+(defun rng-intern-optional (ipattern)
+ (cond ((rng-ipattern-get-nullable ipattern) ipattern)
+ ((eq ipattern rng-not-allowed-ipattern) rng-empty-ipattern)
+ (t (rng-intern-choice1
+ ;; This is sorted since the empty pattern
+ ;; is before everything except not allowed.
+ ;; It cannot have a duplicate empty pattern,
+ ;; since it is not nullable.
+ (cons rng-empty-ipattern
+ (if (eq (rng-ipattern-get-type ipattern) 'choice)
+ (rng-ipattern-get-child ipattern)
+ (list ipattern)))
+ t))))
+
+
+(defun rng-intern-choice1 (normalized nullable)
+ (let ((key (cons 'choice
+ (mapcar 'rng-ipattern-get-index normalized))))
+ (or (rng-get-ipattern key)
+ (rng-put-ipattern key
+ 'choice
+ nil
+ normalized
+ nullable))))
+
+(defun rng-intern-choice-shortcut (ipatterns)
+ "Try to shortcut interning a choice list. If successful, return the
+interned pattern. Otherwise return nil."
+ (while (and ipatterns
+ (eq (car ipatterns)
+ rng-not-allowed-ipattern))
+ (setq ipatterns (cdr ipatterns)))
+ (if ipatterns
+ (let ((ret (car ipatterns)))
+ (setq ipatterns (cdr ipatterns))
+ (while (and ipatterns ret)
+ (or (eq (car ipatterns) rng-not-allowed-ipattern)
+ (eq (car ipatterns) ret)
+ (setq ret nil))
+ (setq ipatterns (cdr ipatterns)))
+ ret)
+ rng-not-allowed-ipattern))
+
+(defun rng-normalize-choice-list (ipatterns)
+ "Normalize a list of choices, expanding nested choices, removing
+not-allowed members, sorting by index and removing duplicates. Return
+a pair whose car says whether the list is nullable and whose cdr is
+the normalized list."
+ (let ((sorted t)
+ (nullable nil)
+ (head (cons nil ipatterns)))
+ (let ((tail head)
+ (final-tail nil)
+ (prev-index -100)
+ (cur ipatterns)
+ member)
+ ;; the cdr of tail is always cur
+ (while cur
+ (setq member (car cur))
+ (or nullable
+ (setq nullable (rng-ipattern-get-nullable member)))
+ (cond ((eq (rng-ipattern-get-type member) 'choice)
+ (setq final-tail
+ (append (rng-ipattern-get-child member)
+ final-tail))
+ (setq cur (cdr cur))
+ (setq sorted nil)
+ (setcdr tail cur))
+ ((eq member rng-not-allowed-ipattern)
+ (setq cur (cdr cur))
+ (setcdr tail cur))
+ (t
+ (if (and sorted
+ (let ((cur-index (rng-ipattern-get-index member)))
+ (if (>= prev-index cur-index)
+ (or (= prev-index cur-index) ; will remove it
+ (setq sorted nil)) ; won't remove it
+ (setq prev-index cur-index)
+ ;; won't remove it
+ nil)))
+ (progn
+ ;; remove it
+ (setq cur (cdr cur))
+ (setcdr tail cur))
+ ;; don't remove it
+ (setq tail cur)
+ (setq cur (cdr cur))))))
+ (setcdr tail final-tail))
+ (setq head (cdr head))
+ (cons nullable
+ (if sorted
+ head
+ (rng-uniquify-eq (sort head 'rng-compare-ipattern))))))
+
+(defun rng-compare-ipattern (p1 p2)
+ (< (rng-ipattern-get-index p1)
+ (rng-ipattern-get-index p2)))
+
+;;; Name classes
+
+(defsubst rng-name-class-contains (nc nm)
+ (if (consp nc)
+ (equal nm nc)
+ (rng-name-class-contains1 nc nm)))
+
+(defun rng-name-class-contains1 (nc nm)
+ (let ((type (aref nc 0)))
+ (cond ((eq type 'any-name) t)
+ ((eq type 'any-name-except)
+ (not (rng-name-class-contains (aref nc 1) nm)))
+ ((eq type 'ns-name)
+ (eq (car nm) (aref nc 1)))
+ ((eq type 'ns-name-except)
+ (and (eq (car nm) (aref nc 1))
+ (not (rng-name-class-contains (aref nc 2) nm))))
+ ((eq type 'choice)
+ (let ((choices (aref nc 1))
+ (ret nil))
+ (while choices
+ (if (rng-name-class-contains (car choices) nm)
+ (progn
+ (setq choices nil)
+ (setq ret t))
+ (setq choices (cdr choices))))
+ ret)))))
+
+(defun rng-name-class-possible-names (nc accum)
+ "Return a list of possible names that nameclass NC can match.
+
+Each possible name should be returned as a (NAMESPACE . LOCAL-NAME)
+pair, where NAMESPACE is a symbol or nil and LOCAL-NAME is a string.
+nil for NAMESPACE matches the absent namespace. ACCUM is a list of
+names which should be appended to the returned list. The returned list
+may contain duplicates."
+ (if (consp nc)
+ (cons nc accum)
+ (when (eq (aref nc 0) 'choice)
+ (let ((members (aref nc 1)) member)
+ (while members
+ (setq member (car members))
+ (setq accum
+ (if (consp member)
+ (cons member accum)
+ (rng-name-class-possible-names member
+ accum)))
+ (setq members (cdr members)))))
+ accum))
+
+;;; Debugging utilities
+
+(defun rng-ipattern-to-string (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (concat (rng-ipattern-to-string
+ (rng-ipattern-get-child ipattern))
+ " </> "
+ (rng-ipattern-to-string
+ (rng-ipattern-get-after ipattern))))
+ ((eq type 'element)
+ (concat "element "
+ (rng-name-class-to-string
+ (rng-ipattern-get-name-class ipattern))
+ ;; we can get cycles with elements so don't print it out
+ " {...}"))
+ ((eq type 'attribute)
+ (concat "attribute "
+ (rng-name-class-to-string
+ (rng-ipattern-get-name-class ipattern))
+ " { "
+ (rng-ipattern-to-string
+ (rng-ipattern-get-child ipattern))
+ " } "))
+ ((eq type 'empty) "empty")
+ ((eq type 'text) "text")
+ ((eq type 'not-allowed) "notAllowed")
+ ((eq type 'one-or-more)
+ (concat (rng-ipattern-to-string
+ (rng-ipattern-get-child ipattern))
+ "+"))
+ ((eq type 'choice)
+ (concat "("
+ (mapconcat 'rng-ipattern-to-string
+ (rng-ipattern-get-child ipattern)
+ " | ")
+ ")"))
+ ((eq type 'group)
+ (concat "("
+ (mapconcat 'rng-ipattern-to-string
+ (rng-ipattern-get-child ipattern)
+ ", ")
+ ")"))
+ ((eq type 'interleave)
+ (concat "("
+ (mapconcat 'rng-ipattern-to-string
+ (rng-ipattern-get-child ipattern)
+ " & ")
+ ")"))
+ (t (symbol-name type)))))
+
+(defun rng-name-class-to-string (nc)
+ (if (consp nc)
+ (cdr nc)
+ (let ((type (aref nc 0)))
+ (cond ((eq type 'choice)
+ (mapconcat 'rng-name-class-to-string
+ (aref nc 1)
+ "|"))
+ (t (concat (symbol-name type) "*"))))))
+
+
+;;; Compiling
+
+(defun rng-compile-maybe-init ()
+ (unless rng-compile-table
+ (setq rng-compile-table (make-hash-table :test 'eq))))
+
+(defun rng-compile-clear ()
+ (when rng-compile-table
+ (clrhash rng-compile-table)))
+
+(defun rng-compile (pattern)
+ (or (gethash pattern rng-compile-table)
+ (let ((ipattern (apply (get (car pattern) 'rng-compile)
+ (cdr pattern))))
+ (puthash pattern ipattern rng-compile-table)
+ ipattern)))
+
+(put 'empty 'rng-compile 'rng-compile-empty)
+(put 'text 'rng-compile 'rng-compile-text)
+(put 'not-allowed 'rng-compile 'rng-compile-not-allowed)
+(put 'element 'rng-compile 'rng-compile-element)
+(put 'attribute 'rng-compile 'rng-compile-attribute)
+(put 'choice 'rng-compile 'rng-compile-choice)
+(put 'optional 'rng-compile 'rng-compile-optional)
+(put 'group 'rng-compile 'rng-compile-group)
+(put 'interleave 'rng-compile 'rng-compile-interleave)
+(put 'ref 'rng-compile 'rng-compile-ref)
+(put 'one-or-more 'rng-compile 'rng-compile-one-or-more)
+(put 'zero-or-more 'rng-compile 'rng-compile-zero-or-more)
+(put 'mixed 'rng-compile 'rng-compile-mixed)
+(put 'data 'rng-compile 'rng-compile-data)
+(put 'data-except 'rng-compile 'rng-compile-data-except)
+(put 'value 'rng-compile 'rng-compile-value)
+(put 'list 'rng-compile 'rng-compile-list)
+
+(defun rng-compile-not-allowed () rng-not-allowed-ipattern)
+(defun rng-compile-empty () rng-empty-ipattern)
+(defun rng-compile-text () rng-text-ipattern)
+
+(defun rng-compile-element (name-class pattern)
+ ;; don't intern
+ (rng-make-ipattern 'element
+ (rng-gen-ipattern-index)
+ (rng-compile-name-class name-class)
+ pattern ; compile lazily
+ nil))
+
+(defun rng-element-get-child (element)
+ (let ((tem (rng-ipattern-get-child element)))
+ (if (vectorp tem)
+ tem
+ (rng-ipattern-set-child element (rng-compile tem)))))
+
+(defun rng-compile-attribute (name-class pattern)
+ (rng-intern-attribute (rng-compile-name-class name-class)
+ (rng-compile pattern)))
+
+(defun rng-compile-ref (pattern name)
+ (and (memq pattern rng-being-compiled)
+ (rng-compile-error "Reference loop on symbol %s" name))
+ (setq rng-being-compiled
+ (cons pattern rng-being-compiled))
+ (unwind-protect
+ (rng-compile pattern)
+ (setq rng-being-compiled
+ (cdr rng-being-compiled))))
+
+(defun rng-compile-one-or-more (pattern)
+ (rng-intern-one-or-more (rng-compile pattern)))
+
+(defun rng-compile-zero-or-more (pattern)
+ (rng-intern-optional
+ (rng-intern-one-or-more (rng-compile pattern))))
+
+(defun rng-compile-optional (pattern)
+ (rng-intern-optional (rng-compile pattern)))
+
+(defun rng-compile-mixed (pattern)
+ (rng-intern-interleave (cons rng-text-ipattern
+ (list (rng-compile pattern)))))
+
+(defun rng-compile-list (pattern)
+ (rng-intern-list (rng-compile pattern)))
+
+(defun rng-compile-choice (&rest patterns)
+ (rng-intern-choice (mapcar 'rng-compile patterns)))
+
+(defun rng-compile-group (&rest patterns)
+ (rng-intern-group (mapcar 'rng-compile patterns)))
+
+(defun rng-compile-interleave (&rest patterns)
+ (rng-intern-interleave (mapcar 'rng-compile patterns)))
+
+(defun rng-compile-dt (name params)
+ (let ((rng-dt-error-reporter 'rng-compile-error))
+ (funcall (let ((uri (car name)))
+ (or (get uri 'rng-dt-compile)
+ (rng-compile-error "Unknown datatype library %s" uri)))
+ (cdr name)
+ params)))
+
+(defun rng-compile-data (name params)
+ (let ((dt (rng-compile-dt name params)))
+ (rng-intern-data (cdr dt) (car dt))))
+
+(defun rng-compile-data-except (name params pattern)
+ (rng-intern-data-except (cdr (rng-compile-dt name params))
+ (rng-compile pattern)))
+
+(defun rng-compile-value (name str context)
+ (let* ((dt (cdr (rng-compile-dt name '())))
+ (rng-dt-namespace-context-getter (list 'identity context))
+ (obj (rng-dt-make-value dt str)))
+ (if obj
+ (rng-intern-value dt obj)
+ (rng-compile-error "Value %s is not a valid instance of the datatype %s"
+ str
+ name))))
+
+(defun rng-compile-name-class (nc)
+ (let ((type (car nc)))
+ (cond ((eq type 'name) (nth 1 nc))
+ ((eq type 'any-name) [any-name])
+ ((eq type 'any-name-except)
+ (vector 'any-name-except
+ (rng-compile-name-class (nth 1 nc))))
+ ((eq type 'ns-name)
+ (vector 'ns-name (nth 1 nc)))
+ ((eq type 'ns-name-except)
+ (vector 'ns-name-except
+ (nth 1 nc)
+ (rng-compile-name-class (nth 2 nc))))
+ ((eq type 'choice)
+ (vector 'choice
+ (mapcar 'rng-compile-name-class (cdr nc))))
+ (t (error "Bad name-class type %s" type)))))
+
+;;; Searching patterns
+
+;; We write this non-recursively to avoid hitting max-lisp-eval-depth
+;; on large schemas.
+
+(defun rng-map-element-attribute (function pattern accum &rest args)
+ (let ((searched (make-hash-table :test 'eq))
+ type todo patterns)
+ (while (progn
+ (setq type (car pattern))
+ (cond ((memq type '(element attribute))
+ (setq accum
+ (apply function
+ (cons pattern
+ (cons accum args))))
+ (setq pattern (nth 2 pattern)))
+ ((eq type 'ref)
+ (setq pattern (nth 1 pattern))
+ (if (gethash pattern searched)
+ (setq pattern nil)
+ (puthash pattern t searched)))
+ ((memq type '(choice group interleave))
+ (setq todo (cons (cdr pattern) todo))
+ (setq pattern nil))
+ ((memq type '(one-or-more
+ zero-or-more
+ optional
+ mixed))
+ (setq pattern (nth 1 pattern)))
+ (t (setq pattern nil)))
+ (cond (pattern)
+ (patterns
+ (setq pattern (car patterns))
+ (setq patterns (cdr patterns))
+ t)
+ (todo
+ (setq patterns (car todo))
+ (setq todo (cdr todo))
+ (setq pattern (car patterns))
+ (setq patterns (cdr patterns))
+ t))))
+ accum))
+
+(defun rng-find-element-content-pattern (pattern accum name)
+ (if (and (eq (car pattern) 'element)
+ (rng-search-name name (nth 1 pattern)))
+ (cons (rng-compile (nth 2 pattern)) accum)
+ accum))
+
+(defun rng-search-name (name nc)
+ (let ((type (car nc)))
+ (cond ((eq type 'name)
+ (equal (cadr nc) name))
+ ((eq type 'choice)
+ (let ((choices (cdr nc))
+ (found nil))
+ (while (and choices (not found))
+ (if (rng-search-name name (car choices))
+ (setq found t)
+ (setq choices (cdr choices))))
+ found))
+ (t nil))))
+
+(defun rng-find-name-class-uris (nc accum)
+ (let ((type (car nc)))
+ (cond ((eq type 'name)
+ (rng-accum-namespace-uri (car (nth 1 nc)) accum))
+ ((memq type '(ns-name ns-name-except))
+ (rng-accum-namespace-uri (nth 1 nc) accum))
+ ((eq type 'choice)
+ (let ((choices (cdr nc)))
+ (while choices
+ (setq accum
+ (rng-find-name-class-uris (car choices) accum))
+ (setq choices (cdr choices))))
+ accum)
+ (t accum))))
+
+(defun rng-accum-namespace-uri (ns accum)
+ (if (and ns (not (memq ns accum)))
+ (cons ns accum)
+ accum))
+
+;;; Derivatives
+
+(defun rng-ipattern-text-typed-p (ipattern)
+ (let ((memo (rng-ipattern-get-memo-text-typed ipattern)))
+ (if (eq memo 'unknown)
+ (rng-ipattern-set-memo-text-typed
+ ipattern
+ (rng-ipattern-compute-text-typed-p ipattern))
+ memo)))
+
+(defun rng-ipattern-compute-text-typed-p (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'choice)
+ (let ((cur (rng-ipattern-get-child ipattern))
+ (ret nil))
+ (while (and cur (not ret))
+ (if (rng-ipattern-text-typed-p (car cur))
+ (setq ret t)
+ (setq cur (cdr cur))))
+ ret))
+ ((eq type 'group)
+ (let ((cur (rng-ipattern-get-child ipattern))
+ (ret nil)
+ member)
+ (while (and cur (not ret))
+ (setq member (car cur))
+ (if (rng-ipattern-text-typed-p member)
+ (setq ret t))
+ (setq cur
+ (and (rng-ipattern-get-nullable member)
+ (cdr cur))))
+ ret))
+ ((eq type 'after)
+ (rng-ipattern-text-typed-p (rng-ipattern-get-child ipattern)))
+ (t (and (memq type '(value list data data-except)) t)))))
+
+(defun rng-start-tag-open-deriv (ipattern nm)
+ (or (rng-memo-map-get
+ nm
+ (rng-ipattern-get-memo-map-start-tag-open-deriv ipattern))
+ (rng-ipattern-memo-start-tag-open-deriv
+ ipattern
+ nm
+ (rng-compute-start-tag-open-deriv ipattern nm))))
+
+(defun rng-ipattern-memo-start-tag-open-deriv (ipattern nm deriv)
+ (or (memq ipattern rng-const-ipatterns)
+ (rng-ipattern-set-memo-map-start-tag-open-deriv
+ ipattern
+ (rng-memo-map-add nm
+ deriv
+ (rng-ipattern-get-memo-map-start-tag-open-deriv
+ ipattern))))
+ deriv)
+
+(defun rng-compute-start-tag-open-deriv (ipattern nm)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'choice)
+ (rng-transform-choice `(lambda (p)
+ (rng-start-tag-open-deriv p ',nm))
+ ipattern))
+ ((eq type 'element)
+ (if (rng-name-class-contains
+ (rng-ipattern-get-name-class ipattern)
+ nm)
+ (rng-intern-after (rng-element-get-child ipattern)
+ rng-empty-ipattern)
+ rng-not-allowed-ipattern))
+ ((eq type 'group)
+ (rng-transform-group-nullable
+ `(lambda (p) (rng-start-tag-open-deriv p ',nm))
+ 'rng-cons-group-after
+ ipattern))
+ ((eq type 'interleave)
+ (rng-transform-interleave-single
+ `(lambda (p) (rng-start-tag-open-deriv p ',nm))
+ 'rng-subst-interleave-after
+ ipattern))
+ ((eq type 'one-or-more)
+ (rng-apply-after
+ `(lambda (p)
+ (rng-intern-group (list p ,(rng-intern-optional ipattern))))
+ (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern)
+ nm)))
+ ((eq type 'after)
+ (rng-apply-after
+ `(lambda (p)
+ (rng-intern-after p
+ ,(rng-ipattern-get-after ipattern)))
+ (rng-start-tag-open-deriv (rng-ipattern-get-child ipattern)
+ nm)))
+ (t rng-not-allowed-ipattern))))
+
+(defun rng-start-attribute-deriv (ipattern nm)
+ (or (rng-memo-map-get
+ nm
+ (rng-ipattern-get-memo-map-start-attribute-deriv ipattern))
+ (rng-ipattern-memo-start-attribute-deriv
+ ipattern
+ nm
+ (rng-compute-start-attribute-deriv ipattern nm))))
+
+(defun rng-ipattern-memo-start-attribute-deriv (ipattern nm deriv)
+ (or (memq ipattern rng-const-ipatterns)
+ (rng-ipattern-set-memo-map-start-attribute-deriv
+ ipattern
+ (rng-memo-map-add
+ nm
+ deriv
+ (rng-ipattern-get-memo-map-start-attribute-deriv ipattern))))
+ deriv)
+
+(defun rng-compute-start-attribute-deriv (ipattern nm)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'choice)
+ (rng-transform-choice `(lambda (p)
+ (rng-start-attribute-deriv p ',nm))
+ ipattern))
+ ((eq type 'attribute)
+ (if (rng-name-class-contains
+ (rng-ipattern-get-name-class ipattern)
+ nm)
+ (rng-intern-after (rng-ipattern-get-child ipattern)
+ rng-empty-ipattern)
+ rng-not-allowed-ipattern))
+ ((eq type 'group)
+ (rng-transform-interleave-single
+ `(lambda (p) (rng-start-attribute-deriv p ',nm))
+ 'rng-subst-group-after
+ ipattern))
+ ((eq type 'interleave)
+ (rng-transform-interleave-single
+ `(lambda (p) (rng-start-attribute-deriv p ',nm))
+ 'rng-subst-interleave-after
+ ipattern))
+ ((eq type 'one-or-more)
+ (rng-apply-after
+ `(lambda (p)
+ (rng-intern-group (list p ,(rng-intern-optional ipattern))))
+ (rng-start-attribute-deriv (rng-ipattern-get-child ipattern)
+ nm)))
+ ((eq type 'after)
+ (rng-apply-after
+ `(lambda (p)
+ (rng-intern-after p ,(rng-ipattern-get-after ipattern)))
+ (rng-start-attribute-deriv (rng-ipattern-get-child ipattern)
+ nm)))
+ (t rng-not-allowed-ipattern))))
+
+(defun rng-cons-group-after (x y)
+ (rng-apply-after `(lambda (p) (rng-intern-group (cons p ',y)))
+ x))
+
+(defun rng-subst-group-after (new old list)
+ (rng-apply-after `(lambda (p)
+ (rng-intern-group (rng-substq p ,old ',list)))
+ new))
+
+(defun rng-subst-interleave-after (new old list)
+ (rng-apply-after `(lambda (p)
+ (rng-intern-interleave (rng-substq p ,old ',list)))
+ new))
+
+(defun rng-apply-after (f ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (rng-intern-after
+ (rng-ipattern-get-child ipattern)
+ (funcall f
+ (rng-ipattern-get-after ipattern))))
+ ((eq type 'choice)
+ (rng-transform-choice `(lambda (x) (rng-apply-after ,f x))
+ ipattern))
+ (t rng-not-allowed-ipattern))))
+
+(defun rng-start-tag-close-deriv (ipattern)
+ (or (rng-ipattern-get-memo-start-tag-close-deriv ipattern)
+ (rng-ipattern-set-memo-start-tag-close-deriv
+ ipattern
+ (rng-compute-start-tag-close-deriv ipattern))))
+
+(defconst rng-transform-map
+ '((choice . rng-transform-choice)
+ (group . rng-transform-group)
+ (interleave . rng-transform-interleave)
+ (one-or-more . rng-transform-one-or-more)
+ (after . rng-transform-after-child)))
+
+(defun rng-compute-start-tag-close-deriv (ipattern)
+ (let* ((type (rng-ipattern-get-type ipattern)))
+ (if (eq type 'attribute)
+ rng-not-allowed-ipattern
+ (let ((transform (assq type rng-transform-map)))
+ (if transform
+ (funcall (cdr transform)
+ 'rng-start-tag-close-deriv
+ ipattern)
+ ipattern)))))
+
+(defun rng-ignore-attributes-deriv (ipattern)
+ (let* ((type (rng-ipattern-get-type ipattern)))
+ (if (eq type 'attribute)
+ rng-empty-ipattern
+ (let ((transform (assq type rng-transform-map)))
+ (if transform
+ (funcall (cdr transform)
+ 'rng-ignore-attributes-deriv
+ ipattern)
+ ipattern)))))
+
+(defun rng-text-only-deriv (ipattern)
+ (or (rng-ipattern-get-memo-text-only-deriv ipattern)
+ (rng-ipattern-set-memo-text-only-deriv
+ ipattern
+ (rng-compute-text-only-deriv ipattern))))
+
+(defun rng-compute-text-only-deriv (ipattern)
+ (let* ((type (rng-ipattern-get-type ipattern)))
+ (if (eq type 'element)
+ rng-not-allowed-ipattern
+ (let ((transform (assq type
+ '((choice . rng-transform-choice)
+ (group . rng-transform-group)
+ (interleave . rng-transform-interleave)
+ (one-or-more . rng-transform-one-or-more)
+ (after . rng-transform-after-child)))))
+ (if transform
+ (funcall (cdr transform)
+ 'rng-text-only-deriv
+ ipattern)
+ ipattern)))))
+
+(defun rng-mixed-text-deriv (ipattern)
+ (or (rng-ipattern-get-memo-mixed-text-deriv ipattern)
+ (rng-ipattern-set-memo-mixed-text-deriv
+ ipattern
+ (rng-compute-mixed-text-deriv ipattern))))
+
+(defun rng-compute-mixed-text-deriv (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'text) ipattern)
+ ((eq type 'after)
+ (rng-transform-after-child 'rng-mixed-text-deriv
+ ipattern))
+ ((eq type 'choice)
+ (rng-transform-choice 'rng-mixed-text-deriv
+ ipattern))
+ ((eq type 'one-or-more)
+ (rng-intern-group
+ (list (rng-mixed-text-deriv
+ (rng-ipattern-get-child ipattern))
+ (rng-intern-optional ipattern))))
+ ((eq type 'group)
+ (rng-transform-group-nullable
+ 'rng-mixed-text-deriv
+ (lambda (x y) (rng-intern-group (cons x y)))
+ ipattern))
+ ((eq type 'interleave)
+ (rng-transform-interleave-single
+ 'rng-mixed-text-deriv
+ (lambda (new old list) (rng-intern-interleave
+ (rng-substq new old list)))
+ ipattern))
+ ((and (eq type 'data)
+ (not (rng-ipattern-get-memo-text-typed ipattern)))
+ ipattern)
+ (t rng-not-allowed-ipattern))))
+
+(defun rng-end-tag-deriv (ipattern)
+ (or (rng-ipattern-get-memo-end-tag-deriv ipattern)
+ (rng-ipattern-set-memo-end-tag-deriv
+ ipattern
+ (rng-compute-end-tag-deriv ipattern))))
+
+(defun rng-compute-end-tag-deriv (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'choice)
+ (rng-intern-choice
+ (mapcar 'rng-end-tag-deriv
+ (rng-ipattern-get-child ipattern))))
+ ((eq type 'after)
+ (if (rng-ipattern-get-nullable
+ (rng-ipattern-get-child ipattern))
+ (rng-ipattern-get-after ipattern)
+ rng-not-allowed-ipattern))
+ (t rng-not-allowed-ipattern))))
+
+(defun rng-data-deriv (ipattern value)
+ (or (rng-memo-map-get value
+ (rng-ipattern-get-memo-map-data-deriv ipattern))
+ (and (rng-memo-map-get
+ (cons value (rng-namespace-context-get-no-trace))
+ (rng-ipattern-get-memo-map-data-deriv ipattern))
+ (rng-memo-map-get
+ (cons value (apply (car rng-dt-namespace-context-getter)
+ (cdr rng-dt-namespace-context-getter)))
+ (rng-ipattern-get-memo-map-data-deriv ipattern)))
+ (let* ((used-context (vector nil))
+ (rng-dt-namespace-context-getter
+ (cons 'rng-namespace-context-tracer
+ (cons used-context
+ rng-dt-namespace-context-getter)))
+ (deriv (rng-compute-data-deriv ipattern value)))
+ (rng-ipattern-memo-data-deriv ipattern
+ value
+ (aref used-context 0)
+ deriv))))
+
+(defun rng-namespace-context-tracer (used getter &rest args)
+ (let ((context (apply getter args)))
+ (aset used 0 context)
+ context))
+
+(defun rng-namespace-context-get-no-trace ()
+ (let ((tem rng-dt-namespace-context-getter))
+ (while (and tem (eq (car tem) 'rng-namespace-context-tracer))
+ (setq tem (cddr tem)))
+ (apply (car tem) (cdr tem))))
+
+(defconst rng-memo-data-deriv-max-length 80
+ "Don't memoize data-derivs for values longer than this.")
+
+(defun rng-ipattern-memo-data-deriv (ipattern value context deriv)
+ (or (memq ipattern rng-const-ipatterns)
+ (> (length value) rng-memo-data-deriv-max-length)
+ (rng-ipattern-set-memo-map-data-deriv
+ ipattern
+ (rng-memo-map-add (if context (cons value context) value)
+ deriv
+ (rng-ipattern-get-memo-map-data-deriv ipattern)
+ t)))
+ deriv)
+
+(defun rng-compute-data-deriv (ipattern value)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'text) ipattern)
+ ((eq type 'choice)
+ (rng-transform-choice `(lambda (p) (rng-data-deriv p ,value))
+ ipattern))
+ ((eq type 'group)
+ (rng-transform-group-nullable
+ `(lambda (p) (rng-data-deriv p ,value))
+ (lambda (x y) (rng-intern-group (cons x y)))
+ ipattern))
+ ((eq type 'one-or-more)
+ (rng-intern-group (list (rng-data-deriv
+ (rng-ipattern-get-child ipattern)
+ value)
+ (rng-intern-optional ipattern))))
+ ((eq type 'after)
+ (let ((child (rng-ipattern-get-child ipattern)))
+ (if (or (rng-ipattern-get-nullable
+ (rng-data-deriv child value))
+ (and (rng-ipattern-get-nullable child)
+ (rng-blank-p value)))
+ (rng-ipattern-get-after ipattern)
+ rng-not-allowed-ipattern)))
+ ((eq type 'data)
+ (if (rng-dt-make-value (rng-ipattern-get-datatype ipattern)
+ value)
+ rng-empty-ipattern
+ rng-not-allowed-ipattern))
+ ((eq type 'data-except)
+ (if (and (rng-dt-make-value (rng-ipattern-get-datatype ipattern)
+ value)
+ (not (rng-ipattern-get-nullable
+ (rng-data-deriv
+ (rng-ipattern-get-child ipattern)
+ value))))
+ rng-empty-ipattern
+ rng-not-allowed-ipattern))
+ ((eq type 'value)
+ (if (equal (rng-dt-make-value (rng-ipattern-get-datatype ipattern)
+ value)
+ (rng-ipattern-get-value-object ipattern))
+ rng-empty-ipattern
+ rng-not-allowed-ipattern))
+ ((eq type 'list)
+ (let ((tokens (split-string value))
+ (state (rng-ipattern-get-child ipattern)))
+ (while (and tokens
+ (not (eq state rng-not-allowed-ipattern)))
+ (setq state (rng-data-deriv state (car tokens)))
+ (setq tokens (cdr tokens)))
+ (if (rng-ipattern-get-nullable state)
+ rng-empty-ipattern
+ rng-not-allowed-ipattern)))
+ ;; don't think interleave can occur
+ ;; since we do text-only-deriv first
+ (t rng-not-allowed-ipattern))))
+
+(defun rng-transform-multi (f ipattern interner)
+ (let* ((members (rng-ipattern-get-child ipattern))
+ (transformed (mapcar f members)))
+ (if (rng-members-eq members transformed)
+ ipattern
+ (funcall interner transformed))))
+
+(defun rng-transform-choice (f ipattern)
+ (rng-transform-multi f ipattern 'rng-intern-choice))
+
+(defun rng-transform-group (f ipattern)
+ (rng-transform-multi f ipattern 'rng-intern-group))
+
+(defun rng-transform-interleave (f ipattern)
+ (rng-transform-multi f ipattern 'rng-intern-interleave))
+
+(defun rng-transform-one-or-more (f ipattern)
+ (let* ((child (rng-ipattern-get-child ipattern))
+ (transformed (funcall f child)))
+ (if (eq child transformed)
+ ipattern
+ (rng-intern-one-or-more transformed))))
+
+(defun rng-transform-after-child (f ipattern)
+ (let* ((child (rng-ipattern-get-child ipattern))
+ (transformed (funcall f child)))
+ (if (eq child transformed)
+ ipattern
+ (rng-intern-after transformed
+ (rng-ipattern-get-after ipattern)))))
+
+(defun rng-transform-interleave-single (f subster ipattern)
+ (let ((children (rng-ipattern-get-child ipattern))
+ found)
+ (while (and children (not found))
+ (let* ((child (car children))
+ (transformed (funcall f child)))
+ (if (eq transformed rng-not-allowed-ipattern)
+ (setq children (cdr children))
+ (setq found
+ (funcall subster
+ transformed
+ child
+ (rng-ipattern-get-child ipattern))))))
+ (or found
+ rng-not-allowed-ipattern)))
+
+(defun rng-transform-group-nullable (f conser ipattern)
+ "Given a group x1,...,xn,y1,...,yn where the xs are all
+nullable and y1 isn't, return a choice
+ (conser f(x1) x2,...,xm,y1,...,yn)
+ |(conser f(x2) x3,...,xm,y1,...,yn)
+ |...
+ |(conser f(xm) y1,...,yn)
+ |(conser f(y1) y2,...,yn)"
+ (rng-intern-choice
+ (rng-transform-group-nullable-gen-choices
+ f
+ conser
+ (rng-ipattern-get-child ipattern))))
+
+(defun rng-transform-group-nullable-gen-choices (f conser members)
+ (let ((head (car members))
+ (tail (cdr members)))
+ (if tail
+ (cons (funcall conser (funcall f head) tail)
+ (if (rng-ipattern-get-nullable head)
+ (rng-transform-group-nullable-gen-choices f conser tail)
+ nil))
+ (list (funcall f head)))))
+
+(defun rng-members-eq (list1 list2)
+ (while (and list1
+ list2
+ (eq (car list1) (car list2)))
+ (setq list1 (cdr list1))
+ (setq list2 (cdr list2)))
+ (and (null list1) (null list2)))
+
+
+(defun rng-ipattern-after (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'choice)
+ (rng-transform-choice 'rng-ipattern-after ipattern))
+ ((eq type 'after)
+ (rng-ipattern-get-after ipattern))
+ ((eq type 'not-allowed)
+ ipattern)
+ (t (error "Internal error in rng-ipattern-after: unexpected type %s"
type)))))
+
+(defun rng-unknown-start-tag-open-deriv (ipattern)
+ (rng-intern-after (rng-compile rng-any-content) ipattern))
+
+(defun rng-ipattern-optionalize-elements (ipattern)
+ (let* ((type (rng-ipattern-get-type ipattern))
+ (transform (assq type rng-transform-map)))
+ (cond (transform
+ (funcall (cdr transform)
+ 'rng-ipattern-optionalize-elements
+ ipattern))
+ ((eq type 'element)
+ (rng-intern-optional ipattern))
+ (t ipattern))))
+
+(defun rng-ipattern-empty-before-p (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (eq (rng-ipattern-get-child ipattern) rng-empty-ipattern))
+ ((eq type 'choice)
+ (let ((members (rng-ipattern-get-child ipattern))
+ (ret t))
+ (while (and members ret)
+ (or (rng-ipattern-empty-before-p (car members))
+ (setq ret nil))
+ (setq members (cdr members)))
+ ret))
+ (t nil))))
+
+(defun rng-ipattern-possible-start-tags (ipattern accum)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (rng-ipattern-possible-start-tags
+ (rng-ipattern-get-child ipattern)
+ accum))
+ ((memq type '(choice interleave))
+ (let ((members (rng-ipattern-get-child ipattern)))
+ (while members
+ (setq accum
+ (rng-ipattern-possible-start-tags (car members)
+ accum))
+ (setq members (cdr members))))
+ accum)
+ ((eq type 'group)
+ (let ((members (rng-ipattern-get-child ipattern)))
+ (while members
+ (setq accum
+ (rng-ipattern-possible-start-tags (car members)
+ accum))
+ (setq members
+ (and (rng-ipattern-get-nullable (car members))
+ (cdr members)))))
+ accum)
+ ((eq type 'element)
+ (if (eq (rng-element-get-child ipattern) rng-not-allowed-ipattern)
+ accum
+ (rng-name-class-possible-names
+ (rng-ipattern-get-name-class ipattern)
+ accum)))
+ ((eq type 'one-or-more)
+ (rng-ipattern-possible-start-tags
+ (rng-ipattern-get-child ipattern)
+ accum))
+ (t accum))))
+
+(defun rng-ipattern-start-tag-possible-p (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((memq type '(after one-or-more))
+ (rng-ipattern-start-tag-possible-p
+ (rng-ipattern-get-child ipattern)))
+ ((memq type '(choice interleave))
+ (let ((members (rng-ipattern-get-child ipattern))
+ (possible nil))
+ (while (and members (not possible))
+ (setq possible
+ (rng-ipattern-start-tag-possible-p (car members)))
+ (setq members (cdr members)))
+ possible))
+ ((eq type 'group)
+ (let ((members (rng-ipattern-get-child ipattern))
+ (possible nil))
+ (while (and members (not possible))
+ (setq possible
+ (rng-ipattern-start-tag-possible-p (car members)))
+ (setq members
+ (and (rng-ipattern-get-nullable (car members))
+ (cdr members))))
+ possible))
+ ((eq type 'element)
+ (not (eq (rng-element-get-child ipattern)
+ rng-not-allowed-ipattern)))
+ (t nil))))
+
+(defun rng-ipattern-possible-attributes (ipattern accum)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (rng-ipattern-possible-attributes (rng-ipattern-get-child ipattern)
+ accum))
+ ((memq type '(choice interleave group))
+ (let ((members (rng-ipattern-get-child ipattern)))
+ (while members
+ (setq accum
+ (rng-ipattern-possible-attributes (car members)
+ accum))
+ (setq members (cdr members))))
+ accum)
+ ((eq type 'attribute)
+ (rng-name-class-possible-names
+ (rng-ipattern-get-name-class ipattern)
+ accum))
+ ((eq type 'one-or-more)
+ (rng-ipattern-possible-attributes
+ (rng-ipattern-get-child ipattern)
+ accum))
+ (t accum))))
+
+(defun rng-ipattern-possible-values (ipattern accum)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (rng-ipattern-possible-values (rng-ipattern-get-child ipattern)
+ accum))
+ ((eq type 'choice)
+ (let ((members (rng-ipattern-get-child ipattern)))
+ (while members
+ (setq accum
+ (rng-ipattern-possible-values (car members)
+ accum))
+ (setq members (cdr members))))
+ accum)
+ ((eq type 'value)
+ (let ((value-object (rng-ipattern-get-value-object ipattern)))
+ (if (stringp value-object)
+ (cons value-object accum)
+ accum)))
+ (t accum))))
+
+(defun rng-ipattern-required-element (ipattern)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((memq type '(after one-or-more))
+ (rng-ipattern-required-element (rng-ipattern-get-child ipattern)))
+ ((eq type 'choice)
+ (let* ((members (rng-ipattern-get-child ipattern))
+ (required (rng-ipattern-required-element (car members))))
+ (while (and required
+ (setq members (cdr members)))
+ (unless (equal required
+ (rng-ipattern-required-element (car members)))
+ (setq required nil)))
+ required))
+ ((eq type 'group)
+ (let ((members (rng-ipattern-get-child ipattern))
+ required)
+ (while (and (not (setq required
+ (rng-ipattern-required-element
+ (car members))))
+ (rng-ipattern-get-nullable (car members))
+ (setq members (cdr members))))
+ required))
+ ((eq type 'interleave)
+ (let ((members (rng-ipattern-get-child ipattern))
+ required)
+ (while members
+ (let ((tem (rng-ipattern-required-element (car members))))
+ (cond ((not tem)
+ (setq members (cdr members)))
+ ((not required)
+ (setq required tem)
+ (setq members (cdr members)))
+ ((equal required tem)
+ (setq members (cdr members)))
+ (t
+ (setq required nil)
+ (setq members nil)))))
+ required))
+ ((eq type 'element)
+ (let ((nc (rng-ipattern-get-name-class ipattern)))
+ (and (consp nc)
+ (not (eq (rng-element-get-child ipattern)
+ rng-not-allowed-ipattern))
+ nc))))))
+
+(defun rng-ipattern-required-attributes (ipattern accum)
+ (let ((type (rng-ipattern-get-type ipattern)))
+ (cond ((eq type 'after)
+ (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern)
+ accum))
+ ((memq type '(interleave group))
+ (let ((members (rng-ipattern-get-child ipattern)))
+ (while members
+ (setq accum
+ (rng-ipattern-required-attributes (car members)
+ accum))
+ (setq members (cdr members))))
+ accum)
+ ((eq type 'choice)
+ (let ((members (rng-ipattern-get-child ipattern))
+ in-all in-this new-in-all)
+ (setq in-all
+ (rng-ipattern-required-attributes (car members)
+ nil))
+ (while (and in-all (setq members (cdr members)))
+ (setq in-this
+ (rng-ipattern-required-attributes (car members) nil))
+ (setq new-in-all nil)
+ (while in-this
+ (when (member (car in-this) in-all)
+ (setq new-in-all
+ (cons (car in-this) new-in-all)))
+ (setq in-this (cdr in-this)))
+ (setq in-all new-in-all))
+ (append in-all accum)))
+ ((eq type 'attribute)
+ (let ((nc (rng-ipattern-get-name-class ipattern)))
+ (if (consp nc)
+ (cons nc accum)
+ accum)))
+ ((eq type 'one-or-more)
+ (rng-ipattern-required-attributes (rng-ipattern-get-child ipattern)
+ accum))
+ (t accum))))
+
+(defun rng-compile-error (&rest args)
+ (signal 'rng-compile-error
+ (list (apply 'format args))))
+
+(put 'rng-compile-error
+ 'error-conditions
+ '(error rng-error rng-compile-error))
+
+(put 'rng-compile-error
+ 'error-message
+ "Incorrect schema")
+
+
+;;; External API
+
+(defsubst rng-match-state () rng-match-state)
+
+(defsubst rng-set-match-state (state)
+ (setq rng-match-state state))
+
+(defsubst rng-match-state-equal (state)
+ (eq state rng-match-state))
+
+(defun rng-schema-changed ()
+ (rng-ipattern-clear)
+ (rng-compile-clear))
+
+(defun rng-match-init-buffer ()
+ (make-local-variable 'rng-compile-table)
+ (make-local-variable 'rng-ipattern-table)
+ (make-local-variable 'rng-last-ipattern-index))
+
+(defun rng-match-start-document ()
+ (rng-ipattern-maybe-init)
+ (rng-compile-maybe-init)
+ (add-hook 'rng-schema-change-hook 'rng-schema-changed nil t)
+ (setq rng-match-state (rng-compile rng-current-schema)))
+
+(defun rng-match-start-tag-open (name)
+ (rng-update-match-state (rng-start-tag-open-deriv rng-match-state
+ name)))
+
+(defun rng-match-attribute-name (name)
+ (rng-update-match-state (rng-start-attribute-deriv rng-match-state
+ name)))
+
+(defun rng-match-attribute-value (value)
+ (rng-update-match-state (rng-data-deriv rng-match-state
+ value)))
+
+(defun rng-match-element-value (value)
+ (and (rng-update-match-state (rng-text-only-deriv rng-match-state))
+ (rng-update-match-state (rng-data-deriv rng-match-state
+ value))))
+
+(defun rng-match-start-tag-close ()
+ (rng-update-match-state (rng-start-tag-close-deriv rng-match-state)))
+
+(defun rng-match-mixed-text ()
+ (rng-update-match-state (rng-mixed-text-deriv rng-match-state)))
+
+(defun rng-match-end-tag ()
+ (rng-update-match-state (rng-end-tag-deriv rng-match-state)))
+
+(defun rng-match-after ()
+ (rng-update-match-state
+ (rng-ipattern-after rng-match-state)))
+
+(defun rng-match-out-of-context-start-tag-open (name)
+ (let* ((found (rng-map-element-attribute 'rng-find-element-content-pattern
+ rng-current-schema
+ nil
+ name))
+ (content-pattern (if found
+ (rng-intern-choice found)
+ rng-not-allowed-ipattern)))
+ (rng-update-match-state
+ (rng-intern-after content-pattern rng-match-state))))
+
+(defun rng-match-possible-namespace-uris ()
+ "Return a list of all the namespace URIs used in the current schema.
+The absent URI is not included, so the result is always list of symbols."
+ (rng-map-element-attribute (lambda (pattern accum)
+ (rng-find-name-class-uris (nth 1 pattern)
+ accum))
+ rng-current-schema
+ nil))
+
+(defun rng-match-unknown-start-tag-open ()
+ (rng-update-match-state
+ (rng-unknown-start-tag-open-deriv rng-match-state)))
+
+(defun rng-match-optionalize-elements ()
+ (rng-update-match-state
+ (rng-ipattern-optionalize-elements rng-match-state)))
+
+(defun rng-match-ignore-attributes ()
+ (rng-update-match-state
+ (rng-ignore-attributes-deriv rng-match-state)))
+
+(defun rng-match-text-typed-p ()
+ (rng-ipattern-text-typed-p rng-match-state))
+
+(defun rng-match-empty-content ()
+ (if (rng-match-text-typed-p)
+ (rng-match-element-value "")
+ (rng-match-end-tag)))
+
+(defun rng-match-empty-before-p ()
+ "Return non-nil if what can be matched before an end-tag is empty.
+In other words, return non-nil if the pattern for what can be matched
+for an end-tag is equivalent to empty."
+ (rng-ipattern-empty-before-p rng-match-state))
+
+(defun rng-match-infer-start-tag-namespace (local-name)
+ (let ((ncs (rng-ipattern-possible-start-tags rng-match-state nil))
+ (nc nil)
+ (ns nil))
+ (while ncs
+ (setq nc (car ncs))
+ (if (and (equal (cdr nc) local-name)
+ (symbolp (car nc)))
+ (cond ((not ns)
+ ;; first possible namespace
+ (setq ns (car nc))
+ (setq ncs (cdr ncs)))
+ ((equal ns (car nc))
+ ;; same as first namespace
+ (setq ncs (cdr ncs)))
+ (t
+ ;; more than one possible namespace
+ (setq ns nil)
+ (setq ncs nil)))
+ (setq ncs (cdr ncs))))
+ ns))
+
+(defun rng-match-nullable-p ()
+ (rng-ipattern-get-nullable rng-match-state))
+
+(defun rng-match-possible-start-tag-names ()
+ "Return a list of possible names that would be valid for start-tags.
+
+Each possible name is returned as a (NAMESPACE . LOCAL-NAME) pair,
+where NAMESPACE is a symbol or nil (meaning the absent namespace) and
+LOCAL-NAME is a string. The returned list may contain duplicates."
+ (rng-ipattern-possible-start-tags rng-match-state nil))
+
+;; This is no longer used. It might be useful so leave it in for now.
+(defun rng-match-start-tag-possible-p ()
+ "Return non-nil if a start-tag is possible."
+ (rng-ipattern-start-tag-possible-p rng-match-state))
+
+(defun rng-match-possible-attribute-names ()
+ "Return a list of possible names that would be valid for attributes.
+
+See the function `rng-match-possible-start-tag-names' for
+more information."
+ (rng-ipattern-possible-attributes rng-match-state nil))
+
+(defun rng-match-possible-value-strings ()
+ "Return a list of strings that would be valid as content.
+The list may contain duplicates. Typically, the list will not
+be exhaustive."
+ (rng-ipattern-possible-values rng-match-state nil))
+
+(defun rng-match-required-element-name ()
+ "Return the name of an element which must occur, or nil if none."
+ (rng-ipattern-required-element rng-match-state))
+
+(defun rng-match-required-attribute-names ()
+ "Return a list of names of attributes which must all occur."
+ (rng-ipattern-required-attributes rng-match-state nil))
+
+(defmacro rng-match-save (&rest body)
+ (let ((state (make-symbol "state")))
+ `(let ((,state rng-match-state))
+ (unwind-protect
+ (progn ,@body)
+ (setq rng-match-state ,state)))))
+
+(put 'rng-match-save 'lisp-indent-function 0)
+(def-edebug-spec rng-match-save t)
+
+(defmacro rng-match-with-schema (schema &rest body)
+ `(let ((rng-current-schema ,schema)
+ rng-match-state
+ rng-compile-table
+ rng-ipattern-table
+ rng-last-ipattern-index)
+ (rng-ipattern-maybe-init)
+ (rng-compile-maybe-init)
+ (setq rng-match-state (rng-compile rng-current-schema))
+ ,@body))
+
+(put 'rng-match-with-schema 'lisp-indent-function 1)
+(def-edebug-spec rng-match-with-schema t)
+
+(provide 'rng-match)
+
+;;; rng-match.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to lisp/nxml/rng-match.el,
Mark A. Hershberger <=