;;; TpoI.el --- RELAX NG validator.

;; Copyright (C) 2003 MIYASHITA Hisashi

;; Keywords: XML, schema, RELAX NG, validator

;; TpoI 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, or (at your option)
;; any later version.

;; TpoI 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;; Comment:
;;   TpoI is a RELAX NG validator.

;;; TODO
;; datatype library SPI
;; Error message
;; pattern/document <-> point
;; restriction

;;; Internal data structure:

;;; Pattern
;;; [<TYPE> <NC> (ARGS) <OA> <RANGE> <OPTIONS> <CACHES> <FLAG>]

;;;                              function	OA	ARGS
;;; element           ... TpoI-match-element	nil	pattern+
;;; attribute         ... TpoI-match-attribute	nil	pattern
;;; group             ... TpoI-match-group	nil	pattern+
;;; interleave        ... TpoI-match-interleave	nil	(pattern pattern)
;;; choice            ... TpoI-match-choice	nil	pattern+
;;; n-or-more         ... TpoI-match-n-or-more	n	pattern
;;; list              ... TpoI-match-list	nil	pattern+
;;; empty             ... TpoI-match-empty	nil	nil
;;; text              ... TpoI-match-text	nil	nil
;;; value             ... TpoI-match-value	DTS	string
;;; data              ... TpoI-match-data	DTS	params
;;; not-allowed       ... TpoI-match-not-allowed nil	nil
;;;
;;; DTS(datatypespec) := (datatypelib . type)
;;; params := ([ exceptpattern ] param*)
;;; exceptpattern := pattern
;;; param := (string . string)
;;;

