|
0
|
1 ;;;; psgml-parse.el --- Parser for SGML-editing mode with parsing support
|
|
78
|
2 ;; $Id: psgml-parse.el,v 1.2 1997/01/03 03:10:27 steve Exp $
|
|
0
|
3
|
|
|
4 ;; Copyright (C) 1994, 1995 Lennart Staflin
|
|
|
5
|
|
|
6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
|
|
|
7 ;; Acknowledgment:
|
|
|
8 ;; The catalog parsing code was contributed by
|
|
|
9 ;; David Megginson <dmeggins@aix1.uottawa.CA>
|
|
|
10
|
|
|
11 ;; This program is free software; you can redistribute it and/or
|
|
|
12 ;; modify it under the terms of the GNU General Public License
|
|
|
13 ;; as published by the Free Software Foundation; either version 2
|
|
|
14 ;; of the License, or (at your option) any later version.
|
|
|
15 ;;
|
|
|
16 ;; This program is distributed in the hope that it will be useful,
|
|
|
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
19 ;; GNU General Public License for more details.
|
|
|
20 ;;
|
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
|
22 ;; along with this program; if not, write to the Free Software
|
|
|
23 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
24
|
|
|
25
|
|
|
26 ;;;; Commentary:
|
|
|
27
|
|
|
28 ;; Part of major mode for editing the SGML document-markup language.
|
|
|
29
|
|
|
30
|
|
|
31 ;;;; Code:
|
|
|
32
|
|
|
33 (require 'psgml)
|
|
|
34
|
|
|
35 ;;; Interface to psgml-dtd
|
|
|
36 (eval-and-compile
|
|
|
37 (autoload 'sgml-do-usemap-element "psgml-dtd")
|
|
|
38 (autoload 'sgml-write-dtd "psgml-dtd")
|
|
|
39 (autoload 'sgml-check-dtd-subset "psgml-dtd")
|
|
|
40 )
|
|
|
41
|
|
|
42
|
|
|
43 ;;;; Advise to do-auto-fill
|
|
|
44
|
|
|
45 (defvar sgml-auto-fill-inhibit-function nil
|
|
|
46 "If non-nil, it should be a function of no arguments.
|
|
|
47 The functions is evaluated before the standard auto-fill function,
|
|
|
48 do-auto-fill, tries to fill a line. If the function returns a true
|
|
|
49 value the auto-fill is inhibited.")
|
|
|
50
|
|
|
51 ;;(defadvice do-auto-fill (around disable-auto-fill-hook activate)
|
|
|
52 ;; (or (and sgml-auto-fill-inhibit-function
|
|
|
53 ;; (funcall sgml-auto-fill-inhibit-function))
|
|
|
54 ;; ad-do-it))
|
|
|
55
|
|
|
56
|
|
|
57 ;;;; Variables
|
|
|
58
|
|
|
59 ;;; Hooks
|
|
|
60
|
|
|
61 (defvar sgml-open-element-hook nil
|
|
|
62 "The hook run by `sgml-open-element'.
|
|
|
63 Theses functions are called with two arguments, the first argument is
|
|
|
64 the opened element and the second argument is the attribute specification
|
|
|
65 list. It is probably best not to refer to the content or the end-tag of
|
|
|
66 the element.")
|
|
|
67
|
|
|
68 (defvar sgml-close-element-hook nil
|
|
|
69 "The hook run by `sgml-close-element'.
|
|
|
70 These functions are invoked with `sgml-current-tree' bound to the
|
|
|
71 element just parsed.")
|
|
|
72
|
|
|
73 (defvar sgml-doctype-parsed-hook nil
|
|
|
74 "This hook is caled after the doctype has been parsed.
|
|
|
75 It can be used to load any additional information into the DTD structure.")
|
|
|
76
|
|
|
77 (defvar sgml-sysid-resolve-functions nil
|
|
|
78 "This variable should contain a list of functions.
|
|
|
79 Each function should take one argument, the system identifier of an entity.
|
|
|
80 If the function can handle that identifier, it should insert the text
|
|
|
81 of the entity into the current buffer at point and return t. If the
|
|
|
82 system identifier is not handled the function should return nil.")
|
|
|
83
|
|
|
84 ;;; Internal variables
|
|
|
85
|
|
|
86 (defconst sgml-pcdata-token (intern "#PCDATA"))
|
|
|
87
|
|
|
88 (defvar sgml-computed-map nil
|
|
|
89 "Internal representation of entity search map.")
|
|
|
90
|
|
|
91 (defvar sgml-used-entity-map nil
|
|
|
92 "The value of `sgml-current-entity-map' used to compute the map in
|
|
|
93 `sgml-compute-map'.")
|
|
|
94
|
|
|
95 (defvar sgml-last-element nil
|
|
|
96 "Used to keep information about position in element structure between
|
|
|
97 commands.")
|
|
|
98
|
|
|
99 (defconst sgml-users-of-last-element
|
|
|
100 '(sgml-beginning-of-element
|
|
|
101 sgml-end-of-element
|
|
|
102 sgml-up-element
|
|
|
103 sgml-backward-up-element
|
|
|
104 sgml-backward-element
|
|
|
105 sgml-forward-element
|
|
|
106 sgml-down-element
|
|
|
107 sgml-show-context
|
|
|
108 sgml-next-data-field
|
|
|
109 )
|
|
|
110 "List of commands that set the sgml-last-element variable.")
|
|
|
111
|
|
|
112 (defvar sgml-parser-syntax nil
|
|
|
113 "Syntax table used during parsing.")
|
|
|
114
|
|
|
115 (defvar sgml-ecat-assoc nil
|
|
|
116 "Assoc list caching parsed ecats.")
|
|
|
117
|
|
|
118 (defvar sgml-catalog-assoc nil
|
|
|
119 "Assoc list caching parsed catalogs.")
|
|
|
120
|
|
|
121
|
|
|
122 ;;; Variables dynamically bound to affect parsing
|
|
|
123
|
|
|
124 (defvar sgml-throw-on-warning nil
|
|
|
125 "Set to a symbol other than nil to make sgml-log-warning throw to that symbol.")
|
|
|
126
|
|
|
127 (defvar sgml-throw-on-error nil
|
|
|
128 "Set to a symbol other than nil to make sgml-error throw to that symbol.")
|
|
|
129
|
|
|
130 (defvar sgml-show-warnings nil
|
|
|
131 "Set to t to show warnings.")
|
|
|
132
|
|
|
133 (defvar sgml-close-element-trap nil
|
|
|
134 "Can be nil for no trap, an element or t for any element.
|
|
|
135 Tested by sgml-close-element to see if the parse should be ended.")
|
|
|
136
|
|
|
137 (defvar sgml-goal 0
|
|
|
138 "Point in buffer to parse up to.")
|
|
|
139
|
|
|
140 (defvar sgml-shortref-handler (function sgml-handle-shortref)
|
|
|
141 "Function called by parser to handle a short reference.
|
|
|
142 Called with the entity as argument. The start and end of the
|
|
|
143 short reference is `sgml-markup-start' and point.")
|
|
|
144
|
|
|
145 (defvar sgml-data-function nil
|
|
|
146 "Function called with parsed data.")
|
|
|
147
|
|
|
148 (defvar sgml-entity-function nil
|
|
|
149 "Function called with entity referenced at current point in parse.")
|
|
|
150
|
|
|
151 (defvar sgml-pi-function nil
|
|
|
152 "Function called with parsed process instruction.")
|
|
|
153
|
|
|
154 (defvar sgml-signal-data-function nil
|
|
|
155 "Called when some data characters are conceptually parsed,
|
|
|
156 e.g. a data entity reference.")
|
|
|
157
|
|
|
158 (defvar sgml-throw-on-element-change nil
|
|
|
159 "Throw tag.")
|
|
|
160
|
|
|
161 ;;; Global variables active during parsing
|
|
|
162
|
|
|
163 (defvar sgml-parsing-dtd nil
|
|
|
164 "This variable is bound to `t' while parsing a DTD (subset).")
|
|
|
165
|
|
|
166 (defvar sgml-rs-ignore-pos nil
|
|
|
167 "Set to position of last parsing start in current buffer.")
|
|
|
168 (make-variable-buffer-local 'sgml-rs-ignore-pos)
|
|
|
169
|
|
|
170 (defvar sgml-dtd-info nil
|
|
|
171 "Holds the `sgml-dtd' structure describing the current DTD.")
|
|
|
172
|
|
|
173 (defvar sgml-current-omittag nil
|
|
|
174 "Value of `sgml-omittag' in main buffer. Valid during parsing.")
|
|
|
175
|
|
|
176 (defvar sgml-current-shorttag nil
|
|
|
177 "Value of `sgml-shorttag' in main buffer. Valid during parsing.")
|
|
|
178
|
|
|
179 (defvar sgml-current-localcat nil
|
|
|
180 "Value of `sgml-local-catalogs' in main buffer. Valid during parsing.")
|
|
|
181
|
|
|
182 (defvar sgml-current-local-ecat nil
|
|
|
183 "Value of `sgml-local-ecat-files' in main buffer. Valid during parsing.")
|
|
|
184
|
|
2
|
185 (defvar sgml-current-top-buffer nil
|
|
|
186 "The buffer of the document entity, the main buffer.
|
|
|
187 Valid during parsing. This is used to find current directory for
|
|
|
188 catalogs.")
|
|
|
189
|
|
0
|
190 (defvar sgml-current-state nil
|
|
|
191 "Current state in content model or model type if CDATA, RCDATA or ANY.")
|
|
|
192
|
|
|
193 (defvar sgml-current-shortmap nil
|
|
|
194 "The current active short reference map.")
|
|
|
195
|
|
|
196 (defvar sgml-current-tree nil
|
|
|
197 "Current parse tree node, identifies open element.")
|
|
|
198
|
|
|
199 (defvar sgml-previous-tree nil
|
|
|
200 "Previous tree node in current tree.
|
|
|
201 This is nil if no previous node.")
|
|
|
202
|
|
|
203 (defvar sgml-markup-type nil
|
|
|
204 "Contains the type of markup parsed last.
|
|
|
205 The value is a symbol:
|
|
|
206 nil - pcdata or space
|
|
|
207 CDATA - CDATA or RCDATA
|
|
|
208 comment - comment declaration
|
|
|
209 doctype - doctype declaration
|
|
|
210 end-tag
|
|
|
211 ignored - ignored marked section
|
|
|
212 ms-end - marked section start, if not ignored
|
|
|
213 ms-start - marked section end, if not ignored
|
|
|
214 pi - processing instruction
|
|
|
215 sgml - SGML declaration
|
|
|
216 start-tag
|
|
|
217 entity - general entity reference
|
|
|
218 param - parameter reference
|
|
|
219 shortref- short reference
|
|
|
220 mdecl - markup declaration
|
|
|
221 ")
|
|
|
222
|
|
|
223 (defvar sgml-top-tree nil
|
|
|
224 "Root node of parse tree during parsing.")
|
|
|
225
|
|
|
226 (defvar sgml-markup-tree nil
|
|
|
227 "Tree node of markup parsed.
|
|
|
228 In case markup closed element this is different from sgml-current-tree.
|
|
|
229 Only valid after `sgml-parse-to'.")
|
|
|
230
|
|
|
231 (defvar sgml-markup-start nil
|
|
70
|
232 "Start point of markup beeing parsed.")
|
|
0
|
233
|
|
|
234 (defvar sgml-conref-flag nil
|
|
|
235 "This variable is set by `sgml-parse-attribute-specification-list'
|
|
|
236 if a CONREF attribute is parsed.")
|
|
|
237
|
|
|
238 (defvar sgml-no-elements nil
|
|
|
239 "Number of declared elements.")
|
|
|
240
|
|
|
241 ;;; Vars used in *param* buffers
|
|
|
242
|
|
|
243 (defvar sgml-previous-buffer nil)
|
|
|
244
|
|
|
245 (defvar sgml-current-eref nil
|
|
|
246 "This is the entity reference used to enter current entity.
|
|
|
247 If this is nil, then current entity is main buffer.")
|
|
|
248
|
|
|
249 (defvar sgml-scratch-buffer nil
|
|
|
250 "The global value of this variable is the first scratch buffer for
|
|
|
251 entities. The entity buffers can have a buffer local value for this variable
|
|
|
252 to point to the next scratch buffer.")
|
|
|
253
|
|
|
254 (defvar sgml-last-entity-buffer nil)
|
|
|
255
|
|
|
256 ;;; For loading DTD
|
|
|
257
|
|
|
258 (eval-and-compile
|
|
|
259 (defconst sgml-max-single-octet-number 250
|
|
|
260 "Octets greater than this is the first of a two octet coding."))
|
|
|
261
|
|
|
262 (defvar sgml-read-token-vector nil) ; Vector of symbols used to decode
|
|
|
263 ; token numbers.
|
|
|
264 (defvar sgml-read-nodes nil) ; Vector of nodes used when reading
|
|
|
265 ; a finite automaton.
|
|
|
266
|
|
|
267 ;; Buffer local variables
|
|
|
268
|
|
|
269 (defvar sgml-loaded-dtd nil
|
|
|
270 "File name corresponding to current DTD.")
|
|
|
271 (make-variable-buffer-local 'sgml-loaded-dtd)
|
|
|
272
|
|
|
273 (defvar sgml-current-element-name nil
|
|
|
274 "Name of current element for mode line display.")
|
|
|
275
|
|
|
276
|
|
|
277 ;;;; Build parser syntax table
|
|
|
278
|
|
|
279 (setq sgml-parser-syntax (make-syntax-table))
|
|
|
280
|
|
|
281 (let ((i 0))
|
|
|
282 (while (< i 256)
|
|
|
283 (modify-syntax-entry i " " sgml-parser-syntax)
|
|
|
284 (setq i (1+ i))))
|
|
|
285
|
|
|
286 (mapconcat (function (lambda (c)
|
|
|
287 (modify-syntax-entry c "w" sgml-parser-syntax)))
|
|
|
288 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrtsuvwxyz" "")
|
|
|
289 (mapconcat (function (lambda (c)
|
|
|
290 (modify-syntax-entry c "_" sgml-parser-syntax)))
|
|
|
291 "-.0123456789" "")
|
|
|
292 (mapconcat (function (lambda (c)
|
|
|
293 (modify-syntax-entry c "." sgml-parser-syntax)))
|
|
|
294 "</>&%#[]" ".")
|
|
|
295
|
|
|
296 ;;(progn (set-syntax-table sgml-parser-syntax) (describe-syntax))
|
|
|
297
|
|
|
298
|
|
|
299 (defmacro sgml-with-parser-syntax (&rest body)
|
|
|
300 (` (let ((normal-syntax-table (syntax-table)))
|
|
|
301 (set-syntax-table sgml-parser-syntax)
|
|
|
302 (unwind-protect
|
|
|
303 (progn (,@ body))
|
|
|
304 (set-syntax-table normal-syntax-table)))))
|
|
|
305
|
|
|
306
|
|
|
307 ;;;; State machine
|
|
|
308
|
|
|
309 ;; From the parsers POV a state is a mapping from tokens (in sgml it
|
|
|
310 ;; is primitive state tokens) to states. The pairs of the mapping is
|
|
|
311 ;; called moves.
|
|
|
312
|
|
|
313 ;; DFAs are always represented by the start state, which is a
|
|
|
314 ;; normal state. Normal states contain moves of two types:
|
|
|
315 ;; 1. moves for required tokens, 2. moves for optional tokens.
|
|
|
316 ;; By design these are keept in two different sets.
|
|
|
317 ;; [Alt: they could perhaps have been keept in one set but
|
|
|
318 ;; marked in different ways.]
|
|
|
319
|
|
2
|
320 ;; The and-model groups creates too big state machines, therefor
|
|
|
321 ;; there is a datastruture called and-node.
|
|
|
322
|
|
|
323 ;; A and-node is a specification for a dfa that has not been computed.
|
|
0
|
324 ;; It contains a set of dfas that all have to be traversed befor going
|
|
2
|
325 ;; to the next state. The and-nodes are only stored in moves and are
|
|
|
326 ;; not seen by the parser. When a move is taken the and-node is converted
|
|
|
327 ;; to a and-state.
|
|
|
328
|
|
|
329 ;; A and-state keeps track of which dfas still need to be
|
|
0
|
330 ;; traversed and the state of the current dfa.
|
|
|
331
|
|
|
332 ;; move = <token, node>
|
|
|
333
|
|
2
|
334 ;; node = normal-state | and-node
|
|
|
335
|
|
|
336 ;; and-node = <dfas, next>
|
|
0
|
337 ;; where: dfas is a set of normal-state
|
|
|
338 ;; next is a normal-state
|
|
|
339
|
|
2
|
340 ;; State = normal-state | and-state
|
|
0
|
341 ;; The parser only knows about the state type.
|
|
|
342
|
|
|
343 ;; normal-state = <opts, reqs>
|
|
|
344 ;; where: opts is a set of moves for optional tokens
|
|
|
345 ;; reqs is a set of moves for required tokens
|
|
|
346
|
|
2
|
347 ;; and-state = <substate, dfas, next>
|
|
0
|
348 ;; where: substate is a normal-state
|
|
|
349 ;; dfas is a set of states
|
|
|
350 ;; next is the next state
|
|
|
351
|
|
2
|
352 ;; The and-state is only used during the parsing.
|
|
0
|
353 ;; Primitiv functions to get data from parse state need
|
|
2
|
354 ;; to know both normal-state and and-state.
|
|
0
|
355
|
|
|
356
|
|
|
357 ;;; Representations:
|
|
|
358
|
|
|
359 ;;move: (token . node)
|
|
|
360
|
|
|
361 (defmacro sgml-make-move (token node)
|
|
|
362 (` (cons (, token) (, node))))
|
|
|
363
|
|
|
364 (defmacro sgml-move-token (x)
|
|
|
365 (` (car (, x))))
|
|
|
366
|
|
|
367 (defmacro sgml-move-dest (x)
|
|
|
368 (` (cdr (, x))))
|
|
|
369
|
|
|
370 ;; set of moves: list of moves
|
|
|
371
|
|
|
372 (defmacro sgml-add-move-to-set (token node set)
|
|
|
373 (`(cons (cons (, token) (, node)) (, set))))
|
|
|
374
|
|
|
375 (defmacro sgml-moves-lookup (token set)
|
|
|
376 (` (assq (, token) (, set))))
|
|
|
377
|
|
|
378 ;; normal-state: ('normal-state opts . reqs)
|
|
|
379
|
|
|
380 (defsubst sgml-make-state ()
|
|
|
381 (cons 'normal-state (cons nil nil)))
|
|
|
382
|
|
|
383 (defmacro sgml-normal-state-p (s)
|
|
|
384 (` (eq (car (, s)) 'normal-state)))
|
|
|
385
|
|
|
386 (defmacro sgml-state-opts (s)
|
|
|
387 (` (cadr (, s))))
|
|
|
388
|
|
|
389 (defmacro sgml-state-reqs (s)
|
|
|
390 (` (cddr (, s))))
|
|
|
391
|
|
|
392 (defmacro sgml-state-final-p (s)
|
|
|
393 (`(null (sgml-state-reqs (, s)))))
|
|
|
394
|
|
|
395 ;; adding moves
|
|
|
396 ;; *** Should these functions check for ambiguity?
|
|
|
397 ;; What if adding a optional move for a token that has a
|
|
|
398 ;; required move?
|
|
|
399 ;; What about the other way?
|
|
|
400
|
|
|
401 (defsubst sgml-add-opt-move (s token dest)
|
|
|
402 (or (sgml-moves-lookup token (sgml-state-opts s))
|
|
|
403 (setf (sgml-state-opts s)
|
|
|
404 (sgml-add-move-to-set token dest (sgml-state-opts s)))))
|
|
|
405
|
|
|
406 (defsubst sgml-add-req-move (s token dest)
|
|
|
407 (or (sgml-moves-lookup token (sgml-state-reqs s))
|
|
|
408 (setf (sgml-state-reqs s)
|
|
|
409 (sgml-add-move-to-set token dest (sgml-state-reqs s)))))
|
|
|
410
|
|
|
411 (defsubst sgml-make-primitive-content-token (token)
|
|
|
412 (let ((s1 (sgml-make-state))
|
|
|
413 (s2 (sgml-make-state)))
|
|
|
414 (sgml-add-req-move s1 token s2)
|
|
|
415 s1))
|
|
|
416
|
|
2
|
417 ;;and-state: (state next . dfas)
|
|
|
418
|
|
|
419 (defsubst sgml-make-and-state (state dfas next)
|
|
0
|
420 (cons state (cons next dfas)))
|
|
|
421
|
|
2
|
422 (defsubst sgml-step-and-state (state and-state)
|
|
|
423 (cons state (cdr and-state)))
|
|
|
424
|
|
|
425 (defsubst sgml-and-state-substate (s)
|
|
0
|
426 (car s))
|
|
|
427
|
|
2
|
428 (defsubst sgml-and-state-dfas (s)
|
|
0
|
429 (cddr s))
|
|
|
430
|
|
2
|
431 (defsubst sgml-and-state-next (s)
|
|
0
|
432 (cadr s))
|
|
|
433
|
|
|
434
|
|
2
|
435 ;;and-node: (next . dfas)
|
|
|
436
|
|
|
437 (defsubst sgml-make-and-node (dfas next)
|
|
0
|
438 (cons next dfas))
|
|
|
439
|
|
2
|
440 (defmacro sgml-and-node-next (n)
|
|
0
|
441 (` (car (, n))))
|
|
|
442
|
|
2
|
443 (defmacro sgml-and-node-dfas (n)
|
|
0
|
444 (` (cdr (, n))))
|
|
|
445
|
|
|
446
|
|
|
447 ;;; Using states
|
|
|
448
|
|
78
|
449 (defsubst sgml-final (state)
|
|
|
450 (if (sgml-normal-state-p state)
|
|
|
451 (sgml-state-final-p state)
|
|
|
452 (sgml-final-and state)))
|
|
|
453
|
|
|
454 (defun sgml-final-and (state)
|
|
|
455 (and (sgml-final (sgml-and-state-substate state))
|
|
|
456 (loop for s in (sgml-and-state-dfas state)
|
|
|
457 always (sgml-state-final-p s))
|
|
|
458 (sgml-state-final-p (sgml-and-state-next state))))
|
|
|
459
|
|
0
|
460 ;; get-move: State x Token --> State|nil
|
|
|
461
|
|
|
462 (defsubst sgml-get-move (state token)
|
|
|
463 "Return a new state or nil, after traversing TOKEN from STATE."
|
|
|
464 (cond
|
|
|
465 ((sgml-normal-state-p state)
|
|
|
466 (let ((c (or (sgml-moves-lookup token (sgml-state-opts state))
|
|
|
467 (sgml-moves-lookup token (sgml-state-reqs state)))))
|
|
|
468 (if c
|
|
|
469 (let ((dest (sgml-move-dest c)))
|
|
|
470 (if (sgml-normal-state-p dest)
|
|
|
471 dest
|
|
2
|
472 ;; dest is a and-node
|
|
|
473 (sgml-next-sub-and (sgml-and-node-dfas dest)
|
|
|
474 token
|
|
|
475 (sgml-and-node-next dest)))))))
|
|
|
476 (t ;state is a and-state
|
|
|
477 (sgml-get-and-move state token))))
|
|
|
478
|
|
|
479 (defun sgml-get-and-move (state token)
|
|
|
480 ;; state is a and-state
|
|
|
481 (let ((m (sgml-get-move (sgml-and-state-substate state) token)))
|
|
|
482 (cond (m (cons m (cdr state)))
|
|
|
483 ((sgml-final (sgml-and-state-substate state))
|
|
|
484 (sgml-next-sub-and (sgml-and-state-dfas state)
|
|
0
|
485 token
|
|
2
|
486 (sgml-and-state-next state))))))
|
|
|
487
|
|
|
488 (defun sgml-next-sub-and (dfas token next)
|
|
0
|
489 "Compute the next state, choosing from DFAS and moving by TOKEN.
|
|
|
490 If this is not possible, but all DFAS are final, move by TOKEN in NEXT."
|
|
|
491 (let ((allfinal t)
|
|
|
492 (l dfas)
|
|
|
493 (res nil)
|
|
|
494 s1 s2)
|
|
|
495 (while (and l (not res))
|
|
|
496 (setq s1 (car l)
|
|
|
497 allfinal (and allfinal (sgml-state-final-p s1))
|
|
|
498 s2 (sgml-get-move s1 token)
|
|
2
|
499 res (and s2 (sgml-make-and-state s2 (remq s1 dfas) next))
|
|
0
|
500 l (cdr l)))
|
|
|
501 (cond (res)
|
|
|
502 (allfinal (sgml-get-move next token)))))
|
|
|
503
|
|
|
504 (defsubst sgml-tokens-of-moves (moves)
|
|
|
505 (mapcar (function (lambda (m) (sgml-move-token m)))
|
|
|
506 moves))
|
|
|
507
|
|
|
508 (defun sgml-required-tokens (state)
|
|
|
509 (if (sgml-normal-state-p state)
|
|
|
510 (sgml-tokens-of-moves (sgml-state-reqs state))
|
|
2
|
511 (or (sgml-required-tokens (sgml-and-state-substate state))
|
|
|
512 (loop for s in (sgml-and-state-dfas state)
|
|
0
|
513 nconc (sgml-tokens-of-moves (sgml-state-reqs s)))
|
|
2
|
514 (sgml-tokens-of-moves (sgml-state-reqs (sgml-and-state-next state))))))
|
|
0
|
515
|
|
|
516 (defun sgml-optional-tokens (state)
|
|
|
517 (if (sgml-normal-state-p state)
|
|
|
518 (sgml-tokens-of-moves (sgml-state-opts state))
|
|
|
519 (nconc
|
|
2
|
520 (sgml-optional-tokens (sgml-and-state-substate state))
|
|
|
521 (if (sgml-final (sgml-and-state-substate state))
|
|
|
522 (loop for s in (sgml-and-state-dfas state)
|
|
0
|
523 nconc (sgml-tokens-of-moves (sgml-state-opts s))))
|
|
2
|
524 (if (loop for s in (sgml-and-state-dfas state)
|
|
0
|
525 always (sgml-state-final-p s))
|
|
2
|
526 (sgml-tokens-of-moves
|
|
|
527 (sgml-state-opts (sgml-and-state-next state)))))))
|
|
0
|
528
|
|
|
529
|
|
|
530 ;;;; Attribute Types
|
|
|
531
|
|
|
532 ;;; Basic Types
|
|
|
533 ;; name = string attribute names are lisp symbols
|
|
|
534 ;; attval = string attribute values are lisp strings
|
|
|
535
|
|
|
536 ;;; Attribute Declaration Type
|
|
|
537 ;; attdecl = <name, declared-value, default-value>
|
|
|
538
|
|
|
539 ;; This is the result of the ATTLIST declarations in the DTD.
|
|
|
540 ;; All attribute declarations for an element is the elements
|
|
|
541 ;; attlist.
|
|
|
542
|
|
|
543 ;;; Attribute Declaration Operations
|
|
|
544 ;; sgml-make-attdecl: name declared-value default-value -> attdecl
|
|
|
545 ;; sgml-attdecl-name: attdecl -> name
|
|
|
546 ;; sgml-attdecl-declared-value: attdecl -> declared-value
|
|
|
547 ;; sgml-attdecl-default-value: attdecl -> default-value
|
|
|
548
|
|
|
549 ;;; Attribute Declaration List Type
|
|
|
550 ;; attlist = attdecl*
|
|
|
551
|
|
|
552 ;;; Attribute Declaration List Operations
|
|
|
553 ;; sgml-lookup-attdecl: name x attlist -> attdecl
|
|
|
554
|
|
|
555 ;;; Declared Value Type
|
|
|
556 ;; declared-value = (token-group | notation | simpel)
|
|
|
557 ;; token-group = nametoken+
|
|
|
558 ;; notation = nametoken+
|
|
|
559 ;; simple = symbol lisp symbol corresponding to SGML type
|
|
|
560
|
|
|
561 ;;; Declared Value Operations
|
|
|
562 ;; sgml-declared-value-token-group: declared-value -> list of symbols
|
|
|
563 ;; sgml-declared-value-notation: declared-value -> list of symbols
|
|
|
564 ;; (empty list if not token-group/notation)
|
|
|
565
|
|
|
566 ;;; Default Value Type
|
|
|
567 ;; default-value = (required | implied | conref | specified )
|
|
|
568 ;; implied, conref = constant symbol
|
|
|
569 ;; specified = (fixed | normal)
|
|
|
570 ;; fixed, normal = attval
|
|
|
571
|
|
|
572 ;;; Default Value Operations
|
|
|
573 ;; sgml-default-value-attval: default-value -> (attval | nil)
|
|
|
574 ;; sgml-default-value-type-p: type x default-value -> cond
|
|
|
575
|
|
|
576 ;;; Attribute Specification Type
|
|
|
577 ;; attspec = <name, attval>
|
|
|
578
|
|
|
579 ;; This is the result of parsing an attribute specification.
|
|
|
580
|
|
|
581 ;; sgml-make-attspec: name x attval -> attspec
|
|
|
582 ;; sgml-attspec-name: attspec -> name
|
|
|
583 ;; sgml-attspec-attval: attspec -> attval
|
|
|
584
|
|
|
585
|
|
|
586 ;;; Attribute Specification List Type
|
|
|
587 ;; asl = attspec*
|
|
|
588
|
|
|
589 ;; aka. attribute value list
|
|
|
590
|
|
|
591
|
|
|
592 ;;; Code
|
|
|
593
|
|
|
594 ;;; attdecl representation = (name declared-value default-value)
|
|
|
595
|
|
|
596 (defun sgml-make-attdecl (name dcl-value default-value)
|
|
|
597 (list name dcl-value default-value))
|
|
|
598
|
|
|
599 (defun sgml-attdecl-name (attdecl)
|
|
|
600 (car attdecl))
|
|
|
601
|
|
|
602 (defun sgml-attdecl-declared-value (attdecl)
|
|
|
603 "The declared value of ATTDECL.
|
|
|
604 It may be a symbol or (name-token-group (NAME1 ... NAMEn))
|
|
|
605 or (notation (NOT1 ... NOTn))"
|
|
|
606 (cadr attdecl))
|
|
|
607
|
|
|
608 (defun sgml-attdecl-default-value (attdecl)
|
|
|
609 "The default value of ATTDECL.
|
|
|
610 The default value is either a symbol (required | implied | current |
|
|
|
611 conref) or a list with first element nil or symbol 'fixed' and second
|
|
|
612 element the value."
|
|
|
613 (caddr attdecl))
|
|
|
614
|
|
|
615
|
|
|
616 ;;; attlist representation = (attspec*)
|
|
|
617
|
|
|
618 (defun sgml-lookup-attdecl (name attlist)
|
|
|
619 "Return the attribute declaration for NAME in ATTLIST."
|
|
|
620 (assoc name attlist))
|
|
|
621
|
|
|
622 (defun sgml-attribute-with-declared-value (attlist declared-value)
|
|
|
623 "Find the first attribute in ATTLIST that has DECLARED-VALUE."
|
|
|
624 (let ((found nil))
|
|
|
625 (while (and attlist (not found))
|
|
|
626 (when (equal declared-value
|
|
|
627 (sgml-attdecl-declared-value (car attlist)))
|
|
|
628 (setq found (car attlist)))
|
|
|
629 (setq attlist (cdr attlist)))
|
|
|
630 found))
|
|
|
631
|
|
|
632
|
|
|
633 ;;; declared-value representation
|
|
|
634 ;; token-group = (name-token (symbol+))
|
|
|
635 ;; notation = (notation (symbol+))
|
|
|
636 ;; simple = symbol lisp symbol correspoinding to SGML type
|
|
|
637
|
|
|
638 (defun sgml-make-declared-value (type &optional names)
|
|
|
639 "Make a declared-value of TYPE.
|
|
|
640 TYPE should be a symbol. If TYPE is name-token-group or notation
|
|
|
641 NAMES should be a list of symbols."
|
|
|
642 (if (consp names)
|
|
|
643 (list type names)
|
|
|
644 type))
|
|
|
645
|
|
|
646 (defun sgml-declared-value-token-group (declared-value)
|
|
|
647 "Return the name token group for the DECLARED-VALUE.
|
|
|
648 This applies to name token groups. For other declared values nil is
|
|
|
649 returned."
|
|
|
650 (and (consp declared-value)
|
|
|
651 (eq 'name-token-group (car declared-value))
|
|
|
652 (cadr declared-value)))
|
|
|
653
|
|
|
654 (defun sgml-declared-value-notation (declared-value)
|
|
|
655 "Return the list of notation names for the DECLARED-VALUE.
|
|
|
656 This applies to notation declared value. For other declared values
|
|
|
657 nil is returned."
|
|
|
658 (and (consp declared-value)
|
|
|
659 (eq 'notation (car declared-value))
|
|
|
660 (cadr declared-value)))
|
|
|
661
|
|
|
662 ;;; default-value representation = symbol | ((nil | 'fixed) attval)
|
|
|
663
|
|
|
664 (defun sgml-make-default-value (type &optional attval)
|
|
|
665 (if attval
|
|
|
666 (list type attval)
|
|
|
667 type))
|
|
|
668
|
|
|
669 (defun sgml-default-value-attval (default-value)
|
|
|
670 "Return the actual default value of the declared DEFAULT-VALUE.
|
|
|
671 The actual value is a string. Return nil if no actual value."
|
|
|
672 (and (consp default-value)
|
|
|
673 (cadr default-value)))
|
|
|
674
|
|
|
675 (defun sgml-default-value-type-p (type default-value)
|
|
|
676 "Return true if DEFAULT-VALUE is of TYPE.
|
|
|
677 Where TYPE is a symbol, one of required, implied, conref, or fixed."
|
|
|
678 (or (eq type default-value)
|
|
|
679 (and (consp default-value)
|
|
|
680 (eq type (car default-value)))))
|
|
|
681
|
|
|
682
|
|
|
683 ;;; attspec representation = (symbol . string)
|
|
|
684
|
|
|
685 (defun sgml-make-attspec (name attval)
|
|
|
686 "Create an attspec from NAME and ATTVAL.
|
|
|
687 Special case, if ATTVAL is nil this is an implied attribute."
|
|
|
688 (cons name attval))
|
|
|
689
|
|
|
690 ;; sgml-attspec-name: attspec -> name
|
|
|
691 (defun sgml-attspec-name (attspec)
|
|
|
692 (car attspec))
|
|
|
693
|
|
|
694 ;; sgml-attspec-attval: attspec -> attval
|
|
|
695 (defun sgml-attspec-attval (attspec)
|
|
|
696 "Return the value of attribute specification ATTSPEC.
|
|
|
697 If ATTSPEC is nil, nil is returned."
|
|
|
698 (cdr attspec))
|
|
|
699
|
|
|
700 ;;; asl representaion = (attspec*)
|
|
|
701
|
|
|
702 (defun sgml-lookup-attspec (name asl)
|
|
|
703 (assoc name asl))
|
|
|
704
|
|
|
705
|
|
|
706 ;;;; Element content types
|
|
|
707
|
|
|
708 ;; The content of an element is defined as
|
|
|
709 ;; (125 declared content | 126 content model),
|
|
|
710 ;; 125 declared content = "CDATA" | "RCDATA" | "EMPTY"
|
|
|
711 ;; 126 content model = (127 model group | "ANY"),
|
|
|
712 ;; (65 ps+, 138 exceptions)?
|
|
|
713
|
|
|
714 ;; I represent a model group with the first state of a corresponding finite
|
|
|
715 ;; automaton (this is a cons). Exceptions are handled separately.
|
|
|
716 ;; The other content types are represented by symbols.
|
|
|
717
|
|
|
718 (defsubst sgml-model-group-p (model)
|
|
|
719 (consp model))
|
|
|
720
|
|
|
721 (defconst sgml-cdata 'CDATA)
|
|
|
722 (defconst sgml-rcdata 'RCDATA)
|
|
|
723 (defconst sgml-empty 'EMPTY)
|
|
|
724 (defconst sgml-any 'ANY)
|
|
|
725
|
|
|
726
|
|
|
727 ;;;; External identifier
|
|
|
728 ;; extid = (pubid? sysid? dir)
|
|
|
729 ;; Representation as (pubid sysid . dir)
|
|
|
730 ;; where pubid = nil | string
|
|
|
731 ;; sysid = nil | string
|
|
|
732 ;; dir = string
|
|
|
733
|
|
|
734 (defun sgml-make-extid (pubid sysid &optional dir)
|
|
|
735 (cons pubid (cons sysid (or dir default-directory))))
|
|
|
736
|
|
|
737 (defun sgml-extid-pubid (extid)
|
|
|
738 (car extid))
|
|
|
739
|
|
|
740 (defun sgml-extid-sysid (extid)
|
|
|
741 (if (consp (cdr extid))
|
|
|
742 (cadr extid)
|
|
|
743 (cdr extid)))
|
|
|
744
|
|
|
745 (defun sgml-extid-dir (extid)
|
|
|
746 "Directory where EXTID was declared"
|
|
|
747 (if (consp (cdr extid))
|
|
|
748 (cddr extid)
|
|
|
749 nil))
|
|
|
750
|
|
|
751 (defun sgml-extid-expand (file extid)
|
|
|
752 "Expand file name FILE in the context of EXTID."
|
|
|
753 (expand-file-name file (sgml-extid-dir extid)))
|
|
|
754
|
|
|
755 ;;;; DTD
|
|
|
756
|
|
|
757 ;; DTD = (doctype, eltypes, parameters, entities, shortmaps,
|
|
|
758 ;; notations, dependencies, merged)
|
|
|
759 ;; DTDsubset ~=~ DTD, but doctype is unused
|
|
|
760 ;;
|
|
|
761 ;; doctype = name
|
|
|
762 ;; eltypes = oblist
|
|
|
763 ;; parameters = entity*
|
|
|
764 ;; entities = entity*
|
|
|
765 ;; shortmaps = (name, shortmap)*
|
|
|
766 ;; dependencies = file*
|
|
|
767 ;; merged = Compiled-DTD? where Compiled-DTD = (file, DTD)
|
|
|
768
|
|
|
769 (defstruct (sgml-dtd
|
|
|
770 (:type vector)
|
|
|
771 (:constructor sgml-make-dtd (doctype)))
|
|
|
772 doctype ; STRING, name of doctype
|
|
|
773 (eltypes ; OBLIST, element types defined
|
|
|
774 (sgml-make-eltype-table))
|
|
|
775 (parameters ; ALIST
|
|
|
776 (sgml-make-entity-table))
|
|
|
777 (entities ; ALIST
|
|
|
778 (sgml-make-entity-table))
|
|
|
779 (shortmaps ; ALIST
|
|
|
780 (sgml-make-shortref-table))
|
|
|
781 (notations ; ??
|
|
|
782 nil)
|
|
|
783 (dependencies ; LIST
|
|
|
784 nil)
|
|
|
785 (merged ; (file . DTD)
|
|
|
786 nil)
|
|
|
787 (undef-entities ; LIST of entity names
|
|
|
788 nil))
|
|
|
789
|
|
|
790
|
|
|
791 ;;;; Element type objects
|
|
|
792
|
|
|
793 ;; An element type object contains the information about an element type
|
|
|
794 ;; obtained from parsing the DTD.
|
|
|
795
|
|
|
796 ;; An element type object is represented by a symbol in a special oblist.
|
|
|
797 ;; A table of element type objects is represented by a oblist.
|
|
|
798
|
|
|
799
|
|
|
800 ;;; Element type objects
|
|
|
801
|
|
|
802 (defun sgml-eltype-name (et)
|
|
|
803 (symbol-name et))
|
|
|
804
|
|
|
805 (define-compiler-macro sgml-eltype-name (et)
|
|
|
806 (`(symbol-name (, et))))
|
|
|
807
|
|
|
808 (defun sgml-eltype-defined (et)
|
|
|
809 (fboundp et))
|
|
|
810
|
|
|
811 (defun sgml-eltype-token (et)
|
|
|
812 "Return a token for the element type"
|
|
|
813 et)
|
|
|
814
|
|
|
815 (define-compiler-macro sgml-eltype-token (et)
|
|
|
816 et)
|
|
|
817
|
|
|
818 (defun sgml-token-eltype (token)
|
|
|
819 "Return the element type corresponding to TOKEN."
|
|
|
820 token)
|
|
|
821
|
|
|
822 (define-compiler-macro sgml-token-eltype (token)
|
|
|
823 token)
|
|
|
824
|
|
|
825 (defmacro sgml-prop-fields (&rest names)
|
|
|
826 (cons
|
|
|
827 'progn
|
|
|
828 (loop for n in names collect
|
|
|
829 (`(defmacro (, (intern (format "sgml-eltype-%s" n))) (et)
|
|
|
830 (list 'get et ''(, n)))))))
|
|
|
831
|
|
|
832 (sgml-prop-fields
|
|
|
833 ;;flags ; optional tags and mixed
|
|
|
834 ; (perhaps in value field)
|
|
|
835 ;;model ; Content type
|
|
|
836 ; (perhaps in function field)
|
|
|
837 attlist ; List of defined attributes
|
|
|
838 includes ; List of included elements
|
|
|
839 excludes ; List of excluded elements
|
|
|
840 shortmap ; Associated shortref map
|
|
|
841 ; nil if none and 'empty if #empty
|
|
|
842 )
|
|
|
843
|
|
|
844 (defmacro sgml-eltype-flags (et)
|
|
|
845 (` (symbol-value (, et))))
|
|
|
846
|
|
|
847 (defun sgml-eltype-model (et)
|
|
|
848 (if (fboundp et)
|
|
|
849 (symbol-function et)
|
|
|
850 sgml-any))
|
|
|
851
|
|
|
852 (defsetf sgml-eltype-model fset)
|
|
|
853
|
|
|
854
|
|
|
855 (defun sgml-eltype-stag-optional (et)
|
|
|
856 (oddp (sgml-eltype-flags et)))
|
|
|
857
|
|
|
858 (defun sgml-eltype-etag-optional (et)
|
|
|
859 (/= 0 (logand 2 (sgml-eltype-flags et))))
|
|
|
860
|
|
|
861 (defun sgml-eltype-mixed (et)
|
|
|
862 (< 3 (sgml-eltype-flags et)))
|
|
|
863 (define-compiler-macro sgml-eltype-mixed (et)
|
|
|
864 (`(< 3 (sgml-eltype-flags (, et)))))
|
|
|
865
|
|
|
866 (defsetf sgml-eltype-stag-optional (et) (f)
|
|
|
867 (list 'sgml-set-eltype-flag et 1 f))
|
|
|
868 (defsetf sgml-eltype-etag-optional (et) (f)
|
|
|
869 (list 'sgml-set-eltype-flag et 2 f))
|
|
|
870 (defsetf sgml-eltype-mixed (et) (f)
|
|
|
871 (list 'sgml-set-eltype-flag et 4 f))
|
|
|
872
|
|
|
873 (defun sgml-set-eltype-flag (et mask f)
|
|
|
874 (setf (sgml-eltype-flags et)
|
|
|
875 (logior (logand (if (boundp et)
|
|
|
876 (sgml-eltype-flags et)
|
|
|
877 0)
|
|
|
878 (lognot mask))
|
|
|
879 (if f mask 0))))
|
|
|
880
|
|
|
881 (defun sgml-maybe-put (sym prop val)
|
|
|
882 (when val (put sym prop val)))
|
|
|
883
|
|
|
884 (defsetf sgml-eltype-includes (et) (l)
|
|
|
885 (list 'sgml-maybe-put et ''includes l))
|
|
|
886
|
|
|
887 (defsetf sgml-eltype-excludes (et) (l)
|
|
|
888 (list 'sgml-maybe-put et ''excludes l))
|
|
|
889
|
|
|
890 (defmacro sgml-eltype-appdata (et prop)
|
|
|
891 "Get application data from element type ET with name PROP.
|
|
|
892 PROP should be a symbol, reserved names are: flags, model, attlist,
|
|
|
893 includes, excludes, conref-regexp, mixed, stag-optional, etag-optional."
|
|
|
894 (` (get (, et) (, prop))))
|
|
|
895
|
|
|
896 (defun sgml-eltype-all-miscdata (et)
|
|
|
897 (loop for p on (symbol-plist et) by (function cddr)
|
|
|
898 unless (memq (car p) '(model flags includes excludes))
|
|
|
899 nconc (list (car p) (cadr p))))
|
|
|
900
|
|
|
901 (defun sgml-eltype-set-all-miscdata (et miscdata)
|
|
|
902 (setf (symbol-plist et)
|
|
|
903 (nconc (symbol-plist et) miscdata)))
|
|
|
904
|
|
|
905 (defun sgml-make-eltype (name)
|
|
|
906 (let ((et (make-symbol name)))
|
|
|
907 (setf (sgml-eltype-flags et) 0)
|
|
|
908 et))
|
|
|
909
|
|
|
910
|
|
|
911 ;;; Element type tables
|
|
|
912
|
|
|
913 (defun sgml-make-eltype-table ()
|
|
|
914 "Make an empty table of element types."
|
|
|
915 (make-vector 73 0))
|
|
|
916
|
|
|
917 (defun sgml-eltype-table-empty (eltype-table)
|
|
|
918 (loop for x across eltype-table always (eq x 0)))
|
|
|
919
|
|
|
920 (defun sgml-merge-eltypes (eltypes1 eltypes2)
|
|
|
921 "Return the merge of two element type tables ELTYPES1 and ELTYPES2.
|
|
|
922 This may change ELTYPES1, ELTYPES2 is unchanged. Returns the new table."
|
|
|
923 (if (sgml-eltype-table-empty eltypes1)
|
|
|
924 eltypes2
|
|
|
925 (progn
|
|
|
926 (mapatoms
|
|
|
927 (function (lambda (sym)
|
|
|
928 (let ((et (intern (symbol-name sym) eltypes1)))
|
|
|
929 (unless (fboundp et) ; not yet defined by <!element
|
|
|
930 (when (fboundp sym)
|
|
|
931 (fset et (symbol-function sym)))
|
|
|
932 (when (boundp sym)
|
|
|
933 (set et (symbol-value sym))))
|
|
|
934 (setf (symbol-plist et)
|
|
|
935 (nconc (symbol-plist et)
|
|
|
936 (copy-list (symbol-plist sym)))))))
|
|
|
937 eltypes2)
|
|
|
938 eltypes1)))
|
|
|
939
|
|
|
940 (defun sgml-lookup-eltype (name &optional dtd)
|
|
|
941 "Lookup the element defintion for NAME (string)."
|
|
|
942 (intern name (sgml-dtd-eltypes (or dtd sgml-dtd-info))))
|
|
|
943
|
|
|
944 (defun sgml-eltype-completion-table (eltypes)
|
|
|
945 "Make a completion table from a list, ELTYPES, of element types."
|
|
|
946 (loop for et in eltypes as name = (sgml-eltype-name et)
|
|
|
947 if (boundp et)
|
|
|
948 collect (cons name name)))
|
|
|
949
|
|
|
950 (defun sgml-read-element-type (prompt dtd &optional default)
|
|
|
951 "Read an element type name.
|
|
|
952 PROMPT is displayed as a prompt and DTD should be the dtd to get the
|
|
|
953 element types from. Optional argument DEFAULT (string) will be used as
|
|
|
954 a default for the element type name."
|
|
|
955 (let ((name
|
|
|
956 (completing-read prompt
|
|
|
957 (sgml-dtd-eltypes dtd)
|
|
|
958 (function fboundp)
|
|
|
959 t
|
|
|
960 nil
|
|
|
961 nil)))
|
|
|
962 (when (equal name "")
|
|
|
963 (setq name (or default (error "Aborted"))))
|
|
|
964 (sgml-lookup-eltype name dtd)))
|
|
|
965
|
|
|
966 (defun sgml-map-eltypes (fn dtd &optional collect all)
|
|
|
967 (let ((*res* nil))
|
|
|
968 (mapatoms
|
|
|
969 (cond ((and collect all)
|
|
|
970 (function (lambda (a) (push (funcall fn a) *res*))))
|
|
|
971 (collect
|
|
|
972 (function (lambda (a) (when (boundp a)
|
|
|
973 (push (funcall fn a) *res*)))))
|
|
|
974 (all
|
|
|
975 (function (lambda (a) (funcall fn a))))
|
|
|
976 (t
|
|
|
977 (function (lambda (a) (when (boundp a) (funcall fn a))))))
|
|
|
978 (sgml-dtd-eltypes dtd))
|
|
|
979 (nreverse *res*)))
|
|
|
980
|
|
|
981 ;;;; Load a saved dtd
|
|
|
982
|
|
2
|
983 ;;; Wing addition
|
|
0
|
984 (defmacro sgml-char-int (ch)
|
|
|
985 (if (fboundp 'char-int)
|
|
|
986 (` (char-int (, ch)))
|
|
|
987 ch))
|
|
|
988
|
|
|
989 (defsubst sgml-read-octet ()
|
|
2
|
990 ;; Wing change
|
|
0
|
991 (prog1 (sgml-char-int (following-char))
|
|
|
992 (forward-char)))
|
|
|
993
|
|
|
994 (defsubst sgml-read-number ()
|
|
|
995 "Read a number.
|
|
|
996 A number is 1: an octet [0--sgml-max-singel-octet-number]
|
|
|
997 or 2: two octets (n,m) interpreted as (n-t-1)*256+m+t."
|
|
|
998 (if (> (following-char) sgml-max-single-octet-number)
|
|
|
999 (+ (* (- (following-char) (eval-when-compile
|
|
|
1000 (1+ sgml-max-single-octet-number)))
|
|
|
1001 256)
|
|
|
1002 (prog1 (char-after (1+ (point)))
|
|
|
1003 (forward-char 2))
|
|
|
1004 sgml-max-single-octet-number)
|
|
|
1005 (sgml-read-octet)))
|
|
|
1006
|
|
|
1007 (defsubst sgml-read-peek ()
|
|
|
1008 (following-char))
|
|
|
1009
|
|
|
1010 (defun sgml-read-sexp ()
|
|
|
1011 (prog1
|
|
|
1012 (let ((standard-input (current-buffer)))
|
|
|
1013 (read))
|
|
|
1014 (skip-chars-forward " \t")
|
|
|
1015 (forward-char 1)))
|
|
|
1016
|
|
|
1017 (defsubst sgml-read-token ()
|
|
|
1018 (aref sgml-read-token-vector (sgml-read-number)))
|
|
|
1019
|
|
|
1020 (defsubst sgml-read-node-ref ()
|
|
|
1021 (aref sgml-read-nodes (sgml-read-octet)))
|
|
|
1022
|
|
|
1023 (defun sgml-read-model-seq ()
|
|
|
1024 (loop repeat (sgml-read-number) collect (sgml-read-model)))
|
|
|
1025
|
|
|
1026 (defun sgml-read-token-seq ()
|
|
|
1027 (loop repeat (sgml-read-number) collect (sgml-read-token)))
|
|
|
1028
|
|
|
1029 (defun sgml-read-moves ()
|
|
|
1030 (loop repeat (sgml-read-number)
|
|
|
1031 collect (sgml-make-move (sgml-read-token) (sgml-read-node-ref))))
|
|
|
1032
|
|
|
1033 (defun sgml-read-model ()
|
|
|
1034 (let* ((n (sgml-read-number))
|
|
|
1035 (sgml-read-nodes (make-vector n nil)))
|
|
|
1036 (loop for i below n do (aset sgml-read-nodes i (sgml-make-state)))
|
|
|
1037 (loop for e across sgml-read-nodes do
|
|
2
|
1038 (cond ((eq 255 (sgml-read-peek)) ; a and-node
|
|
0
|
1039 (sgml-read-octet) ; skip
|
|
2
|
1040 (setf (sgml-and-node-next e) (sgml-read-node-ref))
|
|
|
1041 (setf (sgml-and-node-dfas e) (sgml-read-model-seq)))
|
|
0
|
1042 (t ; a normal-state
|
|
|
1043 (setf (sgml-state-opts e) (sgml-read-moves))
|
|
|
1044 (setf (sgml-state-reqs e) (sgml-read-moves)))))
|
|
|
1045 (aref sgml-read-nodes 0)))
|
|
|
1046
|
|
|
1047 (defun sgml-read-content ()
|
|
|
1048 (let ((c (sgml-read-octet)))
|
|
|
1049 (cond ((eq c 0) sgml-cdata)
|
|
|
1050 ((eq c 1) sgml-rcdata)
|
|
|
1051 ((eq c 2) sgml-empty)
|
|
|
1052 ((eq c 3) sgml-any)
|
|
|
1053 ((eq c 4) nil)
|
|
|
1054 ((eq c 128)
|
|
|
1055 (sgml-read-model)))))
|
|
|
1056
|
|
|
1057 (defun sgml-read-decode-flag (flag mask)
|
|
|
1058 (not (zerop (logand flag mask))))
|
|
|
1059
|
|
|
1060 (defun sgml-read-element (et)
|
|
|
1061 (sgml-eltype-set-all-miscdata et (sgml-read-sexp))
|
|
|
1062 (let ((flags (sgml-read-octet)))
|
|
|
1063 (unless (= flags 128)
|
|
|
1064 (setf (sgml-eltype-flags et) flags
|
|
|
1065 (sgml-eltype-model et) (sgml-read-content)
|
|
|
1066 (sgml-eltype-includes et) (sgml-read-token-seq)
|
|
|
1067 (sgml-eltype-excludes et) (sgml-read-token-seq)))))
|
|
|
1068
|
|
|
1069 (defun sgml-read-dtd ()
|
|
|
1070 "Decode the saved DTD in current buffer, return the DTD."
|
|
|
1071 (let ((gc-cons-threshold (max gc-cons-threshold 500000))
|
|
|
1072 temp dtd)
|
|
|
1073 (setq temp (sgml-read-sexp)) ; file-version
|
|
|
1074 (cond
|
|
|
1075 ((equal temp '(sgml-saved-dtd-version 5))
|
|
|
1076 ;; Doctype -- create dtd structure
|
|
|
1077 (setq dtd (sgml-make-dtd (sgml-read-sexp)))
|
|
|
1078 ;; Element type names -- read and create token vector
|
|
|
1079 (setq temp (sgml-read-number)) ; # eltypes
|
|
|
1080 (setq sgml-read-token-vector (make-vector (1+ temp) nil))
|
|
|
1081 (aset sgml-read-token-vector 0 sgml-pcdata-token)
|
|
|
1082 (loop for i from 1 to temp do
|
|
|
1083 (aset sgml-read-token-vector i
|
|
|
1084 (sgml-lookup-eltype (sgml-read-sexp) dtd)))
|
|
|
1085 ;; Element type descriptions
|
|
|
1086 (loop for i from 1 to (sgml-read-number) do
|
|
|
1087 (sgml-read-element (aref sgml-read-token-vector i)))
|
|
|
1088 (setf (sgml-dtd-parameters dtd) (sgml-read-sexp))
|
|
|
1089 (setf (sgml-dtd-entities dtd) (sgml-read-sexp))
|
|
|
1090 (setf (sgml-dtd-shortmaps dtd) (sgml-read-sexp))
|
|
|
1091 (setf (sgml-dtd-notations dtd) (sgml-read-sexp))
|
|
|
1092 (setf (sgml-dtd-dependencies dtd) (sgml-read-sexp)))
|
|
|
1093 ;; New version
|
|
|
1094 ((equal temp '(sgml-saved-dtd-version 6))
|
|
|
1095 (setq dtd (sgml-bdtd-read-dtd)))
|
|
|
1096 ;; Something else
|
|
|
1097 (t
|
|
|
1098 (error "Unknown file format for saved DTD: %s" temp)))
|
|
|
1099 dtd))
|
|
|
1100
|
|
|
1101 (defun sgml-load-dtd (file)
|
|
|
1102 "Load a saved DTD from FILE."
|
|
|
1103 (interactive
|
|
|
1104 (let ((tem (expand-file-name
|
|
|
1105 (or sgml-default-dtd-file
|
|
|
1106 (sgml-default-dtd-file)))))
|
|
|
1107 (list (read-file-name "Load DTD from: "
|
|
|
1108 (file-name-directory tem)
|
|
|
1109 tem
|
|
|
1110 t
|
|
|
1111 (file-name-nondirectory tem)))))
|
|
|
1112 (setq sgml-loaded-dtd nil) ; Allow reloading of DTD
|
|
|
1113 ;; Search for 'file' on the sgml-system-path [ndw]
|
|
|
1114 (let ((real-file (car (mapcan (function
|
|
|
1115 (lambda (dir)
|
|
|
1116 (let ((f (expand-file-name file dir)))
|
|
|
1117 (if (file-exists-p f)
|
|
|
1118 (list f)))))
|
|
|
1119 (cons "."
|
|
|
1120 ;; wing change -- add sgml-data-directory
|
|
|
1121 (append sgml-system-path
|
|
|
1122 (list sgml-data-directory)))))))
|
|
|
1123 (or real-file
|
|
|
1124 (error "Saved DTD file %s not found" file))
|
|
|
1125 (let ((cb (current-buffer))
|
|
|
1126 (tem nil)
|
|
|
1127 (dtd nil)
|
|
|
1128 (l (buffer-list))
|
|
|
1129 (find-file-type ; Allways binary
|
|
|
1130 (function (lambda (fname) 1))))
|
|
|
1131 ;; Search loaded buffer for a already loaded DTD
|
|
|
1132 (while (and l (null tem))
|
|
|
1133 (set-buffer (car l))
|
|
|
1134 (if (equal sgml-loaded-dtd real-file)
|
|
|
1135 (setq tem (current-buffer)))
|
|
|
1136 (setq l (cdr l)))
|
|
|
1137 (cond
|
|
|
1138 (tem ; loaded DTD found
|
|
|
1139 (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state)))
|
|
|
1140 (t ; load DTD from file
|
|
|
1141 (set-buffer cb)
|
|
|
1142 (sgml-push-to-entity real-file)
|
|
|
1143 (message "Loading DTD from %s..." real-file)
|
|
|
1144 (setq dtd (sgml-read-dtd))
|
|
|
1145 (message "Loading DTD from %s...done" real-file)
|
|
|
1146 (sgml-pop-entity)))
|
|
|
1147 (set-buffer cb)
|
|
|
1148 (sgml-set-initial-state dtd)
|
|
|
1149 (setq sgml-default-dtd-file file)
|
|
|
1150 (setq sgml-loaded-dtd real-file))))
|
|
|
1151
|
|
|
1152 ;;;; Biniary coded DTD module
|
|
|
1153 ;;; Works on the binary coded compiled DTD (bdtd)
|
|
|
1154
|
|
|
1155 ;;; bdtd-load: cfile dtdfile ents -> bdtd
|
|
|
1156 ;;; bdtd-merge: bdtd dtd -> dtd?
|
|
|
1157 ;;; bdtd-read-dtd: bdtd -> dtd
|
|
|
1158
|
|
|
1159 ;;; Implement by letting bdtd be implicitly the current buffer and
|
|
|
1160 ;;; dtd implicit in sgml-dtd-info.
|
|
|
1161
|
|
|
1162 (defun sgml-bdtd-load (cfile dtdfile ents)
|
|
|
1163 "Load the compiled dtd from CFILE into the current buffer.
|
|
|
1164 If this file does not exists, is of an old version or out of date, a
|
|
|
1165 new compiled dtd will be creted from file DTDFILE and parameter entity
|
|
|
1166 settings in ENTS."
|
|
|
1167 ;;(Assume the current buffer is a scratch buffer and is empty)
|
|
|
1168 (sgml-debug "Trying to load compiled DTD from %s..." cfile)
|
|
|
1169 (or (and (file-readable-p cfile)
|
|
|
1170 (let ((find-file-type ; Allways binary
|
|
|
1171 (function (lambda (fname) 1))))
|
|
|
1172 ;; fifth arg to insert-file-contents is not available in early
|
|
|
1173 ;; v19.
|
|
|
1174 (insert-file-contents cfile nil nil nil))
|
|
|
1175 (equal '(sgml-saved-dtd-version 6) (sgml-read-sexp))
|
|
|
1176 (or (sgml-up-to-date-p cfile (sgml-read-sexp))
|
|
|
1177 (if (eq 'ask sgml-recompile-out-of-date-cdtd)
|
|
|
1178 (not (y-or-n-p
|
|
|
1179 "Compiled DTD is out of date, recompile? "))
|
|
|
1180 (not sgml-recompile-out-of-date-cdtd))))
|
|
|
1181 (sgml-compile-dtd dtdfile cfile ents)))
|
|
|
1182
|
|
|
1183 (defun sgml-up-to-date-p (file dependencies)
|
|
|
1184 "Check if FILE is newer than all files in the list DEPENDENCIES.
|
|
|
1185 If DEPENDENCIES contains the symbol `t', FILE is not considered newer."
|
|
|
1186 (if (memq t dependencies)
|
|
|
1187 nil
|
|
|
1188 (loop for f in dependencies
|
|
|
1189 always (file-newer-than-file-p file f))))
|
|
|
1190
|
|
|
1191 (defun sgml-compile-dtd (dtd-file to-file ents)
|
|
|
1192 "Construct a binary code compiled dtd from DTD-FILE and write it to TO-FILE.
|
|
|
1193 The dtd will be constructed with the parameter entities set according
|
|
|
1194 to ENTS. The bdtd will be left in the current buffer. The current
|
|
|
1195 buffer is assumend to be empty to start with."
|
|
|
1196 (sgml-log-message "Recompiling DTD file %s..." dtd-file)
|
|
|
1197 (let* ((sgml-dtd-info (sgml-make-dtd nil))
|
|
|
1198 (parameters (sgml-dtd-parameters sgml-dtd-info))
|
|
|
1199 (sgml-parsing-dtd t))
|
|
|
1200 (push dtd-file
|
|
|
1201 (sgml-dtd-dependencies sgml-dtd-info))
|
|
|
1202 (loop for (name . val) in ents
|
|
|
1203 do (sgml-entity-declare name parameters 'text val))
|
|
|
1204 (sgml-push-to-entity dtd-file)
|
|
|
1205 (sgml-check-dtd-subset)
|
|
|
1206 (sgml-pop-entity)
|
|
|
1207 (erase-buffer)
|
|
2
|
1208 ;; For XEmacs-20.0/Mule
|
|
78
|
1209 (setq file-coding-system 'noconv)
|
|
0
|
1210 (sgml-write-dtd sgml-dtd-info to-file)
|
|
|
1211 t))
|
|
|
1212
|
|
|
1213 (defun sgml-check-entities (params1 params2)
|
|
|
1214 "Check that PARAMS1 is compatible with PARAMS2."
|
|
|
1215 (block check-entities
|
|
|
1216 (sgml-map-entities
|
|
|
1217 (function (lambda (entity)
|
|
|
1218 (let ((other
|
|
|
1219 (sgml-lookup-entity (sgml-entity-name entity)
|
|
|
1220 params2)))
|
|
|
1221 (unless (or (null other)
|
|
|
1222 (equal entity other))
|
|
|
1223 (sgml-log-message
|
|
|
1224 "Parameter %s in complied DTD has wrong value;\
|
|
|
1225 is '%s' should be '%s'"
|
|
|
1226 (sgml-entity-name entity)
|
|
|
1227 (sgml-entity-text other)
|
|
|
1228 (sgml-entity-text entity))
|
|
|
1229 (return-from check-entities nil)))))
|
|
|
1230 params1)
|
|
|
1231 t))
|
|
|
1232
|
|
|
1233 (defun sgml-bdtd-merge ()
|
|
|
1234 "Merge the binary coded dtd in the current buffer with the current dtd.
|
|
|
1235 The current dtd is the variable sgml-dtd-info. Return t if mereged
|
|
|
1236 was successfull or nil if failed."
|
|
78
|
1237 (setq file-coding-system 'noconv)
|
|
0
|
1238 (goto-char (point-min))
|
|
|
1239 (sgml-read-sexp) ; skip filev
|
|
|
1240 (let ((dependencies (sgml-read-sexp))
|
|
|
1241 (parameters (sgml-read-sexp))
|
|
|
1242 (gc-cons-threshold (max gc-cons-threshold 500000))
|
|
|
1243 temp)
|
|
|
1244 ;; Check comaptibility of parameters
|
|
|
1245 (and (sgml-check-entities (sgml-dtd-parameters sgml-dtd-info)
|
|
|
1246 parameters)
|
|
|
1247 (progn
|
|
|
1248 ;; Do the merger
|
|
|
1249 (sgml-message "Reading compiled DTD...")
|
|
|
1250 (sgml-merge-entity-tables (sgml-dtd-parameters sgml-dtd-info)
|
|
|
1251 parameters)
|
|
|
1252 (setf (sgml-dtd-dependencies sgml-dtd-info)
|
|
|
1253 (nconc (sgml-dtd-dependencies sgml-dtd-info)
|
|
|
1254 dependencies))
|
|
|
1255 ;; Doctype
|
|
|
1256 (setq temp (sgml-read-sexp))
|
|
|
1257 (when (and temp (null (sgml-dtd-doctype sgml-dtd-info)))
|
|
|
1258 (setf (sgml-dtd-doctype sgml-dtd-info) temp))
|
|
|
1259
|
|
|
1260 ;; Element type names -- read and create token vector
|
|
|
1261 (setq temp (sgml-read-number)) ; # eltypes
|
|
|
1262 (setq sgml-read-token-vector (make-vector (1+ temp) nil))
|
|
|
1263 (aset sgml-read-token-vector 0 sgml-pcdata-token)
|
|
|
1264 (loop for i from 1 to temp do
|
|
|
1265 (aset sgml-read-token-vector i
|
|
|
1266 (sgml-lookup-eltype (sgml-read-sexp))))
|
|
|
1267 ;; Element type descriptions
|
|
|
1268 (loop for i from 1 to (sgml-read-number) do
|
|
|
1269 (sgml-read-element (aref sgml-read-token-vector i)))
|
|
|
1270 (sgml-merge-entity-tables (sgml-dtd-entities sgml-dtd-info)
|
|
|
1271 (sgml-read-sexp))
|
|
|
1272 (sgml-merge-shortmaps (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
1273 (sgml-read-sexp))
|
|
|
1274 (setf (sgml-dtd-notations sgml-dtd-info) (sgml-read-sexp))
|
|
|
1275 t))))
|
|
|
1276
|
|
|
1277 (defun sgml-bdtd-read-dtd ()
|
|
|
1278 "Create and return a dtd from the binary coded dtd in the current buffer."
|
|
|
1279 (let ((sgml-dtd-info (sgml-make-dtd nil)))
|
|
|
1280 (sgml-bdtd-merge)
|
|
|
1281 sgml-dtd-info))
|
|
|
1282
|
|
|
1283 ;;;; Set markup type
|
|
|
1284
|
|
|
1285 (defsubst sgml-set-markup-type (type)
|
|
|
1286 "Set the type of the markup parsed to TYPE.
|
|
|
1287 The markup starts at position given by variable sgml-markup-start and
|
|
|
1288 ends at point."
|
|
|
1289 (when (and sgml-set-face
|
|
|
1290 (null sgml-current-eref))
|
|
|
1291 (sgml-set-face-for sgml-markup-start (point) type))
|
|
|
1292 (setq sgml-markup-type type))
|
|
|
1293
|
|
|
1294
|
|
|
1295 ;;;; Parsing delimiters
|
|
|
1296
|
|
|
1297 (eval-and-compile
|
|
|
1298 (defconst sgml-delimiters
|
|
|
1299 '("AND" "&"
|
|
|
1300 "COM" "--"
|
|
|
1301 "CRO" "&#"
|
|
|
1302 "DSC" "]"
|
|
|
1303 "DSO" "["
|
|
|
1304 "DTGC" "]"
|
|
|
1305 "DTGO" "["
|
|
|
1306 "ERO" "&"
|
|
|
1307 "ETAGO" "</"
|
|
|
1308 "GRPC" ")"
|
|
|
1309 "GRPO" "("
|
|
|
1310 "LIT" "\""
|
|
|
1311 "LITA" "'"
|
|
|
1312 "MDC" ">"
|
|
|
1313 "MDO" "<!"
|
|
|
1314 "MINUS" "-"
|
|
|
1315 "MSC" "]]"
|
|
|
1316 "NET" "/"
|
|
|
1317 "OPT" "?"
|
|
|
1318 "OR" "|"
|
|
|
1319 "PERO" "%"
|
|
|
1320 "PIC" ">"
|
|
|
1321 "PIO" "<?"
|
|
|
1322 "PLUS" "+"
|
|
|
1323 "REFC" ";"
|
|
|
1324 "REP" "*"
|
|
|
1325 "RNI" "#"
|
|
|
1326 "SEQ" ","
|
|
|
1327 "STAGO" "<"
|
|
|
1328 "TAGC" ">"
|
|
|
1329 "VI" "="
|
|
|
1330 ;; Some combinations
|
|
|
1331 "MS-START" "<![" ; MDO DSO
|
|
|
1332 "MS-END" "]]>" ; MSC MDC
|
|
|
1333 ;; Pseudo
|
|
|
1334 "NULL" ""
|
|
|
1335 )))
|
|
|
1336
|
|
|
1337
|
|
|
1338 (defmacro sgml-is-delim (delim &optional context move offset)
|
|
|
1339 "Macro for matching delimiters.
|
|
|
1340 Syntax: DELIM &optional CONTEXT MOVE
|
|
|
1341 where DELIM is the delimiter name (string or symbol),
|
|
|
1342 CONTEXT the contextual constraint, and
|
|
|
1343 MOVE is `nil', `move' or `check'.
|
|
|
1344
|
|
|
1345 Test if the text following point in current buffer matches the SGML
|
|
|
1346 delimiter DELIM. Also check the characters after the delimiter for
|
|
|
1347 CONTEXT. Applicable values for CONTEXT is
|
|
|
1348 `gi' -- name start or TAGC if SHORTTAG YES,
|
|
|
1349 `com' -- if COM or MDC,
|
|
|
1350 `nmstart' -- name start character,
|
|
|
1351 `stagc' -- TAGC if SHORTTAG YES,
|
|
|
1352 `digit' -- any Digit,
|
|
|
1353 string -- delimiter with that name,
|
|
|
1354 list -- any of the contextual constraints in the list."
|
|
|
1355
|
|
|
1356 (or offset (setq offset 0))
|
|
|
1357 (let ((ds (member (upcase (format "%s" delim))
|
|
|
1358 sgml-delimiters)))
|
|
|
1359 (assert ds)
|
|
|
1360 (setq delim (car ds)
|
|
|
1361 ds (cadr ds))
|
|
|
1362 (cond ((eq context 'gi)
|
|
|
1363 (setq context '(nmstart stagc)))
|
|
|
1364 ((eq context 'com)
|
|
|
1365 (setq context '("COM" "MDC")))
|
|
|
1366 ((null context)
|
|
|
1367 (setq context '(t)))
|
|
|
1368 ((not (listp context))
|
|
|
1369 (setq context (list context))))
|
|
|
1370 (`(if (and ; This and checks that characters
|
|
|
1371 ; of the delimiter
|
|
|
1372 (,@(loop for i from 0 below (length ds) collect
|
|
|
1373 (` (eq (, (aref ds i))
|
|
|
1374 (sgml-following-char (, (+ i offset)))))))
|
|
|
1375 (or
|
|
|
1376 (,@(loop
|
|
|
1377 for c in context collect ; context check
|
|
|
1378 (cond
|
|
|
1379 ((eq c 'nmstart) ; name start character
|
|
|
1380 (`(sgml-startnm-char
|
|
|
1381 (or (sgml-following-char (, (length ds))) 0))))
|
|
|
1382 ((eq c 'stagc)
|
|
|
1383 (`(and sgml-current-shorttag
|
|
|
1384 (sgml-is-delim "TAGC" nil nil (, (length ds))))))
|
|
|
1385 ((eq c 'digit)
|
|
|
1386 (`(memq (sgml-following-char (, (length ds)))
|
|
|
1387 '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))))
|
|
|
1388 ((stringp c)
|
|
|
1389 (`(sgml-is-delim (, c) nil nil (, (length ds)))))
|
|
|
1390 ((eq c t))
|
|
|
1391 (t (error "Context type: %s" c))))
|
|
|
1392 )))
|
|
|
1393
|
|
|
1394 (progn ; Do operations if delimiter found
|
|
|
1395 (,@ (if move (`((forward-char (, (length ds)))))))
|
|
|
1396 (,@ (if (not (eq move 'check))
|
|
|
1397 '(t))))
|
|
|
1398 (,@ (if (eq move 'check)
|
|
|
1399 (`((sgml-delimiter-parse-error (, delim))))))))))
|
|
|
1400
|
|
|
1401 (defmacro sgml-following-char (n)
|
|
|
1402 (cond ((zerop n) '(following-char))
|
|
|
1403 ((= n 1) '(char-after (1+ (point))))
|
|
|
1404 (t (` (char-after (+ (, n) (point)))))))
|
|
|
1405
|
|
|
1406 (defun sgml-delimiter-parse-error (delim)
|
|
|
1407 (sgml-parse-error "Delimiter %s (%s) expected"
|
|
|
1408 delim (cadr (member delim sgml-delimiters))))
|
|
|
1409
|
|
|
1410 (defmacro sgml-parse-delim (delim &optional context)
|
|
|
1411 (`(sgml-is-delim (, delim) (, context) move)))
|
|
|
1412
|
|
|
1413 (defmacro sgml-check-delim (delim &optional context)
|
|
|
1414 (`(sgml-is-delim (, delim) (, context) check)))
|
|
|
1415
|
|
|
1416 (defmacro sgml-skip-upto (delim)
|
|
|
1417 "Skip until the delimiter or first char of one of the delimiters.
|
|
|
1418 If DELIM is a string/symbol this is should be a delimiter role.
|
|
|
1419 Characters are skipped until the delimiter is recognized.
|
|
|
1420 If DELIM is a list of delimiters, skip until a character that is first
|
|
|
1421 in any of them."
|
|
|
1422 (cond
|
|
|
1423 ((consp delim)
|
|
|
1424 (list 'skip-chars-forward
|
|
|
1425 (concat "^"
|
|
|
1426 (loop for d in delim
|
|
|
1427 concat (let ((ds (member (upcase (format "%s" d))
|
|
|
1428 sgml-delimiters)))
|
|
|
1429 (assert ds)
|
|
|
1430 (let ((s (substring (cadr ds) 0 1)))
|
|
|
1431 (if (member s '("-" "\\"))
|
|
|
1432 (concat "\\" s)
|
|
|
1433 s)))))))
|
|
|
1434 (t
|
|
|
1435 (let ((ds (member (upcase (format "%s" delim))
|
|
|
1436 sgml-delimiters)))
|
|
|
1437 (assert ds)
|
|
|
1438 (setq ds (cadr ds))
|
|
|
1439 (if (= 1 (length ds))
|
|
|
1440 (list 'skip-chars-forward (concat "^" ds))
|
|
|
1441 (`(and (search-forward (, ds) nil t)
|
|
|
1442 (backward-char (, (length ds))))))))))
|
|
|
1443
|
|
|
1444
|
|
|
1445 ;;(macroexpand '(sgml-is-delim mdo))
|
|
|
1446 ;;(macroexpand '(sgml-parse-delim mdo))
|
|
|
1447 ;;(macroexpand '(sgml-check-delim mdo))
|
|
|
1448
|
|
|
1449
|
|
|
1450 ;;;; General lexical functions
|
|
|
1451 ;;; Naming conventions
|
|
|
1452 ;;; sgml-parse-xx try to parse xx, return nil if can't else return
|
|
|
1453 ;;; some propriate non-nil value.
|
|
|
1454 ;;; Except: for name/nametoken parsing, return 0 if can't.
|
|
|
1455 ;;; sgml-check-xx require xx, report error if can't parse. Return
|
|
|
1456 ;;; aproporiate value.
|
|
|
1457
|
|
|
1458 (defmacro sgml-parse-char (char)
|
|
|
1459 (` (cond ((eq (, char) (following-char))
|
|
|
1460 (forward-char 1)
|
|
|
1461 t))))
|
|
|
1462
|
|
|
1463 (defmacro sgml-parse-chars (char1 char2 &optional char3)
|
|
|
1464 "Parse two or three chars; return nil if can't"
|
|
|
1465 (if (null char3)
|
|
|
1466 (` (cond ((and (eq (, char1) (following-char))
|
|
|
1467 (eq (, char2) (char-after (1+ (point)))))
|
|
|
1468 (forward-char 2)
|
|
|
1469 t)))
|
|
|
1470 (` (cond ((and (eq (, char1) (following-char))
|
|
|
1471 (eq (, char2) (char-after (1+ (point))))
|
|
|
1472 (eq (, char3) (char-after (1+ (1+ (point))))))
|
|
|
1473 (forward-char 3)
|
|
|
1474 t)))))
|
|
|
1475
|
|
|
1476 (defun sgml-check-char (char)
|
|
|
1477 (cond ((not (sgml-parse-char char))
|
|
|
1478 (sgml-parse-error "Expecting %c" char))))
|
|
|
1479
|
|
|
1480 (defun sgml-parse-RE ()
|
|
|
1481 (or (sgml-parse-char ?\n)
|
|
|
1482 (sgml-parse-char ?\r)))
|
|
|
1483
|
|
|
1484 (defmacro sgml-startnm-char (c)
|
|
|
1485 (` (eq ?w (char-syntax (, c)))))
|
|
|
1486
|
|
|
1487 (defun sgml-startnm-char-next ()
|
|
|
1488 (and (not (eobp))
|
|
|
1489 (sgml-startnm-char (following-char))))
|
|
|
1490
|
|
|
1491 (defun sgml-name-char (c)
|
|
|
1492 (and c
|
|
|
1493 (or (sgml-startnm-char c)
|
|
|
1494 (eq ?_ (char-syntax c)))))
|
|
|
1495
|
|
|
1496 (defun sgml-is-end-tag ()
|
|
|
1497 (sgml-is-delim "ETAGO" gi))
|
|
|
1498
|
|
|
1499 (defsubst sgml-is-enabled-net ()
|
|
|
1500 (and (sgml-is-delim "NET")
|
|
|
1501 sgml-current-shorttag
|
|
|
1502 (sgml-tree-net-enabled sgml-current-tree)))
|
|
|
1503
|
|
|
1504 (defun sgml-is-start-tag ()
|
|
|
1505 (sgml-is-delim "STAGO" gi))
|
|
|
1506
|
|
|
1507 (defsubst sgml-parse-s (&optional shortmap)
|
|
|
1508 (if shortmap
|
|
|
1509 (or (/= 0 (skip-chars-forward " "))
|
|
|
1510 (/= 0 (skip-chars-forward "\t"))
|
|
|
1511 (sgml-parse-char ?\n)
|
|
|
1512 (sgml-parse-char ?\r))
|
|
|
1513 (/= 0 (skip-chars-forward " \t\n\r"))))
|
|
|
1514
|
|
|
1515 (defsubst sgml-parse-processing-instruction ()
|
|
|
1516 (if (sgml-parse-delim "PIO")
|
|
|
1517 (sgml-do-processing-instruction)))
|
|
|
1518
|
|
|
1519 (defun sgml-do-processing-instruction ()
|
|
|
1520 (let ((start (point)))
|
|
|
1521 (sgml-skip-upto "PIC")
|
|
|
1522 (when sgml-pi-function
|
|
|
1523 (funcall sgml-pi-function
|
|
|
1524 (buffer-substring-no-properties start (point)))))
|
|
|
1525 (sgml-check-delim "PIC")
|
|
|
1526 (sgml-set-markup-type 'pi)
|
|
|
1527 t)
|
|
|
1528
|
|
|
1529
|
|
|
1530 (defmacro sgml-general-case (string) (`(downcase (, string))))
|
|
|
1531 (defmacro sgml-entity-case (string) string)
|
|
|
1532
|
|
|
1533 (defun sgml-parse-name (&optional entity-name)
|
|
|
1534 (if (sgml-startnm-char-next)
|
|
|
1535 (let ((name (buffer-substring-no-properties
|
|
|
1536 (point)
|
|
|
1537 (progn (skip-syntax-forward "w_")
|
|
|
1538 (point)))))
|
|
|
1539 (if entity-name
|
|
|
1540 (sgml-entity-case name)
|
|
|
1541 (sgml-general-case name)))))
|
|
|
1542
|
|
|
1543 (define-compiler-macro sgml-parse-name (&whole form &optional entity-name)
|
|
|
1544 (cond
|
|
|
1545 ((memq entity-name '(nil t))
|
|
|
1546 (` (if (sgml-startnm-char-next)
|
|
|
1547 ((, (if entity-name 'sgml-entity-case 'sgml-general-case))
|
|
|
1548 (buffer-substring-no-properties (point)
|
|
|
1549 (progn (skip-syntax-forward "w_")
|
|
|
1550 (point)))))))
|
|
|
1551 (t
|
|
|
1552 form)))
|
|
|
1553
|
|
|
1554 (defun sgml-check-name (&optional entity-name)
|
|
|
1555 (or (sgml-parse-name entity-name)
|
|
|
1556 (sgml-parse-error "Name expected")))
|
|
|
1557
|
|
|
1558 (define-compiler-macro sgml-check-name (&optional entity-name)
|
|
|
1559 (`(or (, (if entity-name
|
|
|
1560 (`(sgml-parse-name (, entity-name)))
|
|
|
1561 '(sgml-parse-name)))
|
|
|
1562 (sgml-parse-error "Name expected"))))
|
|
|
1563
|
|
|
1564
|
|
|
1565 (defun sgml-parse-nametoken (&optional entity-name)
|
|
|
1566 "Parses a name token and returns a string or nil if no nametoken."
|
|
|
1567 (if (sgml-name-char (following-char))
|
|
|
1568 (let ((name (buffer-substring-no-properties
|
|
|
1569 (point)
|
|
|
1570 (progn (skip-syntax-forward "w_")
|
|
|
1571 (point)))))
|
|
|
1572 (if entity-name
|
|
|
1573 (sgml-entity-case name)
|
|
|
1574 (sgml-general-case name)))))
|
|
|
1575
|
|
|
1576 (defun sgml-check-nametoken ()
|
|
|
1577 (or (sgml-parse-nametoken)
|
|
|
1578 (sgml-parse-error "Name token expected")))
|
|
|
1579
|
|
|
1580 ;;(defun sgml-gname-symbol (string)
|
|
|
1581 ;; "Convert a string to a general name/nametoken/numbertoken."
|
|
|
1582 ;; (intern (sgml-general-case string)))
|
|
|
1583
|
|
|
1584 ;;(defun sgml-ename-symbol (string)
|
|
|
1585 ;; "Convert a string to an entity name."
|
|
|
1586 ;; (intern (sgml-entity-case string)))
|
|
|
1587
|
|
|
1588 (defsubst sgml-parse-general-entity-ref ()
|
|
|
1589 (if (sgml-parse-delim "ERO" nmstart)
|
|
|
1590 (sgml-do-general-entity-ref)))
|
|
|
1591
|
|
|
1592 (defun sgml-do-general-entity-ref ()
|
|
|
1593 (sgml-do-entity-ref
|
|
|
1594 (prog1 (sgml-parse-name t)
|
|
|
1595 (or (sgml-parse-delim "REFC")
|
|
|
1596 (sgml-parse-RE))
|
|
|
1597 (sgml-set-markup-type 'entity)))
|
|
|
1598 t)
|
|
|
1599
|
|
|
1600 (defun sgml-do-entity-ref (name)
|
|
|
1601 (let ((entity
|
|
|
1602 (sgml-lookup-entity name
|
|
|
1603 (sgml-dtd-entities sgml-dtd-info))))
|
|
|
1604 (cond ((and (null entity)
|
|
|
1605 sgml-warn-about-undefined-entities)
|
|
|
1606 (sgml-log-warning
|
|
|
1607 "Undefined entity %s" name))
|
|
|
1608 ((sgml-entity-data-p entity)
|
|
|
1609 (when sgml-signal-data-function
|
|
|
1610 (funcall sgml-signal-data-function))
|
|
|
1611 (cond
|
|
|
1612 (sgml-entity-function
|
|
|
1613 (funcall sgml-entity-function entity))
|
|
|
1614 (sgml-data-function
|
|
|
1615 (sgml-push-to-entity entity sgml-markup-start)
|
|
|
1616 (funcall sgml-data-function (buffer-string))
|
|
|
1617 (sgml-pop-entity))))
|
|
|
1618 (t
|
|
|
1619 (sgml-push-to-entity entity sgml-markup-start)))))
|
|
|
1620
|
|
|
1621 (defsubst sgml-parse-parameter-entity-ref ()
|
|
|
1622 "Parse and push to a parameter entity, return nil if no ref here."
|
|
|
1623 ;;(setq sgml-markup-start (point))
|
|
|
1624 (if (sgml-parse-delim "PERO" nmstart)
|
|
|
1625 (sgml-do-parameter-entity-ref)))
|
|
|
1626
|
|
|
1627 (defun sgml-do-parameter-entity-ref ()
|
|
|
1628 (let* ((name (sgml-parse-name t))
|
|
|
1629 (ent (sgml-lookup-entity name
|
|
|
1630 (sgml-dtd-parameters sgml-dtd-info))))
|
|
|
1631 (or (sgml-parse-delim "REFC")
|
|
|
1632 (sgml-parse-char ?\n))
|
|
|
1633 ;;(sgml-set-markup-type 'param)
|
|
|
1634 (cond (ent
|
|
|
1635 (sgml-push-to-entity ent sgml-markup-start 'param))
|
|
|
1636 (t
|
|
|
1637 (sgml-log-warning
|
|
|
1638 "Undefined parameter entity %s" name)))
|
|
|
1639 t))
|
|
|
1640
|
|
|
1641 (defun sgml-parse-comment ()
|
|
|
1642 (if (sgml-parse-delim "COM")
|
|
|
1643 (progn (sgml-skip-upto "COM")
|
|
|
1644 (sgml-check-delim "COM")
|
|
|
1645 t)))
|
|
|
1646
|
|
|
1647 (defun sgml-skip-cs ()
|
|
|
1648 "Skip over the separator used in the catalog.
|
|
|
1649 Return true if not at the end of the buffer."
|
|
|
1650 (while (or (sgml-parse-s)
|
|
|
1651 (sgml-parse-comment)))
|
|
|
1652 (not (eobp)))
|
|
|
1653
|
|
|
1654 (defsubst sgml-skip-ps ()
|
|
|
1655 "Move point forward stopping before a char that isn't a parameter separator."
|
|
|
1656 (while
|
|
|
1657 (or (sgml-parse-s)
|
|
|
1658 (if (eobp) (sgml-pop-entity))
|
|
|
1659 (sgml-parse-parameter-entity-ref)
|
|
|
1660 (sgml-parse-comment))))
|
|
|
1661
|
|
|
1662 (defsubst sgml-parse-ds ()
|
|
|
1663 ;71 ds = 5 s | EE | 60+ parameter entity reference
|
|
|
1664 ; | 91 comment declaration
|
|
|
1665 ; | 44 processing instruction
|
|
|
1666 ; | 93 marked section declaration ***
|
|
|
1667 (or (and (eobp) (sgml-pop-entity)) ;EE
|
|
|
1668 (sgml-parse-s) ;5 s
|
|
|
1669 ;;(sgml-parse-comment-declaration) ;91 comment declaration
|
|
|
1670 (sgml-parse-parameter-entity-ref)
|
|
|
1671 (sgml-parse-processing-instruction)))
|
|
|
1672
|
|
|
1673 (defun sgml-skip-ds ()
|
|
|
1674 (while (sgml-parse-ds)))
|
|
|
1675
|
|
|
1676 (defmacro sgml-parse-rni (&optional name)
|
|
|
1677 "Parse a RNI (#) return nil if none; with optional NAME,
|
|
|
1678 a RNI must be followed by NAME."
|
|
|
1679 (cond
|
|
|
1680 (name
|
|
|
1681 (` (if (sgml-parse-delim "RNI")
|
|
|
1682 (sgml-check-token (, name)))))
|
|
|
1683 (t '(sgml-parse-delim "RNI"))))
|
|
|
1684
|
|
|
1685 (defun sgml-check-token (name)
|
|
|
1686 (or (equal (sgml-check-name) name)
|
|
|
1687 (sgml-parse-error "Reserved name not expected")))
|
|
|
1688
|
|
|
1689 (defun sgml-parse-literal ()
|
|
|
1690 "Parse a literal and return a string, if no literal return nil."
|
|
|
1691 (let (lita start value)
|
|
|
1692 (cond ((or (sgml-parse-delim "LIT")
|
|
|
1693 (setq lita (sgml-parse-delim "LITA")))
|
|
|
1694 (setq start (point))
|
|
|
1695 (if lita
|
|
|
1696 (sgml-skip-upto "LITA")
|
|
|
1697 (sgml-skip-upto "LIT"))
|
|
|
1698 (setq value (buffer-substring-no-properties start (point)))
|
|
|
1699 (if lita
|
|
|
1700 (sgml-check-delim "LITA")
|
|
|
1701 (sgml-check-delim "LIT"))
|
|
|
1702 value))))
|
|
|
1703
|
|
|
1704 (defun sgml-check-literal ()
|
|
|
1705 (or (sgml-parse-literal)
|
|
|
1706 (sgml-parse-error "A litteral expected")))
|
|
|
1707
|
|
|
1708 (defun sgml-parse-minimum-literal ()
|
|
|
1709 "Parse a quoted SGML string and return it, if no string return nil."
|
|
|
1710 (cond
|
|
|
1711 ((memq (following-char) '(?\" ?\'))
|
|
|
1712 (let* ((qchar (following-char))
|
|
|
1713 (blanks " \t\r\n")
|
|
|
1714 (qskip (format "^%s%c" blanks qchar))
|
|
|
1715 (start (point))
|
|
|
1716 (value ; accumulates the literal value
|
|
|
1717 "")
|
|
|
1718 (spaced ""))
|
|
|
1719 (forward-char 1)
|
|
|
1720 (skip-chars-forward blanks)
|
|
|
1721 (while (not (sgml-parse-char qchar))
|
|
|
1722 (cond ((eobp)
|
|
|
1723 (goto-char start)
|
|
|
1724 (sgml-parse-error "Unterminated literal"))
|
|
|
1725 ((sgml-parse-s)
|
|
|
1726 (setq spaced " "))
|
|
|
1727 (t
|
|
|
1728 (setq value
|
|
|
1729 (concat value spaced
|
|
|
1730 (buffer-substring-no-properties
|
|
|
1731 (point)
|
|
|
1732 (progn (skip-chars-forward qskip)
|
|
|
1733 (point))))
|
|
|
1734 spaced ""))))
|
|
|
1735 value))))
|
|
|
1736
|
|
|
1737 (defun sgml-check-minimum-literal ()
|
|
|
1738 (or (sgml-parse-minimum-literal)
|
|
|
1739 (sgml-parse-error "A minimum literal expected")))
|
|
|
1740
|
|
|
1741 (defun sgml-parse-external ()
|
|
|
1742 "Leaves nil if no external id, or (pubid . sysid)"
|
|
|
1743 (sgml-skip-ps)
|
|
|
1744 (let* ((p (point))
|
|
|
1745 (token (sgml-parse-nametoken)))
|
|
|
1746 (cond
|
|
|
1747 (token
|
|
|
1748 (sgml-skip-ps)
|
|
|
1749 (cond ((member token '("public" "system"))
|
|
|
1750 (let* ((pubid ; the public id
|
|
|
1751 (if (string-equal token "public")
|
|
|
1752 (or (sgml-parse-minimum-literal)
|
|
|
1753 (sgml-parse-error "Public identifier expected"))))
|
|
|
1754 (sysid ; the system id
|
|
|
1755 (progn (sgml-skip-ps)
|
|
|
1756 (sgml-parse-literal))))
|
|
|
1757 (sgml-make-extid pubid sysid)))
|
|
|
1758 (t
|
|
|
1759 (goto-char p)
|
|
|
1760 nil))))))
|
|
|
1761
|
|
|
1762 (defun sgml-skip-tag ()
|
|
|
1763 (when (sgml-parse-char ?<)
|
|
|
1764 (sgml-parse-char ?/)
|
|
|
1765 (unless (search-forward-regexp
|
|
|
1766 "\\([^\"'<>/]\\|\"[^\"]*\"\\|'[^']*'\\)*"
|
|
|
1767 nil t)
|
|
|
1768 (sgml-error "Invalid tag"))
|
|
|
1769 (or (sgml-parse-char ?>)
|
|
|
1770 (sgml-parse-char ?/))))
|
|
|
1771
|
|
|
1772
|
|
|
1773 ;;;; Entity Manager
|
|
|
1774
|
|
|
1775 (defstruct (sgml-entity
|
|
|
1776 (:type list)
|
|
|
1777 (:constructor sgml-make-entity (name type text)))
|
|
|
1778 name ; Name of entity (string)
|
|
|
1779 type ; Type of entity CDATA NDATA PI SDATA
|
|
|
1780 text ; string or external
|
|
|
1781 )
|
|
|
1782
|
|
|
1783 (defun sgml-entity-data-p (entity)
|
|
|
1784 "True if ENTITY is a data entity, that is not a text entity."
|
|
|
1785 (not (eq (sgml-entity-type entity) 'text)))
|
|
|
1786
|
|
|
1787 (defun sgml-entity-marked-undefined-p (entity)
|
|
|
1788 (cdddr entity))
|
|
|
1789
|
|
|
1790
|
|
|
1791 ;;; Entity tables
|
|
|
1792 ;; Represented by a cons-cell whose car is the default entity (or nil)
|
|
|
1793 ;; and whose cdr is as an association list.
|
|
|
1794
|
|
|
1795 (defun sgml-make-entity-table ()
|
|
|
1796 (list nil))
|
|
|
1797
|
|
|
1798 (defun sgml-lookup-entity (name entity-table)
|
|
|
1799 (or (assoc name (cdr entity-table))
|
|
|
1800 (car entity-table)))
|
|
|
1801
|
|
|
1802 (defun sgml-entity-declare (name entity-table type text)
|
|
|
1803 "Declare an entity with name NAME in table ENTITY-TABLE.
|
|
|
1804 TYPE should be the type of the entity (text|cdata|ndata|sdata...).
|
|
|
1805 TEXT is the text of the entity, a string or an external identifier.
|
|
|
1806 If NAME is nil, this defines the default entity."
|
|
|
1807 (cond
|
|
|
1808 (name
|
|
|
1809 (unless (sgml-lookup-entity name entity-table)
|
|
|
1810 (sgml-debug "Declare entity %s %s as %S" name type text)
|
|
|
1811 (nconc entity-table
|
|
|
1812 (list (sgml-make-entity name type text)))))
|
|
|
1813 (t
|
|
|
1814 (unless (car entity-table)
|
|
|
1815 (sgml-debug "Declare default entity %s as %S" type text)
|
|
|
1816 (setcar entity-table (sgml-make-entity name type text))))))
|
|
|
1817
|
|
|
1818 (defun sgml-entity-completion-table (entity-table)
|
|
|
1819 "Make a completion table from the ENTITY-TABLE."
|
|
|
1820 (cdr entity-table))
|
|
|
1821
|
|
|
1822 (defun sgml-map-entities (fn entity-table &optional collect)
|
|
|
1823 (if collect
|
|
|
1824 (mapcar fn (cdr entity-table))
|
|
|
1825 (loop for e in (cdr entity-table) do (funcall fn e))))
|
|
|
1826
|
|
|
1827 (defun sgml-merge-entity-tables (tab1 tab2)
|
|
|
1828 "Merge entity table TAB2 into TAB1. TAB1 is modified."
|
|
|
1829 (nconc tab1 (cdr tab2))
|
|
|
1830 (setcar tab1 (or (car tab1) (car tab2))))
|
|
|
1831
|
|
2
|
1832
|
|
|
1833 (defun sgml-entity-insert-text (entity &optional ptype)
|
|
|
1834 "Insert the text of ENTITY.
|
|
|
1835 PTYPE can be 'param if this is a parameter entity."
|
|
|
1836 (let ((text (sgml-entity-text entity)))
|
|
|
1837 (cond
|
|
|
1838 ((stringp text)
|
|
|
1839 (insert text))
|
|
|
1840 (t
|
|
|
1841 (sgml-insert-external-entity text
|
|
|
1842 (or ptype
|
|
|
1843 (sgml-entity-type entity))
|
|
|
1844 (sgml-entity-name entity))))))
|
|
0
|
1845
|
|
|
1846 ;;;; External identifyer resolve
|
|
|
1847
|
|
2
|
1848 (defun sgml-cache-catalog (file cache-var parser-fun
|
|
|
1849 &optional default-dir)
|
|
0
|
1850 "Return parsed catalog.
|
|
|
1851 FILE is the file containing the catalog. Maintains a cache of parsed
|
|
|
1852 catalog files in variable CACHE-VAR. The parsing is done by function
|
|
|
1853 PARSER-FUN that should parse the current buffer and return the parsed
|
|
|
1854 repreaentation of the catalog."
|
|
2
|
1855 (setq file (file-truename (expand-file-name file default-dir)))
|
|
0
|
1856 (and
|
|
|
1857 (file-readable-p file)
|
|
|
1858 (let ((c (assoc file (symbol-value cache-var)))
|
|
|
1859 (modtime (elt (file-attributes file) 5)))
|
|
|
1860 (if (and c (equal (second c) modtime))
|
|
|
1861 (cddr c)
|
|
|
1862 (when c (set cache-var (delq c (symbol-value cache-var))))
|
|
|
1863 (let (new)
|
|
|
1864 (message "Loading %s ..." file)
|
|
|
1865 (sgml-push-to-entity file)
|
|
|
1866 (setq default-directory (file-name-directory file))
|
|
|
1867 (setq new (funcall parser-fun))
|
|
|
1868 (sgml-pop-entity)
|
|
|
1869 (push (cons file (cons modtime new)) (symbol-value cache-var))
|
|
|
1870 (message "Loading %s ... done" file)
|
|
|
1871 new)))))
|
|
|
1872
|
|
2
|
1873 (defun sgml-main-directory ()
|
|
|
1874 "Directory of the document entity."
|
|
|
1875 (let ((cb (current-buffer)))
|
|
|
1876 (set-buffer sgml-current-top-buffer)
|
|
|
1877 (prog1 default-directory
|
|
|
1878 (set-buffer cb))))
|
|
|
1879
|
|
|
1880 (defun sgml-trace-lookup (&rest args)
|
|
|
1881 "Log a message like `sgml-log-message', but only if `sgml-trace-entity-lookup' is set."
|
|
|
1882 (when sgml-trace-entity-lookup
|
|
|
1883 (apply (function sgml-log-message) args)))
|
|
|
1884
|
|
|
1885
|
|
0
|
1886 (defun sgml-catalog-lookup (files pubid type name)
|
|
|
1887 "Look up the public identifier/entity name in catalogs.
|
|
|
1888 FILES is a list of catalogs to use. PUBID is the public identifier
|
|
|
1889 \(if any). TYPE is the entity type and NAME is the entity name."
|
|
|
1890 (cond ((eq type 'param)
|
|
|
1891 (setq name (format "%%%s" name)
|
|
|
1892 type 'entity))
|
|
|
1893 ((eq type 'dtd)
|
|
|
1894 (setq type 'doctype)))
|
|
2
|
1895 ;;(sgml-trace-lookup " [pubid='%s' type=%s name='%s']" pubid type name)
|
|
0
|
1896 (loop
|
|
|
1897 for f in files thereis
|
|
|
1898 (let ((cat (sgml-cache-catalog f 'sgml-catalog-assoc
|
|
2
|
1899 (function sgml-parse-catalog-buffer)
|
|
|
1900 (sgml-main-directory))))
|
|
|
1901 (sgml-trace-lookup " catalog: %s %s"
|
|
|
1902 (expand-file-name f (sgml-main-directory))
|
|
|
1903 (if (null cat) "empty/non existent" "exists"))
|
|
0
|
1904 (or
|
|
|
1905 ;; Giv PUBLIC entries priority over ENTITY and DOCTYPE
|
|
|
1906 (if pubid
|
|
|
1907 (loop for (key cname file) in cat
|
|
2
|
1908 thereis (if (and (eq 'public key)
|
|
|
1909 (string= pubid cname))
|
|
|
1910 (if (file-readable-p file)
|
|
|
1911 (progn
|
|
|
1912 (sgml-trace-lookup " >> %s [by pubid]" file)
|
|
|
1913 file)
|
|
|
1914 (progn
|
|
|
1915 (sgml-trace-lookup " !unreadable %s" file)
|
|
|
1916 nil)))))
|
|
0
|
1917 (loop for (key cname file) in cat
|
|
2
|
1918 ;;do (sgml-trace-lookup " %s %s" key cname)
|
|
|
1919 thereis (if (and (eq type key)
|
|
|
1920 (or (null cname)
|
|
|
1921 (string= name cname)))
|
|
|
1922 (if (file-readable-p file)
|
|
|
1923 (progn
|
|
|
1924 (sgml-trace-lookup " >> %s [by %s %s]"
|
|
|
1925 file key cname)
|
|
|
1926 file)
|
|
|
1927 (progn
|
|
|
1928 (sgml-trace-lookup " !unreadable %s" file)
|
|
|
1929 nil))))))))
|
|
0
|
1930
|
|
|
1931 (defun sgml-path-lookup (extid type name)
|
|
|
1932 (let* ((pubid (sgml-extid-pubid extid))
|
|
|
1933 (sysid (sgml-extid-sysid extid))
|
|
|
1934 (subst (list '(?% ?%))))
|
|
|
1935 (when pubid
|
|
|
1936 (nconc subst (list (cons ?p (sgml-transliterate-file pubid)))
|
|
|
1937 (sgml-pubid-parts pubid))
|
|
|
1938 (setq pubid (sgml-canonize-pubid pubid)))
|
|
|
1939 (when sysid (nconc subst (list (cons ?s sysid))))
|
|
|
1940 (when name (nconc subst (list (cons ?n name))))
|
|
|
1941 (when type (nconc subst (list (cons ?y (cond ((eq type 'dtd) "dtd")
|
|
|
1942 ((eq type 'text) "text")
|
|
|
1943 ((eq type 'param) "parm")
|
|
|
1944 (t "sgml"))))))
|
|
|
1945 (sgml-debug "Ext. file subst. = %S" subst)
|
|
|
1946 (loop for cand in sgml-public-map
|
|
|
1947 thereis
|
|
|
1948 (and (setq cand (sgml-subst-expand cand subst))
|
|
|
1949 (file-readable-p
|
|
|
1950 (setq cand
|
|
|
1951 (sgml-extid-expand (substitute-in-file-name cand)
|
|
|
1952 extid)))
|
|
|
1953 (not (file-directory-p cand))
|
|
|
1954 cand))))
|
|
|
1955
|
|
|
1956 (defun sgml-external-file (extid &optional type name)
|
|
|
1957 "Return file name for entity with external identifier EXTID.
|
|
|
1958 Optional argument TYPE should be the type of entity and NAME should be
|
|
|
1959 the entity name."
|
|
|
1960 ;; extid is (pubid . sysid)
|
|
|
1961 (let ((pubid (sgml-extid-pubid extid)))
|
|
|
1962 (when pubid (setq pubid (sgml-canonize-pubid pubid)))
|
|
2
|
1963 (sgml-trace-lookup "Start looking for %s entity %s public %s system %s"
|
|
|
1964 (or type "-")
|
|
|
1965 (or name "?")
|
|
|
1966 pubid
|
|
|
1967 (sgml-extid-sysid extid))
|
|
78
|
1968 (or (if (and sgml-system-identifiers-are-preferred
|
|
|
1969 (sgml-extid-sysid extid))
|
|
|
1970 (or (sgml-lookup-sysid-as-file extid)
|
|
|
1971 (sgml-path-lookup ;Try the path also, but only using sysid
|
|
|
1972 (sgml-make-extid nil (sgml-extid-sysid extid))
|
|
|
1973 nil nil)))
|
|
0
|
1974 (sgml-catalog-lookup sgml-current-localcat pubid type name)
|
|
|
1975 (sgml-catalog-lookup sgml-catalog-files pubid type name)
|
|
|
1976 (if (not sgml-system-identifiers-are-preferred)
|
|
|
1977 (sgml-lookup-sysid-as-file extid))
|
|
|
1978 (sgml-path-lookup extid type name))))
|
|
|
1979
|
|
|
1980 (defun sgml-lookup-sysid-as-file (extid)
|
|
|
1981 (let ((sysid (sgml-extid-sysid extid)))
|
|
|
1982 (and sysid
|
|
|
1983 (loop for pat in sgml-public-map
|
|
|
1984 never (string-match "%[Ss]" pat))
|
|
|
1985 (file-readable-p (setq sysid (sgml-extid-expand sysid extid)))
|
|
|
1986 sysid)))
|
|
|
1987
|
|
|
1988 (defun sgml-insert-external-entity (extid &optional type name)
|
|
|
1989 "Insert the contents of an external entity at point.
|
|
|
1990 EXTID is the external identifier of the entity. Optional arguments TYPE
|
|
|
1991 is the entity type and NAME is the entity name, used to find the entity.
|
|
|
1992 Returns nil if entity is not found."
|
|
|
1993 (let* ((pubid (sgml-extid-pubid extid))
|
|
|
1994 (sysid (sgml-extid-sysid extid)))
|
|
|
1995 (or (if sysid
|
|
|
1996 (loop for fn in sgml-sysid-resolve-functions
|
|
|
1997 thereis (funcall fn sysid)))
|
|
|
1998 (let ((file (sgml-external-file extid type name)))
|
|
|
1999 (and file (insert-file-contents file)))
|
|
|
2000 (progn
|
|
|
2001 (sgml-log-warning "External entity %s not found" name)
|
|
|
2002 (when pubid
|
|
|
2003 (sgml-log-warning " Public identifier %s" pubid))
|
|
|
2004 (when sysid
|
|
|
2005 (sgml-log-warning " System identfier %s" sysid))
|
|
|
2006 nil))))
|
|
|
2007
|
|
|
2008
|
|
|
2009 ;; Parse a buffer full of catalogue entries.
|
|
|
2010 (defun sgml-parse-catalog-buffer ()
|
|
|
2011 "Parse all entries in a catalogue."
|
|
2
|
2012 (sgml-trace-lookup " (Parsing catalog)")
|
|
0
|
2013 (loop
|
|
|
2014 while (sgml-skip-cs)
|
|
|
2015 for type = (downcase (sgml-check-cat-literal))
|
|
|
2016 for class = (cdr (assoc type '(("public" . public) ("dtddecl" . public)
|
|
|
2017 ("entity" . name) ("linktype" . name)
|
|
|
2018 ("doctype" . name) ("sgmldecl" . noname)
|
|
|
2019 ("document" . noname))))
|
|
|
2020 when (not (null class))
|
|
|
2021 collect
|
|
|
2022 (let* ((name
|
|
|
2023 (cond ((eq class 'public)
|
|
|
2024 (sgml-skip-cs)
|
|
|
2025 (sgml-canonize-pubid (sgml-check-minimum-literal)))
|
|
|
2026 ((string= type "doctype")
|
|
|
2027 (sgml-general-case (sgml-check-cat-literal)))
|
|
|
2028 ((eq class 'name)
|
|
|
2029 (sgml-entity-case (sgml-check-cat-literal)))))
|
|
|
2030 (file
|
|
|
2031 (expand-file-name (sgml-check-cat-literal))))
|
|
|
2032 (list (intern type) name file))))
|
|
|
2033
|
|
|
2034
|
|
|
2035 (defun sgml-check-cat-literal ()
|
|
|
2036 "Read the next catalog token.
|
|
|
2037 Skips any leading spaces/comments."
|
|
|
2038 (sgml-skip-cs)
|
|
|
2039 (or (sgml-parse-literal)
|
|
|
2040 (buffer-substring-no-properties
|
|
|
2041 (point)
|
|
|
2042 (progn (skip-chars-forward "^ \r\n\t")
|
|
|
2043 (point)))))
|
|
|
2044
|
|
|
2045 (defconst sgml-formal-pubid-regexp
|
|
|
2046 (concat
|
|
|
2047 "^\\(+//\\|-//\\|\\)" ; Registered indicator [1]
|
|
|
2048 "\\(\\([^/]\\|/[^/]\\)+\\)" ; Owner [2]
|
|
|
2049 "//"
|
|
|
2050 "\\([^ ]+\\)" ; Text class [4]
|
|
|
2051 " "
|
|
|
2052 "\\(\\([^/]\\|/[^/]\\)*\\)" ; Text description [5]
|
|
|
2053 "//"
|
|
|
2054 "\\(\\([^/]\\|/[^/]\\)*\\)" ; Language [7]
|
|
|
2055 "\\(//" ; [9]
|
|
|
2056 "\\(\\([^/]\\|/[^/]\\)*\\)" ; Version [10]
|
|
|
2057 "\\)?"))
|
|
|
2058
|
|
|
2059 (defun sgml-pubid-parts (pubid)
|
|
|
2060 (nconc
|
|
|
2061 (if (string-match sgml-formal-pubid-regexp pubid)
|
|
|
2062 (nconc
|
|
|
2063 (list
|
|
|
2064 (cons ?o (sgml-transliterate-file (sgml-matched-string pubid 2)))
|
|
|
2065 (cons ?c (downcase (sgml-matched-string pubid 4)))
|
|
|
2066 (cons ?d (sgml-transliterate-file (sgml-matched-string pubid 5)))
|
|
|
2067 ;; t alias for d (%T used by sgmls)
|
|
|
2068 (cons ?t (sgml-transliterate-file (sgml-matched-string pubid 5)))
|
|
|
2069 (cons ?l (downcase (sgml-matched-string pubid 7))))
|
|
|
2070 (if (match-beginning 9)
|
|
|
2071 (list (cons ?v (sgml-transliterate-file
|
|
|
2072 (sgml-matched-string pubid 10)))))))))
|
|
|
2073
|
|
|
2074 (defun sgml-canonize-pubid (pubid)
|
|
|
2075 (if (string-match sgml-formal-pubid-regexp pubid)
|
|
|
2076 (concat
|
|
|
2077 (sgml-matched-string pubid 1) ; registered indicator
|
|
|
2078 (sgml-matched-string pubid 2) ; Owner
|
|
|
2079 "//"
|
|
|
2080 (upcase (sgml-matched-string pubid 4)) ; class
|
|
|
2081 " "
|
|
|
2082 (sgml-matched-string pubid 5) ; Text description
|
|
|
2083 "//"
|
|
|
2084 (upcase (sgml-matched-string pubid 7)) ; Language
|
|
|
2085 "//"
|
|
|
2086 (if (match-beginning 9)
|
|
|
2087 (sgml-matched-string pubid 10) ""))))
|
|
|
2088
|
|
|
2089 (defun sgml-transliterate-file (string)
|
|
|
2090 (mapconcat (function (lambda (c)
|
|
|
2091 (char-to-string
|
|
|
2092 (or (cdr-safe (assq c sgml-public-transliterations))
|
|
|
2093 c))))
|
|
|
2094 string ""))
|
|
|
2095
|
|
|
2096 (defun sgml-subst-expand-char (c parts)
|
|
|
2097 (cdr-safe (assq (downcase c) parts)))
|
|
|
2098
|
|
|
2099 (defun sgml-subst-expand (s parts)
|
|
|
2100 (loop for i from 0 to (1- (length s))
|
|
|
2101 as c = (aref s i)
|
|
|
2102 concat (if (eq c ?%)
|
|
|
2103 (or (sgml-subst-expand-char (aref s (incf i)) parts)
|
|
|
2104 (return nil))
|
|
|
2105 (char-to-string (aref s i)))))
|
|
|
2106
|
|
|
2107 (defun sgml-matched-string (string n &optional regexp noerror)
|
|
|
2108 (let ((res (if regexp
|
|
|
2109 (or (string-match regexp string)
|
|
|
2110 noerror
|
|
|
2111 (error "String match fail")))))
|
|
|
2112 (if (or (null regexp)
|
|
|
2113 (numberp res))
|
|
|
2114 (substring string (match-beginning n)
|
|
|
2115 (match-end n)))))
|
|
|
2116
|
|
|
2117 ;;;; Files for SGML declaration and DOCTYPE declaration
|
|
|
2118
|
|
|
2119 (defun sgml-declaration ()
|
|
|
2120 (or sgml-declaration
|
|
|
2121 (if sgml-doctype
|
|
|
2122 (sgml-in-file-eval sgml-doctype
|
|
|
2123 '(sgml-declaration)))
|
|
|
2124 (if sgml-parent-document
|
|
|
2125 (sgml-in-file-eval (car sgml-parent-document)
|
|
|
2126 '(sgml-declaration)))
|
|
|
2127 ;; *** check for sgmldecl comment
|
|
|
2128 (sgml-external-file nil 'sgmldecl)
|
|
|
2129 )
|
|
|
2130 )
|
|
|
2131
|
|
|
2132 (defun sgml-in-file-eval (file expr)
|
|
|
2133 (let ((cb (current-buffer)))
|
|
|
2134 (set-buffer (find-file-noselect file))
|
|
|
2135 (prog1 (eval expr)
|
|
|
2136 (set-buffer cb))))
|
|
|
2137
|
|
|
2138
|
|
|
2139 ;;;; Entity references and positions
|
|
|
2140
|
|
|
2141 (defstruct (sgml-eref
|
|
|
2142 (:constructor sgml-make-eref (entity start end))
|
|
|
2143 (:type list))
|
|
|
2144 entity
|
|
|
2145 start ; type: epos
|
|
|
2146 end)
|
|
|
2147
|
|
|
2148 (defun sgml-make-epos (eref pos)
|
|
|
2149 (cons eref pos))
|
|
|
2150
|
|
|
2151 (defun sgml-epos-eref (epos)
|
|
|
2152 (if (consp epos)
|
|
|
2153 (car epos)))
|
|
|
2154
|
|
|
2155 (defun sgml-epos-pos (epos)
|
|
2
|
2156 "The buffer position of EPOS withing its entity."
|
|
0
|
2157 (if (consp epos)
|
|
|
2158 (cdr epos)
|
|
|
2159 epos))
|
|
|
2160
|
|
|
2161 (defun sgml-bpos-p (epos)
|
|
2
|
2162 "True if EPOS is a position in the main buffer."
|
|
0
|
2163 (numberp epos))
|
|
|
2164
|
|
|
2165 (defun sgml-strict-epos-p (epos)
|
|
2
|
2166 "True if EPOS is a position in an entity other then the main buffer."
|
|
0
|
2167 (consp epos))
|
|
|
2168
|
|
|
2169 (defun sgml-epos (pos)
|
|
|
2170 "Convert a buffer position POS into an epos."
|
|
|
2171 (if sgml-current-eref
|
|
|
2172 (sgml-make-epos sgml-current-eref pos)
|
|
|
2173 pos))
|
|
|
2174
|
|
2
|
2175 (defun sgml-epos-before (epos)
|
|
|
2176 "The last position in buffer not after EPOS.
|
|
|
2177 If EPOS is a buffer position this is the same. If EPOS is in an entity
|
|
|
2178 this is the buffer position before the entity reference."
|
|
0
|
2179 (while (consp epos)
|
|
|
2180 (setq epos (sgml-eref-start (sgml-epos-eref epos))))
|
|
|
2181 epos)
|
|
|
2182
|
|
2
|
2183 (defun sgml-epos-after (epos)
|
|
|
2184 "The first position in buffer after EPOS.
|
|
|
2185 If EPOS is in an other entity, buffer position is after
|
|
|
2186 entity reference leading to EPOS."
|
|
0
|
2187 (while (consp epos)
|
|
|
2188 (setq epos (sgml-eref-end (sgml-epos-eref epos))))
|
|
|
2189 epos)
|
|
|
2190
|
|
|
2191 (defun sgml-epos-promote (epos)
|
|
2
|
2192 "Convert position in entity structure EPOS to a buffer position.
|
|
|
2193 If EPOS is in an entity, the buffer position will be the position
|
|
|
2194 before the entity reference if EPOS is first character in entity
|
|
|
2195 text. Otherwise buffer position will be after entity reference."
|
|
0
|
2196 (while (and (consp epos)
|
|
|
2197 (= (cdr epos) 1))
|
|
|
2198 (setq epos (sgml-eref-start (car epos))))
|
|
2
|
2199 (sgml-epos-after epos))
|
|
0
|
2200
|
|
|
2201
|
|
|
2202 ;;;; DTD repository
|
|
|
2203 ;;compiled-dtd: extid -> Compiled-DTD?
|
|
|
2204 ;;extid-cdtd-name: extid -> file?
|
|
|
2205 ;;up-to-date-p: (file, dependencies) -> cond
|
|
|
2206
|
|
|
2207 ;; Emacs Catalogues:
|
|
|
2208 ;; Syntax:
|
|
|
2209 ;; ecat ::= (cs | ecat-entry)*
|
|
|
2210 ;; cs ::= (s | comment)
|
|
|
2211 ;; ecat-entry ::= (pub-entry | file-entry)
|
|
|
2212 ;; pub-entry ::= ("PUBLIC", minimal literal, ent-spec?, cat literal)
|
|
|
2213 ;; pub-entry ::= ("FILE", literal, ent-spec?, cat literal)
|
|
|
2214 ;; ent-spec ::= ("[", (name, literal)*, "]")
|
|
|
2215
|
|
|
2216 ;; Parsed ecat = (eent*)
|
|
|
2217 ;; eent = (type ...)
|
|
|
2218 ;; = ('public pubid cfile . ents)
|
|
|
2219 ;; = ('file file cfile . ents)
|
|
|
2220
|
|
|
2221 (defun sgml-load-ecat (file)
|
|
|
2222 "Return ecat for FILE."
|
|
|
2223 (sgml-cache-catalog
|
|
|
2224 file 'sgml-ecat-assoc
|
|
|
2225 (function
|
|
|
2226 (lambda ()
|
|
|
2227 (let (new type ents from to name val)
|
|
|
2228 (while (progn (sgml-skip-cs)
|
|
|
2229 (setq type (sgml-parse-name)))
|
|
|
2230 (setq type (intern (downcase type)))
|
|
|
2231 (setq ents nil from nil)
|
|
|
2232 (sgml-skip-cs)
|
|
|
2233 (cond
|
|
|
2234 ((eq type 'public)
|
|
|
2235 (setq from (sgml-canonize-pubid (sgml-check-minimum-literal))))
|
|
|
2236 ((eq type 'file)
|
|
|
2237 (setq from (expand-file-name (sgml-check-cat-literal)))))
|
|
|
2238 (cond
|
|
|
2239 ((null from)
|
|
|
2240 (error "Syntax error in ECAT: %s" file))
|
|
|
2241 (t
|
|
|
2242 (sgml-skip-cs)
|
|
|
2243 (when (sgml-parse-char ?\[)
|
|
|
2244 (while (progn (sgml-skip-cs)
|
|
|
2245 (setq name (sgml-parse-name t)))
|
|
|
2246 (sgml-skip-cs)
|
|
|
2247 (setq val (sgml-check-literal))
|
|
|
2248 (push (cons name val) ents))
|
|
|
2249 (sgml-check-char ?\])
|
|
|
2250 (sgml-skip-cs))
|
|
|
2251 (setq to (expand-file-name (sgml-check-cat-literal)))
|
|
|
2252 (push (cons type (cons from (cons to ents)))
|
|
|
2253 new))))
|
|
|
2254 (nreverse new))))))
|
|
|
2255
|
|
|
2256 (defun sgml-ecat-lookup (files pubid file)
|
|
|
2257 "Return (file . ents) or nil."
|
|
|
2258 (let ((params (sgml-dtd-parameters sgml-dtd-info)))
|
|
|
2259 (loop
|
|
|
2260 for f in files
|
|
|
2261 do (sgml-debug "Search ECAT %s" f)
|
|
|
2262 thereis
|
|
|
2263 (loop
|
|
|
2264 for (type name cfile . ents) in (sgml-load-ecat f)
|
|
|
2265 thereis
|
|
|
2266 (if (and (cond ((eq type 'public) (equal name pubid))
|
|
|
2267 ((eq type 'file) (equal name file)))
|
|
|
2268 (loop for (name . val) in ents
|
|
|
2269 for entity = (sgml-lookup-entity name params)
|
|
|
2270 always (and entity
|
|
|
2271 (equal val (sgml-entity-text entity)))))
|
|
|
2272 (cons cfile ents))))))
|
|
|
2273
|
|
|
2274 ;;(let ((sgml-dtd-info (sgml-make-dtd nil)))
|
|
|
2275 ;; (sgml-ecat-lookup sgml-ecat-files
|
|
|
2276 ;; "-//lenst//DTD My DTD//EN//"
|
|
|
2277 ;; "/home/u5/lenst/src/psgml/bar.dtd"))
|
|
|
2278
|
|
|
2279
|
|
|
2280 ;;;; Merge compiled dtd
|
|
|
2281
|
|
|
2282 (defun sgml-try-merge-compiled-dtd (pubid file)
|
|
|
2283 (when pubid (setq pubid (sgml-canonize-pubid pubid)))
|
|
|
2284 (when file (setq file (expand-file-name file)))
|
|
|
2285 (sgml-debug "Find compiled dtd for %s %s" pubid file)
|
|
|
2286 (let ((ce (or (sgml-ecat-lookup sgml-current-local-ecat pubid file)
|
|
2
|
2287 (sgml-ecat-lookup sgml-ecat-files pubid file))))
|
|
0
|
2288 (and ce
|
|
|
2289 (let ((cfile (car ce))
|
|
|
2290 (ents (cdr ce)))
|
|
|
2291 (sgml-debug "Found %s" cfile)
|
|
|
2292 (if (sgml-use-special-case)
|
|
|
2293 (sgml-try-merge-special-case pubid file cfile ents)
|
|
|
2294 (and (sgml-bdtd-load cfile file ents)
|
|
|
2295 (sgml-bdtd-merge)))))))
|
|
|
2296
|
|
|
2297 (defun sgml-use-special-case ()
|
|
|
2298 (and (null (sgml-dtd-merged sgml-dtd-info))
|
|
|
2299 (sgml-eltype-table-empty (sgml-dtd-eltypes sgml-dtd-info))
|
|
|
2300 (eq 'dtd (sgml-entity-type (sgml-eref-entity sgml-current-eref)))))
|
|
|
2301
|
|
|
2302 (defun sgml-try-merge-special-case (pubid file cfile ents)
|
|
|
2303 (let (cdtd)
|
|
|
2304 (sgml-debug "Merging special case")
|
|
|
2305 ;; Look for a compiled dtd in som other buffer
|
|
|
2306 (let ((cb (current-buffer)))
|
|
|
2307 (loop for b in (buffer-list)
|
|
|
2308 until
|
|
|
2309 (progn (set-buffer b)
|
|
|
2310 (and sgml-buffer-parse-state
|
|
|
2311 (let ((m (sgml-dtd-merged
|
|
|
2312 (sgml-pstate-dtd sgml-buffer-parse-state))))
|
|
|
2313 (and m
|
|
|
2314 (string-equal cfile (car m))
|
|
|
2315 (setq cdtd (cdr m)))))))
|
|
|
2316 (set-buffer cb))
|
|
|
2317 ;; Load a new compiled dtd
|
|
|
2318 (unless cdtd
|
|
|
2319 (and (sgml-bdtd-load cfile file ents)
|
|
|
2320 (setq cdtd (sgml-bdtd-read-dtd))))
|
|
|
2321 ;; Do the merger
|
|
|
2322 (cond
|
|
|
2323 ((and cdtd
|
|
|
2324 (sgml-check-entities (sgml-dtd-parameters sgml-dtd-info)
|
|
|
2325 (sgml-dtd-parameters cdtd)))
|
|
|
2326 (setf (sgml-dtd-eltypes sgml-dtd-info)
|
|
|
2327 (sgml-dtd-eltypes cdtd))
|
|
|
2328 (sgml-merge-entity-tables (sgml-dtd-entities sgml-dtd-info)
|
|
|
2329 (sgml-dtd-entities cdtd))
|
|
|
2330 (sgml-merge-entity-tables (sgml-dtd-parameters sgml-dtd-info)
|
|
|
2331 (sgml-dtd-parameters cdtd))
|
|
|
2332 (sgml-merge-shortmaps (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
2333 (sgml-dtd-shortmaps cdtd))
|
|
|
2334 (setf (sgml-dtd-dependencies sgml-dtd-info)
|
|
|
2335 (nconc (sgml-dtd-dependencies sgml-dtd-info)
|
|
|
2336 (sgml-dtd-dependencies cdtd)))
|
|
|
2337 (setf (sgml-dtd-merged sgml-dtd-info) (cons cfile cdtd))))))
|
|
|
2338
|
|
|
2339
|
|
|
2340 ;;;; Pushing and poping entities
|
|
|
2341
|
|
|
2342 (defun sgml-push-to-entity (entity &optional ref-start type)
|
|
|
2343 "Set current buffer to a buffer containing the entity ENTITY.
|
|
|
2344 ENTITY can also be a file name. Optional argument REF-START should be
|
|
|
2345 the start point of the entity reference. Optional argument TYPE,
|
|
|
2346 overrides the entity type in entity look up."
|
|
2
|
2347 (sgml-debug "Push to %s"
|
|
|
2348 (cond ((stringp entity)
|
|
|
2349 (format "string '%s'" entity))
|
|
|
2350 (t
|
|
|
2351 (sgml-entity-name entity))))
|
|
0
|
2352 (when ref-start
|
|
2
|
2353 ;; don't consider a RS shortref here again
|
|
0
|
2354 (setq sgml-rs-ignore-pos ref-start))
|
|
|
2355 (unless (and sgml-scratch-buffer
|
|
|
2356 (buffer-name sgml-scratch-buffer))
|
|
|
2357 (setq sgml-scratch-buffer (generate-new-buffer " *entity*")))
|
|
|
2358 (let ((cb (current-buffer))
|
|
|
2359 (dd default-directory)
|
|
|
2360 ;;*** should eref be argument ?
|
|
|
2361 (eref (sgml-make-eref (if (stringp entity)
|
|
|
2362 (sgml-make-entity entity nil nil)
|
|
|
2363 entity)
|
|
|
2364 (sgml-epos (or ref-start (point)))
|
|
|
2365 (sgml-epos (point)))))
|
|
|
2366 (set-buffer sgml-scratch-buffer)
|
|
2
|
2367 ;; For MULE to not misinterpret binary data set the mc-flag
|
|
|
2368 ;; (reported by Jeffrey Friedl <jfriedl@nff.ncl.omron.co.jp>)
|
|
|
2369 (setq mc-flag nil)
|
|
|
2370 ;; For XEmacs 20.0/Mule
|
|
78
|
2371 (setq file-coding-system 'noconv)
|
|
0
|
2372 (when (eq sgml-scratch-buffer (default-value 'sgml-scratch-buffer))
|
|
|
2373 (make-local-variable 'sgml-scratch-buffer)
|
|
|
2374 (setq sgml-scratch-buffer nil))
|
|
2
|
2375 (when after-change-function ;***
|
|
|
2376 (message "OOPS: after-change-function not NIL in scratch buffer %s: %s"
|
|
|
2377 (current-buffer)
|
|
|
2378 after-change-function)
|
|
|
2379 (setq before-change-function nil
|
|
|
2380 after-change-function nil))
|
|
0
|
2381 (setq sgml-last-entity-buffer (current-buffer))
|
|
|
2382 (erase-buffer)
|
|
|
2383 (setq default-directory dd)
|
|
|
2384 (make-local-variable 'sgml-current-eref)
|
|
|
2385 (setq sgml-current-eref eref)
|
|
|
2386 (set-syntax-table sgml-parser-syntax)
|
|
|
2387 (make-local-variable 'sgml-previous-buffer)
|
|
|
2388 (setq sgml-previous-buffer cb)
|
|
|
2389 (setq sgml-rs-ignore-pos ; don't interpret beginning of buffer
|
|
|
2390 ; as #RS if internal entity.
|
|
|
2391 (if (or (stringp entity)
|
|
|
2392 (stringp (sgml-entity-text entity)))
|
|
|
2393 (point)
|
|
|
2394 0))
|
|
2
|
2395 (when sgml-buffer-parse-state
|
|
|
2396 (sgml-debug "-- pstate set in scratch buffer")
|
|
|
2397 (setq sgml-buffer-parse-state nil))
|
|
0
|
2398 (cond
|
|
|
2399 ((stringp entity) ; a file name
|
|
|
2400 (save-excursion (insert-file-contents entity))
|
|
|
2401 (setq default-directory (file-name-directory entity)))
|
|
2
|
2402 ((consp (sgml-entity-text entity)) ; external id?
|
|
|
2403 (let* ((extid (sgml-entity-text entity))
|
|
|
2404 (file
|
|
|
2405 (sgml-external-file extid
|
|
|
2406 (or type (sgml-entity-type entity))
|
|
|
2407 (sgml-entity-name entity))))
|
|
|
2408 (when sgml-parsing-dtd
|
|
|
2409 (push (or file t)
|
|
|
2410 (sgml-dtd-dependencies sgml-dtd-info)))
|
|
|
2411 (sgml-debug "Push to %s = %s" extid file)
|
|
0
|
2412 (cond
|
|
2
|
2413 ((and file sgml-parsing-dtd
|
|
|
2414 (sgml-try-merge-compiled-dtd (sgml-extid-pubid extid)
|
|
0
|
2415 file))
|
|
|
2416 (goto-char (point-max)))
|
|
|
2417 (file
|
|
|
2418 ;; fifth arg not available in early v19
|
|
|
2419 (erase-buffer)
|
|
|
2420 (insert-file-contents file nil nil nil)
|
|
|
2421 (setq default-directory (file-name-directory file))
|
|
2
|
2422 (goto-char (point-min)))
|
|
|
2423 (t ;; No file for entity
|
|
|
2424 (save-excursion
|
|
|
2425 (let* ((pubid (sgml-extid-pubid extid))
|
|
|
2426 (sysid (sgml-extid-sysid extid)))
|
|
|
2427 (or (if sysid ; try the sysid hooks
|
|
|
2428 (loop for fn in sgml-sysid-resolve-functions
|
|
|
2429 thereis (funcall fn sysid)))
|
|
|
2430 (progn
|
|
|
2431 ;; Mark entity as not found
|
|
|
2432 (setcdr (cddr entity) t) ;***
|
|
|
2433 (sgml-log-warning "External entity %s not found"
|
|
|
2434 (sgml-entity-name entity))
|
|
|
2435 (when pubid
|
|
|
2436 (sgml-log-warning " Public identifier %s" pubid))
|
|
|
2437 (when sysid
|
|
|
2438 (sgml-log-warning " System identfier %s" sysid))
|
|
|
2439 nil))))))))
|
|
|
2440 (t ;; internal entity
|
|
|
2441 (save-excursion
|
|
|
2442 (insert (sgml-entity-text entity)))))))
|
|
0
|
2443
|
|
|
2444 (defun sgml-pop-entity ()
|
|
|
2445 (cond ((and (boundp 'sgml-previous-buffer)
|
|
|
2446 (bufferp sgml-previous-buffer))
|
|
|
2447 (sgml-debug "Exit entity")
|
|
|
2448 (setq sgml-last-entity-buffer sgml-previous-buffer)
|
|
|
2449 (set-buffer sgml-previous-buffer)
|
|
|
2450 t)))
|
|
|
2451
|
|
|
2452 (defun sgml-goto-epos (epos)
|
|
|
2453 "Goto a position in an entity given by EPOS."
|
|
|
2454 (assert epos)
|
|
|
2455 (cond ((sgml-bpos-p epos)
|
|
|
2456 (goto-char epos))
|
|
|
2457 (t
|
|
|
2458 (let ((eref (sgml-epos-eref epos)))
|
|
|
2459 (sgml-cleanup-entities)
|
|
|
2460 (sgml-goto-epos (sgml-eref-end eref))
|
|
|
2461 (sgml-push-to-entity (sgml-eref-entity eref)
|
|
|
2462 (sgml-epos-pos (sgml-eref-start eref))))
|
|
|
2463 (goto-char (sgml-epos-pos epos)))))
|
|
|
2464
|
|
|
2465 (defun sgml-pop-all-entities ()
|
|
|
2466 (while (sgml-pop-entity)))
|
|
|
2467
|
|
|
2468 (defun sgml-cleanup-entities ()
|
|
|
2469 (let ((cb (current-buffer))
|
|
|
2470 (n 0))
|
|
|
2471 (while (and sgml-scratch-buffer (buffer-name sgml-scratch-buffer))
|
|
|
2472 (set-buffer sgml-scratch-buffer)
|
|
|
2473 (assert (not (eq sgml-scratch-buffer
|
|
|
2474 (default-value 'sgml-scratch-buffer))))
|
|
|
2475 (incf n))
|
|
|
2476 (while (> n 10)
|
|
|
2477 (set-buffer (prog1 sgml-previous-buffer
|
|
|
2478 (kill-buffer (current-buffer))))
|
|
|
2479 (decf n))
|
|
|
2480 (set-buffer cb)))
|
|
|
2481
|
|
|
2482 (defun sgml-any-open-param/file ()
|
|
|
2483 "Return true if there currently is a parameter or file open."
|
|
|
2484 (and (boundp 'sgml-previous-buffer)
|
|
|
2485 sgml-previous-buffer))
|
|
|
2486
|
|
|
2487
|
|
|
2488 ;;;; Parse tree
|
|
|
2489
|
|
|
2490 (defstruct (sgml-tree
|
|
|
2491 (:type vector)
|
|
|
2492 (:constructor sgml-make-tree
|
|
|
2493 (eltype stag-epos stag-len parent level
|
|
|
2494 excludes includes pstate net-enabled
|
|
|
2495 conref &optional shortmap pshortmap asl)))
|
|
|
2496 eltype ; element object
|
|
2
|
2497 ;;start ; start point in buffer
|
|
0
|
2498 ;;end ; end point in buffer
|
|
|
2499 stag-epos ; start-tag entity position
|
|
|
2500 etag-epos ; end-tag entity position
|
|
|
2501 stag-len ; length of start-tag
|
|
|
2502 etag-len ; length of end-tag
|
|
|
2503 parent ; parent tree
|
|
|
2504 level ; depth of this node
|
|
|
2505 excludes ; current excluded elements
|
|
|
2506 includes ; current included elements
|
|
|
2507 pstate ; state in parent
|
|
|
2508 next ; next sibling tree
|
|
|
2509 content ; child trees
|
|
|
2510 net-enabled ; if NET enabled (t this element,
|
|
|
2511 ; other non-nil, some parent)
|
|
|
2512 conref ; if conref attribute used
|
|
|
2513 shortmap ; shortmap at start of element
|
|
|
2514 pshortmap ; parents shortmap
|
|
|
2515 asl ; attribute specification list
|
|
|
2516 )
|
|
|
2517
|
|
|
2518
|
|
|
2519 (defun sgml-tree-end (tree)
|
|
2
|
2520 "Buffer position after end of TREE."
|
|
0
|
2521 (let ((epos (sgml-tree-etag-epos tree))
|
|
|
2522 (len (sgml-tree-etag-len tree)))
|
|
|
2523 (cond ((sgml-bpos-p epos)
|
|
|
2524 (+ epos len))
|
|
|
2525 ((zerop len)
|
|
|
2526 (sgml-epos-promote epos))
|
|
|
2527 (t
|
|
2
|
2528 (sgml-epos-after epos)))))
|
|
0
|
2529
|
|
|
2530
|
|
|
2531 ;;;; (text) Element view of parse tree
|
|
|
2532
|
|
|
2533 (defmacro sgml-alias-fields (orig dest &rest fields)
|
|
|
2534 (let ((macs nil))
|
|
|
2535 (while fields
|
|
|
2536 (push
|
|
|
2537 (` (defmacro (, (intern (format "%s-%s" dest (car fields)))) (element)
|
|
|
2538 (, (format "Return %s field of ELEMENT." (car fields)))
|
|
|
2539 (list
|
|
|
2540 '(, (intern (format "%s-%s" orig (car fields))))
|
|
|
2541 element)))
|
|
|
2542 macs)
|
|
|
2543 (setq fields (cdr fields)))
|
|
|
2544 (cons 'progn macs)))
|
|
|
2545
|
|
|
2546 (sgml-alias-fields sgml-tree sgml-element
|
|
|
2547 eltype ; element object
|
|
|
2548 ;; start ; start point in buffer
|
|
|
2549 stag-epos
|
|
|
2550 etag-epos
|
|
|
2551 stag-len ; length of start-tag
|
|
|
2552 etag-len ; length of end-tag
|
|
|
2553 parent ; parent tree
|
|
|
2554 level ; depth of this node
|
|
|
2555 excludes ; current excluded elements
|
|
|
2556 includes ; current included elements
|
|
|
2557 pstate ; state in parent
|
|
|
2558 net-enabled ; if NET enabled
|
|
|
2559 )
|
|
|
2560
|
|
|
2561 (defun sgml-element-model (element)
|
|
|
2562 "Declared content or content model of ELEMENT."
|
|
|
2563 (sgml-eltype-model (sgml-tree-eltype element)))
|
|
|
2564
|
|
|
2565 (defun sgml-element-name (element)
|
|
|
2566 "Return name (symbol) of ELEMENT."
|
|
|
2567 (sgml-tree-eltype element))
|
|
|
2568
|
|
|
2569 (defun sgml-element-gi (element)
|
|
|
2570 "Return general identifier (string) of ELEMENT."
|
|
|
2571 (sgml-eltype-name (sgml-tree-eltype element)))
|
|
|
2572
|
|
|
2573 (defun sgml-element-appdata (element prop)
|
|
|
2574 "Return the application data named PROP associated with the type of ELEMENT."
|
|
|
2575 (sgml-eltype-appdata (sgml-tree-eltype element) prop))
|
|
|
2576
|
|
|
2577 (defmacro sgml-element-stag-optional (element)
|
|
|
2578 "True if start-tag of ELEMENT is omissible."
|
|
|
2579 (`(sgml-eltype-stag-optional (sgml-tree-eltype (, element)))))
|
|
|
2580
|
|
|
2581 (defun sgml-element-etag-optional (element)
|
|
|
2582 "True if end-tag of ELEMENT is omissible."
|
|
|
2583 (sgml-eltype-etag-optional (sgml-tree-eltype element)))
|
|
|
2584
|
|
|
2585 (define-compiler-macro sgml-element-etag-optional (element)
|
|
|
2586 "True if end-tag of ELEMENT is omissible."
|
|
|
2587 (`(sgml-eltype-etag-optional (sgml-tree-eltype (, element)))))
|
|
|
2588
|
|
|
2589 (defun sgml-element-attlist (element)
|
|
|
2590 "Return the attribute specification list of ELEMENT."
|
|
|
2591 (sgml-eltype-attlist (sgml-tree-eltype element)))
|
|
|
2592
|
|
|
2593 (defun sgml-element-mixed (element)
|
|
|
2594 "True if ELEMENT has mixed content."
|
|
|
2595 (sgml-eltype-mixed (sgml-tree-eltype element)))
|
|
|
2596
|
|
|
2597 (define-compiler-macro sgml-element-mixed (element)
|
|
|
2598 (`(sgml-eltype-mixed (sgml-tree-eltype (, element)))))
|
|
|
2599
|
|
|
2600 (defun sgml-element-start (element)
|
|
|
2601 "Position before start of ELEMENT."
|
|
|
2602 (sgml-epos-promote (sgml-tree-stag-epos element)))
|
|
|
2603
|
|
|
2604 (defun sgml-element-stag-end (element)
|
|
|
2605 "Position after start-tag of ELEMENT."
|
|
|
2606 (let ((epos (sgml-tree-stag-epos element))
|
|
|
2607 (len (sgml-tree-stag-len element)))
|
|
|
2608 (cond ((sgml-bpos-p epos)
|
|
|
2609 (+ epos len))
|
|
|
2610 ((zerop len)
|
|
|
2611 (sgml-epos-promote epos))
|
|
|
2612 (t
|
|
2
|
2613 (sgml-epos-after epos)))))
|
|
0
|
2614
|
|
|
2615 (defun sgml-element-empty (element)
|
|
|
2616 "True if ELEMENT is empty."
|
|
|
2617 (or (eq sgml-empty (sgml-element-model element))
|
|
|
2618 (sgml-tree-conref element)))
|
|
|
2619
|
|
|
2620 (defun sgml-element-data-p (element)
|
|
|
2621 "True if ELEMENT can have data characters in its content."
|
|
|
2622 (or (sgml-element-mixed element)
|
|
|
2623 (eq sgml-cdata (sgml-element-model element))
|
|
|
2624 (eq sgml-rcdata (sgml-element-model element))))
|
|
|
2625
|
|
|
2626 (defun sgml-element-context-string (element)
|
|
|
2627 "Return string describing context of ELEMENT."
|
|
|
2628 (if (eq element sgml-top-tree)
|
|
|
2629 ""
|
|
|
2630 (format "in %s %s"
|
|
|
2631 (sgml-element-gi element)
|
|
|
2632 (sgml-element-context-string (sgml-tree-parent element)))))
|
|
|
2633
|
|
|
2634 ;;;; Display and Mode-line
|
|
|
2635
|
|
|
2636 (defun sgml-update-display ()
|
|
|
2637 (when (not (eq this-command 'keyboard-quit))
|
|
|
2638 ;; Don't let point be inside an invisible region
|
|
|
2639 (when (and (get-text-property (point) 'invisible)
|
|
|
2640 (eq (get-text-property (point) 'invisible)
|
|
|
2641 (get-text-property (1- (point)) 'invisible)))
|
|
|
2642 (setq sgml-last-element nil) ; May not be valid after point moved
|
|
|
2643 (if (memq this-command '(backward-char previous-line backward-word))
|
|
|
2644 (goto-char (or (previous-single-property-change (point) 'invisible)
|
|
|
2645 (point-min)))
|
|
|
2646 (goto-char (or (next-single-property-change (point) 'invisible)
|
|
|
2647 (point-max)))))
|
|
2
|
2648 (when (and (not executing-macro)
|
|
0
|
2649 (or sgml-live-element-indicator
|
|
2
|
2650 sgml-set-face)
|
|
|
2651 (not (null sgml-buffer-parse-state))
|
|
|
2652 (sit-for 0))
|
|
|
2653 (let ((deactivate-mark nil))
|
|
|
2654 (sgml-need-dtd)
|
|
|
2655 (let ((start
|
|
|
2656 (save-excursion (sgml-find-start-point (point))
|
|
|
2657 (sgml-pop-all-entities)
|
|
|
2658 (point)))
|
|
|
2659 (eol-pos
|
|
|
2660 (save-excursion (end-of-line 1) (point))))
|
|
|
2661 (let ((quiet (< (- (point) start) 500)))
|
|
|
2662 ;;(message "Should parse %s to %s => %s" start (point) quiet)
|
|
|
2663 (when (if quiet
|
|
|
2664 t
|
|
|
2665 (setq sgml-current-element-name "?")
|
|
|
2666 (sit-for 1))
|
|
|
2667
|
|
|
2668 ;; Find current element
|
|
0
|
2669 (cond ((and (memq this-command sgml-users-of-last-element)
|
|
|
2670 sgml-last-element)
|
|
|
2671 (setq sgml-current-element-name
|
|
|
2672 (sgml-element-gi sgml-last-element)))
|
|
|
2673 (sgml-live-element-indicator
|
|
|
2674 (save-excursion
|
|
2
|
2675 (condition-case nil
|
|
|
2676 (sgml-parse-to
|
|
|
2677 (point) (function input-pending-p) quiet)
|
|
|
2678 (error
|
|
|
2679 (setq sgml-current-element-name "*error*")))
|
|
|
2680 (unless (input-pending-p)
|
|
|
2681 (setq sgml-current-element-name
|
|
|
2682 (sgml-element-gi sgml-current-tree))))))
|
|
|
2683 ;; Set face on current line
|
|
|
2684 (when (and sgml-set-face (not (input-pending-p)))
|
|
|
2685 (save-excursion
|
|
|
2686 (condition-case nil
|
|
|
2687 (sgml-parse-to
|
|
|
2688 eol-pos (function input-pending-p) quiet)
|
|
|
2689 (error nil)))))))
|
|
|
2690 ;; Set face in rest of buffer
|
|
|
2691 (sgml-fontify-buffer 6) ;*** make option for delay
|
|
|
2692 ))))
|
|
|
2693
|
|
|
2694 (defun sgml-fontify-buffer (delay)
|
|
|
2695 (and
|
|
|
2696 sgml-set-face
|
|
|
2697 (null (sgml-tree-etag-epos
|
|
|
2698 (sgml-pstate-top-tree sgml-buffer-parse-state)))
|
|
|
2699 (sit-for delay)
|
|
|
2700 (condition-case nil
|
|
|
2701 (save-excursion
|
|
|
2702 (message "Fontifying...")
|
|
|
2703 (sgml-parse-until-end-of nil nil
|
|
|
2704 (function input-pending-p)
|
|
|
2705 t)
|
|
|
2706 (message "Fontifying...done"))
|
|
|
2707 (error nil))))
|
|
0
|
2708
|
|
|
2709 (defun sgml-set-active-dtd-indicator (name)
|
|
|
2710 (set (make-local-variable 'sgml-active-dtd-indicator)
|
|
|
2711 (list (format " [%s" name)
|
|
|
2712 '(sgml-live-element-indicator ("/" sgml-current-element-name))
|
|
|
2713 "]"))
|
|
|
2714 (force-mode-line-update))
|
|
|
2715
|
|
|
2716 ;;;; Parser state
|
|
|
2717
|
|
|
2718 (defstruct (sgml-pstate
|
|
|
2719 (:constructor sgml-make-pstate (dtd top-tree)))
|
|
|
2720 dtd
|
|
|
2721 top-tree)
|
|
|
2722
|
|
2
|
2723 ;(defsubst sgml-excludes ()
|
|
|
2724 ; (sgml-tree-excludes sgml-current-tree))
|
|
|
2725
|
|
|
2726 ;(defsubst sgml-includes ()
|
|
|
2727 ; (sgml-tree-includes sgml-current-tree))
|
|
0
|
2728
|
|
|
2729 (defsubst sgml-current-mixed-p ()
|
|
|
2730 (sgml-element-mixed sgml-current-tree))
|
|
|
2731
|
|
|
2732 (defun sgml-set-initial-state (dtd)
|
|
|
2733 "Set initial state of parsing"
|
|
|
2734 (make-local-variable 'before-change-function)
|
|
|
2735 (setq before-change-function 'sgml-note-change-at)
|
|
2
|
2736 (make-local-variable 'after-change-function)
|
|
|
2737 (setq after-change-function 'sgml-set-face-after-change)
|
|
0
|
2738 (sgml-set-active-dtd-indicator (sgml-dtd-doctype dtd))
|
|
|
2739 (let ((top-type ; Fake element type for the top
|
|
|
2740 ; node of the parse tree
|
|
|
2741 (sgml-make-eltype "#DOC") ; was "Document (no element)"
|
|
|
2742 ))
|
|
|
2743 (setf (sgml-eltype-model top-type)
|
|
|
2744 (sgml-make-primitive-content-token
|
|
|
2745 (sgml-eltype-token
|
|
|
2746 (sgml-lookup-eltype (sgml-dtd-doctype dtd) dtd))))
|
|
|
2747 (setq sgml-buffer-parse-state
|
|
|
2748 (sgml-make-pstate dtd
|
|
|
2749 (sgml-make-tree top-type
|
|
|
2750 0 0 nil 0 nil nil nil nil nil)))))
|
|
|
2751
|
|
|
2752 (defun sgml-set-parse-state (tree where)
|
|
|
2753 "Set parse state from TREE, either from start of TREE if WHERE is start
|
|
|
2754 or from after TREE if WHERE is after."
|
|
|
2755 (setq sgml-current-tree tree
|
|
2
|
2756 sgml-markup-tree tree
|
|
|
2757 sgml-rs-ignore-pos 0 )
|
|
0
|
2758 (let ((empty
|
|
|
2759 (sgml-element-empty tree)))
|
|
|
2760 (cond ((and (eq where 'start)
|
|
|
2761 (not empty))
|
|
|
2762 (setq sgml-current-state (sgml-element-model sgml-current-tree)
|
|
|
2763 sgml-current-shortmap (sgml-tree-shortmap sgml-current-tree)
|
|
|
2764 sgml-previous-tree nil)
|
|
|
2765 (setq sgml-markup-type
|
|
|
2766 (if (and (not (zerop (sgml-tree-stag-len tree)))
|
|
|
2767 (sgml-bpos-p (sgml-tree-stag-epos tree)))
|
|
|
2768 'start-tag)
|
|
|
2769 sgml-markup-start (sgml-element-start sgml-current-tree))
|
|
|
2770 (sgml-goto-epos (sgml-tree-stag-epos sgml-current-tree))
|
|
|
2771 (forward-char (sgml-tree-stag-len sgml-current-tree)))
|
|
|
2772 (t
|
|
|
2773 (setq sgml-current-state (sgml-tree-pstate sgml-current-tree)
|
|
|
2774 sgml-current-shortmap (sgml-tree-pshortmap sgml-current-tree)
|
|
|
2775 sgml-previous-tree sgml-current-tree)
|
|
|
2776 (sgml-goto-epos (sgml-tree-etag-epos sgml-current-tree))
|
|
|
2777 (forward-char (sgml-tree-etag-len sgml-current-tree))
|
|
|
2778 (setq sgml-markup-type (if empty 'start-tag 'end-tag)
|
|
|
2779 sgml-markup-start (- (point)
|
|
|
2780 (sgml-tree-etag-len sgml-current-tree)))
|
|
|
2781 (setq sgml-current-tree (sgml-tree-parent sgml-current-tree))))
|
|
|
2782 (assert sgml-current-state)))
|
|
|
2783
|
|
|
2784 (defsubst sgml-final-p (state)
|
|
|
2785 ;; Test if a state/model can be ended
|
|
|
2786 (or (not (sgml-model-group-p state))
|
|
|
2787 (sgml-final state)))
|
|
|
2788
|
|
|
2789 ;(defun sgml-current-element-contains-data ()
|
|
|
2790 ; "Retrun true if the current open element is either mixed or is (r)cdata."
|
|
|
2791 ; (or (eq sgml-cdata sgml-current-state)
|
|
|
2792 ; (eq sgml-rcdata sgml-current-state)
|
|
|
2793 ; (sgml-current-mixed-p)))
|
|
|
2794
|
|
|
2795 ;(defun sgml-current-element-content-class ()
|
|
|
2796 ; "Return a string describing the type of content in the current element.
|
|
|
2797 ;The type can be CDATA, RCDATA, ANY, #PCDATA or none."
|
|
|
2798 ; (cond ((eq sgml-cdata sgml-current-state)
|
|
|
2799 ; "CDATA")
|
|
|
2800 ; ((eq sgml-rcdata sgml-current-state)
|
|
|
2801 ; "RCDATA")
|
|
|
2802 ; ((eq sgml-any sgml-current-state)
|
|
|
2803 ; "ANY")
|
|
|
2804 ; ((sgml-current-mixed-p)
|
|
|
2805 ; "#PCDATA")
|
|
|
2806 ; (t "")))
|
|
|
2807
|
|
|
2808 (defun sgml-promoted-epos (start end)
|
|
|
2809 "Return an entity position for start of region START END.
|
|
|
2810 If region is empty, choose return an epos as high in the
|
|
|
2811 entity hierarchy as possible."
|
|
|
2812 ;; This does not work if the entity is entered by a shortref that
|
|
|
2813 ;; only is active in the current element.
|
|
|
2814 (let ((epos (sgml-epos start)))
|
|
|
2815 (when (= start end)
|
|
|
2816 (while (and (sgml-strict-epos-p epos)
|
|
|
2817 (= 1 (sgml-epos-pos epos)))
|
|
|
2818 (setq epos (sgml-eref-start (sgml-epos-eref epos)))))
|
|
|
2819 epos))
|
|
|
2820
|
|
|
2821 (defun sgml-open-element (eltype conref before-tag after-tag &optional asl)
|
|
|
2822 (unless (sgml-eltype-defined eltype)
|
|
|
2823 (setf (sgml-eltype-mixed eltype) t)
|
|
|
2824 (setf (sgml-eltype-etag-optional eltype) t)
|
|
|
2825 (when sgml-warn-about-undefined-elements
|
|
|
2826 (sgml-log-warning
|
|
|
2827 "Start-tag of undefined element %s; assume O O ANY"
|
|
|
2828 (sgml-eltype-name eltype))))
|
|
|
2829 (let* ((emap (sgml-eltype-shortmap eltype))
|
|
|
2830 (newmap (if emap
|
|
|
2831 (if (eq 'empty emap)
|
|
|
2832 nil
|
|
|
2833 (sgml-lookup-shortref-map
|
|
|
2834 (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
2835 emap))
|
|
|
2836 sgml-current-shortmap))
|
|
|
2837 (nt (sgml-make-tree
|
|
|
2838 eltype
|
|
|
2839 (sgml-promoted-epos before-tag after-tag) ; stag-epos
|
|
|
2840 (- after-tag before-tag) ; stag-len
|
|
|
2841 sgml-current-tree ; parent
|
|
|
2842 (1+ (sgml-tree-level sgml-current-tree)) ; level
|
|
2
|
2843 (append (sgml-eltype-excludes eltype)
|
|
|
2844 (sgml-tree-excludes sgml-current-tree))
|
|
|
2845 (append (sgml-eltype-includes eltype)
|
|
|
2846 (sgml-tree-includes sgml-current-tree))
|
|
0
|
2847 sgml-current-state
|
|
|
2848 (if (sgml-tree-net-enabled sgml-current-tree) 1)
|
|
|
2849 conref
|
|
|
2850 newmap
|
|
|
2851 sgml-current-shortmap
|
|
|
2852 asl)))
|
|
|
2853 ;; (let ((u (sgml-tree-content sgml-current-tree)))
|
|
|
2854 ;; (cond ((and u (> before-tag (sgml-element-start u)))
|
|
|
2855 ;; (while (and (sgml-tree-next u)
|
|
|
2856 ;; (> before-tag
|
|
|
2857 ;; (sgml-element-start (sgml-tree-next u))))
|
|
|
2858 ;; (setq u (sgml-tree-next u)))
|
|
|
2859 ;; (setf (sgml-tree-next u) nt))
|
|
|
2860 ;; (t
|
|
|
2861 ;; (setf (sgml-tree-content sgml-current-tree) nt))))
|
|
|
2862 ;; Install new node in tree
|
|
|
2863 (cond (sgml-previous-tree
|
|
2
|
2864 (sgml-debug "Open element %s: after %s"
|
|
|
2865 eltype (sgml-tree-eltype sgml-previous-tree))
|
|
0
|
2866 (setf (sgml-tree-next sgml-previous-tree) nt))
|
|
|
2867 (t
|
|
2
|
2868 (sgml-debug "Open element %s: first in %s"
|
|
|
2869 eltype (sgml-tree-eltype sgml-current-tree))
|
|
0
|
2870 (setf (sgml-tree-content sgml-current-tree) nt)))
|
|
|
2871 ;; Prune tree
|
|
|
2872 ;; *** all the way up? tree-end = nil?
|
|
|
2873 (setf (sgml-tree-next sgml-current-tree) nil)
|
|
|
2874 ;; Set new state
|
|
|
2875 (setq sgml-current-state (sgml-eltype-model eltype)
|
|
|
2876 sgml-current-shortmap newmap
|
|
|
2877 sgml-current-tree nt
|
|
|
2878 sgml-previous-tree nil)
|
|
|
2879 (assert sgml-current-state)
|
|
|
2880 (setq sgml-markup-tree sgml-current-tree)
|
|
|
2881 (run-hook-with-args 'sgml-open-element-hook sgml-current-tree asl)
|
|
|
2882 (when (sgml-element-empty sgml-current-tree)
|
|
|
2883 (sgml-close-element after-tag after-tag))))
|
|
|
2884
|
|
|
2885 (defun sgml-fake-open-element (tree el &optional state)
|
|
|
2886 (sgml-make-tree
|
|
|
2887 el 0 0
|
|
|
2888 tree
|
|
|
2889 0
|
|
|
2890 (append (sgml-eltype-excludes el) (sgml-tree-excludes tree))
|
|
|
2891 (append (sgml-eltype-includes el) (sgml-tree-includes tree))
|
|
|
2892 state
|
|
|
2893 nil
|
|
|
2894 nil))
|
|
|
2895
|
|
|
2896 (defun sgml-close-element (before-tag after-tag)
|
|
|
2897 (when (or (eq sgml-close-element-trap t)
|
|
|
2898 (eq sgml-close-element-trap sgml-current-tree))
|
|
|
2899 (setq sgml-goal (point)))
|
|
|
2900 (when sgml-throw-on-element-change
|
|
|
2901 (throw sgml-throw-on-element-change 'end))
|
|
2
|
2902 (sgml-debug "Close element %s" (sgml-tree-eltype sgml-current-tree))
|
|
0
|
2903 (setf (sgml-tree-etag-epos sgml-current-tree)
|
|
|
2904 ;;(sgml-promoted-epos before-tag after-tag)
|
|
|
2905 (sgml-epos before-tag))
|
|
|
2906 (setf (sgml-tree-etag-len sgml-current-tree) (- after-tag before-tag))
|
|
|
2907 (run-hooks 'sgml-close-element-hook)
|
|
|
2908 (setq sgml-markup-tree sgml-current-tree)
|
|
|
2909 (cond ((eq sgml-current-tree sgml-top-tree)
|
|
|
2910 (unless (eobp)
|
|
|
2911 (sgml-error "Parse ended")))
|
|
|
2912 (t
|
|
|
2913 (setq sgml-previous-tree sgml-current-tree
|
|
|
2914 sgml-current-state (sgml-tree-pstate sgml-current-tree)
|
|
|
2915 sgml-current-shortmap (sgml-tree-pshortmap sgml-current-tree)
|
|
|
2916 sgml-current-tree (sgml-tree-parent sgml-current-tree))
|
|
|
2917 (assert sgml-current-state))))
|
|
|
2918
|
|
|
2919 (defun sgml-fake-close-element (tree)
|
|
|
2920 (sgml-tree-parent tree))
|
|
|
2921
|
|
|
2922 (defun sgml-note-change-at (at &optional end)
|
|
|
2923 ;; Inform the cache that there have been some changes after AT
|
|
|
2924 (when sgml-buffer-parse-state
|
|
2
|
2925 (sgml-debug "sgml-note-change-at %s" at)
|
|
0
|
2926 (let ((u (sgml-pstate-top-tree sgml-buffer-parse-state)))
|
|
|
2927 (when u
|
|
|
2928 ;;(message "%d" at)
|
|
|
2929 (while
|
|
|
2930 (cond
|
|
|
2931 ((and (sgml-tree-next u) ; Change clearly in next element
|
|
|
2932 (> at (sgml-element-stag-end (sgml-tree-next u))))
|
|
|
2933 (setq u (sgml-tree-next u)))
|
|
|
2934 (t ;
|
|
|
2935 (setf (sgml-tree-next u) nil) ; Forget next element
|
|
|
2936 (cond
|
|
|
2937 ;; If change after this element and it is ended by an end
|
|
|
2938 ;; tag no pruning is done. If the end of the element is
|
|
|
2939 ;; implied changing the tag that implied it may change
|
|
|
2940 ;; the extent of the element.
|
|
|
2941 ((and (sgml-tree-etag-epos u)
|
|
|
2942 (> at (sgml-tree-end u))
|
|
|
2943 (or (> (sgml-tree-etag-len u) 0)
|
|
|
2944 (sgml-element-empty u)))
|
|
|
2945 nil)
|
|
|
2946 (t
|
|
|
2947 (setf (sgml-tree-etag-epos u) nil)
|
|
|
2948 (cond;; Enter into content if change is clearly in it
|
|
|
2949 ((and (sgml-tree-content u)
|
|
|
2950 (> at (sgml-element-stag-end (sgml-tree-content u))))
|
|
|
2951 (setq u (sgml-tree-content u)))
|
|
|
2952 ;; Check if element has no start tag,
|
|
|
2953 ;; then it must be pruned as a change could create
|
|
|
2954 ;; a valid start tag for the element.
|
|
|
2955 ((and (zerop (sgml-tree-stag-len u))
|
|
|
2956 (> at (sgml-element-start u)))
|
|
|
2957 ;; restart from to with new position
|
|
|
2958 ;; this can't loop forever as
|
|
|
2959 ;; position allways gets smaller
|
|
|
2960 (setq at (sgml-element-start u)
|
|
|
2961 u sgml-top-tree))
|
|
|
2962 (t
|
|
|
2963 (setf (sgml-tree-content u) nil))))))))))))
|
|
|
2964
|
|
|
2965 (defun sgml-list-implications (token type)
|
|
|
2966 "Return a list of the tags implied by a token TOKEN.
|
|
|
2967 TOKEN is a token, and the list elements are either tokens or `t'.
|
|
|
2968 Where the latter represents end-tags."
|
|
|
2969 (let ((state sgml-current-state)
|
|
|
2970 (tree sgml-current-tree)
|
|
|
2971 (temp nil)
|
|
|
2972 (imps nil))
|
|
|
2973 (while ; Until token accepted
|
|
|
2974 (cond
|
|
|
2975 ;; Test if accepted in state
|
|
|
2976 ((or (eq state sgml-any)
|
|
|
2977 (and (sgml-model-group-p state)
|
|
2
|
2978 (not (memq token (sgml-tree-excludes tree)))
|
|
|
2979 (or (memq token (sgml-tree-includes tree))
|
|
0
|
2980 (sgml-get-move state token))))
|
|
|
2981 nil)
|
|
|
2982 ;; Test if end tag implied
|
|
2
|
2983 ((or (eq state sgml-empty)
|
|
0
|
2984 (and (sgml-final-p state)
|
|
|
2985 (not (eq tree sgml-top-tree))))
|
|
|
2986 (unless (eq state sgml-empty) ; not realy implied
|
|
|
2987 (push t imps))
|
|
|
2988 (setq state (sgml-tree-pstate tree)
|
|
|
2989 tree (sgml-fake-close-element tree))
|
|
|
2990 t)
|
|
|
2991 ;; Test if start-tag can be implied
|
|
|
2992 ((and (setq temp (sgml-required-tokens state))
|
|
|
2993 (null (cdr temp)))
|
|
|
2994 (setq temp (car temp)
|
|
|
2995 tree (sgml-fake-open-element tree temp
|
|
|
2996 (sgml-get-move state temp))
|
|
|
2997 state (sgml-element-model tree))
|
|
|
2998 (push temp imps)
|
|
|
2999 t)
|
|
|
3000 ;; No implictions and not accepted
|
|
|
3001 (t
|
|
|
3002 (sgml-log-warning "Out of context %s" type)
|
|
|
3003 (setq imps nil))))
|
|
|
3004 ;; Return the implications in correct order
|
|
|
3005 (nreverse imps)))
|
|
|
3006
|
|
|
3007
|
|
|
3008 (defun sgml-eltypes-in-state (tree state)
|
|
|
3009 "Return list of element types (eltype) valid in STATE and TREE."
|
|
|
3010 (let* ((req ; Required tokens
|
|
|
3011 (if (sgml-model-group-p state)
|
|
|
3012 (sgml-required-tokens state)))
|
|
|
3013 (elems ; Normally valid tokens
|
|
|
3014 (if (sgml-model-group-p state)
|
|
|
3015 (nconc req
|
|
|
3016 (delq sgml-pcdata-token (sgml-optional-tokens state))))))
|
|
|
3017 ;; Modify for exceptions
|
|
|
3018 (loop for et in (sgml-tree-includes tree) ;*** Tokens or eltypes?
|
|
|
3019 unless (memq et elems) do (push et elems))
|
|
|
3020 (loop for et in (sgml-tree-excludes tree)
|
|
|
3021 do (setq elems (delq et elems)))
|
|
|
3022 ;; Check for omitable start-tags
|
|
|
3023 (when (and sgml-omittag-transparent
|
|
|
3024 (not (sgml-final-p state))
|
|
|
3025 req
|
|
|
3026 (null (cdr req)))
|
|
|
3027 (let ((et (sgml-token-eltype (car req))))
|
|
|
3028 (when (sgml-eltype-stag-optional et)
|
|
|
3029 (setq elems
|
|
|
3030 (nconc elems ; *** possibility of duplicates
|
|
|
3031 (sgml-eltypes-in-state
|
|
|
3032 (sgml-fake-open-element tree et)
|
|
|
3033 (sgml-eltype-model et)))))))
|
|
|
3034 elems))
|
|
|
3035
|
|
|
3036 (defun sgml-current-list-of-valid-eltypes ()
|
|
|
3037 "Returns a list of contextually valid element types (eltype)."
|
|
|
3038 (let ((elems (sgml-eltypes-in-state sgml-current-tree sgml-current-state))
|
|
|
3039 (tree sgml-current-tree)
|
|
|
3040 (state sgml-current-state))
|
|
|
3041 (when sgml-omittag-transparent
|
|
|
3042 (while (and tree
|
|
|
3043 (sgml-final-p state)
|
|
|
3044 (sgml-element-etag-optional tree))
|
|
|
3045 (setq state (sgml-tree-pstate tree)
|
|
|
3046 tree (sgml-tree-parent tree))
|
|
|
3047 (loop for e in (sgml-eltypes-in-state tree state) do
|
|
|
3048 (when (not (memq e elems))
|
|
|
3049 (setq elems (nconc elems (list e)))))))
|
|
|
3050 ;; *** Filter out elements that are undefined?
|
|
|
3051 (sort elems (function string-lessp))))
|
|
|
3052
|
|
|
3053 (defun sgml-current-list-of-endable-eltypes ()
|
|
|
3054 "Return a list of the element types endable in current state."
|
|
|
3055 (let* ((elems nil)
|
|
|
3056 (tree sgml-current-tree)
|
|
|
3057 (state sgml-current-state))
|
|
|
3058 (while
|
|
|
3059 (and (sgml-final-p state)
|
|
|
3060 (not (eq tree sgml-top-tree))
|
|
|
3061 (progn
|
|
|
3062 (setq elems
|
|
|
3063 (nconc elems (list (sgml-tree-eltype tree))))
|
|
|
3064 sgml-omittag)
|
|
|
3065 (sgml-eltype-etag-optional (sgml-tree-eltype tree)))
|
|
|
3066 (setq state (sgml-tree-pstate tree)
|
|
|
3067 tree (sgml-tree-parent tree)))
|
|
|
3068 elems))
|
|
|
3069
|
|
|
3070 ;;;; Logging of warnings
|
|
|
3071
|
|
|
3072 (defconst sgml-log-buffer-name "*SGML LOG*")
|
|
|
3073
|
|
|
3074 (defvar sgml-log-last-size 0)
|
|
|
3075
|
|
|
3076 (defun sgml-display-log ()
|
|
|
3077 (let ((buf (get-buffer sgml-log-buffer-name)))
|
|
|
3078 (when buf
|
|
|
3079 (display-buffer buf)
|
|
|
3080 (setq sgml-log-last-size (save-excursion (set-buffer buf)
|
|
|
3081 (point-max))))))
|
|
|
3082
|
|
|
3083 (defun sgml-log-warning (format &rest things)
|
|
|
3084 (when sgml-throw-on-warning
|
|
|
3085 (apply 'message format things)
|
|
|
3086 (throw sgml-throw-on-warning t))
|
|
|
3087 (when (or sgml-show-warnings sgml-parsing-dtd)
|
|
|
3088 (apply 'sgml-message format things)
|
|
|
3089 (apply 'sgml-log-message format things)))
|
|
|
3090
|
|
|
3091 (defun sgml-log-message (format &rest things)
|
|
|
3092 (let ((mess (apply 'format format things))
|
|
|
3093 (buf (get-buffer-create sgml-log-buffer-name))
|
|
|
3094 (cb (current-buffer)))
|
|
|
3095 (set-buffer buf)
|
|
|
3096 (goto-char (point-max))
|
|
|
3097 (insert mess "\n")
|
|
|
3098 (when (get-buffer-window buf)
|
|
|
3099 (setq sgml-log-last-size (point-max)))
|
|
|
3100 (set-buffer cb)))
|
|
|
3101
|
|
|
3102 (defun sgml-error (format &rest things)
|
|
|
3103 (when sgml-throw-on-error
|
|
|
3104 (throw sgml-throw-on-error nil))
|
|
|
3105 (while (and (boundp 'sgml-previous-buffer) sgml-previous-buffer)
|
|
|
3106 (when sgml-current-eref
|
|
|
3107 (sgml-log-message
|
|
|
3108 "Line %s in %S "
|
|
|
3109 (count-lines (point-min) (point))
|
|
|
3110 (sgml-entity-name (sgml-eref-entity sgml-current-eref))))
|
|
|
3111 (sgml-pop-entity))
|
|
|
3112 (apply 'sgml-log-warning format things)
|
|
|
3113 (apply 'error format things))
|
|
|
3114
|
|
|
3115 (defun sgml-parse-error (format &rest things)
|
|
|
3116 (apply 'sgml-error
|
|
|
3117 (concat format "; at: %s")
|
|
|
3118 (append things (list (buffer-substring-no-properties
|
|
|
3119 (point)
|
|
|
3120 (min (point-max) (+ (point) 12)))))))
|
|
|
3121
|
|
|
3122 (defun sgml-message (format &rest things)
|
|
|
3123 (let ((buf (get-buffer sgml-log-buffer-name)))
|
|
|
3124 (when (and buf
|
|
|
3125 (> (save-excursion (set-buffer buf)
|
|
|
3126 (point-max))
|
|
|
3127 sgml-log-last-size))
|
|
|
3128 (sgml-display-log)))
|
|
|
3129 (apply 'message format things))
|
|
|
3130
|
|
|
3131 (defun sgml-reset-log ()
|
|
|
3132 (let ((buf (get-buffer sgml-log-buffer-name)))
|
|
|
3133 (when buf
|
|
|
3134 (setq sgml-log-last-size
|
|
|
3135 (save-excursion (set-buffer buf)
|
|
|
3136 (point-max))))))
|
|
|
3137
|
|
|
3138 (defun sgml-clear-log ()
|
|
|
3139 (let ((b (get-buffer sgml-log-buffer-name)))
|
|
|
3140 (when b
|
|
|
3141 (delete-windows-on b)
|
|
|
3142 (kill-buffer b)
|
|
|
3143 (setq sgml-log-last-size 0))))
|
|
|
3144
|
|
|
3145 (defun sgml-show-or-clear-log ()
|
|
|
3146 "Show the *SGML LOG* buffer if it is not showing, or clear and
|
|
|
3147 remove it if it is showing."
|
|
|
3148 (interactive)
|
|
|
3149 (cond ((and (get-buffer sgml-log-buffer-name)
|
|
|
3150 (null (get-buffer-window sgml-log-buffer-name)))
|
|
|
3151 (sgml-display-log))
|
|
|
3152 (t
|
|
|
3153 (sgml-clear-log))))
|
|
|
3154
|
|
|
3155
|
|
|
3156
|
|
|
3157 ;;; This has noting to do with warnings...
|
|
|
3158
|
|
|
3159 (defvar sgml-lazy-time 0)
|
|
|
3160
|
|
|
3161 (defun sgml-lazy-message (&rest args)
|
|
|
3162 (unless (= sgml-lazy-time (second (current-time)))
|
|
|
3163 (apply 'message args)
|
|
|
3164 (setq sgml-lazy-time (second (current-time)))))
|
|
|
3165
|
|
|
3166 ;;;; Shortref maps
|
|
|
3167
|
|
|
3168 (eval-and-compile
|
|
|
3169 (defconst sgml-shortref-list
|
|
|
3170 '(
|
|
|
3171 "\t" ;&#TAB
|
|
|
3172 "\n" ;&#RE;
|
|
|
3173 "\001" ;&#RS;
|
|
|
3174 "\001B"
|
|
|
3175 "\001\n"
|
|
|
3176 "\001B\n"
|
|
|
3177 "B\n"
|
|
|
3178 " " ;&#SPACE;
|
|
|
3179 "BB"
|
|
|
3180 "\"" ;"
|
|
|
3181 "#"
|
|
|
3182 "%"
|
|
|
3183 "'"
|
|
|
3184 "("
|
|
|
3185 ")"
|
|
|
3186 "*"
|
|
|
3187 "+"
|
|
|
3188 ","
|
|
|
3189 "-"
|
|
|
3190 "--"
|
|
|
3191 ":"
|
|
|
3192 ";"
|
|
|
3193 "="
|
|
|
3194 "@"
|
|
|
3195 "["
|
|
|
3196 "]"
|
|
|
3197 "^"
|
|
|
3198 "_"
|
|
|
3199 "{"
|
|
|
3200 "|"
|
|
|
3201 "}"
|
|
|
3202 "~")))
|
|
|
3203
|
|
|
3204 (eval-and-compile
|
|
|
3205 (defun sgml-shortref-index (string)
|
|
|
3206 (let ((pos (member string sgml-shortref-list))
|
|
|
3207 (len (length sgml-shortref-list)))
|
|
|
3208 (and pos (- len (length pos))) )))
|
|
|
3209
|
|
|
3210 (defun sgml-make-shortmap (pairs)
|
|
|
3211 "Create a shortreference map from PAIRS.
|
|
|
3212 Where PAIRS is a list of (delim . ename)."
|
|
|
3213 (let ((map
|
|
|
3214 (make-vector (1+ (length sgml-shortref-list))
|
|
|
3215 nil))
|
|
|
3216 index)
|
|
|
3217 (loop for p in pairs
|
|
|
3218 for delim = (car p)
|
|
|
3219 for name = (cdr p)
|
|
|
3220 do
|
|
|
3221 (setq index (sgml-shortref-index delim))
|
|
|
3222 (cond ((null index)
|
|
|
3223 (sgml-log-warning
|
|
|
3224 "Illegal short reference delimiter '%s'" delim))
|
|
|
3225 (t
|
|
|
3226 (aset map index name))))
|
|
|
3227 ;; Compute a suitable string for skip-chars-forward that
|
|
|
3228 ;; can be used to skip over pcdata
|
|
|
3229 (aset map
|
|
|
3230 (eval-when-compile (length sgml-shortref-list))
|
|
|
3231 (if (some (function
|
|
|
3232 (lambda (r) (aref map (sgml-shortref-index r))))
|
|
|
3233 '("\001B\n" "B\n" " " "BB"))
|
|
|
3234 "^<]/& \n\t\"#%'()*+,\\-:;=@[]\\^_{|}~"
|
|
|
3235 "^<]/&\n\t\"#%'()*+,\\-:;=@[]\\^_{|}~"))
|
|
|
3236 map))
|
|
|
3237
|
|
|
3238 (defun sgml-shortmap-skipstring (map)
|
|
|
3239 (if (bolp)
|
|
|
3240 ""
|
|
|
3241 (aref map (eval-when-compile (length sgml-shortref-list)))))
|
|
|
3242
|
|
|
3243
|
|
|
3244 (defconst sgml-shortref-oneassq
|
|
|
3245 (loop for d in sgml-shortref-list
|
|
|
3246 for c = (aref d 0)
|
|
|
3247 when (and (= 1 (length d))
|
|
|
3248 (/= 1 c) (/= 10 c))
|
|
|
3249 collect (cons c (sgml-shortref-index d))))
|
|
|
3250
|
|
|
3251 (defun sgml-parse-B ()
|
|
|
3252 (/= 0 (skip-chars-forward " \t")))
|
|
|
3253
|
|
|
3254 (defun sgml-deref-shortmap (map &optional nobol)
|
|
|
3255 "Identify shortref delimiter at point and return entity name.
|
|
|
3256 Also move point. Return nil, either if no shortref or undefined."
|
|
|
3257
|
|
|
3258 (macrolet
|
|
|
3259 ((delim (x) (` (aref map (, (sgml-shortref-index x))))))
|
|
|
3260 (let ((i (if nobol 1 0)))
|
|
|
3261 (while (numberp i)
|
|
|
3262 (setq i
|
|
|
3263 (cond
|
|
|
3264 ((and (bolp) (zerop i)) ; Either "\001" "\001B"
|
|
|
3265 ; "\001\n" "\001B\n"
|
|
|
3266 (cond ((sgml-parse-B) ; "\001B"
|
|
|
3267 (if (eolp)
|
|
|
3268 (delim "\001B\n")
|
|
|
3269 (delim "\001B")))
|
|
|
3270 ((sgml-parse-RE) (delim "\001\n"))
|
|
|
3271 ((delim "\001"))
|
|
|
3272 (t 1)))
|
|
|
3273 ((cond ((sgml-parse-char ?\t) (setq i (delim "\t")) t)
|
|
|
3274 ((sgml-parse-char ? ) (setq i (delim " ")) t))
|
|
|
3275 (cond ((sgml-parse-B) (setq i (delim "BB"))))
|
|
|
3276 (cond ((sgml-parse-char ?\n)
|
|
|
3277 (delim "B\n"))
|
|
|
3278 (t i)))
|
|
|
3279 ((sgml-parse-RE) (delim "\n"))
|
|
|
3280 ((sgml-parse-chars ?- ?-) (delim "--"))
|
|
|
3281 ;; The other one character delimiters
|
|
|
3282 ((setq i (assq (following-char) sgml-shortref-oneassq))
|
|
|
3283 (when i (forward-char 1))
|
|
|
3284 (aref map (cdr i))))))
|
|
|
3285 i)))
|
|
|
3286
|
|
|
3287 ;;; Table of shortref maps
|
|
|
3288
|
|
|
3289 (defun sgml-make-shortref-table ()
|
|
|
3290 (list nil))
|
|
|
3291
|
|
|
3292 (defun sgml-add-shortref-map (table name map)
|
|
|
3293 (nconc table (list (cons name map))))
|
|
|
3294
|
|
|
3295 (defun sgml-lookup-shortref-map (table name)
|
|
|
3296 (cdr (assoc name (cdr table))))
|
|
|
3297
|
|
2
|
3298 (defun sgml-lookup-shortref-name (table map)
|
|
|
3299 (car (rassq map (cdr table))))
|
|
|
3300
|
|
0
|
3301 (defun sgml-merge-shortmaps (tab1 tab2)
|
|
|
3302 "Merge tables of short reference maps TAB2 into TAB1, modifying TAB1."
|
|
|
3303 (nconc tab1 (cdr tab2)))
|
|
|
3304
|
|
|
3305 ;;;; Parse markup declarations
|
|
|
3306
|
|
|
3307 (defun sgml-skip-until-dsc ()
|
|
|
3308 (while (progn
|
|
|
3309 (sgml-skip-upto ("DSO" "DSC" "LITA" "LIT" "COM"))
|
|
|
3310 (not (sgml-parse-delim "DSC")))
|
|
|
3311 (cond ((sgml-parse-literal))
|
|
|
3312 ((sgml-parse-delim "DSO")
|
|
|
3313 (sgml-skip-until-dsc))
|
|
|
3314 ((sgml-parse-comment))
|
|
|
3315 (t (forward-char 1)))))
|
|
|
3316
|
|
|
3317 (defun sgml-skip-upto-mdc ()
|
|
|
3318 "Move point forward until end of current markup declaration.
|
|
|
3319 Assumes starts with point inside a markup declaration."
|
|
|
3320 (while (progn
|
|
|
3321 (sgml-skip-upto ("DSO" "MDC" "LIT" "LITA" "COM"))
|
|
|
3322 (not (sgml-is-delim "MDC")))
|
|
|
3323 (cond ((sgml-parse-delim "DSO")
|
|
|
3324 (sgml-skip-until-dsc))
|
|
|
3325 ((sgml-parse-literal))
|
|
|
3326 ((sgml-parse-comment))
|
|
|
3327 (t (forward-char 1)))))
|
|
|
3328
|
|
|
3329 (defun sgml-do-sgml-declaration ()
|
|
|
3330 (sgml-skip-upto-mdc)
|
|
|
3331 (setq sgml-markup-type 'sgml))
|
|
|
3332
|
|
|
3333 (defun sgml-do-doctype ()
|
|
|
3334 (cond
|
|
|
3335 (sgml-dtd-info ; Has doctype already been defined
|
|
|
3336 (sgml-skip-upto-mdc))
|
|
|
3337 (t
|
|
|
3338 (let (sgml-markup-start)
|
|
|
3339 (message "Parsing doctype...")
|
|
|
3340 (sgml-setup-doctype (sgml-check-name)
|
|
|
3341 (sgml-parse-external))
|
|
|
3342 (message "Parsing doctype...done"))))
|
|
|
3343 (setq sgml-markup-type 'doctype))
|
|
|
3344
|
|
2
|
3345 (defun sgml-check-end-of-entity (type)
|
|
|
3346 (unless (eobp)
|
|
|
3347 (sgml-parse-error "Illegal character '%c' in %s"
|
|
|
3348 (following-char)
|
|
|
3349 type)))
|
|
|
3350
|
|
0
|
3351 (defun sgml-setup-doctype (docname external)
|
|
|
3352 (let ((sgml-parsing-dtd t))
|
|
|
3353 (setq sgml-no-elements 0)
|
|
|
3354 (setq sgml-dtd-info (sgml-make-dtd docname))
|
|
|
3355 ;;(setq sgml-dtd-shortmaps nil)
|
|
|
3356 (sgml-skip-ps)
|
|
|
3357 (cond
|
|
|
3358 ((sgml-parse-delim "DSO")
|
|
2
|
3359 (let ((original-buffer (current-buffer)))
|
|
|
3360 (sgml-check-dtd-subset)
|
|
|
3361 (if (eq (current-buffer) original-buffer)
|
|
|
3362 (sgml-check-delim "DSC")
|
|
|
3363 (sgml-parse-error "Illegal character '%c' in doctype declaration"
|
|
|
3364 (following-char))))))
|
|
0
|
3365 (cond (external
|
|
|
3366 (sgml-push-to-entity (sgml-make-entity docname 'dtd external))
|
|
2
|
3367 (sgml-check-dtd-subset)
|
|
|
3368 (sgml-check-end-of-entity "DTD subset")
|
|
0
|
3369 (sgml-pop-entity)))
|
|
|
3370 ;;; (loop for map in sgml-dtd-shortmaps do
|
|
|
3371 ;;; (sgml-add-shortref-map
|
|
|
3372 ;;; (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
3373 ;;; (car map)
|
|
|
3374 ;;; (sgml-make-shortmap (cdr map))))
|
|
|
3375 (sgml-set-initial-state sgml-dtd-info)
|
|
|
3376 (run-hooks 'sgml-doctype-parsed-hook)))
|
|
|
3377
|
|
|
3378 (defun sgml-do-data (type &optional marked-section)
|
|
|
3379 "Move point forward until there is an end-tag open after point."
|
|
|
3380 (let ((start (point))
|
|
|
3381 (done nil)
|
|
|
3382 (eref sgml-current-eref)
|
|
|
3383 sgml-signal-data-function)
|
|
|
3384 (while (not done)
|
|
|
3385 (cond (marked-section
|
|
|
3386 (skip-chars-forward (if (eq type sgml-cdata) "^]" "^&]"))
|
|
|
3387 (when sgml-data-function
|
|
|
3388 (funcall sgml-data-function (buffer-substring-no-properties
|
|
|
3389 start (point))))
|
|
|
3390 (setq done (sgml-parse-delim "MS-END")))
|
|
|
3391 (t
|
|
|
3392 (skip-chars-forward (if (eq type sgml-cdata) "^</" "^</&"))
|
|
|
3393 (when sgml-data-function
|
|
|
3394 (funcall sgml-data-function (buffer-substring-no-properties start (point))))
|
|
|
3395 (setq done (or (sgml-is-delim "ETAGO" gi)
|
|
|
3396 (sgml-is-enabled-net)))))
|
|
|
3397 (setq start (point))
|
|
|
3398 (cond
|
|
|
3399 (done)
|
|
|
3400 ((eobp)
|
|
|
3401 (when (eq eref sgml-current-eref)
|
|
|
3402 (sgml-error "Unterminated %s %s"
|
|
|
3403 type (if marked-section "marked section")))
|
|
|
3404 (sgml-pop-entity)
|
|
|
3405 (setq start (point)))
|
|
|
3406 ((null sgml-data-function)
|
|
|
3407 (forward-char 1))
|
|
|
3408 ((sgml-parse-general-entity-ref)
|
|
|
3409 (setq start (point)))
|
|
|
3410 (t
|
|
|
3411 (forward-char 1))))))
|
|
|
3412
|
|
|
3413
|
|
|
3414 (defun sgml-do-marked-section ()
|
|
|
3415 (let ((status nil))
|
|
|
3416 (while (progn (sgml-skip-ps)
|
|
|
3417 (not (sgml-parse-char ?\[)))
|
|
|
3418 (push (sgml-check-name)
|
|
|
3419 status))
|
|
|
3420 (cond
|
|
|
3421 ((member "ignore" status)
|
|
|
3422 (sgml-skip-marked-section)
|
|
|
3423 (sgml-set-markup-type 'ignored))
|
|
|
3424 ((or (member "cdata" status)
|
|
|
3425 (member "rcdata" status))
|
|
|
3426 (when sgml-signal-data-function
|
|
|
3427 (funcall sgml-signal-data-function))
|
|
|
3428 (let ((type (if (member "cdata" status) sgml-cdata sgml-rcdata)))
|
|
|
3429 (sgml-do-data type t)
|
|
|
3430 (sgml-set-markup-type type)))
|
|
|
3431 (t
|
|
|
3432 (sgml-set-markup-type 'ms-start)))))
|
|
|
3433
|
|
|
3434 (defun sgml-skip-marked-section ()
|
|
|
3435 (while (progn
|
|
|
3436 (sgml-skip-upto ("MS-START" "MS-END"))
|
|
|
3437 (when (eobp) (sgml-error "Marked section unterminated"))
|
|
|
3438 (not (sgml-parse-delim "MS-END")))
|
|
|
3439 (cond ((sgml-parse-delim "MS-START")
|
|
|
3440 ;;(search-forward "[")
|
|
|
3441 (sgml-skip-marked-section))
|
|
|
3442 (t (forward-char 1)))))
|
|
|
3443
|
|
|
3444 (defun sgml-do-usemap ()
|
|
2
|
3445 (let (mapname)
|
|
0
|
3446 ;;(setq sgml-markup-type 'usemap)
|
|
|
3447 (unless (sgml-parse-rni "empty")
|
|
|
3448 (setq mapname (sgml-check-name)))
|
|
|
3449 (sgml-skip-ps)
|
|
|
3450 (cond
|
|
|
3451 ((sgml-is-delim "MDC")
|
|
|
3452 (sgml-debug "USEMAP %s" (if mapname mapname "#EMPTY"))
|
|
|
3453 (cond (sgml-dtd-info
|
|
|
3454 (setq sgml-current-shortmap
|
|
|
3455 (if mapname
|
|
|
3456 (or (sgml-lookup-shortref-map
|
|
|
3457 (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
3458 mapname)
|
|
|
3459 (sgml-error "Undefined shortref map %s" mapname)))))
|
|
|
3460 ;; If in prolog
|
|
|
3461 (t
|
|
|
3462 (sgml-log-warning
|
|
|
3463 "USEMAP without associated element type in prolog"))))
|
|
|
3464 (t
|
|
|
3465 ;; Should be handled by psgml-dtd
|
|
|
3466 (sgml-do-usemap-element mapname)))))
|
|
|
3467
|
|
|
3468 (defconst sgml-markup-declaration-table
|
|
|
3469 '(("sgml" . sgml-do-sgml-declaration)
|
|
|
3470 ("doctype" . sgml-do-doctype)
|
|
|
3471 ("element" . sgml-declare-element)
|
|
|
3472 ("entity" . sgml-declare-entity)
|
|
|
3473 ("usemap" . sgml-do-usemap)
|
|
|
3474 ("shortref" . sgml-declare-shortref)
|
|
|
3475 ("notation" . sgml-declare-notation)
|
|
|
3476 ("attlist" . sgml-declare-attlist)
|
|
|
3477 ("uselink" . sgml-skip-upto-mdc)
|
|
|
3478 ("linktype" . sgml-skip-upto-mdc)
|
|
|
3479 ("link" . sgml-skip-upto-mdc)
|
|
|
3480 ("idlink" . sgml-skip-upto-mdc)
|
|
|
3481 ))
|
|
|
3482
|
|
|
3483 (defun sgml-parse-markup-declaration (option)
|
|
|
3484 "Parse a markup declartion.
|
|
|
3485 OPTION can be `prolog' if parsing the prolog or `dtd' if parsing the
|
|
|
3486 dtd or `ignore' if the declaration is to be ignored."
|
|
|
3487 (cond
|
|
|
3488 ((sgml-parse-delim "MDO" (nmstart "COM" "MDC"))
|
|
|
3489 (cond
|
|
|
3490 ((sgml-startnm-char-next)
|
|
|
3491 (setq sgml-markup-type nil)
|
|
|
3492 (let* ((tok (sgml-parse-nametoken))
|
|
|
3493 (rut (assoc tok sgml-markup-declaration-table)))
|
|
|
3494 (when (and (not (memq option '(prolog ignore)))
|
|
|
3495 (member tok '("sgml" "doctype")))
|
|
|
3496 (sgml-error "%s declaration is only valid in prolog" tok))
|
|
|
3497 (when (and (not (memq option '(dtd ignore)))
|
|
|
3498 (member tok '("element" "entity" "attlist" "notation"
|
|
|
3499 "shortref")))
|
|
|
3500 (sgml-error "%s declaration is only valid in doctype" tok))
|
|
|
3501 (cond ((eq option 'ignore)
|
|
|
3502 (sgml-skip-upto-mdc))
|
|
|
3503 (rut (sgml-skip-ps)
|
|
|
3504 (funcall (cdr rut)))
|
|
|
3505 (t (sgml-parse-error
|
|
|
3506 "Illegal markup declaration %s" tok)))))
|
|
|
3507 (t
|
|
|
3508 (setq sgml-markup-type 'comment)))
|
|
|
3509 (sgml-skip-ps)
|
|
|
3510 (sgml-check-delim "MDC")
|
|
|
3511 (unless (eq option 'ignore) ; Set the markup type given
|
|
|
3512 (when sgml-markup-type
|
|
|
3513 (sgml-set-markup-type sgml-markup-type)))
|
|
|
3514 t)
|
|
|
3515 ((sgml-parse-delim "MS-START")
|
|
|
3516 (sgml-do-marked-section))))
|
|
|
3517
|
|
|
3518
|
|
|
3519 ;;;; Parsing attribute values
|
|
|
3520
|
|
|
3521 (defun sgml-parse-attribute-specification-list (&optional eltype)
|
|
|
3522 "Parse an attribute specification list.
|
|
|
3523 Optional argument ELTYPE, is used to resolve omitted name=.
|
|
|
3524 Returns a list of attspec (attribute specification)."
|
|
|
3525 (setq sgml-conref-flag nil)
|
|
|
3526 (let ((attlist (if eltype (sgml-eltype-attlist eltype)))
|
|
|
3527 name val asl attdecl)
|
|
|
3528 (while (setq name (progn (sgml-parse-s)
|
|
|
3529 (sgml-parse-nametoken)))
|
|
|
3530 (sgml-parse-s)
|
|
|
3531 (cond ((sgml-parse-delim "VI")
|
|
|
3532 (sgml-parse-s)
|
|
|
3533 (setq val (sgml-check-attribute-value-specification))
|
|
|
3534 (when eltype
|
|
|
3535 (or (setq attdecl (sgml-lookup-attdecl name attlist))
|
|
|
3536 (sgml-log-warning
|
|
|
3537 "Attribute %s not declared for element %s"
|
|
|
3538 name (sgml-eltype-name eltype)))))
|
|
|
3539 ((null eltype)
|
|
|
3540 (sgml-parse-error "Expecting a ="))
|
|
|
3541 ((progn
|
|
|
3542 (unless sgml-current-shorttag
|
|
|
3543 (sgml-log-warning
|
|
|
3544 "Must have attribute name when SHORTTAG NO"))
|
|
|
3545 (setq attdecl
|
|
|
3546 (sgml-find-attdecl-for-value (setq val name)
|
|
|
3547 eltype))))
|
|
|
3548 (t
|
|
|
3549 (sgml-log-warning
|
|
|
3550 "%s is not in any name group for element %s."
|
|
|
3551 val
|
|
|
3552 (sgml-eltype-name eltype))))
|
|
|
3553 ;; *** What happens when eltype is nil ??
|
|
|
3554 (when attdecl
|
|
|
3555 (push (sgml-make-attspec (sgml-attdecl-name attdecl) val)
|
|
|
3556 asl)
|
|
|
3557 (when (sgml-default-value-type-p 'conref
|
|
|
3558 (sgml-attdecl-default-value attdecl))
|
|
|
3559 (setq sgml-conref-flag t))))
|
|
|
3560 asl))
|
|
|
3561
|
|
|
3562 (defun sgml-check-attribute-value-specification ()
|
|
|
3563 (or (sgml-parse-literal)
|
|
|
3564 (sgml-parse-nametoken t) ; Not really a nametoken, but an
|
|
|
3565 ; undelimited literal
|
|
|
3566 (sgml-parse-error "Expecting an attribute value: literal or token")))
|
|
|
3567
|
|
|
3568 (defun sgml-find-attdecl-for-value (value eltype)
|
|
|
3569 "Find the attribute declaration of ELTYPE that has VALUE in its name group.
|
|
|
3570 VALUE is a string. Returns nil or an attdecl."
|
|
|
3571 (let ((al (sgml-eltype-attlist eltype))
|
|
|
3572 dv)
|
|
|
3573 (while (and al
|
|
|
3574 (or (atom (setq dv (sgml-attdecl-declared-value (car al))))
|
|
|
3575 (not (member value
|
|
|
3576 (sgml-declared-value-token-group dv)))))
|
|
|
3577 (setq al (cdr al)))
|
|
|
3578 (if al (car al))))
|
|
|
3579
|
|
|
3580
|
|
|
3581 ;;;; Parser driver
|
|
|
3582
|
|
|
3583 ;; The parser maintains a partial parse tree during the parse. This tree
|
|
|
3584 ;; can be inspected to find information, and also be used to restart the
|
|
|
3585 ;; parse. The parser also has a postition in the current content model.
|
|
|
3586 ;; (Called a state.) The parser is used for several things:
|
|
|
3587 ;; 1) To find the state the parser would be in at a point in the buffer.
|
|
|
3588 ;; (Point in emacs sense, I.e. between chararacters).
|
|
|
3589 ;; 2) Identify the element containing a character.
|
|
|
3590 ;; 3) Find end of an element.
|
|
|
3591 ;; 4) Find the next element.
|
|
|
3592 ;; 5) To find the previous element.
|
|
|
3593
|
|
|
3594 ;; These tasks are done by a combination of parsing and traversing
|
|
|
3595 ;; the partial parse tree. The primitive parse operation is to parse
|
|
|
3596 ;; until a goal point in the buffer has been passed. In addition to
|
|
|
3597 ;; this it is possible to "trap" closing of elements. Either for a
|
|
|
3598 ;; specific element or for any element. When the trap is sprung the
|
|
|
3599 ;; parse is ended. This is used to extend the parse tree. When the
|
|
|
3600 ;; trap is used the parser is usually called with the end of the
|
|
|
3601 ;; buffer as the goal point.
|
|
|
3602
|
|
|
3603 (defun sgml-need-dtd ()
|
|
|
3604 "Make sure that an eventual DTD is parsed or loaded."
|
|
2
|
3605 (sgml-pop-all-entities)
|
|
0
|
3606 (sgml-cleanup-entities)
|
|
|
3607 (when (null sgml-buffer-parse-state) ; first parse in this buffer
|
|
|
3608 ;;(sgml-set-initial-state) ; fall back DTD
|
|
|
3609 (add-hook 'pre-command-hook 'sgml-reset-log)
|
|
|
3610 (make-local-variable 'sgml-auto-fill-inhibit-function)
|
|
|
3611 (setq sgml-auto-fill-inhibit-function (function sgml-in-prolog-p))
|
|
|
3612 (if sgml-default-dtd-file
|
|
|
3613 (sgml-load-dtd sgml-default-dtd-file)
|
|
|
3614 (sgml-load-doctype)))
|
|
2
|
3615 (sgml-debug "Need dtd getting state from %s" (buffer-name))
|
|
0
|
3616 (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
|
|
|
3617 sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
|
|
|
3618 (sgml-set-global))
|
|
|
3619
|
|
|
3620
|
|
|
3621 (defun sgml-load-doctype ()
|
|
|
3622 (cond
|
|
|
3623 ;; Case of doctype in another file
|
|
|
3624 ((or sgml-parent-document sgml-doctype)
|
|
|
3625 (let ((dtd
|
|
|
3626 (save-excursion ; get DTD from parent document
|
|
|
3627 (set-buffer (find-file-noselect
|
|
|
3628 (if (consp sgml-parent-document)
|
|
|
3629 (car sgml-parent-document)
|
|
|
3630 (or sgml-doctype sgml-parent-document))))
|
|
|
3631 (sgml-need-dtd)
|
|
|
3632 (sgml-pstate-dtd sgml-buffer-parse-state))))
|
|
|
3633 (sgml-set-initial-state dtd)
|
|
|
3634 (when (consp sgml-parent-document) ; modify DTD for child documents
|
|
|
3635 (sgml-modify-dtd (cdr sgml-parent-document)))))
|
|
|
3636
|
|
|
3637 ;; The doctype declaration should be in the current buffer
|
|
|
3638 (t
|
|
|
3639 (save-excursion (sgml-parse-prolog)))))
|
|
|
3640
|
|
|
3641
|
|
|
3642 (defun sgml-modify-dtd (modifier)
|
|
|
3643 (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
|
|
|
3644 sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
|
|
|
3645 (sgml-set-global)
|
|
78
|
3646 (setq sgml-current-tree sgml-top-tree)
|
|
0
|
3647 (while (stringp (cadr modifier)) ; Loop thru the context elements
|
|
|
3648 (let ((et (sgml-lookup-eltype (car modifier))))
|
|
|
3649 (sgml-open-element et nil (point-min) (point-min))
|
|
|
3650 (setq modifier (cdr modifier))))
|
|
|
3651
|
|
|
3652 (unless (stringp (car modifier))
|
|
|
3653 (error "wrong format of sgml-parent-document"))
|
|
|
3654
|
|
|
3655 (let* ((doctypename (car modifier))
|
|
|
3656 (et (sgml-lookup-eltype
|
|
|
3657 (sgml-general-case (if (symbolp doctypename)
|
|
|
3658 (symbol-name doctypename)
|
|
|
3659 doctypename)))))
|
|
|
3660
|
|
|
3661 (setq sgml-current-state
|
|
|
3662 (sgml-make-primitive-content-token et))
|
|
|
3663
|
|
|
3664 (when (consp (cadr modifier)) ; There are "seen" elements
|
|
|
3665 (sgml-open-element et nil (point-min) (point-min))
|
|
|
3666 (loop for seenel in (cadr modifier)
|
|
|
3667 do (setq sgml-current-state
|
|
|
3668 (sgml-get-move sgml-current-state
|
|
|
3669 (sgml-lookup-eltype seenel))))))
|
|
|
3670
|
|
|
3671 (let ((top (sgml-pstate-top-tree sgml-buffer-parse-state)))
|
|
2
|
3672 (setf (sgml-tree-includes top) (sgml-tree-includes sgml-current-tree))
|
|
|
3673 (setf (sgml-tree-excludes top) (sgml-tree-excludes sgml-current-tree))
|
|
0
|
3674 (setf (sgml-tree-shortmap top) sgml-current-shortmap)
|
|
|
3675 (setf (sgml-eltype-model (sgml-tree-eltype top))
|
|
|
3676 sgml-current-state)))
|
|
|
3677
|
|
|
3678
|
|
|
3679 (defun sgml-set-global ()
|
|
|
3680 (setq sgml-current-omittag sgml-omittag
|
|
|
3681 sgml-current-shorttag sgml-shorttag
|
|
|
3682 sgml-current-localcat sgml-local-catalogs
|
|
2
|
3683 sgml-current-local-ecat sgml-local-ecat-files
|
|
|
3684 sgml-current-top-buffer (current-buffer)))
|
|
0
|
3685
|
|
|
3686 (defun sgml-parse-prolog ()
|
|
|
3687 "Parse the document prolog to learn the DTD."
|
|
|
3688 (interactive)
|
|
2
|
3689 (sgml-debug "Parse prolog in buffer %s" (buffer-name))
|
|
|
3690 (unless sgml-debug
|
|
|
3691 (sgml-clear-log))
|
|
0
|
3692 (message "Parsing prolog...")
|
|
|
3693 (sgml-cleanup-entities)
|
|
|
3694 (sgml-set-global)
|
|
|
3695 (setq sgml-dtd-info nil)
|
|
|
3696 (goto-char (point-min))
|
|
|
3697 (sgml-with-parser-syntax
|
|
|
3698 (while (progn (sgml-skip-ds)
|
|
|
3699 (setq sgml-markup-start (point))
|
|
|
3700 (and (sgml-parse-markup-declaration 'prolog)
|
|
|
3701 (null sgml-dtd-info))))
|
|
|
3702 (unless sgml-dtd-info ; Set up a default doctype
|
|
|
3703 (let ((docname (or sgml-default-doctype-name
|
|
|
3704 (if (sgml-parse-delim "STAGO" gi)
|
|
|
3705 (sgml-parse-name)))))
|
|
|
3706 (when docname
|
|
|
3707 (sgml-setup-doctype docname '(nil))))))
|
|
|
3708 (unless sgml-dtd-info
|
|
|
3709 (error "No document type defined by prolog"))
|
|
|
3710 (sgml-message "Parsing prolog...done"))
|
|
|
3711
|
|
2
|
3712
|
|
0
|
3713 (defun sgml-parse-until-end-of (sgml-close-element-trap &optional
|
|
|
3714 cont extra-cond quiet)
|
|
|
3715 "Parse until the SGML-CLOSE-ELEMENT-TRAP has ended,
|
|
|
3716 or if it is t, any additional element has ended,
|
|
|
3717 or if nil, until end of buffer."
|
|
|
3718 (cond
|
|
|
3719 (cont (sgml-parse-continue (point-max)))
|
|
|
3720 (t (sgml-parse-to (point-max) extra-cond quiet)))
|
|
|
3721 (when (eobp) ; End of buffer, can imply
|
|
|
3722 ; end of any open element.
|
|
|
3723 (while (prog1 (not
|
|
|
3724 (or (eq sgml-close-element-trap t)
|
|
|
3725 (eq sgml-close-element-trap sgml-current-tree)
|
|
|
3726 (eq sgml-current-tree sgml-top-tree)))
|
|
|
3727 (sgml-implied-end-tag "buffer end" (point) (point))))))
|
|
|
3728
|
|
|
3729 (defun sgml-parse-to (sgml-goal &optional extra-cond quiet)
|
|
|
3730 "Parse until (at least) SGML-GOAL.
|
|
|
3731 Optional argument EXTRA-COND should be a function. This function is
|
|
|
3732 called in the parser loop, and the loop is exited if the function returns t.
|
|
|
3733 If third argument QUIT is non-nil, no \"Parsing...\" message will be displayed."
|
|
|
3734 (sgml-need-dtd)
|
|
2
|
3735
|
|
|
3736 (unless before-change-function
|
|
|
3737 (message "WARN: before-change-function has been lost, restoring (%s)"
|
|
|
3738 (current-buffer))
|
|
|
3739 (setq before-change-function 'sgml-note-change-at)
|
|
|
3740 (setq after-change-function 'sgml-set-face-after-change)
|
|
|
3741 )
|
|
|
3742
|
|
0
|
3743 (sgml-find-start-point (min sgml-goal (point-max)))
|
|
|
3744 (assert sgml-current-tree)
|
|
|
3745 (let ((bigparse (and (not quiet) (> (- sgml-goal (point)) 10000))))
|
|
|
3746 (when bigparse
|
|
|
3747 (sgml-message "Parsing..."))
|
|
|
3748 (sgml-with-parser-syntax
|
|
|
3749 (sgml-parser-loop extra-cond))
|
|
|
3750 (when bigparse
|
|
|
3751 (sgml-message ""))))
|
|
|
3752
|
|
2
|
3753 (defun sgml-parse-continue (sgml-goal &optional extra-cond quiet)
|
|
0
|
3754 "Parse until (at least) SGML-GOAL."
|
|
|
3755 (assert sgml-current-tree)
|
|
2
|
3756 (unless quiet
|
|
|
3757 (sgml-message "Parsing..."))
|
|
0
|
3758 (sgml-with-parser-syntax
|
|
2
|
3759 (sgml-parser-loop extra-cond))
|
|
|
3760 (unless quiet
|
|
|
3761 (sgml-message "")))
|
|
0
|
3762
|
|
|
3763 (defun sgml-reparse-buffer (shortref-fun)
|
|
|
3764 "Reparse the buffer and let SHORTREF-FUN take care of short references.
|
|
|
3765 SHORTREF-FUN is called with the entity as argument and `sgml-markup-start'
|
|
|
3766 pointing to start of short ref and point pointing to the end."
|
|
|
3767 (sgml-note-change-at (point-min))
|
|
|
3768 (let ((sgml-shortref-handler shortref-fun))
|
|
|
3769 (sgml-parse-until-end-of nil)))
|
|
|
3770
|
|
|
3771 (defun sgml-move-current-state (token)
|
|
|
3772 (setq sgml-current-state
|
|
|
3773 (or (sgml-get-move sgml-current-state token)
|
|
|
3774 sgml-current-state)))
|
|
|
3775
|
|
|
3776 (defun sgml-execute-implied (imps type)
|
|
|
3777 (loop for token in imps do
|
|
|
3778 (if (eq t token)
|
|
|
3779 (sgml-implied-end-tag type sgml-markup-start sgml-markup-start)
|
|
|
3780 (sgml-move-current-state token)
|
|
|
3781 (when sgml-throw-on-element-change
|
|
|
3782 (throw sgml-throw-on-element-change 'start))
|
|
|
3783 (sgml-open-element (sgml-token-eltype token)
|
|
|
3784 nil sgml-markup-start sgml-markup-start)
|
|
|
3785 (unless (and sgml-current-omittag
|
|
|
3786 (sgml-element-stag-optional sgml-current-tree))
|
|
|
3787 (sgml-log-warning
|
|
|
3788 "%s start-tag implied by %s; not minimizable"
|
|
|
3789 (sgml-eltype-name (sgml-token-eltype token))
|
|
|
3790 type)))))
|
|
|
3791
|
|
|
3792 (defun sgml-do-move (token type)
|
|
|
3793 (sgml-execute-implied (sgml-list-implications token type) type)
|
|
|
3794 (unless (eq sgml-any sgml-current-state)
|
|
|
3795 (sgml-move-current-state token)))
|
|
|
3796
|
|
|
3797 (defun sgml-pcdata-move ()
|
|
|
3798 "Moify parser state to reflect parsed data."
|
|
|
3799 (sgml-do-move sgml-pcdata-token "data character"))
|
|
|
3800
|
|
|
3801 (defsubst sgml-parse-pcdata ()
|
|
|
3802 (/= 0
|
|
|
3803 (if sgml-current-shortmap
|
|
|
3804 (skip-chars-forward (sgml-shortmap-skipstring sgml-current-shortmap))
|
|
|
3805 (skip-chars-forward "^<]/&"))))
|
|
|
3806
|
|
|
3807 (defsubst sgml-do-pcdata ()
|
|
|
3808 ;; Parse pcdata
|
|
|
3809 (sgml-pcdata-move)
|
|
|
3810 ;;*** assume sgml-markup-start = point
|
|
|
3811 ;;*** should perhaps handle &#nn;?
|
|
|
3812 (forward-char 1)
|
|
|
3813 (sgml-parse-pcdata)
|
|
|
3814 (when sgml-data-function
|
|
|
3815 (funcall sgml-data-function (buffer-substring-no-properties
|
|
|
3816 sgml-markup-start
|
|
|
3817 (point))))
|
|
|
3818 (sgml-set-markup-type nil))
|
|
|
3819
|
|
|
3820 (defun sgml-parser-loop (extra-cond)
|
|
|
3821 (let (tem
|
|
|
3822 (sgml-signal-data-function (function sgml-pcdata-move)))
|
|
|
3823 (while (and (eq sgml-current-tree sgml-top-tree)
|
|
|
3824 (or (< (point) sgml-goal) sgml-current-eref)
|
|
|
3825 (progn (setq sgml-markup-start (point)
|
|
|
3826 sgml-markup-type nil)
|
|
|
3827 (or (sgml-parse-s)
|
|
|
3828 (sgml-parse-markup-declaration 'prolog)
|
|
|
3829 (sgml-parse-processing-instruction)))))
|
|
|
3830 (while (and (or (< (point) sgml-goal) sgml-current-eref)
|
|
|
3831 (not (if extra-cond (funcall extra-cond))))
|
|
|
3832 (assert sgml-current-tree)
|
|
|
3833 (setq sgml-markup-start (point)
|
|
|
3834 sgml-markup-type nil)
|
|
|
3835 (cond
|
|
|
3836 ((eobp) (sgml-pop-entity))
|
|
|
3837 ((and (or (eq sgml-current-state sgml-cdata)
|
|
|
3838 (eq sgml-current-state sgml-rcdata)))
|
|
|
3839 (if (or (sgml-parse-delim "ETAGO" gi)
|
|
|
3840 (sgml-is-enabled-net))
|
|
|
3841 (sgml-do-end-tag)
|
|
|
3842 (sgml-do-data sgml-current-state)))
|
|
|
3843 ((and sgml-current-shortmap
|
|
|
3844 (or (setq tem (sgml-deref-shortmap sgml-current-shortmap
|
|
|
3845 (eq (point)
|
|
|
3846 sgml-rs-ignore-pos)))
|
|
|
3847 ;; Restore position, to consider the delim for S+ or data
|
|
|
3848 (progn (goto-char sgml-markup-start)
|
|
|
3849 nil)))
|
|
2
|
3850 (setq sgml-rs-ignore-pos sgml-markup-start) ; don't reconsider RS
|
|
0
|
3851 (funcall sgml-shortref-handler tem))
|
|
|
3852 ((and (not (sgml-current-mixed-p))
|
|
|
3853 (sgml-parse-s sgml-current-shortmap)))
|
|
|
3854 ((or (sgml-parse-delim "ETAGO" gi)
|
|
|
3855 (sgml-is-enabled-net))
|
|
|
3856 (sgml-do-end-tag))
|
|
|
3857 ((sgml-parse-delim "STAGO" gi)
|
|
|
3858 (sgml-do-start-tag))
|
|
|
3859 ((sgml-parse-general-entity-ref))
|
|
|
3860 ((sgml-parse-markup-declaration nil))
|
|
|
3861 ((sgml-parse-delim "MS-END") ; end of marked section
|
|
|
3862 (sgml-set-markup-type 'ms-end))
|
|
|
3863 ((sgml-parse-processing-instruction))
|
|
|
3864 (t
|
|
|
3865 (sgml-do-pcdata))))))
|
|
|
3866
|
|
|
3867 (defun sgml-handle-shortref (name)
|
|
|
3868 (sgml-set-markup-type 'shortref)
|
|
|
3869 (sgml-do-entity-ref name))
|
|
|
3870
|
|
|
3871 (defun sgml-do-start-tag ()
|
|
|
3872 ;; Assume point after STAGO
|
|
|
3873 (when sgml-throw-on-element-change
|
|
|
3874 (throw sgml-throw-on-element-change 'start))
|
|
|
3875 (setq sgml-conref-flag nil)
|
|
2
|
3876 (let (net-enabled et asl)
|
|
0
|
3877 (setq et (if (sgml-is-delim "TAGC") ; empty start-tag
|
|
|
3878 (sgml-do-empty-start-tag)
|
|
|
3879 (sgml-lookup-eltype (sgml-check-name))))
|
|
|
3880 (unless (sgml-parse-delim "TAGC") ; optimize common case
|
|
|
3881 (setq asl (sgml-parse-attribute-specification-list et))
|
|
|
3882 (or
|
|
|
3883 (if (sgml-parse-delim "NET")
|
|
|
3884 (prog1 (setq net-enabled t)
|
|
|
3885 (or sgml-current-shorttag
|
|
|
3886 (sgml-log-warning
|
|
|
3887 "NET enabling start-tag is not allowed with SHORTTAG NO"))))
|
|
|
3888 (sgml-check-tag-close)))
|
|
|
3889 (sgml-set-markup-type 'start-tag)
|
|
|
3890 (cond ((and sgml-ignore-undefined-elements
|
|
|
3891 (not (sgml-eltype-defined et)))
|
|
|
3892 (when sgml-warn-about-undefined-elements
|
|
|
3893 (sgml-log-warning
|
|
|
3894 "Start-tag of undefined element %s; ignored"
|
|
|
3895 (sgml-eltype-name et))))
|
|
|
3896 (t
|
|
|
3897 (sgml-do-move (sgml-eltype-token et)
|
|
|
3898 (format "%s start-tag" (sgml-eltype-name et)))
|
|
|
3899 (sgml-open-element et sgml-conref-flag
|
|
|
3900 sgml-markup-start (point) asl)
|
|
|
3901 (when net-enabled
|
|
|
3902 (setf (sgml-tree-net-enabled sgml-current-tree) t))))))
|
|
|
3903
|
|
|
3904
|
|
|
3905 (defun sgml-do-empty-start-tag ()
|
|
|
3906 "Return eltype to use if empty start tag"
|
|
|
3907 (cond
|
|
|
3908 ;; Document element if no element is open
|
|
|
3909 ((eq sgml-current-tree sgml-top-tree)
|
|
|
3910 (sgml-lookup-eltype
|
|
|
3911 (sgml-dtd-doctype sgml-dtd-info)))
|
|
|
3912 ;; If omittag use current open element
|
|
|
3913 (sgml-current-omittag
|
|
|
3914 (sgml-tree-eltype sgml-current-tree))
|
|
|
3915 ;; Find the eltype of the last closed element.
|
|
|
3916 ;; If element has a left sibling then use that
|
|
|
3917 (sgml-previous-tree
|
|
|
3918 (sgml-tree-eltype sgml-previous-tree))
|
|
|
3919 ;; No sibling, last closed must be found in enclosing element
|
|
|
3920 (t
|
|
|
3921 (loop named outer
|
|
|
3922 for current = sgml-current-tree then (sgml-tree-parent current)
|
|
|
3923 for parent = (sgml-tree-parent current)
|
|
|
3924 do;; Search for a parent with a child before current
|
|
|
3925 (when (eq parent sgml-top-tree)
|
|
|
3926 (sgml-error "No previously closed element"))
|
|
|
3927 (unless (eq current (sgml-tree-content parent))
|
|
|
3928 ;; Search content of u for element before current
|
|
|
3929 (loop for c = (sgml-tree-content parent) then (sgml-tree-next c)
|
|
|
3930 do (when (eq current (sgml-tree-next c))
|
|
|
3931 (return-from outer (sgml-tree-eltype c)))))))))
|
|
|
3932
|
|
|
3933
|
|
|
3934 (defun sgml-do-end-tag ()
|
|
|
3935 "Assume point after </ or at / in a NET"
|
|
|
3936 (let ((gi "Null") ; Name of element to end or "NET"
|
|
|
3937 et ; Element type of end tag
|
|
|
3938 (found ; Set to true when found element to end
|
|
|
3939 t))
|
|
|
3940 (cond ((sgml-parse-delim "TAGC") ; empty end-tag
|
|
|
3941 (setq et (sgml-tree-eltype sgml-current-tree)))
|
|
|
3942 ((sgml-parse-delim "NET"))
|
|
|
3943 (t
|
|
|
3944 (setq et (sgml-lookup-eltype (sgml-check-name)))
|
|
|
3945 (sgml-parse-s)
|
|
|
3946 (sgml-check-tag-close)))
|
|
|
3947 (sgml-set-markup-type 'end-tag) ; This will create the overlay for
|
|
|
3948 ; the end-tag before the element
|
|
|
3949 ; is closed
|
|
|
3950 (when et
|
|
|
3951 (setq gi (sgml-eltype-name et))
|
|
|
3952 (setq found ; check if there is an open element
|
|
|
3953 ; with the right eltype
|
|
|
3954 (loop for u = sgml-current-tree then (sgml-tree-parent u)
|
|
|
3955 while u
|
|
|
3956 thereis (eq et (sgml-tree-eltype u))))
|
|
|
3957 (unless found
|
|
|
3958 (sgml-log-warning
|
|
|
3959 "End-tag %s does not end any open element; ignored"
|
|
|
3960 gi)))
|
|
|
3961 (when found
|
|
|
3962 (setq found nil)
|
|
|
3963 (while (not found) ; Loop until correct element to
|
|
|
3964 ; end is found
|
|
|
3965 (unless (sgml-final-p sgml-current-state)
|
|
|
3966 (sgml-log-warning
|
|
|
3967 "%s element can't end here, need one of %s; %s end-tag out of context"
|
|
|
3968 (sgml-element-gi sgml-current-tree)
|
|
|
3969 (sgml-required-tokens sgml-current-state)
|
|
|
3970 gi))
|
|
|
3971 (when (eq sgml-current-tree sgml-top-tree)
|
|
|
3972 (sgml-error "%s end-tag ended document and parse" gi))
|
|
|
3973 (setq found
|
|
|
3974 (or (eq et (sgml-tree-eltype sgml-current-tree))
|
|
|
3975 (and (null et) ; Null end-tag
|
|
|
3976 (eq t (sgml-tree-net-enabled sgml-current-tree)))))
|
|
|
3977 (unless found
|
|
|
3978 (sgml-implied-end-tag (format "%s end-tag" gi)
|
|
|
3979 sgml-markup-start sgml-markup-start)))
|
|
|
3980 (sgml-close-element sgml-markup-start (point)))))
|
|
|
3981
|
|
|
3982 (defun sgml-is-goal-after-start (goal tree)
|
|
|
3983 (and tree
|
|
2
|
3984 (if (sgml-bpos-p (sgml-tree-stag-epos tree))
|
|
|
3985 (> goal (sgml-tree-stag-epos tree))
|
|
|
3986 (>= goal (sgml-epos-after (sgml-tree-stag-epos tree))))))
|
|
0
|
3987
|
|
|
3988 (defun sgml-find-start-point (goal)
|
|
|
3989 (let ((u sgml-top-tree))
|
|
|
3990 (while
|
|
|
3991 (cond
|
|
|
3992 ((sgml-is-goal-after-start goal (sgml-tree-next u))
|
|
|
3993 (setq u (sgml-tree-next u)))
|
|
|
3994 ((and (sgml-tree-etag-epos u)
|
|
|
3995 (if (> (sgml-tree-etag-len u) 0) ; if threre is an end-tag
|
|
|
3996 (>= goal (sgml-tree-end u)) ; precisely after is after
|
|
|
3997 (> goal (sgml-tree-end u)))) ; else it could possibly
|
|
|
3998 ; become part of the element
|
|
|
3999 (sgml-set-parse-state u 'after)
|
|
|
4000 nil)
|
|
|
4001 ((sgml-is-goal-after-start goal (sgml-tree-content u))
|
|
|
4002 (setq u (sgml-tree-content u)))
|
|
|
4003 (t
|
|
|
4004 (sgml-set-parse-state u 'start)
|
|
|
4005 nil)))
|
|
|
4006 )
|
|
|
4007 )
|
|
|
4008
|
|
|
4009
|
|
|
4010 (defun sgml-check-tag-close ()
|
|
|
4011 (or
|
|
|
4012 (sgml-parse-delim "TAGC")
|
|
|
4013 (if (or (sgml-is-delim "STAGO" gi)
|
|
|
4014 (sgml-is-delim "ETAGO" gi))
|
|
|
4015 (or sgml-current-shorttag
|
|
|
4016 (sgml-log-warning
|
|
|
4017 "Unclosed tag is not allowed with SHORTTAG NO")
|
|
|
4018 t))
|
|
|
4019 (sgml-error "Invalid character in markup %c"
|
|
|
4020 (following-char))))
|
|
|
4021
|
|
|
4022 (defun sgml-implied-end-tag (type start end)
|
|
|
4023 (cond ((eq sgml-current-tree sgml-top-tree)
|
|
|
4024 (unless (= start (point-max))
|
|
|
4025 (sgml-error
|
|
|
4026 "document ended by %s" type)))
|
|
|
4027 ((not
|
|
|
4028 (and sgml-current-omittag
|
|
|
4029 (sgml-element-etag-optional sgml-current-tree)))
|
|
|
4030 (sgml-log-warning
|
|
|
4031 "%s end-tag implied by %s; not minimizable"
|
|
|
4032 (sgml-element-gi sgml-current-tree)
|
|
|
4033 type)))
|
|
|
4034 (sgml-close-element start end))
|
|
|
4035
|
|
|
4036
|
|
|
4037 ;;;; Parsing tasks and extending the element view of the parse tree
|
|
|
4038
|
|
|
4039 (defun sgml-find-context-of (pos)
|
|
|
4040 "Find the parser context for POS, returns the parse tree.
|
|
|
4041 Also sets sgml-current-tree and sgml-current-state. If POS is in
|
|
|
4042 markup, sgml-markup-type will be a symbol identifying the markup
|
|
|
4043 type. It will be nil otherwise."
|
|
|
4044 (save-excursion
|
|
|
4045 (sgml-parse-to pos)
|
|
|
4046 (cond ((and (> (point) pos)
|
|
|
4047 sgml-markup-type)
|
|
|
4048 ;;(setq sgml-current-state sgml-markup-type)
|
|
|
4049 (cond ((memq sgml-markup-type '(start-tag end-tag))
|
|
|
4050 (setq sgml-current-tree sgml-markup-tree))))
|
|
|
4051 (t
|
|
|
4052 (setq sgml-markup-type nil)))
|
|
|
4053 sgml-current-tree))
|
|
|
4054
|
|
|
4055 (defun sgml-parse-to-here ()
|
|
|
4056 "Find context of point.
|
|
|
4057 See documentation of sgml-find-context-of."
|
|
|
4058 (sgml-find-context-of (point)))
|
|
|
4059
|
|
|
4060 (defun sgml-find-element-of (pos)
|
|
|
4061 "Find the element containing character at POS."
|
|
|
4062 (when (eq pos (point-max))
|
|
|
4063 (error "End of buffer"))
|
|
|
4064 (save-excursion
|
|
|
4065 (sgml-parse-to (1+ pos)) ; Ensures that the element is
|
|
|
4066 ; in the tree.
|
|
|
4067 ;; Find p in u:
|
|
|
4068 ;; assert p >= start(u)
|
|
|
4069 ;; if next(u) and p >= start(next(u)): find p in next(u)
|
|
|
4070 ;; else if end(u) and p >= end(u): in parent(u) unless u is top
|
|
|
4071 ;; else if content:
|
|
|
4072 ;; if p < start(content(u)): in u
|
|
|
4073 ;; else find p in content(u)
|
|
|
4074 ;; else: in u
|
|
|
4075 (let ((u sgml-top-tree))
|
|
|
4076 (while ; pos >= start(u)
|
|
|
4077 (cond ((and (sgml-tree-next u)
|
|
|
4078 (>= pos (sgml-element-start (sgml-tree-next u))))
|
|
|
4079 (setq u (sgml-tree-next u))) ; continue searching next node
|
|
|
4080 ((and (sgml-tree-etag-epos u)
|
|
|
4081 (>= pos (sgml-tree-end u)))
|
|
|
4082 (setq u (sgml-tree-parent u)) ; must be parent node
|
|
|
4083 nil)
|
|
|
4084 ((and (sgml-tree-content u)
|
|
|
4085 (>= pos (sgml-element-start (sgml-tree-content u))))
|
|
|
4086 (setq u (sgml-tree-content u))))) ; search content
|
|
|
4087 u)))
|
|
|
4088
|
|
|
4089 (defun sgml-find-previous-element (pos &optional in-element)
|
|
|
4090 "Find the element before POS and return it, error if non found.
|
|
|
4091 If in IN-ELEMENT is given look for previous element in IN-ELEMENT else
|
|
|
4092 look in current element. If this element has no content elements but
|
|
|
4093 end at POS, it will be returned as previous element."
|
|
|
4094 (save-excursion
|
|
|
4095 ;; Parse to point; now the previous element is in the parse tree
|
|
|
4096 (sgml-parse-to pos)
|
|
|
4097 ;; containing element may be given or obtained from parser
|
|
|
4098 (or in-element (setq in-element sgml-current-tree))
|
|
|
4099 ;; in-element is the containing element
|
|
|
4100 (let* ((c ; this is the content of the
|
|
|
4101 ; containing element
|
|
|
4102 (sgml-tree-content in-element)))
|
|
|
4103 (while
|
|
|
4104 (cond
|
|
|
4105 ((null c) ; If c = Nil: no previous element.
|
|
|
4106 ;; But maybe the containing element ends at pos too.
|
|
|
4107 (cond ((= pos (sgml-element-end in-element))
|
|
|
4108 (setq c in-element))) ; Previous is parent!
|
|
|
4109 nil)
|
|
|
4110 ((<= pos (sgml-element-start c)) ; Pos before first content el
|
|
|
4111 (setq c nil)) ; No, previous element.
|
|
|
4112 ((null (sgml-tree-next c)) nil) ; No next, c must be the prev el
|
|
|
4113 ((>= (sgml-element-start (sgml-tree-next c)) pos)
|
|
|
4114 nil)
|
|
|
4115 (t
|
|
|
4116 (setq c (sgml-tree-next c)))))
|
|
|
4117 (or c
|
|
|
4118 (error "No previous element in %s element"
|
|
|
4119 (sgml-element-gi in-element))))))
|
|
|
4120
|
|
|
4121 (defun sgml-find-element-after (pos &optional in-element)
|
|
|
4122 "Find the first element starting after POS.
|
|
|
4123 Returns parse tree; error if no element after POS."
|
|
|
4124 (setq in-element (or in-element
|
|
|
4125 (save-excursion (sgml-find-context-of pos))))
|
|
|
4126 (or
|
|
|
4127 ;; First try to find element after POS in IN-ELEMENT/current element
|
|
|
4128 (let ((c ; content of in-element
|
|
|
4129 (sgml-element-content in-element)))
|
|
|
4130 (while (and c
|
|
|
4131 (> pos (sgml-element-start c)))
|
|
|
4132 (setq c (sgml-element-next c)))
|
|
|
4133 c)
|
|
|
4134 ;; If there is no more elements IN-ELEMENT/current element try
|
|
|
4135 ;; to identify the element containing the character after POS.
|
|
|
4136 ;; If this element starts at POS, use it for element after POS.
|
|
|
4137 (let ((el (sgml-find-element-of pos)))
|
|
|
4138 (if (and el (= pos (sgml-element-start el)))
|
|
|
4139 el))
|
|
|
4140 (progn
|
|
|
4141 (sgml-message "") ; force display of log buffer
|
|
|
4142 (error "No more elements in %s element"
|
|
|
4143 (sgml-element-gi in-element)))))
|
|
|
4144
|
|
|
4145 (defun sgml-element-content (element)
|
|
|
4146 "First element in content of ELEMENT, or nil."
|
|
|
4147 (when (null (or (sgml-tree-content element)
|
|
|
4148 (sgml-tree-etag-epos element)))
|
|
|
4149 (save-excursion (sgml-parse-until-end-of t)))
|
|
|
4150 (sgml-tree-content element))
|
|
|
4151
|
|
|
4152 (defun sgml-element-next (element)
|
|
|
4153 "Next sibling of ELEMENT."
|
|
|
4154 (unless (sgml-tree-etag-epos element)
|
|
|
4155 (save-excursion (sgml-parse-until-end-of element)))
|
|
|
4156 (unless (or (sgml-tree-next element)
|
|
|
4157 (sgml-tree-etag-epos (sgml-tree-parent element)))
|
|
|
4158 (save-excursion (sgml-parse-until-end-of t)))
|
|
|
4159 (sgml-tree-next element))
|
|
|
4160
|
|
|
4161 (defun sgml-element-etag-start (element)
|
|
|
4162 "Last position in content of ELEMENT and start of end-tag, if any."
|
|
|
4163 (unless (sgml-tree-etag-epos element)
|
|
|
4164 (save-excursion
|
|
|
4165 (sgml-parse-until-end-of element)))
|
|
|
4166 (assert (sgml-tree-etag-epos element))
|
|
|
4167 (sgml-epos-promote (sgml-tree-etag-epos element)))
|
|
|
4168
|
|
|
4169 (defun sgml-element-end (element)
|
|
|
4170 "First position after ELEMENT."
|
|
|
4171 (sgml-element-etag-start element) ; make end be defined
|
|
|
4172 (sgml-tree-end element))
|
|
|
4173
|
|
|
4174 (defun sgml-read-element-name (prompt)
|
|
|
4175 (sgml-parse-to-here)
|
|
|
4176 (cond (sgml-markup-type
|
|
|
4177 (error "No elements allowed in markup"))
|
|
|
4178 ((and ;;sgml-buffer-eltype-map
|
|
|
4179 (not (eq sgml-current-state sgml-any)))
|
|
|
4180 (let ((tab
|
|
|
4181 (mapcar (function (lambda (x) (cons (symbol-name x) nil)))
|
|
|
4182 (sgml-current-list-of-valid-eltypes))))
|
|
|
4183 (cond ((null tab)
|
|
|
4184 (error "No element valid at this point"))
|
|
|
4185 (t
|
|
|
4186 (completing-read prompt tab nil t
|
|
|
4187 (and (null (cdr tab)) (caar tab)))))))
|
|
|
4188 (t
|
|
|
4189 (read-from-minibuffer prompt))))
|
|
|
4190
|
|
|
4191 (defun sgml-element-attribute-specification-list (element)
|
|
|
4192 "Return the attribute specification list for ELEMENT.
|
|
|
4193 This is a list of (attname value) lists."
|
|
|
4194 ;;; (if (> (sgml-element-stag-len element) 2)
|
|
|
4195 ;;; (save-excursion
|
|
|
4196 ;;; (sgml-with-parser-syntax
|
|
|
4197 ;;; (sgml-goto-epos (sgml-element-stag-epos element))
|
|
|
4198 ;;; (sgml-check-delim "STAGO")
|
|
|
4199 ;;; (sgml-check-name)
|
|
|
4200 ;;; (prog1 (sgml-parse-attribute-specification-list
|
|
|
4201 ;;; (sgml-element-eltype element))
|
|
|
4202 ;;; (sgml-pop-all-entities)))))
|
|
|
4203 (sgml-tree-asl element))
|
|
|
4204
|
|
|
4205 (defun sgml-find-attribute-element ()
|
|
|
4206 "Return the element to which an attribute editing command should be applied."
|
|
|
4207 (let ((el (sgml-find-element-of (point))))
|
|
|
4208 (save-excursion
|
|
|
4209 (sgml-parse-to (point))
|
|
|
4210 ;; If after a start-tag of an empty element return that element
|
|
|
4211 ;; instead of current element
|
|
|
4212 (if (eq sgml-markup-type 'start-tag)
|
|
|
4213 sgml-markup-tree ; the element of the start-tag
|
|
|
4214 el))))
|
|
|
4215
|
|
|
4216
|
|
|
4217 (defun sgml-element-attval (element attribute)
|
|
|
4218 "Return the value of the ATTRIBUTE in ELEMENT, string or nil."
|
|
|
4219 (let ((asl (sgml-element-attribute-specification-list element))
|
|
|
4220 (def (sgml-attdecl-default-value
|
|
|
4221 (sgml-lookup-attdecl attribute (sgml-element-attlist element)))))
|
|
|
4222 (or (sgml-attspec-attval (sgml-lookup-attspec attribute asl))
|
|
|
4223 (sgml-default-value-attval def))))
|
|
|
4224
|
|
|
4225
|
|
|
4226 (defun sgml-cohere-name (x)
|
|
|
4227 "Convert X into a string where X can be a string, a symbol or an element."
|
|
|
4228 (cond ((stringp x) x)
|
|
|
4229 ((symbolp x) (symbol-name x))
|
|
|
4230 (t (sgml-element-gi x))))
|
|
|
4231
|
|
|
4232 (defun sgml-start-tag-of (element)
|
|
|
4233 "Return the start-tag for ELEMENT."
|
|
|
4234 (format "<%s>" (sgml-cohere-name element)))
|
|
|
4235
|
|
|
4236 (defun sgml-end-tag-of (element)
|
|
|
4237 "Return the end-tag for ELEMENT (token or element)."
|
|
|
4238 (format "</%s>" (sgml-cohere-name element)))
|
|
|
4239
|
|
|
4240 (defun sgml-top-element ()
|
|
|
4241 "Return the document element."
|
|
|
4242 (sgml-element-content (sgml-find-context-of (point-min))))
|
|
|
4243
|
|
|
4244 (defun sgml-off-top-p (element)
|
|
|
4245 "True if ELEMENT is the pseudo element above the document element."
|
|
|
4246 (null (sgml-tree-parent element)))
|
|
|
4247
|
|
|
4248 (defun sgml-safe-context-of (pos)
|
|
|
4249 (let ((sgml-throw-on-error 'parse-error))
|
|
|
4250 (catch sgml-throw-on-error
|
|
|
4251 (sgml-find-context-of pos))))
|
|
|
4252
|
|
|
4253 (defun sgml-safe-element-at (pos)
|
|
|
4254 (let ((sgml-throw-on-error 'parse-error))
|
|
|
4255 (catch sgml-throw-on-error
|
|
|
4256 (if (= pos (point-max))
|
|
|
4257 (sgml-find-context-of pos)
|
|
|
4258 (sgml-find-element-of pos)))))
|
|
|
4259
|
|
|
4260 (defun sgml-in-prolog-p ()
|
|
|
4261 (let ((el (sgml-safe-context-of (point))))
|
|
|
4262 (or (null el)
|
|
|
4263 (sgml-off-top-p el))))
|
|
|
4264
|
|
|
4265
|
|
|
4266 ;;;; Provide
|
|
|
4267
|
|
|
4268 (provide 'psgml-parse)
|
|
|
4269
|
|
2
|
4270 ;; Local variables:
|
|
|
4271 ;; byte-compile-warnings:(free-vars unresolved callargs redefine)
|
|
|
4272 ;; End:
|
|
0
|
4273 ;;; psgml-parse.el ends here
|
