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, or (at your option)
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; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 ;; This parses a RELAX NG Compact Syntax schema into the form
28 ;; specified in rng-pttrn.el.
30 ;; RELAX NG Compact Syntax is specified by
31 ;; http://relaxng.org/compact.html
33 ;; This file uses the prefix "rng-c-".
43 (defun rng-c-load-schema (filename)
44 "Load a schema in RELAX NG compact syntax from FILENAME.
46 (rng-c-parse-file filename
))
50 (put 'rng-c-incorrect-schema
52 '(error rng-error nxml-file-parse-error rng-c-incorrect-schema
))
54 (put 'rng-c-incorrect-schema
58 (defun rng-c-signal-incorrect-schema (filename pos message
)
59 (nxml-signal-file-parse-error filename
62 'rng-c-incorrect-schema
))
66 (defconst rng-c-keywords
86 "List of strings that are keywords in the compact syntax.")
88 (defconst rng-c-anchored-keyword-re
89 (concat "\\`\\(" (regexp-opt rng-c-keywords
) "\\)\\'")
90 "Regular expression to match a keyword in the compact syntax.")
92 (defvar rng-c-syntax-table nil
93 "Syntax table for parsing the compact syntax.")
95 (if rng-c-syntax-table
97 (setq rng-c-syntax-table
(make-syntax-table))
98 (modify-syntax-entry ?
# "<" rng-c-syntax-table
)
99 (modify-syntax-entry ?
\n ">" rng-c-syntax-table
)
100 (modify-syntax-entry ?-
"w" rng-c-syntax-table
)
101 (modify-syntax-entry ?.
"w" rng-c-syntax-table
)
102 (modify-syntax-entry ?_
"w" rng-c-syntax-table
)
103 (modify-syntax-entry ?
: "_" rng-c-syntax-table
))
105 (defconst rng-c-literal-1-re
106 "'\\(''\\([^']\\|'[^']\\|''[^']\\)*''\\|[^'\n]*\\)'"
107 "Regular expression to match a single-quoted literal.")
109 (defconst rng-c-literal-2-re
110 (replace-regexp-in-string "'" "\"" rng-c-literal-1-re
)
111 "Regular expression to match a double-quoted literal.")
113 (defconst rng-c-ncname-re
"\\w+")
115 (defconst rng-c-anchored-ncname-re
116 (concat "\\`" rng-c-ncname-re
"\\'"))
118 (defconst rng-c-token-re
119 (concat "[&|]=" "\\|"
120 "[][()|&,*+?{}~=-]" "\\|"
121 rng-c-literal-1-re
"\\|"
122 rng-c-literal-2-re
"\\|"
123 rng-c-ncname-re
"\\(:\\(\\*\\|" rng-c-ncname-re
"\\)\\)?" "\\|"
124 "\\\\" rng-c-ncname-re
"\\|"
126 "Regular expression to match a token in the compact syntax.")
128 (defun rng-c-init-buffer ()
129 (setq case-fold-search nil
) ; automatically becomes buffer-local when set
130 (set-buffer-multibyte t
)
131 (set-syntax-table rng-c-syntax-table
))
133 (defvar rng-c-current-token nil
)
134 (make-variable-buffer-local 'rng-c-current-token
)
136 (defun rng-c-advance ()
137 (cond ((looking-at rng-c-token-re
)
138 (setq rng-c-current-token
(match-string 0))
139 (goto-char (match-end 0))
140 (forward-comment (point-max)))
141 ((= (point) (point-max))
142 (setq rng-c-current-token
""))
143 (t (rng-c-error "Invalid token"))))
145 (defconst rng-c-anchored-datatype-name-re
146 (concat "\\`" rng-c-ncname-re
":" rng-c-ncname-re
"\\'"))
148 (defsubst rng-c-current-token-keyword-p
()
149 (string-match rng-c-anchored-keyword-re rng-c-current-token
))
151 (defsubst rng-c-current-token-prefixed-name-p
()
152 (string-match rng-c-anchored-datatype-name-re rng-c-current-token
))
154 (defsubst rng-c-current-token-literal-p
()
155 (string-match "\\`['\"]" rng-c-current-token
))
157 (defsubst rng-c-current-token-quoted-identifier-p
()
158 (string-match "\\`\\\\" rng-c-current-token
))
160 (defsubst rng-c-current-token-ncname-p
()
161 (string-match rng-c-anchored-ncname-re rng-c-current-token
))
163 (defsubst rng-c-current-token-ns-name-p
()
164 (let ((len (length rng-c-current-token
)))
166 (= (aref rng-c-current-token
(- len
1)) ?
*))))
170 (defvar rng-c-inherit-namespace nil
)
172 (defvar rng-c-default-namespace nil
)
174 (defvar rng-c-default-namespace-declared nil
)
176 (defvar rng-c-namespace-decls nil
177 "Alist of namespace declarations.")
179 (defconst rng-c-no-namespace nil
)
181 (defun rng-c-declare-standard-namespaces ()
182 (setq rng-c-namespace-decls
183 (cons (cons "xml" nxml-xml-namespace-uri
)
184 rng-c-namespace-decls
))
185 (when (and (not rng-c-default-namespace-declared
)
186 rng-c-inherit-namespace
)
187 (setq rng-c-default-namespace rng-c-inherit-namespace
)))
189 (defun rng-c-expand-name (prefixed-name)
190 (let ((i (string-match ":" prefixed-name
)))
191 (rng-make-name (rng-c-lookup-prefix (substring prefixed-name
194 (substring prefixed-name
(+ i
1)))))
196 (defun rng-c-lookup-prefix (prefix)
197 (let ((binding (assoc prefix rng-c-namespace-decls
)))
198 (or binding
(rng-c-error "Undefined prefix %s" prefix
))
201 (defun rng-c-unqualified-namespace (attribute)
204 rng-c-default-namespace
))
206 (defun rng-c-make-context ()
207 (cons rng-c-default-namespace rng-c-namespace-decls
))
211 (defconst rng-string-datatype
212 (rng-make-datatype rng-builtin-datatypes-uri
"string"))
214 (defconst rng-token-datatype
215 (rng-make-datatype rng-builtin-datatypes-uri
"token"))
217 (defvar rng-c-datatype-decls nil
218 "Alist of datatype declarations.
219 Contains a list of pairs (PREFIX . URI) where PREFIX is a string
220 and URI is a symbol.")
222 (defun rng-c-declare-standard-datatypes ()
223 (setq rng-c-datatype-decls
224 (cons (cons "xsd" rng-xsd-datatypes-uri
)
225 rng-c-datatype-decls
)))
227 (defun rng-c-lookup-datatype-prefix (prefix)
228 (let ((binding (assoc prefix rng-c-datatype-decls
)))
229 (or binding
(rng-c-error "Undefined prefix %s" prefix
))
232 (defun rng-c-expand-datatype (prefixed-name)
233 (let ((i (string-match ":" prefixed-name
)))
235 (rng-c-lookup-datatype-prefix (substring prefixed-name
0 i
))
236 (substring prefixed-name
(+ i
1)))))
240 (defvar rng-c-current-grammar nil
)
241 (defvar rng-c-parent-grammar nil
)
243 (defun rng-c-make-grammar ()
244 (make-hash-table :test
'equal
))
246 (defconst rng-c-about-override-slot
0)
247 (defconst rng-c-about-combine-slot
1)
249 (defun rng-c-lookup-create (name grammar
)
250 "Return a def object for NAME. A def object is a pair
251 \(ABOUT . REF) where REF is returned by `rng-make-ref'. ABOUT is a
252 two-element vector [OVERRIDE COMBINE]. COMBINE is either nil, choice
253 or interleave. OVERRIDE is either nil, require or t."
254 (let ((def (gethash name grammar
)))
258 (setq def
(cons (vector nil nil
) (rng-make-ref name
)))
259 (puthash name def grammar
)
262 (defun rng-c-make-ref (name)
263 (or rng-c-current-grammar
264 (rng-c-error "Reference not in a grammar"))
265 (cdr (rng-c-lookup-create name rng-c-current-grammar
)))
267 (defun rng-c-make-parent-ref (name)
268 (or rng-c-parent-grammar
269 (rng-c-error "Reference to non-existent parent grammar"))
270 (cdr (rng-c-lookup-create name rng-c-parent-grammar
)))
272 (defvar rng-c-overrides nil
273 "Contains a list of (NAME . DEF) pairs.")
275 (defun rng-c-merge-combine (def combine name
)
276 (let* ((about (car def
))
277 (current-combine (aref about rng-c-about-combine-slot
)))
280 (or (eq combine current-combine
)
281 (rng-c-error "Inconsistent combine for %s" name
))
282 (aset about rng-c-about-combine-slot combine
))
285 (defun rng-c-prepare-define (name combine in-include
)
286 (let* ((def (rng-c-lookup-create name rng-c-current-grammar
))
288 (overridden (aref about rng-c-about-override-slot
)))
290 (setq rng-c-overrides
(cons (cons name def
) rng-c-overrides
)))
291 (cond (overridden (and (eq overridden
'require
)
292 (aset about rng-c-about-override-slot t
))
294 (t (setq combine
(rng-c-merge-combine def combine name
))
295 (and (rng-ref-get (cdr def
))
297 (rng-c-error "Duplicate definition of %s" name
))
300 (defun rng-c-start-include (overrides)
301 (mapcar (lambda (name-def)
302 (let* ((def (cdr name-def
))
304 (save (aref about rng-c-about-override-slot
)))
305 (aset about rng-c-about-override-slot
'require
)
306 (cons save name-def
)))
309 (defun rng-c-end-include (overrides)
311 (let* ((saved (car o
))
313 (name (car name-def
))
316 (and (eq (aref about rng-c-about-override-slot
) 'require
)
317 (rng-c-error "Definition of %s in include did not override definition in included file" name
))
318 (aset about rng-c-about-override-slot saved
)))
321 (defun rng-c-define (def value
)
323 (let ((current-value (rng-ref-get (cdr def
))))
324 (rng-ref-set (cdr def
)
326 (if (eq (aref (car def
) rng-c-about-combine-slot
)
328 (rng-make-choice (list current-value value
))
329 (rng-make-interleave (list current-value value
)))
332 (defun rng-c-finish-grammar ()
333 (maphash (lambda (key def
)
334 (or (rng-ref-get (cdr def
))
335 (rng-c-error "Reference to undefined pattern %s" key
)))
336 rng-c-current-grammar
)
337 (rng-ref-get (cdr (or (gethash 'start rng-c-current-grammar
)
338 (rng-c-error "No definition of start")))))
342 (defvar rng-c-escape-positions nil
)
343 (make-variable-buffer-local 'rng-c-escape-positions
)
345 (defvar rng-c-file-name nil
)
346 (make-variable-buffer-local 'rng-c-file-name
)
348 (defvar rng-c-file-index nil
)
350 (defun rng-c-parse-file (filename &optional context
)
352 (set-buffer (get-buffer-create (rng-c-buffer-name context
)))
355 (setq rng-c-file-name
356 (car (insert-file-contents filename
)))
357 (setq rng-c-escape-positions nil
)
358 (rng-c-process-escapes)
359 (rng-c-parse-top-level context
)))
361 (defun rng-c-buffer-name (context)
362 (concat " *RNC Input"
365 (number-to-string (setq rng-c-file-index
366 (1+ rng-c-file-index
)))
368 (setq rng-c-file-index
1)
371 (defun rng-c-process-escapes ()
372 ;; Check for any nuls, since we will use nul chars
373 ;; for internal purposes.
374 (let ((pos (search-forward "\C-@" nil t
)))
376 (rng-c-error "Nul character found (binary file?)")))
378 (while (re-search-forward "\\\\x+{\\([0-9a-fA-F]+\\)}"
381 (let* ((ch (decode-char 'ucs
(string-to-number (match-string 1) 16))))
382 (if (and ch
(> ch
0))
383 (let ((begin (match-beginning 0))
385 (delete-region begin end
)
386 ;; Represent an escaped newline by nul, so
387 ;; that we can distinguish it from a literal newline.
388 ;; We will translate it back into a real newline later.
389 (insert (if (eq ch ?
\n) 0 ch
))
390 (setq offset
(+ offset
(- end begin
1)))
391 (setq rng-c-escape-positions
392 (cons (cons (point) offset
)
393 rng-c-escape-positions
)))
394 (rng-c-error "Invalid character escape")))))
397 (defun rng-c-translate-position (pos)
398 (let ((tem rng-c-escape-positions
))
401 (setq tem
(cdr tem
)))
406 (defun rng-c-error (&rest args
)
407 (rng-c-signal-incorrect-schema rng-c-file-name
408 (rng-c-translate-position (point))
409 (apply 'format args
)))
411 (defun rng-c-parse-top-level (context)
412 (let ((rng-c-namespace-decls nil
)
413 (rng-c-default-namespace nil
)
414 (rng-c-datatype-decls nil
))
415 (goto-char (point-min))
416 (forward-comment (point-max))
419 (let ((p (if (eq context
'include
)
420 (if (rng-c-implicit-grammar-p)
421 (rng-c-parse-grammar-body "")
422 (rng-c-parse-included-grammar))
423 (if (rng-c-implicit-grammar-p)
424 (rng-c-parse-implicit-grammar)
425 (rng-c-parse-pattern)))))
426 (or (string-equal rng-c-current-token
"")
427 (rng-c-error "Unexpected characters after pattern"))
430 (defun rng-c-parse-included-grammar ()
431 (or (string-equal rng-c-current-token
"grammar")
432 (rng-c-error "Included schema is not a grammar"))
435 (rng-c-parse-grammar-body "}"))
437 (defun rng-c-implicit-grammar-p ()
438 (or (and (or (rng-c-current-token-prefixed-name-p)
439 (rng-c-current-token-quoted-identifier-p)
440 (and (rng-c-current-token-ncname-p)
441 (not (rng-c-current-token-keyword-p))))
443 (and (string-equal rng-c-current-token
"[")
444 (rng-c-parse-lead-annotation)
446 (member rng-c-current-token
'("div" "include" ""))
447 (looking-at "[|&]?=")))
449 (defun rng-c-parse-decls ()
450 (setq rng-c-default-namespace-declared nil
)
453 (assoc rng-c-current-token
454 '(("namespace" . rng-c-parse-namespace
)
455 ("datatypes" . rng-c-parse-datatypes
)
456 ("default" . rng-c-parse-default
)))))
460 (funcall (cdr binding
))
463 (rng-c-declare-standard-datatypes)
464 (rng-c-declare-standard-namespaces))
466 (defun rng-c-parse-datatypes ()
467 (let ((prefix (rng-c-parse-identifier-or-keyword)))
468 (or (not (assoc prefix rng-c-datatype-decls
))
469 (rng-c-error "Duplicate datatypes declaration for prefix %s" prefix
))
471 (setq rng-c-datatype-decls
473 (rng-make-datatypes-uri (rng-c-parse-literal)))
474 rng-c-datatype-decls
))))
476 (defun rng-c-parse-namespace ()
477 (rng-c-declare-namespace nil
478 (rng-c-parse-identifier-or-keyword)))
480 (defun rng-c-parse-default ()
481 (rng-c-expect "namespace")
482 (rng-c-declare-namespace t
483 (if (string-equal rng-c-current-token
"=")
485 (rng-c-parse-identifier-or-keyword))))
487 (defun rng-c-declare-namespace (declare-default prefix
)
489 (let ((ns (cond ((string-equal rng-c-current-token
"inherit")
491 rng-c-inherit-namespace
)
493 (nxml-make-namespace (rng-c-parse-literal))))))
495 (or (not (assoc prefix rng-c-namespace-decls
))
496 (rng-c-error "Duplicate namespace declaration for prefix %s"
498 (setq rng-c-namespace-decls
499 (cons (cons prefix ns
) rng-c-namespace-decls
)))
501 (or (not rng-c-default-namespace-declared
)
502 (rng-c-error "Duplicate default namespace declaration"))
503 (setq rng-c-default-namespace-declared t
)
504 (setq rng-c-default-namespace ns
))))
506 (defun rng-c-parse-implicit-grammar ()
507 (let* ((rng-c-parent-grammar rng-c-current-grammar
)
508 (rng-c-current-grammar (rng-c-make-grammar)))
509 (rng-c-parse-grammar-body "")
510 (rng-c-finish-grammar)))
512 (defun rng-c-parse-grammar-body (close-token &optional in-include
)
513 (while (not (string-equal rng-c-current-token close-token
))
514 (cond ((rng-c-current-token-keyword-p)
515 (let ((kw (intern rng-c-current-token
)))
516 (cond ((eq kw
'start
)
517 (rng-c-parse-define 'start in-include
))
520 (rng-c-parse-div in-include
))
523 (rng-c-error "Nested include"))
525 (rng-c-parse-include))
526 (t (rng-c-error "Invalid grammar keyword")))))
527 ((rng-c-current-token-ncname-p)
528 (if (looking-at "\\[")
529 (rng-c-parse-annotation-element)
530 (rng-c-parse-define rng-c-current-token
532 ((rng-c-current-token-quoted-identifier-p)
533 (if (looking-at "\\[")
534 (rng-c-parse-annotation-element)
535 (rng-c-parse-define (substring rng-c-current-token
1)
537 ((rng-c-current-token-prefixed-name-p)
538 (rng-c-parse-annotation-element))
539 ((string-equal rng-c-current-token
"[")
540 (rng-c-parse-lead-annotation)
541 (and (string-equal rng-c-current-token close-token
)
542 (rng-c-error "Missing annotation subject"))
543 (and (looking-at "\\[")
544 (rng-c-error "Leading annotation applied to annotation")))
545 (t (rng-c-error "Invalid grammar content"))))
546 (or (string-equal rng-c-current-token
"")
549 (defun rng-c-parse-div (in-include)
551 (rng-c-parse-grammar-body "}" in-include
))
553 (defun rng-c-parse-include ()
554 (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
555 (rng-c-inherit-namespace (rng-c-parse-opt-inherit))
557 (cond ((string-equal rng-c-current-token
"{")
559 (let ((rng-c-overrides nil
))
560 (rng-c-parse-grammar-body "}" t
)
561 (setq overrides rng-c-overrides
))
562 (setq overrides
(rng-c-start-include overrides
))
563 (rng-c-parse-file filename
'include
)
564 (rng-c-end-include overrides
))
565 (t (rng-c-parse-file filename
'include
)))))
567 (defun rng-c-parse-define (name in-include
)
569 (let ((assign (assoc rng-c-current-token
572 ("&=" . interleave
)))))
574 (rng-c-error "Expected assignment operator"))
576 (let ((ref (rng-c-prepare-define name
(cdr assign
) in-include
)))
577 (rng-c-define ref
(rng-c-parse-pattern)))))
579 (defvar rng-c-had-except nil
)
581 (defun rng-c-parse-pattern ()
582 (let* ((rng-c-had-except nil
)
583 (p (rng-c-parse-repeated))
584 (op (assoc rng-c-current-token
585 '(("|" . rng-make-choice
)
586 ("," . rng-make-group
)
587 ("&" . rng-make-interleave
)))))
590 (rng-c-error "Parentheses required around pattern using -")
591 (let* ((patterns (cons p nil
))
593 (connector rng-c-current-token
))
596 (let ((newcdr (cons (rng-c-parse-repeated) nil
)))
599 (string-equal rng-c-current-token connector
)))
600 (funcall (cdr op
) patterns
)))
603 (defun rng-c-parse-repeated ()
604 (let ((p (rng-c-parse-follow-annotations
605 (rng-c-parse-primary)))
606 (op (assoc rng-c-current-token
607 '(("*" . rng-make-zero-or-more
)
608 ("+" . rng-make-one-or-more
)
609 ("?" . rng-make-optional
)))))
612 (rng-c-error "Parentheses required around pattern using -")
613 (rng-c-parse-follow-annotations
616 (funcall (cdr op
) p
))))
619 (defun rng-c-parse-primary ()
620 "Parse a primary expression. The current token must be the first
621 token of the expression. After parsing the current token should be
622 token following the primary expression."
623 (cond ((rng-c-current-token-keyword-p)
624 (let ((parse-function (get (intern rng-c-current-token
)
627 (rng-c-error "Keyword %s does not introduce a pattern"
628 rng-c-current-token
))
630 (funcall parse-function
)))
631 ((rng-c-current-token-ncname-p)
632 (rng-c-advance-with (rng-c-make-ref rng-c-current-token
)))
633 ((string-equal rng-c-current-token
"(")
635 (let ((p (rng-c-parse-pattern)))
638 ((rng-c-current-token-prefixed-name-p)
639 (let ((name (rng-c-expand-datatype rng-c-current-token
)))
641 (rng-c-parse-data name
)))
642 ((rng-c-current-token-literal-p)
643 (rng-make-value rng-token-datatype
(rng-c-parse-literal) nil
))
644 ((rng-c-current-token-quoted-identifier-p)
646 (rng-c-make-ref (substring rng-c-current-token
1))))
647 ((string-equal rng-c-current-token
"[")
648 (rng-c-parse-lead-annotation)
649 (rng-c-parse-primary))
650 (t (rng-c-error "Invalid pattern"))))
652 (defun rng-c-parse-parent ()
653 (and (rng-c-current-token-keyword-p)
654 (rng-c-error "Keyword following parent was not quoted"
655 rng-c-current-token
))
656 (rng-c-make-parent-ref (rng-c-parse-identifier-or-keyword)))
658 (defun rng-c-parse-literal ()
659 (rng-c-fix-escaped-newlines
660 (apply 'concat
(rng-c-parse-literal-segments))))
662 (defun rng-c-parse-literal-segments ()
663 (let ((str (rng-c-parse-literal-segment)))
665 (cond ((string-equal rng-c-current-token
"~")
667 (rng-c-parse-literal-segments))
670 (defun rng-c-parse-literal-segment ()
671 (or (rng-c-current-token-literal-p)
672 (rng-c-error "Expected a literal"))
674 (let ((n (if (and (>= (length rng-c-current-token
) 6)
675 (eq (aref rng-c-current-token
0)
676 (aref rng-c-current-token
1)))
679 (substring rng-c-current-token n
(- n
)))))
681 (defun rng-c-fix-escaped-newlines (str)
684 (let ((n (string-match "\C-@" str pos
)))
687 (setq pos
(1+ n
)))))))
690 (defun rng-c-parse-identifier-or-keyword ()
691 (cond ((rng-c-current-token-ncname-p)
692 (rng-c-advance-with rng-c-current-token
))
693 ((rng-c-current-token-quoted-identifier-p)
694 (rng-c-advance-with (substring rng-c-current-token
1)))
695 (t (rng-c-error "Expected identifier or keyword"))))
697 (put 'string
'rng-c-pattern
'rng-c-parse-string
)
698 (put 'token
'rng-c-pattern
'rng-c-parse-token
)
699 (put 'element
'rng-c-pattern
'rng-c-parse-element
)
700 (put 'attribute
'rng-c-pattern
'rng-c-parse-attribute
)
701 (put 'list
'rng-c-pattern
'rng-c-parse-list
)
702 (put 'mixed
'rng-c-pattern
'rng-c-parse-mixed
)
703 (put 'text
'rng-c-pattern
'rng-c-parse-text
)
704 (put 'empty
'rng-c-pattern
'rng-c-parse-empty
)
705 (put 'notAllowed
'rng-c-pattern
'rng-c-parse-not-allowed
)
706 (put 'grammar
'rng-c-pattern
'rng-c-parse-grammar
)
707 (put 'parent
'rng-c-pattern
'rng-c-parse-parent
)
708 (put 'external
'rng-c-pattern
'rng-c-parse-external
)
710 (defun rng-c-parse-element ()
711 (let ((name-class (rng-c-parse-name-class nil
)))
713 (let ((pattern (rng-c-parse-pattern)))
715 (rng-make-element name-class pattern
))))
717 (defun rng-c-parse-attribute ()
718 (let ((name-class (rng-c-parse-name-class 'attribute
)))
720 (let ((pattern (rng-c-parse-pattern)))
722 (rng-make-attribute name-class pattern
))))
724 (defun rng-c-parse-name-class (attribute)
725 (let* ((rng-c-had-except nil
)
727 (rng-c-parse-follow-annotations
728 (rng-c-parse-primary-name-class attribute
))))
729 (if (string-equal rng-c-current-token
"|")
730 (let* ((name-classes (cons name-class nil
))
732 (or (not rng-c-had-except
)
733 (rng-c-error "Parentheses required around name-class using - operator"))
737 (cons (rng-c-parse-follow-annotations
738 (rng-c-parse-primary-name-class attribute
))
742 (string-equal rng-c-current-token
"|")))
743 (rng-make-choice-name-class name-classes
))
746 (defun rng-c-parse-primary-name-class (attribute)
747 (cond ((rng-c-current-token-ncname-p)
749 (rng-make-name-name-class
750 (rng-make-name (rng-c-unqualified-namespace attribute
)
751 rng-c-current-token
))))
752 ((rng-c-current-token-prefixed-name-p)
754 (rng-make-name-name-class
755 (rng-c-expand-name rng-c-current-token
))))
756 ((string-equal rng-c-current-token
"*")
757 (let ((except (rng-c-parse-opt-except-name-class attribute
)))
759 (rng-make-any-name-except-name-class except
)
760 (rng-make-any-name-name-class))))
761 ((rng-c-current-token-ns-name-p)
763 (rng-c-lookup-prefix (substring rng-c-current-token
766 (except (rng-c-parse-opt-except-name-class attribute
)))
768 (rng-make-ns-name-except-name-class ns except
)
769 (rng-make-ns-name-name-class ns
))))
770 ((string-equal rng-c-current-token
"(")
772 (let ((name-class (rng-c-parse-name-class attribute
)))
775 ((rng-c-current-token-quoted-identifier-p)
777 (rng-make-name-name-class
778 (rng-make-name (rng-c-unqualified-namespace attribute
)
779 (substring rng-c-current-token
1)))))
780 ((string-equal rng-c-current-token
"[")
781 (rng-c-parse-lead-annotation)
782 (rng-c-parse-primary-name-class attribute
))
783 (t (rng-c-error "Bad name class"))))
785 (defun rng-c-parse-opt-except-name-class (attribute)
787 (and (string-equal rng-c-current-token
"-")
788 (or (not rng-c-had-except
)
789 (rng-c-error "Parentheses required around name-class using - operator"))
790 (setq rng-c-had-except t
)
793 (rng-c-parse-primary-name-class attribute
))))
795 (defun rng-c-parse-mixed ()
797 (let ((pattern (rng-make-mixed (rng-c-parse-pattern))))
801 (defun rng-c-parse-list ()
803 (let ((pattern (rng-make-list (rng-c-parse-pattern))))
807 (defun rng-c-parse-text ()
810 (defun rng-c-parse-empty ()
813 (defun rng-c-parse-not-allowed ()
814 (rng-make-not-allowed))
816 (defun rng-c-parse-string ()
817 (rng-c-parse-data rng-string-datatype
))
819 (defun rng-c-parse-token ()
820 (rng-c-parse-data rng-token-datatype
))
822 (defun rng-c-parse-data (name)
823 (if (rng-c-current-token-literal-p)
825 (rng-c-parse-literal)
827 (rng-c-make-context)))
828 (let ((params (rng-c-parse-optional-params)))
829 (if (string-equal rng-c-current-token
"-")
832 (rng-c-error "Parentheses required around pattern using -")
833 (setq rng-c-had-except t
))
835 (rng-make-data-except name
837 (rng-c-parse-primary)))
838 (rng-make-data name params
)))))
840 (defun rng-c-parse-optional-params ()
841 (and (string-equal rng-c-current-token
"{")
842 (let* ((head (cons nil nil
))
845 (while (not (string-equal rng-c-current-token
"}"))
846 (and (string-equal rng-c-current-token
"[")
847 (rng-c-parse-lead-annotation))
848 (let ((name (rng-c-parse-identifier-or-keyword)))
850 (let ((newcdr (cons (cons (intern name
)
851 (rng-c-parse-literal))
854 (setq tail newcdr
))))
858 (defun rng-c-parse-external ()
859 (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
860 (rng-c-inherit-namespace (rng-c-parse-opt-inherit)))
861 (rng-c-parse-file filename
'external
)))
863 (defun rng-c-expand-file (uri)
865 (rng-uri-file-name (rng-uri-resolve uri
866 (rng-file-name-uri rng-c-file-name
)))
868 (rng-c-error (cadr err
)))))
870 (defun rng-c-parse-opt-inherit ()
871 (cond ((string-equal rng-c-current-token
"inherit")
874 (rng-c-lookup-prefix (rng-c-parse-identifier-or-keyword)))
875 (t rng-c-default-namespace
)))
877 (defun rng-c-parse-grammar ()
879 (let* ((rng-c-parent-grammar rng-c-current-grammar
)
880 (rng-c-current-grammar (rng-c-make-grammar)))
881 (rng-c-parse-grammar-body "}")
882 (rng-c-finish-grammar)))
884 (defun rng-c-parse-lead-annotation ()
885 (rng-c-parse-annotation-body)
886 (and (string-equal rng-c-current-token
"[")
887 (rng-c-error "Multiple leading annotations")))
889 (defun rng-c-parse-follow-annotations (obj)
890 (while (string-equal rng-c-current-token
">>")
892 (if (rng-c-current-token-prefixed-name-p)
894 (rng-c-parse-identifier-or-keyword))
895 (rng-c-parse-annotation-body t
))
898 (defun rng-c-parse-annotation-element ()
900 (rng-c-parse-annotation-body t
))
902 ;; XXX need stricter checking of attribute names
903 ;; XXX don't allow attributes after text
905 (defun rng-c-parse-annotation-body (&optional allow-text
)
906 "Current token is [. Parse up to matching ]. Current token after
907 parse is token following ]."
908 (or (string-equal rng-c-current-token
"[")
909 (rng-c-error "Expected ["))
911 (while (not (string-equal rng-c-current-token
"]"))
912 (cond ((rng-c-current-token-literal-p)
914 (rng-c-error "Out of place text within annotation"))
915 (rng-c-parse-literal))
917 (if (rng-c-current-token-prefixed-name-p)
919 (rng-c-parse-identifier-or-keyword))
920 (cond ((string-equal rng-c-current-token
"[")
921 (rng-c-parse-annotation-body t
))
922 ((string-equal rng-c-current-token
"=")
924 (rng-c-parse-literal))
925 (t (rng-c-error "Expected = or ["))))))
928 (defun rng-c-advance-with (pattern)
932 (defun rng-c-expect (str)
933 (or (string-equal rng-c-current-token str
)
934 (rng-c-error "Expected `%s' but got `%s'" str rng-c-current-token
))
941 ;; arch-tag: 90395eb1-283b-4146-bbc1-6d6ef1704e57