1 ;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas
3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
6 ;; Keywords: 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 (put 'rng-c-incorrect-schema
50 '(error rng-error nxml-file-parse-error rng-c-incorrect-schema
))
52 (put 'rng-c-incorrect-schema
56 (defun rng-c-signal-incorrect-schema (filename pos message
)
57 (nxml-signal-file-parse-error filename
60 'rng-c-incorrect-schema
))
64 (defconst rng-c-keywords
84 "List of strings that are keywords in the compact syntax.")
86 (defconst rng-c-anchored-keyword-re
87 (concat "\\`\\(" (regexp-opt rng-c-keywords
) "\\)\\'")
88 "Regular expression to match a keyword in the compact syntax.")
90 (defvar rng-c-syntax-table nil
91 "Syntax table for parsing the compact syntax.")
93 (if rng-c-syntax-table
95 (setq rng-c-syntax-table
(make-syntax-table))
96 (modify-syntax-entry ?
# "<" rng-c-syntax-table
)
97 (modify-syntax-entry ?
\n ">" rng-c-syntax-table
)
98 (modify-syntax-entry ?-
"w" rng-c-syntax-table
)
99 (modify-syntax-entry ?.
"w" rng-c-syntax-table
)
100 (modify-syntax-entry ?_
"w" rng-c-syntax-table
)
101 (modify-syntax-entry ?
: "_" rng-c-syntax-table
))
103 (defconst rng-c-literal-1-re
104 "'\\(''\\([^']\\|'[^']\\|''[^']\\)*''\\|[^'\n]*\\)'"
105 "Regular expression to match a single-quoted literal.")
107 (defconst rng-c-literal-2-re
108 (replace-regexp-in-string "'" "\"" rng-c-literal-1-re
)
109 "Regular expression to match a double-quoted literal.")
111 (defconst rng-c-ncname-re
"\\w+")
113 (defconst rng-c-anchored-ncname-re
114 (concat "\\`" rng-c-ncname-re
"\\'"))
116 (defconst rng-c-token-re
117 (concat "[&|]=" "\\|"
118 "[][()|&,*+?{}~=-]" "\\|"
119 rng-c-literal-1-re
"\\|"
120 rng-c-literal-2-re
"\\|"
121 rng-c-ncname-re
"\\(:\\(\\*\\|" rng-c-ncname-re
"\\)\\)?" "\\|"
122 "\\\\" rng-c-ncname-re
"\\|"
124 "Regular expression to match a token in the compact syntax.")
126 (defun rng-c-init-buffer ()
127 (setq case-fold-search nil
) ; automatically becomes buffer-local when set
128 (set-buffer-multibyte t
)
129 (set-syntax-table rng-c-syntax-table
))
131 (defvar rng-c-current-token nil
)
132 (make-variable-buffer-local 'rng-c-current-token
)
134 (defun rng-c-advance ()
135 (cond ((looking-at rng-c-token-re
)
136 (setq rng-c-current-token
(match-string 0))
137 (goto-char (match-end 0))
138 (forward-comment (point-max)))
139 ((= (point) (point-max))
140 (setq rng-c-current-token
""))
141 (t (rng-c-error "Invalid token"))))
143 (defconst rng-c-anchored-datatype-name-re
144 (concat "\\`" rng-c-ncname-re
":" rng-c-ncname-re
"\\'"))
146 (defsubst rng-c-current-token-keyword-p
()
147 (string-match rng-c-anchored-keyword-re rng-c-current-token
))
149 (defsubst rng-c-current-token-prefixed-name-p
()
150 (string-match rng-c-anchored-datatype-name-re rng-c-current-token
))
152 (defsubst rng-c-current-token-literal-p
()
153 (string-match "\\`['\"]" rng-c-current-token
))
155 (defsubst rng-c-current-token-quoted-identifier-p
()
156 (string-match "\\`\\\\" rng-c-current-token
))
158 (defsubst rng-c-current-token-ncname-p
()
159 (string-match rng-c-anchored-ncname-re rng-c-current-token
))
161 (defsubst rng-c-current-token-ns-name-p
()
162 (let ((len (length rng-c-current-token
)))
164 (= (aref rng-c-current-token
(- len
1)) ?
*))))
168 (defvar rng-c-inherit-namespace nil
)
170 (defvar rng-c-default-namespace nil
)
172 (defvar rng-c-default-namespace-declared nil
)
174 (defvar rng-c-namespace-decls nil
175 "Alist of namespace declarations.")
177 (defconst rng-c-no-namespace nil
)
179 (defun rng-c-declare-standard-namespaces ()
180 (setq rng-c-namespace-decls
181 (cons (cons "xml" nxml-xml-namespace-uri
)
182 rng-c-namespace-decls
))
183 (when (and (not rng-c-default-namespace-declared
)
184 rng-c-inherit-namespace
)
185 (setq rng-c-default-namespace rng-c-inherit-namespace
)))
187 (defun rng-c-expand-name (prefixed-name)
188 (let ((i (string-match ":" prefixed-name
)))
189 (rng-make-name (rng-c-lookup-prefix (substring prefixed-name
192 (substring prefixed-name
(+ i
1)))))
194 (defun rng-c-lookup-prefix (prefix)
195 (let ((binding (assoc prefix rng-c-namespace-decls
)))
196 (or binding
(rng-c-error "Undefined prefix %s" prefix
))
199 (defun rng-c-unqualified-namespace (attribute)
202 rng-c-default-namespace
))
204 (defun rng-c-make-context ()
205 (cons rng-c-default-namespace rng-c-namespace-decls
))
209 (defconst rng-string-datatype
210 (rng-make-datatype rng-builtin-datatypes-uri
"string"))
212 (defconst rng-token-datatype
213 (rng-make-datatype rng-builtin-datatypes-uri
"token"))
215 (defvar rng-c-datatype-decls nil
216 "Alist of datatype declarations.
217 Contains a list of pairs (PREFIX . URI) where PREFIX is a string
218 and URI is a symbol.")
220 (defun rng-c-declare-standard-datatypes ()
221 (setq rng-c-datatype-decls
222 (cons (cons "xsd" rng-xsd-datatypes-uri
)
223 rng-c-datatype-decls
)))
225 (defun rng-c-lookup-datatype-prefix (prefix)
226 (let ((binding (assoc prefix rng-c-datatype-decls
)))
227 (or binding
(rng-c-error "Undefined prefix %s" prefix
))
230 (defun rng-c-expand-datatype (prefixed-name)
231 (let ((i (string-match ":" prefixed-name
)))
233 (rng-c-lookup-datatype-prefix (substring prefixed-name
0 i
))
234 (substring prefixed-name
(+ i
1)))))
238 (defvar rng-c-current-grammar nil
)
239 (defvar rng-c-parent-grammar nil
)
241 (defun rng-c-make-grammar ()
242 (make-hash-table :test
'equal
))
244 (defconst rng-c-about-override-slot
0)
245 (defconst rng-c-about-combine-slot
1)
247 (defun rng-c-lookup-create (name grammar
)
248 "Return a def object for NAME. A def object is a pair
249 \(ABOUT . REF) where REF is returned by `rng-make-ref'. ABOUT is a
250 two-element vector [OVERRIDE COMBINE]. COMBINE is either nil, choice
251 or interleave. OVERRIDE is either nil, require or t."
252 (let ((def (gethash name grammar
)))
256 (setq def
(cons (vector nil nil
) (rng-make-ref name
)))
257 (puthash name def grammar
)
260 (defun rng-c-make-ref (name)
261 (or rng-c-current-grammar
262 (rng-c-error "Reference not in a grammar"))
263 (cdr (rng-c-lookup-create name rng-c-current-grammar
)))
265 (defun rng-c-make-parent-ref (name)
266 (or rng-c-parent-grammar
267 (rng-c-error "Reference to non-existent parent grammar"))
268 (cdr (rng-c-lookup-create name rng-c-parent-grammar
)))
270 (defvar rng-c-overrides nil
271 "Contains a list of (NAME . DEF) pairs.")
273 (defun rng-c-merge-combine (def combine name
)
274 (let* ((about (car def
))
275 (current-combine (aref about rng-c-about-combine-slot
)))
278 (or (eq combine current-combine
)
279 (rng-c-error "Inconsistent combine for %s" name
))
280 (aset about rng-c-about-combine-slot combine
))
283 (defun rng-c-prepare-define (name combine in-include
)
284 (let* ((def (rng-c-lookup-create name rng-c-current-grammar
))
286 (overridden (aref about rng-c-about-override-slot
)))
288 (setq rng-c-overrides
(cons (cons name def
) rng-c-overrides
)))
289 (cond (overridden (and (eq overridden
'require
)
290 (aset about rng-c-about-override-slot t
))
292 (t (setq combine
(rng-c-merge-combine def combine name
))
293 (and (rng-ref-get (cdr def
))
295 (rng-c-error "Duplicate definition of %s" name
))
298 (defun rng-c-start-include (overrides)
299 (mapcar (lambda (name-def)
300 (let* ((def (cdr name-def
))
302 (save (aref about rng-c-about-override-slot
)))
303 (aset about rng-c-about-override-slot
'require
)
304 (cons save name-def
)))
307 (defun rng-c-end-include (overrides)
309 (let* ((saved (car o
))
311 (name (car name-def
))
314 (and (eq (aref about rng-c-about-override-slot
) 'require
)
315 (rng-c-error "Definition of %s in include did not override definition in included file" name
))
316 (aset about rng-c-about-override-slot saved
)))
319 (defun rng-c-define (def value
)
321 (let ((current-value (rng-ref-get (cdr def
))))
322 (rng-ref-set (cdr def
)
324 (if (eq (aref (car def
) rng-c-about-combine-slot
)
326 (rng-make-choice (list current-value value
))
327 (rng-make-interleave (list current-value value
)))
330 (defun rng-c-finish-grammar ()
331 (maphash (lambda (key def
)
332 (or (rng-ref-get (cdr def
))
333 (rng-c-error "Reference to undefined pattern %s" key
)))
334 rng-c-current-grammar
)
335 (rng-ref-get (cdr (or (gethash 'start rng-c-current-grammar
)
336 (rng-c-error "No definition of start")))))
340 (defvar rng-c-escape-positions nil
)
341 (make-variable-buffer-local 'rng-c-escape-positions
)
343 (defvar rng-c-file-name nil
)
344 (make-variable-buffer-local 'rng-c-file-name
)
346 (defvar rng-c-file-index nil
)
348 (defun rng-c-parse-file (filename &optional context
)
350 (set-buffer (get-buffer-create (rng-c-buffer-name context
)))
353 (setq rng-c-file-name
354 (car (insert-file-contents filename
)))
355 (setq rng-c-escape-positions nil
)
356 (rng-c-process-escapes)
357 (rng-c-parse-top-level context
)))
359 (defun rng-c-buffer-name (context)
360 (concat " *RNC Input"
363 (number-to-string (setq rng-c-file-index
364 (1+ rng-c-file-index
)))
366 (setq rng-c-file-index
1)
369 (defun rng-c-process-escapes ()
370 ;; Check for any nuls, since we will use nul chars
371 ;; for internal purposes.
372 (let ((pos (search-forward "\C-@" nil t
)))
374 (rng-c-error "Nul character found (binary file?)")))
376 (while (re-search-forward "\\\\x+{\\([0-9a-fA-F]+\\)}"
379 (let* ((ch (decode-char 'ucs
(string-to-number (match-string 1) 16))))
380 (if (and ch
(> ch
0))
381 (let ((begin (match-beginning 0))
383 (delete-region begin end
)
384 ;; Represent an escaped newline by nul, so
385 ;; that we can distinguish it from a literal newline.
386 ;; We will translate it back into a real newline later.
387 (insert (if (eq ch ?
\n) 0 ch
))
388 (setq offset
(+ offset
(- end begin
1)))
389 (setq rng-c-escape-positions
390 (cons (cons (point) offset
)
391 rng-c-escape-positions
)))
392 (rng-c-error "Invalid character escape")))))
395 (defun rng-c-translate-position (pos)
396 (let ((tem rng-c-escape-positions
))
399 (setq tem
(cdr tem
)))
404 (defun rng-c-error (&rest args
)
405 (rng-c-signal-incorrect-schema rng-c-file-name
406 (rng-c-translate-position (point))
407 (apply 'format args
)))
409 (defun rng-c-parse-top-level (context)
410 (let ((rng-c-namespace-decls nil
)
411 (rng-c-default-namespace nil
)
412 (rng-c-datatype-decls nil
))
413 (goto-char (point-min))
414 (forward-comment (point-max))
417 (let ((p (if (eq context
'include
)
418 (if (rng-c-implicit-grammar-p)
419 (rng-c-parse-grammar-body "")
420 (rng-c-parse-included-grammar))
421 (if (rng-c-implicit-grammar-p)
422 (rng-c-parse-implicit-grammar)
423 (rng-c-parse-pattern)))))
424 (or (string-equal rng-c-current-token
"")
425 (rng-c-error "Unexpected characters after pattern"))
428 (defun rng-c-parse-included-grammar ()
429 (or (string-equal rng-c-current-token
"grammar")
430 (rng-c-error "Included schema is not a grammar"))
433 (rng-c-parse-grammar-body "}"))
435 (defun rng-c-implicit-grammar-p ()
436 (or (and (or (rng-c-current-token-prefixed-name-p)
437 (rng-c-current-token-quoted-identifier-p)
438 (and (rng-c-current-token-ncname-p)
439 (not (rng-c-current-token-keyword-p))))
441 (and (string-equal rng-c-current-token
"[")
442 (rng-c-parse-lead-annotation)
444 (member rng-c-current-token
'("div" "include" ""))
445 (looking-at "[|&]?=")))
447 (defun rng-c-parse-decls ()
448 (setq rng-c-default-namespace-declared nil
)
451 (assoc rng-c-current-token
452 '(("namespace" . rng-c-parse-namespace
)
453 ("datatypes" . rng-c-parse-datatypes
)
454 ("default" . rng-c-parse-default
)))))
458 (funcall (cdr binding
))
461 (rng-c-declare-standard-datatypes)
462 (rng-c-declare-standard-namespaces))
464 (defun rng-c-parse-datatypes ()
465 (let ((prefix (rng-c-parse-identifier-or-keyword)))
466 (or (not (assoc prefix rng-c-datatype-decls
))
467 (rng-c-error "Duplicate datatypes declaration for prefix %s" prefix
))
469 (setq rng-c-datatype-decls
471 (rng-make-datatypes-uri (rng-c-parse-literal)))
472 rng-c-datatype-decls
))))
474 (defun rng-c-parse-namespace ()
475 (rng-c-declare-namespace nil
476 (rng-c-parse-identifier-or-keyword)))
478 (defun rng-c-parse-default ()
479 (rng-c-expect "namespace")
480 (rng-c-declare-namespace t
481 (if (string-equal rng-c-current-token
"=")
483 (rng-c-parse-identifier-or-keyword))))
485 (defun rng-c-declare-namespace (declare-default prefix
)
487 (let ((ns (cond ((string-equal rng-c-current-token
"inherit")
489 rng-c-inherit-namespace
)
491 (nxml-make-namespace (rng-c-parse-literal))))))
493 (or (not (assoc prefix rng-c-namespace-decls
))
494 (rng-c-error "Duplicate namespace declaration for prefix %s"
496 (setq rng-c-namespace-decls
497 (cons (cons prefix ns
) rng-c-namespace-decls
)))
499 (or (not rng-c-default-namespace-declared
)
500 (rng-c-error "Duplicate default namespace declaration"))
501 (setq rng-c-default-namespace-declared t
)
502 (setq rng-c-default-namespace ns
))))
504 (defun rng-c-parse-implicit-grammar ()
505 (let* ((rng-c-parent-grammar rng-c-current-grammar
)
506 (rng-c-current-grammar (rng-c-make-grammar)))
507 (rng-c-parse-grammar-body "")
508 (rng-c-finish-grammar)))
510 (defun rng-c-parse-grammar-body (close-token &optional in-include
)
511 (while (not (string-equal rng-c-current-token close-token
))
512 (cond ((rng-c-current-token-keyword-p)
513 (let ((kw (intern rng-c-current-token
)))
514 (cond ((eq kw
'start
)
515 (rng-c-parse-define 'start in-include
))
518 (rng-c-parse-div in-include
))
521 (rng-c-error "Nested include"))
523 (rng-c-parse-include))
524 (t (rng-c-error "Invalid grammar keyword")))))
525 ((rng-c-current-token-ncname-p)
526 (if (looking-at "\\[")
527 (rng-c-parse-annotation-element)
528 (rng-c-parse-define rng-c-current-token
530 ((rng-c-current-token-quoted-identifier-p)
531 (if (looking-at "\\[")
532 (rng-c-parse-annotation-element)
533 (rng-c-parse-define (substring rng-c-current-token
1)
535 ((rng-c-current-token-prefixed-name-p)
536 (rng-c-parse-annotation-element))
537 ((string-equal rng-c-current-token
"[")
538 (rng-c-parse-lead-annotation)
539 (and (string-equal rng-c-current-token close-token
)
540 (rng-c-error "Missing annotation subject"))
541 (and (looking-at "\\[")
542 (rng-c-error "Leading annotation applied to annotation")))
543 (t (rng-c-error "Invalid grammar content"))))
544 (or (string-equal rng-c-current-token
"")
547 (defun rng-c-parse-div (in-include)
549 (rng-c-parse-grammar-body "}" in-include
))
551 (defun rng-c-parse-include ()
552 (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
553 (rng-c-inherit-namespace (rng-c-parse-opt-inherit))
555 (cond ((string-equal rng-c-current-token
"{")
557 (let ((rng-c-overrides nil
))
558 (rng-c-parse-grammar-body "}" t
)
559 (setq overrides rng-c-overrides
))
560 (setq overrides
(rng-c-start-include overrides
))
561 (rng-c-parse-file filename
'include
)
562 (rng-c-end-include overrides
))
563 (t (rng-c-parse-file filename
'include
)))))
565 (defun rng-c-parse-define (name in-include
)
567 (let ((assign (assoc rng-c-current-token
570 ("&=" . interleave
)))))
572 (rng-c-error "Expected assignment operator"))
574 (let ((ref (rng-c-prepare-define name
(cdr assign
) in-include
)))
575 (rng-c-define ref
(rng-c-parse-pattern)))))
577 (defvar rng-c-had-except nil
)
579 (defun rng-c-parse-pattern ()
580 (let* ((rng-c-had-except nil
)
581 (p (rng-c-parse-repeated))
582 (op (assoc rng-c-current-token
583 '(("|" . rng-make-choice
)
584 ("," . rng-make-group
)
585 ("&" . rng-make-interleave
)))))
588 (rng-c-error "Parentheses required around pattern using -")
589 (let* ((patterns (cons p nil
))
591 (connector rng-c-current-token
))
594 (let ((newcdr (cons (rng-c-parse-repeated) nil
)))
597 (string-equal rng-c-current-token connector
)))
598 (funcall (cdr op
) patterns
)))
601 (defun rng-c-parse-repeated ()
602 (let ((p (rng-c-parse-follow-annotations
603 (rng-c-parse-primary)))
604 (op (assoc rng-c-current-token
605 '(("*" . rng-make-zero-or-more
)
606 ("+" . rng-make-one-or-more
)
607 ("?" . rng-make-optional
)))))
610 (rng-c-error "Parentheses required around pattern using -")
611 (rng-c-parse-follow-annotations
614 (funcall (cdr op
) p
))))
617 (defun rng-c-parse-primary ()
618 "Parse a primary expression. The current token must be the first
619 token of the expression. After parsing the current token should be
620 token following the primary expression."
621 (cond ((rng-c-current-token-keyword-p)
622 (let ((parse-function (get (intern rng-c-current-token
)
625 (rng-c-error "Keyword %s does not introduce a pattern"
626 rng-c-current-token
))
628 (funcall parse-function
)))
629 ((rng-c-current-token-ncname-p)
630 (rng-c-advance-with (rng-c-make-ref rng-c-current-token
)))
631 ((string-equal rng-c-current-token
"(")
633 (let ((p (rng-c-parse-pattern)))
636 ((rng-c-current-token-prefixed-name-p)
637 (let ((name (rng-c-expand-datatype rng-c-current-token
)))
639 (rng-c-parse-data name
)))
640 ((rng-c-current-token-literal-p)
641 (rng-make-value rng-token-datatype
(rng-c-parse-literal) nil
))
642 ((rng-c-current-token-quoted-identifier-p)
644 (rng-c-make-ref (substring rng-c-current-token
1))))
645 ((string-equal rng-c-current-token
"[")
646 (rng-c-parse-lead-annotation)
647 (rng-c-parse-primary))
648 (t (rng-c-error "Invalid pattern"))))
650 (defun rng-c-parse-parent ()
651 (and (rng-c-current-token-keyword-p)
652 (rng-c-error "Keyword following parent was not quoted"
653 rng-c-current-token
))
654 (rng-c-make-parent-ref (rng-c-parse-identifier-or-keyword)))
656 (defun rng-c-parse-literal ()
657 (rng-c-fix-escaped-newlines
658 (apply 'concat
(rng-c-parse-literal-segments))))
660 (defun rng-c-parse-literal-segments ()
661 (let ((str (rng-c-parse-literal-segment)))
663 (cond ((string-equal rng-c-current-token
"~")
665 (rng-c-parse-literal-segments))
668 (defun rng-c-parse-literal-segment ()
669 (or (rng-c-current-token-literal-p)
670 (rng-c-error "Expected a literal"))
672 (let ((n (if (and (>= (length rng-c-current-token
) 6)
673 (eq (aref rng-c-current-token
0)
674 (aref rng-c-current-token
1)))
677 (substring rng-c-current-token n
(- n
)))))
679 (defun rng-c-fix-escaped-newlines (str)
682 (let ((n (string-match "\C-@" str pos
)))
685 (setq pos
(1+ n
)))))))
688 (defun rng-c-parse-identifier-or-keyword ()
689 (cond ((rng-c-current-token-ncname-p)
690 (rng-c-advance-with rng-c-current-token
))
691 ((rng-c-current-token-quoted-identifier-p)
692 (rng-c-advance-with (substring rng-c-current-token
1)))
693 (t (rng-c-error "Expected identifier or keyword"))))
695 (put 'string
'rng-c-pattern
'rng-c-parse-string
)
696 (put 'token
'rng-c-pattern
'rng-c-parse-token
)
697 (put 'element
'rng-c-pattern
'rng-c-parse-element
)
698 (put 'attribute
'rng-c-pattern
'rng-c-parse-attribute
)
699 (put 'list
'rng-c-pattern
'rng-c-parse-list
)
700 (put 'mixed
'rng-c-pattern
'rng-c-parse-mixed
)
701 (put 'text
'rng-c-pattern
'rng-c-parse-text
)
702 (put 'empty
'rng-c-pattern
'rng-c-parse-empty
)
703 (put 'notAllowed
'rng-c-pattern
'rng-c-parse-not-allowed
)
704 (put 'grammar
'rng-c-pattern
'rng-c-parse-grammar
)
705 (put 'parent
'rng-c-pattern
'rng-c-parse-parent
)
706 (put 'external
'rng-c-pattern
'rng-c-parse-external
)
708 (defun rng-c-parse-element ()
709 (let ((name-class (rng-c-parse-name-class nil
)))
711 (let ((pattern (rng-c-parse-pattern)))
713 (rng-make-element name-class pattern
))))
715 (defun rng-c-parse-attribute ()
716 (let ((name-class (rng-c-parse-name-class 'attribute
)))
718 (let ((pattern (rng-c-parse-pattern)))
720 (rng-make-attribute name-class pattern
))))
722 (defun rng-c-parse-name-class (attribute)
723 (let* ((rng-c-had-except nil
)
725 (rng-c-parse-follow-annotations
726 (rng-c-parse-primary-name-class attribute
))))
727 (if (string-equal rng-c-current-token
"|")
728 (let* ((name-classes (cons name-class nil
))
730 (or (not rng-c-had-except
)
731 (rng-c-error "Parentheses required around name-class using - operator"))
735 (cons (rng-c-parse-follow-annotations
736 (rng-c-parse-primary-name-class attribute
))
740 (string-equal rng-c-current-token
"|")))
741 (rng-make-choice-name-class name-classes
))
744 (defun rng-c-parse-primary-name-class (attribute)
745 (cond ((rng-c-current-token-ncname-p)
747 (rng-make-name-name-class
748 (rng-make-name (rng-c-unqualified-namespace attribute
)
749 rng-c-current-token
))))
750 ((rng-c-current-token-prefixed-name-p)
752 (rng-make-name-name-class
753 (rng-c-expand-name rng-c-current-token
))))
754 ((string-equal rng-c-current-token
"*")
755 (let ((except (rng-c-parse-opt-except-name-class attribute
)))
757 (rng-make-any-name-except-name-class except
)
758 (rng-make-any-name-name-class))))
759 ((rng-c-current-token-ns-name-p)
761 (rng-c-lookup-prefix (substring rng-c-current-token
764 (except (rng-c-parse-opt-except-name-class attribute
)))
766 (rng-make-ns-name-except-name-class ns except
)
767 (rng-make-ns-name-name-class ns
))))
768 ((string-equal rng-c-current-token
"(")
770 (let ((name-class (rng-c-parse-name-class attribute
)))
773 ((rng-c-current-token-quoted-identifier-p)
775 (rng-make-name-name-class
776 (rng-make-name (rng-c-unqualified-namespace attribute
)
777 (substring rng-c-current-token
1)))))
778 ((string-equal rng-c-current-token
"[")
779 (rng-c-parse-lead-annotation)
780 (rng-c-parse-primary-name-class attribute
))
781 (t (rng-c-error "Bad name class"))))
783 (defun rng-c-parse-opt-except-name-class (attribute)
785 (and (string-equal rng-c-current-token
"-")
786 (or (not rng-c-had-except
)
787 (rng-c-error "Parentheses required around name-class using - operator"))
788 (setq rng-c-had-except t
)
791 (rng-c-parse-primary-name-class attribute
))))
793 (defun rng-c-parse-mixed ()
795 (let ((pattern (rng-make-mixed (rng-c-parse-pattern))))
799 (defun rng-c-parse-list ()
801 (let ((pattern (rng-make-list (rng-c-parse-pattern))))
805 (defun rng-c-parse-text ()
808 (defun rng-c-parse-empty ()
811 (defun rng-c-parse-not-allowed ()
812 (rng-make-not-allowed))
814 (defun rng-c-parse-string ()
815 (rng-c-parse-data rng-string-datatype
))
817 (defun rng-c-parse-token ()
818 (rng-c-parse-data rng-token-datatype
))
820 (defun rng-c-parse-data (name)
821 (if (rng-c-current-token-literal-p)
823 (rng-c-parse-literal)
825 (rng-c-make-context)))
826 (let ((params (rng-c-parse-optional-params)))
827 (if (string-equal rng-c-current-token
"-")
830 (rng-c-error "Parentheses required around pattern using -")
831 (setq rng-c-had-except t
))
833 (rng-make-data-except name
835 (rng-c-parse-primary)))
836 (rng-make-data name params
)))))
838 (defun rng-c-parse-optional-params ()
839 (and (string-equal rng-c-current-token
"{")
840 (let* ((head (cons nil nil
))
843 (while (not (string-equal rng-c-current-token
"}"))
844 (and (string-equal rng-c-current-token
"[")
845 (rng-c-parse-lead-annotation))
846 (let ((name (rng-c-parse-identifier-or-keyword)))
848 (let ((newcdr (cons (cons (intern name
)
849 (rng-c-parse-literal))
852 (setq tail newcdr
))))
856 (defun rng-c-parse-external ()
857 (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
858 (rng-c-inherit-namespace (rng-c-parse-opt-inherit)))
859 (rng-c-parse-file filename
'external
)))
861 (defun rng-c-expand-file (uri)
863 (rng-uri-file-name (rng-uri-resolve uri
864 (rng-file-name-uri rng-c-file-name
)))
866 (rng-c-error (cadr err
)))))
868 (defun rng-c-parse-opt-inherit ()
869 (cond ((string-equal rng-c-current-token
"inherit")
872 (rng-c-lookup-prefix (rng-c-parse-identifier-or-keyword)))
873 (t rng-c-default-namespace
)))
875 (defun rng-c-parse-grammar ()
877 (let* ((rng-c-parent-grammar rng-c-current-grammar
)
878 (rng-c-current-grammar (rng-c-make-grammar)))
879 (rng-c-parse-grammar-body "}")
880 (rng-c-finish-grammar)))
882 (defun rng-c-parse-lead-annotation ()
883 (rng-c-parse-annotation-body)
884 (and (string-equal rng-c-current-token
"[")
885 (rng-c-error "Multiple leading annotations")))
887 (defun rng-c-parse-follow-annotations (obj)
888 (while (string-equal rng-c-current-token
">>")
890 (if (rng-c-current-token-prefixed-name-p)
892 (rng-c-parse-identifier-or-keyword))
893 (rng-c-parse-annotation-body t
))
896 (defun rng-c-parse-annotation-element ()
898 (rng-c-parse-annotation-body t
))
900 ;; XXX need stricter checking of attribute names
901 ;; XXX don't allow attributes after text
903 (defun rng-c-parse-annotation-body (&optional allow-text
)
904 "Current token is [. Parse up to matching ]. Current token after
905 parse is token following ]."
906 (or (string-equal rng-c-current-token
"[")
907 (rng-c-error "Expected ["))
909 (while (not (string-equal rng-c-current-token
"]"))
910 (cond ((rng-c-current-token-literal-p)
912 (rng-c-error "Out of place text within annotation"))
913 (rng-c-parse-literal))
915 (if (rng-c-current-token-prefixed-name-p)
917 (rng-c-parse-identifier-or-keyword))
918 (cond ((string-equal rng-c-current-token
"[")
919 (rng-c-parse-annotation-body t
))
920 ((string-equal rng-c-current-token
"=")
922 (rng-c-parse-literal))
923 (t (rng-c-error "Expected = or ["))))))
926 (defun rng-c-advance-with (pattern)
930 (defun rng-c-expect (str)
931 (or (string-equal rng-c-current-token str
)
932 (rng-c-error "Expected `%s' but got `%s'" str rng-c-current-token
))
939 ;; arch-tag: 90395eb1-283b-4146-bbc1-6d6ef1704e57