cgit.sxemacs.org Git - packages/blob - xemacs-packages/psgml/psgml-dtd.el

   1 ;;;; psgml-dtd.el --- DTD parser for SGML-editing mode with parsing support
   2 ;; $Id: psgml-dtd.el,v 2.30 2003/03/25 19:46:09 lenst Exp $
   3
   4 ;; Copyright (C) 1994 Lennart Staflin
   5
   6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
   7
   8 ;; This program is free software; you can redistribute it and/or
   9 ;; modify it under the terms of the GNU General Public License
  10 ;; as published by the Free Software Foundation; either version 2
  11 ;; of the License, or (at your option) any later version.
  12 ;;
  13 ;; This program is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17 ;;
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; if not, write to the Free Software
  20 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22 \f
  23 ;;;; Commentary:
  24
  25 ;; Part of major mode for editing the SGML document-markup language.
  26
  27 \f
  28 ;;;; Code:
  29
  30 (provide 'psgml-dtd)
  31 (require 'psgml)
  32 (require 'psgml-parse)
  33 (eval-when-compile (require 'cl))
  34 \f
  35 ;;;; Variables
  36
  37 ;; Variables used during doctype parsing and loading
  38 (defvar sgml-used-pcdata nil
  39   "True if model group built is mixed.")
  40
  41 \f
  42 ;;;; Constructing basic
  43
  44 (defun sgml-copy-moves (s1 s2)
  45   "Copy all moves from S1 to S2, keeping their status."
  46   (let ((l (sgml-state-opts s1)))
  47     (while l
  48       (sgml-add-opt-move s2
  49                          (sgml-move-token (car l))
  50                          (sgml-move-dest (car l)))
  51       (setq l (cdr l)))
  52     (setq l (sgml-state-reqs s1))
  53     (while l
  54       (sgml-add-req-move s2
  55                          (sgml-move-token (car l))
  56                          (sgml-move-dest (car l)))
  57       (setq l (cdr l)))))
  58
  59 (defun sgml-copy-moves-to-opt (s1 s2)
  60   "Copy all moves from S1 to S2 as optional moves."
  61   (let ((l (sgml-state-opts s1)))
  62     (while l
  63       (sgml-add-opt-move s2
  64                          (sgml-move-token (car l))
  65                          (sgml-move-dest (car l)))
  66       (setq l (cdr l)))
  67     (setq l (sgml-state-reqs s1))
  68     (while l
  69       (sgml-add-opt-move s2
  70                          (sgml-move-token (car l))
  71                          (sgml-move-dest (car l)))
  72       (setq l (cdr l)))))
  73
  74
  75 (defun sgml-some-states-of (state)
  76   ;; List of some states reachable from STATE, includes all final states
  77   (let* ((states (list state))
  78          (l states)
  79          s ms m)
  80     (while l
  81       (setq s (car l)
  82             ms (append (sgml-state-opts s) (sgml-state-reqs s)))
  83       (while ms
  84         (setq m (sgml-move-dest (car ms))
  85               ms (cdr ms))
  86         (unless (sgml-normal-state-p m)
  87           (setq m (sgml-and-node-next m)))
  88         (unless (memq m states)
  89           (nconc states (list m))))
  90       (setq l (cdr l)))
  91     states))
  92
  93 (defmacro sgml-for-all-final-states (s dfa &rest forms)
  94   "For all final states S in DFA do FORMS.
  95 Syntax: var dfa-expr &body forms"
  96   (` (let ((L-states (sgml-some-states-of (, dfa)))
  97            (, s))
  98        (while L-states
  99          (when (sgml-state-final-p (setq (, s) (car L-states)))
 100            (,@ forms))
 101          (setq L-states (cdr L-states))))))
 102
 103 (put 'sgml-for-all-final-states 'lisp-indent-hook 2)
 104 (put 'sgml-for-all-final-states 'edebug-form-hook '(symbolp &rest form))
 105
 106 \f
 107 ;;;; Optimization for the dfa building
 108
 109 (defsubst sgml-empty-state-p (s)
 110   "True if S has no outgoing moves."
 111   (and (sgml-normal-state-p s)
 112        (null (sgml-state-reqs s))
 113        (null (sgml-state-opts s)))  )
 114
 115 (defun sgml-one-final-state (s)
 116   "Collapse all states that have no moves.
 117 This is a safe optimization, useful for (..|..|..)."
 118   (sgml-debug "OPT one final: reqs %d opts %d"
 119               (length (sgml-state-reqs s))
 120               (length (sgml-state-opts s)))
 121   (let ((final nil)
 122         dest)
 123     (loop for m in (append (sgml-state-reqs s)
 124                            (sgml-state-opts s))
 125           do
 126           (setq dest (sgml-move-dest m))
 127           (when (sgml-empty-state-p dest)
 128             (cond ((null final)
 129                    (setq final dest))
 130                   (t
 131                    (setf (sgml-move-dest m) final)))))))
 132
 133 (defun sgml-states-equal (s1 s2)
 134   (and (= (length (sgml-state-opts s1))
 135           (length (sgml-state-opts s2)))
 136        (= (length (sgml-state-reqs s1))
 137           (length (sgml-state-reqs s2)))
 138        (loop for m in (sgml-state-opts s1)
 139              always
 140              (eq (sgml-move-dest m)
 141                  (sgml-move-dest (sgml-moves-lookup (sgml-move-token m)
 142                                                     (sgml-state-opts s2)))))
 143        (loop for m in (sgml-state-reqs s1)
 144              always
 145              (eq (sgml-move-dest m)
 146                  (sgml-move-dest (sgml-moves-lookup (sgml-move-token m)
 147                                                     (sgml-state-reqs s2)))))))
 148
 149 (defun sgml-remove-redundant-states-1 (s)
 150   ;; Remove states accessible from s with one move and equivalent to s,
 151   ;; by changing the moves from s.
 152   (sgml-debug "OPT redundant-1: reqs %d opts %d"
 153               (length (sgml-state-reqs s))
 154               (length (sgml-state-opts s)))
 155   (let ((yes nil)
 156         (no (list s))
 157         (l (sgml-state-reqs s))
 158         (nl (sgml-state-opts s))
 159         dest)
 160     (while (or l (setq l (prog1 nl (setq nl nil))))
 161       (cond
 162        ((not (sgml-normal-state-p (setq dest (sgml-move-dest (car l))))))
 163        ((memq dest no))
 164        ((memq dest yes))
 165        ((sgml-states-equal s dest)
 166         (progn (push dest yes))))
 167       (setq l (cdr l)))
 168     (setq l (sgml-state-opts s)
 169           nl (sgml-state-reqs s))
 170     (when yes
 171       (sgml-debug "OPT redundant-1: success %s" (length yes))
 172       (while (or l (setq l (prog1 nl (setq nl nil))))
 173         (cond ((memq (sgml-move-dest (car l)) yes)
 174                (setf (sgml-move-dest (car l)) s)))
 175         (setq l (cdr l))))))
 176
 177
 178 \f
 179 ;;;; Constructing
 180
 181 (defun sgml-make-opt (s1)
 182   (when (sgml-state-reqs s1)
 183     (setf (sgml-state-opts s1)
 184           (nconc (sgml-state-opts s1)
 185                  (sgml-state-reqs s1)))
 186     (setf (sgml-state-reqs s1) nil))
 187   s1)
 188
 189 (defun sgml-make-* (s1)
 190   (setq s1 (sgml-make-+ s1))
 191   (when (sgml-state-reqs s1)
 192     (sgml-make-opt s1))
 193   (sgml-remove-redundant-states-1 s1)
 194   s1)
 195
 196 (defun sgml-make-+ (s1)
 197   (sgml-for-all-final-states s s1
 198     (sgml-copy-moves-to-opt s1 s))
 199   (sgml-remove-redundant-states-1 s1)   ; optimize
 200   s1)
 201
 202 (defun sgml-make-conc (s1 s2)
 203   (let ((moves (append (sgml-state-reqs s1) (sgml-state-opts s1))))
 204     (cond
 205      (;; optimize the case where all moves from s1 goes to empty states
 206       (loop for m in moves
 207             always (sgml-empty-state-p (sgml-move-dest m)))
 208       (loop for m in moves do (setf (sgml-move-dest m) s2))
 209       (when (sgml-state-final-p s1)
 210         (sgml-copy-moves s2 s1)))
 211      (t                                 ; general case
 212       (sgml-for-all-final-states s s1
 213         (sgml-copy-moves s2 s)
 214         (sgml-remove-redundant-states-1 s)))))
 215   s1)
 216
 217 (defun sgml-make-pcdata ()
 218   (sgml-make-* (sgml-make-primitive-content-token sgml-pcdata-token)))
 219
 220 (defun sgml-reduce-, (l)
 221   (while (cdr l)
 222     (setcar (cdr l)
 223             (sgml-make-conc (car l) (cadr l)))
 224     (setq l (cdr l)))
 225   (car l))
 226
 227 (defun sgml-reduce-| (l)
 228   (while (cdr l)                        ; apply the binary make-alt
 229     (cond ((or (sgml-state-final-p (car l))     ; is result optional
 230                (sgml-state-final-p (cadr l)))
 231            (sgml-make-opt (car l))
 232            (sgml-copy-moves-to-opt (cadr l) (car l)))
 233           (t
 234            (sgml-copy-moves (cadr l) (car l))))
 235     (setcdr l (cddr l)))
 236   (sgml-one-final-state (car l))        ; optimization
 237   (car l))
 238
 239 (defun sgml-make-& (dfas)
 240   (let ((&n (sgml-make-and-node dfas (sgml-make-state)))
 241         (s (sgml-make-state))
 242         (l dfas))
 243     (while l                            ; For each si:
 244       ;; For m in opts(si): add optional move from s to &n on token(m).
 245       (loop for m in (sgml-state-opts (car l))
 246             do (sgml-add-opt-move s (sgml-move-token m) &n))
 247       ;; For m in reqs(si): add required move from s to &n on token(m).
 248       (loop for m in (sgml-state-reqs (car l))
 249             do (sgml-add-req-move s (sgml-move-token m) &n))
 250       (setq l (cdr l)))
 251     ;; Return s.
 252     s))
 253
 254
 255
 256 ;(sgml-make-conc (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list))
 257 ;(sgml-make-conc (sgml-make-& (list (sgml-make-primitive-content-token 'para) (sgml-make-primitive-content-token 'list))) (sgml-make-primitive-content-token 'foo))
 258
 259 ;(setq x  (sgml-some-states-of  (sgml-make-primitive-content-token 'para)))
 260 ;(sgml-state-final-p (car x) )
 261 ;(sgml-state-final-p (cadr x))
 262
 263 \f
 264 ;;;; Parse doctype: General
 265
 266 (defun sgml-skip-ts ()
 267   ;; Skip over ts*
 268   ;;70  ts   = 5 s | EE | 60+ parameter entity reference
 269   ;;For simplicity I use ps*
 270   ;;65  ps   = 5 s | EE | 60+ parameter entity reference | 92 comment
 271   ;;*** some comments are accepted that shouldn't
 272   (sgml-skip-ps))
 273
 274 (defun sgml-parse-character-reference (&optional dofunchar)
 275   ;; *** Actually only numerical character references
 276   ;; I don't know how to handel the function character references.
 277   ;; For the shortrefs let's give them numeric values.
 278   (if (if dofunchar
 279           (sgml-parse-delim "CRO" (digit nmstart))
 280         (sgml-parse-delim "CRO" (digit)))
 281       (prog1 (if (sgml-is-delim "NULL" digit)
 282                  (string-to-int (sgml-check-nametoken))
 283                (let ((spec (sgml-check-name)))
 284                  (or (cdr (assoc spec '(("RE" . 10)
 285                                         ("RS" . 1)
 286                                         ("TAB" . 9)
 287                                         ("SPACE" . 32))))
 288                      ;; *** What to do with other names?
 289                      127)))
 290         (or (sgml-parse-delim "REFC")
 291             (sgml-parse-RE)))))
 292
 293 (defun sgml-parse-parameter-literal (&optional dofunchar)
 294   (let* (lita                           ; flag if lita
 295          (value                         ; accumulates literals value
 296           "")
 297          (original-buffer               ; Buffer (entity) where lit started
 298           (current-buffer))
 299          temp)
 300     (cond
 301      ((or (sgml-parse-delim "LIT")
 302           (setq lita (sgml-parse-delim "LITA")))
 303       (while (not (and (eq (current-buffer) original-buffer)
 304                        (if lita
 305                            (sgml-parse-delim "LITA")
 306                          (sgml-parse-delim "LIT"))))
 307         (cond ((eobp)
 308                (or (sgml-pop-entity)
 309                    (sgml-error "Parameter literal unterminated")))
 310               ((sgml-parse-parameter-entity-ref))
 311               ((setq temp (sgml-parse-character-reference dofunchar))
 312                (setq value
 313                      (concat value
 314                              (cond ((< temp 256)
 315                                     ;; XEmacs: test if bound
 316                                     (if (and
 317                                          (boundp 'enable-multibyte-characters)
 318                                          enable-multibyte-characters
 319                                          (fboundp 'unibyte-char-to-multibyte))
 320                                         (setq temp (unibyte-char-to-multibyte temp)))
 321                                     (format "%c" temp))
 322                                    (t
 323                                     (format "&#%d;" temp))))))
 324               (t
 325                (setq value
 326                      (concat value
 327                              (buffer-substring-no-properties
 328                               (point)
 329                               (progn (forward-char 1)
 330                                      (if lita
 331                                          (sgml-skip-upto ("LITA" "PERO" "CRO"))
 332                                        (sgml-skip-upto ("LIT" "PERO" "CRO")))
 333                                      (point))))))))
 334       value))))
 335
 336 (defun sgml-check-parameter-literal ()
 337   (or (sgml-parse-parameter-literal)
 338       (sgml-parse-error "Parameter literal expected")))
 339
 340 (defsubst sgml-parse-connector ()
 341   (sgml-skip-ps)
 342   (cond ((sgml-parse-delim "SEQ")
 343          (function sgml-reduce-,))
 344         ((sgml-parse-delim "OR")
 345          (function sgml-reduce-|))
 346         ((sgml-parse-delim "AND")
 347          (if sgml-xml-p
 348              (sgml-error "XML forbids AND connector")
 349            (function sgml-make-&)))))
 350
 351 (defun sgml-parse-name-group ()
 352   "Parse a single name or a name group (general name case) .
 353 Returns a list of strings or nil."
 354   (let (names)
 355     (cond
 356      ((sgml-parse-delim "GRPO")
 357       (sgml-skip-ps)
 358       (setq names (sgml-parse-name-group)) ; *** Allows more than it should
 359       (while (sgml-parse-connector)
 360         (sgml-skip-ps)
 361         (nconc names (sgml-parse-name-group)))
 362       (sgml-check-delim "GRPC")
 363       names)
 364      ((setq names (sgml-parse-name))
 365       (list names)))))
 366
 367 (defun sgml-check-name-group ()
 368   (or (sgml-parse-name-group)
 369       (sgml-parse-error "Expecting a name or a name group")))
 370
 371 (defun sgml-check-nametoken-group ()
 372   "Parse a name token group, return a list of strings.
 373 Case transformed for general names."
 374   (sgml-skip-ps)
 375   (let ((names nil))
 376     (cond
 377      ((sgml-parse-delim GRPO)
 378       (while (progn
 379                (sgml-skip-ps)
 380                (push (sgml-general-case (sgml-check-nametoken)) names)
 381                (sgml-parse-connector)))
 382       (sgml-check-delim GRPC)
 383       (nreverse names))                 ; store in same order as declared
 384      (t
 385       (list (sgml-general-case (sgml-check-nametoken)))))))
 386
 387 (defun sgml-check-element-type ()
 388   "Parse and check an element type, return list of strings."
 389 ;;; 117  element type     =  [[30 generic identifier]]
 390 ;;;                      |  [[69 name group]]
 391 ;;;                      |  [[118 ranked element]]
 392 ;;;                      |  [[119 ranked group]]
 393   (cond
 394    ((sgml-parse-delim GRPO)
 395     (when sgml-xml-p
 396       (sgml-error "XML forbids name groups for the element type"))
 397     (sgml-skip-ts)
 398     (let ((names (list (sgml-check-name))))
 399       (while (progn (sgml-skip-ts)
 400                     (sgml-parse-connector))
 401         (sgml-skip-ts)
 402         (nconc names (list (sgml-check-name))))
 403       (sgml-check-delim GRPC)
 404       ;; A ranked group will have a rank suffix here
 405       (sgml-skip-ps)
 406       (if (sgml-is-delim "NULL" digit)
 407         (let ((suffix (sgml-parse-nametoken)))
 408           (loop for n in names
 409                 collect (concat n suffix)))
 410         names)))
 411    (t                                   ; gi/ranked element
 412     (let ((name (sgml-check-name)))
 413       (sgml-skip-ps)
 414       (list (if (sgml-is-delim "NULL" digit)
 415                 (concat name (sgml-check-nametoken))
 416               name))))))
 417
 418
 419 (defun sgml-check-external (&optional pubid-ok)
 420   (or (sgml-parse-external pubid-ok)
 421       (sgml-parse-error "Expecting a PUBLIC or SYSTEM")))
 422 \f
 423 ;;;; Parse doctype: notation
 424
 425 (defun sgml-declare-notation ()
 426   ;;148  notation declaration = MDO, "NOTATION",
 427   ;;                        65 ps+, 41 notation name,
 428   ;;                        65 ps+, 149 notation identifier,
 429   ;;                        65 ps*, MDC
 430   ;;41   notation name    = 55 name
 431   ;;149  notation identifier = 73 external identifier
 432   (sgml-skip-ps)
 433   (sgml-check-name)
 434   (sgml-skip-ps)
 435   (sgml-check-external t))
 436
 437 \f
 438 ;;;; Parse doctype: Element
 439
 440 (defun sgml-parse-opt ()
 441   (sgml-skip-ps)
 442   (cond ((or (sgml-parse-char ?o)
 443              (sgml-parse-char ?O))
 444          (if sgml-xml-p
 445               (sgml-error "XML forbids omitted tag minimization.")
 446            t))
 447         ((sgml-parse-char ?-)
 448          (if sgml-xml-p
 449              (sgml-error "XML forbids omitted tag minimization")
 450            nil))))
 451
 452 (defun sgml-parse-modifier ()
 453   (cond ((sgml-parse-delim "PLUS")
 454          (function sgml-make-+))
 455         ((sgml-parse-delim "REP")
 456          (function sgml-make-*))
 457         ((sgml-parse-delim "OPT")
 458          (function sgml-make-opt))))
 459
 460 (defun sgml-check-primitive-content-token ()
 461   (sgml-make-primitive-content-token
 462    (sgml-eltype-token
 463     (sgml-lookup-eltype
 464      (sgml-check-name)))))
 465
 466 (defun sgml-check-model-group ()
 467   (sgml-skip-ps)
 468   (let (el mod)
 469     (cond
 470      ((sgml-parse-delim "GRPO")
 471       (let ((subs (list (sgml-check-model-group)))
 472             (con1 nil)
 473             (con2 nil))
 474         (while (setq con2 (sgml-parse-connector))
 475           (cond ((and con1
 476                       (not (eq con1 con2)))
 477                  (sgml-parse-error "Mixed connectors")))
 478           (setq con1 con2)
 479           (setq subs (nconc subs (list (sgml-check-model-group)))))
 480         (sgml-check-delim "GRPC")
 481         (setq el (if con1
 482                      (funcall con1 subs)
 483                    (car subs)))))
 484      ((sgml-parse-rni "PCDATA")         ; #PCDATA (FIXME: when changing case)
 485       (setq sgml-used-pcdata t)
 486       (setq el (sgml-make-pcdata)))
 487      ((sgml-parse-delim "DTGO")                 ; data tag group
 488       (when sgml-xml-p
 489         (sgml-error "XML forbids DATATAG"))
 490       (sgml-skip-ts)
 491       (let ((tok (sgml-check-primitive-content-token)))
 492         (sgml-skip-ts) (sgml-check-delim "SEQ")
 493         (sgml-skip-ts) (sgml-check-data-tag-pattern)
 494         (sgml-skip-ts) (sgml-check-delim "DTGC")
 495         (setq el (sgml-make-conc tok (sgml-make-pcdata)))
 496         (setq sgml-used-pcdata t)))
 497      (t
 498       (setq el (sgml-check-primitive-content-token))))
 499     (setq mod (sgml-parse-modifier))
 500     (if mod
 501         (funcall mod el)
 502       el)))
 503
 504 (defun sgml-check-data-tag-pattern ()
 505   ;; 134  data tag pattern
 506   ;; template | template group
 507   (cond ((sgml-parse-delim GRPO)
 508          (sgml-skip-ts)
 509          (sgml-check-parameter-literal) ; data tag template,
 510          (while (progn (sgml-skip-ts)
 511                        (sgml-parse-delim OR))
 512            (sgml-skip-ts)
 513            (sgml-check-parameter-literal)) ; data tag template
 514          (sgml-skip-ts)
 515          (sgml-check-delim GRPC))
 516         (t
 517          (sgml-check-parameter-literal))) ; data tag template
 518   (sgml-skip-ts)
 519   (when (sgml-parse-delim SEQ)
 520     (sgml-check-parameter-literal)))    ; data tag padding template
 521
 522 (defun sgml-check-content-model ()
 523   (sgml-check-model-group))
 524
 525 (defun sgml-check-content ()
 526   (sgml-skip-ps)
 527   (cond ((sgml-is-delim GRPO)
 528          (sgml-check-content-model))
 529         (t
 530          ;; ANY, CDATA, RCDATA or EMPTY
 531          (let ((dc (intern (sgml-check-case (sgml-check-name)))))
 532            (cond ((eq dc 'ANY)
 533                   (setq sgml-used-pcdata t))
 534                  ((eq dc 'CDATA)
 535                   (when sgml-xml-p
 536                     (sgml-error "XML forbids CDATA declared content")))
 537                  ((eq dc 'RCDATA)
 538                   (when sgml-xml-p
 539                     (sgml-error "XML forbids RCDATA declared content")))
 540                  ((eq dc 'EMPTY))
 541                  (t
 542                   (sgml-error "Exptected content model group or one of %s"
 543                               (if sgml-xml-p
 544                                   "ANY or EMPTY"
 545                                   "ANY, CDATA, RCDATA or EMPTY"))))
 546            dc))))
 547
 548 (defun sgml-parse-exception (type)
 549   (sgml-skip-ps)
 550   (if (sgml-parse-char type)
 551       (if sgml-xml-p
 552            (sgml-error "XML forbids inclusion and exclusion exceptions")
 553         (mapcar (function sgml-lookup-eltype)
 554                 (sgml-check-name-group)))))
 555
 556 (defun sgml-before-eltype-modification ()
 557 ;;;  (let ((merged (sgml-dtd-merged sgml-dtd-info)))
 558 ;;;    (when (and merged
 559 ;;;            (eq (sgml-dtd-eltypes sgml-dtd-info)
 560 ;;;                (sgml-dtd-eltypes (cdr merged))))
 561 ;;;      (setf (sgml-dtd-eltypes sgml-dtd-info)
 562 ;;;         (sgml-merge-eltypes (sgml-make-eltypes-table)
 563 ;;;                             (sgml-dtd-eltypes sgml-dtd-info)))))
 564   )
 565
 566 (defun sgml-declare-element ()
 567   (let* ((names (sgml-check-element-type))
 568          (stag-opt (sgml-parse-opt))
 569          (etag-opt (sgml-parse-opt))
 570          (sgml-used-pcdata nil)
 571          (model (sgml-check-content))
 572          (exclusions (sgml-parse-exception ?-))
 573          (inclusions (sgml-parse-exception ?+)))
 574     (sgml-before-eltype-modification)
 575     (while names
 576       (sgml-debug "Defining element %s" (car names))
 577       (let ((et (sgml-lookup-eltype (car names))))
 578         (setf (sgml-eltype-stag-optional et) stag-opt
 579               (sgml-eltype-etag-optional et) etag-opt
 580               (sgml-eltype-model et) model
 581               (sgml-eltype-mixed et) sgml-used-pcdata
 582               (sgml-eltype-excludes et) exclusions
 583               (sgml-eltype-includes et) inclusions))
 584       (setq names (cdr names)))
 585     (sgml-lazy-message "Parsing doctype (%s elements)..."
 586                        (incf sgml-no-elements))))
 587 \f
 588 ;;;; Parse doctype: Entity
 589
 590 (defun sgml-declare-entity ()
 591   (let (name                            ; Name of entity
 592         dest                            ; Entity table
 593         (type 'text)                    ; Type of entity
 594         (notation nil)                  ; Notation of entity
 595         text                            ; Text of entity
 596         extid                           ; External id
 597         )
 598     (cond
 599      ((sgml-parse-delim "PERO")         ; parameter entity declaration
 600       (sgml-skip-ps)
 601       (setq name (sgml-check-name t))
 602       (setq dest (sgml-dtd-parameters sgml-dtd-info)))
 603      (t                                 ; normal entity declaration
 604       (or (sgml-parse-rni "DEFAULT")
 605           (setq name (sgml-check-name t)))
 606       (setq dest (sgml-dtd-entities sgml-dtd-info))))
 607     (sgml-skip-ps)
 608     ;;105  entity text  = 66 parameter literal
 609     ;;                 | 106 data text
 610     ;;                 | 107 bracketed text
 611     ;;                 | 108 external entity specification
 612     (setq extid (sgml-parse-external))
 613     (setq text
 614           (cond
 615            (extid                       ; external entity specification =
 616                                         ; 73 external identifier,
 617                                         ; (65 ps+, 109+ entity type)?
 618             (sgml-skip-ps)
 619             (let ((tn (sgml-parse-entity-type)))
 620               (setq type (or (car tn) 'text))
 621               (unless (eq (cdr tn) "")
 622                 (setq notation (cdr tn))))
 623             extid)
 624            ((sgml-startnm-char-next)
 625             (let ((token (intern (sgml-check-case (sgml-check-name)))))
 626               (sgml-skip-ps)
 627               (when (and sgml-xml-p
 628                          (memq token '(CDATA SDATA PI STARTTAG ENDTAG MS MD)))
 629                 (sgml-error "XML forbids %s entities"
 630                             (upcase (symbol-name token))))
 631               (cond
 632                ((memq token '(CDATA SDATA)) ; data text ***
 633                 (setq type token)
 634                 (sgml-check-parameter-literal))
 635                ((eq token 'PI)
 636                 (concat "<?" (sgml-check-parameter-literal) ">"))
 637                ((eq token 'STARTTAG)
 638                 (sgml-start-tag-of (sgml-check-parameter-literal)))
 639                ((eq token 'ENDTAG)
 640                 (sgml-end-tag-of (sgml-check-parameter-literal)))
 641                ((eq token 'MS)          ; marked section
 642                 (concat "<![" (sgml-check-parameter-literal) "]]>"))
 643                ((eq token 'MD)          ; Markup declaration
 644                 (concat "<!" (sgml-check-parameter-literal) ">")))))
 645            ((sgml-check-parameter-literal))))
 646     (when dest
 647       (sgml-entity-declare name dest type text notation))))
 648
 649
 650 (defun sgml-parse-entity-type ()
 651   ;;109+ entity type      = "SUBDOC"
 652   ;;                      | (("CDATA" | "NDATA" | "SDATA"),
 653   ;;                             65 ps+,
 654   ;;                             41 notation name,
 655   ;;                             149.2+ data attribute specification?)
 656   (let ((type (sgml-parse-name))
 657         (notation nil))
 658     (when type
 659       (setq type (intern (sgml-check-case type)))
 660       (when (and sgml-xml-p (memq type '(SUBDOC CDATA SDATA)))
 661         (sgml-error "XML forbids %s entities"
 662                     (upcase (symbol-name type))))
 663       (cond ((eq type 'SUBDOC))
 664             ((memq type '(CDATA NDATA SDATA))
 665              (sgml-skip-ps)
 666              (setq notation (sgml-parse-name))
 667              ;;149.2+ data attribute specification
 668              ;;                      = 65 ps+, DSO,
 669              ;;                        31 attribute specification list,
 670              ;;                        5 s*, DSC
 671              (sgml-skip-ps)
 672              (when (sgml-parse-delim DSO)
 673                (sgml-parse-attribute-specification-list)
 674                (sgml-parse-s)
 675                (sgml-check-delim DSC)))
 676             (t (sgml-error "Illegal entity type: %s" type))))
 677     (cons type notation)))
 678
 679 \f
 680 ;;;; Parse doctype: Attlist
 681
 682 (defun sgml-declare-attlist ()
 683   (let* ((assnot (cond ((sgml-parse-rni "NOTATION")
 684                         (when sgml-xml-p
 685                           (sgml-error "XML forbids data attribute declarations"))
 686                         (sgml-skip-ps)
 687                         t)))
 688          (assel (sgml-check-name-group))
 689          (attlist nil)
 690          (attdef nil))
 691     (when (and sgml-xml-p (> (length assel) 1))
 692       (sgml-error "XML forbids name groups for an associated element type"))
 693     (while (setq attdef (sgml-parse-attribute-definition))
 694       (push attdef attlist))
 695     (setq attlist (nreverse attlist))
 696     (unless assnot
 697       (sgml-before-eltype-modification)
 698       (loop for elname in assel do
 699             (setf (sgml-eltype-attlist (sgml-lookup-eltype elname))
 700                   (sgml-merge-attlists
 701                    (sgml-eltype-attlist
 702                     (sgml-lookup-eltype elname))
 703                    attlist))))))
 704
 705 (defun sgml-merge-attlists (old new)
 706   (setq old (nreverse (copy-sequence old)))
 707   (loop for att in new do
 708         (unless (assoc (car att) old)
 709           (setq old (cons att old))))
 710   (nreverse old))
 711
 712 (defun sgml-parse-attribute-definition ()
 713   (sgml-skip-ps)
 714   (if (sgml-is-delim "MDC") ; End of attlist?
 715       nil
 716     (sgml-make-attdecl (sgml-check-name)
 717                        (sgml-check-declared-value)
 718                        (sgml-check-default-value))))
 719
 720 (defun sgml-check-declared-value ()
 721   (sgml-skip-ps)
 722   (let ((type 'name-token-group)
 723         (names nil))
 724     (unless (eq (following-char) ?\()
 725       (setq type (intern (sgml-check-case (sgml-check-name))))
 726       (sgml-validate-declared-value type)
 727       (sgml-skip-ps))
 728     (when (memq type '(name-token-group NOTATION))
 729       (setq names (sgml-check-nametoken-group)))
 730     (sgml-make-declared-value type names)))
 731
 732 (defun sgml-validate-declared-value (type)
 733   (unless (memq type
 734                 '(CDATA
 735                   ENTITY
 736                   ENTITIES
 737                   ID
 738                   IDREF
 739                   IDREFS
 740                   NAME
 741                   NAMES
 742                   NMTOKEN
 743                   NMTOKENS
 744                   NOTATION
 745                   NUMBER
 746                   NUMBERS
 747                   NUTOKEN
 748                   NUTOKENS))
 749     (sgml-error "Invalid attribute declared value: %s" type))
 750   (when (and sgml-xml-p (memq type
 751                               '(NAME NAMES NUMBER NUMBERS NUTOKEN NUTOKENS)))
 752     (sgml-error "XML forbids %s attributes" (upcase (symbol-name type)))))
 753
 754 (defun sgml-check-default-value ()
 755   (sgml-skip-ps)
 756   (let* ((rni (sgml-parse-rni))
 757          (key (if rni (intern (sgml-check-case (sgml-check-name))))))
 758     (if rni (sgml-validate-default-value-rn key))
 759     (sgml-skip-ps)
 760     (sgml-make-default-value
 761      key
 762      (if (or (not rni) (eq key 'FIXED))
 763          (sgml-check-attribute-value-specification)))))
 764
 765 (defun sgml-validate-default-value-rn (rn)
 766   (unless (memq rn '(REQUIRED FIXED CURRENT CONREF IMPLIED))
 767     (sgml-error "Unknown reserved name: %s"
 768                 (upcase (symbol-name rn))))
 769   (when (and sgml-xml-p (memq rn '(CURRENT CONREF)))
 770     (sgml-error "XML forbids #%s attributes"
 771                 (upcase (symbol-name rn)))))
 772
 773
 774 \f
 775 ;;;; Parse doctype: Shortref
 776
 777 ;;;150  short reference mapping declaration = MDO, "SHORTREF",
 778 ;;;                        [[65 ps]]+, [[151 map name]],
 779 ;;;                        ([[65 ps]]+, [[66 parameter literal]],
 780 ;;;                        [[65 ps]]+, [[55 name]])+,
 781 ;;;                        [[65 ps]]*, MDC
 782
 783 (defun sgml-declare-shortref ()
 784   (let ((mapname (sgml-check-name))
 785         mappings literal name)
 786     (while (progn
 787              (sgml-skip-ps)
 788              (setq literal (sgml-parse-parameter-literal 'dofunchar)))
 789       (sgml-skip-ps)
 790       (setq name (sgml-check-name t))
 791       (push (cons literal name) mappings))
 792     (sgml-add-shortref-map
 793      (sgml-dtd-shortmaps sgml-dtd-info)
 794      mapname
 795      (sgml-make-shortmap mappings))))
 796
 797 ;;;152  short reference use declaration = MDO, "USEMAP",
 798 ;;;                        [[65 ps]]+, [[153 map specification]],
 799 ;;;                        ([[65 ps]]+, [[72 associated element type]])?,
 800 ;;;                        [[65 ps]]*, MDC
 801
 802 (defun sgml-do-usemap-element (mapname)
 803   ;; This is called from sgml-do-usemap with the mapname
 804   (sgml-before-eltype-modification)
 805   (loop for e in (sgml-parse-name-group) do
 806         (setf (sgml-eltype-shortmap (sgml-lookup-eltype e sgml-dtd-info))
 807               (if (null mapname)
 808                   'empty
 809                 mapname))))
 810
 811 \f
 812 ;;;; Parse doctype
 813
 814 (defun sgml-check-dtd-subset ()
 815   (let ((sgml-parsing-dtd t)
 816         (eref sgml-current-eref))
 817     (while
 818         (progn
 819           (setq sgml-markup-start (point))
 820           (cond
 821            ((and (eobp) (eq sgml-current-eref eref))
 822             nil)
 823            ((sgml-parse-ds))
 824            ((sgml-parse-markup-declaration 'dtd))
 825            ((sgml-parse-delim "MS-END")))))))
 826
 827 \f
 828 ;;;; Save DTD: compute translation
 829
 830 (defvar sgml-translate-table nil)
 831
 832 (defun sgml-translate-node (node)
 833   (assert (not (numberp node)))
 834   (let ((tp (assq node sgml-translate-table)))
 835     (unless tp
 836       (setq tp (cons node (length sgml-translate-table)))
 837       (nconc sgml-translate-table (list tp)))
 838     (cdr tp)))
 839
 840 (defun sgml-translate-moves (moves)
 841   (while moves
 842     (sgml-translate-node (sgml-move-dest (car moves)))
 843     (setq moves (cdr moves))))
 844
 845 (defun sgml-translate-model (model)
 846   (let* ((sgml-translate-table (list (cons model 0)))
 847          (p sgml-translate-table))
 848     (while p
 849       (cond ((sgml-normal-state-p (caar p))
 850              (sgml-translate-moves (sgml-state-opts (caar p)))
 851              (sgml-translate-moves (sgml-state-reqs (caar p))))
 852             (t
 853              (sgml-translate-node (sgml-and-node-next (caar p)))))
 854       (setq p (cdr p)))
 855     sgml-translate-table))
 856 \f
 857 ;;;; Save DTD: binary coding
 858
 859 (defvar sgml-code-token-numbers nil)
 860 (defvar sgml-code-xlate nil)
 861
 862 (defsubst sgml-code-xlate (node)
 863   ;;(let ((x (cdr (assq node sgml-code-xlate)))) (assert x) x)
 864   (cdr (assq node sgml-code-xlate)))
 865
 866 (defun sgml-code-number (num)
 867   (if (> num sgml-max-single-octet-number)
 868       (insert (+ (lsh (- num sgml-max-single-octet-number) -8)
 869                  sgml-max-single-octet-number 1)
 870               (logand (- num sgml-max-single-octet-number) 255))
 871     (insert num)))
 872
 873 (defun sgml-code-token-number (token)
 874   (let ((bp (assq token sgml-code-token-numbers)))
 875     (unless bp
 876       (setq sgml-code-token-numbers
 877             (nconc sgml-code-token-numbers
 878                    (list (setq bp (cons token
 879                                         (length sgml-code-token-numbers)))))))
 880     (cdr bp)))
 881
 882 (defun sgml-code-token (token)
 883   (sgml-code-number (sgml-code-token-number token)))
 884
 885 (defmacro sgml-code-sequence (loop-c &rest body)
 886   "Produce the binary coding of a counted sequence from a list.
 887 Syntax: (var seq) &body forms
 888 FORMS should produce the binary coding of element in VAR."
 889   (let ((var (car loop-c))
 890         (seq (cadr loop-c)))
 891     (` (let ((seq (, seq)))
 892          (sgml-code-number (length seq))
 893          (loop for (, var) in seq
 894                do (,@ body))))))
 895
 896 (put 'sgml-code-sequence 'lisp-indent-hook 1)
 897 (put 'sgml-code-sequence 'edbug-forms-hook '(sexp &rest form))
 898
 899 (defun sgml-code-sexp (sexp)
 900   (let ((standard-output (current-buffer)))
 901     (prin1 sexp)
 902     (terpri)))
 903
 904 (defun sgml-code-tokens (l)
 905   (sgml-code-sequence (x l)
 906     (sgml-code-token x)))
 907
 908 (defsubst sgml-code-move (m)
 909   (sgml-code-token (sgml-move-token m))
 910   (insert (sgml-code-xlate (sgml-move-dest m))))
 911
 912 (defun sgml-code-model (m)
 913   (let ((sgml-code-xlate (sgml-translate-model m)))
 914     (sgml-code-sequence (s sgml-code-xlate)             ; s is (node . number)
 915       (setq s (car s))                  ; s is node
 916       (cond
 917        ((sgml-normal-state-p s)
 918         (assert (and (< (length (sgml-state-opts s)) 255)
 919                      (< (length (sgml-state-reqs s)) 256)))
 920         (sgml-code-sequence (x (sgml-state-opts s))
 921           (sgml-code-move x))
 922         (sgml-code-sequence (x (sgml-state-reqs s))
 923           (sgml-code-move x)))
 924        (t                               ; s is a &-node
 925         (insert 255)                    ; Tag &-node
 926         (insert (sgml-code-xlate (sgml-and-node-next s)))
 927         (sgml-code-sequence (m (sgml-and-node-dfas s))
 928           (sgml-code-model m)))))))
 929
 930 (defun sgml-code-element (et)
 931   (sgml-code-sexp (sgml-eltype-all-miscdata et))
 932   (cond
 933    ((not (sgml-eltype-defined et))
 934     (insert 128))
 935    (t
 936     (insert (sgml-eltype-flags et))
 937     (let ((c (sgml-eltype-model et)))
 938       (cond ((eq c sgml-cdata) (insert 0))
 939             ((eq c sgml-rcdata) (insert 1))
 940             ((eq c sgml-empty) (insert 2))
 941             ((eq c sgml-any) (insert 3))
 942             ((null c) (insert 4))
 943             (t
 944              (assert (sgml-model-group-p c))
 945              (insert 128)
 946              (sgml-code-model c))))
 947     (sgml-code-tokens (sgml-eltype-includes et))
 948     (sgml-code-tokens (sgml-eltype-excludes et)))))
 949
 950
 951 (defun sgml-code-dtd (dtd)
 952   "Produce the binary coding of the current DTD into the current buffer."
 953   (sgml-code-sexp (sgml-dtd-dependencies dtd))
 954   (sgml-code-sexp (sgml-dtd-parameters dtd))
 955   (sgml-code-sexp (sgml-dtd-doctype dtd))
 956   (let ((done 0)                        ; count written elements
 957         tot)
 958     (setq sgml-code-token-numbers nil)
 959     (sgml-code-token-number sgml-pcdata-token) ; Make #PCDATA token 0
 960     (sgml-map-eltypes                   ; Assign numbers to all tokens
 961      (function (lambda (et)
 962                  (sgml-code-token-number (sgml-eltype-token et))))
 963      dtd nil t)
 964     (setq tot (length sgml-code-token-numbers))
 965     ;; Produce the counted sequence of element type names
 966     (sgml-code-sequence (pair (cdr sgml-code-token-numbers))
 967       (sgml-code-sexp (sgml-eltype-name (car pair))))
 968     ;; Produce the counted sequence of element types
 969     (sgml-code-sequence (pair (cdr sgml-code-token-numbers))
 970       (setq done (1+ done))
 971       (sgml-code-element (car pair))
 972       (sgml-lazy-message "Saving DTD %d%% done" (/ (* 100 done) tot)))
 973     (sgml-code-sexp (sgml-dtd-entities dtd))
 974     (sgml-code-sexp (sgml-dtd-shortmaps dtd))
 975     (sgml-code-sexp (sgml-dtd-notations dtd))))
 976
 977 \f
 978 ;;;; Save DTD
 979
 980 (defun sgml-save-dtd (file)
 981   "Save the parsed dtd on FILE."
 982   (interactive
 983    (let* ((tem (expand-file-name
 984                 (or sgml-default-dtd-file
 985                     (sgml-default-dtd-file))))
 986           (dir (file-name-directory tem))
 987           (nam (file-name-nondirectory tem)))
 988      (list
 989       (read-file-name "Save DTD in: " dir tem nil nam))))
 990   (setq file (expand-file-name file))
 991   (when (equal file (buffer-file-name))
 992     (error "Would clobber current file"))
 993   (sgml-need-dtd)
 994   (sgml-push-to-entity (sgml-make-entity "#SAVE" nil ""))
 995   (sgml-write-dtd sgml-dtd-info file)
 996   (sgml-pop-entity)
 997   (setq sgml-default-dtd-file
 998         (if (equal (expand-file-name default-directory)
 999                    (file-name-directory file))
1000             (file-name-nondirectory file)
1001           file))
1002   (setq sgml-loaded-dtd file))
1003
1004 (defun sgml-write-dtd (dtd file)
1005   "Save the parsed DTD in FILE.
1006 Construct the binary coded DTD (bdtd) in the current buffer."
1007   (sgml-set-buffer-multibyte nil)
1008   (insert
1009    ";;; This file was created by psgml on " (current-time-string)
1010    " -*-coding:binary-*-\n"
1011    "(sgml-saved-dtd-version 7)\n")
1012   (let ((print-escape-multibyte t))
1013     (sgml-code-dtd dtd))
1014   (set 'file-type 1)
1015   (let ((coding-system-for-write 'no-conversion))
1016     (write-region (point-min) (point-max) file)))
1017
1018 \f
1019 ;;; psgml-dtd.el ends here