doc raus
[cxml-rng.git] / compact.lisp
blob35abb53d3073c84077aa8cb32e6b2f1d6225d471
1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
2 ;;;
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
7 ;;; are met:
8 ;;;
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
11 ;;;
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.
16 ;;;
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.
30 (in-package :cxml-rng)
32 #+sbcl
33 (declaim (optimize (debug 2)))
35 (defparameter *keywords*
36 '("attribute" "default" "datatypes" "div" "element" "empty" "external"
37 "grammar" "include" "inherit" "list" "mixed" "namespace" "notAllowed"
38 "parent" "start" "string" "text" "token"))
40 (defmacro double (x)
41 `((lambda (x) (return (values x x))) ,x))
44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
45 ;;;; Escape interpretation
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 (defclass hex-stream (trivial-gray-streams:fundamental-character-input-stream)
49 ((source :initarg :source :accessor stream-source)
50 (buffer :initform (make-array 1 :adjustable t :fill-pointer 0)
51 :accessor stream-buffer)
52 (pos :initform 0 :accessor stream-pos)))
54 (defmethod trivial-gray-streams:stream-file-position ((s hex-stream))
55 (file-position (stream-source s)))
57 ;; zzz geht das nicht besser?
58 (defmethod trivial-gray-streams:stream-read-char ((s hex-stream))
59 (with-slots (source buffer pos) s
60 (cond
61 ((< pos (length buffer))
62 (prog1
63 (elt buffer pos)
64 (incf pos)))
66 (setf (fill-pointer buffer) 0)
67 (setf pos 0)
68 (flet ((slurp ()
69 (let ((c (read-char source nil)))
70 (vector-push-extend c buffer)
71 c)))
72 (macrolet ((with-expectation (frob &body body)
73 (when (characterp frob)
74 (setf frob `(eql (slurp) ,frob)))
75 `(let ((result ,frob))
76 (cond
77 (result
78 ,@(or body (list 'result)))
80 (prog1
81 (elt buffer 0)
82 (incf pos)))))))
83 (with-expectation
84 #\\
85 (with-expectation
86 #\x
87 (with-expectation
88 (loop
89 for d = (peek-char nil source)
90 while (eql d #\x)
91 do (slurp)
92 finally
93 (return (eql (slurp) #\{)))
94 (with-expectation
95 (loop
96 for result = 0 then (+ (* result 16) i)
97 for d = (peek-char nil source nil)
98 for i = (digit-char-p d 16)
99 while i
101 (slurp)
102 finally
103 (return
104 (when (eql (slurp) #\})
105 (setf (fill-pointer buffer) 0)
106 (setf pos 0)
107 (code-char result))))))))))))))
110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111 ;;;; Tokenization
112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
114 (clex:deflexer rng
116 ;; NCName
117 (letter+extras
118 (or (range #x0041 #x005A) (range #x0061 #x007A)
119 ;; just allow the rest of unicode, because clex can't deal with the
120 ;; complete definition of name-char:
121 (range #x00c0 #xd7ff)
122 (range #xe000 #xfffd)
123 (range #x10000 #x10ffff)))
124 (digit (range #x0030 #x0039)) ;ditto
125 (name-start-char (or letter+extras #\_))
126 (name-char (or letter+extras digit #\. #\- #\_ #\:))
128 ;; some RNC ranges
129 (char
130 (or 9 10 13
131 (range 32 #xd7ff)
132 (range #xe000 #xfffd)
133 (range #x10000 #x10ffff)))
134 (init-comment-char
135 (or 9 32 33 34
136 ;; #\#
137 (range 36 #xd7ff)
138 (range #xe000 #xfffd)
139 (range #x10000 #x10ffff)))
140 (comment-char
141 (or 35 init-comment-char))
142 (string-char
143 (or 32 33
144 ;; #\"
145 (range 35 38)
146 ;; #\'
147 (range 40 #xd7ff)
148 (range #xe000 #xfffd)
149 (range #x10000 #x10ffff)))
150 (space (or 9 10 13 32))
151 (newline (or 10 13)))
153 ((* space))
155 ((and "##") (clex:begin 'documentation-line))
156 ((and "##" newline))
157 ((clex::in documentation-line newline) (clex:begin 'clex:initial))
158 ((clex::in documentation-line comment-char)
159 (return (values 'documentation-line clex:bag)))
161 ((and #\# init-comment-char) (clex:begin 'comment))
162 ((and #\# newline))
163 ((clex::in comment newline) (clex:begin 'clex:initial))
164 ((clex::in comment comment-char))
166 ((and "'''" (* (or string-char #\' #\")) "'''")
167 (return
168 (values 'literal-segment (subseq clex:bag 3 (- (length clex:bag) 3)))))
170 ((and #\' (* (or string-char #\")) #\')
171 (when (or (find (code-char 13) clex:bag)
172 (find (code-char 10) clex:bag))
173 (rng-error nil "disallowed newline in string literal"))
174 (return
175 (values 'literal-segment (subseq clex:bag 1 (- (length clex:bag) 1)))))
177 ((and #\" #\" #\" (* (or string-char #\' #\")) #\" #\" #\")
178 (return
179 (values 'literal-segment (subseq clex:bag 3 (- (length clex:bag) 3)))))
181 ((and #\" (* (or string-char #\')) #\")
182 (when (or (find (code-char 13) clex:bag)
183 (find (code-char 10) clex:bag))
184 (rng-error nil "disallowed newline in string literal"))
185 (return
186 (values 'literal-segment (subseq clex:bag 1 (- (length clex:bag) 1)))))
188 ((and name-start-char (* name-char))
189 (return
190 (cond
191 ((find clex:bag *keywords* :test #'equal)
192 (let ((sym (intern (string-upcase clex:bag) :keyword)))
193 (values sym sym)))
194 ((find #\: clex:bag)
195 (let* ((pos (position #\: clex:bag))
196 (prefix (subseq clex:bag 0 pos))
197 (lname (subseq clex:bag (1+ pos ))))
198 (when (find #\: lname)
199 (rng-error "too many colons"))
200 (unless (and (cxml-types::nc-name-p prefix))
201 (rng-error nil "not an ncname: ~A" prefix))
202 (let ((ch (clex::getch)))
203 (cond
204 ((and (equal lname "") (eql ch #\*))
205 (values 'nsname prefix))
207 (clex::backup ch)
208 (unless (and (cxml-types::nc-name-p lname))
209 (rng-error nil "not an ncname: ~A" lname))
210 (values 'cname (cons prefix lname)))))))
212 (unless (cxml-types::nc-name-p clex:bag)
213 (rng-error nil "not an ncname: ~A" clex:bag))
214 (values 'identifier clex:bag)))))
216 ((and #\\ name-start-char (* name-char))
217 (let ((str (subseq clex:bag 1)))
218 (unless (cxml-types::nc-name-p str)
219 (rng-error nil "not an ncname: ~A" clex:bag))
220 (return (values 'identifier str))))
222 (#\= (double '=))
223 (#\{ (double '{))
224 (#\} (double '}))
225 (#\[ (double '[))
226 (#\] (double ']))
227 (#\, (double '|,|))
228 (#\& (double '&))
229 (#\| (double '|\||))
230 (#\? (double '?))
231 (#\* (double '*))
232 (#\+ (double '+))
233 (#\( (double '|(|))
234 (#\) (double '|)|))
235 ((and "|=") (double '|\|=|))
236 ((and "&=") (double '&=))
237 ((and ">>") (double '>>))
238 (#\~ (double '~))
239 (#\- (double '-)))
242 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
243 ;;;; Parsing into S-Expressions
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246 (eval-when (:compile-toplevel :load-toplevel :execute)
247 #+(or)
248 (defmacro lambda* ((&rest args) &body body)
249 (setf args (mapcar (lambda (arg) (or arg (gensym))) args))
250 `(lambda (,@args)
251 (declare (ignorable ,@args))
252 ,@body))
254 (defmacro lambda* ((&rest args) &body body)
255 (setf args (mapcar (lambda (arg) (or arg (gensym))) args))
256 `(lambda (&rest .args.)
257 (unless (equal (length .args.) ,(length args))
258 (error "expected ~A, got ~A" ',args .args.))
259 (destructuring-bind (,@args) .args.
260 (declare (ignorable ,@args))
261 ,@body)))
263 (defun wrap-decls (decls content)
264 (if decls
265 `(,@(car decls)
266 ,(wrap-decls (cadr decls) content))
267 content)))
269 (yacc:define-parser *compact-parser*
270 (:start-symbol top-level)
271 (:terminals (:attribute :default :datatypes :div :element :empty
272 :external :grammar :include :inherit :list
273 :mixed :namespace :notAllowed :parent :start
274 :string :text :token
275 = { } |,| & |\|| ? * + |(| |)| |\|=| &= ~ -
276 [ ] >>
277 identifier literal-segment cname nsname
278 documentation-line))
279 #+debug (:print-first-terminals t)
280 #+debug (:print-states t)
281 #+debug (:print-lookaheads t)
282 #+debug (:print-goto-graph t)
283 (:muffle-conflicts (50 0)) ;hrmpf
285 (top-level (decl* pattern #'wrap-decls)
286 (decl* grammar-content*
287 (lambda (a b) (wrap-decls a `(with-grammar () ,@b)))))
289 (decl* () (decl decl*))
291 (decl (:namespace identifier-or-keyword = namespace-uri-literal
292 (lambda* (nil name nil uri)
293 `(with-namespace (:uri ,uri :name ,name))))
294 (:default :namespace = namespace-uri-literal
295 (lambda* (nil nil nil uri)
296 `(with-namespace (:uri ,uri :default t))))
297 (:default :namespace identifier-or-keyword = namespace-uri-literal
298 (lambda* (nil nil name nil uri)
299 `(with-namespace (:uri ,uri :name ,name :default t))))
300 (:datatypes identifier-or-keyword = literal
301 (lambda* (nil name nil uri)
302 `(with-data-type (:name ,name :uri ,uri)))))
304 (pattern (inner-pattern
305 (lambda* (p) `(without-annotations ,p))))
307 (particle (inner-particle
308 (lambda* (p) `(without-annotations ,p))))
310 (inner-pattern inner-particle
311 (particle-choice (lambda* (p) `(%with-annotations ,p)))
312 (particle-group (lambda* (p) `(%with-annotations ,p)))
313 (particle-interleave (lambda* (p) `(%with-annotations ,p)))
314 (data-except (lambda* (p) `(%with-annotations-group ,p))))
316 (primary (:element name-class { pattern }
317 (lambda* (nil name nil pattern nil)
318 `(with-element (:name ,name) ,pattern)))
319 (:attribute name-class { pattern }
320 (lambda* (nil name nil pattern nil)
321 `(with-attribute (:name ,name) ,pattern)))
322 (:list { pattern }
323 (lambda* (nil nil pattern nil)
324 `(list ,pattern)))
325 (:mixed { pattern }
326 (lambda* (nil nil pattern nil)
327 `(mixed ,pattern)))
328 (identifier (lambda* (x)
329 `(ref ,x)))
330 (:parent identifier
331 (lambda* (nil x)
332 `(parent-ref ,x)))
333 (:empty)
334 (:text)
335 (data-type-name [params]
336 (lambda* (name params)
337 `(data :data-type ,name :params ,params)))
338 (data-type-name data-type-value
339 (lambda* (name value)
340 `(value :data-type ,name :value ,value)))
341 (data-type-value (lambda* (value)
342 `(value :data-type nil :value ,value)))
343 (:notallowed)
344 (:external any-uri-literal [inherit]
345 (lambda* (nil uri inherit)
346 `(external-ref :uri ,uri :inherit ,inherit)))
347 (:grammar { grammar-content* }
348 (lambda* (nil nil content nil)
349 `(with-grammar () ,@content)))
350 (\( pattern \) (lambda* (nil p nil) p)))
352 (data-except (data-type-name [params] - lead-annotated-primary
353 (lambda* (name params nil p)
354 `(data :data-type ,name
355 :params ,params
356 :except ,p))))
358 (inner-particle (annotated-primary
359 (lambda* (p) `(%with-annotations-group ,p)))
360 (repeated-primary follow-annotations
361 (lambda* (a b)
362 `(progn
363 (%with-annotations ,a)
364 ,b))))
366 (repeated-primary (annotated-primary *
367 (lambda* (p nil) `(zero-or-more ,p)))
368 (annotated-primary +
369 (lambda* (p nil) `(one-or-more ,p)))
370 (annotated-primary ?
371 (lambda* (p nil) `(optional ,p))))
373 (annotated-primary (lead-annotated-primary follow-annotations
374 (lambda* (a b)
375 `(progn ,a ,b))))
377 (annotated-data-except (lead-annotated-data-except follow-annotations
378 (lambda* (a b)
379 `(progn ,a ,b))))
381 (lead-annotated-data-except data-except
382 (annotations data-except
383 (lambda* (a p)
384 `(with-annotations ,a ,p))))
386 (lead-annotated-primary primary
387 (annotations primary
388 (lambda* (a p)
389 `(with-annotations ,a ,p)))
390 (\( inner-pattern \)
391 (lambda* (nil p nil) p))
392 (annotations \( inner-pattern \)
393 (lambda* (a nil p nil)
394 `(let-annotations ,a ,p))))
396 (particle-choice (particle \| particle
397 (lambda* (a nil b) `(choice ,a ,b)))
398 (particle \| particle-choice
399 (lambda* (a nil b) `(choice ,a ,@(cdr b)))))
401 (particle-group (particle \, particle
402 (lambda* (a nil b) `(group ,a ,b)))
403 (particle \, particle-group
404 (lambda* (a nil b) `(group ,a ,@(cdr b)))))
406 (particle-interleave (particle \& particle
407 (lambda* (a nil b) `(interleave ,a ,b)))
408 (particle \& particle-interleave
409 (lambda* (a nil b) `(interleave ,a ,@(cdr b)))))
411 (param (identifier-or-keyword = literal
412 (lambda* (name nil value)
413 `(param ,name ,value)))
414 (annotations identifier-or-keyword = literal
415 (lambda* (a name nil value)
416 `(with-annotations ,a (param ,name ,value)))))
418 (grammar-content* ()
419 (member grammar-content* #'cons))
421 (member annotated-component
422 annotated-element-not-keyword)
424 (annotated-component component
425 (annotations component
426 (lambda* (a c)
427 `(with-annotations ,a ,c))))
429 (component start
430 define
431 (:div { grammar-content* }
432 (lambda* (nil nil content nil)
433 `(with-div ,@content)))
434 (:include any-uri-literal [inherit] [include-content]
435 (lambda* (nil uri inherit content)
436 `(with-include (:inherit ,inherit :uri ,uri)
437 ,@content))))
439 (include-content* ()
440 (include-member include-content* #'cons))
442 (include-member annotated-include-component
443 annotation-element-not-keyword)
445 (annotated-include-component include-component
446 (annotations include-component
447 (lambda* (a c)
448 `(with-annotations (,@a) ,c))))
450 (include-component start
451 define
452 (:div { grammar-content* }
453 (lambda* (nil nil content nil)
454 `(with-div ,@content))))
456 (start (:start assign-method pattern
457 (lambda* (nil method pattern)
458 `(with-start (:combine-method ,method) ,pattern))))
460 (define (identifier assign-method pattern
461 (lambda* (name method pattern)
462 `(with-definition (:name ,name :combine-method ,method)
463 ,pattern))))
465 (assign-method (= (constantly nil))
466 (\|= (constantly "choice"))
467 (&= (constantly "interleave")))
469 (name-class (inner-name-class (lambda (nc) `(without-annotations ,nc))))
471 (inner-name-class (annotated-simple-nc
472 (lambda (nc) `(%with-annotations-choice ,nc)))
473 (nc-choice
474 (lambda (nc) `(%with-annotations ,nc)))
475 (annotated-nc-except
476 (lambda (nc) `(%with-annotations-choice ,nc))))
478 (simple-nc (name (lambda* (n) `(name ,n)))
479 (ns-name (lambda* (n) `(ns-name ,n)))
480 (* (constantly `(any-name)))
481 (\( name-class \) (lambda* (nil nc nil) nc)))
483 (follow-annotations ()
484 (>> annotation-element follow-annotations))
486 (annotations #+nil ()
487 (documentations
488 (lambda (e)
489 `(annotation :elements ,e)))
490 ([ annotation-attributes annotation-elements ]
491 (lambda* (nil a e nil)
492 `(annotation :attributes ,a :elements ,e)))
493 (documentations [ annotation-attributes annotation-elements ]
494 (lambda* (d nil a e nil)
495 `(annotation :attributes ,a
496 :elements ,(append e d)))))
498 (annotation-attributes
499 ((constantly '(annotation-attributes)))
500 (foreign-attribute-name = literal annotation-attributes
501 (lambda* (name nil value rest)
502 `(annotation-attributes
503 (annotation-attribute ,name ,value)
504 ,@(cdr rest)))))
506 (foreign-attribute-name prefixed-name)
508 (annotation-elements ()
509 (annotation-element annotation-elements #'cons))
511 (annotation-element (foreign-element-name annotation-attributes-content
512 (lambda (a b)
513 `(with-annotation-element
514 (:name ,a)
515 ,b))))
517 (foreign-element-name identifier-or-keyword
518 prefixed-name)
520 (annotation-element-not-keyword (foreign-element-name-not-keyword
521 annotation-attributes-content
522 (lambda (a b)
523 `(with-annotation-element
524 (:name ,a)
525 ,b))))
527 (foreign-element-name-not-keyword identifier prefixed-name)
529 (annotation-attributes-content ([ nested-annotation-attributes
530 annotation-content ]))
532 (nested-annotation-attributes
533 ((constantly '(annotation-attributes)))
534 (any-attribute-name = literal
535 nested-annotation-attributes
536 (lambda* (name nil value rest)
537 `(annotation-attributes
538 (annotation-attribute ,name ,value)
539 ,@(cdr rest)))))
541 (any-attribute-name identifier-or-keyword prefixed-name)
543 (annotation-content ()
544 (nested-annotation-element annotation-content #'cons)
545 (literal annotation-content #'cons))
547 (nested-annotation-element (any-element-name annotation-attributes-content
548 (lambda (a b)
549 `(with-annotation-element
550 (:name ,a)
551 ,b))))
553 (any-element-name identifier-or-keyword prefixed-name)
555 (prefixed-name cname)
557 (documentations (documentation)
558 (documentation documentations #'cons))
560 (documentation documentation-line
561 (documentation-line documentation
562 (lambda (a b)
563 (concatenate 'string a b))))
565 (annotated-nc-except (lead-annotated-nc-except
566 follow-annotations
567 (lambda (p a)
568 `(progn ,p ,a))))
570 (lead-annotated-nc-except nc-except
571 (annotations nc-except
572 (lambda (a p)
573 `(with-annotations ,a ,p))))
575 (annotated-simple-nc (lead-annotated-simple-nc
576 follow-annotations
577 (lambda (p a) `(progn ,p ,a))))
579 (lead-annotated-simple-nc
580 simple-nc
581 (\( inner-name-class \) (lambda* (nil nc nil) nc))
582 (annotations simple-nc
583 (lambda (a nc) `(with-annotations ,a ,nc)))
584 (annotations \( inner-name-class \)
585 (lambda (a nc) `(let-annotations ,a ,nc))))
587 (nc-except (ns-name - simple-nc
588 (lambda* (nc1 nil nc2) `(ns-name ,nc1 :except ,nc2)))
589 (* - simple-nc
590 (lambda* (nil nil nc) `(any-name :except ,nc))))
592 (nc-choice (annotated-simple-nc \| annotated-simple-nc
593 (lambda* (a nil b)
594 `(name-choice ,a ,b)))
595 (annotated-simple-nc \| nc-choice
596 (lambda* (a nil b)
597 `(name-choice ,a ,@(cdr b)))))
599 (name identifier-or-keyword cname)
601 (data-type-name cname :string :token)
603 (data-type-value literal)
604 (any-uri-literal literal)
606 (namespace-uri-literal literal :inherit)
608 (inherit (:inherit = identifier-or-keyword
609 (lambda* (nil nil x) x)))
611 (identifier-or-keyword identifier keyword)
613 ;; identifier ::= (ncname - keyword) | quotedidentifier
614 ;; quotedidentifier ::= "\" ncname
616 ;; (ns-name (ncname \:*))
617 (ns-name nsname)
619 (ncname identifier-or-keyword)
621 (literal literal-segment
622 (literal-segment ~ literal
623 (lambda* (a nil b)
624 (concatenate 'string a b))))
626 ;; literalsegment ::= ...
628 (keyword :attribute :default :datatypes :div :element :empty :external
629 :grammar :include :inherit :list :mixed :namespace :notAllowed
630 :parent :start :string :text :token)
632 ;; optional stuff
633 ([data-type-name] () data-type-name)
634 ([inherit] () inherit)
635 ([params] () ({ params } (lambda* (nil p nil) p)))
636 (params () (param params #'cons))
637 ([include-content] () ({ include-content* }
638 (lambda* (nil content nil) content))))
641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
642 ;;;; Conversion of sexps into SAX
643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
645 (defun uncompact (list)
646 (funcall (or (get (car list) 'uncompactor)
647 (error "no uncompactor for ~A" (car list)))
648 (cdr list)))
650 (defmacro define-uncompactor (name (&rest args) &body body)
651 `(setf (get ',name 'uncompactor)
652 (lambda (.form.) (destructuring-bind ,args .form. ,@body))))
654 (defparameter *namespaces* '(("xml" . "http://www.w3.org/XML/1998/namespace")))
655 (defparameter *default-namespace* nil)
656 (defparameter *data-types*
657 '(("xsd" . "http://www.w3.org/2001/XMLSchema-datatypes")))
659 (defun xor (a b)
660 (if a (not b) b))
662 (defun lookup-prefix (prefix)
663 (cdr (assoc prefix *namespaces* :test 'equal)))
665 (defun lookup-default ()
666 (or *default-namespace* :inherit))
668 (defun lookup-data-type (name)
669 (cdr (assoc name *data-types* :test 'equal)))
671 (define-uncompactor with-namespace ((&key uri name default) &body body)
672 (when (xor (equal name "xml")
673 (equal uri "http://www.w3.org/XML/1998/namespace"))
674 (rng-error nil "invalid redeclaration of `xml' namespace"))
675 (when (equal name "xmlns")
676 (rng-error nil "invalid declaration of `xmlns' namespace"))
677 (let ((*namespaces* *namespaces*)
678 (*default-namespace* *default-namespace*))
679 (when name
680 (when (lookup-prefix name)
681 (rng-error nil "duplicate declaration of prefix ~A" name))
682 (push (cons name uri) *namespaces*))
683 (when default
684 (when *default-namespace*
685 (rng-error nil "default namespace already declared to ~A"
686 *default-namespace*))
687 (push (cons "" uri) *namespaces*)
688 (setf *default-namespace* uri))
689 (if (and name (not (or (eq uri :inherit) (equal uri ""))))
690 (cxml:with-namespace (name uri)
691 (mapc #'uncompact body))
692 (mapc #'uncompact body))))
694 (define-uncompactor with-data-type ((&key name uri) &body body)
695 (when (and (equal name "xsd")
696 (not (equal uri "http://www.w3.org/2001/XMLSchema-datatypes")))
697 (rng-error nil "invalid redeclaration of `xml' namespace"))
698 (when (and (lookup-data-type name) (not (equal name "xsd")))
699 (rng-error nil "duplicate declaration of library ~A" name))
700 (let ((*data-types* (acons name uri *data-types*)))
701 (mapc #'uncompact body)))
703 (defparameter *annotation-attributes* nil)
704 (defparameter *annotation-elements* nil)
705 (defparameter *annotation-wrap* nil)
707 (defmacro with-element (name-and-args &body body)
708 (destructuring-bind (prefix lname &rest args)
709 (if (atom name-and-args)
710 (list nil name-and-args)
711 name-and-args)
712 `(invoke-with-element ,prefix
713 ,lname
714 (lambda () ,@args)
715 (lambda () ,@body))))
717 (defun invoke-with-element (prefix lname args body)
718 (if (and *annotation-attributes*
719 *annotation-wrap*)
720 (cxml:with-element* (nil *annotation-wrap*)
721 (let ((*annotation-wrap* nil))
722 (invoke-with-element prefix lname args body)))
723 (let ((*annotation-wrap* nil))
724 (cxml:with-element* (prefix lname)
725 (funcall args)
726 (when *annotation-attributes*
727 (uncompact *annotation-attributes*))
728 (dolist (elt *annotation-elements*)
729 (cxml:with-namespace
730 ("a" "http://relaxng.org/ns/compatibility/annotations/1.0")
731 (cxml:with-element* ("a" "documentation")
732 (cxml:text elt))))
733 (funcall body)))))
735 (define-uncompactor with-grammar ((&optional) &body body)
736 (with-element "grammar"
737 (mapc #'uncompact body)))
739 (define-uncompactor with-start ((&key combine-method) &body body)
740 (with-element (nil "start"
741 (cxml:attribute "combine" combine-method))
742 (mapc #'uncompact body)))
744 (define-uncompactor ref (name)
745 (with-element (nil "ref"
746 (cxml:attribute "name" name))))
748 (define-uncompactor parent-ref (name)
749 (with-element (nil "parentRef"
750 (cxml:attribute "name" name))))
752 (define-uncompactor parent-ref (name)
753 (with-element (nil "parentRef" (cxml:attribute "name" name))))
755 (defun ns-attribute (uri-or-inherit)
756 (unless (eq uri-or-inherit :inherit)
757 (cxml:attribute "ns" uri-or-inherit)))
759 (define-uncompactor external-ref (&key uri inherit)
760 (let ((ns (if inherit (lookup-prefix inherit) (lookup-default))))
761 (with-element (nil "externalRef"
762 (cxml:attribute "href" (munge-schema-ref uri))
763 (ns-attribute ns)))))
765 (defvar *elementp*)
767 (define-uncompactor with-element ((&key name) pattern)
768 (with-element "element"
769 (let ((*elementp* t))
770 (uncompact name))
771 (uncompact pattern)))
773 (define-uncompactor with-attribute ((&key name) pattern)
774 (with-element "attribute"
775 (let ((*elementp* nil))
776 (uncompact name))
777 (uncompact pattern)))
779 (define-uncompactor list (pattern)
780 (with-element "list"
781 (uncompact pattern)))
783 (define-uncompactor mixed (pattern)
784 (with-element "mixed"
785 (uncompact pattern)))
787 (define-uncompactor :empty ()
788 (with-element "empty"))
790 (define-uncompactor :text ()
791 (with-element "text"))
793 (defun uncompact-data-type (data-type)
794 (case data-type
795 (:string
796 (cxml:attribute "datatypeLibrary" "")
797 (cxml:attribute "type" "string"))
798 (:token
799 (cxml:attribute "datatypeLibrary" "")
800 (cxml:attribute "type" "token"))
802 (cxml:attribute "datatypeLibrary"
803 (lookup-data-type (car data-type)))
804 (cxml:attribute "type" (cdr data-type)))))
806 (define-uncompactor data (&key data-type params except)
807 (with-element (nil "data" (uncompact-data-type data-type))
808 (mapc #'uncompact params)
809 (when except
810 (with-element "except"
811 (uncompact except)))))
813 (define-uncompactor value (&key data-type value)
814 (with-element (nil "value" (uncompact-data-type data-type))
815 (cxml:text value)))
817 (define-uncompactor :notallowed ()
818 (with-element "notAllowed"))
820 (define-uncompactor with-definition ((&key name combine-method) &body body)
821 (with-element (nil "define"
822 (cxml:attribute "name" name)
823 (cxml:attribute "combine" combine-method))
824 (mapc #'uncompact body)))
826 (define-uncompactor with-div (&body body)
827 (with-element "div"
828 (mapc #'uncompact body)))
830 (define-uncompactor any-name (&key except)
831 (with-element "anyName"
832 (when except
833 (with-element "except"
834 (uncompact except)))))
836 (define-uncompactor ns-name (nc &key except)
837 (with-element (nil "nsName"
838 (ns-attribute (lookup-prefix nc)))
839 (when except
840 (with-element "except"
841 (uncompact except)))))
843 (define-uncompactor name-choice (&rest ncs)
844 (with-element "choice"
845 (mapc #'uncompact ncs)))
847 (defun destructure-cname-like (x)
848 (when (keywordp x)
849 (setf x (find x *keywords* :test 'string-equal)))
850 (when (atom x)
851 (setf x (cons (if *elementp* "" nil)
852 x)))
853 (values (lookup-prefix (car x))
854 (cdr x)))
856 (define-uncompactor name (x)
857 (multiple-value-bind (uri lname) (destructure-cname-like x)
858 (with-element (nil
859 "name"
860 (ns-attribute uri))
861 (cxml:text lname))))
863 (define-uncompactor choice (&rest body)
864 (with-element "choice"
865 (mapc #'uncompact body)))
867 (define-uncompactor group (&rest body)
868 (with-element "group"
869 (mapc #'uncompact body)))
871 (define-uncompactor interleave (&rest body)
872 (with-element "interleave"
873 (mapc #'uncompact body)))
875 (define-uncompactor one-or-more (p)
876 (with-element "oneOrMore"
877 (uncompact p)))
879 (define-uncompactor optional (p)
880 (with-element "optional"
881 (uncompact p)))
883 (define-uncompactor zero-or-more (p)
884 (with-element "zeroOrMore"
885 (uncompact p)))
887 (defun munge-schema-ref (uri)
888 (if (search "://" uri)
889 (concatenate 'string "rnc+" uri)
890 (concatenate 'string "rnc+://" uri)))
892 (defun rnc-uri-p (uri)
893 (and (search "://" uri)
894 (equal (mismatch "rnc+" uri) 4)))
896 (defun follow-rnc-uri (uri)
897 (if (equal (mismatch "rnc+://" uri) 7)
898 ;; rnc+://foo/bar
899 (subseq uri 7)
900 ;; rnc+file:///usr/foo/...
901 (subseq uri 4)))
903 (define-uncompactor with-include ((&key inherit uri) &body body)
904 (let ((ns (if inherit (lookup-prefix inherit) (lookup-default))))
905 (with-element (nil "include"
906 (cxml:attribute "href" (munge-schema-ref uri))
907 (ns-attribute ns))
908 (mapc #'uncompact body))))
910 (define-uncompactor with-annotations
911 ((annotation &key attributes elements) &body body)
912 (check-type annotation (member annotation))
913 (let ((*annotation-attributes* attributes)
914 (*annotation-elements* elements))
915 (mapc #'uncompact body)))
917 (define-uncompactor without-annotations (&body body)
918 (let ((*annotation-attributes* nil)
919 (*annotation-elements* nil))
920 (mapc #'uncompact body)))
922 ;; zzz das kann weg
923 (define-uncompactor %with-annotations (&body body)
924 (mapc #'uncompact body))
926 (define-uncompactor %with-annotations-group (&body body)
927 (let ((*annotation-wrap* "group"))
928 (mapc #'uncompact body)))
930 (define-uncompactor %with-annotations-choice (&body body)
931 (let ((*annotation-wrap* "choice"))
932 (mapc #'uncompact body)))
934 (define-uncompactor progn (a b)
935 (when a (uncompact a))
936 (when b (uncompact b)))
938 (define-uncompactor annotation-attributes (&rest attrs)
939 (mapc #'uncompact attrs))
941 (define-uncompactor annotation-attribute (name value)
942 (cxml:attribute* (car name) (cdr name) value))
944 (define-uncompactor param (name value)
945 (with-element (nil "param"
946 (cxml:attribute "name" name))
947 (cxml:text value)))
949 (define-uncompactor with-annotation-element ((&key name) &body attrs)
950 (cxml:with-element name
951 (mapc #'uncompact attrs)))
953 ;;; zzz strip BOM
954 ;;; zzz newline normalization: Wir lesen von einem character-stream, daher
955 ;;; macht das schon das Lisp fuer uns -- je nach Plattform. Aber nicht richtig.
956 (defun uncompact-file-1 (stream)
957 (handler-case
958 (let ((lexer (make-rng-lexer
959 (make-instance 'hex-stream :source stream))))
960 (yacc:parse-with-lexer
961 (lambda ()
962 (multiple-value-bind (cat sem) (funcall lexer)
963 #+nil (print (list cat sem))
964 (if (eq cat :eof)
966 (values cat sem))))
967 *compact-parser*))
968 (error (c)
969 (rng-error nil
970 "failed to parse compact syntax at char ~A, ~A:~% ~A"
971 (file-position stream)
972 (cxml::safe-stream-sysid stream)
973 c))))
975 (defun uncompact-file (input &optional stream)
976 (let ((tree
977 (etypecase input
978 (pathname (with-open-file (s input) (uncompact-file-1 s)))
979 (stream (with-open-stream (s input) (uncompact-file-1 s))))))
980 #+nil (print tree)
981 (with-output-to-string (s)
982 (cxml:with-xml-output
983 (if stream
984 (cxml:make-octet-stream-sink stream)
985 (cxml:make-character-stream-sink s))
986 (cxml:with-namespace ("" "http://relaxng.org/ns/structure/1.0")
987 (uncompact tree))))))
989 (defun parse-compact (pathname)
990 "@arg[pathname]{a pathname designator for a Relax NG compact file}
991 @return{a parsed @class{schema}}
992 @short{This function parses a Relax NG schema file in compact syntax}
993 and returns a parsed representation of that schema.
995 @see{parse-schema}
996 @see{make-validator}"
997 (parse-schema (named-string-xstream
998 (uncompact-file pathname)
999 (cxml::pathname-to-uri pathname))))
1001 (defun test-compact ()
1002 (dolist (p (directory "/home/david/src/nxml-mode-20041004/schema/*.rnc"))
1003 (print p)
1004 (with-open-file (s (make-pathname :type "rng" :defaults p)
1005 :direction :output
1006 :if-exists :supersede)
1007 (uncompact-file p s))))
1009 #+(or)
1010 (compact)