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