src/parse/sgml-dtd.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SGML; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: A very first approach to parse DTD's directly
   4 ;;;   Created: 1997-10-14
   5 ;;;    Author: Gilbert Baumann <gilbert@base-engineering.com>
   6 ;;;   License: MIT style (see below)
   7 ;;; ---------------------------------------------------------------------------
   8 ;;;  (c) copyright 1997-2001 by Gilbert Baumann
   9
  10 ;;;  Permission is hereby granted, free of charge, to any person obtaining
  11 ;;;  a copy of this software and associated documentation files (the
  12 ;;;  "Software"), to deal in the Software without restriction, including
  13 ;;;  without limitation the rights to use, copy, modify, merge, publish,
  14 ;;;  distribute, sublicense, and/or sell copies of the Software, and to
  15 ;;;  permit persons to whom the Software is furnished to do so, subject to
  16 ;;;  the following conditions:
  17 ;;;
  18 ;;;  The above copyright notice and this permission notice shall be
  19 ;;;  included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  24 ;;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  25 ;;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  26 ;;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  27 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  28
  29 (in-package :SGML)
  30
  31 (defstruct element
  32   name                          ;the name (a SYMBOL)
  33   include                       ;set of included elements (a list)
  34   exclude                       ;set of excluded elements (a list)
  35   obegin?                       ;optional start tag? (boolean)
  36   oend?                         ;optional end tag? (boolean)
  37   attlist)
  38
  39 (defstruct (dtd (:print-function print-dtd))
  40   name
  41   elements                      ;EQ-hashtable mapping from SYMBOLs to ELEMENTs
  42   entities                      ;a simple alist mapping from entity names to entity values
  43   resolve-info                  ;a EQUAL-hashtable
  44   elm-surclusion-cache
  45   root-elements)
  46
  47 (defun print-dtd (self sink depth)
  48   (declare (ignore depth))
  49   (cond (*print-readably*
  50          (princ "#S" sink)
  51          (prin1 (list 'dtd
  52                       :name (dtd-name self)
  53                       :elements (dtd-elements self))
  54                 sink))
  55         (t
  56          (format sink "#<~S ~S>" (type-of self) (dtd-name self)))))
  57
  58 ;;;; ------------------------------------------------------------------------------------------
  59 ;;;;  Lexical analysis
  60 ;;;;
  61
  62 (defvar *entities*)
  63
  64 #||
  65 (defun find-entity (name)
  66   (cdr (assoc name *entities* :test #'string=)))
  67
  68 (defun add-entity (name value)
  69   (setf *entities* (nconc *entities* (list (cons name value)))))
  70
  71 (defun new-entities ()
  72   (setf *entities* nil))
  73 ||#
  74
  75 (defun find-entity (name)
  76   (gethash name *entities*))
  77
  78 (defun add-entity (name value)
  79   (if (> (length value) 60)
  80       (format T "~&;; % ~A <- '~A [...]' "
  81               name (substitute #\space #\newline (subseq value 0 60)))
  82     (format T "~&;; % ~A <- '~A' " name (substitute #\space #\newline value)))
  83   (unless (gethash name *entities*)
  84     (setf (gethash name *entities*) value)))
  85
  86 (defun new-entities ()
  87   (setf *entities* (make-hash-table :test #'equal)))
  88
  89 (clex:deflexer dtd
  90     ((alpha (or (range "a" "z") (range "A" "Z")))
  91      (digit (range "0" "9"))
  92      (white (or #\space #\newline #\tab #\page))
  93      (name-start alpha)
  94      (name-char (or alpha digit "." "-" "_"))
  95
  96      (string-char (or white (range #\space #\!) (range #\# #\&) (range #\( #\~)))
  97
  98      (name (and name-start (* name-char)))
  99      (any (or white (range #\space #\~))) )
 100
 101   ;;slurp away white spaces
 102   ((white))
 103   ;; slurp away comments
 104   ("--" (clex:begin 'comment))
 105   ((clex::in comment "--") (clex:begin 'clex:initial))
 106   ((clex::in comment any))
 107
 108   (("%" name ";")
 109    ;;this is a defined entity
 110    (let ((looked (find-entity (subseq clex:bag 1 (- (length clex:bag) 1)))))
 111      (cond (looked
 112             (clex:backup looked)
 113             #+(OR)
 114             (do ((i (- (length looked) 1) (- i 1)))
 115                 ((< i 0))
 116               (clex:backup (char looked i))))
 117            ((error "Entity ~A is not defined." clex:bag)) )))
 118   (("%" name)
 119    ;;this is a defined entity
 120    (let ((looked (find-entity (subseq clex:bag 1))))
 121      (cond (looked
 122             (do ((i (- (length looked) 1) (- i 1)))
 123                 ((< i 0))
 124               (clex:backup (char looked i))))
 125            ((error "Entity ~A is not defined." clex:bag)) )))
 126
 127   ("<!"
 128    (return :open))
 129   (">"
 130    (return :close))
 131   ("[" (return #\[))
 132   ("]" (return #\]))
 133   ("ENTITY"  (return :entity))
 134   ("ATTLIST" (return :attlist))
 135   ("ELEMENT" (return :element))
 136   ("SYSTEM"   (return :system))
 137   ("PUBLIC"   (return :public))
 138   ("CDATA"    (return :cdata))
 139   ("IGNORE"    (return :ignore))
 140   ("INCLUDE"    (return :include))
 141   ("#REQUIRED" (return :required))
 142   ("#IMPLIED" (return :implied))
 143   ("#PCDATA"  (return :pcdata))
 144   ("#FIXED"  (return :fixed))
 145   (name (return (list :name clex:bag)))
 146
 147   ("+(" (clex:backup #\() (return :plus-prefix))
 148   ("-(" (clex:backup #\() (return :minus-prefix))
 149
 150   ((+ digit)
 151    (return (list :number (parse-integer clex:bag))))
 152
 153   ;;singetons
 154   ((or "%()|+-*?,&")
 155    (return (char clex:bag 0)))
 156   ;;
 157   ((and #\" (* (or string-char #\')) #\")
 158    (return (list :string (subseq clex:bag 1 (- (length clex:bag) 1)))))
 159   ((and #\' (* (or string-char #\")) #\')
 160    (return (list :string (subseq clex:bag 1 (- (length clex:bag) 1))))) )
 161
 162 ;;;; ------------------------------------------------------------------------------------------
 163 ;;;;  Grammar
 164 ;;;;
 165
 166 (defvar *dtd*)
 167
 168 (defmacro action (&rest body)
 169   (let ((args (gensym)))
 170     `#'(lambda (&rest ,args)
 171          (declare (ignorable ,args))
 172          (symbol-macrolet (($1 (nth 0 ,args))
 173                            ($2 (nth 1 ,args))
 174                            ($3 (nth 2 ,args))
 175                            ($4 (nth 3 ,args))
 176                            ($5 (nth 4 ,args))
 177                            ($6 (nth 5 ,args))
 178                            ($7 (nth 6 ,args)))
 179            ,@body))) )
 180
 181 (lalr:define-grammar dtd-parser (:open :close :entity :attlist :element :name
 182                                  #\% #\( #\) #\| #\+ #\- #\* #\? #\, #\&
 183                                  :string
 184                                  :plus-prefix :minus-prefix
 185                                  :fixed
 186                                  :required :implied :number :pcdata :cdata
 187                                  :public :system :ignore :include #\[ #\])
 188   (start --> <definitions> (action nil))
 189
 190   (<definitions> --> <one-def> :close <definitions> (action nil))
 191   (<definitions> --> #'(lambda () nil))
 192
 193   (<one-def> --> definition (action (cond ((eq (car $1) 'def-my-entity)
 194                                            (add-entity (second $1) (third $1)))
 195                                           (t
 196                                            (case (car $1)
 197                                              ((defelement defattlist) (princ #\.) (finish-output *standard-output*)))
 198                                            (process-dtd-def *dtd* $1)))))
 199
 200   (<ignored-definitions> --> ignored-definition :close <ignored-definitions> (action nil))
 201   (<ignored-definitions> --> (action nil))
 202
 203   (ignored-definition --> definition (action nil))
 204
 205   (definition --> :open (action nil))
 206   (definition --> :open :ENTITY #\% :name :string               (action (list 'DEF-MY-ENTITY $4 $5)))
 207   (definition --> :open :ENTITY #\% :name <sgml-resource>       (action (list 'DEF-MY-ENTITY $4 (sgml-resource-as-string $5))))
 208   (definition --> :open :ENTITY :name <sgml-resource>           (action (list 'DEF-ENTITY $3 (sgml-resource-as-string $4))))
 209   (definition --> :open :ATTLIST production attliste            (action (list 'DEFATTLIST $3 $4)))
 210   (definition --> :open :ELEMENT production odef odef production maybe-pm       (action (list 'DEFELEMENT $3 $4 $5 $6 $7)))
 211
 212   (definition --> :open #\[ :ignore #\[ <ignored-definitions> #\] #\]
 213               #'(lambda (&rest i) i nil))
 214   (definition --> :open #\[ :include #\[ <definitions> #\] #\]
 215               #'(lambda (&rest i) i nil))
 216
 217   (attliste --> #'(lambda () nil))
 218   (attliste --> att-def attliste                #'cons)
 219
 220   (att-def --> ident production value           #'list)
 221   (att-def --> ident production :fixed value    #'(lambda (n p i v) i (list n p v)))
 222
 223   (maybe-pm --> #'(lambda () nil))
 224   (maybe-pm --> :plus-prefix production         #'(lambda (i p) i (list '+ p)))
 225   (maybe-pm --> :minus-prefix production        #'(lambda (i p) i (list '- p)))
 226
 227   (odef --> #\-   #'(lambda (i) i '-))
 228   (odef --> ident #'identity)
 229   (production --> p1 #'identity)
 230
 231   (p1 --> p2 #\| p1                             #'(lambda (a b c) b (as-cons 'or a c)))
 232   (p1 --> p2                                    #'identity)
 233   (p2 --> p3 #\, p2                             #'(lambda (a b c) b (as-cons 'and a c)))
 234   (p2 --> p3 #\& p2                             #'(lambda (a b c) b (as-cons 'amp a c)))
 235   (p2 --> p3                                    #'identity)
 236   (p3 --> p4 #\*                                #'(lambda (a b) b (list '* a)))
 237   (p3 --> p4 #\+                                #'(lambda (a b) b (list '+ a)))
 238   (p3 --> p4 #\?                                #'(lambda (a b) b (list '? a)))
 239   (p3 --> p4                                    #'identity)
 240   (p4 --> #\( production #\)                    #'(lambda (a b c) a c b))
 241   (p4 --> ident                                 #'identity)
 242   (p4 --> :pcdata                               #'identity)
 243   (p4 --> :cdata                                #'identity)
 244   (p4 --> :number                               #'(lambda (x) (princ-to-string x)))
 245
 246   (value --> :implied                           #'(lambda (a) a :implied))
 247   (value --> :required                          #'(lambda (a) a :required))
 248   (value --> ident                              #'identity)
 249   (value --> :string                            #'identity)
 250   (value --> :number                            #'identity)
 251
 252   (ident --> :name
 253          #'(lambda (x) (intern (string-upcase x) :keyword)))
 254
 255   ( <sgml-resource> --> :cdata  :string         #'list)
 256   ( <sgml-resource> --> :public :string         #'list)
 257   ( <sgml-resource> --> :public :string :string #'list)
 258   )
 259
 260 (defun parse-dtd (res-name &optional (top-elment :html))
 261   (let ((dtd (make-dtd :name res-name :elements (make-hash-table :test #'eq))))
 262     (with-open-stream (input (apply #'open-sgml-resource res-name))
 263       (let ((*dtd* dtd)
 264             (*entities*)
 265             (lexer (make-dtd-lexer input)))
 266         (new-entities)
 267         (labels ((next-input ()
 268                    (let ((x (funcall lexer)))
 269                      (cond ((eq x :eof) (values :eof :eof))
 270                            ((atom x) (values x x))
 271                            (t (values (first x) (second x))))))
 272                  (parse-error ()
 273                    ;;(untrack)
 274                    (error "Parse-Error! at pos = ~D" (ignore-errors (file-position input)))))
 275           (dtd-parser #'next-input #'parse-error))))
 276     (setf (gethash :pcdata (dtd-elements dtd))
 277       (make-element :name :pcdata
 278                     :include nil
 279                     :exclude nil))
 280     (calculate-resolve-info dtd top-elment)
 281     dtd))
 282
 283 ;;;; ------------------------------------------------------------------------------------------
 284
 285 (defun as-cons (op x y)
 286   (cond ((and (consp y) (eq (car y) op))
 287          (list* op x (cdr y)))
 288         ((list op x y))))
 289
 290 (defun find-element (dtd name &optional (intern? nil) (error? t))
 291   (or (gethash name (dtd-elements dtd))
 292       (and intern?
 293            (let ((new (make-element :name name)))
 294              (setf (gethash name (dtd-elements dtd)) new)
 295              new))
 296       (and error? (error "Element ~S is not defined." name))))
 297
 298 (defun find-element-attlist (dtd name)
 299   (let ((x (find-element dtd name nil nil)))
 300     (and x (element-attlist x))))
 301
 302 (defun canon-optional-tag-definition (x)
 303   (cond ((eq x '-) nil)
 304         ((eq x :O) t)
 305         (t
 306          (error "Optionalilty definition must be either '-' or 'O' - ~S. " x))))
 307
 308 (defun production->name-list (prod)
 309   (cond ((atom prod) (list prod))
 310         ((eq (car prod) 'or)
 311          (mapcan #'production->name-list (cdr prod)))
 312         (t
 313          (error "Bogus production - ~S" prod))))
 314
 315 (defun production->name-list/2 (prod)
 316   (cond ((atom prod) (list prod))
 317         ((member (car prod) '(or and amp + * ?))
 318          (mapcan #'production->name-list/2 (cdr prod)))
 319         (t
 320          (error "Bogus production - ~S" prod))))
 321
 322 (defun process-def-element (dtd name odef cdef production additional)
 323   (cond ((consp name)
 324          (dolist (name (production->name-list name))
 325            (process-def-element dtd name odef cdef production additional)))
 326         ((let ((obegin? (canon-optional-tag-definition odef))
 327                (oend?   (canon-optional-tag-definition cdef))
 328                (incl    (subst :pcdata :cdata           ;xxx hack here
 329                                (production->name-list/2 production)))
 330                (excl    nil))
 331            (cond ((and (consp additional) (eq (car additional) '+))
 332                   (setf incl (union incl (production->name-list/2 (cadr additional)))))
 333                  ((and (consp additional) (eq (car additional) '-))
 334                   (setf excl (production->name-list/2 (cadr additional))))
 335                  ((null additional))
 336                  (t
 337                   (error "Bogus extra inclusion/exclusion - ~S" additional)))
 338            (let ((elm (find-element dtd name t)))
 339              (setf (element-include elm) (if (equal incl '(:empty)) nil incl)
 340                    (element-exclude elm) excl
 341                    (element-obegin? elm) obegin?
 342                    (element-oend? elm)   oend?))))))
 343
 344 (defun process-attribute (name type value)
 345   (declare (ignore value))
 346   (setq type (production->name-list type))
 347   (cond ((and (= (length type) 1)
 348               (member (car type) '(:cdata)))
 349          (list (intern (symbol-name name) :keyword) 't))
 350         ((and (= (length type) 1)
 351               (member (car type) '(:number :name :id)))
 352          (list name (car type)))
 353         ((list (intern (symbol-name name) :keyword) type)) ))
 354
 355 (defun process-def-attlist (dtd name attlist)
 356   (cond ((consp name)
 357          (dolist (name (production->name-list name))
 358            (process-def-attlist dtd name attlist)))
 359         (t
 360          (setf (element-attlist (find-element dtd name t))
 361            (mapcar #'(lambda (x)
 362                        (process-attribute (first x) (second x) (third x)))
 363                    attlist)))))
 364
 365 (defun process-dtd-def (dtd def)
 366   (cond ((null def))
 367         ((eq (car def) 'def-entity)
 368          (push (cons (second def)
 369                      (resolve-entities-in-string
 370                       (string-rod (third def))
 371                       (dtd-entities dtd)))
 372                (dtd-entities dtd)))
 373         ((eq (car def) 'defelement)
 374          (process-def-element dtd
 375                               (second def) (third def) (fourth def) (fifth def) (sixth def)))
 376         ((eq (car def) 'defattlist)
 377          (process-def-attlist dtd (second def) (third def)))
 378         (t
 379          (error "Bogus dtd-def-form ~S" def))))
 380
 381 ;;; Uhu! CDATA seems also to been a defined content element. E.g. upon
 382 ;;; STYLE in the HTML-4.0 DTD.
 383
 384
 385 ;;;; ------------------------------------------------------------------------------------------
 386 ;;;;  SGML resources (how is this called in reality?)
 387 ;;;;
 388
 389 (defvar *simple-catalog* nil)
 390
 391 (defun open-sgml-resource (name-space &rest more)
 392   (ecase name-space
 393     (:system (apply #'open-system-resource more))
 394     (:public (apply #'open-public-resource more))
 395     (:cdata  (apply #'make-string-input-stream more)) ))
 396
 397 (defun open-system-resource (filename)
 398   (open filename :direction :input))
 399
 400 (defun open-public-resource (name &optional system-fallback)
 401   (open-sgml-resource :system
 402                       (cdr (or (assoc name *simple-catalog* :test #'string-equal)
 403                                system-fallback
 404                                (error "I do not know where to fetch PUBLIC \"~A\"." name)))))
 405
 406 #+nil
 407 (defun slurp-catalog (catalog-url)
 408   ;; Really dirty implementation
 409   (setf *simple-catalog* nil)
 410   (multiple-value-bind (io header) (netlib::open-document-2 catalog-url)
 411     (declare (ignore header))
 412     (unwind-protect
 413         (let ((str (html-glisp::gstream-as-string io)))
 414           (with-input-from-string (input str)
 415             (do ((x (read input nil nil) (read input nil nil)))
 416                 ((null x))
 417               (assert (equal (symbol-name x) "PUBLIC"))
 418               (let ((name (read input))
 419                     (file (read input)))
 420                 (assert (stringp name))
 421                 (assert (stringp file))
 422                 (push (cons name (url:merge-url (url:parse-url file) catalog-url))
 423                       *simple-catalog*)))))
 424       (g/close io))))
 425
 426 ;;;; ------------------------------------------------------------------------------------------
 427
 428 #+(OR)                                  ;seems to be buggy
 429 (defun sgml-resource-as-string (name)
 430   (with-open-stream (in (apply #'open-sgml-resource name))
 431     (let ((buffer (g/make-string 32 :adjustable t)))
 432       (do* ((i 0 j)
 433             (j (html-glisp:read-char-sequence buffer in :start 0 :end 32)
 434                (html-glisp:read-char-sequence buffer in :start i :end (+ i 4000)) ))
 435           ((= j i) (subseq buffer 0 j))
 436         (princ "%") (finish-output)
 437         (adjust-array buffer (list (+ j 4000))) ))))
 438
 439 (defun sgml-resource-as-string (name)
 440   (with-output-to-string (bag)
 441     (with-open-stream (in (apply #'open-sgml-resource name))
 442       (do ((x (read-char in nil nil) (read-char in nil nil)))
 443           ((null x))
 444         (write-char x bag)))))
 445
 446
 447
 448 ;;;; ------------------------------------------------------------------------------------------
 449 ;;;;  Calculating the resolve information
 450 ;;;;
 451
 452 ;;; Token data type
 453
 454 (defstruct token
 455   )
 456
 457 (defstruct (tag (:include token))
 458   name)
 459
 460 (defstruct (start-tag (:include tag) (:print-function print-start-tag))
 461   atts)
 462
 463 (defstruct (end-tag (:include tag) (:print-function print-end-tag)))
 464
 465 (defstruct (comment-token (:include token))
 466   data)
 467
 468 #||
 469 (defstruct (empty-tag
 470             (:include tag)
 471             (:print-function print-empty-tag))
 472   atts)
 473 ||#
 474
 475 (defun print-start-tag (self sink depth)
 476   (declare (ignore depth))
 477   (cond (*print-readably*
 478          (format sink "#.~S" `(MAKE-START-TAG :NAME ,(tag-name self)
 479                                               :ATTS ,(start-tag-atts self))))
 480         (t
 481          (format sink "<~A>" (tag-name self)))))
 482
 483 (defun print-end-tag (self sink depth)
 484   (declare (ignore depth))
 485   (cond (*print-readably*
 486          (format sink "#.~S" `(MAKE-END-TAG :NAME ,(tag-name self))))
 487         (t
 488          (format sink "</~A>" (tag-name self)))))
 489
 490 ;;; Elements
 491
 492 (defun elm-stag (elm)
 493   (make-start-tag :name elm))
 494
 495 (defun elm-etag (elm)
 496   (make-end-tag :name elm))
 497
 498 (defun find-dtd-top-elements (dtd)
 499   (or (dtd-root-elements dtd)
 500       (setf (dtd-root-elements dtd)
 501         (let ((includes nil)
 502               (tags nil))
 503           (maphash (lambda (key val)
 504                      (pushnew key tags)
 505                      (dolist (k (element-include val))
 506                        (pushnew k includes)))
 507                    (dtd-elements dtd))
 508           (set-difference tags includes)))))
 509
 510 (defun elm-inclusion (dtd x)
 511   (cond ((eql x :%top)
 512          (find-dtd-top-elements dtd)) ;;'(:html))
 513         (t
 514          (element-include (find-element dtd x)))))
 515
 516 (defun elm-oend? (dtd x)
 517   (cond ((eql x :%top)
 518          nil)
 519         ((eql x :pcdata)
 520          t)
 521         (t
 522          (element-oend? (find-element dtd x)))))
 523
 524 (defun elm-ostart? (dtd x)
 525   (if (eql x :%top)
 526       nil
 527     (element-obegin? (find-element dtd x))))
 528
 529 (defun all-elms (dtd)
 530   (let ((r nil))
 531     (maphash (lambda (n i)
 532                (declare (ignore i))
 533                (push n r))
 534              (dtd-elements dtd))
 535     r))
 536
 537 (defun elm-surclusion (dtd e)
 538   "For a given element 'e' calculate the surclusion, that is the set of all
 539    elements, which may contain `e' as direct child."
 540   (or (gethash e (dtd-elm-surclusion-cache dtd))
 541       (setf (gethash e (dtd-elm-surclusion-cache dtd))
 542         (cond ((eql e :html)
 543                (list :%top))
 544               (t
 545                (loop for k in (all-elms dtd)
 546                    when (member e (elm-inclusion dtd k))
 547                    collect k))) )))
 548
 549 (defun legal-in-p (dtd s x)
 550   (cond ((start-tag-p x)
 551          (member (tag-name x) (elm-inclusion dtd s)))
 552         ((end-tag-p x)
 553          (eq s (tag-name x))) ))
 554
 555 ;;; Actual calculation of resolve information
 556
 557 (defun raux (dtd s x yet)
 558   (let ((res nil))
 559     (cond ((member s yet)
 560            nil)
 561           ((legal-in-p dtd s x)
 562            (list nil))
 563           (t
 564            (let (q)
 565              (dolist (a (elm-inclusion dtd s))
 566                (when (and (elm-ostart? dtd a)
 567                           (setq q (raux dtd a x (cons s yet))))
 568                  (cond ((and (end-tag-p (car q))
 569                              (eql (tag-name (car q)) a))
 570                         '(warn "RAUX: s=~S x=~S yet=~S -> a=~S" s x yet a))
 571                        (t
 572                         (pushnew (elm-stag a) res :key #'tag-name)))))
 573              (when (elm-oend? dtd s)
 574                (dolist (z (elm-surclusion dtd s))
 575                  (when (raux dtd z x (cons s yet))
 576                    (pushnew (elm-etag s) res :key #'tag-name))))
 577              res)))))
 578
 579 (defun resolve-key (state token)
 580   (cond ((start-tag-p token)
 581          (list state :start (tag-name token)))
 582         ((end-tag-p token)
 583          (list state :end (tag-name token)))
 584         (t
 585          (error "oops in resolve-key ~S ~S" state token))))
 586
 587 (defun calculate-resolve-info (dtd &optional (top-elment :html))
 588   (setf (dtd-resolve-info dtd)
 589     (make-hash-table :test #'equal))
 590   (setf (dtd-elm-surclusion-cache dtd) (make-hash-table :test #'eq))
 591   (let ()
 592     (labels ((puta (a b r)
 593                (cond ((null r) )
 594                      ((= (length r) 1)
 595                       (setf (gethash (resolve-key a b) (dtd-resolve-info dtd)) (car r)))
 596                      (t
 597                       (warn "Ambiguous : ~S ~S." a b)))))
 598       (dolist (a (cons ':%top (all-elms dtd)))
 599         (princ "*") (finish-output)
 600         (dolist (b (cons ':%top (all-elms dtd)))
 601           (let ((bs (elm-stag b))
 602                 (be (elm-etag b)))
 603             (unless (legal-in-p dtd a bs)
 604               (puta a bs (raux dtd a bs nil)))
 605             (unless (legal-in-p dtd a be)
 606               (puta a be (raux dtd a be nil)))))))) )
 607
 608 (defun resolve (dtd state token)
 609   (gethash (resolve-key state token) (dtd-resolve-info dtd)))
 610
 611 ;;; -------------------------------------------------------------------------------------------
 612
 613 (defun set-equal (x y &rest options)
 614   (null (apply #'set-exclusive-or x y options)))
 615
 616 (defun elms-eqv (dtd x y)
 617   ;; zwei elms sind genau dann aequivalent, wenn inclusion und surclusion gleich sind.
 618   (and (set-equal (elm-inclusion dtd x) (elm-inclusion dtd y))
 619        (set-equal (elm-surclusion dtd x) (elm-surclusion dtd y))
 620        (equal (elm-oend? dtd x) (elm-oend? dtd x))
 621        (equal (elm-ostart? dtd x) (elm-ostart? dtd x))))
 622
 623 (defun eqv-classes (dtd)
 624   (let ((classes nil))
 625     (dolist (k (all-elms dtd))
 626       (do ((q classes (cdr q)))
 627           ((null q)
 628            (push (list k) classes))
 629         (when (elms-eqv dtd k (caar q))
 630           (setf (car q) (cons k (car q)))
 631           (return))))
 632     classes))
 633
 634 ;;;; ----------------------------------------------------------------------------------------------------
 635 ;;;;  Compiled DTDs
 636 ;;;;
 637
 638 ;; Since parsing and 'compiling' DTDs is slow, I'll provide for a way
 639 ;; to (un)dump compiled DTD to stream.
 640
 641 (defun dump-dtd (dtd sink)
 642   (let ((*print-pretty* nil)
 643         (*print-readably* t)
 644         (*print-circle* t))
 645     (princ "#." sink)
 646     (prin1
 647      `(MAKE-DTD :NAME ',(dtd-name dtd)
 648                 :ELEMENTS (LET ((R (MAKE-HASH-TABLE :TEST #'EQ)))
 649                                (SETF ,@(let ((q nil))
 650                                          (maphash (lambda (key value)
 651                                                     (push `',value q)
 652                                                     (push `(GETHASH ',key R) q))
 653                                                   (dtd-elements dtd))
 654                                          q))
 655                                R)
 656                 :ENTITIES ',(dtd-entities dtd)
 657                 :RESOLVE-INFO (LET ((R (MAKE-HASH-TABLE :TEST #'EQUAL)))
 658                                    (SETF ,@(let ((q nil))
 659                                              (maphash (lambda (key value)
 660                                                         (push `',value q)
 661                                                         (push `(GETHASH ',key R) q))
 662                                                       (dtd-resolve-info dtd))
 663                                              q))
 664                                    R)
 665                 ;; XXX surclusion-cache fehlt
 666                 )
 667      sink)))
 668
 669 ;;XXX
 670 (defun save-html-dtd ()
 671   (with-open-file (sink "html-dtd.lisp" :direction :output :if-exists :new-version)
 672     (print `(in-package :sgml) sink)
 673     (let ((*package* (find-package :sgml)))
 674       (princ "(SETQ " sink)
 675       (prin1 'cl-user::*html-dtd* sink)
 676       (princ " '" sink)
 677       (dump-dtd cl-user::*html-dtd* sink)
 678       (princ ")" sink))))
 679
 680 ;;; --------------------------------------------------------------------------------
 681 ;;;  dumping DTDs
 682
 683
 684 (defun dump-dtd (dtd filename)
 685   (let ((*foo* dtd))
 686     (declare (special *foo*))
 687     (with-open-file (sink (merge-pathnames filename "*.lisp")
 688                      :direction :output
 689                      :if-exists :new-version)
 690       (format sink "(in-package :sgml)(locally (declare (special *foo*))(setq *foo* '#.*foo*))"))
 691     (compile-file (merge-pathnames filename "*.lisp"))))
 692
 693 (defun undump-dtd (filename)
 694   (let (*foo*)
 695     (declare (special *foo*))
 696     (load (compile-file-pathname (merge-pathnames filename "*.lisp"))
 697           :verbose nil
 698           :print nil)
 699     *foo*))
 700
 701 (defmethod make-load-form ((self dtd) &optional env)
 702   (declare (ignore env))
 703   `(make-dtd :name                  ',(dtd-name self)
 704              :elements              ',(dtd-elements self)
 705              :entities              ',(dtd-entities self)
 706              :resolve-info          ',(dtd-resolve-info self)
 707              :elm-surclusion-cache  ',(dtd-elm-surclusion-cache self)
 708              :root-elements         ',(dtd-root-elements self)))
 709
 710 (defmethod make-load-form ((self element) &optional env)
 711   (declare (ignore env))
 712   `(make-element
 713     :name    ',(element-name self)
 714     :include ',(element-include self)
 715     :exclude ',(element-exclude self)
 716     :obegin? ',(element-obegin? self)
 717     :oend?   ',(element-oend? self)
 718     :attlist ',(element-attlist self)))
 719
 720 (defmethod make-load-form ((self tag) &optional env)
 721   (declare (ignore env))
 722   `(make-tag :name ',(tag-name self)))
 723
 724 (defmethod make-load-form ((self start-tag) &optional env)
 725   (declare (ignore env))
 726   `(make-start-tag :name ',(tag-name self)
 727                    :atts ',(start-tag-atts self)))
 728
 729 (defmethod make-load-form ((self end-tag) &optional env)
 730   (declare (ignore env))
 731   `(make-end-tag :name ',(tag-name self)))
 732
 733 (defmethod make-load-form ((self comment-token) &optional env)
 734   (declare (ignore env))
 735   `(make-comment-token :data ',(comment-token-data self)))
 736
 737 ;;;;
 738 #||
 739 (defmethod my-make-load-form ((self dtd))
 740   (declare (ignore env))
 741   `(make-dtd :name                  ,(my-make-load-form (dtd-name self))
 742              :elements              ,(my-make-load-form (dtd-elements self))
 743              :entities              ,(my-make-load-form (dtd-entities self))
 744              :resolve-info          ,(my-make-load-form (dtd-resolve-info self))
 745              :elm-surclusion-cache  ,(my-make-load-form (dtd-elm-surclusion-cache self))
 746              :root-elements         ,(my-make-load-form (dtd-root-elements self))))
 747
 748 (defmethod my-make-load-form ((self element))
 749   (declare (ignore env))
 750   `(make-element
 751     :name    ,(my-make-load-form (element-name self))
 752     :include ,(my-make-load-form (element-include self))
 753     :exclude ,(my-make-load-form (element-exclude self))
 754     :obegin? ,(my-make-load-form (element-obegin? self))
 755     :oend?   ,(my-make-load-form (element-oend? self))
 756     :attlist ,(my-make-load-form (element-attlist self))))
 757
 758 (defmethod my-make-load-form ((self tag))
 759   (declare (ignore env))
 760   `(make-tag :name ,(my-make-load-form (tag-name self))))
 761
 762 (defmethod my-make-load-form ((self start-tag))
 763   (declare (ignore env))
 764   `(make-start-tag :name ,(my-make-load-form (tag-name self))
 765                    :atts ,(my-make-load-form (start-tag-atts self))))
 766
 767 (defmethod my-make-load-form ((self end-tag))
 768   (declare (ignore env))
 769   `(make-end-tag :name ,(my-make-load-form (tag-name self))))
 770
 771 (defmethod my-make-load-form ((self comment-token))
 772   (declare (ignore env))
 773   `(make-comment-token :data ,(my-make-load-form (comment-token-data self))))
 774
 775 (defmethod my-make-load-form ((object cons))
 776   (let ((yet nil))
 777     (do ((q object (cdr q)))
 778         ((atom q)
 779          (if (null q)
 780              `(list ,@(reverse yet))
 781            `(list* ,@(reverse yet) ,(my-make-load-form q))))
 782       (push (my-make-load-form (car q)) yet))))
 783
 784 (defmethod my-make-load-form ((object string))
 785   object)
 786
 787 (defmethod my-make-load-form ((object vector))
 788   `(make-array ,(length object)
 789                :element-type ',(array-element-type object)
 790                :initial-contents ,(my-make-load-form (coerce object 'list))))
 791
 792 (defmethod my-make-load-form ((object symbol))
 793   (cond ((keywordp object) object)
 794         ((eq object nil) nil)
 795         (t `',object)))
 796
 797 (defmethod my-make-load-form ((object number))
 798   object)
 799
 800 (defmethod my-make-load-form ((object hash-table))
 801   `(let ((res (make-hash-table :test ',(hash-table-test object))))
 802      ,@(let ((todo nil))
 803          (maphash (lambda (key value)
 804                     (push `(gethash ,(my-make-load-form key) res) todo)
 805                     (push (my-make-load-form value) todo))
 806                   object)
 807          todo)
 808      res))
 809
 810 (defun dump-dtd (dtd filename)
 811   (with-open-file (sink filename
 812                    :direction :output
 813                    :if-exists :new-version)
 814     (with-standard-io-syntax
 815       (let ((*package* (find-package :cl)))
 816         (print (my-make-load-form dtd) sink))))
 817   (values))
 818 ||#
 819
 820 #||
 821 ;; ACL specific
 822
 823 (defun dump-dtd (dtd filename)
 824   (with-open-file (sink filename
 825                    :direction :output
 826                    :if-exists :new-version
 827                    :element-type '(unsigned-byte 8))
 828     (with-standard-io-syntax
 829       (let ((*package* (find-package :cl)))
 830         (excl:fasl-write dtd sink))))
 831   (values))
 832
 833 (defun undump-dtd (filename)
 834   (first (excl:fasl-read (open filename :element-type '(unsigned-byte 8)))))
 835 ||#