1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
12 ;;; * Redistributions in binary form must reproduce the above
13 ;;; copyright notice, this list of conditions and the following
14 ;;; disclaimer in the documentation and/or other materials
15 ;;; provided with the distribution.
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 (in-package :cxml-rng
)
32 (declaim (optimize (debug 2)))
37 (define-condition rng-error
(simple-error)
38 ((line-number :initarg
:line-number
:accessor rng-error-line-number
)
39 (column-number :initarg
:column-number
:accessor rng-error-column-number
)
40 (system-id :initarg
:system-id
:accessor rng-error-system-id
))
42 "The class of all validation errors.
43 @see-slot{rng-error-line-number}
44 @see-slot{rng-error-column-number}
45 @see-slot{rng-error-system-id}"))
47 (setf (documentation 'rng-error-line-number
'function
)
48 "@arg[instance]{an instance of @class{rng-error}}
49 @return{an integer, or nil}
50 Return the line number reported by the parser when the Relax NG error
51 was detected, or NIL if not available.")
53 (setf (documentation 'rng-error-column-number
'function
)
54 "@arg[instance]{an instance of @class{rng-error}}
55 @return{an integer, or nil}
56 Return the column number reported by the parser when the Relax NG error
57 was detected, or NIL if not available.")
59 (setf (documentation 'rng-error-system-id
'function
)
60 "@arg[instance]{an instance of @class{rng-error}}
61 @return{a puri:uri, or nil}
62 Return the System ID of the document being parsed when the Relax NG
63 error was detected, or NIL if not available.")
65 (defun rng-error (source fmt
&rest args
)
67 (let ((s (make-string-output-stream)))
68 (apply #'format s fmt args
)
69 (multiple-value-bind (line-number column-number system-id
)
73 (values (klacks:current-line-number source
)
74 (klacks:current-column-number source
)
75 (klacks:current-system-id source
)))
77 (values (sax:line-number source
)
78 (sax:column-number source
)
79 (sax:system-id source
))))
80 (when (or line-number column-number system-id
)
81 (format s
"~& [ Error at line ~D, column ~D in ~S ]"
87 :format-arguments
(list (get-output-stream-string s
))
88 :line-number line-number
89 :column-number column-number
90 :system-id system-id
))))
95 (defvar *datatype-library
*)
96 (defvar *namespace-uri
*)
98 (defvar *entity-resolver
*)
99 (defvar *external-href-stack
*)
100 (defvar *include-uri-stack
*)
101 (defvar *include-body-p
* nil
)
107 (:constructor make-schema
(start definitions
)))
108 "An instance of this class represents a Relax NG grammar that has
109 been parsed and simplified.
110 @see-slot{schema-start}
111 @see-constructor{parse-schema}
113 @see{serialize-schema} "
114 (start (missing) :type pattern
)
115 (definitions (missing) :type list
)
116 (interned-start nil
:type
(or null pattern
))
117 (registratur nil
:type
(or null hash-table
)))
119 (setf (documentation 'schema-start
'function
)
120 "@arg[instance]{an instance of @class{schema}}
121 @return{the start pattern, an instance of @class{pattern}}
122 Reader function for the grammar's start pattern, from which all
123 of the grammar's patters are reachable.")
125 (defmethod print-object ((object schema
) stream
)
126 (print-unreadable-object (object stream
:type t
:identity t
)))
128 (defun invoke-with-klacks-handler (fn source
)
133 (cxml:xml-parse-error
(c)
134 (rng-error source
"Cannot parse schema: ~A" c
)))))
136 (defvar *validate-grammar
* t
)
137 (defparameter *relax-ng-grammar
* nil
)
138 (defun flush () (setf *relax-ng-grammar
* nil
))
140 (defun make-validating-source (input)
141 (let ((upstream (cxml:make-source input
)))
142 (if *validate-grammar
*
143 (klacks:make-tapping-source upstream
144 (make-validator *relax-ng-grammar
*))
147 (defun parse-schema (input &key entity-resolver
)
148 "@arg[input]{a string, pathname, stream, or xstream}
149 @arg[entity-resolver]{a function of two arguments, or NIL}
150 @return{a parsed @class{schema}}
151 @short{This function parses a Relax NG schema file in XML syntax}
152 and returns a parsed representation of that schema.
154 @code{input} can be any stream designator as understood by
155 @code{cxml:make-source}.
157 Note that namestrings are not valid arguments,
158 because they would be interpreted as XML source code. Use pathnames
161 @code{entity-resolver} can be passed as a function of two arguments.
162 It is invoked for every entity referenced by the
163 document with the entity's Public ID (a rod) and System ID (an
164 URI object) as arguments. The function may either return
165 nil, CXML will then try to resolve the entity as usual.
166 Alternatively it may return a Common Lisp stream specialized on
167 @code{(unsigned-byte 8)} which will be used instead.
170 @see{make-validator}"
171 (when *validate-grammar
*
172 (unless *relax-ng-grammar
*
173 (setf *relax-ng-grammar
*
174 (let* ((*validate-grammar
* nil
)
175 (d (slot-value (asdf:find-system
:cxml-rng
)
176 'asdf
::relative-pathname
)))
177 (parse-schema (merge-pathnames "rng.rng" d
))
179 (parse-compact (merge-pathnames "rng.rnc" d
))))))
180 (klacks:with-open-source
(source (make-validating-source input
))
181 (invoke-with-klacks-handler
183 (klacks:find-event source
:start-element
)
184 (let* ((*datatype-library
* "")
186 (*entity-resolver
* entity-resolver
)
187 (*external-href-stack
* '())
188 (*include-uri-stack
* '())
189 (*grammar
* (make-grammar nil
))
190 (start (p/pattern source
)))
192 (rng-error nil
"empty grammar"))
193 (setf (grammar-start *grammar
*)
194 (make-definition :name
:start
:child start
))
195 (check-pattern-definitions source
*grammar
*)
196 (check-recursion start
0)
197 (multiple-value-bind (new-start defns
)
198 (finalize-definitions start
)
199 (setf start
(fold-not-allowed new-start
))
201 (setf (defn-child defn
) (fold-not-allowed (defn-child defn
))))
202 (setf start
(fold-empty start
))
204 (setf (defn-child defn
) (fold-empty (defn-child defn
)))))
205 (multiple-value-bind (new-start defns
)
206 (finalize-definitions start
)
207 (check-start-restrictions new-start
)
209 (check-restrictions (defn-child defn
)))
210 (make-schema new-start defns
))))
214 ;;;; pattern structures
217 "@short{The superclass of all patterns.}
218 Instances of this class represent elements in the \"simplified syntax\"
221 Patterns are documented for introspective purposes and are not meant to
222 be modified by user code.
224 The start pattern of a schema is available through @fun{schema-start}.
227 (nullable :uninitialized
))
229 (defmethod print-object :around
((object pattern
) stream
)
231 (let ((*print-circle
* t
))
233 (print-unreadable-object (object stream
:type t
:identity t
))))
235 (defstruct (%parent
(:include pattern
) (:conc-name
"PATTERN-"))
238 (defstruct (%named-pattern
(:include %parent
) (:conc-name
"PATTERN-"))
241 (setf (documentation 'pattern-name
'function
)
242 "@arg[instance]{an instance of @class{pattern}}
243 @return{a @class{name-class}}
244 @short{Returns the @code{pattern}'s name class.}
246 This slot describes the name allowed for the current element or
252 (setf (documentation 'pattern-child
'function
)
253 "@arg[instance]{an instance of @class{pattern}}
254 @return{an instance of @class{pattern}}
255 @short{Returns the pattern's sub-pattern.}
257 (Elements in the full Relax NG syntax allow more than one child
258 pattern, but simplification normalizes the representation so that
259 any such element has exactly one child.)
267 (defstruct (element (:include %named-pattern
))
268 "@short{This pattern specifies that an element of a certain name class
271 Its child pattern describes the attributes and child nodes
273 @see-slot{pattern-name}
274 @see-slot{pattern-child}")
276 (defstruct (attribute (:include %named-pattern
))
277 "@short{This pattern specifies that an attribute of a certain name class
280 Its child pattern describes the type of the attribute's
282 @see-slot{pattern-name}
283 @see-slot{pattern-child}")
285 (defstruct (%combination
(:include pattern
) (:conc-name
"PATTERN-"))
288 (setf (documentation 'pattern-a
'function
)
289 "@arg[instance]{an instance of @class{pattern}}
290 @return{an instance of @class{pattern}}
291 @short{Returns the first of two sub-patterns the pattern instance has.}
293 (Elements in the full Relax NG syntax allow more than two child
294 patterns, but simplification normalizes the representation so that
295 any such element has exactly two children.)
302 (setf (documentation 'pattern-b
'function
)
303 "@arg[instance]{an instance of @class{pattern}}
304 @return{an instance of @class{pattern}}
305 @short{Returns the second of two sub-patterns the pattern instance has.}
307 (Elements in the full Relax NG syntax allow more than two child
308 patterns, but simplification normalizes the representation so that
309 any such element has exactly two children.)
317 (:include %combination
)
318 (:constructor make-group
(a b
)))
319 "@short{This pattern specifies that two subpatterns are
320 required at the current position in a specific order.}
323 @see-slot{pattern-b}")
324 (defstruct (interleave
325 (:include %combination
)
326 (:constructor make-interleave
(a b
)))
327 "@short{This pattern specifies that two possible subpatterns are
328 allowed to occur in any order at the current position.}
331 @see-slot{pattern-b}")
333 (:include %combination
)
334 (:constructor make-choice
(a b
)))
335 "@short{This pattern specifies that one of two possible subpatterns are
336 allowed at the current position, given as its children.}
339 @see-slot{pattern-b}")
341 (:include %combination
)
342 (:constructor make-after
(a b
))))
344 (defstruct (one-or-more
346 (:constructor make-one-or-more
(child)))
347 "@short{This pattern specifies that its subpattern is
348 allowed to occur at the current position one or more times.}
350 @see-slot{pattern-child}")
351 (defstruct (list-pattern
353 (:constructor make-list-pattern
(child)))
354 "@short{This pattern specifies that a subpatterns is allowed multiple
355 times a the current position, with whitespace as a separator.}
357 @see-slot{pattern-child}")
361 (:conc-name
"PATTERN-")
362 (:constructor make-ref
(target)))
363 "@short{This pattern references another part of the pattern graph.}
365 @code{ref} is the only pattern to introduce shared structure and
366 circularity into the pattern graph, by referring to elements defined
369 (@code{ref} patterns in the full Relax NG syntax can be used to refer
370 to any pattern definition in the grammar. Simplification normalizes
371 the schema so that ref patterns only refer to definitions which have
372 an @code{element} as their child.)
374 @see-slot{pattern-element}"
378 (defun pattern-element (ref)
379 "@arg[ref]{an instance of @class{ref}}
380 @return{an instance of @class{element}}
381 @short{Returns the ref pattern's target.}
383 @code{ref} is the only pattern to introduce shared structure and
384 circularity into the pattern graph, by referring to elements defined
387 (@code{ref} patterns in the full Relax NG syntax can be used to refer
388 to any pattern definition in the grammar. Simplification normalizes
389 the schema so that ref patterns only refer to definitions which have
390 an @code{element} as their child.)"
391 (defn-child (pattern-target ref
)))
393 (defstruct (%leaf
(:include pattern
)))
395 (defstruct (empty (:include %leaf
))
396 "@short{This pattern specifies that nothing more is expected at the current
399 (defstruct (text (:include %leaf
))
400 "@short{This pattern specifies that text is expected here.}")
402 (defstruct (%typed-pattern
(:include %leaf
) (:conc-name
"PATTERN-"))
405 (setf (documentation 'pattern-type
'function
)
406 "@arg[instance]{an instance of @class{pattern}}
407 @return{a @class{cxml-types:data-type}}
408 @short{Returns the data type expected at this position.}
410 This type has already been parsed into an object. Its name and
411 the URI of its library can be queried from that object.
415 @see{cxml-types:type-name}
416 @see{cxml-types:type-library}")
418 (defstruct (value (:include %typed-pattern
) (:conc-name
"PATTERN-"))
419 "@short{This pattern specifies that a specific value is expected as text
422 The value expected is @code{pattern-value}, parsed from
423 @code{pattern-string} using @code{pattern-type}.
425 @see-slot{pattern-type}
426 @see-slot{pattern-value}
427 @see-slot{pattern-string}"
432 (setf (documentation 'pattern-string
'function
)
433 "@arg[instance]{an instance of @class{value}}
435 @short{Returns the string expected at this position.}
437 This string is the lexical representation expected, not parsed into
438 a value object yet. The parsed object is available as
443 (setf (documentation 'pattern-value
'function
)
444 "@arg[instance]{an instance of @class{value}}
445 @return{an object as returned by @fun{cxml-types:parse}}
446 @short{Returns the value expected at this position.}
448 This object is the result of parsing @fun{pattern-string} using
449 @fun{pattern-type}.")
451 (defstruct (data (:include %typed-pattern
) (:conc-name
"PATTERN-"))
452 "@short{This pattern specifies that text of a specific data type is
455 The data type instance stored in the @code{pattern-type} slot takes into
456 account additional paramaters, which can be retrieved using
457 @code{pattern-params} in their original form.
459 @see-slot{pattern-type}
460 @see-slot{pattern-params}
461 @see-slot{pattern-except}"
465 (setf (documentation 'pattern-except
'function
)
466 "@arg[instance]{an instance of @class{data}}
467 @return{a @class{pattern}, or @code{nil}}
468 @short{Returns the @code{data} instance's @code{except} pattern.}
470 In addition to a data type, @code{data} can specify that certain
471 values are @em{not} permitted. They are described using a pattern.
473 If this slot is @code{nil}, no exception is defined.")
475 (setf (documentation 'pattern-params
'function
)
476 "@arg[instance]{an instance of @class{data}}
477 @return{a list of @fun{cxml-types:param}}
478 @short{The data type parameters for this data pattern.}
480 (With the XSD type library, these are known as restricting facets.)")
482 (defstruct (not-allowed (:include %leaf
))
483 "@short{This pattern specifies that the part of the schema reached at
484 this point is not valid.}")
489 (defstruct (grammar (:constructor make-grammar
(parent)))
492 (definitions (make-hash-table :test
'equal
)))
494 ;; Clark calls this structure "RefPattern"
495 (defstruct (definition (:conc-name
"DEFN-"))
506 (error "missing arg"))
508 (defstruct name-class
509 "@short{The abstract superclass of all name-related classes.}
511 Name classes represent sets of permissible names for an element or
514 Names are pairs of namespace URI and local-name.
519 (defstruct (any-name (:include name-class
)
520 (:constructor make-any-name
(except)))
521 "@short{This name class allows any name.}
523 Exceptions are given as @code{any-name-except}.
525 @see-slot{any-name-except}"
526 (except (missing) :type
(or null name-class
)))
528 (setf (documentation 'any-name-except
'function
)
529 "@arg[instance]{an instance of @class{any-name}}
530 @return{a @class{name-class} or @code{nil}}
532 Return the name class @em{not} allowed by this @code{any-name},
533 or @code{nil} if there is no such exception.")
535 (defstruct (name (:include name-class
)
536 (:constructor make-name
(uri lname
)))
537 "@short{This name class allows only a specific name.}
539 A specific namespace URI and local name are expected.
542 @see-slot{name-lname}"
543 (uri (missing) :type string
)
544 (lname (missing) :type string
))
546 (setf (documentation 'name-uri
'function
)
547 "@arg[instance]{an instance of @class{name}}
549 Return the expected namespace URI.")
551 (setf (documentation 'name-lname
'function
)
552 "@arg[instance]{an instance of @class{name}}
554 Return the expected local name.")
556 (defstruct (ns-name (:include name-class
)
557 (:constructor make-ns-name
(uri except
)))
558 "@short{This name class allows all names in a specific namespace}, with
561 A specific namespace URI is expected.
563 Exceptions are given as @code{ns-name-except}.
565 @see-slot{ns-name-uri}
566 @see-slot{ns-name-except}"
567 (uri (missing) :type string
)
568 (except (missing) :type
(or null name-class
)))
570 (setf (documentation 'ns-name-uri
'function
)
571 "@arg[instance]{an instance of @class{ns-name}}
573 Return the expected namespace URI.")
575 (setf (documentation 'ns-name-except
'function
)
576 "@arg[instance]{an instance of @class{ns-name}}
577 @return{a @class{name-class} or @code{nil}}
579 Return the name class @em{not} allowed by this @code{ns-name},
580 or @code{nil} if there is no such exception.")
582 (defstruct (name-class-choice (:include name-class
)
583 (:constructor make-name-class-choice
(a b
)))
584 "@short{This name class represents the union of two other name classes.}
586 @see-slot{name-class-choice-a}
587 @see-slot{name-class-choice-b}"
588 (a (missing) :type name-class
)
589 (b (missing) :type name-class
))
591 (setf (documentation 'name-class-choice-a
'function
)
592 "@arg[instance]{an instance of @class{name-class-choice}}
593 @return{a @class{name-class}}
594 Returns the 'first' of two name classes that are allowed.
595 @see{name-class-choice-b}")
597 (setf (documentation 'name-class-choice-b
'function
)
598 "@arg[instance]{an instance of @class{name-class-choice}}
599 @return{a @class{name-class}}
600 Returns the 'second' of two name classes that are allowed.
601 @see{name-class-choice-a}")
603 (defun simplify-nc-choice (values)
604 (zip #'make-name-class-choice values
))
609 (defvar *rng-namespace
* "http://relaxng.org/ns/structure/1.0")
611 (defun skip-foreign* (source)
613 (case (klacks:peek-next source
)
614 (:start-element
(skip-foreign source
))
615 (:end-element
(return)))))
617 (defun skip-to-native (source)
619 (case (klacks:peek source
)
621 (when (equal (klacks:current-uri source
) *rng-namespace
*)
623 (klacks:serialize-element source nil
))
624 (:end-element
(return)))
625 (klacks:consume source
)))
627 (defun consume-and-skip-to-native (source)
628 (klacks:consume source
)
629 (skip-to-native source
))
631 (defun skip-foreign (source)
632 (when (equal (klacks:current-uri source
) *rng-namespace
*)
634 "invalid schema: ~A not allowed here"
635 (klacks:current-lname source
)))
636 (klacks:serialize-element source nil
))
638 (defun attribute (lname attrs
)
640 (let ((a (sax:find-attribute-ns
"" lname attrs
)))
642 (sax:attribute-value a
)
645 (defparameter *whitespace
*
646 (format nil
"~C~C~C~C"
652 (defun ntc (lname source-or-attrs
)
653 ;; used for (n)ame, (t)ype, and (c)ombine, this also strings whitespace
655 (if (listp source-or-attrs
)
657 (klacks:list-attributes source-or-attrs
)))
658 (a (sax:find-attribute-ns
"" lname attrs
)))
660 (string-trim *whitespace
* (sax:attribute-value a
))
663 (defmacro with-library-and-ns
(attrs &body body
)
664 `(invoke-with-library-and-ns (lambda () ,@body
) ,attrs
))
666 (defun invoke-with-library-and-ns (fn attrs
)
667 (let* ((dl (attribute "datatypeLibrary" attrs
))
668 (ns (attribute "ns" attrs
))
669 (*datatype-library
* (if dl
(escape-uri dl
) *datatype-library
*))
670 (*namespace-uri
* (or ns
*namespace-uri
*))
672 ;; FIXME: Ganz boese gehackt -- gerade so, dass wir die Relax NG
673 ;; Test-Suite bestehen.
675 (not (zerop (length *datatype-library
*)))
676 ;; scheme pruefen, und es muss was folgen
677 (or (not (cl-ppcre:all-matches
678 "^[a-zA-Z][a-zA-Z0-9+.-]*:.+"
680 ;; keine kaputten %te, keine #
681 (cl-ppcre:all-matches
682 "(%$|%.$|%[^0-9A-Fa-f][^0-9A-Fa-f]|#)"
683 *datatype-library
*)))
684 (rng-error nil
"malformed datatypeLibrary: ~A" *datatype-library
*))
687 (defun p/pattern
(source)
688 (let* ((lname (klacks:current-lname source
))
689 (attrs (klacks:list-attributes source
)))
690 (with-library-and-ns attrs
691 (case (find-symbol lname
:keyword
)
692 (:|element|
(p/element source
(ntc "name" attrs
)))
693 (:|attribute|
(p/attribute source
(ntc "name" attrs
)))
694 (:|group|
(p/combination
#'groupify source
))
695 (:|interleave|
(p/combination
#'interleave-ify source
))
696 (:|choice|
(p/combination
#'choice-ify source
))
697 (:|optional|
(p/optional source
))
698 (:|zeroOrMore|
(p/zero-or-more source
))
699 (:|oneOrMore|
(p/one-or-more source
))
700 (:|list|
(p/list source
))
701 (:|mixed|
(p/mixed source
))
702 (:|ref|
(p/ref source
))
703 (:|parentRef|
(p/parent-ref source
))
704 (:|empty|
(p/empty source
))
705 (:|text|
(p/text source
))
706 (:|value|
(p/value source
))
707 (:|data|
(p/data source
))
708 (:|notAllowed|
(p/not-allowed source
))
709 (:|externalRef|
(p/external-ref source
))
710 (:|grammar|
(p/grammar source
))
711 (t (skip-foreign source
))))))
713 (defun p/pattern
+ (source)
714 (let ((children nil
))
716 (case (klacks:peek source
)
718 (let ((p (p/pattern source
))) (when p
(push p children
))))
722 (klacks:consume source
))))
724 (rng-error source
"empty element"))
725 (nreverse children
)))
727 (defun p/pattern?
(source)
730 (skip-to-native source
)
731 (case (klacks:peek source
)
734 (rng-error source
"at most one pattern expected here"))
735 (setf result
(p/pattern source
)))
739 (klacks:consume source
))))
742 (defun p/element
(source name
)
743 (klacks:expecting-element
(source "element")
744 (let ((elt (make-element)))
745 (consume-and-skip-to-native source
)
747 (setf (pattern-name elt
) (destructure-name source name
))
748 (setf (pattern-name elt
) (p/name-class source
)))
749 (skip-to-native source
)
750 (setf (pattern-child elt
) (groupify (p/pattern
+ source
)))
751 (make-ref (make-definition :name
(gensym "ANONYMOUS") :child elt
)))))
753 (defvar *attribute-namespace-p
* nil
)
755 (defun p/attribute
(source name
)
756 (klacks:expecting-element
(source "attribute")
757 (let ((result (make-attribute)))
758 (consume-and-skip-to-native source
)
760 (setf (pattern-name result
)
761 (let ((*namespace-uri
* (or *ns
* ""))
762 (*attribute-namespace-p
* t
))
763 (destructure-name source name
)))
764 (setf (pattern-name result
)
765 (let ((*attribute-namespace-p
* t
))
766 (p/name-class source
))))
767 (skip-to-native source
)
768 (setf (pattern-child result
)
769 (or (p/pattern? source
) (make-text)))
772 (defun p/combination
(zipper source
)
773 (klacks:expecting-element
(source)
774 (consume-and-skip-to-native source
)
775 (funcall zipper
(p/pattern
+ source
))))
777 (defun p/one-or-more
(source)
778 (klacks:expecting-element
(source "oneOrMore")
779 (consume-and-skip-to-native source
)
780 (let ((children (p/pattern
+ source
)))
781 (make-one-or-more (groupify children
)))))
783 (defun p/zero-or-more
(source)
784 (klacks:expecting-element
(source "zeroOrMore")
785 (consume-and-skip-to-native source
)
786 (let ((children (p/pattern
+ source
)))
787 (make-choice (make-one-or-more (groupify children
))
790 (defun p/optional
(source)
791 (klacks:expecting-element
(source "optional")
792 (consume-and-skip-to-native source
)
793 (let ((children (p/pattern
+ source
)))
794 (make-choice (groupify children
) (make-empty)))))
796 (defun p/list
(source)
797 (klacks:expecting-element
(source "list")
798 (consume-and-skip-to-native source
)
799 (let ((children (p/pattern
+ source
)))
800 (make-list-pattern (groupify children
)))))
802 (defun p/mixed
(source)
803 (klacks:expecting-element
(source "mixed")
804 (consume-and-skip-to-native source
)
805 (let ((children (p/pattern
+ source
)))
806 (make-interleave (groupify children
) (make-text)))))
808 (defun p/ref
(source)
809 (klacks:expecting-element
(source "ref")
811 (let* ((name (ntc "name" source
))
813 (or (find-definition name
)
814 (setf (find-definition name
)
815 (make-definition :name name
:child nil
)))))
816 (make-ref pdefinition
))
817 (skip-foreign* source
))))
819 (defun p/parent-ref
(source)
820 (klacks:expecting-element
(source "parentRef")
822 (let* ((name (ntc "name" source
))
823 (grammar (grammar-parent *grammar
*))
825 (or (find-definition name grammar
)
826 (setf (find-definition name grammar
)
827 (make-definition :name name
:child nil
)))))
828 (make-ref pdefinition
))
829 (skip-foreign* source
))))
831 (defun p/empty
(source)
832 (klacks:expecting-element
(source "empty")
833 (skip-foreign* source
)
836 (defun p/text
(source)
837 (klacks:expecting-element
(source "text")
838 (skip-foreign* source
)
841 (defun consume-and-parse-characters (source)
845 (multiple-value-bind (key data
) (klacks:peek-next source
)
848 (setf tmp
(concatenate 'string tmp data
)))
849 (:end-element
(return)))))
852 (defun p/value
(source)
853 (klacks:expecting-element
(source "value")
854 (let* ((type (ntc "type" source
))
855 (string (consume-and-parse-characters source
))
857 (dl *datatype-library
*))
862 (cxml-types:find-type
(and dl
(find-symbol dl
:keyword
))
865 (vc (cxml-types:make-klacks-validation-context source
)))
867 (rng-error source
"type not found: ~A/~A" type dl
))
868 (make-value :string string
869 :value
(cxml-types:parse data-type string vc
)
873 (defun p/data
(source)
874 (klacks:expecting-element
(source "data")
875 (let* ((type (ntc "type" source
))
879 (multiple-value-bind (key uri lname
)
880 (klacks:peek-next source
)
884 (case (find-symbol lname
:keyword
)
885 (:|param|
(push (p/param source
) params
))
887 (setf except
(p/except-pattern source
))
888 (skip-to-native source
)
890 (t (skip-foreign source
))))
893 (setf params
(nreverse params
))
894 (let* ((dl *datatype-library
*)
895 (data-type (cxml-types:find-type
896 (and dl
(find-symbol dl
:keyword
))
900 (rng-error source
"type not found: ~A/~A" type dl
))
901 (when (eq data-type
:error
)
902 (rng-error source
"params not valid for type: ~A/~A/~A"
909 (defun p/param
(source)
910 (klacks:expecting-element
(source "param")
911 (let ((name (ntc "name" source
))
912 (string (consume-and-parse-characters source
)))
913 (cxml-types:make-param name string
))))
915 (defun p/except-pattern
(source)
916 (klacks:expecting-element
(source "except")
917 (with-library-and-ns (klacks:list-attributes source
)
918 (klacks:consume source
)
919 (choice-ify (p/pattern
+ source
)))))
921 (defun p/not-allowed
(source)
922 (klacks:expecting-element
(source "notAllowed")
923 (consume-and-skip-to-native source
)
926 (defun safe-parse-uri (source str
&optional base
)
927 (when (zerop (length str
))
928 (rng-error source
"missing URI"))
929 (let* ((compactp (rnc-uri-p str
))
930 (str (if compactp
(follow-rnc-uri str
) str
))
934 (puri:merge-uris str base
)
935 (puri:parse-uri str
))
936 (puri:uri-parse-error
()
937 (rng-error source
"invalid URI: ~A" str
)))))
938 (when (and (eq (puri:uri-scheme uri
) :file
)
939 (puri:uri-fragment uri
))
940 (rng-error source
"Forbidden fragment in URI: ~A" str
))
941 (values uri compactp
)))
943 (defun named-string-xstream (str uri
)
944 (let ((xstream (cxml::string-
>xstream str
)))
945 (setf (cxml::xstream-name xstream
)
946 (cxml::make-stream-name
947 :entity-name
"main document"
952 (defun xstream-open-schema (uri compactp
)
954 (named-string-xstream
956 ;; fixme: Hier waere es schon, mit *entity-resolver* arbeiten
957 ;; zu koennen, aber der liefert binaere Streams.
958 (open (cxml::uri-to-pathname uri
)
959 :element-type
'character
962 (cxml::xstream-open-extid
* *entity-resolver
* nil uri
)))
964 (defun p/external-ref
(source)
965 (klacks:expecting-element
(source "externalRef")
967 (escape-uri (attribute "href" (klacks:list-attributes source
))))
968 (base (klacks:current-xml-base source
)))
969 (multiple-value-bind (uri compactp
)
970 (safe-parse-uri source href base
)
971 (when (find uri
*include-uri-stack
* :test
#'puri
:uri
=)
972 (rng-error source
"looping include"))
974 (let* ((*include-uri-stack
* (cons uri
*include-uri-stack
*))
975 (xstream (xstream-open-schema uri compactp
)))
976 (klacks:with-open-source
977 (source (make-validating-source xstream
))
978 (invoke-with-klacks-handler
980 (klacks:find-event source
:start-element
)
981 (let ((*datatype-library
* ""))
984 (skip-foreign* source
))))))
986 (defun p/grammar
(source &optional grammar
)
987 (klacks:expecting-element
(source "grammar")
988 (consume-and-skip-to-native source
)
989 (let ((*grammar
* (or grammar
(make-grammar *grammar
*)))
991 (process-grammar-content* source
)
992 (unless (or includep
(grammar-start *grammar
*))
993 (rng-error source
"no <start> in grammar"))
995 (check-pattern-definitions source
*grammar
*)
996 (defn-child (grammar-start *grammar
*))))))
998 (defvar *include-start
*)
999 (defvar *include-definitions
*)
1001 (defun process-grammar-content* (source &key disallow-include
)
1003 (multiple-value-bind (key uri lname
) (klacks:peek source
)
1007 (klacks:consume source
))
1009 (with-library-and-ns (klacks:list-attributes source
)
1010 (case (find-symbol lname
:keyword
)
1012 (process-start source
))
1013 (:|define|
(process-define source
))
1014 (:|div|
(process-div source
))
1016 (when disallow-include
1017 (rng-error source
"nested include not permitted"))
1018 (process-include source
))
1020 (skip-foreign source
)))))
1024 (defun process-start (source)
1025 (klacks:expecting-element
(source "start")
1026 (let* ((combine0 (ntc "combine" source
))
1029 (find-symbol (string-upcase combine0
) :keyword
)))
1032 (consume-and-skip-to-native source
)
1033 (p/pattern source
)))
1034 (pdefinition (grammar-start *grammar
*)))
1035 (skip-foreign* source
)
1036 ;; fixme: shared code with process-define
1038 (setf pdefinition
(make-definition :name
:start
:child nil
))
1039 (setf (grammar-start *grammar
*) pdefinition
))
1040 (when *include-body-p
*
1041 (setf *include-start
* pdefinition
))
1043 ((defn-child pdefinition
)
1044 (ecase (defn-redefinition pdefinition
)
1045 (:not-being-redefined
1047 (defn-combine-method pdefinition
)
1049 (defn-combine-method pdefinition
))))
1050 (rng-error source
"conflicting combine values for <start>"))
1052 (when (defn-head-p pdefinition
)
1053 (rng-error source
"multiple definitions for <start>"))
1054 (setf (defn-head-p pdefinition
) t
))
1055 (unless (defn-combine-method pdefinition
)
1056 (setf (defn-combine-method pdefinition
) combine
))
1057 (setf (defn-child pdefinition
)
1058 (case (defn-combine-method pdefinition
)
1060 (make-choice (defn-child pdefinition
) child
))
1062 (make-interleave (defn-child pdefinition
) child
)))))
1063 (:being-redefined-and-no-original
1064 (setf (defn-redefinition pdefinition
)
1065 :being-redefined-and-original
))
1066 (:being-redefined-and-original
)))
1068 (setf (defn-child pdefinition
) child
)
1069 (setf (defn-combine-method pdefinition
) combine
)
1070 (setf (defn-head-p pdefinition
) (null combine
))
1071 (setf (defn-redefinition pdefinition
) :not-being-redefined
))))))
1073 (defun zip (constructor children
)
1076 (rng-error nil
"empty choice?"))
1077 ((null (cdr children
))
1080 (destructuring-bind (a b
&rest rest
)
1082 (zip constructor
(cons (funcall constructor a b
) rest
))))))
1084 (defun choice-ify (children) (zip #'make-choice children
))
1085 (defun groupify (children) (zip #'make-group children
))
1086 (defun interleave-ify (children) (zip #'make-interleave children
))
1088 (defun find-definition (name &optional
(grammar *grammar
*))
1089 (gethash name
(grammar-definitions grammar
)))
1091 (defun (setf find-definition
) (newval name
&optional
(grammar *grammar
*))
1092 (setf (gethash name
(grammar-definitions grammar
)) newval
))
1094 (defun process-define (source)
1095 (klacks:expecting-element
(source "define")
1096 (let* ((name (ntc "name" source
))
1097 (combine0 (ntc "combine" source
))
1098 (combine (when combine0
1099 (find-symbol (string-upcase combine0
) :keyword
)))
1102 (consume-and-skip-to-native source
)
1103 (p/pattern
+ source
))))
1104 (pdefinition (find-definition name
)))
1106 (setf pdefinition
(make-definition :name name
:child nil
))
1107 (setf (find-definition name
) pdefinition
))
1108 (when *include-body-p
*
1109 (push pdefinition
*include-definitions
*))
1111 ((defn-child pdefinition
)
1112 (case (defn-redefinition pdefinition
)
1113 (:not-being-redefined
1115 (defn-combine-method pdefinition
)
1117 (defn-combine-method pdefinition
))))
1118 (rng-error source
"conflicting combine values for ~A" name
))
1120 (when (defn-head-p pdefinition
)
1121 (rng-error source
"multiple definitions for ~A" name
))
1122 (setf (defn-head-p pdefinition
) t
))
1123 (unless (defn-combine-method pdefinition
)
1124 (setf (defn-combine-method pdefinition
) combine
))
1125 (setf (defn-child pdefinition
)
1126 (case (defn-combine-method pdefinition
)
1128 (make-choice (defn-child pdefinition
) child
))
1130 (make-interleave (defn-child pdefinition
) child
)))))
1131 (:being-redefined-and-no-original
1132 (setf (defn-redefinition pdefinition
)
1133 :being-redefined-and-original
))
1134 (:being-redefined-and-original
)))
1136 (setf (defn-child pdefinition
) child
)
1137 (setf (defn-combine-method pdefinition
) combine
)
1138 (setf (defn-head-p pdefinition
) (null combine
))
1139 (setf (defn-redefinition pdefinition
) :not-being-redefined
))))))
1141 (defun process-div (source)
1142 (klacks:expecting-element
(source "div")
1143 (consume-and-skip-to-native source
)
1144 (process-grammar-content* source
)))
1146 (defun reset-definition-for-include (defn)
1147 (setf (defn-combine-method defn
) nil
)
1148 (setf (defn-redefinition defn
) :being-redefined-and-no-original
)
1149 (setf (defn-head-p defn
) nil
))
1151 (defun restore-definition (defn original
)
1152 (setf (defn-combine-method defn
) (defn-combine-method original
))
1153 (setf (defn-redefinition defn
) (defn-redefinition original
))
1154 (setf (defn-head-p defn
) (defn-head-p original
)))
1156 (defun process-include (source)
1157 (klacks:expecting-element
(source "include")
1159 (escape-uri (attribute "href" (klacks:list-attributes source
))))
1160 (base (klacks:current-xml-base source
))
1161 (*include-start
* nil
)
1162 (*include-definitions
* '()))
1163 (multiple-value-bind (uri compactp
)
1164 (safe-parse-uri source href base
)
1165 (consume-and-skip-to-native source
)
1166 (let ((*include-body-p
* t
))
1167 (process-grammar-content* source
:disallow-include t
))
1169 (when *include-start
*
1171 (copy-structure *include-start
*)
1172 (reset-definition-for-include *include-start
*))))
1175 for defn in
*include-definitions
*
1178 (copy-structure defn
)
1179 (reset-definition-for-include defn
)))))
1180 (when (find uri
*include-uri-stack
* :test
#'puri
:uri
=)
1181 (rng-error source
"looping include"))
1182 (let* ((*include-uri-stack
* (cons uri
*include-uri-stack
*))
1183 (xstream (xstream-open-schema uri compactp
)))
1184 (klacks:with-open-source
(source (make-validating-source xstream
))
1185 (invoke-with-klacks-handler
1187 (klacks:find-event source
:start-element
)
1188 (let ((*datatype-library
* ""))
1189 (p/grammar source
*grammar
*)))
1192 (when (eq (defn-redefinition *include-start
*)
1193 :being-redefined-and-no-original
)
1194 (rng-error source
"start not found in redefinition of grammar"))
1195 (restore-definition *include-start
* tmp-start
))
1196 (dolist (copy tmp-defns
)
1197 (let ((defn (gethash (defn-name copy
)
1198 (grammar-definitions *grammar
*))))
1199 (when (eq (defn-redefinition defn
)
1200 :being-redefined-and-no-original
)
1201 (rng-error source
"redefinition not found in grammar"))
1202 (restore-definition defn copy
)))
1205 (defun check-pattern-definitions (source grammar
)
1206 (when (and (grammar-start grammar
)
1207 (eq (defn-redefinition (grammar-start grammar
))
1208 :being-redefined-and-no-original
))
1209 (rng-error source
"start not found in redefinition of grammar"))
1210 (loop for defn being each hash-value in
(grammar-definitions grammar
) do
1211 (when (eq (defn-redefinition defn
) :being-redefined-and-no-original
)
1212 (rng-error source
"redefinition not found in grammar"))
1213 (unless (defn-child defn
)
1214 (rng-error source
"unresolved reference to ~A" (defn-name defn
)))))
1216 (defvar *any-name-allowed-p
* t
)
1217 (defvar *ns-name-allowed-p
* t
)
1219 (defun destructure-name (source qname
)
1220 (multiple-value-bind (uri lname
)
1221 (klacks:decode-qname qname source
)
1222 (setf uri
(or uri
*namespace-uri
*))
1223 (when (and *attribute-namespace-p
*
1224 (or (and (equal lname
"xmlns") (equal uri
""))
1225 (equal uri
"http://www.w3.org/2000/xmlns")))
1226 (rng-error source
"namespace attribute not permitted"))
1227 (make-name uri lname
)))
1229 (defun p/name-class
(source)
1230 (klacks:expecting-element
(source)
1231 (with-library-and-ns (klacks:list-attributes source
)
1232 (case (find-symbol (klacks:current-lname source
) :keyword
)
1234 (let ((qname (string-trim *whitespace
*
1235 (consume-and-parse-characters source
))))
1236 (destructure-name source qname
)))
1238 (unless *any-name-allowed-p
*
1239 (rng-error source
"anyname not permitted in except"))
1240 (klacks:consume source
)
1242 (let ((*any-name-allowed-p
* nil
))
1243 (make-any-name (p/except-name-class? source
)))
1244 (skip-to-native source
)))
1246 (unless *ns-name-allowed-p
*
1247 (rng-error source
"nsname not permitted in except"))
1248 (let ((uri *namespace-uri
*)
1249 (*any-name-allowed-p
* nil
)
1250 (*ns-name-allowed-p
* nil
))
1251 (when (and *attribute-namespace-p
*
1252 (equal uri
"http://www.w3.org/2000/xmlns"))
1253 (rng-error source
"namespace attribute not permitted"))
1254 (klacks:consume source
)
1256 (make-ns-name uri
(p/except-name-class? source
))
1257 (skip-to-native source
))))
1259 (klacks:consume source
)
1260 (simplify-nc-choice (p/name-class
* source
)))
1262 (rng-error source
"invalid child in except"))))))
1264 (defun p/name-class
* (source)
1265 (let ((results nil
))
1267 (skip-to-native source
)
1268 (case (klacks:peek source
)
1270 (klacks:consume source
))
1272 (push (p/name-class source
) results
))
1275 (nreverse results
)))
1277 (defun p/except-name-class?
(source)
1278 (skip-to-native source
)
1279 (multiple-value-bind (key uri lname
)
1280 (klacks:peek source
)
1282 (if (and (eq key
:start-element
)
1283 (string= (find-symbol lname
:keyword
) "except"))
1284 (p/except-name-class source
)
1287 (defun p/except-name-class
(source)
1288 (klacks:expecting-element
(source "except")
1289 (with-library-and-ns (klacks:list-attributes source
)
1290 (klacks:consume source
)
1291 (let ((x (p/name-class
* source
)))
1293 (simplify-nc-choice x
)
1296 (defun escape-uri (string)
1297 (with-output-to-string (out)
1298 (loop for c across
(cxml::rod-to-utf8-string string
) do
1299 (let ((code (char-code c
)))
1300 ;; http://www.w3.org/TR/xlink/#link-locators
1301 (if (or (>= code
127) (<= code
32) (find c
"<>\"{}|\\^`"))
1302 (format out
"%~2,'0X" code
)
1303 (write-char c out
))))))
1308 (defvar *definitions-to-names
*)
1309 (defvar *seen-names
*)
1311 (defun serialization-name (defn)
1312 (or (gethash defn
*definitions-to-names
*)
1313 (setf (gethash defn
*definitions-to-names
*)
1314 (let ((name (if (gethash (defn-name defn
) *seen-names
*)
1317 (hash-table-count *seen-names
*))
1319 (setf (gethash name
*seen-names
*) defn
)
1322 (defun serialize-schema (schema sink
)
1323 "@arg[schema]{a Relax NG @class{schema}}
1324 @arg[sink]{a SAX handler}
1325 @return{the result of @code{sax:end-document}}
1326 @short{This function serializes a parsed Relax NG back into XML syntax.}
1328 Note that the schema represented in memory has gone through simplification
1329 as is textually different from the original XML document.
1332 (cxml:with-xml-output sink
1333 (let ((*definitions-to-names
* (make-hash-table))
1334 (*seen-names
* (make-hash-table :test
'equal
)))
1335 (cxml:with-element
"grammar"
1336 (cxml:with-element
"start"
1337 (serialize-pattern (schema-start schema
)))
1338 (loop for defn being each hash-key in
*definitions-to-names
* do
1339 (serialize-definition defn
))))))
1341 (defun serialize-pattern (pattern)
1344 (cxml:with-element
"element"
1345 (serialize-name (pattern-name pattern
))
1346 (serialize-pattern (pattern-child pattern
))))
1348 (cxml:with-element
"attribute"
1349 (serialize-name (pattern-name pattern
))
1350 (serialize-pattern (pattern-child pattern
))))
1355 (interleave "interleave")
1357 (serialize-pattern (pattern-a pattern
))
1358 (serialize-pattern (pattern-b pattern
))))
1360 (cxml:with-element
"oneOrMore"
1361 (serialize-pattern (pattern-child pattern
))))
1363 (cxml:with-element
"list"
1364 (serialize-pattern (pattern-child pattern
))))
1366 (cxml:with-element
"ref"
1367 (cxml:attribute
"name" (serialization-name (pattern-target pattern
)))))
1369 (cxml:with-element
"empty"))
1371 (cxml:with-element
"notAllowed"))
1373 (cxml:with-element
"text"))
1375 (cxml:with-element
"value"
1376 (let ((type (pattern-type pattern
)))
1377 (cxml:attribute
"datatype-library"
1378 (symbol-name (cxml-types:type-library type
)))
1379 (cxml:attribute
"type" (cxml-types:type-name type
)))
1380 (cxml:attribute
"ns" (pattern-ns pattern
))
1381 (cxml:text
(pattern-string pattern
))))
1383 (cxml:with-element
"value"
1384 (let ((type (pattern-type pattern
)))
1385 (cxml:attribute
"datatype-library"
1386 (symbol-name (cxml-types:type-library type
)))
1387 (cxml:attribute
"type" (cxml-types:type-name type
)))
1388 (dolist (param (pattern-params pattern
))
1389 (cxml:with-element
"param"
1390 (cxml:attribute
"name" (cxml-types:param-name param
))
1391 (cxml:text
(cxml-types:param-value param
))))
1392 (when (pattern-except pattern
)
1393 (cxml:with-element
"except"
1394 (serialize-pattern (pattern-except pattern
))))))))
1396 (defun serialize-definition (defn)
1397 (cxml:with-element
"define"
1398 (cxml:attribute
"name" (serialization-name defn
))
1399 (serialize-pattern (defn-child defn
))))
1401 (defun serialize-name (name)
1404 (cxml:with-element
"name"
1405 (cxml:attribute
"ns" (name-uri name
))
1406 (cxml:text
(name-lname name
))))
1408 (cxml:with-element
"anyName"
1409 (when (any-name-except name
)
1410 (serialize-except-name (any-name-except name
)))))
1412 (cxml:with-element
"anyName"
1413 (cxml:attribute
"ns" (ns-name-uri name
))
1414 (when (ns-name-except name
)
1415 (serialize-except-name (ns-name-except name
)))))
1417 (cxml:with-element
"choice"
1418 (serialize-name (name-class-choice-a name
))
1419 (serialize-name (name-class-choice-b name
))))))
1421 (defun serialize-except-name (spec)
1422 (cxml:with-element
"except"
1423 (serialize-name spec
)))
1429 ;;; Foreign attributes and elements are removed implicitly while parsing.
1432 ;;; All character data is discarded while parsing (which can only be
1433 ;;; whitespace after validation).
1435 ;;; Whitespace in name, type, and combine attributes is stripped while
1436 ;;; parsing. Ditto for <name/>.
1438 ;;; 4.3. datatypeLibrary attribute
1439 ;;; Escaping is done by p/pattern.
1440 ;;; Attribute value defaulting is done using *datatype-library*; only
1441 ;;; p/data and p/value record the computed value.
1443 ;;; 4.4. type attribute of value element
1444 ;;; Done by p/value.
1446 ;;; 4.5. href attribute
1447 ;;; Escaping is done by process-include and p/external-ref.
1449 ;;; FIXME: Mime-type handling should be the job of the entity resolver,
1450 ;;; but that requires xstream hacking.
1452 ;;; 4.6. externalRef element
1453 ;;; Done by p/external-ref.
1455 ;;; 4.7. include element
1456 ;;; Done by process-include.
1458 ;;; 4.8. name attribute of element and attribute elements
1459 ;;; `name' is stored as a slot, not a child. Done by p/element and
1462 ;;; 4.9. ns attribute
1463 ;;; done by p/name-class, p/value, p/element, p/attribute
1466 ;;; done by p/name-class
1468 ;;; 4.11. div element
1469 ;;; Legen wir gar nicht erst an.
1471 ;;; 4.12. 4.13 4.14 4.15
1476 ;;; -- ausser der sache mit den datentypen
1478 ;;; 4.17, 4.18, 4.19
1479 ;;; Ueber die Grammar-und Definition Objekte, wie von James Clark
1482 ;;; Dabei werden keine Umbenennungen vorgenommen, weil Referenzierung
1483 ;;; durch Aufbei der Graphenstruktur zwischen ref und Definition
1484 ;;; erfolgt und Namen dann bereits aufgeloest sind. Wir benennen
1485 ;;; dafuer beim Serialisieren um.
1487 (defmethod check-recursion ((pattern element
) depth
)
1488 (check-recursion (pattern-child pattern
) (1+ depth
)))
1490 (defmethod check-recursion ((pattern ref
) depth
)
1491 (when (eql (pattern-crdepth pattern
) depth
)
1492 (rng-error nil
"infinite recursion in ~A"
1493 (defn-name (pattern-target pattern
))))
1494 (when (null (pattern-crdepth pattern
))
1495 (setf (pattern-crdepth pattern
) depth
)
1496 (check-recursion (defn-child (pattern-target pattern
)) depth
)
1497 (setf (pattern-crdepth pattern
) t
)))
1499 (defmethod check-recursion ((pattern %parent
) depth
)
1500 (check-recursion (pattern-child pattern
) depth
))
1502 (defmethod check-recursion ((pattern %combination
) depth
)
1503 (check-recursion (pattern-a pattern
) depth
)
1504 (check-recursion (pattern-b pattern
) depth
))
1506 (defmethod check-recursion ((pattern %leaf
) depth
)
1507 (declare (ignore depth
)))
1509 (defmethod check-recursion ((pattern data
) depth
)
1510 (when (pattern-except pattern
)
1511 (check-recursion (pattern-except pattern
) depth
)))
1518 (defmethod fold-not-allowed ((pattern element
))
1519 (setf (pattern-child pattern
) (fold-not-allowed (pattern-child pattern
)))
1522 (defmethod fold-not-allowed ((pattern %parent
))
1523 (setf (pattern-child pattern
) (fold-not-allowed (pattern-child pattern
)))
1524 (if (typep (pattern-child pattern
) 'not-allowed
)
1525 (pattern-child pattern
)
1530 (defmethod fold-not-allowed ((pattern %combination
))
1531 (setf (pattern-a pattern
) (fold-not-allowed (pattern-a pattern
)))
1532 (setf (pattern-b pattern
) (fold-not-allowed (pattern-b pattern
)))
1535 (defmethod fold-not-allowed ((pattern group
))
1538 ;; remove if any child is not allowed
1539 ((typep (pattern-a pattern
) 'not-allowed
) (pattern-a pattern
))
1540 ((typep (pattern-b pattern
) 'not-allowed
) (pattern-b pattern
))
1543 (defmethod fold-not-allowed ((pattern interleave
))
1546 ;; remove if any child is not allowed
1547 ((typep (pattern-a pattern
) 'not-allowed
) (pattern-a pattern
))
1548 ((typep (pattern-b pattern
) 'not-allowed
) (pattern-b pattern
))
1551 (defmethod fold-not-allowed ((pattern choice
))
1554 ;; if any child is not allowed, choose the other
1555 ((typep (pattern-a pattern
) 'not-allowed
) (pattern-b pattern
))
1556 ((typep (pattern-b pattern
) 'not-allowed
) (pattern-a pattern
))
1561 (defmethod fold-not-allowed ((pattern %leaf
))
1564 (defmethod fold-not-allowed ((pattern data
))
1565 (when (pattern-except pattern
)
1566 (setf (pattern-except pattern
) (fold-not-allowed (pattern-except pattern
)))
1567 (when (typep (pattern-except pattern
) 'not-allowed
)
1568 (setf (pattern-except pattern
) nil
)))
1573 (defmethod fold-not-allowed ((pattern ref
))
1581 (defmethod fold-empty ((pattern one-or-more
))
1583 (if (typep (pattern-child pattern
) 'empty
)
1584 (pattern-child pattern
)
1587 (defmethod fold-empty ((pattern %parent
))
1588 (setf (pattern-child pattern
) (fold-empty (pattern-child pattern
)))
1593 (defmethod fold-empty ((pattern %combination
))
1594 (setf (pattern-a pattern
) (fold-empty (pattern-a pattern
)))
1595 (setf (pattern-b pattern
) (fold-empty (pattern-b pattern
)))
1598 (defmethod fold-empty ((pattern group
))
1601 ;; if any child is empty, choose the other
1602 ((typep (pattern-a pattern
) 'empty
) (pattern-b pattern
))
1603 ((typep (pattern-b pattern
) 'empty
) (pattern-a pattern
))
1606 (defmethod fold-empty ((pattern interleave
))
1609 ;; if any child is empty, choose the other
1610 ((typep (pattern-a pattern
) 'empty
) (pattern-b pattern
))
1611 ((typep (pattern-b pattern
) 'empty
) (pattern-a pattern
))
1614 (defmethod fold-empty ((pattern choice
))
1616 (if (typep (pattern-b pattern
) 'empty
)
1618 ((typep (pattern-a pattern
) 'empty
)
1619 (pattern-a pattern
))
1621 (rotatef (pattern-a pattern
) (pattern-b pattern
))
1627 (defmethod fold-empty ((pattern %leaf
))
1630 (defmethod fold-empty ((pattern data
))
1631 (when (pattern-except pattern
)
1632 (setf (pattern-except pattern
) (fold-empty (pattern-except pattern
))))
1637 (defmethod fold-empty ((pattern ref
))
1641 ;;;; name class overlap
1643 ;;; fixme: memorize this stuff?
1645 (defparameter !uri
(string (code-char 1)))
1646 (defparameter !lname
"")
1648 (defun classes-overlap-p (nc1 nc2
)
1649 (flet ((both-contain (x)
1650 (and (contains nc1
(car x
) (cdr x
))
1651 (contains nc2
(car x
) (cdr x
)))))
1652 (or (some #'both-contain
(representatives nc1
))
1653 (some #'both-contain
(representatives nc2
)))))
1655 (defmethod representatives ((nc any-name
))
1656 (cons (cons !uri
!lname
)
1657 (if (any-name-except nc
)
1658 (representatives (any-name-except nc
))
1661 (defmethod representatives ((nc ns-name
))
1662 (cons (cons (ns-name-uri nc
) !lname
)
1663 (if (ns-name-except nc
)
1664 (representatives (ns-name-except nc
))
1667 (defmethod representatives ((nc name
))
1668 (list (cons (name-uri nc
) (name-lname nc
))))
1670 (defmethod representatives ((nc name-class-choice
))
1671 (nconc (representatives (name-class-choice-a nc
))
1672 (representatives (name-class-choice-b nc
))))
1677 (defun finalize-definitions (pattern)
1678 (let ((defns (make-hash-table)))
1679 (labels ((recurse (p)
1682 (let ((target (pattern-target p
)))
1683 (unless (gethash target defns
)
1684 (setf (gethash target defns
) t
)
1685 (setf (defn-child target
) (recurse (defn-child target
))))
1686 (if (typep (defn-child target
) 'element
)
1688 (copy-pattern-tree (defn-child target
)))))
1692 (when (pattern-except p
)
1693 (setf (pattern-except p
) (recurse (pattern-except p
)))))
1695 (setf (pattern-child p
) (recurse (pattern-child p
))))
1697 (setf (pattern-a p
) (recurse (pattern-a p
)))
1698 (setf (pattern-b p
) (recurse (pattern-b p
))))
1704 for defn being each hash-key in defns
1707 (defun copy-pattern-tree (pattern)
1708 (labels ((recurse (p)
1709 (let ((q (copy-structure p
)))
1712 (when (pattern-except p
)
1713 (setf (pattern-except q
) (recurse (pattern-except p
)))))
1715 (setf (pattern-child q
) (recurse (pattern-child p
))))
1717 (setf (pattern-a q
) (recurse (pattern-a p
)))
1718 (setf (pattern-b q
) (recurse (pattern-b p
))))
1723 (defparameter *in-attribute-p
* nil
)
1724 (defparameter *in-one-or-more-p
* nil
)
1725 (defparameter *in-one-or-more
//group-or-interleave-p
* nil
)
1726 (defparameter *in-list-p
* nil
)
1727 (defparameter *in-data-except-p
* nil
)
1728 (defparameter *in-start-p
* nil
)
1730 (defun check-start-restrictions (pattern)
1731 (let ((*in-start-p
* t
))
1732 (check-restrictions pattern
)))
1734 (defun content-type-max (a b
)
1743 (defun groupable-max (a b
)
1744 (if (or (eq a
:empty
)
1746 (and (eq a
:complex
)
1748 (content-type-max a b
)
1751 (defun assert-name-class-finite (nc)
1753 ((or any-name ns-name
)
1754 (rng-error nil
"infinite attribute name class outside of one-or-more"))
1757 (assert-name-class-finite (name-class-choice-a nc
))
1758 (assert-name-class-finite (name-class-choice-b nc
)))))
1760 (defmethod check-restrictions ((pattern attribute
))
1761 (when *in-attribute-p
*
1762 (rng-error nil
"nested attribute not allowed"))
1763 (when *in-one-or-more
//group-or-interleave-p
*
1764 (rng-error nil
"attribute not allowed in oneOrMore//group, oneOrMore//interleave"))
1766 (rng-error nil
"attribute in list not allowed"))
1767 (when *in-data-except-p
*
1768 (rng-error nil
"attribute in data/except not allowed"))
1770 (rng-error nil
"attribute in start not allowed"))
1771 (let ((*in-attribute-p
* t
))
1772 (unless *in-one-or-more-p
*
1773 (assert-name-class-finite (pattern-name pattern
)))
1774 (values (if (check-restrictions (pattern-child pattern
))
1777 (list (pattern-name pattern
))
1780 (defmethod check-restrictions ((pattern ref
))
1781 (when *in-attribute-p
*
1782 (rng-error nil
"ref in attribute not allowed"))
1784 (rng-error nil
"ref in list not allowed"))
1785 (when *in-data-except-p
*
1786 (rng-error nil
"ref in data/except not allowed"))
1789 (list (pattern-name (defn-child (pattern-target pattern
))))
1792 (defmethod check-restrictions ((pattern one-or-more
))
1793 (when *in-data-except-p
*
1794 (rng-error nil
"oneOrMore in data/except not allowed"))
1796 (rng-error nil
"one-or-more in start not allowed"))
1797 (let* ((*in-one-or-more-p
* t
))
1798 (multiple-value-bind (x a e textp
)
1799 (check-restrictions (pattern-child pattern
))
1800 (values (groupable-max x x
) a e textp
))))
1802 (defmethod check-restrictions ((pattern group
))
1803 (when *in-data-except-p
*
1804 (rng-error nil
"group in data/except not allowed"))
1806 (rng-error nil
"group in start not allowed"))
1807 (let ((*in-one-or-more
//group-or-interleave-p
*
1808 *in-one-or-more-p
*))
1809 (multiple-value-bind (x a e tp
) (check-restrictions (pattern-a pattern
))
1810 (multiple-value-bind (y b f tq
) (check-restrictions (pattern-b pattern
))
1813 (when (classes-overlap-p nc1 nc2
)
1814 (rng-error nil
"attribute name overlap in group: ~A ~A"
1816 (values (groupable-max x y
)
1821 (defmethod check-restrictions ((pattern interleave
))
1823 (rng-error nil
"interleave in list not allowed"))
1824 (when *in-data-except-p
*
1825 (rng-error nil
"interleave in data/except not allowed"))
1827 (rng-error nil
"interleave in start not allowed"))
1828 (let ((*in-one-or-more
//group-or-interleave-p
*
1829 *in-one-or-more-p
*))
1830 (multiple-value-bind (x a e tp
) (check-restrictions (pattern-a pattern
))
1831 (multiple-value-bind (y b f tq
) (check-restrictions (pattern-b pattern
))
1834 (when (classes-overlap-p nc1 nc2
)
1835 (rng-error nil
"attribute name overlap in interleave: ~A ~A"
1839 (when (classes-overlap-p nc1 nc2
)
1840 (rng-error nil
"element name overlap in interleave: ~A ~A"
1843 (rng-error nil
"multiple text permitted by interleave"))
1844 (values (groupable-max x y
)
1849 (defmethod check-restrictions ((pattern choice
))
1850 (multiple-value-bind (x a e tp
) (check-restrictions (pattern-a pattern
))
1851 (multiple-value-bind (y b f tq
) (check-restrictions (pattern-b pattern
))
1852 (values (content-type-max x y
)
1857 (defmethod check-restrictions ((pattern list-pattern
))
1859 (rng-error nil
"nested list not allowed"))
1860 (when *in-data-except-p
*
1861 (rng-error nil
"list in data/except not allowed"))
1862 (let ((*in-list-p
* t
))
1863 (check-restrictions (pattern-child pattern
)))
1865 (rng-error nil
"list in start not allowed"))
1868 (defmethod check-restrictions ((pattern text
))
1870 (rng-error nil
"text in list not allowed"))
1871 (when *in-data-except-p
*
1872 (rng-error nil
"text in data/except not allowed"))
1874 (rng-error nil
"text in start not allowed"))
1875 (values :complex nil nil t
))
1877 (defmethod check-restrictions ((pattern data
))
1879 (rng-error nil
"data in start not allowed"))
1880 (when (pattern-except pattern
)
1881 (let ((*in-data-except-p
* t
))
1882 (check-restrictions (pattern-except pattern
))))
1885 (defmethod check-restrictions ((pattern value
))
1887 (rng-error nil
"value in start not allowed"))
1890 (defmethod check-restrictions ((pattern empty
))
1891 (when *in-data-except-p
*
1892 (rng-error nil
"empty in data/except not allowed"))
1894 (rng-error nil
"empty in start not allowed"))
1897 (defmethod check-restrictions ((pattern element
))
1898 (unless (check-restrictions (pattern-child pattern
))
1899 (rng-error nil
"restrictions on string sequences violated")))
1901 (defmethod check-restrictions ((pattern not-allowed
))