1 ;;; semantic/debug.el --- Language Debugger framework
3 ;; Copyright (C) 2003, 2004, 2005, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
7 ;; This file is part of GNU Emacs.
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.
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.
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/>.
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
29 ;; Fortunately, the nature of language support files means that the parser
30 ;; may not need to be instrumented first.
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.
39 (eval-when-compile (require 'cl
))
42 (eval-when-compile (require 'semantic
/find
))
47 (defvar semantic-debug-parser-source nil
48 "For any buffer, the file name (no path) of the parser.
49 This would be a parser for a specific language, not the source
50 to one of the parser generators.")
52 (make-variable-buffer-local 'semantic-debug-parser-source
)
55 (defvar semantic-debug-parser-class nil
56 "Class to create when building a debug parser object.")
58 (make-variable-buffer-local 'semantic-debug-parser-class
)
60 (defvar semantic-debug-enabled nil
61 "Non-nil when debugging a parser.")
63 ;;; Variables used during a debug session.
64 (defvar semantic-debug-current-interface nil
65 "The debugger interface currently active for this buffer.")
67 (defvar semantic-debug-current-parser nil
68 "The parser current active for this buffer.")
70 ;;; User Interface Portion
72 (defclass semantic-debug-interface
()
73 ((parser-buffer :initarg
:parser-buffer
76 "The buffer containing the parser we are debugging.")
77 (parser-local-map :initarg
:parser-local-map
80 "The local keymap originally in the PARSER buffer.")
81 (parser-location :type marker
83 "A marker representing where we are in the parser buffer.")
84 (source-buffer :initarg
:source-buffer
87 "The buffer containing the source we are parsing.
88 The :parser-buffer defines a parser that can parse the text in the
90 (source-local-map :initarg
:source-local-map
93 "The local keymap originally in the SOURCE buffer.")
94 (source-location :type marker
96 "A marker representing where we are in the parser buffer.")
97 (data-buffer :initarg
:data-buffer
100 "Buffer being used to display some useful data.
101 These buffers are brought into view when layout occurs.")
102 (current-frame :type semantic-debug-frame
104 "The currently displayed frame.")
108 "Any active overlays being used to show the debug position.")
110 "Controls action when in `semantic-debug-mode'")
113 (defmethod semantic-debug-set-frame ((iface semantic-debug-interface
) frame
)
114 "Set the current frame on IFACE to FRAME."
116 (oset iface current-frame frame
)
117 (slot-makeunbound iface
'current-frame
)))
119 (defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface
) point
)
120 "Set the parser location in IFACE to POINT."
121 (with-current-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
))
127 (defmethod semantic-debug-set-source-location ((iface semantic-debug-interface
) point
)
128 "Set the source location in IFACE to POINT."
129 (with-current-buffer (oref iface source-buffer
)
130 (if (not (slot-boundp iface
'source-location
))
131 (oset iface source-location
(make-marker)))
132 (move-marker (oref iface source-location
) point
))
135 (defmethod semantic-debug-interface-layout ((iface semantic-debug-interface
))
136 "Layout windows in the current frame to facilitate debugging."
137 (delete-other-windows)
138 ;; Deal with the data buffer
139 (when (slot-boundp iface
'data-buffer
)
140 (let ((lines (/ (frame-height (selected-frame)) 3))
141 (cnt (with-current-buffer (oref iface data-buffer
)
142 (count-lines (point-min) (point-max))))
144 ;; Set the number of lines to 1/3, or the size of the data buffer.
145 (if (< cnt lines
) (setq cnt lines
))
147 (split-window-vertically cnt
)
148 (switch-to-buffer (oref iface data-buffer
))
152 (switch-to-buffer (oref iface parser-buffer
))
153 (when (slot-boundp iface
'parser-location
)
154 (goto-char (oref iface parser-location
)))
155 (split-window-vertically)
158 (switch-to-buffer (oref iface source-buffer
))
159 (when (slot-boundp iface
'source-location
)
160 (goto-char (oref iface source-location
)))
163 (defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface
) token
)
164 "For IFACE, highlight TOKEN in the source buffer .
165 TOKEN is a lexical token."
166 (set-buffer (oref iface
:source-buffer
))
168 (object-add-to-list iface
'overlays
169 (semantic-lex-highlight-token token
))
171 (semantic-debug-set-source-location iface
(semantic-lex-token-start token
))
174 (defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface
) nonterm
&optional rule match
)
175 "For IFACE, highlight NONTERM in the parser buffer.
176 NONTERM is the name of the rule currently being processed that shows up
177 as a nonterminal (or tag) in the source buffer.
178 If RULE and MATCH indicies are specified, highlight those also."
179 (set-buffer (oref iface
:parser-buffer
))
181 (let* ((rules (semantic-find-tags-by-class 'nonterminal
(current-buffer)))
182 (nt (semantic-find-first-tag-by-name nonterm rules
))
186 ;; I know it is the first symbol appearing in the body of this token.
187 (goto-char (semantic-tag-start nt
))
189 (setq o
(semantic-make-overlay (point) (progn (forward-sexp 1) (point))))
190 (semantic-overlay-put o
'face
'highlight
)
192 (object-add-to-list iface
'overlays o
)
194 (semantic-debug-set-parser-location iface
(semantic-overlay-start o
))
196 (when (and rule match
)
198 ;; Rule, an int, is the rule inside the nonterminal we are following.
199 (re-search-forward ":\\s-*")
201 (re-search-forward "^\\s-*|\\s-*")
202 (setq rule
(1- rule
)))
204 ;; Now find the match inside the rule
207 (skip-chars-forward " \t")
208 (setq match
(1- match
)))
210 ;; Now highlight the thingy we find there.
211 (setq o
(semantic-make-overlay (point) (progn (forward-sexp 1) (point))))
212 (semantic-overlay-put o
'face
'highlight
)
214 (object-add-to-list iface
'overlays o
)
216 ;; If we have a match for a sub-rule, have the parser position
217 ;; move so we can see it in the output window for very long rules.
218 (semantic-debug-set-parser-location iface
(semantic-overlay-start o
))
222 (defmethod semantic-debug-unhighlight ((iface semantic-debug-interface
))
223 "Remove all debugging overlays."
224 (mapc 'semantic-overlay-delete
(oref iface overlays
))
225 (oset iface overlays nil
))
227 ;; Call from the parser at a breakpoint
228 (defvar semantic-debug-user-command nil
229 "The command the user is requesting.")
231 (defun semantic-debug-break (frame)
232 "Stop parsing now at FRAME.
233 FRAME is an object that represents the parser's view of the
234 current state of the world.
235 This function enters a recursive edit. It returns
236 on an `exit-recursive-edit', or if someone uses one
237 of the `semantic-debug-mode' commands.
238 It returns the command specified. Parsers need to take action
239 on different types of return values."
240 (save-window-excursion
241 ;; Set up displaying information
242 (semantic-debug-mode t
)
245 (semantic-debug-frame-highlight frame
)
246 (semantic-debug-interface-layout semantic-debug-current-interface
)
248 ;; Enter recursive edit... wait for user command.
251 (semantic-debug-unhighlight semantic-debug-current-interface
)
252 (semantic-debug-mode nil
))
253 ;; Find the requested user state. Do something.
254 (let ((returnstate semantic-debug-user-command
))
255 (setq semantic-debug-user-command nil
)
261 ;; A frame can represent the state at a break point.
262 (defclass semantic-debug-frame
()
265 "One frame representation.")
267 (defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame
))
268 "Highlight one parser frame."
272 (defmethod semantic-debug-frame-info ((frame semantic-debug-frame
))
273 "Display info about this one parser frame."
279 (defvar semantic-debug-mode-map
280 (let ((km (make-sparse-keymap)))
281 (define-key km
"n" 'semantic-debug-next
)
282 (define-key km
" " 'semantic-debug-next
)
283 (define-key km
"s" 'semantic-debug-step
)
284 (define-key km
"u" 'semantic-debug-up
)
285 (define-key km
"d" 'semantic-debug-down
)
286 (define-key km
"f" 'semantic-debug-fail-match
)
287 (define-key km
"h" 'semantic-debug-print-state
)
288 (define-key km
"s" 'semantic-debug-jump-to-source
)
289 (define-key km
"p" 'semantic-debug-jump-to-parser
)
290 (define-key km
"q" 'semantic-debug-quit
)
291 (define-key km
"a" 'semantic-debug-abort
)
292 (define-key km
"g" 'semantic-debug-go
)
293 (define-key km
"b" 'semantic-debug-set-breakpoint
)
294 ;; Some boring bindings.
295 (define-key km
"e" 'eval-expression
)
298 "Keymap used when in semantic-debug-node.")
300 (defun semantic-debug-mode (onoff)
301 "Turn `semantic-debug-mode' on and off.
302 Argument ONOFF is non-nil when we are entering debug mode.
303 \\{semantic-debug-mode-map}"
304 (let ((iface semantic-debug-current-interface
))
307 (with-current-buffer (oref iface parser-buffer
)
308 ;; Install our map onto this buffer
309 (use-local-map semantic-debug-mode-map
)
310 ;; Make the buffer read only
313 (set-buffer (oref iface source-buffer
))
314 ;; Use our map in the source buffer also
315 (use-local-map semantic-debug-mode-map
)
316 ;; Make the buffer read only
319 (run-hooks 'semantic-debug-mode-hook
)
321 ;; Restore old mode information
323 (oref semantic-debug-current-interface parser-buffer
)
325 (oref semantic-debug-current-interface parser-local-map
))
328 (oref semantic-debug-current-interface source-buffer
)
330 (oref semantic-debug-current-interface source-local-map
))
332 (run-hooks 'semantic-debug-exit-hook
)
335 (defun semantic-debug ()
336 "Parse the current buffer and run in debug mode."
338 (if semantic-debug-current-interface
339 (error "You are already in a debug session"))
340 (if (not semantic-debug-parser-class
)
341 (error "This major mode does not support parser debugging"))
342 ;; Clear the cache to force a full reparse.
343 (semantic-clear-toplevel-cache)
345 (let ((semantic-debug-enabled t
)
346 ;; Create an interface
347 (semantic-debug-current-interface
348 (let ((parserb (semantic-debug-find-parser-source)))
349 (semantic-debug-interface
351 :parser-buffer parserb
352 :parser-local-map
(with-current-buffer parserb
354 :source-buffer
(current-buffer)
355 :source-local-map
(current-local-map)
357 ;; Create a parser debug interface
358 (semantic-debug-current-parser
359 (funcall semantic-debug-parser-class
"parser"))
361 ;; We could recurse into a parser while debugging.
362 ;; Is that a problem?
363 (semantic-fetch-tags)
364 ;; We should turn the auto-parser back on, but don't do it for
365 ;; now until the debugger is working well.
368 (defun semantic-debug-find-parser-source ()
369 "Return a buffer containing the parser source file for the current buffer.
370 The parser needs to be on the load path, or this routine returns nil."
371 (if (not semantic-debug-parser-source
)
372 (error "No parser is associated with this buffer"))
373 (let ((parser (locate-library semantic-debug-parser-source t
)))
375 (find-file-noselect parser
)
376 (error "Cannot find parser source. It should be on the load-path"))))
378 ;;; Debugger commands
380 (defun semantic-debug-next ()
381 "Perform one parser operation.
382 In the recursive parser, this steps past one match rule.
383 In other parsers, this may be just like `semantic-debug-step'."
385 (let ((parser semantic-debug-current-parser
))
386 (semantic-debug-parser-next parser
)
387 (exit-recursive-edit)
391 (defun semantic-debug-step ()
392 "Perform one parser operation."
394 (let ((parser semantic-debug-current-parser
))
395 (semantic-debug-parser-step parser
)
396 (exit-recursive-edit)
400 (defun semantic-debug-up ()
401 "Move highlighting representation up one level."
403 (message "Not implemented yet.")
406 (defun semantic-debug-down ()
407 "Move highlighting representation down one level."
409 (message "Not implemented yet.")
412 (defun semantic-debug-fail-match ()
413 "Artificially fail the current match."
415 (let ((parser semantic-debug-current-parser
))
416 (semantic-debug-parser-fail parser
)
417 (exit-recursive-edit)
421 (defun semantic-debug-print-state ()
422 "Show interesting parser state."
424 (let ((parser semantic-debug-current-parser
))
425 (semantic-debug-parser-print-state parser
)
429 (defun semantic-debug-jump-to-source ()
430 "Move cursor to the source code being parsed at the current lexical token."
432 (let* ((interface semantic-debug-current-interface
)
433 (buf (oref interface source-buffer
)))
434 (if (get-buffer-window buf
)
436 (select-frame (window-frame (get-buffer-window buf
)))
437 (select-window (get-buffer-window buf
)))
438 ;; Technically, this should do a window layout operation
439 (switch-to-buffer buf
))
443 (defun semantic-debug-jump-to-parser ()
444 "Move cursor to the parser being debugged."
446 (let* ((interface semantic-debug-current-interface
)
447 (buf (oref interface parser-buffer
)))
448 (if (get-buffer-window buf
)
450 (select-frame (window-frame (get-buffer-window buf
)))
451 (select-window (get-buffer-window buf
)))
452 ;; Technically, this should do a window layout operation
453 (switch-to-buffer buf
))
457 (defun semantic-debug-quit ()
458 "Exit debug mode, blowing all stack, and leaving the parse incomplete.
459 Do not update any tokens already parsed."
461 (let ((parser semantic-debug-current-parser
))
462 (semantic-debug-parser-quit parser
)
463 (exit-recursive-edit)
467 (defun semantic-debug-abort ()
468 "Abort one level of debug mode, blowing all stack."
470 (let ((parser semantic-debug-current-parser
))
471 (semantic-debug-parser-abort parser
)
472 (exit-recursive-edit)
476 (defun semantic-debug-go ()
477 "Continue parsing till finish or breakpoint."
479 (let ((parser semantic-debug-current-parser
))
480 (semantic-debug-parser-go parser
)
481 (exit-recursive-edit)
485 (defun semantic-debug-set-breakpoint ()
486 "Set a breakpoint at the current rule location."
488 (let ((parser semantic-debug-current-parser
)
489 ;; Get the location as semantic tokens.
490 (location (semantic-current-tag))
493 (semantic-debug-parser-break parser location
)
494 (error "Not on a rule"))
499 ;;; Debugger superclass
501 (defclass semantic-debug-parser
()
504 "Represents a parser and its state.
505 When implementing the debug parser you can add extra functionality
506 by overriding one of the command methods. Be sure to use
507 `call-next-method' so that the debug command is saved, and passed
508 down to your parser later."
511 (defmethod semantic-debug-parser-next ((parser semantic-debug-parser
))
512 "Execute next for this PARSER."
513 (setq semantic-debug-user-command
'next
)
516 (defmethod semantic-debug-parser-step ((parser semantic-debug-parser
))
517 "Execute a step for this PARSER."
518 (setq semantic-debug-user-command
'step
)
521 (defmethod semantic-debug-parser-go ((parser semantic-debug-parser
))
522 "Continue executiong in this PARSER until the next breakpoint."
523 (setq semantic-debug-user-command
'go
)
526 (defmethod semantic-debug-parser-fail ((parser semantic-debug-parser
))
527 "Continue executiong in this PARSER until the next breakpoint."
528 (setq semantic-debug-user-command
'fail
)
531 (defmethod semantic-debug-parser-quit ((parser semantic-debug-parser
))
532 "Continue executiong in this PARSER until the next breakpoint."
533 (setq semantic-debug-user-command
'quit
)
536 (defmethod semantic-debug-parser-abort ((parser semantic-debug-parser
))
537 "Continue executiong in this PARSER until the next breakpoint."
538 (setq semantic-debug-user-command
'abort
)
541 (defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser
))
542 "Print state for this PARSER at the current breakpoint."
543 (with-slots (current-frame) semantic-debug-current-interface
545 (semantic-debug-frame-info current-frame
)
548 (defmethod semantic-debug-parser-break ((parser semantic-debug-parser
))
549 "Set a breakpoint for this PARSER."
553 (defmethod semantic-debug-parser-frames ((parser semantic-debug-parser
))
554 "Return a list of frames for the current parser.
555 A frame is of the form:
558 (error "Parser has not implemented frame values")
562 (provide 'semantic
/debug
)
565 ;; generated-autoload-file: "loaddefs.el"
566 ;; generated-autoload-load-name: "semantic/debug"
569 ;; arch-tag: 6f189d2d-8a65-45a5-a7f0-9894625eb860
570 ;;; semantic/debug.el ends here