compact.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2 ;;;
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29
  30 (in-package :cxml-rng)
  31
  32 #+sbcl
  33 (declaim (optimize (debug 2)))
  34
  35 (defparameter *keywords*
  36   '("attribute" "default" "datatypes" "div" "element" "empty" "external"
  37     "grammar" "include" "inherit" "list" "mixed" "namespace" "notAllowed"
  38     "parent" "start" "string" "text" "token"))
  39
  40 (defmacro double (x)
  41   `((lambda (x) (return (values x x))) ,x))
  42
  43
  44 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45 ;;;; Escape interpretation
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47
  48 (defclass hex-stream (trivial-gray-streams:fundamental-character-input-stream)
  49     ((source :initarg :source :accessor stream-source)
  50      (buffer :initform (make-array 1 :adjustable t :fill-pointer 0)
  51              :accessor stream-buffer)
  52      (pos :initform 0 :accessor stream-pos)))
  53
  54 (defmethod trivial-gray-streams:stream-file-position ((s hex-stream))
  55   (file-position (stream-source s)))
  56
  57 ;; zzz geht das nicht besser?
  58 (defmethod trivial-gray-streams:stream-read-char ((s hex-stream))
  59   (with-slots (source buffer pos) s
  60     (cond
  61       ((< pos (length buffer))
  62        (prog1
  63          (elt buffer pos)
  64          (incf pos)))
  65       (t
  66        (setf (fill-pointer buffer) 0)
  67        (setf pos 0)
  68        (flet ((slurp ()
  69                 (let ((c (read-char source nil)))
  70                   (vector-push-extend c buffer)
  71                   c)))
  72          (macrolet ((with-expectation (frob &body body)
  73                       (when (characterp frob)
  74                         (setf frob `(eql (slurp) ,frob)))
  75                       `(let ((result ,frob))
  76                          (cond
  77                            (result
  78                             ,@(or body (list 'result)))
  79                            (t
  80                             (prog1
  81                                 (elt buffer 0)
  82                               (incf pos)))))))
  83            (with-expectation
  84                #\\
  85              (with-expectation
  86                  #\x
  87                (with-expectation
  88                    (loop
  89                       for d = (peek-char nil source)
  90                       while (eql d #\x)
  91                       do (slurp)
  92                       finally
  93                         (return (eql (slurp) #\{)))
  94                  (with-expectation
  95                      (loop
  96                         for result = 0 then (+ (* result 16) i)
  97                         for d = (peek-char nil source nil)
  98                         for i = (digit-char-p d 16)
  99                         while i
 100                         do
 101                           (slurp)
 102                         finally
 103                           (return
 104                             (when (eql (slurp) #\})
 105                               (setf (fill-pointer buffer) 0)
 106                               (setf pos 0)
 107                               (code-char result))))))))))))))
 108
 109
 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 ;;;; Tokenization
 112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 113
 114 (clex:deflexer rng
 115     (
 116      ;; NCName
 117      (letter+extras
 118       (or (range #x0041 #x005A) (range #x0061 #x007A)
 119           ;; just allow the rest of unicode, because clex can't deal with the
 120           ;; complete definition of name-char:
 121           (range #x00c0 #xd7ff)
 122           (range #xe000 #xfffd)
 123           (range #x10000 #x10ffff)))
 124      (digit (range #x0030 #x0039))      ;ditto
 125      (name-start-char (or letter+extras #\_))
 126      (name-char (or letter+extras digit #\. #\- #\_ #\:))
 127
 128      ;; some RNC ranges
 129      (char
 130       (or 9 10 13
 131           (range 32 #xd7ff)
 132           (range #xe000 #xfffd)
 133           (range #x10000 #x10ffff)))
 134      (init-comment-char
 135       (or 9 32 33 34
 136           ;; #\#
 137           (range 36 #xd7ff)
 138           (range #xe000 #xfffd)
 139           (range #x10000 #x10ffff)))
 140      (comment-char
 141       (or 35 init-comment-char))
 142      (string-char
 143       (or 32 33
 144           ;; #\"
 145           (range 35 38)
 146           ;; #\'
 147           (range 40  #xd7ff)
 148           (range #xe000 #xfffd)
 149           (range #x10000 #x10ffff)))
 150      (space (or 9 10 13 32))
 151      (newline (or 10 13)))
 152
 153   ((* space))
 154
 155   ((and "##") (clex:begin 'documentation-line))
 156   ((and "##" newline))
 157   ((clex::in documentation-line newline) (clex:begin 'clex:initial))
 158   ((clex::in documentation-line comment-char)
 159    (return (values 'documentation-line clex:bag)))
 160
 161   ((and #\# init-comment-char) (clex:begin 'comment))
 162   ((and #\# newline))
 163   ((clex::in comment newline) (clex:begin 'clex:initial))
 164   ((clex::in comment comment-char))
 165
 166   ((and "'''" (* (or string-char #\' #\")) "'''")
 167    (return
 168      (values 'literal-segment (subseq clex:bag 3 (- (length clex:bag) 3)))))
 169
 170   ((and #\' (* (or string-char #\")) #\')
 171    (when (or (find (code-char 13) clex:bag)
 172              (find (code-char 10) clex:bag))
 173      (rng-error nil "disallowed newline in string literal"))
 174    (return
 175      (values 'literal-segment (subseq clex:bag 1 (- (length clex:bag) 1)))))
 176
 177   ((and #\" #\" #\" (* (or string-char #\' #\")) #\" #\" #\")
 178    (return
 179      (values 'literal-segment (subseq clex:bag 3 (- (length clex:bag) 3)))))
 180
 181   ((and #\" (* (or string-char #\')) #\")
 182    (when (or (find (code-char 13) clex:bag)
 183              (find (code-char 10) clex:bag))
 184      (rng-error nil "disallowed newline in string literal"))
 185    (return
 186      (values 'literal-segment (subseq clex:bag 1 (- (length clex:bag) 1)))))
 187
 188   ((and name-start-char (* name-char))
 189    (return
 190      (cond
 191        ((find clex:bag *keywords* :test #'equal)
 192         (let ((sym (intern (string-upcase clex:bag) :keyword)))
 193           (values sym sym)))
 194        ((find #\: clex:bag)
 195         (let* ((pos (position #\: clex:bag))
 196                (prefix (subseq clex:bag 0 pos))
 197                (lname (subseq clex:bag (1+ pos ))))
 198           (when (find #\: lname)
 199             (rng-error "too many colons"))
 200           (unless (and (cxml-types::nc-name-p prefix))
 201             (rng-error nil "not an ncname: ~A" prefix))
 202           (let ((ch (clex::getch)))
 203             (cond
 204               ((and (equal lname "") (eql ch #\*))
 205                (values 'nsname prefix))
 206               (t
 207                (clex::backup ch)
 208                (unless (and (cxml-types::nc-name-p lname))
 209                  (rng-error nil "not an ncname: ~A" lname))
 210                (values 'cname (cons prefix lname)))))))
 211        (t
 212         (unless (cxml-types::nc-name-p clex:bag)
 213           (rng-error nil "not an ncname: ~A" clex:bag))
 214         (values 'identifier clex:bag)))))
 215
 216   ((and #\\ name-start-char (* name-char))
 217    (let ((str (subseq clex:bag 1)))
 218      (unless (cxml-types::nc-name-p str)
 219        (rng-error nil "not an ncname: ~A" clex:bag))
 220      (return (values 'identifier str))))
 221
 222   (#\= (double '=))
 223   (#\{ (double '{))
 224   (#\} (double '}))
 225   (#\[ (double '[))
 226   (#\] (double ']))
 227   (#\, (double '|,|))
 228   (#\& (double '&))
 229   (#\| (double '|\||))
 230   (#\? (double '?))
 231   (#\* (double '*))
 232   (#\+ (double '+))
 233   (#\( (double '|(|))
 234   (#\) (double '|)|))
 235   ((and "|=") (double '|\|=|))
 236   ((and "&=") (double '&=))
 237   ((and ">>") (double '>>))
 238   (#\~ (double '~))
 239   (#\- (double '-)))
 240
 241
 242 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 243 ;;;; Parsing into S-Expressions
 244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 245
 246 (eval-when (:compile-toplevel :load-toplevel :execute)
 247   #+(or)
 248   (defmacro lambda* ((&rest args) &body body)
 249     (setf args (mapcar (lambda (arg) (or arg (gensym))) args))
 250     `(lambda (,@args)
 251        (declare (ignorable ,@args))
 252        ,@body))
 253
 254   (defmacro lambda* ((&rest args) &body body)
 255     (setf args (mapcar (lambda (arg) (or arg (gensym))) args))
 256     `(lambda (&rest .args.)
 257        (unless (equal (length .args.) ,(length args))
 258          (error "expected ~A, got ~A" ',args .args.))
 259        (destructuring-bind (,@args) .args.
 260          (declare (ignorable ,@args))
 261          ,@body)))
 262
 263   (defun wrap-decls (decls content)
 264     (if decls
 265         `(,@(car decls)
 266             ,(wrap-decls (cadr decls) content))
 267         content)))
 268
 269 (yacc:define-parser *compact-parser*
 270   (:start-symbol top-level)
 271   (:terminals (:attribute :default :datatypes :div :element :empty
 272                           :external :grammar :include :inherit :list
 273                           :mixed :namespace :notAllowed :parent :start
 274                           :string :text :token
 275                           = { } |,| & |\|| ? * + |(| |)| |\|=| &= ~ -
 276                           [ ] >>
 277                           identifier literal-segment cname nsname
 278                           documentation-line))
 279   #+debug (:print-first-terminals t)
 280   #+debug (:print-states t)
 281   #+debug (:print-lookaheads t)
 282   #+debug (:print-goto-graph t)
 283   (:muffle-conflicts (50 0))            ;hrmpf
 284
 285   (top-level (decl* pattern #'wrap-decls)
 286              (decl* grammar-content*
 287                     (lambda (a b) (wrap-decls a `(with-grammar () ,@b)))))
 288
 289   (decl* () (decl decl*))
 290
 291   (decl (:namespace identifier-or-keyword = namespace-uri-literal
 292                     (lambda* (nil name nil uri)
 293                       `(with-namespace (:uri ,uri :name ,name))))
 294         (:default :namespace = namespace-uri-literal
 295                   (lambda* (nil nil nil uri)
 296                     `(with-namespace (:uri ,uri :default t))))
 297         (:default :namespace identifier-or-keyword = namespace-uri-literal
 298                   (lambda* (nil nil name nil uri)
 299                     `(with-namespace (:uri ,uri :name ,name :default t))))
 300         (:datatypes identifier-or-keyword = literal
 301                     (lambda* (nil name nil uri)
 302                       `(with-data-type (:name ,name :uri ,uri)))))
 303
 304   (pattern (inner-pattern
 305             (lambda* (p) `(without-annotations ,p))))
 306
 307   (particle (inner-particle
 308              (lambda* (p) `(without-annotations ,p))))
 309
 310   (inner-pattern inner-particle
 311                  (particle-choice (lambda* (p) `(%with-annotations ,p)))
 312                  (particle-group (lambda* (p) `(%with-annotations ,p)))
 313                  (particle-interleave (lambda* (p) `(%with-annotations ,p)))
 314                  (data-except (lambda* (p) `(%with-annotations-group ,p))))
 315
 316   (primary (:element name-class { pattern }
 317                      (lambda* (nil name nil pattern nil)
 318                        `(with-element (:name ,name) ,pattern)))
 319            (:attribute name-class { pattern }
 320                        (lambda* (nil name nil pattern nil)
 321                          `(with-attribute (:name ,name) ,pattern)))
 322            (:list { pattern }
 323                   (lambda* (nil nil pattern nil)
 324                     `(list ,pattern)))
 325            (:mixed { pattern }
 326                    (lambda* (nil nil pattern nil)
 327                      `(mixed ,pattern)))
 328            (identifier (lambda* (x)
 329                          `(ref ,x)))
 330            (:parent identifier
 331                     (lambda* (nil x)
 332                       `(parent-ref ,x)))
 333            (:empty)
 334            (:text)
 335            (data-type-name [params]
 336                            (lambda* (name params)
 337                              `(data :data-type ,name :params ,params)))
 338            (data-type-name data-type-value
 339                            (lambda* (name value)
 340                              `(value :data-type ,name :value ,value)))
 341            (data-type-value (lambda* (value)
 342                               `(value :data-type nil :value ,value)))
 343            (:notallowed)
 344            (:external any-uri-literal [inherit]
 345                       (lambda* (nil uri inherit)
 346                         `(external-ref :uri ,uri :inherit ,inherit)))
 347            (:grammar { grammar-content* }
 348                      (lambda* (nil nil content nil)
 349                        `(with-grammar () ,@content)))
 350            (\( pattern \) (lambda* (nil p nil) p)))
 351
 352   (data-except (data-type-name [params] - lead-annotated-primary
 353                                (lambda* (name params nil p)
 354                                  `(data :data-type ,name
 355                                         :params ,params
 356                                         :except ,p))))
 357
 358   (inner-particle (annotated-primary
 359                    (lambda* (p) `(%with-annotations-group ,p)))
 360                   (repeated-primary follow-annotations
 361                                     (lambda* (a b)
 362                                       `(progn
 363                                          (%with-annotations ,a)
 364                                          ,b))))
 365
 366   (repeated-primary (annotated-primary *
 367                                        (lambda* (p nil) `(zero-or-more ,p)))
 368                     (annotated-primary +
 369                                        (lambda* (p nil) `(one-or-more ,p)))
 370                     (annotated-primary ?
 371                                        (lambda* (p nil) `(optional ,p))))
 372
 373   (annotated-primary (lead-annotated-primary follow-annotations
 374                                              (lambda* (a b)
 375                                                `(progn ,a ,b))))
 376
 377   (annotated-data-except (lead-annotated-data-except follow-annotations
 378                                                      (lambda* (a b)
 379                                                        `(progn ,a ,b))))
 380
 381   (lead-annotated-data-except data-except
 382                               (annotations data-except
 383                                            (lambda* (a p)
 384                                              `(with-annotations ,a ,p))))
 385
 386   (lead-annotated-primary primary
 387                           (annotations primary
 388                                        (lambda* (a p)
 389                                          `(with-annotations ,a ,p)))
 390                           (\( inner-pattern \)
 391                               (lambda* (nil p nil) p))
 392                           (annotations \( inner-pattern \)
 393                                        (lambda* (a nil p nil)
 394                                          `(let-annotations ,a ,p))))
 395
 396   (particle-choice (particle \| particle
 397                              (lambda* (a nil b) `(choice ,a ,b)))
 398                    (particle \| particle-choice
 399                              (lambda* (a nil b) `(choice ,a ,@(cdr b)))))
 400
 401   (particle-group (particle \, particle
 402                             (lambda* (a nil b) `(group ,a ,b)))
 403                   (particle \, particle-group
 404                             (lambda* (a nil b) `(group ,a ,@(cdr b)))))
 405
 406   (particle-interleave (particle \& particle
 407                                  (lambda* (a nil b) `(interleave ,a ,b)))
 408                        (particle \& particle-interleave
 409                                  (lambda* (a nil b) `(interleave ,a ,@(cdr b)))))
 410
 411   (param (identifier-or-keyword = literal
 412                                 (lambda* (name nil value)
 413                                   `(param ,name ,value)))
 414          (annotations identifier-or-keyword = literal
 415                       (lambda* (a name nil value)
 416                         `(with-annotations ,a (param ,name ,value)))))
 417
 418   (grammar-content* ()
 419                     (member grammar-content* #'cons))
 420
 421   (member annotated-component
 422           annotated-element-not-keyword)
 423
 424   (annotated-component component
 425                        (annotations component
 426                                     (lambda* (a c)
 427                                       `(with-annotations ,a ,c))))
 428
 429   (component start
 430              define
 431              (:div { grammar-content* }
 432                    (lambda* (nil nil content nil)
 433                      `(with-div ,@content)))
 434              (:include any-uri-literal [inherit] [include-content]
 435                        (lambda* (nil uri inherit content)
 436                          `(with-include (:inherit ,inherit :uri ,uri)
 437                             ,@content))))
 438
 439   (include-content* ()
 440                     (include-member include-content* #'cons))
 441
 442   (include-member annotated-include-component
 443                   annotation-element-not-keyword)
 444
 445   (annotated-include-component include-component
 446                                (annotations include-component
 447                                             (lambda* (a c)
 448                                               `(with-annotations (,@a) ,c))))
 449
 450   (include-component start
 451                      define
 452                      (:div { grammar-content* }
 453                            (lambda* (nil nil content nil)
 454                              `(with-div ,@content))))
 455
 456   (start (:start assign-method pattern
 457                  (lambda* (nil method pattern)
 458                    `(with-start (:combine-method ,method) ,pattern))))
 459
 460   (define (identifier assign-method pattern
 461                       (lambda* (name method pattern)
 462                         `(with-definition (:name ,name :combine-method ,method)
 463                            ,pattern))))
 464
 465   (assign-method (= (constantly nil))
 466                  (\|= (constantly "choice"))
 467                  (&= (constantly "interleave")))
 468
 469   (name-class (inner-name-class (lambda (nc) `(without-annotations ,nc))))
 470
 471   (inner-name-class (annotated-simple-nc
 472                      (lambda (nc) `(%with-annotations-choice ,nc)))
 473                     (nc-choice
 474                      (lambda (nc) `(%with-annotations ,nc)))
 475                     (annotated-nc-except
 476                      (lambda (nc) `(%with-annotations-choice ,nc))))
 477
 478   (simple-nc (name (lambda* (n) `(name ,n)))
 479              (ns-name (lambda* (n) `(ns-name ,n)))
 480              (* (constantly `(any-name)))
 481              (\( name-class \) (lambda* (nil nc nil) nc)))
 482
 483   (follow-annotations ()
 484                       (>> annotation-element follow-annotations))
 485
 486   (annotations #+nil ()
 487                (documentations
 488                 (lambda (e)
 489                   `(annotation :elements ,e)))
 490                ([ annotation-attributes annotation-elements ]
 491                   (lambda* (nil a e nil)
 492                     `(annotation :attributes ,a :elements ,e)))
 493                (documentations [ annotation-attributes annotation-elements ]
 494                                (lambda* (d nil a e nil)
 495                                  `(annotation :attributes ,a
 496                                               :elements ,(append e d)))))
 497
 498   (annotation-attributes
 499    ((constantly '(annotation-attributes)))
 500    (foreign-attribute-name = literal annotation-attributes
 501                            (lambda* (name nil value rest)
 502                              `(annotation-attributes
 503                                (annotation-attribute ,name ,value)
 504                                ,@(cdr rest)))))
 505
 506   (foreign-attribute-name prefixed-name)
 507
 508   (annotation-elements ()
 509                        (annotation-element annotation-elements #'cons))
 510
 511   (annotation-element (foreign-element-name annotation-attributes-content
 512                                             (lambda (a b)
 513                                               `(with-annotation-element
 514                                                    (:name ,a)
 515                                                  ,b))))
 516
 517   (foreign-element-name identifier-or-keyword
 518                         prefixed-name)
 519
 520   (annotation-element-not-keyword (foreign-element-name-not-keyword
 521                                    annotation-attributes-content
 522                                    (lambda (a b)
 523                                      `(with-annotation-element
 524                                           (:name ,a)
 525                                         ,b))))
 526
 527   (foreign-element-name-not-keyword identifier prefixed-name)
 528
 529   (annotation-attributes-content ([ nested-annotation-attributes
 530                                      annotation-content ]))
 531
 532   (nested-annotation-attributes
 533    ((constantly '(annotation-attributes)))
 534    (any-attribute-name = literal
 535                        nested-annotation-attributes
 536                        (lambda* (name nil value rest)
 537                          `(annotation-attributes
 538                            (annotation-attribute ,name ,value)
 539                            ,@(cdr rest)))))
 540
 541   (any-attribute-name identifier-or-keyword prefixed-name)
 542
 543   (annotation-content ()
 544                       (nested-annotation-element annotation-content #'cons)
 545                       (literal annotation-content #'cons))
 546
 547   (nested-annotation-element (any-element-name annotation-attributes-content
 548                                                (lambda (a b)
 549                                                  `(with-annotation-element
 550                                                       (:name ,a)
 551                                                     ,b))))
 552
 553   (any-element-name identifier-or-keyword prefixed-name)
 554
 555   (prefixed-name cname)
 556
 557   (documentations (documentation)
 558                   (documentation documentations #'cons))
 559
 560   (documentation documentation-line
 561                  (documentation-line documentation
 562                                      (lambda (a b)
 563                                        (concatenate 'string a b))))
 564
 565   (annotated-nc-except (lead-annotated-nc-except
 566                         follow-annotations
 567                         (lambda (p a)
 568                           `(progn ,p ,a))))
 569
 570   (lead-annotated-nc-except nc-except
 571                             (annotations nc-except
 572                                          (lambda (a p)
 573                                            `(with-annotations ,a ,p))))
 574
 575   (annotated-simple-nc (lead-annotated-simple-nc
 576                         follow-annotations
 577                         (lambda (p a) `(progn ,p ,a))))
 578
 579   (lead-annotated-simple-nc
 580    simple-nc
 581    (\( inner-name-class \) (lambda* (nil nc nil) nc))
 582    (annotations simple-nc
 583                 (lambda (a nc) `(with-annotations ,a ,nc)))
 584    (annotations \( inner-name-class \)
 585                 (lambda (a nc) `(let-annotations ,a ,nc))))
 586
 587   (nc-except (ns-name - simple-nc
 588                       (lambda* (nc1 nil nc2) `(ns-name ,nc1 :except ,nc2)))
 589              (* - simple-nc
 590                 (lambda* (nil nil nc) `(any-name :except ,nc))))
 591
 592   (nc-choice (annotated-simple-nc \| annotated-simple-nc
 593                                   (lambda* (a nil b)
 594                                     `(name-choice ,a ,b)))
 595              (annotated-simple-nc \| nc-choice
 596                                   (lambda* (a nil b)
 597                                     `(name-choice ,a ,@(cdr b)))))
 598
 599   (name identifier-or-keyword cname)
 600
 601   (data-type-name cname :string :token)
 602
 603   (data-type-value literal)
 604   (any-uri-literal literal)
 605
 606   (namespace-uri-literal literal :inherit)
 607
 608   (inherit (:inherit = identifier-or-keyword
 609                      (lambda* (nil nil x) x)))
 610
 611   (identifier-or-keyword identifier keyword)
 612
 613   ;; identifier ::= (ncname - keyword) | quotedidentifier
 614   ;; quotedidentifier ::= "\" ncname
 615
 616   ;; (ns-name (ncname \:*))
 617   (ns-name nsname)
 618
 619   (ncname identifier-or-keyword)
 620
 621   (literal literal-segment
 622            (literal-segment ~ literal
 623                             (lambda* (a nil b)
 624                               (concatenate 'string a b))))
 625
 626   ;; literalsegment ::= ...
 627
 628   (keyword :attribute :default :datatypes :div :element :empty :external
 629            :grammar :include :inherit :list :mixed :namespace :notAllowed
 630            :parent :start :string :text :token)
 631
 632   ;; optional stuff
 633   ([data-type-name] () data-type-name)
 634   ([inherit] () inherit)
 635   ([params] () ({ params } (lambda* (nil p nil) p)))
 636   (params () (param params #'cons))
 637   ([include-content] () ({ include-content* }
 638                            (lambda* (nil content nil) content))))
 639
 640
 641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 642 ;;;; Conversion of sexps into SAX
 643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 644
 645 (defun uncompact (list)
 646   (funcall (or (get (car list) 'uncompactor)
 647                (error "no uncompactor for ~A" (car list)))
 648            (cdr list)))
 649
 650 (defmacro define-uncompactor (name (&rest args) &body body)
 651   `(setf (get ',name 'uncompactor)
 652          (lambda (.form.) (destructuring-bind ,args .form. ,@body))))
 653
 654 (defparameter *namespaces* '(("xml" . "http://www.w3.org/XML/1998/namespace")))
 655 (defparameter *default-namespace* nil)
 656 (defparameter *data-types*
 657   '(("xsd" . "http://www.w3.org/2001/XMLSchema-datatypes")))
 658
 659 (defun xor (a b)
 660   (if a (not b) b))
 661
 662 (defun lookup-prefix (prefix)
 663   (cdr (assoc prefix *namespaces* :test 'equal)))
 664
 665 (defun lookup-default ()
 666   (or *default-namespace* :inherit))
 667
 668 (defun lookup-data-type (name)
 669   (cdr (assoc name *data-types* :test 'equal)))
 670
 671 (define-uncompactor with-namespace ((&key uri name default) &body body)
 672   (when (xor (equal name "xml")
 673              (equal uri "http://www.w3.org/XML/1998/namespace"))
 674     (rng-error nil "invalid redeclaration of `xml' namespace"))
 675   (when (equal name "xmlns")
 676     (rng-error nil "invalid declaration of `xmlns' namespace"))
 677   (let ((*namespaces* *namespaces*)
 678         (*default-namespace* *default-namespace*))
 679     (when name
 680       (when (lookup-prefix name)
 681         (rng-error nil "duplicate declaration of prefix ~A" name))
 682       (push (cons name uri) *namespaces*))
 683     (when default
 684       (when *default-namespace*
 685         (rng-error nil "default namespace already declared to ~A"
 686                    *default-namespace*))
 687       (push (cons "" uri) *namespaces*)
 688       (setf *default-namespace* uri))
 689     (if (and name (not (or (eq uri :inherit) (equal uri ""))))
 690         (cxml:with-namespace (name uri)
 691           (mapc #'uncompact body))
 692         (mapc #'uncompact body))))
 693
 694 (define-uncompactor with-data-type ((&key name uri) &body body)
 695   (when (and (equal name "xsd")
 696              (not (equal uri "http://www.w3.org/2001/XMLSchema-datatypes")))
 697     (rng-error nil "invalid redeclaration of `xml' namespace"))
 698   (when (and (lookup-data-type name) (not (equal name "xsd")))
 699     (rng-error nil "duplicate declaration of library ~A" name))
 700   (let ((*data-types* (acons name uri *data-types*)))
 701     (mapc #'uncompact body)))
 702
 703 (defparameter *annotation-attributes* nil)
 704 (defparameter *annotation-elements* nil)
 705 (defparameter *annotation-wrap* nil)
 706
 707 (defmacro with-element (name-and-args &body body)
 708   (destructuring-bind (prefix lname &rest args)
 709       (if (atom name-and-args)
 710           (list nil name-and-args)
 711           name-and-args)
 712     `(invoke-with-element ,prefix
 713                           ,lname
 714                           (lambda () ,@args)
 715                           (lambda () ,@body))))
 716
 717 (defun invoke-with-element (prefix lname args body)
 718   (if (and *annotation-attributes*
 719            *annotation-wrap*)
 720       (cxml:with-element* (nil *annotation-wrap*)
 721         (let ((*annotation-wrap* nil))
 722           (invoke-with-element prefix lname args body)))
 723       (let ((*annotation-wrap* nil))
 724         (cxml:with-element* (prefix lname)
 725           (funcall args)
 726           (when *annotation-attributes*
 727             (uncompact *annotation-attributes*))
 728           (dolist (elt *annotation-elements*)
 729             (cxml:with-namespace
 730                 ("a" "http://relaxng.org/ns/compatibility/annotations/1.0")
 731               (cxml:with-element* ("a" "documentation")
 732                 (cxml:text elt))))
 733           (funcall body)))))
 734
 735 (define-uncompactor with-grammar ((&optional) &body body)
 736   (with-element "grammar"
 737     (mapc #'uncompact body)))
 738
 739 (define-uncompactor with-start ((&key combine-method) &body body)
 740   (with-element (nil "start"
 741                  (cxml:attribute "combine" combine-method))
 742     (mapc #'uncompact body)))
 743
 744 (define-uncompactor ref (name)
 745   (with-element (nil "ref"
 746                      (cxml:attribute "name" name))))
 747
 748 (define-uncompactor parent-ref (name)
 749   (with-element (nil "parentRef"
 750                      (cxml:attribute "name" name))))
 751
 752 (define-uncompactor parent-ref (name)
 753   (with-element (nil "parentRef" (cxml:attribute "name" name))))
 754
 755 (defun ns-attribute (uri-or-inherit)
 756   (unless (eq uri-or-inherit :inherit)
 757     (cxml:attribute "ns" uri-or-inherit)))
 758
 759 (define-uncompactor external-ref (&key uri inherit)
 760   (let ((ns (if inherit (lookup-prefix inherit) (lookup-default))))
 761     (with-element (nil "externalRef"
 762                        (cxml:attribute "href" (munge-schema-ref uri))
 763                        (ns-attribute ns)))))
 764
 765 (defvar *elementp*)
 766
 767 (define-uncompactor with-element ((&key name) pattern)
 768   (with-element "element"
 769     (let ((*elementp* t))
 770       (uncompact name))
 771     (uncompact pattern)))
 772
 773 (define-uncompactor with-attribute ((&key name) pattern)
 774   (with-element "attribute"
 775     (let ((*elementp* nil))
 776       (uncompact name))
 777     (uncompact pattern)))
 778
 779 (define-uncompactor list (pattern)
 780   (with-element "list"
 781     (uncompact pattern)))
 782
 783 (define-uncompactor mixed (pattern)
 784   (with-element "mixed"
 785     (uncompact pattern)))
 786
 787 (define-uncompactor :empty ()
 788   (with-element "empty"))
 789
 790 (define-uncompactor :text ()
 791   (with-element "text"))
 792
 793 (defun uncompact-data-type (data-type)
 794   (case data-type
 795     (:string
 796      (cxml:attribute "datatypeLibrary" "")
 797      (cxml:attribute "type" "string"))
 798     (:token
 799      (cxml:attribute "datatypeLibrary" "")
 800      (cxml:attribute "type" "token"))
 801     (t
 802      (cxml:attribute "datatypeLibrary"
 803                      (lookup-data-type (car data-type)))
 804      (cxml:attribute "type" (cdr data-type)))))
 805
 806 (define-uncompactor data (&key data-type params except)
 807   (with-element (nil "data" (uncompact-data-type data-type))
 808     (mapc #'uncompact params)
 809     (when except
 810       (with-element "except"
 811         (uncompact except)))))
 812
 813 (define-uncompactor value (&key data-type value)
 814   (with-element (nil "value" (uncompact-data-type data-type))
 815     (cxml:text value)))
 816
 817 (define-uncompactor :notallowed ()
 818   (with-element "notAllowed"))
 819
 820 (define-uncompactor with-definition ((&key name combine-method) &body body)
 821   (with-element (nil "define"
 822                      (cxml:attribute "name" name)
 823                      (cxml:attribute "combine" combine-method))
 824     (mapc #'uncompact body)))
 825
 826 (define-uncompactor with-div (&body body)
 827   (with-element "div"
 828     (mapc #'uncompact body)))
 829
 830 (define-uncompactor any-name (&key except)
 831   (with-element "anyName"
 832     (when except
 833       (with-element "except"
 834         (uncompact except)))))
 835
 836 (define-uncompactor ns-name (nc &key except)
 837   (with-element (nil "nsName"
 838                      (ns-attribute (lookup-prefix nc)))
 839     (when except
 840       (with-element "except"
 841         (uncompact except)))))
 842
 843 (define-uncompactor name-choice (&rest ncs)
 844   (with-element "choice"
 845     (mapc #'uncompact ncs)))
 846
 847 (defun destructure-cname-like (x)
 848   (when (keywordp x)
 849     (setf x (find x *keywords* :test 'string-equal)))
 850   (when (atom x)
 851     (setf x (cons (if *elementp* "" nil)
 852                   x)))
 853   (values (lookup-prefix (car x))
 854           (cdr x)))
 855
 856 (define-uncompactor name (x)
 857   (multiple-value-bind (uri lname) (destructure-cname-like x)
 858     (with-element (nil
 859                    "name"
 860                    (ns-attribute uri))
 861       (cxml:text lname))))
 862
 863 (define-uncompactor choice (&rest body)
 864   (with-element "choice"
 865     (mapc #'uncompact body)))
 866
 867 (define-uncompactor group (&rest body)
 868   (with-element "group"
 869     (mapc #'uncompact body)))
 870
 871 (define-uncompactor interleave (&rest body)
 872   (with-element "interleave"
 873     (mapc #'uncompact body)))
 874
 875 (define-uncompactor one-or-more (p)
 876   (with-element "oneOrMore"
 877     (uncompact p)))
 878
 879 (define-uncompactor optional (p)
 880   (with-element "optional"
 881     (uncompact p)))
 882
 883 (define-uncompactor zero-or-more (p)
 884   (with-element "zeroOrMore"
 885     (uncompact p)))
 886
 887 (defun munge-schema-ref (uri)
 888   (if (search "://" uri)
 889       (concatenate 'string "rnc+" uri)
 890       (concatenate 'string "rnc+://" uri)))
 891
 892 (defun rnc-uri-p (uri)
 893   (and (search "://" uri)
 894        (equal (mismatch "rnc+" uri) 4)))
 895
 896 (defun follow-rnc-uri (uri)
 897   (if (equal (mismatch "rnc+://" uri) 7)
 898       ;; rnc+://foo/bar
 899       (subseq uri 7)
 900       ;; rnc+file:///usr/foo/...
 901       (subseq uri 4)))
 902
 903 (define-uncompactor with-include ((&key inherit uri) &body body)
 904   (let ((ns (if inherit (lookup-prefix inherit) (lookup-default))))
 905     (with-element (nil "include"
 906                        (cxml:attribute "href" (munge-schema-ref uri))
 907                        (ns-attribute ns))
 908       (mapc #'uncompact body))))
 909
 910 (define-uncompactor with-annotations
 911     ((annotation &key attributes elements) &body body)
 912   (check-type annotation (member annotation))
 913   (let ((*annotation-attributes* attributes)
 914         (*annotation-elements* elements))
 915     (mapc #'uncompact body)))
 916
 917 (define-uncompactor without-annotations (&body body)
 918   (let ((*annotation-attributes* nil)
 919         (*annotation-elements* nil))
 920     (mapc #'uncompact body)))
 921
 922 ;; zzz das kann weg
 923 (define-uncompactor %with-annotations (&body body)
 924   (mapc #'uncompact body))
 925
 926 (define-uncompactor %with-annotations-group (&body body)
 927   (let ((*annotation-wrap* "group"))
 928     (mapc #'uncompact body)))
 929
 930 (define-uncompactor %with-annotations-choice (&body body)
 931   (let ((*annotation-wrap* "choice"))
 932     (mapc #'uncompact body)))
 933
 934 (define-uncompactor progn (a b)
 935   (when a (uncompact a))
 936   (when b (uncompact b)))
 937
 938 (define-uncompactor annotation-attributes (&rest attrs)
 939   (mapc #'uncompact attrs))
 940
 941 (define-uncompactor annotation-attribute (name value)
 942   (cxml:attribute* (car name) (cdr name) value))
 943
 944 (define-uncompactor param (name value)
 945   (with-element (nil "param"
 946                      (cxml:attribute "name" name))
 947     (cxml:text value)))
 948
 949 (define-uncompactor with-annotation-element ((&key name) &body attrs)
 950   (cxml:with-element name
 951     (mapc #'uncompact attrs)))
 952
 953 ;;; zzz strip BOM
 954 ;;; zzz newline normalization: Wir lesen von einem character-stream, daher
 955 ;;; macht das schon das Lisp fuer uns -- je nach Plattform. Aber nicht richtig.
 956 (defun uncompact-file-1 (stream)
 957   (handler-case
 958       (let ((lexer (make-rng-lexer
 959                     (make-instance 'hex-stream :source stream))))
 960         (yacc:parse-with-lexer
 961          (lambda ()
 962            (multiple-value-bind (cat sem) (funcall lexer)
 963              #+nil (print (list cat sem))
 964              (if (eq cat :eof)
 965                  nil
 966                  (values cat sem))))
 967          *compact-parser*))
 968     (error (c)
 969       (rng-error nil
 970                  "failed to parse compact syntax at char ~A, ~A:~%  ~A"
 971                  (file-position stream)
 972                  (cxml::safe-stream-sysid stream)
 973                  c))))
 974
 975 (defun uncompact-file (input &optional stream)
 976   (let ((tree
 977          (etypecase input
 978            (pathname (with-open-file (s input) (uncompact-file-1 s)))
 979            (stream (with-open-stream (s input) (uncompact-file-1 s))))))
 980     #+nil (print tree)
 981     (with-output-to-string (s)
 982       (cxml:with-xml-output
 983           (if stream
 984               (cxml:make-octet-stream-sink stream)
 985               (cxml:make-character-stream-sink s))
 986         (cxml:with-namespace ("" "http://relaxng.org/ns/structure/1.0")
 987           (uncompact tree))))))
 988
 989 (defun parse-compact (pathname)
 990   "@arg[pathname]{a pathname designator for a Relax NG compact file}
 991    @return{a parsed @class{schema}}
 992    @short{This function parses a Relax NG schema file in compact syntax}
 993    and returns a parsed representation of that schema.
 994
 995    @see{parse-schema}
 996    @see{make-validator}"
 997   (parse-schema (named-string-xstream
 998                  (uncompact-file pathname)
 999                  (cxml::pathname-to-uri pathname))))
1000
1001 (defun test-compact ()
1002   (dolist (p (directory "/home/david/src/nxml-mode-20041004/schema/*.rnc"))
1003     (print p)
1004     (with-open-file (s (make-pathname :type "rng" :defaults p)
1005                        :direction :output
1006                        :if-exists :supersede)
1007       (uncompact-file p s))))
1008
1009 #+(or)
1010 (compact)