David Lichteblau wrote:
Do you have a patch for me that I can just apply?
Attached output of git diff. Note that I just moved PARSE-SCHEMA towards the end of file. I am not sure whether it follows your style conventions.
Chaitanya
diff --git a/parse.lisp b/parse.lisp index 3bcc720..d6aa5dd 100644 --- a/parse.lisp +++ b/parse.lisp @@ -198,84 +198,6 @@ (klacks:make-tapping-source upstream handler)) upstream)))
-(defun parse-schema (input &key entity-resolver (process-dtd-compatibility t)) - "@arg[input]{a string, pathname, stream, or xstream} - @arg[entity-resolver]{a function of two arguments, or NIL} - @arg[process-dtd-compatibility]{a boolean} - @return{a parsed @class{schema}} - @short{This function parses a Relax NG schema file in XML syntax} - and returns a parsed representation of that schema. - - @code{input} can be any stream designator as understood by - @code{cxml:make-source}. - - Note that namestrings are not valid arguments, - because they would be interpreted as XML source code. Use pathnames - instead. - - @code{entity-resolver} can be passed as a function of two arguments. - It is invoked for every entity referenced by the - document with the entity's Public ID (a rod) and System ID (an - URI object) as arguments. The function may either return - nil, CXML will then try to resolve the entity as usual. - Alternatively it may return a Common Lisp stream specialized on - @code{(unsigned-byte 8)} which will be used instead. - - If @code{process-dtd-compatibility} is true, the schema will be checked - for @em{compatibility} with Relax NG DTD Compatibility, and default values - will be recorded. (Without @code{process-dtd-compatibility}, the schema - will not be checked @em{compatibility}, and annotations for - DTD Compatibility will be ignored like any other foreign element.) - - @see{parse-compact} - @see{make-validator}" - (when *validate-grammar* - (unless *relax-ng-grammar* - (let* ((*validate-grammar* nil) - (d (slot-value (asdf:find-system :cxml-rng) - 'asdf::relative-pathname))) - #+(or) (parse-compact (merge-pathnames "rng.rnc" d)) - (setf *relax-ng-grammar* - (parse-schema (merge-pathnames "rng.rng" d))) - (setf *compatibility-grammar* - (parse-schema (merge-pathnames "compatibility.rng" d)))))) - (let ((*process-dtd-compatibility* process-dtd-compatibility)) - (klacks:with-open-source (source (make-schema-source input)) - (invoke-with-klacks-handler - (lambda () - (klacks:find-event source :start-element) - (let* ((*datatype-library* "") - (*namespace-uri* "") - (*entity-resolver* entity-resolver) - (*external-href-stack* '()) - (*include-uri-stack* '()) - (*grammar* (make-grammar nil)) - (start (p/pattern source))) - (unless start - (rng-error nil "empty grammar")) - (setf (grammar-start *grammar*) - (make-definition :name :start :child start)) - (check-pattern-definitions source *grammar*) - (check-recursion start 0) - (multiple-value-bind (new-start defns) - (finalize-definitions start) - (setf start (fold-not-allowed new-start)) - (dolist (defn defns) - (setf (defn-child defn) (fold-not-allowed (defn-child defn)))) - (setf start (fold-empty start)) - (dolist (defn defns) - (setf (defn-child defn) (fold-empty (defn-child defn))))) - (multiple-value-bind (new-start defns) - (finalize-definitions start) - (check-start-restrictions new-start) - (dolist (defn defns) - (check-restrictions (defn-child defn))) - (let ((schema (make-schema new-start defns))) - (when *process-dtd-compatibility* - (check-schema-compatibility schema defns)) - schema)))) - source)))) -
;;;; pattern structures
@@ -2183,3 +2105,84 @@ (assert (null *in-element*)) (let ((*in-element* pattern)) (check-pattern-compatibility (pattern-child pattern)))) + + +;;; Parser + +(defun parse-schema (input &key entity-resolver (process-dtd-compatibility t)) + "@arg[input]{a string, pathname, stream, or xstream} + @arg[entity-resolver]{a function of two arguments, or NIL} + @arg[process-dtd-compatibility]{a boolean} + @return{a parsed @class{schema}} + @short{This function parses a Relax NG schema file in XML syntax} + and returns a parsed representation of that schema. + + @code{input} can be any stream designator as understood by + @code{cxml:make-source}. + + Note that namestrings are not valid arguments, + because they would be interpreted as XML source code. Use pathnames + instead. + + @code{entity-resolver} can be passed as a function of two arguments. + It is invoked for every entity referenced by the + document with the entity's Public ID (a rod) and System ID (an + URI object) as arguments. The function may either return + nil, CXML will then try to resolve the entity as usual. + Alternatively it may return a Common Lisp stream specialized on + @code{(unsigned-byte 8)} which will be used instead. + + If @code{process-dtd-compatibility} is true, the schema will be checked + for @em{compatibility} with Relax NG DTD Compatibility, and default values + will be recorded. (Without @code{process-dtd-compatibility}, the schema + will not be checked @em{compatibility}, and annotations for + DTD Compatibility will be ignored like any other foreign element.) + + @see{parse-compact} + @see{make-validator}" + (when *validate-grammar* + (unless *relax-ng-grammar* + (let* ((*validate-grammar* nil) + (d (slot-value (asdf:find-system :cxml-rng) + 'asdf::relative-pathname))) + #+(or) (parse-compact (merge-pathnames "rng.rnc" d)) + (setf *relax-ng-grammar* + (parse-schema (merge-pathnames "rng.rng" d))) + (setf *compatibility-grammar* + (parse-schema (merge-pathnames "compatibility.rng" d)))))) + (let ((*process-dtd-compatibility* process-dtd-compatibility)) + (klacks:with-open-source (source (make-schema-source input)) + (invoke-with-klacks-handler + (lambda () + (klacks:find-event source :start-element) + (let* ((*datatype-library* "") + (*namespace-uri* "") + (*entity-resolver* entity-resolver) + (*external-href-stack* '()) + (*include-uri-stack* '()) + (*grammar* (make-grammar nil)) + (start (p/pattern source))) + (unless start + (rng-error nil "empty grammar")) + (setf (grammar-start *grammar*) + (make-definition :name :start :child start)) + (check-pattern-definitions source *grammar*) + (check-recursion start 0) + (multiple-value-bind (new-start defns) + (finalize-definitions start) + (setf start (fold-not-allowed new-start)) + (dolist (defn defns) + (setf (defn-child defn) (fold-not-allowed (defn-child defn)))) + (setf start (fold-empty start)) + (dolist (defn defns) + (setf (defn-child defn) (fold-empty (defn-child defn))))) + (multiple-value-bind (new-start defns) + (finalize-definitions start) + (check-start-restrictions new-start) + (dolist (defn defns) + (check-restrictions (defn-child defn))) + (let ((schema (make-schema new-start defns))) + (when *process-dtd-compatibility* + (check-schema-compatibility schema defns)) + schema)))) + source))))