Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-debug.el @ 2:ac2d302a0011 r19-15b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b2
author cvs
date Mon, 13 Aug 2007 08:46:35 +0200
parents 376386a54a3c
children 131b0175ea99
comparison
equal deleted inserted replaced
1:c0c6a60d29db 2:ac2d302a0011
1 ;;;;\filename dump.el 1 ;;;;\filename dump.el
2 ;;;\Last edited: Fri Nov 25 18:30:01 1994 by lenst@dell (Lennart Staflin) 2 ;;;\Last edited: Sun Mar 24 19:17:42 1996 by lenst@triton.lstaflin.pp.se (Lennart Staflin)
3 ;;;\RCS $Id: psgml-debug.el,v 1.1.1.1 1996/12/18 03:35:18 steve Exp $ 3 ;;;\RCS $Id: psgml-debug.el,v 1.1.1.2 1996/12/18 03:47:13 steve Exp $
4 ;;;\author {Lennart Staflin} 4 ;;;\author {Lennart Staflin}
5 ;;;\maketitle 5 ;;;\maketitle
6 6
7 ;;\begin{codeseg} 7 ;;\begin{codeseg}
8 (provide 'psgml-debug) 8 (provide 'psgml-debug)
9 (require 'psgml) 9 (require 'psgml)
10 (require 'psgml-parse) 10 (require 'psgml-parse)
11 (require 'psgml-edit) 11 (require 'psgml-edit)
12 ;;(require 'psgml-dtd) 12 (require 'psgml-dtd)
13 (autoload 'sgml-translate-model "psgml-dtd" "" nil) 13 (autoload 'sgml-translate-model "psgml-dtd" "" nil)
14 14
15 ;;;; Debugging 15 ;;;; Debugging
16 16
17 (define-key sgml-mode-map "\C-c," 'sgml-goto-cache) 17 (define-key sgml-mode-map "\C-c," 'sgml-goto-cache)
18 (define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree) 18 (define-key sgml-mode-map "\C-c\C-x" 'sgml-dump-tree)
19 (define-key sgml-mode-map "\C-c." 'sgml-shortref-identify)
19 20
20 (defun sgml-this-element () 21 (defun sgml-this-element ()
21 (interactive) 22 (interactive)
22 (let ((tree (sgml-find-element-of (point)))) 23 (let ((tree (sgml-find-element-of (point))))
23 (sgml-dump-rec tree))) 24 (sgml-dump-rec tree)))
25 (defun sgml-goto-cache () 26 (defun sgml-goto-cache ()
26 (interactive) 27 (interactive)
27 (setq sgml-dtd-info (sgml-pstate-dtd sgml-buffer-parse-state) 28 (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-top-tree (sgml-pstate-top-tree sgml-buffer-parse-state))
29 (sgml-find-start-point (point)) 30 (sgml-find-start-point (point))
30 (message "%s" (sgml-element-context-string sgml-top-tree))) 31 (message "%s" (sgml-dump-node sgml-current-tree)))
31 32
32 (defun sgml-dump-tree (arg) 33 (defun sgml-dump-tree (arg)
33 (interactive "P") 34 (interactive "P")
34 (when arg 35 (when arg
35 (sgml-parse-to-here)) 36 (sgml-parse-to-here))
36 (with-output-to-temp-buffer "*Dump*" 37 (with-output-to-temp-buffer "*Dump*"
37 (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state)))) 38 (sgml-dump-rec (sgml-pstate-top-tree sgml-buffer-parse-state))))
38 39
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
39 (defun sgml-comepos (epos) 61 (defun sgml-comepos (epos)
40 (if (sgml-strict-epos-p epos) 62 (if (sgml-strict-epos-p epos)
41 (format "%s:%s" 63 (format "%s:%s"
42 (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos))) 64 (sgml-entity-name (sgml-eref-entity (sgml-epos-eref epos)))
43 (sgml-epos-pos epos)) 65 (sgml-epos-pos epos))
44 (format "%s" epos))) 66 (format "%s" epos)))
45 67
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
46 (defun sgml-dump-rec (u) 79 (defun sgml-dump-rec (u)
47 (while u 80 (while u
48 (princ 81 (princ (sgml-dump-node u))
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)) 82 (sgml-dump-rec (sgml-tree-content u))
59 (setq u (sgml-tree-next u)))) 83 (setq u (sgml-tree-next u))))
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"))))
60 103
61 ;;;; For edebug 104 ;;;; For edebug
62 105
63 ;;(put 'when 'edebug-form-hook t) 106 ;;(put 'when 'edebug-form-hook t)
64 ;;(put 'unless 'edebug-form-hook t) 107 ;;(put 'unless 'edebug-form-hook t)
65 ;;(put 'push 'edebug-form-hook '(form sexp)) 108 ;;(put 'push 'edebug-form-hook '(form sexp))
66 ;;(put 'setf 'edebug-form-hook '(sexp form)) 109 ;;(put 'setf 'edebug-form-hook '(sexp form))
67 110
111 (setq edebug-print-level 3
112 edebug-print-length 5
113 edebug-print-circle nil
114 )
115
68 (eval-when (load) 116 (eval-when (load)
69 (def-edebug-spec sgml-with-parser-syntax (&rest form)) 117 (unless sgml-running-xemacs
70 (def-edebug-spec sgml-skip-upto (sexp)) 118 (def-edebug-spec sgml-with-parser-syntax (&rest form))
71 (def-edebug-spec sgml-check-delim (sexp &optional sexp)) 119 (def-edebug-spec sgml-skip-upto (sexp))
72 (def-edebug-spec sgml-parse-delim (sexp &optional sexp)) 120 (def-edebug-spec sgml-check-delim (sexp &optional sexp))
73 (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp))) 121 (def-edebug-spec sgml-parse-delim (sexp &optional sexp))
122 (def-edebug-spec sgml-is-delim (sexp &optional sexp sexp sexp))))
74 123
75 ;;;; dump 124 ;;;; dump
76 125
77 (defun sgml-dump-dtd (&optional dtd) 126 (defun sgml-dump-dtd (&optional dtd)
78 (interactive ) 127 (interactive )
90 (sgml-dtd-eltypes 139 (sgml-dtd-eltypes
91 (sgml-pstate-dtd sgml-buffer-parse-state)) 140 (sgml-pstate-dtd sgml-buffer-parse-state))
92 nil t))) 141 nil t)))
93 (with-output-to-temp-buffer "*Element dump*" 142 (with-output-to-temp-buffer "*Element dump*"
94 (sgml-dp-element (sgml-lookup-eltype el-name)))) 143 (sgml-dp-element (sgml-lookup-eltype el-name))))
95
96 144
97 (defun sgml-dp-element (el) 145 (defun sgml-dp-element (el)
98 (cond 146 (cond
99 ((sgml-eltype-defined el) 147 ((sgml-eltype-defined el)
100 (princ (format "Element %s %s %s%s:\n" 148 (princ (format "Element %s %s %s%s:\n"
127 (cond ((sgml-normal-state-p (car x)) 175 (cond ((sgml-normal-state-p (car x))
128 (princ (format "%s%d: opts=%s reqs=%s\n" 176 (princ (format "%s%d: opts=%s reqs=%s\n"
129 (make-string indent ? ) i 177 (make-string indent ? ) i
130 (sgml-untangel-moves (sgml-state-opts (car x))) 178 (sgml-untangel-moves (sgml-state-opts (car x)))
131 (sgml-untangel-moves (sgml-state-reqs (car x)))))) 179 (sgml-untangel-moves (sgml-state-reqs (car x))))))
132 (t ; &node 180 (t ; and-node
133 (princ (format "%s%d: &node next=%d\n" 181 (princ (format "%s%d: and-node next=%d\n"
134 (make-string indent ? ) i 182 (make-string indent ? ) i
135 (sgml-code-xlate (sgml-&node-next (car x))))) 183 (sgml-code-xlate (sgml-and-node-next (car x)))))
136 (loop for m in (sgml-&node-dfas (car x)) 184 (loop for m in (sgml-and-node-dfas (car x))
137 do (sgml-dp-model m (+ indent 2)))))))) 185 do (sgml-dp-model m (+ indent 2))))))))
138 186
139 (defun sgml-untangel-moves (moves) 187 (defun sgml-untangel-moves (moves)
140 (loop for m in moves 188 (loop for m in moves
141 collect (list (sgml-move-token m) 189 collect (list (sgml-move-token m)
142 (sgml-code-xlate (sgml-move-dest m))))) 190 (sgml-code-xlate (sgml-move-dest m)))))
191
192
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 ? )))))))
143 214
144 215
145 ;;;; Build autoloads for all interactive functions in psgml-parse 216 ;;;; Build autoloads for all interactive functions in psgml-parse
146 217
147 (defun sgml-build-autoloads () 218 (defun sgml-build-autoloads ()
209 280
210 ;;;; Profiling 281 ;;;; Profiling
211 282
212 (defun profile-sgml (&optional file) 283 (defun profile-sgml (&optional file)
213 (interactive) 284 (interactive)
214 (or file (setq file (expand-file-name "~/src/psgml/test/shortref.sgml"))) 285 (or file (setq file (expand-file-name "~/src/psgml/0/test/shortref.sgml")))
215 (find-file file) 286 (find-file file)
216 (sgml-need-dtd) 287 (sgml-need-dtd)
217 (sgml-instrument-parser) 288 (sgml-instrument-parser)
218 (elp-reset-all) 289 (elp-reset-all)
219 (dotimes (i 20) 290 (dotimes (i 20)