(eval-when-compile
  (require 'cl))
(require 'XML-poly)

(defconst TpoI-relaxng-namespace-uri "http://relaxng.org/ns/structure/1.0")
(defconst TpoI-relaxng-namespace
  (XML-poly-get-namespace TpoI-relaxng-namespace-uri))

(defsubst TpoI-intern (name)
  (XML-poly-intern-for-ns name TpoI-relaxng-namespace))

(defsubst TpoI-attr-intern (name)
  (XML-poly-intern-for-ns name XML-poly-local-namespace))

;;;
;;; pattern object handling
;;;
;;; [<TYPE> <NC> (ARGS) <OA> <RANGE> <OPTIONS> <CACHES> <FLAG>]

(defsubst TpoI-make-pattern (type nc &optional oa args options not-fixated)
  (vector type nc args oa nil options nil
	  (if (or not-fixated args) nil 'fixated)))

(defsubst TpoI-pattern-get-type (p) (aref p 0))
(defsubst TpoI-pattern-set-type (p type) (aset p 0 type))
(defsubst TpoI-pattern-get-nc (p) (aref p 1))
(defsubst TpoI-pattern-set-nc (p nc) (aset p 1 nc))
(defsubst TpoI-pattern-get-args (p) (aref p 2))
(defsubst TpoI-pattern-set-args (p args) (aset p 2 args))
(defsubst TpoI-pattern-get-oa (p) (aref p 3))
(defsubst TpoI-pattern-set-oa (p oa) (aset p 3 oa))
(defsubst TpoI-pattern-get-range (p) (aref p 4))
(defsubst TpoI-pattern-set-range (p args) (aset p 4 args))
(defsubst TpoI-pattern-get-options (p prop)
  (plist-get (aref p 5) prop))
(defsubst TpoI-pattern-put-options (p prop val)
  (aset p (plist-put (aref p 5) prop val) 5))
(defsubst TpoI-pattern-get-cache (p) (aref p 6))
(defsubst TpoI-pattern-set-cache (p cache) (aset p 6 cache))
(defsubst TpoI-pattern-get-flag (p) (aref p 7))
(defsubst TpoI-pattern-set-flag (p flag) (aset p 7 flag))

(defsubst TpoI-pattern-args-as-group-p (p)
  (get (TpoI-pattern-get-type p) 'TpoI-args-as-group))

(defun TpoI-clear-all-cache (p)
  (let ((l (TpoI-pattern-get-args p)))
    (TpoI-pattern-set-cache p nil)
    (while l
      (TpoI-clear-all-cache (car l))
      (setq l (cdr l)))))

;;;
;;; error handling
;;;

(defvar TpoI-clear-resolved-error t
  "* Whether TpoI clears resolved errors.
Normally, it should be set to t.  This option is used for debugging TpoI.")

(defun TpoI-define-error (sym msg)
  (put sym 'TpoI-error-message msg))

(TpoI-define-error 'TpoI-error-unmatch-element
		   "`element' pattern's nameclass does not match.")
(TpoI-define-error 'TpoI-error-require-element-but-text
		   "An element is required here so that text is not allowed.")
(TpoI-define-error 'TpoI-error-require-element
		   "An element is required here, but there is nothing.")
(TpoI-define-error 'TpoI-error-element-too-many-contents
		   "Too many contents in the element.")
(TpoI-define-error 'TpoI-error-element-redundant-attribute
		   "The attribute is redundant.")
(TpoI-define-error 'TpoI-error-require-attribute
		   "An attribute is required here.")
(TpoI-define-error 'TpoI-error-unmatch-attribute
		   "The value of the attribute does not match.")
(TpoI-define-error 'TpoI-error-attribute-not-fully-match
		   "The value of the attribute does not match completely.")
(TpoI-define-error 'TpoI-error-require-text
		   "Non-empty text is required here.")
(TpoI-define-error 'TpoI-error-invalid-token-value
		   "Invalid token value.")
(TpoI-define-error 'TpoI-error-invalid-string-value
		   "Invalid string value.")
(TpoI-define-error 'TpoI-error-interleave-combination
		   "Fail to match all possible combinations of `interleave' pattern.")
(TpoI-define-error 'TpoI-error-data-match-except-pattern
		   "`except' pattern matches in `data' pattern.")
(TpoI-define-error 'TpoI-error-invalid-datatype-library
		   "Invalid datatype library.")
(TpoI-define-error 'TpoI-error-not-allowed
		   "matches `notAllowed' pattern.")

(defvar TpoI-error-stack nil)
(defvar TpoI-last-range nil)

;; (status pattern object-or-range) 
(defun TpoI-set-error (status &optional p obj)
  (if obj
      (setq TpoI-error-stack
	    (cons (list status p obj) TpoI-error-stack))
    (if TpoI-last-range
	(setq obj (XML-poly-get-range-end TpoI-last-range)
	      TpoI-error-stack
	      (cons (list status p
			  (cons 'range
				(XML-poly-make-range
				 obj (1+ obj)
				 (XML-poly-get-range-buf TpoI-last-range))))
		    TpoI-error-stack))
      (setq TpoI-error-stack
	    (cons (list status p nil) TpoI-error-stack)))))

(defsubst TpoI-clear-error ()
  (if TpoI-clear-resolved-error
      (setq TpoI-error-stack nil)))

;; TODO
(defun TpoI-get-error-message (er)
  (get (car er) 'TpoI-error-message))

(defun TpoI-get-error-document-range (er)
  (setq er (nth 2 er))
  (when er
    (if (eq (car-safe er) 'range)
	(cdr er)
      (XML-poly-get-range er))))

(defsubst TpoI-get-error-schema-range (er)
  (TpoI-pattern-get-range (nth 1 er)))

;;;
;;; name class
;;;

;;; simplified form:
;;;   NCLikeSym
;;; NCLikeSym := nil | any | <nameitem> | <text-flag>
;;;
;;; complex form:
;;;  [<text-flag> <any-flag> <NSes> <add-nameitems> <sub-nameitems>]
;;;
;;; any-flag := nil | any
;;; NSes := <namespace>*
;;; add-nameitems := <nameitem>*
;;; sub-nameitems := <nameitem>*
;;; nameitem := a symbol that belong to the XML-poly name.
;;; text-flag := nil | simple | complex

(defconst TpoI-empty-complex-nameclass [nil nil nil nil nil])

(defsubst TpoI-complex-nameclass-object-p (s)
  (and (vectorp s) (= (length s) 5)))

(defsubst TpoI-nameclass-text-flag (s)
  (if (symbolp s)
      (if (memq s '(complex simple)) s nil)
    (aref s 0)))

(defun TpoI-group-text-flag (t1 t2)
  (cond ((eq t1 t2) t1)
	((or (eq t1 'complex)
	     (eq t2 'complex)
	     'complex))
	((or (eq t1 'simple)
	     (eq t2 'simple)
	     'simple))
	(t
	 nil)))

;;
;; Nameclass normalized form
;;
;;  A - N1 - N2 - ... - Nk + a1 + ... + an - b1 - ... - bm  => we call A-form
;;                   or
;;  N1 + ... + Nk  + a1 + ... + an - b1 - ... - bm          => we call N-form
;;  Any i, j in {1 ... k} Ni != Nj
;;  Any i in {1 ... n}, j in {1 ... m} ai != bj
;;
;; A-form lisp representation [TF any (N1 ... Nk) (a1 ... an) (b1 ... bm)]
;; N-form lisp representation [TF nil (N1 ... Nk) (a1 ... an) (b1 ... bm)]
;;

(defun TpoI-match-complex-nameclass (nc sym)
  (if (eq (aref nc 1) 'any)
      (if (memq (XML-poly-get-symbol-namespace sym) (aref nc 2))
	  (memq sym (aref nc 3))
	(not (memq sym (aref nc 4))))
    (if (memq (XML-poly-get-symbol-namespace sym) (aref nc 2))
	(not (memq sym (aref nc 4)))
      (memq sym (aref nc 3)))))

(defun TpoI-match-nameclass (nc sym)
  (or (eq nc sym)
      (eq nc (XML-poly-get-symbol-namespace sym))
      (eq nc 'any)
      (if (TpoI-complex-nameclass-object-p nc)
	  (TpoI-match-complex-nameclass nc sym))))

(defsubst TpoI-infinite-nameclass-p (nc)
  (and (vectorp nc)
       (or (eq (aref nc 1) 'any)
	   (aref nc 2))))

(defsubst TpoI-nameclass-A-form-p (nc)
  (eq (aref nc 1) 'any))

(defun TpoI-nameclass-normalize-nameitems (a b)
  (let ((is (intersection a b)))
    (list (set-difference a is)
	  (set-difference b is))))

(defun TpoI-nameclass-normalize-S+S (s1 s2)
  (let (s)
    (if (and (TpoI-nameclass-A-form-p s2)
	     (not (TpoI-nameclass-A-form-p s1)))
	(setq s s2
	      s2 s1
	      s1 s))
    (cond ((TpoI-nameclass-A-form-p s2)
	   ;; A-form + A-form
	   (apply
	    (function vector)
	    (TpoI-group-text-flag
	     (aref s1 0) (aref s2 0))
	    'any
	    (union (aref s1 2) (aref s2 2))
	    (TpoI-nameclass-normalize-nameitems
	     (union (aref s1 3) (aref s2 3))
	     (union (aref s1 4) (aref s2 4)))))

	  ((not (TpoI-nameclass-A-form-p s1))
	   ;; N-form + N-form
	   (apply
	    (function vector)
	    (TpoI-group-text-flag
	     (aref s1 0) (aref s2 0))
	    nil
	    (union (aref s1 2) (aref s2 2))
	    (TpoI-nameclass-normalize-nameitems
	     (union (aref s1 3) (aref s2 3))
	     (union (aref s1 4) (aref s2 4)))))

	  (t
	   ;; A-form + N-form
	   (apply
	    (function vector)
	    (TpoI-group-text-flag
	     (aref s1 0) (aref s2 0))
	    'any
	    (set-difference (aref s1 2) (aref s2 2))
	    (TpoI-nameclass-normalize-nameitems
	     (union (aref s1 3) (aref s2 3))
	     (union (aref s1 4) (aref s2 4))))))))

(defun TpoI-nameclass-normalize-A-S (s)
  (if (TpoI-nameclass-A-form-p s)
      (vector (aref s 0) nil (aref s 2) (aref s 4) (aref s 3))
    (vector (aref s 0) 'any (aref s 2) (aref s 4) (aref s 3))))

(defun TpoI-collect-nameitems (n items)
  (let (r)
    (while items
      (if (eq n (XML-poly-get-symbol-namespace (car items)))
	  (setq r (cons (car items) r)))
      (setq items (cdr items)))
    r))

(defun TpoI-nameclass-normalize-N-S (n s)
  (if (TpoI-nameclass-A-form-p s)
      (vector (aref s 0) nil
	      (if (memq n (aref s 2)) (list n))
	      (TpoI-collect-nameitems n (aref s 4))
	      (TpoI-collect-nameitems n (aref s 3)))
    (if (memq n (aref s 2))
	(vector (aref s 0)
		nil nil
		(TpoI-collect-nameitems n (aref s 4))
		nil)
      (vector (aref s 0)
	      nil (list n)
	      nil
	      (TpoI-collect-nameitems n (aref s 3))))))

(defun TpoI-normalize-complex-nameclass (s)
  (cond ((TpoI-complex-nameclass-object-p s)
	 s)
	((eq s 'any)
	 [nil any nil nil nil])
	((null s)
	 TpoI-empty-complex-nameclass)
	((memq s '(complex simple))
	 (vector s nil nil nil nil))
	((vectorp s)
	 (vector nil nil (list s) nil nil))
	((symbolp s)
	 (vector nil nil nil (list s) nil))
	(t
	 (error "Invalid nameclass object:%S" s))))

(defun TpoI-simplify-nameclass (s)
  (if (TpoI-complex-nameclass-object-p s)
      (cond ((and (null (aref s 1))
		  (null (aref s 2))
		  (null (aref s 3))
		  (null (aref s 4)))
	     (aref s 0))
	    ((equal s [nil any nil nil nil])
	     'any)
	    ((and (null (aref s 0))
		  (null (aref s 1))
		  (= (length (aref s 2)) 1)
		  (null (aref s 3))
		  (null (aref s 4)))
	     (car (aref s 2)))
	    ((and (null (aref s 0))
		  (null (aref s 1))
		  (null (aref s 2))
		  (= (length (aref s 3)) 1)
		  (null (aref s 4)))
	     (car (aref s 3)))
	    (t s))
    s))

;;;
;;; util. for a set
;;;

(defun TpoI-remove-list (l l1)
  (let (r)
    (while (not (eq l l1))
      (setq r (cons (car l) r)
	    l (cdr l)))
    (nconc (nreverse r) (cdr l1))))

(defun TpoI-copy-n-list (l n)
  (if (= n 0) nil
    (let (x r)
      (setq n (nthcdr (1- n) l)
	    x (cdr n))
      (setcdr n nil)
      (setq r (copy-sequence l))
      (setcdr n x)
      r)))

;;;
;;; internal variable
;;;

(defvar TpoI-datatype-library-alist nil)

;; should we use dynamic binding for such purpose?...;_;;;
(defvar TpoI-weak-match nil)

;;;
;;; Pattern match
;;;

(defconst TpoI-ws-regexp (concat "\\`" XML-poly-S*-regexp "\\'"))

;; context
;;   A context has a cons cell that consists of an attribute set in car
;;   a sequence of element or string in cdr.

(defsubst TpoI-context-empty-p (ctx)
  (or (null ctx) (member ctx '((nil . nil) (nil . (""))))))

(defsubst TpoI-make-context (a m)
  (cons a m))

(defun TpoI-normalize-element-attributes (a)
  (let (r aa)
    (while a
      (setq aa (car a)
	    a (cdr a))
      (if (XML-poly-xmlns-symbol-p (XML-poly-get-attribute-name aa))
	  nil
	(setq r (cons aa r))))
    r))

(defun TpoI-normalize-element-contents (c)
  (let (r v s)
    (while c
      (setq v (car c)
	    c (cdr c))
      (if (listp v)
	  (setq v
		(cond ((eq (car v) 'CDATA)
		       (XML-poly-get-cdata-text (car c)))
		      (t nil))))
      (if v
	  (if (stringp v)
	      (setq s (concat s v))
	    (if (and s (not (string-match TpoI-ws-regexp s)))
		(setq r (cons v (cons s r))
		      s nil)
	      (setq r (cons v r)
		    s nil)))))
    (nreverse
     (if (and s
	      (or (null r)
		  (not (string-match TpoI-ws-regexp s))))
	 (cons s r)
       r))))

(defsubst TpoI-make-context-for-element (e)
  (cons
   (TpoI-normalize-element-attributes
    (XML-poly-get-element-attribute-list e))
   (or (TpoI-normalize-element-contents
	(XML-poly-get-element-contents e))
       '(""))))

(defsubst TpoI-make-context-for-attribute (a)
  (cons nil (list (or (XML-poly-get-attribute-value a) ""))))

;;
;; ramification
;;

(defvar TpoI-pattern-stack nil)
(defvar TpoI-ramification-list nil)
(defvar TpoI-ramification-list-stack nil)

(defsubst TpoI-set-rollback-point (p ctx &optional arg)
  ;;(message "%S" (nth 1 (backtrace-frame 5)))
  ;;(message "SR->%S:%S" (TpoI-pattern-get-type p) arg)
  (setq TpoI-ramification-list
	(cons (list TpoI-pattern-stack TpoI-weak-match p ctx arg)
	      TpoI-ramification-list)))

(defsubst TpoI-new-ramification-list ()
  (push TpoI-ramification-list
	TpoI-ramification-list-stack)
  (setq TpoI-ramification-list nil))

(defsubst TpoI-restore-ramification-list ()
  (setq TpoI-ramification-list
	(pop TpoI-ramification-list-stack)))

;;
;; entry functions.
;;

;; 'fail
;; ctx
;; ([pattern] ctx optarg)
(defun TpoI-match-pattern (p ctx)
  (catch 'exit
    (let ((TpoI-weak-match nil)
	  (TpoI-pattern-stack nil)
	  (TpoI-ramification-list nil)
	  (TpoI-ramification-list-stack nil)
	  (TpoI-last-range nil)
	  r rl c1 rng)
      (while t
	(setq c1 (car (cdr ctx)))
	(when c1
	    (setq rng (XML-poly-get-range c1))
	    (if rng
		(setq TpoI-last-range rng)))
	(if rl
	    (setq r (apply (TpoI-pattern-get-type p) rl)
		  rl nil)
	  (setq r (funcall (TpoI-pattern-get-type p) p ctx)))
	(cond ((vectorp (car-safe r))
	       (push (cons p (nth 2 r)) TpoI-pattern-stack)
	       (setq p (car r)
		     ctx (nth 1 r))
	       t)
	      ((eq r 'fail)
	       (setq p (pop TpoI-pattern-stack))
	       (if p
		   (setq rl (list (car p) 'fail (cdr p))
			 p (car p))
		 (throw 'exit 'fail)))
	      ((eq r 'recover)
	       ;; try to rollback
	       (setq rl (pop TpoI-ramification-list))
	       (if rl
		   (setq TpoI-pattern-stack (car rl)
			 rl (cdr rl)
			 TpoI-weak-match (car rl)
			 rl (cdr rl)
			 p (car rl)
			 ctx (nth 1 rl))
		 ;; pop up the parental pattern.
		 (setq p (pop TpoI-pattern-stack))
		 (if p
		     (setq rl (list (car p) 'fail (cdr p))
			   p (car p))
		   (throw 'exit 'fail))))
	      (t
	       (setq p (pop TpoI-pattern-stack))
	       (setq ctx r)
	       (if p
		   (setq rl (list (car p) ctx (cdr p))
			 p (car p))
		 (throw 'exit (if (TpoI-context-empty-p ctx) nil ctx)))))))))

;;
;; Pattern match functions.
;;   The pattern match functions should accept
;;   a pattern as "p", and context as "ctx", and
;;   optional argument, "state".

;; (next-ps origctx wmf)
(defun TpoI-match-element (p ctx &optional st)
  (cond ((eq ctx 'fail)
	 'recover)
	((null st)
	 (let ((ps (TpoI-pattern-get-args p))
	       (wmf TpoI-weak-match)
	       (e (car (cdr ctx))))
	   (if (vectorp e)
	       (if (TpoI-match-nameclass
		    (TpoI-pattern-get-nc p)
		    (XML-poly-get-element-name e))
		   (progn
		     (setq TpoI-weak-match t)
		     (TpoI-new-ramification-list)
		     (list (car ps)
			   (TpoI-make-context-for-element e)
			   (list (cdr ps) ctx wmf)))
		 (TpoI-set-error 'TpoI-error-unmatch-element p e)
		 'fail)
	     (if (stringp e)
		 (TpoI-set-error 'TpoI-error-require-element-but-text p e)
	       (TpoI-set-error 'TpoI-error-require-element p e))
	     'fail)))
	((car st)
	 (let ((ps (car st)))
	   (list (car ps) ctx (cons (cdr ps) (cdr st)))))
	(t
	 (let ((ctx2 (nth 1 st)))
	   (setq TpoI-weak-match (nth 2 st))
	   (if (TpoI-context-empty-p ctx)
	       (progn
		 (TpoI-restore-ramification-list)
		 (cons (car ctx2) (cdr (cdr ctx2))))
	     (if (car ctx)
		 (TpoI-set-error 'TpoI-error-element-redundant-attribute p (car (car ctx)))
	       (TpoI-set-error 'TpoI-error-element-too-many-contents p (car (cdr ctx))))
	     'recover)))))
(put 'TpoI-match-element 'TpoI-args-as-group t)

;; (matched-a ctx wmf)
(defun TpoI-match-attribute (p ctx &optional st)
  (let ((nc (TpoI-pattern-get-nc p))
	(ps (TpoI-pattern-get-args p))
	(wmf TpoI-weak-match)
	a)
    (cond ((null st)
	   (setq a (car ctx))
	   (while (and a
		       (not (TpoI-match-nameclass
			     nc (XML-poly-get-attribute-name (car a)))))
	     (setq a (cdr a)))
	   (if (null a)
	       (progn
		 (TpoI-set-error 'TpoI-error-require-attribute p (car (car ctx)))
		 'fail)
	     (if (null ps) ;; assume <text/> element
		 (cons (TpoI-remove-list (car ctx) a) (cdr ctx))
	       (setq TpoI-weak-match t)
	       (list ps
		     (TpoI-make-context-for-attribute (car a))
		     (list a ctx wmf)))))
	  ((eq ctx 'fail)
	   (setq a (cdr (car st))
		 ctx (nth 1 st))
	   (while (and a
		       (not (TpoI-match-nameclass
			     nc (XML-poly-get-attribute-name (car a)))))
	     (setq a (cdr a)))
	   (if (null a)
	       (progn
		 (setq TpoI-weak-match (nth 2 st))
		 (TpoI-set-error 'TpoI-error-unmatch-attribute p (car (car st)))
		 'fail)
	     (if (null ps) ;; assume <text/> element
		 (cons (TpoI-remove-list (car ctx) a) (cdr ctx))
	       (list ps
		     (TpoI-make-context-for-attribute (car a))
		     (cons a (cdr st))))))
	  ((not (TpoI-context-empty-p ctx))
	   (setq a (cdr (car st))
		 ctx (nth 1 st))
	   (while (and a
		       (not (TpoI-match-nameclass
			     nc (XML-poly-get-attribute-name (car a)))))
	     (setq a (cdr a)))
	   (if (null a)
	       (progn
		 (setq TpoI-weak-match (nth 2 st))
		 (TpoI-set-error 'TpoI-error-attribute-not-fully-match p (car (cdr ctx)))
		 'fail)
	     (if (null ps) ;; assume <text/> element
		 (cons (TpoI-remove-list (car ctx) a) (cdr ctx))
	       (list ps
		     (TpoI-make-context-for-attribute (car a))
		     (cons a (cdr st))))))
	  (t
	   (setq a (car st)
		 ctx (nth 1 st)
		 TpoI-weak-match (nth 2 st))
	   (cons (TpoI-remove-list (car ctx) a) (cdr ctx))))))

(defun TpoI-match-group (p ctx &optional ps)
  (if (eq ctx 'fail)
      'fail
    (if (null ps) (setq ps (TpoI-pattern-get-args p)))
    (if (consp ps)
	(list (car ps) ctx (or (cdr ps) 0))
      ctx)))

;;;
;;; interleave
;;;

(defun TpoI-collect-context-in-nc (ctx nc)
  (let ((a (car ctx))
	(m (cdr ctx))
	an ae mn me)
    (while a
      (if (TpoI-match-nameclass nc (XML-poly-get-attribute-name (car a)))
	  (setq an (cons (car a) an))
	(setq ae (cons (car a) ae)))
      (setq a (cdr a)))
    (if (TpoI-nameclass-text-flag nc)
	(while m
	  (cond ((or (stringp (car m))
		     (TpoI-match-nameclass
		      nc (XML-poly-get-element-name (car m))))
		 (setq mn (cons (car m) mn)))
		(t
		 (setq me (cons (car m) me))))
	  (setq m (cdr m)))
      (while m
	(if (and (vectorp (car m))
		 (TpoI-match-nameclass nc (XML-poly-get-element-name (car m))))
	    (setq mn (cons (car m) mn))
	  (setq me (cons (car m) me)))
	(setq m (cdr m))))
    (cons
     (TpoI-make-context an (nreverse mn))
     (TpoI-make-context ae (nreverse me)))))

;; TODO optimization.
;; (<0 or 1> ctxorig next-ctx)
(defun TpoI-match-interleave (p ctx &optional st)
  (let (p1 p2 ctxc)
    (setq p1 (TpoI-pattern-get-args p)
	  p2 (nth 1 p1)
	  p1 (car p1))
    (cond ((null st)
	   (setq ctxc (TpoI-collect-context-in-nc
		       ctx (TpoI-pattern-get-nc p1)))
	   (list p1 (car ctxc) (list 0 ctx (cdr ctxc))))
	  ((eq ctx 'fail) 'fail)
	  ((= (car st) 0)
	   (if (TpoI-context-empty-p ctx)
	       (list p2 (nth 2 st) (cons 1 (cdr st)))
	     (TpoI-set-error 'TpoI-error-interleave-combination
			     p (if (eq ctx 'fail) nil (car (cdr ctx))))
	     'fail))
	  (t ;; (eq (car-safe st) 1)
	   ctx))))

;; (ctx . ps)
;; (choice . ps)
(defun TpoI-match-choice (p ctx &optional ps)
  (cond ((null ps)
	 (setq ps (TpoI-pattern-get-args p))
	 (list (car ps) ctx (cons ctx (cdr ps))))
	((eq ctx 'fail)
	 (setq ctx (car ps)
	       ps (cdr ps))
	 (if ps
	     (list (car ps) ctx (cons ctx (cdr ps)))
	   'fail))
	((eq 'choice (car ps))
	 (setq ps (cdr ps))
	 ;;(if (cdr ps)
	 ;;    (TpoI-set-rollback-point p ctx (cons 'choice (cdr ps))))
	 (list (car ps) ctx (cons ctx (cdr ps))))
	(t
	 (if (cdr ps)
	     (TpoI-set-rollback-point p (car ps) (cons 'choice (cdr ps))))
	 (TpoI-clear-error)
	 ctx)))
(put 'TpoI-match-choice 'TpoI-ramification t)
(put 'TpoI-match-choice 'TpoI-args-as-group t)

;; TODO: cache
;; (i n)  ... (ctxorig ctxprev)
;; n
(defun TpoI-match-n-or-more (p ctx &optional st)
  (cond ((null st)
	 (let ((pc (TpoI-pattern-get-args p))
	       (n (TpoI-pattern-get-oa p)))
	   (if (> n 0)
	       (list pc ctx (list 1 n))
	     (TpoI-set-rollback-point p ctx 1)
	     ctx)))
	((eq ctx 'fail) 'fail)
	(t
	 (let ((pc (TpoI-pattern-get-args p)))
	   (if (numberp st)
	       ;; rollbacked
	       (list pc ctx (list st st))
	     (let ((i (car st))
		   (n (nth 1 st)))
	       (if (< i n)
		   (list pc ctx (list (1+ i) n))
		 (TpoI-set-rollback-point p ctx (1+ i))
		 ctx)))))))
(put 'TpoI-match-choice 'TpoI-ramification t)

(defun TpoI-match-list (p ctx &optional st)
  (cond ((null st)
	 (let ((s (car (cdr ctx)))
	       (ps (TpoI-pattern-get-args p)))
	   (if (not (stringp s))
	       'fail
	     (setq s (split-string s XML-poly-S-regexp))
	     (list (car ps) (TpoI-make-context nil s) (cons ctx (cdr ps))))))
	((eq ctx 'fail) 'fail)
	(t
	 (let ((ps (cdr st))
	       (ctx2 (car st)))
	   (if ps
	       (list (car ps) ctx (cons (car st) (cdr ps)))
	     (if (TpoI-context-empty-p ctx)
		 (TpoI-make-context (car ctx2) (cdr (cdr ctx2)))
	       'fail))))))

(defsubst TpoI-match-empty (p ctx)
  (if (and TpoI-weak-match
	   (stringp (setq p (car (cdr ctx))))
	   (string-match TpoI-ws-regexp p))
      (cons (car ctx) (cdr (cdr ctx)))
    ctx))

(defun TpoI-match-text (p ctx)
  (let ((m (cdr ctx))
	f)
    (while (and m
		(stringp (car m)))
      (setq m (cdr m)
	    f t))
    (cond (f
	   (TpoI-make-context (car ctx) m))
	  (TpoI-weak-match
	   ctx)
	  (t
	   ;; unmatched
	   'fail))))

(defsubst TpoI-normalize-token-string (s)
  (mapconcat (function identity) (split-string s XML-poly-S-regexp) " "))
  
(defun TpoI-match-value (p ctx)
  (let* ((type (TpoI-pattern-get-oa p))
	 (m (cdr ctx))
	 (s (or (car m) "")))
    (cond ((not (stringp s))
	   (TpoI-set-error 'TpoI-error-require-text p s)
	   'fail)
	  ((eq type 'token)
	   (if (string= (TpoI-normalize-token-string s)
			(TpoI-pattern-get-args p))
	       (cons (car ctx) (cdr m))
	     (TpoI-set-error 'TpoI-error-invalid-token-value p s)
	     'fail))
	  ((eq type 'string)
	   (if (string= s (TpoI-pattern-get-args p))
	       (cons (car ctx) (cdr m))
	     (TpoI-set-error 'TpoI-error-invalid-string-value p s)
	     'fail))
	  (t
	   ;; TODO
	   (TpoI-set-error 'TpoI-error-invalid-datatype-library p s)
	   'fail))))

(defsubst TpoI-match-data-internal (p type ctx s)
  (cond ((symbolp type)
	 (TpoI-make-context (car ctx) (cdr (cdr ctx))))
	(t
	 (if t
	     (TpoI-make-context (car ctx) (cdr (cdr ctx)))
	 ;; TODO
	   (TpoI-set-error 'TpoI-error-invalid-datatype-library p s)
	   'fail))))

;; (ctx . s)
(defun TpoI-match-data (p ctx &optional st)
  (cond ((eq ctx 'fail)
	 (TpoI-match-data-internal
	  p (TpoI-pattern-get-oa p)
	  (car st) (cdr st)))
	(st
	 (TpoI-restore-ramification-list)
	 (TpoI-set-error
	  'TpoI-error-data-match-except-pattern
	  (car (TpoI-pattern-get-args p))
	  (cdr st))
	 'fail)
	(t
	 (let* ((params (TpoI-pattern-get-args p))
		(except-p (car params))
		(m (cdr ctx))
		(s (car m)))
	   (if (vectorp except-p)
	       (setq params (cdr params))
	     (setq except-p nil))
	   (if (not (stringp s))
	       (progn
		 (TpoI-set-error 'TpoI-error-require-text p s)
		 'fail)
	     (if except-p
		 (progn
		   (TpoI-new-ramification-list)
		   (list except-p
			 (TpoI-make-context
			  nil (list s))
			 (cons ctx s)))
	       (TpoI-match-data-internal
		p (TpoI-pattern-get-oa p)
		ctx s)))))))

(defun TpoI-match-not-allowed (p ctx)
  (TpoI-set-error 'TpoI-error-not-allowed p (car (cdr ctx)))
 'fail)

;;;
;;; Datatype library SPI
;;;

(defun TpoI-register-datatype-library (name func)
  ;; TODO
  )

;;;
;;; Schema compilation
;;;

(defvar TpoI-error-handling-function nil)

(defun TpoI-compile-error (mes obj &rest args)
  (if args
      (apply 'error mes args)
    (error mes)))


(defvar TpoI-current-default-namespace "")
(defvar TpoI-current-default-datatype-library "")
(defvar TpoI-current-prefix-alist
  (list
   (cons (XML-poly-intern-xmlns-symbol "xml")
	 "http://www.w3.org/XML/1998/namespace")))

(defvar TpoI-current-base-URI "")
(defvar TpoI-current-importing-filenames nil)

(defconst TpoI-grammar (TpoI-intern "grammar"))

(defconst TpoI-name (TpoI-intern "name"))
(defconst TpoI-anyName (TpoI-intern "anyName"))
(defconst TpoI-nsName (TpoI-intern "nsName"))
(defconst TpoI-choice (TpoI-intern "choice"))
(defconst TpoI-except (TpoI-intern "except"))
(defconst TpoI-param (TpoI-intern "param"))
(defconst TpoI-nameclass-top-syms
  (list TpoI-name TpoI-anyName TpoI-nsName TpoI-choice))

(defconst TpoI-div (TpoI-intern "div"))
(defconst TpoI-define (TpoI-intern "define"))
(defconst TpoI-include (TpoI-intern "include"))
(defconst TpoI-start (TpoI-intern "start"))

(defconst TpoI-empty (TpoI-intern "empty"))

(defconst TpoI-attr-ns (TpoI-attr-intern "ns"))
(defconst TpoI-attr-datatypeLibrary (TpoI-attr-intern "datatypeLibrary"))
(defconst TpoI-attr-type (TpoI-attr-intern "type"))
(defconst TpoI-attr-href (TpoI-attr-intern "href"))
(defconst TpoI-attr-name (TpoI-attr-intern "name"))
(defconst TpoI-attr-combine (TpoI-attr-intern "combine"))

;; import external object

(defun TpoI-update-base-URI (new prev)
  (cond ((string-match XML-poly-external-URI-regexp new)
	 (if (eq (aref new (1- (length new))) ?/)
	     new
	   (concat new "/")))
	((string-match "^/" new)
	 (if (string-match XML-poly-external-URI-regexp prev)
	     (concat (substring prev 0 (match-end 2)) new)
	   new))
	(t
	 (let ((pos (string-match "/[^/]+\\'" prev)))
	   (if pos
	       (concat (substring prev 0 (1+ pos)) new)
	     (cond ((string-match "\\`[^/]*\\'" prev) new)
		   ((string-match "/\\'" prev) (concat prev new))
		   (t (concat prev "/" new))))))))

(defun TpoI-import-external-object (uri baseobj)
  (let ((range (XML-poly-get-range baseobj))
	base buf filename)
    (when range
      (setq buf (XML-poly-get-range-buf range))
      (when (and buf (buffer-file-name buf))
	(setq base (file-name-directory (buffer-file-name buf)))))
    (setq base (XML-poly-parse-external
		(TpoI-update-base-URI uri TpoI-current-base-URI)
		base t)
	  filename (car base))
    (if (member filename TpoI-current-importing-filenames)
	(TpoI-compile-error "" baseobj)
      (push filename TpoI-current-importing-filenames)
      (nthcdr 2 base))))

;; Qualified name
(defconst TpoI-qname-regexp
  (concat
   "\\`" 
   XML-poly-S*-regexp
   XML-poly-name-regexp
   XML-poly-S*-regexp
    "\\'"))
(defun TpoI-intern-qname (str obj &optional ignore-inherited-ns)
  (if (string-match TpoI-qname-regexp str)
      (let* ((prefix (match-string 1 str))
	     (prefix-len (length prefix))
	     (name (match-string 2 str))
	     slot)
	(if (= prefix-len 0)
	    (XML-poly-intern
	     name (if ignore-inherited-ns
		      ""
		    TpoI-current-default-namespace))
	  (setq slot (assq (XML-poly-intern-xmlns-symbol
			    (substring prefix 0 (1- prefix-len)))
			   TpoI-current-prefix-alist))
	  (if slot
	      (XML-poly-intern name (cdr slot))
	    (TpoI-compile-error "Prefix:%s does not defined." obj prefix))))
    (TpoI-compile-error "Invalid QName:%s" obj str)))

(defun TpoI-intern-element-qname (e)
  (let ((c (XML-poly-get-element-contents e))
	type x)
    (catch 'exit
      (while c
	(setq x (car c)
	      c (cdr c))
	(setq type (XML-poly-object-type x))
	(cond ((memq type '(PCDATA CDATA))
	       (if (eq type 'CDATA)
		   (setq x (XML-poly-get-cdata-text x)))
	       (throw 'exit (TpoI-intern-qname x e)))
	      ((eq type 'ELEMENT)
	       (if (eq (XML-poly-get-symbol-namespace (XML-poly-get-element-name x))
		       TpoI-relaxng-namespace)
		   (TpoI-compile-error "RELAX NG element is not allowed here." e))))))))

;; string argument
(defun TpoI-get-element-string (e)
  (let ((c (XML-poly-get-element-contents e))
	type x r)
    (while c
      (setq x (car c)
	    c (cdr c))
      (setq type (XML-poly-object-type x))
      (cond ((memq type '(PCDATA CDATA))
	     (if (eq type 'CDATA)
		 (setq x (XML-poly-get-cdata-text x)))
	     (setq r (concat r x)))
	    ((eq type 'ELEMENT)
	     (TpoI-compile-error "Elements are not allowed here." e))))
    (cond ((stringp r) r)
	  ((null r) "")
	  (t
	   (TpoI-compile-error "Missing string argument." e)))))

;; attribute NCName
(defconst TpoI-ncname-regexp
  (concat
   "\\`"
   XML-poly-S*-regexp
   "\\(" XML-poly-ncname-regexp "\\)" ;; 1
   XML-poly-S*-regexp
   "\\'"))
(defun TpoI-get-attribute-ncname (a)
  (if (string-match TpoI-ncname-regexp
		    (XML-poly-get-attribute-value a))
      (match-string 1 (XML-poly-get-attribute-value a))
    (TpoI-compile-error "Invalid attribute NCName:%s"
			a (XML-poly-get-attribute-value a))))

;; ("name" combination <def>*...)
;; <def> = (object <pattern>+)
;; combination := (choice/interleave/nil . already-unspecified)
(defvar TpoI-current-definition-alist nil)
(defvar TpoI-parent-definition-alist nil)

(defun TpoI-lookup-ref (name &optional parent)
  (let* ((defalist (if parent
		       'TpoI-parent-definition-alist
		     'TpoI-current-definition-alist))
	 (slot (assoc name (symbol-value defalist))))
    (or slot
	(progn
	  (setq slot (list name))
	  (set defalist (cons slot (symbol-value defalist)))
	  slot))))

(defun TpoI-define (e name combination def)
  (let* ((slot (TpoI-lookup-ref name))
	 (oldcomb (nth 1 slot))
	 (olddef (nthcdr 2 slot))
	 already-unspecified)
    (setq already-unspecified (cdr oldcomb)
	  oldcomb (car oldcomb))
    (cond ((and already-unspecified
		(not combination))
	   (TpoI-compile-error
	    (if (eq name 'start)
		"There must not more than one `start' without `combine'."
	      "There must not more than one `define' with the same name without `combine'.")
	    e))
	  ((and combination
		oldcomb
		(not (eq oldcomb combination)))
	   (TpoI-compile-error "Inconsistent `combine'." e))
	  (t
	   (if (null combination)
	       (setq combination (cons oldcomb t))
	     (setq combination (cons combination already-unspecified)))
	   (setq def (cons e def))
	   (if olddef
	       (setcdr slot (cons combination (cons def olddef)))
	     (setcdr slot (cons combination (list def))))))))

(defun TpoI-define-name (cat name func)
  (let ((sym (TpoI-intern name)))
    (if (eq cat 'pattern)
	(put sym 'TpoI-pattern func)
      (put sym 'TpoI-grammar func))))

(TpoI-define-name 'pattern "element" 'TpoI-make-element-pattern)
(TpoI-define-name 'pattern "attribute" 'TpoI-make-attribute-pattern)
(TpoI-define-name 'pattern "group" 'TpoI-make-group-pattern)
(TpoI-define-name 'pattern "interleave" 'TpoI-make-interleave-pattern)
(TpoI-define-name 'pattern "choice" 'TpoI-make-choice-pattern)
(TpoI-define-name 'pattern "optional" 'TpoI-make-optional-pattern)
(TpoI-define-name 'pattern "zeroOrMore" 'TpoI-make-zero-or-more-pattern)
(TpoI-define-name 'pattern "oneOrMore" 'TpoI-make-one-or-more-pattern)
(TpoI-define-name 'pattern "list" 'TpoI-make-list-pattern)
(TpoI-define-name 'pattern "mixed" 'TpoI-make-mixed-pattern)
(TpoI-define-name 'pattern "ref" 'TpoI-make-ref-pattern)
(TpoI-define-name 'pattern "parentRef" 'TpoI-make-parent-ref-pattern)
(TpoI-define-name 'pattern "empty" 'TpoI-make-empty-pattern)
(TpoI-define-name 'pattern "text" 'TpoI-make-text-pattern)
(TpoI-define-name 'pattern "value" 'TpoI-make-value-pattern)
(TpoI-define-name 'pattern "data" 'TpoI-make-data-pattern)
(TpoI-define-name 'pattern "notAllowed" 'TpoI-make-not-allowed-pattern)
(TpoI-define-name 'pattern "externalRef" 'TpoI-make-external-ref-pattern)
(TpoI-define-name 'pattern "grammar" 'TpoI-make-grammar-section)

(defconst TpoI-relaxng-attribute-namespaces
  (list TpoI-relaxng-namespace XML-poly-local-namespace))
(defun TpoI-check-attributes (e &optional allowed)
  (let ((as (XML-poly-get-element-attribute-list e))
	a sym)
    (while as
      (setq a (car as)
	    as (cdr as))
      (setq sym (XML-poly-get-attribute-name a))
      (if (memq (XML-poly-get-symbol-namespace sym)
		TpoI-relaxng-attribute-namespaces)
	  (cond ((eq sym TpoI-attr-ns)
		 (setq TpoI-current-default-namespace
		       (XML-poly-get-attribute-value a)))
		((eq sym TpoI-attr-datatypeLibrary)
		 (setq TpoI-current-default-datatype-library
		       (XML-poly-get-attribute-value a)))
		((eq sym XML-poly-base)
		 (setq TpoI-current-base-URI
		       (TpoI-update-base-URI
			(XML-poly-get-attribute-value a)
			TpoI-current-base-URI)))
		((memq sym allowed))
		(t
		 (TpoI-compile-error
		  "RELAX NG attribute %S is not allowed here."
		  e sym)))
	(if (XML-poly-xmlns-symbol-p sym)
	    (setq TpoI-current-prefix-alist
		  (cons (cons sym (XML-poly-get-attribute-value a))
			TpoI-current-prefix-alist)))))))


(defmacro TpoI-start-element (x-e x-attributes &rest form)
  `(let ((TpoI-current-default-namespace
	  TpoI-current-default-namespace)
	 (TpoI-current-prefix-alist
	  TpoI-current-prefix-alist)
	 (TpoI-current-default-datatype-library
	  TpoI-current-default-datatype-library)
	 (TpoI-current-base-URI
	  TpoI-current-base-URI))
     (TpoI-check-attributes ,x-e ,x-attributes)
     ,@form))
;;(def-edebug-spec TpoI-start-element (arg arg &rest form))

(defun TpoI-parse-contents (c func)
  (let (type x)
    (while c
      (setq x (car c)
	    c (cdr c))
      (setq type (XML-poly-object-type x))

      (cond ((memq type '(PCDATA CDATA))
	     (TpoI-compile-error "text is not allowed here:%S." e x))
	    ((eq type 'ELEMENT)
	     (if (eq (XML-poly-get-symbol-namespace (XML-poly-get-element-name x))
		     TpoI-relaxng-namespace)
		 (funcall func x)))))
    nil))

(defun TpoI-compile-except-nameclass (c)
  (let (type r)
    (TpoI-parse-contents
     c
     (lambda (x)
       (TpoI-start-element
	x nil
	(setq type (XML-poly-get-element-name x))
	(if (not (eq type TpoI-except))
	    (TpoI-compile-error "Must be an except name class." x)
	  (if r
	      (TpoI-compile-error "Except name classes are duplicatedly specified." x)
	    (setq r
		  (TpoI-compile-choice-nameclass
		   (XML-poly-get-element-contents x))))))))
    (if r r TpoI-empty-complex-nameclass)))

(defun TpoI-compile-complex-nameclass-internal (e)
  (TpoI-start-element
   e nil
   (let ((type (XML-poly-get-element-name e)))
     (cond ((eq type TpoI-name)
	    ;; N-form
	    (TpoI-normalize-complex-nameclass
	     (TpoI-intern-element-qname e)))

	   ((eq type TpoI-anyName)
	    ;; A-S
	    (TpoI-nameclass-normalize-A-S
	     (TpoI-compile-except-nameclass
	      (XML-poly-get-element-contents e))))

	   ((eq type TpoI-nsName)
	    ;; N-S
	    (TpoI-nameclass-normalize-N-S
	     (XML-poly-get-namespace
	      TpoI-current-default-namespace)
	     (TpoI-compile-except-nameclass
	      (XML-poly-get-element-contents e))))

	   ((eq type TpoI-choice)
	    (TpoI-compile-choice-nameclass
	     (XML-poly-get-element-contents e)))

	   (t
	    (TpoI-compile-error "Invalid nameclass:%S." e type))))))

(defun TpoI-compile-choice-nameclass (c)
  (let (type r)
    (TpoI-parse-contents
     c
     (lambda (x)
       (setq r
	     (if r
		 (TpoI-nameclass-normalize-S+S
		  r (TpoI-compile-complex-nameclass-internal x))
	       (TpoI-compile-complex-nameclass-internal x)))))
    (if r r TpoI-empty-complex-nameclass)))

(defun TpoI-compile-complex-nameclass (e)
  (TpoI-simplify-nameclass
   (TpoI-compile-complex-nameclass-internal e)))

(defun TpoI-collect-nc-in-pattern (p)
  (if (null (TpoI-pattern-get-nc p))
      (let ((ps (TpoI-pattern-get-args p))
	    nc)
	(if (consp ps)
	    (progn
	      (setq nc (TpoI-normalize-complex-nameclass
			(TpoI-pattern-get-nc (car ps))))
	      (setq ps (cdr ps))
	      (while ps
		(setq nc (TpoI-nameclass-normalize-S+S
			  nc (TpoI-normalize-complex-nameclass
			      (TpoI-pattern-get-nc (car ps)))))
		(setq ps (cdr ps)))
	      (TpoI-pattern-set-nc p (TpoI-simplify-nameclass nc)))
	  (if (vectorp ps)
	      (TpoI-pattern-set-nc p (TpoI-pattern-get-nc ps)))))))

(defun TpoI-make-pattern-for-element (e func opt args)
  (let ((p (TpoI-make-pattern
	    func nil opt args
	    (XML-poly-get-element-options e) t)))
    (TpoI-pattern-set-range p (XML-poly-get-element-range e))
    p))

(defun TpoI-make-pattern-from-contents (c e func opt &optional max)
  (let* ((ps (TpoI-make-pattern-args c max))
	 (p (TpoI-make-pattern
	     func nil
	     opt ps
	     (XML-poly-get-element-options e)
	     t)))
    (TpoI-pattern-set-range p (XML-poly-get-element-range e))
    p))

(defsubst TpoI-make-child-pattern (e func opt &optional max)
  (TpoI-make-pattern-from-contents
   (XML-poly-get-element-contents e) e func opt max))

(defun TpoI-make-nameclass-pattern (func e &optional attribute-p)
  (TpoI-start-element
   e (list TpoI-attr-name)
   (let* ((as (XML-poly-get-element-attribute-list e))
	  (c (XML-poly-get-element-contents e))
	  (name-a (assq TpoI-attr-name as))
	  nc cc p)
     (if name-a
	 (setq nc
	       (TpoI-intern-qname
		(XML-poly-get-attribute-value name-a)
		name-a
		(and attribute-p
		     (null (assq TpoI-attr-ns as)))))

       (while (and (setq cc (car c))
		   (not (and (vectorp cc)
			     (eq (XML-poly-get-symbol-namespace
				  (XML-poly-get-element-name cc))
				 TpoI-relaxng-namespace))))
	 (if (memq (XML-poly-object-type cc) '(PCDATA CDATA))
	     (TpoI-compile-error "Text is not allowed here." cc)
	   (setq c (cdr c))))
       (if cc
	   (setq nc (TpoI-compile-complex-nameclass cc)
		 c (cdr c))
	 (TpoI-compile-error "Invalid element in nameclass spec." e)))
     (setq p (TpoI-make-pattern-from-contents
	      c e func nil (if attribute-p 1)))
     (TpoI-pattern-set-nc p nc)
     p)))

(defun TpoI-make-element-pattern (e)
  (let ((p (TpoI-make-nameclass-pattern
	    'TpoI-match-element e)))
    (if (null (TpoI-pattern-get-args p))
	(TpoI-compile-error
	 "`element' element must have more than one pattern in its children."
	 e))
    p))

(defun TpoI-make-attribute-pattern (e)
  (let* ((p (TpoI-make-nameclass-pattern
	     'TpoI-match-attribute e t)))
    (TpoI-pattern-set-args
     p (car (TpoI-pattern-get-args p)))
    p))

(defun TpoI-make-group-pattern (e)
  (TpoI-start-element
   e nil
   (TpoI-make-child-pattern
    e
    'TpoI-match-group
    nil)))

(defun TpoI-normalize-interleave-pattern (p)
  (let* ((ps (reverse (TpoI-pattern-get-args p)))
	 pn1 pn2 ptext)
    (while ps
      (if (and (vectorp (car ps))
	       (eq (TpoI-pattern-get-type (car ps))
		   'TpoI-match-text))
	  (setq ptext (car ps))
	(if (null pn1)
	    (setq pn1 (car ps))
	  (setq pn2 (copy-sequence p))
	  (TpoI-pattern-set-args pn2 (list (car ps) pn1))
	  (setq pn1 pn2)))
      (setq ps (cdr ps)))
    (when ptext
      (TpoI-pattern-set-args p (list ptext pn1))
      (setq pn1 p))
    pn1))

(defun TpoI-make-interleave-pattern (e)
  (TpoI-normalize-interleave-pattern
   (TpoI-start-element
    e nil
    (TpoI-make-child-pattern
     e
     'TpoI-match-interleave
     nil))))

(defun TpoI-make-choice-pattern (e)
  (TpoI-start-element
   e nil
   (TpoI-make-child-pattern
    e
    'TpoI-match-choice
    nil)))

(defun TpoI-make-optional-pattern (e)
  (TpoI-start-element
   e nil
   (let ((p (TpoI-make-child-pattern e 'TpoI-match-group nil))
	 (pe (TpoI-make-pattern-from-contents nil e 'TpoI-match-empty nil))
	 (pc (TpoI-make-pattern-from-contents nil e 'TpoI-match-choice nil)))
     (TpoI-pattern-set-args
      pc (list pe (if (= (length (TpoI-pattern-get-args p)) 1)
		      (car (TpoI-pattern-get-args p))
		    p)))
     pc)))

(defun TpoI-make-n-or-more-pattern (e n)
  (let* ((p (TpoI-start-element
	     e nil
	     (TpoI-make-child-pattern
	      e 'TpoI-match-n-or-more
	      n)))
	 (ps (TpoI-pattern-get-args p)))
    (if (= (length ps) 1)
	(TpoI-pattern-set-args p (car ps))
      (TpoI-pattern-set-args
       p (TpoI-make-pattern-for-element
	  e 'TpoI-match-group nil ps)))
    p))

(defun TpoI-make-zero-or-more-pattern (e)
  (TpoI-make-n-or-more-pattern e 0))

(defun TpoI-make-one-or-more-pattern (e)
  (TpoI-make-n-or-more-pattern e 1))

(defun TpoI-make-list-pattern (e)
  (let ((p (TpoI-start-element
	    e nil
	    (TpoI-make-child-pattern
	     e 'TpoI-match-list
	     nil))))
    (TpoI-pattern-set-nc p 'simple)
    p))

(defun TpoI-make-mixed-pattern (e)
  (let (p p1 p2)
    (TpoI-start-element
     e nil
     (setq p (TpoI-make-pattern-from-contents nil e 'TpoI-match-interleave nil)
	   p1 (TpoI-make-pattern-from-contents nil e 'TpoI-match-text nil)
	   p2 (TpoI-make-child-pattern e 'TpoI-match-group nil)))
    (TpoI-pattern-set-nc p1 'complex)
    (TpoI-pattern-set-args p (list p1 p2))
    (TpoI-normalize-interleave-pattern p)))

(defun TpoI-make-ref-pattern (e)
  (TpoI-start-element
   e (list TpoI-attr-name)
   (let ((name-a
	  (assq TpoI-attr-name
		(XML-poly-get-element-attribute-list e))))
     (if name-a
	 (TpoI-lookup-ref (TpoI-get-attribute-ncname name-a))
       (TpoI-compile-error "ref element must have a valid name attribute." e)))))

(defun TpoI-make-parent-ref-pattern (e)
  (TpoI-start-element
   e (list TpoI-attr-name)
   (let ((name-a
	  (assq TpoI-attr-name
		(XML-poly-get-element-attribute-list e))))
     (if name-a
	 (TpoI-lookup-ref (TpoI-get-attribute-ncname name-a) t)
       (TpoI-compile-error "parentRef element must have a valid name attribute." e)))))

(defun TpoI-make-empty-pattern (e)
  (TpoI-make-pattern-for-element e 'TpoI-match-empty nil nil))

(defun TpoI-make-text-pattern (e)
  (let ((p (TpoI-make-pattern-for-element e 'TpoI-match-text nil nil)))
    (TpoI-pattern-set-nc p 'complex)
    p))

(defun TpoI-make-value-pattern (e)
  (TpoI-start-element
   e (list TpoI-attr-type)
   (let ((type-a
	  (assq TpoI-attr-type
		(XML-poly-get-element-attribute-list e)))
	 type p)
     (if type-a
	 (progn
	   (setq type (TpoI-get-attribute-ncname type-a))
	   (if (= (length TpoI-current-default-datatype-library) 0)
	       (setq type
		     (cond ((string= type "string")
			    'string)
			   ((string= type "token")
			    'token)
			   (t
			    (TpoI-compile-error "Invalid type name:%s." type-a type))))))
       (setq type 'token))
     (setq p (TpoI-make-pattern-for-element
	      e 'TpoI-match-value
	      (if (symbolp type)
		  type
		(cons
		 TpoI-current-default-datatype-library
		 type))
	      (if (eq 'token type)
		  (TpoI-normalize-token-string
		   (TpoI-get-element-string e))
		(TpoI-get-element-string e))))
     (TpoI-pattern-set-nc p 'simple)
     p)))


(defun TpoI-make-data-pattern (e)
  (TpoI-start-element
   e (list TpoI-attr-type)
   (let ((type-a
	  (assq TpoI-attr-type
		(XML-poly-get-element-attribute-list e)))
	 type params except p)
     (if type-a
	 (progn
	   (setq type (TpoI-get-attribute-ncname type-a))
	   (if (= (length TpoI-current-default-datatype-library) 0)
	       (setq type
		     (cond ((string= type "string")
			    'string)
			   ((string= type "token")
			    'token)
			   (t
			    (TpoI-compile-error "Invalid type name:%s." type-a type))))))
       (setq type 'token))
     (TpoI-parse-contents
      (XML-poly-get-element-contents e)
      (lambda (data-e)
	(TpoI-start-element
	 data-e nil
	 (let ((type (XML-poly-get-element-name data-e))
	       a)
	   (cond ((eq type TpoI-param)
		  (if (symbolp type)
		      (TpoI-compile-error
		       "No parameter is allowed for the standard datatype library."
		       data-e)
		    (if except
			(TpoI-compile-error
			 "`param' must not follow the `except' pattern."
			 data-e)
		      (setq a (assq TpoI-attr-name
				    (XML-poly-get-element-attribute-list data-e)))
		      (if (null a)
			  (TpoI-compile-error
			   "`param' element must have `name' attribute."
			   data-e)
			(setq params (cons (cons (XML-poly-get-attribute-value a)
						 (TpoI-get-element-string data-e))
					   params))))))
		 ((eq type TpoI-except)
		  (if except
		      (TpoI-compile-error "Except patterns are duplicatedly specified."
					  data-e)
		    (setq except
			  (TpoI-make-child-pattern
			   data-e 'TpoI-match-choice nil)))))))))
     (setq p (TpoI-make-pattern-for-element
	      e
	      'TpoI-match-data
	      (if (symbolp type)
		  type
		(cons
		 TpoI-current-default-datatype-library
		 type))
	      (if except (cons except (nreverse params))
		(nreverse params))))
     (TpoI-pattern-set-nc p 'simple)
     p)))

(defun TpoI-make-not-allowed-pattern (e)
  (TpoI-make-pattern-for-element e 'TpoI-match-not-allowed nil nil))

(defun TpoI-make-external-ref-pattern (e)
  (let ((TpoI-current-importing-filenames
	 TpoI-current-importing-filenames)
	(href-a (assq TpoI-attr-href
		      (XML-poly-get-element-attribute-list e)))
	ee)
      (if (null href-a)
	  (TpoI-compile-error "`externalRef' must have `href' attribute" e)
	(setq ee (XML-poly-get-element
		  (TpoI-import-external-object
		   (XML-poly-get-attribute-value href-a)
		   e)))
	(TpoI-make-pattern-args (list ee) 1))))

(defun TpoI-make-pattern-args (c max)
  (let (patterns r)
    (TpoI-parse-contents
     c
     (lambda (x)
       (if max
	   (if (< max 1)
	       (TpoI-compile-error "Too many patterns." x)
	     (setq max (1- max))))
       (let* ((ename (XML-poly-get-element-name x))
	      (func (get ename 'TpoI-pattern)))
	 (if (null func)
	     (TpoI-compile-error "Wrong RELAX NG element." x)
	   (setq r (funcall func x))
	   (if (and (consp r)
		    (not (stringp (car r))))
	       (setq patterns
		     (append r patterns))
	     (setq patterns (cons r patterns)))))))
    (nreverse patterns)))

;;
;; grammar
;;

(defun TpoI-get-combination-mode (e)
  (let ((combine (assq TpoI-attr-combine
		       (XML-poly-get-element-attribute-list e))))
    (when combine
      (setq combine (TpoI-get-attribute-ncname combine))
      (cond ((string= "choice" combine)
	     'choice)
	    ((string= "interleave" combine)
	     'interleave)
	    (t
	     (TpoI-compile-error
	      "combine method must be choice or interleave"
	      e combine))))))

(defun TpoI-make-start-section (e)
  (TpoI-start-element
   e (list TpoI-attr-combine)
   (TpoI-define
    e 'start
    (TpoI-get-combination-mode e)
    (TpoI-make-pattern-args
     (XML-poly-get-element-contents e)
     1))))

;; def := (name combination defs)
(defun TpoI-fix-defined-grammar (def)
  (let ((c (nth 1 def))
	(d (nthcdr 2 def)))
    (if (= (length d) 1)
	(progn
	  (setq d (car d))
	  (if (= (length d) 2)
	      (car (cdr d))
	    (TpoI-make-pattern 'TpoI-match-group nil nil (cdr d))))
      (setq d (mapcar
	       (lambda (x)
		 (if (= (length x) 2)
		     (car (cdr x))
		   (TpoI-make-pattern 'TpoI-match-group nil nil (cdr x))))
	       d))
      (if (eq (car c) 'choice)
	  (TpoI-make-pattern 'TpoI-match-choice nil nil d)
	(TpoI-normalize-interleave-pattern
	 (TpoI-make-pattern 'TpoI-match-interleave nil nil d))))))

(defun TpoI-make-define-section (e)
  (TpoI-start-element
   e (list TpoI-attr-name TpoI-attr-combine)
   (let ((a-name
	  (assq TpoI-attr-name
		(XML-poly-get-element-attribute-list e))))
     (if a-name
	 (TpoI-define
	  e (TpoI-get-attribute-ncname a-name)
	  (TpoI-get-combination-mode e)
	  (TpoI-make-pattern-args
	   (XML-poly-get-element-contents e)
	   nil))
       (TpoI-compile-error
	"define element must have name attribute." e)))))

(defun TpoI-remove-all-matched-define-elements (name e)
  (let ((c (XML-poly-get-element-contents e))
	ec r matched a)
    (while c
      (setq ec (car c)
	    c (cdr c))
      (cond ((not (vectorp ec))
	     (setq r (cons ec r)))
	    ((eq (XML-poly-get-element-name ec) TpoI-define)
	     (setq a (assq TpoI-attr-name (XML-poly-get-element-attribute-list ec)))
	     (if (and a
		      (string= name (TpoI-get-attribute-ncname a)))
		 (setq matched t)
	       (setq r (cons ec r))))
	    ((eq (XML-poly-get-element-name ec) TpoI-div)
	     (setq matched
		   (or (TpoI-remove-all-matched-define-elements name ec)
		       matched)))
	    (t
	     (setq r (cons ec r)))))
    (XML-poly-set-element-contents e (nreverse r))
    matched))

(defun TpoI-remove-all-start-elements (e)
  (let ((c (XML-poly-get-element-contents e))
	ec r matched)
    (while c
      (setq ec (car c)
	    c (cdr c))
      (cond ((not (vectorp ec))
	     (setq r (cons ec r)))
	    ((eq (XML-poly-get-element-name ec) TpoI-start)
	     (setq matched t))
	    ((eq (XML-poly-get-element-name ec) TpoI-div)
	     (setq matched
		   (or (TpoI-remove-all-start-elements ec)
		       matched)))
	    (t
	     (setq r (cons ec r)))))
    (XML-poly-set-element-contents e (nreverse r))
    matched))

(defun TpoI-replace-include-element (ie e)
  (let ((ic (XML-poly-get-element-contents ie))
	eic a)
    (while ic
      (setq eic (car ic)
	    ic (cdr ic))
      (cond ((not (vectorp eic)))
	    ((eq (XML-poly-get-element-name eic) TpoI-start)
	     (if (not (TpoI-remove-all-start-elements e))
		 (TpoI-compile-error
		  "No start element exists in the included document despite being redefined in the include element."
		  eic)))
	    ((eq (XML-poly-get-element-name eic) TpoI-define)
	     (setq a (assq TpoI-attr-name (XML-poly-get-element-attribute-list eic)))
	     (if (null a)
		 (TpoI-compile-error "define element must have `name' attribute" a)
	       (if (not (TpoI-remove-all-matched-define-elements
			 (TpoI-get-attribute-ncname a) e))
		   (TpoI-compile-error
		  "No defin element with the same name exists in the included document despite being redefined in the include element."
		  eic))))
	    ((eq (XML-poly-get-element-name eic) TpoI-div)
	     (TpoI-replace-include-element eic e))
	    (t
	     (TpoI-compile-error "Invalid element in `include' element." eic))))
    (XML-poly-set-element-contents
     e
     (append
      (XML-poly-get-element-contents ie)
      (XML-poly-get-element-contents e)))
    e))

(defun TpoI-make-include-section (ie)
  (let ((TpoI-current-importing-filenames
	 TpoI-current-importing-filenames)
	(href-a (assq TpoI-attr-href
		      (XML-poly-get-element-attribute-list ie)))
	e)
      (if (null href-a)
	  (TpoI-compile-error "`include' must have `href' attribute" ie)
	(setq e (XML-poly-get-element
		 (TpoI-import-external-object
		  (XML-poly-get-attribute-value href-a)
		  ie)))
	(if (not (eq (XML-poly-get-element-name e)
		     TpoI-grammar))
	    (TpoI-compile-error "included element must be `grammar'." ie)
	  (TpoI-make-divided-section
	   (TpoI-replace-include-element ie e)
	   (list TpoI-attr-href))))))

(defun TpoI-make-divided-section (e &optional attrs)
  (let ((c (XML-poly-get-element-contents e))
	type x sym func)
    (TpoI-start-element
     e attrs
     (while c
       (setq x (car c)
	     c (cdr c))
       (setq type (XML-poly-object-type x))

       (cond ((memq type '(PCDATA CDATA))
	      (TpoI-compile-error "text is not allowed here:%S." e x))
	     ((eq type 'ELEMENT)
	      (setq sym (XML-poly-get-element-name x)
		    func (get sym 'TpoI-grammar))
	      (cond ((eq sym TpoI-define)
		     (TpoI-make-define-section x))
		    ((eq sym TpoI-start)
		     (TpoI-make-start-section x))
		    ((eq sym TpoI-include)
		     (TpoI-make-include-section x))
		    ((eq sym TpoI-div)
		     (TpoI-make-divided-section x))
		    ((eq (XML-poly-get-symbol-namespace sym) TpoI-relaxng-namespace)
		     (TpoI-compile-error "Wrong element in grammar context." x)))))))))

(defun TpoI-make-grammar-section (e)
  (let ((TpoI-parent-definition-alist
	 TpoI-current-definition-alist)
	r)
    (let ((TpoI-current-definition-alist nil))
      (TpoI-make-divided-section e)
      (setq r (TpoI-fix-defined-grammar (TpoI-lookup-ref 'start))))
    (setq TpoI-current-definition-alist TpoI-parent-definition-alist)
    r))

;;
;; post-process
;;

(defvar TpoI-ref-in-element nil)
(defvar TpoI-expanding-refs nil)

(defsubst TpoI-pattern-expanded-p (p)
  (memq (TpoI-pattern-get-flag p) '(setup fixated expanded)))

(defsubst TpoI-mark-pattern-expanded (p)
  (or (TpoI-pattern-expanded-p p)
      (TpoI-pattern-set-flag p 'expanded)))

(defsubst TpoI-pattern-fixated-p (p)
  (memq (TpoI-pattern-get-flag p) '(setup fixated)))

(defsubst TpoI-mark-pattern-fixated (p)
  (TpoI-pattern-set-flag p 'fixated))

(defsubst TpoI-pattern-setup-p (p)
  (eq (TpoI-pattern-get-flag p) 'setup))

(defsubst TpoI-mark-pattern-setup (p)
  (TpoI-pattern-set-flag p 'setup))

(defsubst TpoI-expand-refs-internal (slot)
  (mapcar
   (lambda (x)
     (if (and (listp x)
	      (stringp (car x)))
	 (TpoI-expand-refs x)
       x))
   slot))

(defun TpoI-expand-refs (slot)
  (let (def d1 r)
    (if (null (cdr slot))
	(TpoI-compile-error "`%s' is referenced but not defined." nil name)
      (setq def (nthcdr 2 slot))
      (if (eq (nth 1 slot) 'expanded)
	  def

	(if (and (memq slot TpoI-expanding-refs)
		 (not TpoI-ref-in-element))
	    (TpoI-compile-error
	     "Invalid recursive definition:%S." nil TpoI-expanding-refs)
	  (setq TpoI-expanding-refs (cons slot TpoI-expanding-refs))

	  (setq d1 def)
	  (while d1
	    (setq r (cons (TpoI-expand-refs-internal (car d1)) r)
		  d1 (cdr d1)))
	  (setq def (nreverse r))
	  (setcdr (cdr slot) def)
	  (setq def (TpoI-fix-defined-grammar slot))
	  (setcar (cdr slot) 'expanded)
	  (setcdr (cdr slot) def)
	  def)))))

(defun TpoI-expand-pattern (p)
  (let* ((def (TpoI-pattern-get-args p))
	 d1 item)
    (cond ((not (consp def)) p)
	  ((stringp (car def))
	   (TpoI-pattern-set-args p (TpoI-expand-refs def))
	   (TpoI-mark-pattern-expanded p)
	   p)
	  (t
	   (setq d1 def)
	   (while d1
	     (setq item (car d1))
	     (if (and (listp item)
		      (stringp (car item)))
		 (setcar d1 (TpoI-expand-refs item)))
	     (setq d1 (cdr d1)))
	   (TpoI-pattern-set-args p def)
	   (TpoI-mark-pattern-expanded p)
	   p))))

(defun TpoI-fixate-pattern (p)
  ;; first expand ref.
  (if (TpoI-pattern-fixated-p p)
      p
    (setq p
	  (if (TpoI-pattern-expanded-p p)
	      p
	    (TpoI-expand-pattern p)))

    ;; fixate args.
    (let ((TpoI-ref-in-element
	   (or TpoI-ref-in-element
	       (eq (TpoI-pattern-get-type p)
		   'TpoI-match-element)))
	  (args (TpoI-pattern-get-args p))
	  arg)
      (TpoI-mark-pattern-fixated p)
      (cond ((vectorp args)
	     (TpoI-fixate-pattern args)
	     p)
	    ((not (consp args)) p)
	    (t
	     (while args
	       (setq arg (car args)
		     args (cdr args))
	       (TpoI-fixate-pattern arg))
	     p)))))

(defun TpoI-setup-pattern (p)
  (let ((ps (TpoI-pattern-get-args p)))
    (cond ((consp ps)
	   (while ps
	     (when (and (vectorp (car ps))
			(not (TpoI-pattern-setup-p (car ps))))
	       (TpoI-mark-pattern-setup (car ps))
	       (TpoI-setup-pattern (car ps)))
	     (setq ps (cdr ps))))
	  ((vectorp ps)
	   (TpoI-mark-pattern-setup ps)
	   (TpoI-setup-pattern ps)))
    (TpoI-collect-nc-in-pattern p)
    ;; should be added for post-process.
    ))

(defun TpoI-expand-start (def)
  (let ((TpoI-expanding-refs nil))
    (if (consp def)
	(if (stringp (car def))
	    (progn
	      (setq def (TpoI-expand-refs def))
	      (if (memq (TpoI-pattern-get-type def)
			'(TpoI-match-group TpoI-match-attribute
			  TpoI-match-text TpoI-match-list
			  TpoI-match-empty TpoI-match-data
			  TpoI-match-value))
		  (TpoI-compile-error
		   "Top level `start' grammar begins with an invalid pattern."
		   def)))
	  (TpoI-compile-error
	   "Invalid pattern (internal error)" def)))
    (TpoI-fixate-pattern def)
    (TpoI-setup-pattern def)
    def))

;;;
;;; entry
;;;

(defun TpoI-compile-schema-for-element (e)
  (TpoI-expand-start
   (car
    (TpoI-make-pattern-args
     (list e)
     1))))

(defsubst TpoI-compile-schema (obj)
  (TpoI-compile-schema-for-element
   (XML-poly-get-element obj)))

(defun TpoI-compile-schema-file (filename)
   (TpoI-compile-schema
    (cdr
     (XML-poly-parse-file filename t))))

(defun TpoI-validate-for-element (schema e)
  (let ((TpoI-error-stack nil)
	r)
    (setq r (TpoI-match-pattern
	     schema
	     (TpoI-make-context
	      nil (list e))))
    (cons r TpoI-error-stack)))

(defsubst TpoI-validate (schema obj)
  (TpoI-validate-for-element
   schema (XML-poly-get-element obj)))

;;;
;;; Epilogue.
;;;

(provide 'TpoI)

;; TpoI.el ends here.