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