Mercurial > emacs
comparison lisp/cedet/semantic/debug.el @ 104421:b66bb908c129
cedet/semantic/debug.el,
cedet/semantic/doc.el,
cedet/semantic/tag-write.el,
cedet/semantic/analyze/complete.el,
cedet/semantic/analyze/debug.el,
cedet/semantic/analyze/fcn.el,
cedet/semantic/analyze/refs.el: New files.
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sat, 29 Aug 2009 19:45:47 +0000 |
parents | |
children | 3e6235dcb480 |
comparison
equal
deleted
inserted
replaced
104420:2e15afd37998 | 104421:b66bb908c129 |
---|---|
1 ;;; debug.el --- Language Debugger framework | |
2 | |
3 ;;; Copyright (C) 2003, 2004, 2005, 2008 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software: you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation, either version 3 of the License, or | |
12 ;; (at your option) any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
21 | |
22 ;;; Commentary: | |
23 ;; | |
24 ;; To provide better support for debugging parsers, this framework | |
25 ;; provides the interface for debugging. The work of parsing and | |
26 ;; controlling and stepping through the parsing work must be implemented | |
27 ;; by the parser. | |
28 ;; | |
29 ;; Fortunatly, the nature of language support files means that the parser | |
30 ;; may not need to be instrumented first. | |
31 ;; | |
32 ;; The debugger uses EIEIO objects. One object controls the user | |
33 ;; interface, including stepping, data-view, queries. A second | |
34 ;; object implemented here represents the parser itself. A third represents | |
35 ;; a parser independent frame which knows how to highlight the parser buffer. | |
36 ;; Each parser must implement the interface and override any methods as needed. | |
37 ;; | |
38 | |
39 (require 'semantic) | |
40 (require 'eieio) | |
41 ;; (require 'inversion) | |
42 ;; (inversion-require 'eieio "0.18beta1") | |
43 | |
44 ;;; Code: | |
45 (defvar semantic-debug-parser-source nil | |
46 "For any buffer, the file name (no path) of the parser. | |
47 This would be a parser for a specific language, not the source | |
48 to one of the parser generators.") | |
49 (make-variable-buffer-local 'semantic-debug-parser-source) | |
50 | |
51 (defvar semantic-debug-parser-class nil | |
52 "Class to create when building a debug parser object.") | |
53 (make-variable-buffer-local 'semantic-debug-parser-class) | |
54 | |
55 (defvar semantic-debug-enabled nil | |
56 "Non-nil when debugging a parser.") | |
57 | |
58 ;;; Variables used during a debug session. | |
59 (defvar semantic-debug-current-interface nil | |
60 "The debugger interface currently active for this buffer.") | |
61 | |
62 (defvar semantic-debug-current-parser nil | |
63 "The parser current active for this buffer.") | |
64 | |
65 ;;; User Interface Portion | |
66 ;; | |
67 (defclass semantic-debug-interface () | |
68 ((parser-buffer :initarg :parser-buffer | |
69 :type buffer | |
70 :documentation | |
71 "The buffer containing the parser we are debugging.") | |
72 (parser-local-map :initarg :parser-local-map | |
73 :type keymap | |
74 :documentation | |
75 "The local keymap originally in the PARSER buffer.") | |
76 (parser-location :type marker | |
77 :documentation | |
78 "A marker representing where we are in the parser buffer.") | |
79 (source-buffer :initarg :source-buffer | |
80 :type buffer | |
81 :documentation | |
82 "The buffer containing the source we are parsing. | |
83 The :parser-buffer defines a parser that can parse the text in the | |
84 :source-buffer.") | |
85 (source-local-map :initarg :source-local-map | |
86 :type keymap | |
87 :documentation | |
88 "The local keymap originally in the SOURCE buffer.") | |
89 (source-location :type marker | |
90 :documentation | |
91 "A marker representing where we are in the parser buffer.") | |
92 (data-buffer :initarg :data-buffer | |
93 :type buffer | |
94 :documentation | |
95 "Buffer being used to display some useful data. | |
96 These buffers are brought into view when layout occurs.") | |
97 (current-frame :type semantic-debug-frame | |
98 :documentation | |
99 "The currently displayed frame.") | |
100 (overlays :type list | |
101 :initarg nil | |
102 :documentation | |
103 "Any active overlays being used to show the debug position.") | |
104 ) | |
105 "Controls action when in `semantic-debug-mode'") | |
106 | |
107 ;; Methods | |
108 (defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame) | |
109 "Set the current frame on IFACE to FRAME." | |
110 (if frame | |
111 (oset iface current-frame frame) | |
112 (slot-makeunbound iface 'current-frame))) | |
113 | |
114 (defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface) point) | |
115 "Set the parser location in IFACE to POINT." | |
116 (save-excursion | |
117 (set-buffer (oref iface parser-buffer)) | |
118 (if (not (slot-boundp iface 'parser-location)) | |
119 (oset iface parser-location (make-marker))) | |
120 (move-marker (oref iface parser-location) point)) | |
121 ) | |
122 | |
123 (defmethod semantic-debug-set-source-location ((iface semantic-debug-interface) point) | |
124 "Set the source location in IFACE to POINT." | |
125 (save-excursion | |
126 (set-buffer (oref iface source-buffer)) | |
127 (if (not (slot-boundp iface 'source-location)) | |
128 (oset iface source-location (make-marker))) | |
129 (move-marker (oref iface source-location) point)) | |
130 ) | |
131 | |
132 (defmethod semantic-debug-interface-layout ((iface semantic-debug-interface)) | |
133 "Layout windows in the current frame to facilitate debugging." | |
134 (delete-other-windows) | |
135 ;; Deal with the data buffer | |
136 (when (slot-boundp iface 'data-buffer) | |
137 (let ((lines (/ (frame-height (selected-frame)) 3)) | |
138 (cnt (save-excursion | |
139 (set-buffer (oref iface data-buffer)) | |
140 (count-lines (point-min) (point-max)))) | |
141 ) | |
142 ;; Set the number of lines to 1/3, or the size of the data buffer. | |
143 (if (< cnt lines) (setq cnt lines)) | |
144 | |
145 (split-window-vertically cnt) | |
146 (switch-to-buffer (oref iface data-buffer)) | |
147 ) | |
148 (other-window 1)) | |
149 ;; Parser | |
150 (switch-to-buffer (oref iface parser-buffer)) | |
151 (when (slot-boundp iface 'parser-location) | |
152 (goto-char (oref iface parser-location))) | |
153 (split-window-vertically) | |
154 (other-window 1) | |
155 ;; Source | |
156 (switch-to-buffer (oref iface source-buffer)) | |
157 (when (slot-boundp iface 'source-location) | |
158 (goto-char (oref iface source-location))) | |
159 ) | |
160 | |
161 (defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface) token) | |
162 "For IFACE, highlight TOKEN in the source buffer . | |
163 TOKEN is a lexical token." | |
164 (set-buffer (oref iface :source-buffer)) | |
165 | |
166 (object-add-to-list iface 'overlays | |
167 (semantic-lex-highlight-token token)) | |
168 | |
169 (semantic-debug-set-source-location iface (semantic-lex-token-start token)) | |
170 ) | |
171 | |
172 (defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface) nonterm &optional rule match) | |
173 "For IFACE, highlight NONTERM in the parser buffer. | |
174 NONTERM is the name of the rule currently being processed that shows up | |
175 as a nonterminal (or tag) in the source buffer. | |
176 If RULE and MATCH indicies are specified, highlight those also." | |
177 (set-buffer (oref iface :parser-buffer)) | |
178 | |
179 (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer))) | |
180 (nt (semantic-find-first-tag-by-name nonterm rules)) | |
181 (o nil) | |
182 ) | |
183 (when nt | |
184 ;; I know it is the first symbol appearing in the body of this token. | |
185 (goto-char (semantic-tag-start nt)) | |
186 | |
187 (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) | |
188 (semantic-overlay-put o 'face 'highlight) | |
189 | |
190 (object-add-to-list iface 'overlays o) | |
191 | |
192 (semantic-debug-set-parser-location iface (semantic-overlay-start o)) | |
193 | |
194 (when (and rule match) | |
195 | |
196 ;; Rule, an int, is the rule inside the nonterminal we are following. | |
197 (re-search-forward ":\\s-*") | |
198 (while (/= 0 rule) | |
199 (re-search-forward "^\\s-*|\\s-*") | |
200 (setq rule (1- rule))) | |
201 | |
202 ;; Now find the match inside the rule | |
203 (while (/= 0 match) | |
204 (forward-sexp 1) | |
205 (skip-chars-forward " \t") | |
206 (setq match (1- match))) | |
207 | |
208 ;; Now highlight the thingy we find there. | |
209 (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) | |
210 (semantic-overlay-put o 'face 'highlight) | |
211 | |
212 (object-add-to-list iface 'overlays o) | |
213 | |
214 ;; If we have a match for a sub-rule, have the parser position | |
215 ;; move so we can see it in the output window for very long rules. | |
216 (semantic-debug-set-parser-location iface (semantic-overlay-start o)) | |
217 | |
218 )))) | |
219 | |
220 (defmethod semantic-debug-unhighlight ((iface semantic-debug-interface)) | |
221 "Remove all debugging overlays." | |
222 (mapc 'semantic-overlay-delete (oref iface overlays)) | |
223 (oset iface overlays nil)) | |
224 | |
225 ;; Call from the parser at a breakpoint | |
226 (defvar semantic-debug-user-command nil | |
227 "The command the user is requesting.") | |
228 | |
229 (defun semantic-debug-break (frame) | |
230 "Stop parsing now at FRAME. | |
231 FRAME is an object that represents the parser's view of the | |
232 current state of the world. | |
233 This function enters a recursive edit. It returns | |
234 on an `exit-recursive-edit', or if someone uses one | |
235 of the `semantic-debug-mode' commands. | |
236 It returns the command specified. Parsers need to take action | |
237 on different types of return values." | |
238 (save-window-excursion | |
239 ;; Set up displaying information | |
240 (semantic-debug-mode t) | |
241 (unwind-protect | |
242 (progn | |
243 (semantic-debug-frame-highlight frame) | |
244 (semantic-debug-interface-layout semantic-debug-current-interface) | |
245 (condition-case nil | |
246 ;; Enter recursive edit... wait for user command. | |
247 (recursive-edit) | |
248 (error nil))) | |
249 (semantic-debug-unhighlight semantic-debug-current-interface) | |
250 (semantic-debug-mode nil)) | |
251 ;; Find the requested user state. Do something. | |
252 (let ((returnstate semantic-debug-user-command)) | |
253 (setq semantic-debug-user-command nil) | |
254 returnstate) | |
255 )) | |
256 | |
257 ;;; Frame | |
258 ;; | |
259 ;; A frame can represent the state at a break point. | |
260 (defclass semantic-debug-frame () | |
261 ( | |
262 ) | |
263 "One frame representation.") | |
264 | |
265 (defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame)) | |
266 "Highlight one parser frame." | |
267 | |
268 ) | |
269 | |
270 (defmethod semantic-debug-frame-info ((frame semantic-debug-frame)) | |
271 "Display info about this one parser frame." | |
272 | |
273 ) | |
274 | |
275 ;;; Major Mode | |
276 ;; | |
277 (defvar semantic-debug-mode-map | |
278 (let ((km (make-sparse-keymap))) | |
279 (define-key km "n" 'semantic-debug-next) | |
280 (define-key km " " 'semantic-debug-next) | |
281 (define-key km "s" 'semantic-debug-step) | |
282 (define-key km "u" 'semantic-debug-up) | |
283 (define-key km "d" 'semantic-debug-down) | |
284 (define-key km "f" 'semantic-debug-fail-match) | |
285 (define-key km "h" 'semantic-debug-print-state) | |
286 (define-key km "s" 'semantic-debug-jump-to-source) | |
287 (define-key km "p" 'semantic-debug-jump-to-parser) | |
288 (define-key km "q" 'semantic-debug-quit) | |
289 (define-key km "a" 'semantic-debug-abort) | |
290 (define-key km "g" 'semantic-debug-go) | |
291 (define-key km "b" 'semantic-debug-set-breakpoint) | |
292 ;; Some boring bindings. | |
293 (define-key km "e" 'eval-expression) | |
294 | |
295 km) | |
296 "Keymap used when in semantic-debug-node.") | |
297 | |
298 (defun semantic-debug-mode (onoff) | |
299 "Turn `semantic-debug-mode' on and off. | |
300 Argument ONOFF is non-nil when we are entering debug mode. | |
301 \\{semantic-debug-mode-map}" | |
302 (let ((iface semantic-debug-current-interface)) | |
303 (if onoff | |
304 ;; Turn it on | |
305 (save-excursion | |
306 (set-buffer (oref iface parser-buffer)) | |
307 ;; Install our map onto this buffer | |
308 (use-local-map semantic-debug-mode-map) | |
309 ;; Make the buffer read only | |
310 (toggle-read-only 1) | |
311 | |
312 (set-buffer (oref iface source-buffer)) | |
313 ;; Use our map in the source buffer also | |
314 (use-local-map semantic-debug-mode-map) | |
315 ;; Make the buffer read only | |
316 (toggle-read-only 1) | |
317 ;; Hooks | |
318 (run-hooks 'semantic-debug-mode-hooks) | |
319 ) | |
320 ;; Restore old mode information | |
321 (save-excursion | |
322 (set-buffer | |
323 (oref semantic-debug-current-interface parser-buffer)) | |
324 (use-local-map | |
325 (oref semantic-debug-current-interface parser-local-map)) | |
326 ) | |
327 (save-excursion | |
328 (set-buffer | |
329 (oref semantic-debug-current-interface source-buffer)) | |
330 (use-local-map | |
331 (oref semantic-debug-current-interface source-local-map)) | |
332 ) | |
333 (run-hooks 'semantic-debug-exit-hooks) | |
334 ))) | |
335 | |
336 (defun semantic-debug () | |
337 "Parse the current buffer and run in debug mode." | |
338 (interactive) | |
339 (if semantic-debug-current-interface | |
340 (error "You are already in a debug session")) | |
341 (if (not semantic-debug-parser-class) | |
342 (error "This major mode does not support parser debugging")) | |
343 ;; Clear the cache to force a full reparse. | |
344 (semantic-clear-toplevel-cache) | |
345 ;; Do the parse | |
346 (let ((semantic-debug-enabled t) | |
347 ;; Create an interface | |
348 (semantic-debug-current-interface | |
349 (let ((parserb (semantic-debug-find-parser-source))) | |
350 (semantic-debug-interface | |
351 "Debug Interface" | |
352 :parser-buffer parserb | |
353 :parser-local-map (save-excursion | |
354 (set-buffer parserb) | |
355 (current-local-map)) | |
356 :source-buffer (current-buffer) | |
357 :source-local-map (current-local-map) | |
358 ))) | |
359 ;; Create a parser debug interface | |
360 (semantic-debug-current-parser | |
361 (funcall semantic-debug-parser-class "parser")) | |
362 ) | |
363 ;; We could recurse into a parser while debugging. | |
364 ;; Is that a problem? | |
365 (semantic-fetch-tags) | |
366 ;; We should turn the auto-parser back on, but don't do it for | |
367 ;; now until the debugger is working well. | |
368 )) | |
369 | |
370 (defun semantic-debug-find-parser-source () | |
371 "Return a buffer containing the parser source file for the current buffer. | |
372 The parser needs to be on the load path, or this routine returns nil." | |
373 (if (not semantic-debug-parser-source) | |
374 (error "No parser is associated with this buffer")) | |
375 (let ((parser (locate-library semantic-debug-parser-source t))) | |
376 (if parser | |
377 (find-file-noselect parser) | |
378 (error "Cannot find parser source. It should be on the load-path")))) | |
379 | |
380 ;;; Debugger commands | |
381 ;; | |
382 (defun semantic-debug-next () | |
383 "Perform one parser operation. | |
384 In the recursive parser, this steps past one match rule. | |
385 In other parsers, this may be just like `semantic-debug-step'." | |
386 (interactive) | |
387 (let ((parser semantic-debug-current-parser)) | |
388 (semantic-debug-parser-next parser) | |
389 (exit-recursive-edit) | |
390 ) | |
391 ) | |
392 | |
393 (defun semantic-debug-step () | |
394 "Perform one parser operation." | |
395 (interactive) | |
396 (let ((parser semantic-debug-current-parser)) | |
397 (semantic-debug-parser-step parser) | |
398 (exit-recursive-edit) | |
399 ) | |
400 ) | |
401 | |
402 (defun semantic-debug-up () | |
403 "Move highlighting representation up one level." | |
404 (interactive) | |
405 (message "Not implemented yet.") | |
406 ) | |
407 | |
408 (defun semantic-debug-down () | |
409 "Move highlighting representation down one level." | |
410 (interactive) | |
411 (message "Not implemented yet.") | |
412 ) | |
413 | |
414 (defun semantic-debug-fail-match () | |
415 "Artificially fail the current match." | |
416 (interactive) | |
417 (let ((parser semantic-debug-current-parser)) | |
418 (semantic-debug-parser-fail parser) | |
419 (exit-recursive-edit) | |
420 ) | |
421 ) | |
422 | |
423 (defun semantic-debug-print-state () | |
424 "Show interesting parser state." | |
425 (interactive) | |
426 (let ((parser semantic-debug-current-parser)) | |
427 (semantic-debug-parser-print-state parser) | |
428 ) | |
429 ) | |
430 | |
431 (defun semantic-debug-jump-to-source () | |
432 "Move cursor to the source code being parsed at the current lexical token." | |
433 (interactive) | |
434 (let* ((interface semantic-debug-current-interface) | |
435 (buf (oref interface source-buffer))) | |
436 (if (get-buffer-window buf) | |
437 (progn | |
438 (select-frame (window-frame (get-buffer-window buf))) | |
439 (select-window (get-buffer-window buf))) | |
440 ;; Technically, this should do a window layout operation | |
441 (switch-to-buffer buf)) | |
442 ) | |
443 ) | |
444 | |
445 (defun semantic-debug-jump-to-parser () | |
446 "Move cursor to the parser being debugged." | |
447 (interactive) | |
448 (let* ((interface semantic-debug-current-interface) | |
449 (buf (oref interface parser-buffer))) | |
450 (if (get-buffer-window buf) | |
451 (progn | |
452 (select-frame (window-frame (get-buffer-window buf))) | |
453 (select-window (get-buffer-window buf))) | |
454 ;; Technically, this should do a window layout operation | |
455 (switch-to-buffer buf)) | |
456 ) | |
457 ) | |
458 | |
459 (defun semantic-debug-quit () | |
460 "Exit debug mode, blowing all stack, and leaving the parse incomplete. | |
461 Do not update any tokens already parsed." | |
462 (interactive) | |
463 (let ((parser semantic-debug-current-parser)) | |
464 (semantic-debug-parser-quit parser) | |
465 (exit-recursive-edit) | |
466 ) | |
467 ) | |
468 | |
469 (defun semantic-debug-abort () | |
470 "Abort one level of debug mode, blowing all stack." | |
471 (interactive) | |
472 (let ((parser semantic-debug-current-parser)) | |
473 (semantic-debug-parser-abort parser) | |
474 (exit-recursive-edit) | |
475 ) | |
476 ) | |
477 | |
478 (defun semantic-debug-go () | |
479 "Continue parsing till finish or breakpoint." | |
480 (interactive) | |
481 (let ((parser semantic-debug-current-parser)) | |
482 (semantic-debug-parser-go parser) | |
483 (exit-recursive-edit) | |
484 ) | |
485 ) | |
486 | |
487 (defun semantic-debug-set-breakpoint () | |
488 "Set a breakpoint at the current rule location." | |
489 (interactive) | |
490 (let ((parser semantic-debug-current-parser) | |
491 ;; Get the location as semantic tokens. | |
492 (location (semantic-current-tag)) | |
493 ) | |
494 (if location | |
495 (semantic-debug-parser-break parser location) | |
496 (error "Not on a rule")) | |
497 ) | |
498 ) | |
499 | |
500 | |
501 ;;; Debugger superclass | |
502 ;; | |
503 (defclass semantic-debug-parser () | |
504 ( | |
505 ) | |
506 "Represents a parser and its state. | |
507 When implementing the debug parser you can add extra functionality | |
508 by overriding one of the command methods. Be sure to use | |
509 `call-next-method' so that the debug command is saved, and passed | |
510 down to your parser later." | |
511 :abstract t) | |
512 | |
513 (defmethod semantic-debug-parser-next ((parser semantic-debug-parser)) | |
514 "Execute next for this PARSER." | |
515 (setq semantic-debug-user-command 'next) | |
516 ) | |
517 | |
518 (defmethod semantic-debug-parser-step ((parser semantic-debug-parser)) | |
519 "Execute a step for this PARSER." | |
520 (setq semantic-debug-user-command 'step) | |
521 ) | |
522 | |
523 (defmethod semantic-debug-parser-go ((parser semantic-debug-parser)) | |
524 "Continue executiong in this PARSER until the next breakpoint." | |
525 (setq semantic-debug-user-command 'go) | |
526 ) | |
527 | |
528 (defmethod semantic-debug-parser-fail ((parser semantic-debug-parser)) | |
529 "Continue executiong in this PARSER until the next breakpoint." | |
530 (setq semantic-debug-user-command 'fail) | |
531 ) | |
532 | |
533 (defmethod semantic-debug-parser-quit ((parser semantic-debug-parser)) | |
534 "Continue executiong in this PARSER until the next breakpoint." | |
535 (setq semantic-debug-user-command 'quit) | |
536 ) | |
537 | |
538 (defmethod semantic-debug-parser-abort ((parser semantic-debug-parser)) | |
539 "Continue executiong in this PARSER until the next breakpoint." | |
540 (setq semantic-debug-user-command 'abort) | |
541 ) | |
542 | |
543 (defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser)) | |
544 "Print state for this PARSER at the current breakpoint." | |
545 (with-slots (current-frame) semantic-debug-current-interface | |
546 (when current-frame | |
547 (semantic-debug-frame-info current-frame) | |
548 ))) | |
549 | |
550 (defmethod semantic-debug-parser-break ((parser semantic-debug-parser)) | |
551 "Set a breakpoint for this PARSER." | |
552 ) | |
553 | |
554 ;; Stack stuff | |
555 (defmethod semantic-debug-parser-frames ((parser semantic-debug-parser)) | |
556 "Return a list of frames for the current parser. | |
557 A frame is of the form: | |
558 ( .. .what ? .. ) | |
559 " | |
560 (error "Parser has not implemented frame values") | |
561 ) | |
562 | |
563 | |
564 (provide 'semantic/debug) | |
565 | |
566 ;;; semantic-debug.el ends here |