1 ;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas
3 ;; Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc.
6 ;; Keywords: wp, hypermedia, languages, XML, RelaxNG
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; This parses a RELAX NG Compact Syntax schema into the form
26 ;; specified in rng-pttrn.el.
28 ;; RELAX NG Compact Syntax is specified by
29 ;; http://relaxng.org/compact.html
31 ;; This file uses the prefix "rng-c-".
41 (defun rng-c-load-schema (filename)
42 "Load a schema in RELAX NG compact syntax from FILENAME.
44 (rng-c-parse-file filename
))
48 (define-error 'rng-c-incorrect-schema
49 "Incorrect schema" '(rng-error nxml-file-parse-error
))
51 (defun rng-c-signal-incorrect-schema (filename pos message
)
52 (nxml-signal-file-parse-error filename
55 'rng-c-incorrect-schema
))
59 (defconst rng-c-keywords
79 "List of strings that are keywords in the compact syntax.")
81 (defconst rng-c-anchored-keyword-re
82 (concat "\\`\\(" (regexp-opt rng-c-keywords
) "\\)\\'")
83 "Regular expression to match a keyword in the compact syntax.")
85 (defvar rng-c-syntax-table nil
86 "Syntax table for parsing the compact syntax.")
88 (if rng-c-syntax-table
90 (setq rng-c-syntax-table
(make-syntax-table))
91 (modify-syntax-entry ?
# "<" rng-c-syntax-table
)
92 (modify-syntax-entry ?
\n ">" rng-c-syntax-table
)
93 (modify-syntax-entry ?-
"w" rng-c-syntax-table
)
94 (modify-syntax-entry ?.
"w" rng-c-syntax-table
)
95 (modify-syntax-entry ?_
"w" rng-c-syntax-table
)
96 (modify-syntax-entry ?
: "_" rng-c-syntax-table
))
98 (defconst rng-c-literal-1-re
99 "'\\(''\\([^']\\|'[^']\\|''[^']\\)*''\\|[^'\n]*\\)'"
100 "Regular expression to match a single-quoted literal.")
102 (defconst rng-c-literal-2-re
103 (replace-regexp-in-string "'" "\"" rng-c-literal-1-re
)
104 "Regular expression to match a double-quoted literal.")
106 (defconst rng-c-ncname-re
"\\w+")
108 (defconst rng-c-anchored-ncname-re
109 (concat "\\`" rng-c-ncname-re
"\\'"))
111 (defconst rng-c-token-re
112 (concat "[&|]=" "\\|"
113 "[][()|&,*+?{}~=-]" "\\|"
114 rng-c-literal-1-re
"\\|"
115 rng-c-literal-2-re
"\\|"
116 rng-c-ncname-re
"\\(:\\(\\*\\|" rng-c-ncname-re
"\\)\\)?" "\\|"
117 "\\\\" rng-c-ncname-re
"\\|"
119 "Regular expression to match a token in the compact syntax.")
121 (defun rng-c-init-buffer ()
122 (setq case-fold-search nil
) ; automatically becomes buffer-local when set
123 (set-buffer-multibyte t
)
124 (set-syntax-table rng-c-syntax-table
))
126 (defvar rng-c-current-token nil
)
127 (make-variable-buffer-local 'rng-c-current-token
)
129 (defun rng-c-advance ()
130 (cond ((looking-at rng-c-token-re
)
131 (setq rng-c-current-token
(match-string 0))
132 (goto-char (match-end 0))
133 (forward-comment (point-max)))
134 ((= (point) (point-max))
135 (setq rng-c-current-token
""))
136 (t (rng-c-error "Invalid token"))))
138 (defconst rng-c-anchored-datatype-name-re
139 (concat "\\`" rng-c-ncname-re
":" rng-c-ncname-re
"\\'"))
141 (defsubst rng-c-current-token-keyword-p
()
142 (string-match rng-c-anchored-keyword-re rng-c-current-token
))
144 (defsubst rng-c-current-token-prefixed-name-p
()
145 (string-match rng-c-anchored-datatype-name-re rng-c-current-token
))
147 (defsubst rng-c-current-token-literal-p
()
148 (string-match "\\`['\"]" rng-c-current-token
))
150 (defsubst rng-c-current-token-quoted-identifier-p
()
151 (string-match "\\`\\\\" rng-c-current-token
))
153 (defsubst rng-c-current-token-ncname-p
()
154 (string-match rng-c-anchored-ncname-re rng-c-current-token
))
156 (defsubst rng-c-current-token-ns-name-p
()
157 (let ((len (length rng-c-current-token
)))
159 (= (aref rng-c-current-token
(- len
1)) ?
*))))
163 (defvar rng-c-inherit-namespace nil
)
165 (defvar rng-c-default-namespace nil
)
167 (defvar rng-c-default-namespace-declared nil
)
169 (defvar rng-c-namespace-decls nil
170 "Alist of namespace declarations.")
172 (defconst rng-c-no-namespace nil
)
174 (defun rng-c-declare-standard-namespaces ()
175 (setq rng-c-namespace-decls
176 (cons (cons "xml" nxml-xml-namespace-uri
)
177 rng-c-namespace-decls
))
178 (when (and (not rng-c-default-namespace-declared
)
179 rng-c-inherit-namespace
)
180 (setq rng-c-default-namespace rng-c-inherit-namespace
)))
182 (defun rng-c-expand-name (prefixed-name)
183 (let ((i (string-match ":" prefixed-name
)))
184 (rng-make-name (rng-c-lookup-prefix (substring prefixed-name
187 (substring prefixed-name
(+ i
1)))))
189 (defun rng-c-lookup-prefix (prefix)
190 (let ((binding (assoc prefix rng-c-namespace-decls
)))
191 (or binding
(rng-c-error "Undefined prefix %s" prefix
))
194 (defun rng-c-unqualified-namespace (attribute)
197 rng-c-default-namespace
))
199 (defun rng-c-make-context ()
200 (cons rng-c-default-namespace rng-c-namespace-decls
))
204 (defconst rng-string-datatype
205 (rng-make-datatype rng-builtin-datatypes-uri
"string"))
207 (defconst rng-token-datatype
208 (rng-make-datatype rng-builtin-datatypes-uri
"token"))
210 (defvar rng-c-datatype-decls nil
211 "Alist of datatype declarations.
212 Contains a list of pairs (PREFIX . URI) where PREFIX is a string
213 and URI is a symbol.")
215 (defun rng-c-declare-standard-datatypes ()
216 (setq rng-c-datatype-decls
217 (cons (cons "xsd" rng-xsd-datatypes-uri
)
218 rng-c-datatype-decls
)))
220 (defun rng-c-lookup-datatype-prefix (prefix)
221 (let ((binding (assoc prefix rng-c-datatype-decls
)))
222 (or binding
(rng-c-error "Undefined prefix %s" prefix
))
225 (defun rng-c-expand-datatype (prefixed-name)
226 (let ((i (string-match ":" prefixed-name
)))
228 (rng-c-lookup-datatype-prefix (substring prefixed-name
0 i
))
229 (substring prefixed-name
(+ i
1)))))
233 (defvar rng-c-current-grammar nil
)
234 (defvar rng-c-parent-grammar nil
)
236 (defun rng-c-make-grammar ()
237 (make-hash-table :test
'equal
))
239 (defconst rng-c-about-override-slot
0)
240 (defconst rng-c-about-combine-slot
1)
242 (defun rng-c-lookup-create (name grammar
)
243 "Return a def object for NAME.
244 A def object is a pair \(ABOUT . REF) where REF is returned by
246 ABOUT is a two-element vector [OVERRIDE COMBINE].
247 COMBINE is either nil, choice or interleave.
248 OVERRIDE is either nil, require or t."
249 (let ((def (gethash name grammar
)))
253 (setq def
(cons (vector nil nil
) (rng-make-ref name
)))
254 (puthash name def grammar
)
257 (defun rng-c-make-ref (name)
258 (or rng-c-current-grammar
259 (rng-c-error "Reference not in a grammar"))
260 (cdr (rng-c-lookup-create name rng-c-current-grammar
)))
262 (defun rng-c-make-parent-ref (name)
263 (or rng-c-parent-grammar
264 (rng-c-error "Reference to non-existent parent grammar"))
265 (cdr (rng-c-lookup-create name rng-c-parent-grammar
)))
267 (defvar rng-c-overrides nil
268 "Contains a list of (NAME . DEF) pairs.")
270 (defun rng-c-merge-combine (def combine name
)
271 (let* ((about (car def
))
272 (current-combine (aref about rng-c-about-combine-slot
)))
275 (or (eq combine current-combine
)
276 (rng-c-error "Inconsistent combine for %s" name
))
277 (aset about rng-c-about-combine-slot combine
))
280 (defun rng-c-prepare-define (name combine in-include
)
281 (let* ((def (rng-c-lookup-create name rng-c-current-grammar
))
283 (overridden (aref about rng-c-about-override-slot
)))
285 (setq rng-c-overrides
(cons (cons name def
) rng-c-overrides
)))
286 (cond (overridden (and (eq overridden
'require
)
287 (aset about rng-c-about-override-slot t
))
289 (t (setq combine
(rng-c-merge-combine def combine name
))
290 (and (rng-ref-get (cdr def
))
292 (rng-c-error "Duplicate definition of %s" name
))
295 (defun rng-c-start-include (overrides)
296 (mapcar (lambda (name-def)
297 (let* ((def (cdr name-def
))
299 (save (aref about rng-c-about-override-slot
)))
300 (aset about rng-c-about-override-slot
'require
)
301 (cons save name-def
)))
304 (defun rng-c-end-include (overrides)
306 (let* ((saved (car o
))
308 (name (car name-def
))
311 (and (eq (aref about rng-c-about-override-slot
) 'require
)
312 (rng-c-error "Definition of %s in include did not override definition in included file" name
))
313 (aset about rng-c-about-override-slot saved
)))
316 (defun rng-c-define (def value
)
318 (let ((current-value (rng-ref-get (cdr def
))))
319 (rng-ref-set (cdr def
)
321 (if (eq (aref (car def
) rng-c-about-combine-slot
)
323 (rng-make-choice (list current-value value
))
324 (rng-make-interleave (list current-value value
)))
327 (defun rng-c-finish-grammar ()
328 (maphash (lambda (key def
)
329 (or (rng-ref-get (cdr def
))
330 (rng-c-error "Reference to undefined pattern %s" key
)))
331 rng-c-current-grammar
)
332 (rng-ref-get (cdr (or (gethash 'start rng-c-current-grammar
)
333 (rng-c-error "No definition of start")))))
337 (defvar rng-c-escape-positions nil
)
338 (make-variable-buffer-local 'rng-c-escape-positions
)
340 (defvar rng-c-file-name nil
)
341 (make-variable-buffer-local 'rng-c-file-name
)
343 (defvar rng-c-file-index nil
)
345 (defun rng-c-parse-file (filename &optional context
)
346 (with-current-buffer (get-buffer-create (rng-c-buffer-name context
))
349 (setq rng-c-file-name
350 (car (insert-file-contents filename
)))
351 (setq rng-c-escape-positions nil
)
352 (rng-c-process-escapes)
353 (rng-c-parse-top-level context
)))
355 (defun rng-c-buffer-name (context)
356 (concat " *RNC Input"
359 (number-to-string (setq rng-c-file-index
360 (1+ rng-c-file-index
)))
362 (setq rng-c-file-index
1)
365 (defun rng-c-process-escapes ()
366 ;; Check for any NULs, since we will use NUL chars
367 ;; for internal purposes.
368 (let ((pos (search-forward "\C-@" nil t
)))
370 (rng-c-error "Nul character found (binary file?)")))
372 (while (re-search-forward "\\\\x+{\\([0-9a-fA-F]+\\)}"
375 (let* ((ch (decode-char 'ucs
(string-to-number (match-string 1) 16))))
376 (if (and ch
(> ch
0))
377 (let ((begin (match-beginning 0))
379 (delete-region begin end
)
380 ;; Represent an escaped newline by nul, so
381 ;; that we can distinguish it from a literal newline.
382 ;; We will translate it back into a real newline later.
383 (insert (if (eq ch ?
\n) 0 ch
))
384 (setq offset
(+ offset
(- end begin
1)))
385 (setq rng-c-escape-positions
386 (cons (cons (point) offset
)
387 rng-c-escape-positions
)))
388 (rng-c-error "Invalid character escape")))))
391 (defun rng-c-translate-position (pos)
392 (let ((tem rng-c-escape-positions
))
395 (setq tem
(cdr tem
)))
400 (defun rng-c-error (&rest args
)
401 (rng-c-signal-incorrect-schema rng-c-file-name
402 (rng-c-translate-position (point))
403 (apply 'format args
)))
405 (defun rng-c-parse-top-level (context)
406 (let ((rng-c-namespace-decls nil
)
407 (rng-c-default-namespace nil
)
408 (rng-c-datatype-decls nil
))
409 (goto-char (point-min))
410 (forward-comment (point-max))
413 (let ((p (if (eq context
'include
)
414 (if (rng-c-implicit-grammar-p)
415 (rng-c-parse-grammar-body "")
416 (rng-c-parse-included-grammar))
417 (if (rng-c-implicit-grammar-p)
418 (rng-c-parse-implicit-grammar)
419 (rng-c-parse-pattern)))))
420 (or (string-equal rng-c-current-token
"")
421 (rng-c-error "Unexpected characters after pattern"))
424 (defun rng-c-parse-included-grammar ()
425 (or (string-equal rng-c-current-token
"grammar")
426 (rng-c-error "Included schema is not a grammar"))
429 (rng-c-parse-grammar-body "}"))
431 (defun rng-c-implicit-grammar-p ()
432 (or (and (or (rng-c-current-token-prefixed-name-p)
433 (rng-c-current-token-quoted-identifier-p)
434 (and (rng-c-current-token-ncname-p)
435 (not (rng-c-current-token-keyword-p))))
437 (and (string-equal rng-c-current-token
"[")
438 (rng-c-parse-lead-annotation)
440 (member rng-c-current-token
'("div" "include" ""))
441 (looking-at "[|&]?=")))
443 (defun rng-c-parse-decls ()
444 (setq rng-c-default-namespace-declared nil
)
447 (assoc rng-c-current-token
448 '(("namespace" . rng-c-parse-namespace
)
449 ("datatypes" . rng-c-parse-datatypes
)
450 ("default" . rng-c-parse-default
)))))
454 (funcall (cdr binding
))
457 (rng-c-declare-standard-datatypes)
458 (rng-c-declare-standard-namespaces))
460 (defun rng-c-parse-datatypes ()
461 (let ((prefix (rng-c-parse-identifier-or-keyword)))
462 (or (not (assoc prefix rng-c-datatype-decls
))
463 (rng-c-error "Duplicate datatypes declaration for prefix %s" prefix
))
465 (setq rng-c-datatype-decls
467 (rng-make-datatypes-uri (rng-c-parse-literal)))
468 rng-c-datatype-decls
))))
470 (defun rng-c-parse-namespace ()
471 (rng-c-declare-namespace nil
472 (rng-c-parse-identifier-or-keyword)))
474 (defun rng-c-parse-default ()
475 (rng-c-expect "namespace")
476 (rng-c-declare-namespace t
477 (if (string-equal rng-c-current-token
"=")
479 (rng-c-parse-identifier-or-keyword))))
481 (defun rng-c-declare-namespace (declare-default prefix
)
483 (let ((ns (cond ((string-equal rng-c-current-token
"inherit")
485 rng-c-inherit-namespace
)
487 (nxml-make-namespace (rng-c-parse-literal))))))
489 (or (not (assoc prefix rng-c-namespace-decls
))
490 (rng-c-error "Duplicate namespace declaration for prefix %s"
492 (setq rng-c-namespace-decls
493 (cons (cons prefix ns
) rng-c-namespace-decls
)))
495 (or (not rng-c-default-namespace-declared
)
496 (rng-c-error "Duplicate default namespace declaration"))
497 (setq rng-c-default-namespace-declared t
)
498 (setq rng-c-default-namespace ns
))))
500 (defun rng-c-parse-implicit-grammar ()
501 (let* ((rng-c-parent-grammar rng-c-current-grammar
)
502 (rng-c-current-grammar (rng-c-make-grammar)))
503 (rng-c-parse-grammar-body "")
504 (rng-c-finish-grammar)))
506 (defun rng-c-parse-grammar-body (close-token &optional in-include
)
507 (while (not (string-equal rng-c-current-token close-token
))
508 (cond ((rng-c-current-token-keyword-p)
509 (let ((kw (intern rng-c-current-token
)))
510 (cond ((eq kw
'start
)
511 (rng-c-parse-define 'start in-include
))
514 (rng-c-parse-div in-include
))
517 (rng-c-error "Nested include"))
519 (rng-c-parse-include))
520 (t (rng-c-error "Invalid grammar keyword")))))
521 ((rng-c-current-token-ncname-p)
522 (if (looking-at "\\[")
523 (rng-c-parse-annotation-element)
524 (rng-c-parse-define rng-c-current-token
526 ((rng-c-current-token-quoted-identifier-p)
527 (if (looking-at "\\[")
528 (rng-c-parse-annotation-element)
529 (rng-c-parse-define (substring rng-c-current-token
1)
531 ((rng-c-current-token-prefixed-name-p)
532 (rng-c-parse-annotation-element))
533 ((string-equal rng-c-current-token
"[")
534 (rng-c-parse-lead-annotation)
535 (and (string-equal rng-c-current-token close-token
)
536 (rng-c-error "Missing annotation subject"))
537 (and (looking-at "\\[")
538 (rng-c-error "Leading annotation applied to annotation")))
539 (t (rng-c-error "Invalid grammar content"))))
540 (or (string-equal rng-c-current-token
"")
543 (defun rng-c-parse-div (in-include)
545 (rng-c-parse-grammar-body "}" in-include
))
547 (defun rng-c-parse-include ()
548 (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
549 (rng-c-inherit-namespace (rng-c-parse-opt-inherit))
551 (cond ((string-equal rng-c-current-token
"{")
553 (let ((rng-c-overrides nil
))
554 (rng-c-parse-grammar-body "}" t
)
555 (setq overrides rng-c-overrides
))
556 (setq overrides
(rng-c-start-include overrides
))
557 (rng-c-parse-file filename
'include
)
558 (rng-c-end-include overrides
))
559 (t (rng-c-parse-file filename
'include
)))))
561 (defun rng-c-parse-define (name in-include
)
563 (let ((assign (assoc rng-c-current-token
566 ("&=" . interleave
)))))
568 (rng-c-error "Expected assignment operator"))
570 (let ((ref (rng-c-prepare-define name
(cdr assign
) in-include
)))
571 (rng-c-define ref
(rng-c-parse-pattern)))))
573 (defvar rng-c-had-except nil
)
575 (defun rng-c-parse-pattern ()
576 (let* ((rng-c-had-except nil
)
577 (p (rng-c-parse-repeated))
578 (op (assoc rng-c-current-token
579 '(("|" . rng-make-choice
)
580 ("," . rng-make-group
)
581 ("&" . rng-make-interleave
)))))
584 (rng-c-error "Parentheses required around pattern using -")
585 (let* ((patterns (cons p nil
))
587 (connector rng-c-current-token
))
590 (let ((newcdr (cons (rng-c-parse-repeated) nil
)))
593 (string-equal rng-c-current-token connector
)))
594 (funcall (cdr op
) patterns
)))
597 (defun rng-c-parse-repeated ()
598 (let ((p (rng-c-parse-follow-annotations
599 (rng-c-parse-primary)))
600 (op (assoc rng-c-current-token
601 '(("*" . rng-make-zero-or-more
)
602 ("+" . rng-make-one-or-more
)
603 ("?" . rng-make-optional
)))))
606 (rng-c-error "Parentheses required around pattern using -")
607 (rng-c-parse-follow-annotations
610 (funcall (cdr op
) p
))))
613 (defun rng-c-parse-primary ()
614 "Parse a primary expression.
615 The current token must be the first token of the expression.
616 After parsing the current token should be the token following
617 the primary expression."
618 (cond ((rng-c-current-token-keyword-p)
619 (let ((parse-function (get (intern rng-c-current-token
)
622 (rng-c-error "Keyword %s does not introduce a pattern"
623 rng-c-current-token
))
625 (funcall parse-function
)))
626 ((rng-c-current-token-ncname-p)
627 (rng-c-advance-with (rng-c-make-ref rng-c-current-token
)))
628 ((string-equal rng-c-current-token
"(")
630 (let ((p (rng-c-parse-pattern)))
633 ((rng-c-current-token-prefixed-name-p)
634 (let ((name (rng-c-expand-datatype rng-c-current-token
)))
636 (rng-c-parse-data name
)))
637 ((rng-c-current-token-literal-p)
638 (rng-make-value rng-token-datatype
(rng-c-parse-literal) nil
))
639 ((rng-c-current-token-quoted-identifier-p)
641 (rng-c-make-ref (substring rng-c-current-token
1))))
642 ((string-equal rng-c-current-token
"[")
643 (rng-c-parse-lead-annotation)
644 (rng-c-parse-primary))
645 (t (rng-c-error "Invalid pattern"))))
647 (defun rng-c-parse-parent ()
648 (and (rng-c-current-token-keyword-p)
649 (rng-c-error "Keyword following parent was not quoted"
650 rng-c-current-token
))
651 (rng-c-make-parent-ref (rng-c-parse-identifier-or-keyword)))
653 (defun rng-c-parse-literal ()
654 (rng-c-fix-escaped-newlines
655 (apply 'concat
(rng-c-parse-literal-segments))))
657 (defun rng-c-parse-literal-segments ()
658 (let ((str (rng-c-parse-literal-segment)))
660 (cond ((string-equal rng-c-current-token
"~")
662 (rng-c-parse-literal-segments))
665 (defun rng-c-parse-literal-segment ()
666 (or (rng-c-current-token-literal-p)
667 (rng-c-error "Expected a literal"))
669 (let ((n (if (and (>= (length rng-c-current-token
) 6)
670 (eq (aref rng-c-current-token
0)
671 (aref rng-c-current-token
1)))
674 (substring rng-c-current-token n
(- n
)))))
676 (defun rng-c-fix-escaped-newlines (str)
679 (let ((n (string-match "\C-@" str pos
)))
682 (setq pos
(1+ n
)))))))
685 (defun rng-c-parse-identifier-or-keyword ()
686 (cond ((rng-c-current-token-ncname-p)
687 (rng-c-advance-with rng-c-current-token
))
688 ((rng-c-current-token-quoted-identifier-p)
689 (rng-c-advance-with (substring rng-c-current-token
1)))
690 (t (rng-c-error "Expected identifier or keyword"))))
692 (put 'string
'rng-c-pattern
'rng-c-parse-string
)
693 (put 'token
'rng-c-pattern
'rng-c-parse-token
)
694 (put 'element
'rng-c-pattern
'rng-c-parse-element
)
695 (put 'attribute
'rng-c-pattern
'rng-c-parse-attribute
)
696 (put 'list
'rng-c-pattern
'rng-c-parse-list
)
697 (put 'mixed
'rng-c-pattern
'rng-c-parse-mixed
)
698 (put 'text
'rng-c-pattern
'rng-c-parse-text
)
699 (put 'empty
'rng-c-pattern
'rng-c-parse-empty
)
700 (put 'notAllowed
'rng-c-pattern
'rng-c-parse-not-allowed
)
701 (put 'grammar
'rng-c-pattern
'rng-c-parse-grammar
)
702 (put 'parent
'rng-c-pattern
'rng-c-parse-parent
)
703 (put 'external
'rng-c-pattern
'rng-c-parse-external
)
705 (defun rng-c-parse-element ()
706 (let ((name-class (rng-c-parse-name-class nil
)))
708 (let ((pattern (rng-c-parse-pattern)))
710 (rng-make-element name-class pattern
))))
712 (defun rng-c-parse-attribute ()
713 (let ((name-class (rng-c-parse-name-class 'attribute
)))
715 (let ((pattern (rng-c-parse-pattern)))
717 (rng-make-attribute name-class pattern
))))
719 (defun rng-c-parse-name-class (attribute)
720 (let* ((rng-c-had-except nil
)
722 (rng-c-parse-follow-annotations
723 (rng-c-parse-primary-name-class attribute
))))
724 (if (string-equal rng-c-current-token
"|")
725 (let* ((name-classes (cons name-class nil
))
727 (or (not rng-c-had-except
)
728 (rng-c-error "Parentheses required around name-class using - operator"))
732 (cons (rng-c-parse-follow-annotations
733 (rng-c-parse-primary-name-class attribute
))
737 (string-equal rng-c-current-token
"|")))
738 (rng-make-choice-name-class name-classes
))
741 (defun rng-c-parse-primary-name-class (attribute)
742 (cond ((rng-c-current-token-ncname-p)
744 (rng-make-name-name-class
745 (rng-make-name (rng-c-unqualified-namespace attribute
)
746 rng-c-current-token
))))
747 ((rng-c-current-token-prefixed-name-p)
749 (rng-make-name-name-class
750 (rng-c-expand-name rng-c-current-token
))))
751 ((string-equal rng-c-current-token
"*")
752 (let ((except (rng-c-parse-opt-except-name-class attribute
)))
754 (rng-make-any-name-except-name-class except
)
755 (rng-make-any-name-name-class))))
756 ((rng-c-current-token-ns-name-p)
758 (rng-c-lookup-prefix (substring rng-c-current-token
761 (except (rng-c-parse-opt-except-name-class attribute
)))
763 (rng-make-ns-name-except-name-class ns except
)
764 (rng-make-ns-name-name-class ns
))))
765 ((string-equal rng-c-current-token
"(")
767 (let ((name-class (rng-c-parse-name-class attribute
)))
770 ((rng-c-current-token-quoted-identifier-p)
772 (rng-make-name-name-class
773 (rng-make-name (rng-c-unqualified-namespace attribute
)
774 (substring rng-c-current-token
1)))))
775 ((string-equal rng-c-current-token
"[")
776 (rng-c-parse-lead-annotation)
777 (rng-c-parse-primary-name-class attribute
))
778 (t (rng-c-error "Bad name class"))))
780 (defun rng-c-parse-opt-except-name-class (attribute)
782 (and (string-equal rng-c-current-token
"-")
783 (or (not rng-c-had-except
)
784 (rng-c-error "Parentheses required around name-class using - operator"))
785 (setq rng-c-had-except t
)
788 (rng-c-parse-primary-name-class attribute
))))
790 (defun rng-c-parse-mixed ()
792 (let ((pattern (rng-make-mixed (rng-c-parse-pattern))))
796 (defun rng-c-parse-list ()
798 (let ((pattern (rng-make-list (rng-c-parse-pattern))))
802 (defun rng-c-parse-text ()
805 (defun rng-c-parse-empty ()
808 (defun rng-c-parse-not-allowed ()
809 (rng-make-not-allowed))
811 (defun rng-c-parse-string ()
812 (rng-c-parse-data rng-string-datatype
))
814 (defun rng-c-parse-token ()
815 (rng-c-parse-data rng-token-datatype
))
817 (defun rng-c-parse-data (name)
818 (if (rng-c-current-token-literal-p)
820 (rng-c-parse-literal)
822 (rng-c-make-context)))
823 (let ((params (rng-c-parse-optional-params)))
824 (if (string-equal rng-c-current-token
"-")
827 (rng-c-error "Parentheses required around pattern using -")
828 (setq rng-c-had-except t
))
830 (rng-make-data-except name
832 (rng-c-parse-primary)))
833 (rng-make-data name params
)))))
835 (defun rng-c-parse-optional-params ()
836 (and (string-equal rng-c-current-token
"{")
837 (let* ((head (cons nil nil
))
840 (while (not (string-equal rng-c-current-token
"}"))
841 (and (string-equal rng-c-current-token
"[")
842 (rng-c-parse-lead-annotation))
843 (let ((name (rng-c-parse-identifier-or-keyword)))
845 (let ((newcdr (cons (cons (intern name
)
846 (rng-c-parse-literal))
849 (setq tail newcdr
))))
853 (defun rng-c-parse-external ()
854 (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
855 (rng-c-inherit-namespace (rng-c-parse-opt-inherit)))
856 (rng-c-parse-file filename
'external
)))
858 (defun rng-c-expand-file (uri)
860 (rng-uri-file-name (rng-uri-resolve uri
861 (rng-file-name-uri rng-c-file-name
)))
863 (rng-c-error (cadr err
)))))
865 (defun rng-c-parse-opt-inherit ()
866 (cond ((string-equal rng-c-current-token
"inherit")
869 (rng-c-lookup-prefix (rng-c-parse-identifier-or-keyword)))
870 (t rng-c-default-namespace
)))
872 (defun rng-c-parse-grammar ()
874 (let* ((rng-c-parent-grammar rng-c-current-grammar
)
875 (rng-c-current-grammar (rng-c-make-grammar)))
876 (rng-c-parse-grammar-body "}")
877 (rng-c-finish-grammar)))
879 (defun rng-c-parse-lead-annotation ()
880 (rng-c-parse-annotation-body)
881 (and (string-equal rng-c-current-token
"[")
882 (rng-c-error "Multiple leading annotations")))
884 (defun rng-c-parse-follow-annotations (obj)
885 (while (string-equal rng-c-current-token
">>")
887 (if (rng-c-current-token-prefixed-name-p)
889 (rng-c-parse-identifier-or-keyword))
890 (rng-c-parse-annotation-body t
))
893 (defun rng-c-parse-annotation-element ()
895 (rng-c-parse-annotation-body t
))
897 ;; XXX need stricter checking of attribute names
898 ;; XXX don't allow attributes after text
900 (defun rng-c-parse-annotation-body (&optional allow-text
)
901 "Current token is [. Parse up to matching ].
902 Current token after parse is token following ]."
903 (or (string-equal rng-c-current-token
"[")
904 (rng-c-error "Expected ["))
906 (while (not (string-equal rng-c-current-token
"]"))
907 (cond ((rng-c-current-token-literal-p)
909 (rng-c-error "Out of place text within annotation"))
910 (rng-c-parse-literal))
912 (if (rng-c-current-token-prefixed-name-p)
914 (rng-c-parse-identifier-or-keyword))
915 (cond ((string-equal rng-c-current-token
"[")
916 (rng-c-parse-annotation-body t
))
917 ((string-equal rng-c-current-token
"=")
919 (rng-c-parse-literal))
920 (t (rng-c-error "Expected = or ["))))))
923 (defun rng-c-advance-with (pattern)
927 (defun rng-c-expect (str)
928 (or (string-equal rng-c-current-token str
)
929 (rng-c-error "Expected `%s' but got `%s'" str rng-c-current-token
))