code.delx.au - gnu-emacs/blob - lisp/nxml/rng-cmpct.el

   1 ;;; rng-cmpct.el --- parsing of RELAX NG Compact Syntax schemas
   2
   3 ;; Copyright (C) 2003, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML, RelaxNG
   7
   8 ;; This file is part of GNU Emacs.
   9
  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.
  14
  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.
  19
  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/>.
  22
  23 ;;; Commentary:
  24
  25 ;; This parses a RELAX NG Compact Syntax schema into the form
  26 ;; specified in rng-pttrn.el.
  27 ;;
  28 ;; RELAX NG Compact Syntax is specified by
  29 ;;    http://relaxng.org/compact.html
  30 ;;
  31 ;; This file uses the prefix "rng-c-".
  32
  33 ;;; Code:
  34
  35 (require 'nxml-util)
  36 (require 'rng-util)
  37 (require 'rng-uri)
  38 (require 'rng-pttrn)
  39
  40 ;;;###autoload
  41 (defun rng-c-load-schema (filename)
  42   "Load a schema in RELAX NG compact syntax from FILENAME.
  43 Return a pattern."
  44   (rng-c-parse-file filename))
  45
  46 ;;; Error handling
  47
  48 (put 'rng-c-incorrect-schema
  49      'error-conditions
  50      '(error rng-error nxml-file-parse-error rng-c-incorrect-schema))
  51
  52 (put 'rng-c-incorrect-schema
  53      'error-message
  54      "Incorrect schema")
  55
  56 (defun rng-c-signal-incorrect-schema (filename pos message)
  57   (nxml-signal-file-parse-error filename
  58                                 pos
  59                                 message
  60                                 'rng-c-incorrect-schema))
  61
  62 ;;; Lexing
  63
  64 (defconst rng-c-keywords
  65   '("attribute"
  66     "default"
  67     "datatypes"
  68     "div"
  69     "element"
  70     "empty"
  71     "external"
  72     "grammar"
  73     "include"
  74     "inherit"
  75     "list"
  76     "mixed"
  77     "namespace"
  78     "notAllowed"
  79     "parent"
  80     "start"
  81     "string"
  82     "text"
  83     "token")
  84   "List of strings that are keywords in the compact syntax.")
  85
  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.")
  89
  90 (defvar rng-c-syntax-table nil
  91   "Syntax table for parsing the compact syntax.")
  92
  93 (if rng-c-syntax-table
  94     ()
  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))
 102
 103 (defconst rng-c-literal-1-re
 104   "'\\(''\\([^']\\|'[^']\\|''[^']\\)*''\\|[^'\n]*\\)'"
 105   "Regular expression to match a single-quoted literal.")
 106
 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.")
 110
 111 (defconst rng-c-ncname-re "\\w+")
 112
 113 (defconst rng-c-anchored-ncname-re
 114   (concat "\\`" rng-c-ncname-re "\\'"))
 115
 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 "\\|"
 123           ">>")
 124   "Regular expression to match a token in the compact syntax.")
 125
 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))
 130
 131 (defvar rng-c-current-token nil)
 132 (make-variable-buffer-local 'rng-c-current-token)
 133
 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"))))
 142
 143 (defconst rng-c-anchored-datatype-name-re
 144   (concat "\\`" rng-c-ncname-re ":"  rng-c-ncname-re "\\'"))
 145
 146 (defsubst rng-c-current-token-keyword-p ()
 147   (string-match rng-c-anchored-keyword-re rng-c-current-token))
 148
 149 (defsubst rng-c-current-token-prefixed-name-p ()
 150   (string-match rng-c-anchored-datatype-name-re rng-c-current-token))
 151
 152 (defsubst rng-c-current-token-literal-p ()
 153   (string-match "\\`['\"]" rng-c-current-token))
 154
 155 (defsubst rng-c-current-token-quoted-identifier-p ()
 156   (string-match "\\`\\\\" rng-c-current-token))
 157
 158 (defsubst rng-c-current-token-ncname-p ()
 159   (string-match rng-c-anchored-ncname-re rng-c-current-token))
 160
 161 (defsubst rng-c-current-token-ns-name-p ()
 162   (let ((len (length rng-c-current-token)))
 163     (and (> len 0)
 164          (= (aref rng-c-current-token (- len 1)) ?*))))
 165
 166 ;;; Namespaces
 167
 168 (defvar rng-c-inherit-namespace nil)
 169
 170 (defvar rng-c-default-namespace nil)
 171
 172 (defvar rng-c-default-namespace-declared nil)
 173
 174 (defvar rng-c-namespace-decls nil
 175   "Alist of namespace declarations.")
 176
 177 (defconst rng-c-no-namespace nil)
 178
 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)))
 186
 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
 190                                                    0
 191                                                    i))
 192                    (substring prefixed-name (+ i 1)))))
 193
 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))
 197     (cdr binding)))
 198
 199 (defun rng-c-unqualified-namespace (attribute)
 200   (if attribute
 201       rng-c-no-namespace
 202     rng-c-default-namespace))
 203
 204 (defun rng-c-make-context ()
 205   (cons rng-c-default-namespace rng-c-namespace-decls))
 206
 207 ;;; Datatypes
 208
 209 (defconst rng-string-datatype
 210   (rng-make-datatype rng-builtin-datatypes-uri "string"))
 211
 212 (defconst rng-token-datatype
 213   (rng-make-datatype rng-builtin-datatypes-uri "token"))
 214
 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.")
 219
 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)))
 224
 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))
 228     (cdr binding)))
 229
 230 (defun rng-c-expand-datatype (prefixed-name)
 231   (let ((i (string-match ":" prefixed-name)))
 232     (rng-make-datatype
 233      (rng-c-lookup-datatype-prefix (substring prefixed-name 0 i))
 234      (substring prefixed-name (+ i 1)))))
 235
 236 ;;; Grammars
 237
 238 (defvar rng-c-current-grammar nil)
 239 (defvar rng-c-parent-grammar nil)
 240
 241 (defun rng-c-make-grammar ()
 242   (make-hash-table :test 'equal))
 243
 244 (defconst rng-c-about-override-slot 0)
 245 (defconst rng-c-about-combine-slot 1)
 246
 247 (defun rng-c-lookup-create (name grammar)
 248   "Return a def object for NAME.
 249 A def object is a pair \(ABOUT . REF) where REF is returned by
 250 `rng-make-ref'.
 251 ABOUT is a two-element vector [OVERRIDE COMBINE].
 252 COMBINE is either nil, choice or interleave.
 253 OVERRIDE is either nil, require or t."
 254   (let ((def (gethash name grammar)))
 255     (if def
 256         def
 257       (progn
 258         (setq def (cons (vector nil nil) (rng-make-ref name)))
 259         (puthash name def grammar)
 260         def))))
 261
 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)))
 266
 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)))
 271
 272 (defvar rng-c-overrides nil
 273   "Contains a list of (NAME . DEF) pairs.")
 274
 275 (defun rng-c-merge-combine (def combine name)
 276   (let* ((about (car def))
 277          (current-combine (aref about rng-c-about-combine-slot)))
 278     (if combine
 279         (if current-combine
 280             (or (eq combine current-combine)
 281                 (rng-c-error "Inconsistent combine for %s" name))
 282           (aset about rng-c-about-combine-slot combine))
 283       current-combine)))
 284
 285 (defun rng-c-prepare-define (name combine in-include)
 286   (let* ((def (rng-c-lookup-create name rng-c-current-grammar))
 287          (about (car def))
 288          (overridden (aref about rng-c-about-override-slot)))
 289     (and in-include
 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))
 293                       nil)
 294           (t (setq combine (rng-c-merge-combine def combine name))
 295              (and (rng-ref-get (cdr def))
 296                   (not combine)
 297                   (rng-c-error "Duplicate definition of %s" name))
 298              def))))
 299
 300 (defun rng-c-start-include (overrides)
 301   (mapcar (lambda (name-def)
 302             (let* ((def (cdr name-def))
 303                    (about (car def))
 304                    (save (aref about rng-c-about-override-slot)))
 305               (aset about rng-c-about-override-slot 'require)
 306               (cons save name-def)))
 307           overrides))
 308
 309 (defun rng-c-end-include (overrides)
 310   (mapcar (lambda (o)
 311             (let* ((saved (car o))
 312                    (name-def (cdr o))
 313                    (name (car name-def))
 314                    (def (cdr name-def))
 315                    (about (car 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)))
 319           overrides))
 320
 321 (defun rng-c-define (def value)
 322   (and def
 323        (let ((current-value (rng-ref-get (cdr def))))
 324          (rng-ref-set (cdr def)
 325                       (if current-value
 326                           (if (eq (aref (car def) rng-c-about-combine-slot)
 327                                   'choice)
 328                               (rng-make-choice (list current-value value))
 329                             (rng-make-interleave (list current-value value)))
 330                         value)))))
 331
 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")))))
 339
 340 ;;; Parsing
 341
 342 (defvar rng-c-escape-positions nil)
 343 (make-variable-buffer-local 'rng-c-escape-positions)
 344
 345 (defvar rng-c-file-name nil)
 346 (make-variable-buffer-local 'rng-c-file-name)
 347
 348 (defvar rng-c-file-index nil)
 349
 350 (defun rng-c-parse-file (filename &optional context)
 351   (with-current-buffer (get-buffer-create (rng-c-buffer-name context))
 352     (erase-buffer)
 353     (rng-c-init-buffer)
 354     (setq rng-c-file-name
 355           (car (insert-file-contents filename)))
 356     (setq rng-c-escape-positions nil)
 357     (rng-c-process-escapes)
 358     (rng-c-parse-top-level context)))
 359
 360 (defun rng-c-buffer-name (context)
 361   (concat " *RNC Input"
 362           (if context
 363               (concat "<"
 364                       (number-to-string (setq rng-c-file-index
 365                                               (1+ rng-c-file-index)))
 366                       ">*")
 367             (setq rng-c-file-index 1)
 368             "*")))
 369
 370 (defun rng-c-process-escapes ()
 371   ;; Check for any nuls, since we will use nul chars
 372   ;; for internal purposes.
 373   (let ((pos (search-forward "\C-@" nil t)))
 374     (and pos
 375          (rng-c-error "Nul character found (binary file?)")))
 376   (let ((offset 0))
 377     (while (re-search-forward "\\\\x+{\\([0-9a-fA-F]+\\)}"
 378                               (point-max)
 379                               t)
 380       (let* ((ch (decode-char 'ucs (string-to-number (match-string 1) 16))))
 381         (if (and ch (> ch 0))
 382             (let ((begin (match-beginning 0))
 383                   (end (match-end 0)))
 384               (delete-region begin end)
 385               ;; Represent an escaped newline by nul, so
 386               ;; that we can distinguish it from a literal newline.
 387               ;; We will translate it back into a real newline later.
 388               (insert (if (eq ch ?\n) 0 ch))
 389               (setq offset (+ offset (- end begin 1)))
 390               (setq rng-c-escape-positions
 391                     (cons (cons (point) offset)
 392                           rng-c-escape-positions)))
 393           (rng-c-error "Invalid character escape")))))
 394   (goto-char 1))
 395
 396 (defun rng-c-translate-position (pos)
 397   (let ((tem rng-c-escape-positions))
 398     (while (and tem
 399                 (> (caar tem) pos))
 400       (setq tem (cdr tem)))
 401     (if tem
 402         (+ pos (cdar tem))
 403       pos)))
 404
 405 (defun rng-c-error (&rest args)
 406   (rng-c-signal-incorrect-schema rng-c-file-name
 407                                  (rng-c-translate-position (point))
 408                                  (apply 'format args)))
 409
 410 (defun rng-c-parse-top-level (context)
 411   (let ((rng-c-namespace-decls nil)
 412         (rng-c-default-namespace nil)
 413         (rng-c-datatype-decls nil))
 414     (goto-char (point-min))
 415     (forward-comment (point-max))
 416     (rng-c-advance)
 417     (rng-c-parse-decls)
 418     (let ((p (if (eq context 'include)
 419                  (if (rng-c-implicit-grammar-p)
 420                      (rng-c-parse-grammar-body "")
 421                    (rng-c-parse-included-grammar))
 422                (if (rng-c-implicit-grammar-p)
 423                    (rng-c-parse-implicit-grammar)
 424                  (rng-c-parse-pattern)))))
 425       (or (string-equal rng-c-current-token "")
 426           (rng-c-error "Unexpected characters after pattern"))
 427       p)))
 428
 429 (defun rng-c-parse-included-grammar ()
 430   (or (string-equal rng-c-current-token "grammar")
 431       (rng-c-error "Included schema is not a grammar"))
 432   (rng-c-advance)
 433   (rng-c-expect "{")
 434   (rng-c-parse-grammar-body "}"))
 435
 436 (defun rng-c-implicit-grammar-p ()
 437   (or (and (or (rng-c-current-token-prefixed-name-p)
 438                (rng-c-current-token-quoted-identifier-p)
 439                (and (rng-c-current-token-ncname-p)
 440                     (not (rng-c-current-token-keyword-p))))
 441            (looking-at "\\["))
 442       (and (string-equal rng-c-current-token "[")
 443            (rng-c-parse-lead-annotation)
 444            nil)
 445       (member rng-c-current-token '("div" "include" ""))
 446       (looking-at "[|&]?=")))
 447
 448 (defun rng-c-parse-decls ()
 449   (setq rng-c-default-namespace-declared nil)
 450   (while (progn
 451            (let ((binding
 452                   (assoc rng-c-current-token
 453                          '(("namespace" . rng-c-parse-namespace)
 454                            ("datatypes" . rng-c-parse-datatypes)
 455                            ("default" . rng-c-parse-default)))))
 456              (if binding
 457                  (progn
 458                    (rng-c-advance)
 459                    (funcall (cdr binding))
 460                    t)
 461                nil))))
 462   (rng-c-declare-standard-datatypes)
 463   (rng-c-declare-standard-namespaces))
 464
 465 (defun rng-c-parse-datatypes ()
 466   (let ((prefix (rng-c-parse-identifier-or-keyword)))
 467     (or (not (assoc prefix rng-c-datatype-decls))
 468         (rng-c-error "Duplicate datatypes declaration for prefix %s" prefix))
 469     (rng-c-expect "=")
 470     (setq rng-c-datatype-decls
 471           (cons (cons prefix
 472                       (rng-make-datatypes-uri (rng-c-parse-literal)))
 473                 rng-c-datatype-decls))))
 474
 475 (defun rng-c-parse-namespace ()
 476   (rng-c-declare-namespace nil
 477                            (rng-c-parse-identifier-or-keyword)))
 478
 479 (defun rng-c-parse-default ()
 480   (rng-c-expect "namespace")
 481   (rng-c-declare-namespace t
 482                            (if (string-equal rng-c-current-token "=")
 483                                nil
 484                              (rng-c-parse-identifier-or-keyword))))
 485
 486 (defun rng-c-declare-namespace (declare-default prefix)
 487   (rng-c-expect "=")
 488   (let ((ns (cond ((string-equal rng-c-current-token "inherit")
 489                    (rng-c-advance)
 490                    rng-c-inherit-namespace)
 491                   (t
 492                    (nxml-make-namespace (rng-c-parse-literal))))))
 493     (and prefix
 494          (or (not (assoc prefix rng-c-namespace-decls))
 495              (rng-c-error "Duplicate namespace declaration for prefix %s"
 496                           prefix))
 497          (setq rng-c-namespace-decls
 498                (cons (cons prefix ns) rng-c-namespace-decls)))
 499     (and declare-default
 500          (or (not rng-c-default-namespace-declared)
 501              (rng-c-error "Duplicate default namespace declaration"))
 502          (setq rng-c-default-namespace-declared t)
 503          (setq rng-c-default-namespace ns))))
 504
 505 (defun rng-c-parse-implicit-grammar ()
 506   (let* ((rng-c-parent-grammar rng-c-current-grammar)
 507          (rng-c-current-grammar (rng-c-make-grammar)))
 508     (rng-c-parse-grammar-body "")
 509     (rng-c-finish-grammar)))
 510
 511 (defun rng-c-parse-grammar-body (close-token &optional in-include)
 512   (while (not (string-equal rng-c-current-token close-token))
 513     (cond ((rng-c-current-token-keyword-p)
 514            (let ((kw (intern rng-c-current-token)))
 515              (cond ((eq kw 'start)
 516                     (rng-c-parse-define 'start in-include))
 517                    ((eq kw 'div)
 518                     (rng-c-advance)
 519                     (rng-c-parse-div in-include))
 520                    ((eq kw 'include)
 521                     (and in-include
 522                          (rng-c-error "Nested include"))
 523                     (rng-c-advance)
 524                     (rng-c-parse-include))
 525                    (t (rng-c-error "Invalid grammar keyword")))))
 526           ((rng-c-current-token-ncname-p)
 527            (if (looking-at "\\[")
 528                (rng-c-parse-annotation-element)
 529              (rng-c-parse-define rng-c-current-token
 530                                  in-include)))
 531           ((rng-c-current-token-quoted-identifier-p)
 532            (if (looking-at "\\[")
 533                (rng-c-parse-annotation-element)
 534              (rng-c-parse-define (substring rng-c-current-token 1)
 535                                  in-include)))
 536           ((rng-c-current-token-prefixed-name-p)
 537            (rng-c-parse-annotation-element))
 538           ((string-equal rng-c-current-token "[")
 539            (rng-c-parse-lead-annotation)
 540            (and (string-equal rng-c-current-token close-token)
 541                 (rng-c-error "Missing annotation subject"))
 542            (and (looking-at "\\[")
 543                 (rng-c-error "Leading annotation applied to annotation")))
 544           (t (rng-c-error "Invalid grammar content"))))
 545   (or (string-equal rng-c-current-token "")
 546       (rng-c-advance)))
 547
 548 (defun rng-c-parse-div (in-include)
 549   (rng-c-expect "{")
 550   (rng-c-parse-grammar-body "}" in-include))
 551
 552 (defun rng-c-parse-include ()
 553   (let* ((filename (rng-c-expand-file (rng-c-parse-literal)))
 554          (rng-c-inherit-namespace (rng-c-parse-opt-inherit))
 555          overrides)
 556     (cond ((string-equal rng-c-current-token "{")
 557            (rng-c-advance)
 558            (let ((rng-c-overrides nil))
 559              (rng-c-parse-grammar-body "}" t)
 560              (setq overrides rng-c-overrides))
 561            (setq overrides (rng-c-start-include overrides))
 562            (rng-c-parse-file filename 'include)
 563            (rng-c-end-include overrides))
 564           (t (rng-c-parse-file filename 'include)))))
 565
 566 (defun rng-c-parse-define (name in-include)
 567   (rng-c-advance)
 568   (let ((assign (assoc rng-c-current-token
 569                        '(("=" . nil)
 570                          ("|=" . choice)
 571                          ("&=" . interleave)))))
 572     (or assign
 573         (rng-c-error "Expected assignment operator"))
 574     (rng-c-advance)
 575     (let ((ref (rng-c-prepare-define name (cdr assign) in-include)))
 576       (rng-c-define ref (rng-c-parse-pattern)))))
 577
 578 (defvar rng-c-had-except nil)
 579
 580 (defun rng-c-parse-pattern ()
 581   (let* ((rng-c-had-except nil)
 582          (p (rng-c-parse-repeated))
 583          (op (assoc rng-c-current-token
 584                     '(("|" . rng-make-choice)
 585                       ("," . rng-make-group)
 586                       ("&" . rng-make-interleave)))))
 587     (if op
 588         (if rng-c-had-except
 589             (rng-c-error "Parentheses required around pattern using -")
 590           (let* ((patterns (cons p nil))
 591                  (tail patterns)
 592                  (connector rng-c-current-token))
 593             (while (progn
 594                      (rng-c-advance)
 595                      (let ((newcdr (cons (rng-c-parse-repeated) nil)))
 596                        (setcdr tail newcdr)
 597                        (setq tail newcdr))
 598                      (string-equal rng-c-current-token connector)))
 599             (funcall (cdr op) patterns)))
 600       p)))
 601
 602 (defun rng-c-parse-repeated ()
 603   (let ((p (rng-c-parse-follow-annotations
 604             (rng-c-parse-primary)))
 605         (op (assoc rng-c-current-token
 606                    '(("*" . rng-make-zero-or-more)
 607                      ("+" . rng-make-one-or-more)
 608                      ("?" . rng-make-optional)))))
 609     (if op
 610         (if rng-c-had-except
 611             (rng-c-error "Parentheses required around pattern using -")
 612           (rng-c-parse-follow-annotations
 613            (progn
 614              (rng-c-advance)
 615              (funcall (cdr op) p))))
 616       p)))
 617
 618 (defun rng-c-parse-primary ()
 619   "Parse a primary expression.
 620 The current token must be the first token of the expression.
 621 After parsing the current token should be the token following
 622 the primary expression."
 623   (cond ((rng-c-current-token-keyword-p)
 624          (let ((parse-function (get (intern rng-c-current-token)
 625                                     'rng-c-pattern)))
 626            (or parse-function
 627                (rng-c-error "Keyword %s does not introduce a pattern"
 628                             rng-c-current-token))
 629            (rng-c-advance)
 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 "(")
 634          (rng-c-advance)
 635          (let ((p (rng-c-parse-pattern)))
 636            (rng-c-expect ")")
 637            p))
 638         ((rng-c-current-token-prefixed-name-p)
 639          (let ((name (rng-c-expand-datatype rng-c-current-token)))
 640            (rng-c-advance)
 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)
 645          (rng-c-advance-with
 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"))))
 651
 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)))
 657
 658 (defun rng-c-parse-literal ()
 659   (rng-c-fix-escaped-newlines
 660    (apply 'concat (rng-c-parse-literal-segments))))
 661
 662 (defun rng-c-parse-literal-segments ()
 663   (let ((str (rng-c-parse-literal-segment)))
 664     (cons str
 665           (cond ((string-equal rng-c-current-token "~")
 666                  (rng-c-advance)
 667                  (rng-c-parse-literal-segments))
 668                 (t nil)))))
 669
 670 (defun rng-c-parse-literal-segment ()
 671   (or (rng-c-current-token-literal-p)
 672       (rng-c-error "Expected a literal"))
 673   (rng-c-advance-with
 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)))
 677                 3
 678               1)))
 679      (substring rng-c-current-token n (- n)))))
 680
 681 (defun rng-c-fix-escaped-newlines (str)
 682   (let ((pos 0))
 683     (while (progn
 684              (let ((n (string-match "\C-@" str pos)))
 685                (and n
 686                     (aset str n ?\n)
 687                     (setq pos (1+ n)))))))
 688   str)
 689
 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"))))
 696
 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)
 709
 710 (defun rng-c-parse-element ()
 711   (let ((name-class (rng-c-parse-name-class nil)))
 712     (rng-c-expect "{")
 713     (let ((pattern (rng-c-parse-pattern)))
 714       (rng-c-expect "}")
 715       (rng-make-element name-class pattern))))
 716
 717 (defun rng-c-parse-attribute ()
 718   (let ((name-class (rng-c-parse-name-class 'attribute)))
 719     (rng-c-expect "{")
 720     (let ((pattern (rng-c-parse-pattern)))
 721       (rng-c-expect "}")
 722       (rng-make-attribute name-class pattern))))
 723
 724 (defun rng-c-parse-name-class (attribute)
 725   (let* ((rng-c-had-except nil)
 726          (name-class
 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))
 731                (tail name-classes))
 732           (or (not rng-c-had-except)
 733               (rng-c-error "Parentheses required around name-class using - operator"))
 734           (while (progn
 735                    (rng-c-advance)
 736                    (let ((newcdr
 737                           (cons (rng-c-parse-follow-annotations
 738                                  (rng-c-parse-primary-name-class attribute))
 739                                 nil)))
 740                      (setcdr tail newcdr)
 741                      (setq tail newcdr))
 742                    (string-equal rng-c-current-token "|")))
 743           (rng-make-choice-name-class name-classes))
 744       name-class)))
 745
 746 (defun rng-c-parse-primary-name-class (attribute)
 747   (cond ((rng-c-current-token-ncname-p)
 748          (rng-c-advance-with
 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)
 753          (rng-c-advance-with
 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)))
 758            (if except
 759                (rng-make-any-name-except-name-class except)
 760              (rng-make-any-name-name-class))))
 761         ((rng-c-current-token-ns-name-p)
 762          (let* ((ns
 763                  (rng-c-lookup-prefix (substring rng-c-current-token
 764                                                  0
 765                                                  -2)))
 766                 (except (rng-c-parse-opt-except-name-class attribute)))
 767            (if except
 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 "(")
 771          (rng-c-advance)
 772          (let ((name-class (rng-c-parse-name-class attribute)))
 773            (rng-c-expect ")")
 774            name-class))
 775         ((rng-c-current-token-quoted-identifier-p)
 776          (rng-c-advance-with
 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"))))
 784
 785 (defun rng-c-parse-opt-except-name-class (attribute)
 786   (rng-c-advance)
 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)
 791        (progn
 792          (rng-c-advance)
 793          (rng-c-parse-primary-name-class attribute))))
 794
 795 (defun rng-c-parse-mixed ()
 796   (rng-c-expect "{")
 797   (let ((pattern (rng-make-mixed (rng-c-parse-pattern))))
 798     (rng-c-expect "}")
 799     pattern))
 800
 801 (defun rng-c-parse-list ()
 802   (rng-c-expect "{")
 803   (let ((pattern (rng-make-list (rng-c-parse-pattern))))
 804     (rng-c-expect "}")
 805     pattern))
 806
 807 (defun rng-c-parse-text ()
 808   (rng-make-text))
 809
 810 (defun rng-c-parse-empty ()
 811   (rng-make-empty))
 812
 813 (defun rng-c-parse-not-allowed ()
 814   (rng-make-not-allowed))
 815
 816 (defun rng-c-parse-string ()
 817   (rng-c-parse-data rng-string-datatype))
 818
 819 (defun rng-c-parse-token ()
 820   (rng-c-parse-data rng-token-datatype))
 821
 822 (defun rng-c-parse-data (name)
 823   (if (rng-c-current-token-literal-p)
 824       (rng-make-value name
 825                       (rng-c-parse-literal)
 826                       (and (car name)
 827                            (rng-c-make-context)))
 828     (let ((params (rng-c-parse-optional-params)))
 829       (if (string-equal rng-c-current-token "-")
 830           (progn
 831             (if rng-c-had-except
 832                 (rng-c-error "Parentheses required around pattern using -")
 833               (setq rng-c-had-except t))
 834             (rng-c-advance)
 835             (rng-make-data-except name
 836                                   params
 837                                   (rng-c-parse-primary)))
 838         (rng-make-data name params)))))
 839
 840 (defun rng-c-parse-optional-params ()
 841   (and (string-equal rng-c-current-token "{")
 842        (let* ((head (cons nil nil))
 843               (tail head))
 844          (rng-c-advance)
 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)))
 849              (rng-c-expect "=")
 850              (let ((newcdr (cons (cons (intern name)
 851                                        (rng-c-parse-literal))
 852                                  nil)))
 853                (setcdr tail newcdr)
 854                (setq tail newcdr))))
 855          (rng-c-advance)
 856          (cdr head))))
 857
 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)))
 862
 863 (defun rng-c-expand-file (uri)
 864   (condition-case err
 865       (rng-uri-file-name (rng-uri-resolve uri
 866                                           (rng-file-name-uri rng-c-file-name)))
 867     (rng-uri-error
 868      (rng-c-error (cadr err)))))
 869
 870 (defun rng-c-parse-opt-inherit ()
 871   (cond ((string-equal rng-c-current-token "inherit")
 872          (rng-c-advance)
 873          (rng-c-expect "=")
 874          (rng-c-lookup-prefix (rng-c-parse-identifier-or-keyword)))
 875         (t rng-c-default-namespace)))
 876
 877 (defun rng-c-parse-grammar ()
 878   (rng-c-expect "{")
 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)))
 883
 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")))
 888
 889 (defun rng-c-parse-follow-annotations (obj)
 890   (while (string-equal rng-c-current-token ">>")
 891     (rng-c-advance)
 892     (if (rng-c-current-token-prefixed-name-p)
 893         (rng-c-advance)
 894       (rng-c-parse-identifier-or-keyword))
 895     (rng-c-parse-annotation-body t))
 896   obj)
 897
 898 (defun rng-c-parse-annotation-element ()
 899   (rng-c-advance)
 900   (rng-c-parse-annotation-body t))
 901
 902 ;; XXX need stricter checking of attribute names
 903 ;; XXX don't allow attributes after text
 904
 905 (defun rng-c-parse-annotation-body (&optional allow-text)
 906   "Current token is [.  Parse up to matching ].
 907 Current token after parse is token following ]."
 908   (or (string-equal rng-c-current-token "[")
 909       (rng-c-error "Expected ["))
 910   (rng-c-advance)
 911   (while (not (string-equal rng-c-current-token "]"))
 912     (cond ((rng-c-current-token-literal-p)
 913            (or allow-text
 914                (rng-c-error "Out of place text within annotation"))
 915            (rng-c-parse-literal))
 916           (t
 917            (if (rng-c-current-token-prefixed-name-p)
 918                (rng-c-advance)
 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 "=")
 923                   (rng-c-advance)
 924                   (rng-c-parse-literal))
 925                  (t (rng-c-error "Expected = or ["))))))
 926   (rng-c-advance))
 927
 928 (defun rng-c-advance-with (pattern)
 929   (rng-c-advance)
 930   pattern)
 931
 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))
 935   (rng-c-advance))
 936
 937 (provide 'rng-cmpct)
 938
 939 ;;; rng-cmpct.el
 940
 941 ;; arch-tag: 90395eb1-283b-4146-bbc1-6d6ef1704e57