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