Compact syntax parsing fixes
[cxml-rng.git] / compact.lisp
blobe5c4cb99b8c2417bf11a1e809b4a5e2b3069b09e
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 :eof)))
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 (defun nc-name-p (str)
115 (and (cxml-types::namep str) (cxml::nc-name-p str)))
117 (cxml-clex:deflexer rng
119 ;; NCName
120 (letter+extras
121 (or (range #x0041 #x005A) (range #x0061 #x007A)
122 ;; just allow the rest of unicode, because clex can't deal with the
123 ;; complete definition of name-char:
124 (range #x00c0 #xd7ff)
125 (range #xe000 #xfffd)
126 (range #x10000 #x10ffff)))
127 (digit (range #x0030 #x0039)) ;ditto
128 (name-start-char (or letter+extras #\_))
129 (name-char (or letter+extras digit #\. #\- #\_ #\:))
131 ;; some RNC ranges
132 (char
133 (or 9 10 13
134 (range 32 #xd7ff)
135 (range #xe000 #xfffd)
136 (range #x10000 #x10ffff)))
137 (init-comment-char
138 (or 9 32 33 34
139 ;; #\#
140 (range 36 #xd7ff)
141 (range #xe000 #xfffd)
142 (range #x10000 #x10ffff)))
143 (comment-char
144 (or 35 init-comment-char))
145 (string-char
146 (or 32 33
147 ;; #\"
148 (range 35 38)
149 ;; #\'
150 (range 40 #xd7ff)
151 (range #xe000 #xfffd)
152 (range #x10000 #x10ffff)))
153 (space (or 9 10 13 32))
154 (newline (or 10 13)))
156 ((* space))
158 ((and "##") (cxml-clex:begin 'documentation-line))
159 ((and "##" newline))
160 ((cxml-clex::in documentation-line newline) (cxml-clex:begin 'cxml-clex:initial))
161 ((cxml-clex::in documentation-line comment-char)
162 (return (values 'documentation-line cxml-clex:bag)))
164 ((and #\# init-comment-char) (cxml-clex:begin 'comment))
165 ((and #\# newline))
166 ((cxml-clex::in comment newline) (cxml-clex:begin 'cxml-clex:initial))
167 ((cxml-clex::in comment comment-char))
169 ((and "'''" (* (or string-char #\' #\")) "'''")
170 (return
171 (values 'literal-segment (subseq cxml-clex:bag 3 (- (length cxml-clex:bag) 3)))))
173 ((and #\' (* (or string-char #\")) #\')
174 (when (or (find (code-char 13) cxml-clex:bag)
175 (find (code-char 10) cxml-clex:bag))
176 (rng-error nil "disallowed newline in string literal"))
177 (return
178 (values 'literal-segment (subseq cxml-clex:bag 1 (- (length cxml-clex:bag) 1)))))
180 ((and #\" #\" #\" (* (or string-char #\' #\")) #\" #\" #\")
181 (return
182 (values 'literal-segment (subseq cxml-clex:bag 3 (- (length cxml-clex:bag) 3)))))
184 ((and #\" (* (or string-char #\')) #\")
185 (when (or (find (code-char 13) cxml-clex:bag)
186 (find (code-char 10) cxml-clex:bag))
187 (rng-error nil "disallowed newline in string literal"))
188 (return
189 (values 'literal-segment (subseq cxml-clex:bag 1 (- (length cxml-clex:bag) 1)))))
191 ((and name-start-char (* name-char))
192 (return
193 (cond
194 ((find cxml-clex:bag *keywords* :test #'equal)
195 (let ((sym (intern (string-upcase cxml-clex:bag) :keyword)))
196 (values sym sym)))
197 ((find #\: cxml-clex:bag)
198 (let* ((pos (position #\: cxml-clex:bag))
199 (prefix (subseq cxml-clex:bag 0 pos))
200 (lname (subseq cxml-clex:bag (1+ pos ))))
201 (when (find #\: lname)
202 (rng-error nil "too many colons"))
203 (unless (and (nc-name-p prefix))
204 (rng-error nil "not an ncname: ~A" prefix))
205 (let ((ch (cxml-clex::getch)))
206 (cond
207 ((and (equal lname "") (eql ch #\*))
208 (values 'nsname prefix))
210 (cxml-clex::backup ch)
211 (unless (and (nc-name-p lname))
212 (rng-error nil "not an ncname: ~A" lname))
213 (values 'cname (cons prefix lname)))))))
215 (unless (nc-name-p cxml-clex:bag)
216 (rng-error nil "not an ncname: ~A" cxml-clex:bag))
217 (values 'identifier cxml-clex:bag)))))
219 ((and #\\ name-start-char (* name-char))
220 (let ((str (subseq cxml-clex:bag 1)))
221 (unless (nc-name-p str)
222 (rng-error nil "not an ncname: ~A" cxml-clex:bag))
223 (return (values 'identifier str))))
225 (#\= (double '=))
226 (#\{ (double '{))
227 (#\} (double '}))
228 (#\[ (double '[))
229 (#\] (double ']))
230 (#\, (double '|,|))
231 (#\& (double '&))
232 (#\| (double '|\||))
233 (#\? (double '?))
234 (#\* (double '*))
235 (#\+ (double '+))
236 (#\( (double '|(|))
237 (#\) (double '|)|))
238 ((and "|=") (double '|\|=|))
239 ((and "&=") (double '&=))
240 ((and ">>") (double '>>))
241 (#\~ (double '~))
242 (#\- (double '-)))
245 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246 ;;;; Parsing into S-Expressions
247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
249 (eval-when (:compile-toplevel :load-toplevel :execute)
250 #+(or)
251 (defmacro lambda* ((&rest args) &body body)
252 (setf args (mapcar (lambda (arg) (or arg (gensym))) args))
253 `(lambda (,@args)
254 (declare (ignorable ,@args))
255 ,@body))
257 (defmacro lambda* ((&rest args) &body body)
258 (setf args (mapcar (lambda (arg) (or arg (gensym))) args))
259 `(lambda (&rest .args.)
260 (unless (equal (length .args.) ,(length args))
261 (error "expected ~A, got ~A" ',args .args.))
262 (destructuring-bind (,@args) .args.
263 (declare (ignorable ,@args))
264 ,@body)))
266 (defun wrap-decls (decls content)
267 (if decls
268 `(,@(car decls)
269 ,(wrap-decls (cadr decls) content))
270 content)))
272 (yacc:define-parser *compact-parser*
273 (:start-symbol top-level)
274 (:terminals (:attribute :default :datatypes :div :element :empty
275 :external :grammar :include :inherit :list
276 :mixed :namespace :notAllowed :parent :start
277 :string :text :token
278 = { } |,| & |\|| ? * + |(| |)| |\|=| &= ~ -
279 [ ] >>
280 identifier literal-segment cname nsname
281 documentation-line))
282 #+debug (:print-first-terminals t)
283 #+debug (:print-states t)
284 #+debug (:print-lookaheads t)
285 #+debug (:print-goto-graph t)
286 (:muffle-conflicts (50 0)) ;hrmpf
288 (top-level (decl* pattern #'wrap-decls)
289 (decl* grammar-content*
290 (lambda (a b) (wrap-decls a `(with-grammar () ,@b)))))
292 (decl* () (decl decl*))
294 (decl (:namespace identifier-or-keyword = namespace-uri-literal
295 (lambda* (nil name nil uri)
296 `(with-namespace (:uri ,uri :name ,name))))
297 (:default :namespace = namespace-uri-literal
298 (lambda* (nil nil nil uri)
299 `(with-namespace (:uri ,uri :default t))))
300 (:default :namespace identifier-or-keyword = namespace-uri-literal
301 (lambda* (nil nil name nil uri)
302 `(with-namespace (:uri ,uri :name ,name :default t))))
303 (:datatypes identifier-or-keyword = literal
304 (lambda* (nil name nil uri)
305 `(with-data-type (:name ,name :uri ,uri)))))
307 (pattern (inner-pattern
308 (lambda* (p) `(without-annotations ,p))))
310 (particle (inner-particle
311 (lambda* (p) `(without-annotations ,p))))
313 (inner-pattern inner-particle
314 (particle-choice (lambda* (p) `(%with-annotations ,p)))
315 (particle-group (lambda* (p) `(%with-annotations ,p)))
316 (particle-interleave (lambda* (p) `(%with-annotations ,p)))
317 (data-except (lambda* (p) `(%with-annotations-group ,p))))
319 (primary (:element name-class { pattern }
320 (lambda* (nil name nil pattern nil)
321 `(with-element (:name ,name) ,pattern)))
322 (:attribute name-class { pattern }
323 (lambda* (nil name nil pattern nil)
324 `(with-attribute (:name ,name) ,pattern)))
325 (:list { pattern }
326 (lambda* (nil nil pattern nil)
327 `(list ,pattern)))
328 (:mixed { pattern }
329 (lambda* (nil nil pattern nil)
330 `(mixed ,pattern)))
331 (identifier (lambda* (x)
332 `(ref ,x)))
333 (:parent identifier
334 (lambda* (nil x)
335 `(parent-ref ,x)))
336 (:empty)
337 (:text)
338 (data-type-name [params]
339 (lambda* (name params)
340 `(data :data-type ,name :params ,params)))
341 (data-type-name data-type-value
342 (lambda* (name value)
343 `(value :data-type ,name :value ,value)))
344 (data-type-value (lambda* (value)
345 `(value :data-type nil :value ,value)))
346 (:notallowed)
347 (:external any-uri-literal [inherit]
348 (lambda* (nil uri inherit)
349 `(external-ref :uri ,uri :inherit ,inherit)))
350 (:grammar { grammar-content* }
351 (lambda* (nil nil content nil)
352 `(with-grammar () ,@content)))
353 (\( pattern \) (lambda* (nil p nil) p)))
355 (data-except (data-type-name [params] - lead-annotated-primary
356 (lambda* (name params nil p)
357 `(data :data-type ,name
358 :params ,params
359 :except ,p))))
361 (inner-particle (annotated-primary
362 (lambda* (p) `(%with-annotations-group ,p)))
363 (repeated-primary follow-annotations
364 (lambda* (a b)
365 `(progn
366 (%with-annotations ,a)
367 ,b))))
369 (repeated-primary (annotated-primary *
370 (lambda* (p nil) `(zero-or-more ,p)))
371 (annotated-primary +
372 (lambda* (p nil) `(one-or-more ,p)))
373 (annotated-primary ?
374 (lambda* (p nil) `(optional ,p))))
376 (annotated-primary (lead-annotated-primary follow-annotations
377 (lambda* (a b)
378 `(progn ,a ,b))))
380 (annotated-data-except (lead-annotated-data-except follow-annotations
381 (lambda* (a b)
382 `(progn ,a ,b))))
384 (lead-annotated-data-except data-except
385 (annotations data-except
386 (lambda* (a p)
387 `(with-annotations ,a ,p))))
389 (lead-annotated-primary primary
390 (annotations primary
391 (lambda* (a p)
392 `(with-annotations ,a ,p)))
393 (\( inner-pattern \)
394 (lambda* (nil p nil) p))
395 (annotations \( inner-pattern \)
396 (lambda* (a nil p nil)
397 `(let-annotations ,a ,p))))
399 (particle-choice (particle \| particle
400 (lambda* (a nil b) `(choice ,a ,b)))
401 (particle \| particle-choice
402 (lambda* (a nil b) `(choice ,a ,@(cdr b)))))
404 (particle-group (particle \, particle
405 (lambda* (a nil b) `(group ,a ,b)))
406 (particle \, particle-group
407 (lambda* (a nil b) `(group ,a ,@(cdr b)))))
409 (particle-interleave (particle \& particle
410 (lambda* (a nil b) `(interleave ,a ,b)))
411 (particle \& particle-interleave
412 (lambda* (a nil b) `(interleave ,a ,@(cdr b)))))
414 (param (identifier-or-keyword = literal
415 (lambda* (name nil value)
416 `(param ,name ,value)))
417 (annotations identifier-or-keyword = literal
418 (lambda* (a name nil value)
419 `(with-annotations ,a (param ,name ,value)))))
421 (grammar-content* ()
422 (member grammar-content* #'cons))
424 (member annotated-component
425 annotated-element-not-keyword)
427 (annotated-component component
428 (annotations component
429 (lambda* (a c)
430 `(with-annotations ,a ,c))))
432 (component start
433 define
434 (:div { grammar-content* }
435 (lambda* (nil nil content nil)
436 `(with-div ,@content)))
437 (:include any-uri-literal [inherit] [include-content]
438 (lambda* (nil uri inherit content)
439 `(with-include (:inherit ,inherit :uri ,uri)
440 ,@content))))
442 (include-content* ()
443 (include-member include-content* #'cons))
445 (include-member annotated-include-component
446 annotation-element-not-keyword)
448 (annotated-include-component include-component
449 (annotations include-component
450 (lambda* (a c)
451 `(with-annotations (,@a) ,c))))
453 (include-component start
454 define
455 (:div { grammar-content* }
456 (lambda* (nil nil content nil)
457 `(with-div ,@content))))
459 (start (:start assign-method pattern
460 (lambda* (nil method pattern)
461 `(with-start (:combine-method ,method) ,pattern))))
463 (define (identifier assign-method pattern
464 (lambda* (name method pattern)
465 `(with-definition (:name ,name :combine-method ,method)
466 ,pattern))))
468 (assign-method (= (constantly nil))
469 (\|= (constantly "choice"))
470 (&= (constantly "interleave")))
472 (name-class (inner-name-class (lambda (nc) `(without-annotations ,nc))))
474 (inner-name-class (annotated-simple-nc
475 (lambda (nc) `(%with-annotations-choice ,nc)))
476 (nc-choice
477 (lambda (nc) `(%with-annotations ,nc)))
478 (annotated-nc-except
479 (lambda (nc) `(%with-annotations-choice ,nc))))
481 (simple-nc (name (lambda* (n) `(name ,n)))
482 (ns-name (lambda* (n) `(ns-name ,n)))
483 (* (constantly `(any-name)))
484 (\( name-class \) (lambda* (nil nc nil) nc)))
486 (follow-annotations ()
487 (>> annotation-element follow-annotations))
489 (annotations #+nil ()
490 (documentations
491 (lambda (e)
492 `(annotation :elements ,e)))
493 ([ annotation-attributes annotation-elements ]
494 (lambda* (nil a e nil)
495 `(annotation :attributes ,a :elements ,e)))
496 (documentations [ annotation-attributes annotation-elements ]
497 (lambda* (d nil a e nil)
498 `(annotation :attributes ,a
499 :elements ,(append e d)))))
501 (annotation-attributes
502 ((constantly '(annotation-attributes)))
503 (foreign-attribute-name = literal annotation-attributes
504 (lambda* (name nil value rest)
505 `(annotation-attributes
506 (annotation-attribute ,name ,value)
507 ,@(cdr rest)))))
509 (foreign-attribute-name prefixed-name)
511 (annotation-elements ()
512 (annotation-element annotation-elements #'cons))
514 (annotation-element (foreign-element-name annotation-attributes-content
515 (lambda (a b)
516 `(with-annotation-element
517 (:name ,a)
518 ,b))))
520 (foreign-element-name identifier-or-keyword
521 prefixed-name)
523 (annotation-element-not-keyword (foreign-element-name-not-keyword
524 annotation-attributes-content
525 (lambda (a b)
526 `(with-annotation-element
527 (:name ,a)
528 ,b))))
530 (foreign-element-name-not-keyword identifier prefixed-name)
532 (annotation-attributes-content ([ nested-annotation-attributes
533 annotation-content ]))
535 (nested-annotation-attributes
536 ((constantly '(annotation-attributes)))
537 (any-attribute-name = literal
538 nested-annotation-attributes
539 (lambda* (name nil value rest)
540 `(annotation-attributes
541 (annotation-attribute ,name ,value)
542 ,@(cdr rest)))))
544 (any-attribute-name identifier-or-keyword prefixed-name)
546 (annotation-content ()
547 (nested-annotation-element annotation-content #'cons)
548 (literal annotation-content #'cons))
550 (nested-annotation-element (any-element-name annotation-attributes-content
551 (lambda (a b)
552 `(with-annotation-element
553 (:name ,a)
554 ,b))))
556 (any-element-name identifier-or-keyword prefixed-name)
558 (prefixed-name cname)
560 (documentations (documentation)
561 (documentation documentations #'cons))
563 (documentation documentation-line
564 (documentation-line documentation
565 (lambda (a b)
566 (concatenate 'string a b))))
568 (annotated-nc-except (lead-annotated-nc-except
569 follow-annotations
570 (lambda (p a)
571 `(progn ,p ,a))))
573 (lead-annotated-nc-except nc-except
574 (annotations nc-except
575 (lambda (a p)
576 `(with-annotations ,a ,p))))
578 (annotated-simple-nc (lead-annotated-simple-nc
579 follow-annotations
580 (lambda (p a) `(progn ,p ,a))))
582 (lead-annotated-simple-nc
583 simple-nc
584 (\( inner-name-class \) (lambda* (nil nc nil) nc))
585 (annotations simple-nc
586 (lambda (a nc) `(with-annotations ,a ,nc)))
587 (annotations \( inner-name-class \)
588 (lambda (a nc) `(let-annotations ,a ,nc))))
590 (nc-except (ns-name - simple-nc
591 (lambda* (nc1 nil nc2) `(ns-name ,nc1 :except ,nc2)))
592 (* - simple-nc
593 (lambda* (nil nil nc) `(any-name :except ,nc))))
595 (nc-choice (annotated-simple-nc \| annotated-simple-nc
596 (lambda* (a nil b)
597 `(name-choice ,a ,b)))
598 (annotated-simple-nc \| nc-choice
599 (lambda* (a nil b)
600 `(name-choice ,a ,@(cdr b)))))
602 (name identifier-or-keyword cname)
604 (data-type-name cname :string :token)
606 (data-type-value literal)
607 (any-uri-literal literal)
609 (namespace-uri-literal literal :inherit)
611 (inherit (:inherit = identifier-or-keyword
612 (lambda* (nil nil x) x)))
614 (identifier-or-keyword identifier keyword)
616 ;; identifier ::= (ncname - keyword) | quotedidentifier
617 ;; quotedidentifier ::= "\" ncname
619 ;; (ns-name (ncname \:*))
620 (ns-name nsname)
622 (ncname identifier-or-keyword)
624 (literal literal-segment
625 (literal-segment ~ literal
626 (lambda* (a nil b)
627 (concatenate 'string a b))))
629 ;; literalsegment ::= ...
631 (keyword :attribute :default :datatypes :div :element :empty :external
632 :grammar :include :inherit :list :mixed :namespace :notAllowed
633 :parent :start :string :text :token)
635 ;; optional stuff
636 ([data-type-name] () data-type-name)
637 ([inherit] () inherit)
638 ([params] () ({ params } (lambda* (nil p nil) p)))
639 (params () (param params #'cons))
640 ([include-content] () ({ include-content* }
641 (lambda* (nil content nil) content))))
644 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
645 ;;;; Conversion of sexps into SAX
646 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
648 (defun uncompact (list)
649 (funcall (or (get (car list) 'uncompactor)
650 (error "no uncompactor for ~A" (car list)))
651 (cdr list)))
653 (defmacro define-uncompactor (name (&rest args) &body body)
654 `(setf (get ',name 'uncompactor)
655 (lambda (.form.) (destructuring-bind ,args .form. ,@body))))
657 (defparameter *namespaces* '(("xml" . "http://www.w3.org/XML/1998/namespace")))
658 (defparameter *default-namespace* nil)
659 (defparameter *data-types*
660 '(("xsd" . "http://www.w3.org/2001/XMLSchema-datatypes")))
662 (defun xor (a b)
663 (if a (not b) b))
665 (defun lookup-prefix (prefix)
666 (cdr (assoc prefix *namespaces* :test 'equal)))
668 (defun lookup-default ()
669 (or *default-namespace* :inherit))
671 (defun lookup-data-type (name)
672 (cdr (assoc name *data-types* :test 'equal)))
674 (define-uncompactor with-namespace ((&key uri name default) &body body)
675 (when (xor (equal name "xml")
676 (equal uri "http://www.w3.org/XML/1998/namespace"))
677 (rng-error nil "invalid redeclaration of `xml' namespace"))
678 (when (equal name "xmlns")
679 (rng-error nil "invalid declaration of `xmlns' namespace"))
680 (let ((*namespaces* *namespaces*)
681 (*default-namespace* *default-namespace*))
682 (when name
683 (when (lookup-prefix name)
684 (rng-error nil "duplicate declaration of prefix ~A" name))
685 (push (cons name uri) *namespaces*))
686 (when default
687 (when *default-namespace*
688 (rng-error nil "default namespace already declared to ~A"
689 *default-namespace*))
690 (push (cons "" uri) *namespaces*)
691 (setf *default-namespace* uri))
692 (if (and name (not (or (eq uri :inherit) (equal uri ""))))
693 (cxml:with-namespace (name uri)
694 (mapc #'uncompact body))
695 (mapc #'uncompact body))))
697 (define-uncompactor with-data-type ((&key name uri) &body body)
698 (when (and (equal name "xsd")
699 (not (equal uri "http://www.w3.org/2001/XMLSchema-datatypes")))
700 (rng-error nil "invalid redeclaration of `xml' namespace"))
701 (when (and (lookup-data-type name) (not (equal name "xsd")))
702 (rng-error nil "duplicate declaration of library ~A" name))
703 (let ((*data-types* (acons name uri *data-types*)))
704 (mapc #'uncompact body)))
706 (defparameter *annotation-attributes* nil)
707 (defparameter *annotation-elements* nil)
708 (defparameter *annotation-wrap* nil)
710 (defmacro with-element (name-and-args &body body)
711 (destructuring-bind (prefix lname &rest args)
712 (if (atom name-and-args)
713 (list nil name-and-args)
714 name-and-args)
715 `(invoke-with-element ,prefix
716 ,lname
717 (lambda () ,@args)
718 (lambda () ,@body))))
720 (defun invoke-with-element (prefix lname args body)
721 (if (and *annotation-attributes*
722 *annotation-wrap*)
723 (cxml:with-element* (nil *annotation-wrap*)
724 (let ((*annotation-wrap* nil))
725 (invoke-with-element prefix lname args body)))
726 (let ((*annotation-wrap* nil))
727 (cxml:with-element* (prefix lname)
728 (funcall args)
729 (when *annotation-attributes*
730 (uncompact *annotation-attributes*))
731 (dolist (elt *annotation-elements*)
732 (cxml:with-namespace
733 ("a" "http://relaxng.org/ns/compatibility/annotations/1.0")
734 (cxml:with-element* ("a" "documentation")
735 (cxml:text elt))))
736 (funcall body)))))
738 (define-uncompactor with-grammar ((&optional) &body body)
739 (with-element "grammar"
740 (mapc #'uncompact body)))
742 (define-uncompactor with-start ((&key combine-method) &body body)
743 (with-element (nil "start"
744 (cxml:attribute "combine" combine-method))
745 (mapc #'uncompact body)))
747 (define-uncompactor ref (name)
748 (with-element (nil "ref"
749 (cxml:attribute "name" name))))
751 (define-uncompactor parent-ref (name)
752 (with-element (nil "parentRef"
753 (cxml:attribute "name" name))))
755 (define-uncompactor parent-ref (name)
756 (with-element (nil "parentRef" (cxml:attribute "name" name))))
758 (defun ns-attribute (uri-or-inherit)
759 (unless (eq uri-or-inherit :inherit)
760 (cxml:attribute "ns" uri-or-inherit)))
762 (define-uncompactor external-ref (&key uri inherit)
763 (let ((ns (if inherit (lookup-prefix inherit) (lookup-default))))
764 (with-element (nil "externalRef"
765 (cxml:attribute "href" (munge-schema-ref uri))
766 (ns-attribute ns)))))
768 (defvar *elementp*)
770 (define-uncompactor with-element ((&key name) pattern)
771 (with-element "element"
772 (let ((*elementp* t))
773 (uncompact name))
774 (uncompact pattern)))
776 (define-uncompactor with-attribute ((&key name) pattern)
777 (with-element "attribute"
778 (let ((*elementp* nil))
779 (uncompact name))
780 (uncompact pattern)))
782 (define-uncompactor list (pattern)
783 (with-element "list"
784 (uncompact pattern)))
786 (define-uncompactor mixed (pattern)
787 (with-element "mixed"
788 (uncompact pattern)))
790 (define-uncompactor :empty ()
791 (with-element "empty"))
793 (define-uncompactor :text ()
794 (with-element "text"))
796 (defun uncompact-data-type (data-type)
797 (case data-type
798 (:string
799 (cxml:attribute "datatypeLibrary" "")
800 (cxml:attribute "type" "string"))
801 (:token
802 (cxml:attribute "datatypeLibrary" "")
803 (cxml:attribute "type" "token"))
805 (cxml:attribute "datatypeLibrary"
806 (lookup-data-type (car data-type)))
807 (cxml:attribute "type" (cdr data-type)))))
809 (define-uncompactor data (&key data-type params except)
810 (with-element (nil "data" (uncompact-data-type data-type))
811 (mapc #'uncompact params)
812 (when except
813 (with-element "except"
814 (uncompact except)))))
816 (define-uncompactor value (&key data-type value)
817 (with-element (nil "value" (uncompact-data-type data-type))
818 (cxml:text value)))
820 (define-uncompactor :notallowed ()
821 (with-element "notAllowed"))
823 (define-uncompactor with-definition ((&key name combine-method) &body body)
824 (with-element (nil "define"
825 (cxml:attribute "name" name)
826 (cxml:attribute "combine" combine-method))
827 (mapc #'uncompact body)))
829 (define-uncompactor with-div (&body body)
830 (with-element "div"
831 (mapc #'uncompact body)))
833 (define-uncompactor any-name (&key except)
834 (with-element "anyName"
835 (when except
836 (with-element "except"
837 (uncompact except)))))
839 (define-uncompactor ns-name (nc &key except)
840 (with-element (nil "nsName"
841 (ns-attribute (lookup-prefix nc)))
842 (when except
843 (with-element "except"
844 (uncompact except)))))
846 (define-uncompactor name-choice (&rest ncs)
847 (with-element "choice"
848 (mapc #'uncompact ncs)))
850 (defun destructure-cname-like (x)
851 (when (keywordp x)
852 (setf x (find x *keywords* :test 'string-equal)))
853 (when (atom x)
854 (setf x (cons (if *elementp* "" nil)
855 x)))
856 (values (lookup-prefix (car x))
857 (cdr x)))
859 (define-uncompactor name (x)
860 (multiple-value-bind (uri lname) (destructure-cname-like x)
861 (with-element (nil
862 "name"
863 (ns-attribute uri))
864 (cxml:text lname))))
866 (define-uncompactor choice (&rest body)
867 (with-element "choice"
868 (mapc #'uncompact body)))
870 (define-uncompactor group (&rest body)
871 (with-element "group"
872 (mapc #'uncompact body)))
874 (define-uncompactor interleave (&rest body)
875 (with-element "interleave"
876 (mapc #'uncompact body)))
878 (define-uncompactor one-or-more (p)
879 (with-element "oneOrMore"
880 (uncompact p)))
882 (define-uncompactor optional (p)
883 (with-element "optional"
884 (uncompact p)))
886 (define-uncompactor zero-or-more (p)
887 (with-element "zeroOrMore"
888 (uncompact p)))
890 (defun munge-schema-ref (uri)
891 (if (search "://" uri)
892 (concatenate 'string "rnc+" uri)
893 (concatenate 'string "rnc+://" uri)))
895 (defun rnc-uri-p (uri)
896 (and (search "://" uri)
897 (equal (mismatch "rnc+" uri) 4)))
899 (defun follow-rnc-uri (uri)
900 (if (equal (mismatch "rnc+://" uri) 7)
901 ;; rnc+://foo/bar
902 (subseq uri 7)
903 ;; rnc+file:///usr/foo/...
904 (subseq uri 4)))
906 (define-uncompactor with-include ((&key inherit uri) &body body)
907 (let ((ns (if inherit (lookup-prefix inherit) (lookup-default))))
908 (with-element (nil "include"
909 (cxml:attribute "href" (munge-schema-ref uri))
910 (ns-attribute ns))
911 (mapc #'uncompact body))))
913 (define-uncompactor with-annotations
914 ((annotation &key attributes elements) &body body)
915 (check-type annotation (member annotation))
916 (let ((*annotation-attributes* attributes)
917 (*annotation-elements* elements))
918 (mapc #'uncompact body)))
920 (define-uncompactor without-annotations (&body body)
921 (let ((*annotation-attributes* nil)
922 (*annotation-elements* nil))
923 (mapc #'uncompact body)))
925 ;; zzz das kann weg
926 (define-uncompactor %with-annotations (&body body)
927 (mapc #'uncompact body))
929 (define-uncompactor %with-annotations-group (&body body)
930 (let ((*annotation-wrap* "group"))
931 (mapc #'uncompact body)))
933 (define-uncompactor %with-annotations-choice (&body body)
934 (let ((*annotation-wrap* "choice"))
935 (mapc #'uncompact body)))
937 (define-uncompactor progn (a b)
938 (when a (uncompact a))
939 (when b (uncompact b)))
941 (define-uncompactor annotation-attributes (&rest attrs)
942 (mapc #'uncompact attrs))
944 (define-uncompactor annotation-attribute (name value)
945 (cxml:attribute* (car name) (cdr name) value))
947 (define-uncompactor param (name value)
948 (with-element (nil "param"
949 (cxml:attribute "name" name))
950 (cxml:text value)))
952 (define-uncompactor with-annotation-element ((&key name) &body attrs)
953 (cxml:with-element name
954 (mapc #'uncompact attrs)))
956 ;;; zzz strip BOM
957 ;;; zzz newline normalization: Wir lesen von einem character-stream, daher
958 ;;; macht das schon das Lisp fuer uns -- je nach Plattform. Aber nicht richtig.
959 (defun uncompact-file-1 (stream)
960 (handler-case
961 (let ((lexer (make-rng-lexer
962 (make-instance 'hex-stream :source stream))))
963 (yacc:parse-with-lexer
964 (lambda ()
965 (multiple-value-bind (cat sem) (funcall lexer)
966 #+nil (print (list cat sem))
967 (if (eq cat :eof)
969 (values cat sem))))
970 *compact-parser*))
971 (error (c)
972 (rng-error nil
973 "failed to parse compact syntax at char ~A, ~A:~% ~A"
974 (file-position stream)
975 (cxml::safe-stream-sysid stream)
976 c))))
978 (defun uncompact-file (input &optional stream)
979 (let ((tree
980 (etypecase input
981 (pathname (with-open-file (s input) (uncompact-file-1 s)))
982 (stream (with-open-stream (s input) (uncompact-file-1 s))))))
983 #+nil (print tree)
984 (with-output-to-string (s)
985 (cxml:with-xml-output
986 (if stream
987 (cxml:make-octet-stream-sink stream)
988 (cxml:make-character-stream-sink s))
989 (cxml:with-namespace ("" "http://relaxng.org/ns/structure/1.0")
990 (uncompact tree))))))
992 (defun parse-compact (pathname)
993 "@arg[pathname]{a pathname designator for a Relax NG compact file}
994 @return{a parsed @class{schema}}
995 @short{This function parses a Relax NG schema file in compact syntax}
996 and returns a parsed representation of that schema.
998 @see{parse-schema}
999 @see{make-validator}"
1000 (parse-schema (named-string-xstream
1001 (uncompact-file pathname)
1002 (cxml::pathname-to-uri pathname))))
1004 (defun test-compact ()
1005 (dolist (p (directory "/home/david/src/nxml-mode-20041004/schema/*.rnc"))
1006 (print p)
1007 (with-open-file (s (make-pathname :type "rng" :defaults p)
1008 :direction :output
1009 :if-exists :supersede)
1010 (uncompact-file p s))))
1012 #+(or)
1013 (compact)