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