|
0
|
1 ;;;;\filename dump.el
|
|
2
|
2 ;;;\Last edited: Sun Mar 24 19:17:42 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
|
|
70
|
3 ;;;\RCS $Id: psgml-debug.el,v 1.1.1.1 1996/12/18 22:43:36 steve Exp $
|
|
0
|
4 ;;;\author {Lennart Staflin}
|
|
|
5 ;;;\maketitle
|
|
|
6
|
|
|
7 ;;\begin{codeseg}
|
|
|
8 (provide 'psgml-debug)
|
|
|
9 (require 'psgml)
|
|
|
10 (require 'psgml-parse)
|
|
|
11 (require 'psgml-edit)
|
|
2
|
12 (require 'psgml-dtd)
|
|
0
|
13 (autoload 'sgml-translate-model "psgml-dtd" "" nil)
|
|
|
14
|
|
|
15 ;;;; Debugging
|
|
|
16
|
|
|
17 (define-key sgml-mode-map "\C-c," 'sgml-goto-cache)
|
|
|
18 (define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree)
|
|
2
|
19 (define-key sgml-mode-map "\C-c." 'sgml-shortref-identify)
|
|
0
|
20
|
|
|
21 (defun sgml-this-element ()
|
|
|
22 (interactive)
|
|
|
23 (let ((tree (sgml-find-element-of (point))))
|
|
|
24 (sgml-dump-rec tree)))
|
|
|
25
|
|
|
26 (defun sgml-goto-cache ()
|
|
|
27 (interactive)
|
|
|
28 (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state)
|
|
|
29 sgml-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
|
|
|
30 (sgml-find-start-point (point))
|
|
2
|
31 (message "%s" (sgml-dump-node sgml-current-tree)))
|
|
0
|
32
|
|
|
33 (defun sgml-dump-tree (arg)
|
|
|
34 (interactive "P")
|
|
|
35 (when arg
|
|
|
36 (sgml-parse-to-here))
|
|
|
37 (with-output-to-temp-buffer "*Dump*"
|
|
|
38 (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))))
|
|
|
39
|
|
2
|
40 (defun sgml-auto-dump ()
|
|
|
41 (let ((standard-output (get-buffer-create "*Dump*"))
|
|
|
42 (cb (current-buffer)))
|
|
|
43
|
|
|
44 (when sgml-buffer-parse-state
|
|
|
45 (unwind-protect
|
|
|
46 (progn (set-buffer standard-output)
|
|
|
47 (erase-buffer))
|
|
|
48 (set-buffer cb))
|
|
|
49
|
|
|
50 (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))
|
|
|
51
|
|
|
52 ))
|
|
|
53 )
|
|
|
54
|
|
|
55 (defun sgml-start-auto-dump ()
|
|
|
56 (interactive)
|
|
|
57 (add-hook 'post-command-hook
|
|
|
58 (function sgml-auto-dump)
|
|
|
59 'append))
|
|
|
60
|
|
0
|
61 (defun sgml-comepos (epos)
|
|
|
62 (if (sgml-strict-epos-p epos)
|
|
|
63 (format "%s:%s"
|
|
|
64 (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos)))
|
|
|
65 (sgml-epos-pos epos))
|
|
|
66 (format "%s" epos)))
|
|
|
67
|
|
2
|
68 (defun sgml-dump-node (u)
|
|
|
69 (format
|
|
|
70 "%s%s start:%s(%s) end:%s(%s) epos:%s/%s net:%s\n"
|
|
|
71 (make-string (sgml-tree-level u) ?. )
|
|
|
72 (sgml-element-gi u)
|
|
|
73 (sgml-element-start u) (sgml-tree-stag-len u)
|
|
|
74 (if (sgml-tree-etag-epos u) (sgml-tree-end u)) (sgml-tree-etag-len u)
|
|
|
75 (sgml-comepos (sgml-tree-stag-epos u))
|
|
|
76 (sgml-comepos (sgml-tree-etag-epos u))
|
|
|
77 (sgml-tree-net-enabled u)))
|
|
|
78
|
|
0
|
79 (defun sgml-dump-rec (u)
|
|
|
80 (while u
|
|
2
|
81 (princ (sgml-dump-node u))
|
|
0
|
82 (sgml-dump-rec (sgml-tree-content u))
|
|
|
83 (setq u (sgml-tree-next u))))
|
|
2
|
84
|
|
|
85 (defun sgml-shortref-identify ()
|
|
|
86 (interactive)
|
|
|
87 (sgml-find-context-of (point))
|
|
|
88 (let* ((nobol (eq (point) sgml-rs-ignore-pos))
|
|
|
89 (tem (sgml-deref-shortmap sgml-current-shortmap nobol)))
|
|
|
90 (message "%s (%s)" tem nobol)))
|
|
|
91
|
|
|
92 (defun sgml-lookup-shortref-name (table map)
|
|
|
93 (car (rassq map (cdr table))))
|
|
|
94
|
|
|
95 (defun sgml-show-current-map ()
|
|
|
96 (interactive)
|
|
|
97 (sgml-find-context-of (point))
|
|
|
98 (let ((name (sgml-lookup-shortref-name
|
|
|
99 (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
100 sgml-current-shortmap)))
|
|
|
101 (message "Current map: %s"
|
|
|
102 (or name "#EMPTY"))))
|
|
0
|
103
|
|
|
104 ;;;; For edebug
|
|
|
105
|
|
|
106 ;;(put 'when 'edebug-form-hook t)
|
|
|
107 ;;(put 'unless 'edebug-form-hook t)
|
|
|
108 ;;(put 'push 'edebug-form-hook '(form sexp))
|
|
|
109 ;;(put 'setf 'edebug-form-hook '(sexp form))
|
|
|
110
|
|
2
|
111 (setq edebug-print-level 3
|
|
|
112 edebug-print-length 5
|
|
|
113 edebug-print-circle nil
|
|
|
114 )
|
|
|
115
|
|
0
|
116 (eval-when (load)
|
|
2
|
117 (unless sgml-running-xemacs
|
|
|
118 (def-edebug-spec sgml-with-parser-syntax (&rest form))
|
|
|
119 (def-edebug-spec sgml-skip-upto (sexp))
|
|
|
120 (def-edebug-spec sgml-check-delim (sexp &optional sexp))
|
|
|
121 (def-edebug-spec sgml-parse-delim (sexp &optional sexp))
|
|
|
122 (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp))))
|
|
0
|
123
|
|
|
124 ;;;; dump
|
|
|
125
|
|
|
126 (defun sgml-dump-dtd (&optional dtd)
|
|
|
127 (interactive )
|
|
|
128 (unless dtd
|
|
|
129 (setq dtd (sgml-pstate-dtd sgml-buffer-parse-state)))
|
|
|
130 (with-output-to-temp-buffer "*DTD dump*"
|
|
|
131 (princ (format "Dependencies: %S\n"
|
|
|
132 (sgml-dtd-dependencies dtd)))
|
|
|
133 (loop for et being the symbols of (sgml-dtd-eltypes dtd)
|
|
|
134 do (sgml-dp-element et))))
|
|
|
135
|
|
|
136 (defun sgml-dump-element (el-name)
|
|
|
137 (interactive
|
|
|
138 (list (completing-read "Element: "
|
|
|
139 (sgml-dtd-eltypes
|
|
|
140 (sgml-pstate-dtd sgml-buffer-parse-state))
|
|
|
141 nil t)))
|
|
|
142 (with-output-to-temp-buffer "*Element dump*"
|
|
|
143 (sgml-dp-element (sgml-lookup-eltype el-name))))
|
|
|
144
|
|
|
145 (defun sgml-dp-element (el)
|
|
|
146 (cond
|
|
|
147 ((sgml-eltype-defined el)
|
|
|
148 (princ (format "Element %s %s %s%s:\n"
|
|
|
149 (sgml-eltype-name el)
|
|
|
150 (if (sgml-eltype-stag-optional el) "O" "-")
|
|
|
151 (if (sgml-eltype-etag-optional el) "O" "-")
|
|
|
152 (if (sgml-eltype-mixed el) " mixed" "")))
|
|
|
153 (cond
|
|
|
154 ((sgml-model-group-p (sgml-eltype-model el))
|
|
|
155 (sgml-dp-model (sgml-eltype-model el)))
|
|
|
156 (t
|
|
|
157 (prin1 (sgml-eltype-model el))
|
|
|
158 (terpri)))
|
|
|
159 (princ (format "Exeptions: +%S -%S\n"
|
|
|
160 (sgml-eltype-includes el)
|
|
|
161 (sgml-eltype-excludes el)))
|
|
|
162 (princ (format "Attlist: %S\n" (sgml-eltype-attlist el)))
|
|
|
163 (princ (format "Plist: %S\n" (symbol-plist el))))
|
|
|
164 (t
|
|
|
165 (princ (format "Undefined element %s\n" (sgml-eltype-name el)))))
|
|
|
166 (terpri))
|
|
|
167
|
|
|
168
|
|
|
169 (defun sgml-dp-model (model &optional indent)
|
|
|
170 (or indent (setq indent 0))
|
|
|
171 (let ((sgml-code-xlate (sgml-translate-model model)))
|
|
|
172 (loop
|
|
|
173 for i from 0
|
|
|
174 for x in sgml-code-xlate do
|
|
|
175 (cond ((sgml-normal-state-p (car x))
|
|
|
176 (princ (format "%s%d: opts=%s reqs=%s\n"
|
|
|
177 (make-string indent ? ) i
|
|
|
178 (sgml-untangel-moves (sgml-state-opts (car x)))
|
|
|
179 (sgml-untangel-moves (sgml-state-reqs (car x))))))
|
|
2
|
180 (t ; and-node
|
|
|
181 (princ (format "%s%d: and-node next=%d\n"
|
|
0
|
182 (make-string indent ? ) i
|
|
2
|
183 (sgml-code-xlate (sgml-and-node-next (car x)))))
|
|
|
184 (loop for m in (sgml-and-node-dfas (car x))
|
|
0
|
185 do (sgml-dp-model m (+ indent 2))))))))
|
|
|
186
|
|
|
187 (defun sgml-untangel-moves (moves)
|
|
|
188 (loop for m in moves
|
|
|
189 collect (list (sgml-move-token m)
|
|
|
190 (sgml-code-xlate (sgml-move-dest m)))))
|
|
|
191
|
|
|
192
|
|
2
|
193 ;;;; Dump state
|
|
|
194
|
|
|
195 (defun sgml-dump-state ()
|
|
|
196 (interactive)
|
|
|
197 (with-output-to-temp-buffer "*State dump*"
|
|
|
198 (sgml-dp-state sgml-current-state)))
|
|
|
199
|
|
|
200 (defun sgml-dp-state (state &optional indent)
|
|
|
201 (or indent (setq indent 0))
|
|
|
202 (cond
|
|
|
203 ((sgml-normal-state-p state)
|
|
|
204 (sgml-dp-model state indent))
|
|
|
205 (t
|
|
|
206 (princ (format "%sand-state\n" (make-string indent ? )))
|
|
|
207 (sgml-dp-state (sgml-and-state-substate state) (+ 2 indent))
|
|
|
208 (princ (format "%s--next\n" (make-string indent ? )))
|
|
|
209 (sgml-dp-state (sgml-and-state-next state) (+ 2 indent))
|
|
|
210 (princ (format "%s--dfas\n" (make-string indent ? )))
|
|
|
211 (loop for m in (sgml-and-state-dfas state)
|
|
|
212 do (sgml-dp-model m (+ indent 2))
|
|
|
213 (princ (format "%s--\n" (make-string indent ? )))))))
|
|
|
214
|
|
|
215
|
|
0
|
216 ;;;; Build autoloads for all interactive functions in psgml-parse
|
|
|
217
|
|
|
218 (defun sgml-build-autoloads ()
|
|
|
219 (interactive)
|
|
|
220 (with-output-to-temp-buffer "*autoload*"
|
|
|
221 (loop
|
|
|
222 for file in '("psgml-parse" "psgml-edit" "psgml-dtd"
|
|
|
223 "psgml-info" "psgml-charent")
|
|
|
224 do
|
|
|
225 (set-buffer (find-file-noselect (concat file ".el")))
|
|
|
226 (goto-char (point-min))
|
|
|
227 (while (and
|
|
|
228 (not (eobp))
|
|
|
229 (re-search-forward "^(defun +\\([^ ]+\\)" nil t))
|
|
|
230 (let ((name (buffer-substring (match-beginning 1)
|
|
|
231 (match-end 1)))
|
|
|
232 doc)
|
|
|
233 (forward-sexp 1) ; skip argument list
|
|
|
234 (skip-chars-forward " \n\t")
|
|
|
235 (when (eq ?\" (following-char)) ; doc string
|
|
|
236 (setq doc (buffer-substring (point)
|
|
|
237 (progn (forward-sexp 1)
|
|
|
238 (point)))))
|
|
|
239 (skip-chars-forward " \n\t")
|
|
|
240 (when (looking-at "(interactive")
|
|
|
241 (if (null doc)
|
|
|
242 (message "No doc for %s" name))
|
|
|
243 (princ (format
|
|
|
244 "(autoload '%s \"%s\" %s t)\n"
|
|
|
245 name file doc))))))))
|
|
|
246
|
|
|
247 ;;;; Test psgml with sgmls test cases
|
|
|
248
|
|
|
249 (defun test-sgml (start)
|
|
|
250 (interactive "p")
|
|
|
251 (let (file
|
|
|
252 (sgml-show-warnings t))
|
|
|
253 (with-output-to-temp-buffer "*Testing psgml*"
|
|
|
254 (while
|
|
|
255 (progn
|
|
|
256 (setq file (format "/usr/local/src/sgmls-1.1/test/test%03d.sgm"
|
|
|
257 start))
|
|
|
258 (file-exists-p file))
|
|
|
259 (princ (format "*** File test%03d ***\n" start))
|
|
|
260 (find-file file)
|
|
|
261 (condition-case errcode
|
|
|
262 (progn
|
|
|
263 (sgml-parse-prolog)
|
|
|
264 ;;(sgml-next-trouble-spot)
|
|
|
265 (sgml-parse-until-end-of nil)
|
|
|
266 )
|
|
|
267 (error
|
|
|
268 (princ errcode)
|
|
|
269 (terpri)))
|
|
|
270 (if (get-buffer sgml-log-buffer-name)
|
|
|
271 (princ (save-excursion
|
|
|
272 (set-buffer sgml-log-buffer-name)
|
|
|
273 (buffer-string))))
|
|
|
274 (terpri)
|
|
|
275 (terpri)
|
|
|
276 (sit-for 0)
|
|
|
277 (kill-buffer (current-buffer))
|
|
|
278 (setq start (1+ start))))))
|
|
|
279
|
|
|
280
|
|
|
281 ;;;; Profiling
|
|
|
282
|
|
|
283 (defun profile-sgml (&optional file)
|
|
|
284 (interactive)
|
|
2
|
285 (or file (setq file (expand-file-name "~/src/psgml/0/test/shortref.sgml")))
|
|
0
|
286 (find-file file)
|
|
|
287 (sgml-need-dtd)
|
|
|
288 (sgml-instrument-parser)
|
|
|
289 (elp-reset-all)
|
|
|
290 (dotimes (i 20)
|
|
|
291 (garbage-collect)
|
|
|
292 (sgml-reparse-buffer (function sgml-handle-shortref)))
|
|
|
293 (elp-results))
|
|
|
294
|
|
|
295 (defun sgml-instrument-parser ()
|
|
|
296 (interactive)
|
|
|
297 (require 'elp)
|
|
|
298 (setq elp-function-list nil)
|
|
|
299 (elp-restore-all)
|
|
|
300 (setq elp-function-list
|
|
|
301 '(
|
|
|
302 sgml-parse-to
|
|
|
303 sgml-parser-loop
|
|
|
304 sgml-parse-markup-declaration
|
|
|
305 sgml-do-processing-instruction
|
|
|
306 sgml-pop-entity
|
|
|
307 sgml-tree-net-enabled
|
|
|
308 sgml-do-end-tag
|
|
|
309 sgml-do-data
|
|
|
310 sgml-deref-shortmap
|
|
|
311 sgml-handle-shortref
|
|
|
312 sgml-do-start-tag
|
|
|
313 sgml-do-general-entity-ref
|
|
|
314 sgml-set-face-for
|
|
|
315 sgml-pcdata-move
|
|
|
316 sgml-shortmap-skipstring
|
|
|
317 ;;
|
|
|
318 ))
|
|
|
319 (elp-instrument-list))
|
|
|
320
|
|
|
321
|
|
|
322 (defun sgml-instrument-dtd-parser ()
|
|
|
323 (interactive)
|
|
|
324 (require 'elp)
|
|
|
325 (setq elp-function-list nil)
|
|
|
326 (elp-restore-all)
|
|
|
327 (setq elp-function-list
|
|
|
328 '(
|
|
|
329 sgml-parse-prolog
|
|
|
330 sgml-skip-ds
|
|
|
331 sgml-parse-markup-declaration
|
|
|
332 sgml-check-doctype-body
|
|
|
333 ;;
|
|
|
334 sgml-check-dtd-subset
|
|
|
335 sgml-parse-ds
|
|
|
336 sgml-declare-attlist
|
|
|
337 sgml-declare-entity
|
|
|
338 sgml-declare-element
|
|
|
339 sgml-declare-shortref
|
|
|
340 ;;
|
|
|
341 sgml-parse-parameter-literal
|
|
|
342 sgml-check-element-type
|
|
|
343 sgml-check-primitive-content-token
|
|
|
344 sgml-check-model-group
|
|
|
345 ;; In sgml-check-model-group
|
|
|
346 sgml-parse-modifier
|
|
|
347 sgml-make-pcdata
|
|
|
348 sgml-skip-ts
|
|
|
349 sgml-make-opt
|
|
|
350 sgml-make-*
|
|
|
351 sgml-make-+
|
|
|
352 sgml-reduce-,
|
|
|
353 sgml-reduce-|
|
|
|
354 sgml-make-&
|
|
|
355 sgml-make-conc
|
|
|
356 sgml-copy-moves
|
|
|
357 ;; is ps*
|
|
|
358 sgml-do-parameter-entity-ref
|
|
|
359 ;;
|
|
|
360 sgml-make-primitive-content-token
|
|
|
361 sgml-push-to-entity
|
|
|
362 sgml-lookup-entity
|
|
|
363 sgml-lookup-eltype
|
|
|
364 sgml-one-final-state
|
|
|
365 sgml-remove-redundant-states-1
|
|
|
366 ))
|
|
|
367 (elp-instrument-list))
|
|
|
368
|
|
|
369
|
|
|
370 ;¤¤\end{codeseg}
|
