1 ;;; semantic-debug.el --- Language Debugger framework
3 ;;; Copyright (C) 2003, 2004, 2005 Eric M. Ludlam
5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
6 ;; X-RCS: $Id: semantic-debug.el.upstream,v 1.1 2007-11-26 15:10:34 michaels Exp $
8 ;; This file is not part of GNU Emacs.
10 ;; This is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This software is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
27 ;; To provide better support for debugging parsers, this framework
28 ;; provides the interface for debugging. The work of parsing and
29 ;; controlling and stepping through the parsing work must be implemented
32 ;; Fortunatly, the nature of language support files means that the parser
33 ;; may not need to be instrumented first.
35 ;; The debugger uses EIEIO objects. One object controls the user
36 ;; interface, including stepping, data-view, queries. A second
37 ;; object implemented here represents the parser itself. A third represents
38 ;; a parser independent frame which knows how to highlight the parser buffer.
39 ;; Each parser must implement the interface and override any methods as needed.
44 (inversion-require 'eieio "0.18beta1")
48 (defvar semantic-debug-parser-source nil
49 "For any buffer, the file name (no path) of the parser.
50 This would be a parser for a specific language, not the source
51 to one of the parser generators.")
53 (make-variable-buffer-local 'semantic-debug-parser-source)
56 (defvar semantic-debug-parser-class nil
57 "Class to create when building a debug parser object.")
59 (make-variable-buffer-local 'semantic-debug-parser-class)
62 (defvar semantic-debug-enabled nil
63 "Non-nil when debugging a parser.")
65 ;;; Variables used during a debug session.
66 (defvar semantic-debug-current-interface nil
67 "The debugger interface currently active for this buffer.")
69 (defvar semantic-debug-current-parser nil
70 "The parser current active for this buffer.")
72 ;;; User Interface Portion
74 (defclass semantic-debug-interface ()
75 ((parser-buffer :initarg :parser-buffer
78 "The buffer containing the parser we are debugging.")
79 (parser-local-map :initarg :parser-local-map
82 "The local keymap originally in the PARSER buffer.")
83 (parser-location :type marker
85 "A marker representing where we are in the parser buffer.")
86 (source-buffer :initarg :source-buffer
89 "The buffer containing the source we are parsing.
90 The :parser-buffer defines a parser that can parse the text in the
92 (source-local-map :initarg :source-local-map
95 "The local keymap originally in the SOURCE buffer.")
96 (source-location :type marker
98 "A marker representing where we are in the parser buffer.")
99 (data-buffer :initarg :data-buffer
102 "Buffer being used to display some useful data.
103 These buffers are brought into view when layout occurs.")
104 (current-frame :type semantic-debug-frame
106 "The currently displayed frame.")
110 "Any active overlays being used to show the debug position.")
112 "Controls action when in `semantic-debug-mode'")
115 (defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame)
116 "Set the current frame on IFACE to FRAME."
118 (oset iface current-frame frame)
119 (slot-makeunbound iface 'current-frame)))
121 (defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface) point)
122 "Set the parser location in IFACE to POINT."
124 (set-buffer (oref iface parser-buffer))
125 (if (not (slot-boundp iface 'parser-location))
126 (oset iface parser-location (make-marker)))
127 (move-marker (oref iface parser-location) point))
130 (defmethod semantic-debug-set-source-location ((iface semantic-debug-interface) point)
131 "Set the source location in IFACE to POINT."
133 (set-buffer (oref iface source-buffer))
134 (if (not (slot-boundp iface 'source-location))
135 (oset iface source-location (make-marker)))
136 (move-marker (oref iface source-location) point))
139 (defmethod semantic-debug-interface-layout ((iface semantic-debug-interface))
140 "Layout windows in the current frame to facilitate debugging."
141 (delete-other-windows)
142 ;; Deal with the data buffer
143 (when (slot-boundp iface 'data-buffer)
144 (let ((lines (/ (frame-height (selected-frame)) 3))
146 (set-buffer (oref iface data-buffer))
147 (count-lines (point-min) (point-max))))
149 ;; Set the number of lines to 1/3, or the size of the data buffer.
150 (if (< cnt lines) (setq cnt lines))
152 (split-window-vertically cnt)
153 (switch-to-buffer (oref iface data-buffer))
157 (switch-to-buffer (oref iface parser-buffer))
158 (when (slot-boundp iface 'parser-location)
159 (goto-char (oref iface parser-location)))
160 (split-window-vertically)
163 (switch-to-buffer (oref iface source-buffer))
164 (when (slot-boundp iface 'source-location)
165 (goto-char (oref iface source-location)))
168 (defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface) token)
169 "For IFACE, highlight TOKEN in the source buffer .
170 TOKEN is a lexical token."
171 (set-buffer (oref iface :source-buffer))
173 (object-add-to-list iface 'overlays
174 (semantic-lex-highlight-token token))
176 (semantic-debug-set-source-location iface (semantic-lex-token-start token))
179 (defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface) nonterm &optional rule match)
180 "For IFACE, highlight NONTERM in the parser buffer.
181 NONTERM is the name of the rule currently being processed that shows up
182 as a nonterminal (or tag) in the source buffer.
183 If RULE and MATCH indicies are specified, highlight those also."
184 (set-buffer (oref iface :parser-buffer))
186 (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer)))
187 (nt (semantic-find-first-tag-by-name nonterm rules))
191 ;; I know it is the first symbol appearing in the body of this token.
192 (goto-char (semantic-tag-start nt))
194 (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point))))
195 (semantic-overlay-put o 'face 'highlight)
197 (object-add-to-list iface 'overlays o)
199 (semantic-debug-set-parser-location iface (semantic-overlay-start o))
201 (when (and rule match)
203 ;; Rule, an int, is the rule inside the nonterminal we are following.
204 (re-search-forward ":\\s-*")
206 (re-search-forward "^\\s-*|\\s-*")
207 (setq rule (1- rule)))
209 ;; Now find the match inside the rule
212 (skip-chars-forward " \t")
213 (setq match (1- match)))
215 ;; Now highlight the thingy we find there.
216 (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point))))
217 (semantic-overlay-put o 'face 'highlight)
219 (object-add-to-list iface 'overlays o)
221 ;; If we have a match for a sub-rule, have the parser position
222 ;; move so we can see it in the output window for very long rules.
223 (semantic-debug-set-parser-location iface (semantic-overlay-start o))
227 (defmethod semantic-debug-unhighlight ((iface semantic-debug-interface))
228 "Remove all debugging overlays."
229 (mapcar 'semantic-overlay-delete (oref iface overlays))
230 (oset iface overlays nil))
232 ;; Call from the parser at a breakpoint
233 (defvar semantic-debug-user-command nil
234 "The command the user is requesting.")
237 (defun semantic-debug-break (frame)
238 "Stop parsing now at FRAME.
239 FRAME is an object that represents the parser's view of the
240 current state of the world.
241 This function enters a recursive edit. It returns
242 on an `exit-recursive-edit', or if someone uses one
243 of the `semantic-debug-mode' commands.
244 It returns the command specified. Parsers need to take action
245 on different types of return values."
246 (save-window-excursion
247 ;; Set up displaying information
248 (semantic-debug-mode t)
251 (semantic-debug-frame-highlight frame)
252 (semantic-debug-interface-layout semantic-debug-current-interface)
254 ;; Enter recursive edit... wait for user command.
257 (semantic-debug-unhighlight semantic-debug-current-interface)
258 (semantic-debug-mode nil))
259 ;; Find the requested user state. Do something.
260 (let ((returnstate semantic-debug-user-command))
261 (setq semantic-debug-user-command nil)
267 ;; A frame can represent the state at a break point.
268 (defclass semantic-debug-frame ()
271 "One frame representation.")
273 (defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame))
274 "Highlight one parser frame."
278 (defmethod semantic-debug-frame-info ((frame semantic-debug-frame))
279 "Display info about this one parser frame."
285 (defvar semantic-debug-mode-map
286 (let ((km (make-sparse-keymap)))
287 (define-key km "n" 'semantic-debug-next)
288 (define-key km " " 'semantic-debug-next)
289 (define-key km "s" 'semantic-debug-step)
290 (define-key km "u" 'semantic-debug-up)
291 (define-key km "d" 'semantic-debug-down)
292 (define-key km "f" 'semantic-debug-fail-match)
293 (define-key km "h" 'semantic-debug-print-state)
294 (define-key km "s" 'semantic-debug-jump-to-source)
295 (define-key km "p" 'semantic-debug-jump-to-parser)
296 (define-key km "q" 'semantic-debug-quit)
297 (define-key km "a" 'semantic-debug-abort)
298 (define-key km "g" 'semantic-debug-go)
299 (define-key km "b" 'semantic-debug-set-breakpoint)
300 ;; Some boring bindings.
301 (define-key km "e" 'eval-expression)
304 "Keymap used when in semantic-debug-node.")
306 (defun semantic-debug-mode (onoff)
307 "Turn `semantic-debug-mode' on and off.
308 Argument ONOFF is non-nil when we are entering debug mode.
309 \\{semantic-debug-mode-map}"
310 (let ((iface semantic-debug-current-interface))
314 (set-buffer (oref iface parser-buffer))
315 ;; Install our map onto this buffer
316 (use-local-map semantic-debug-mode-map)
317 ;; Make the buffer read only
320 (set-buffer (oref iface source-buffer))
321 ;; Use our map in the source buffer also
322 (use-local-map semantic-debug-mode-map)
323 ;; Make the buffer read only
326 (run-hooks 'semantic-debug-mode-hooks)
328 ;; Restore old mode information
331 (oref semantic-debug-current-interface parser-buffer))
333 (oref semantic-debug-current-interface parser-local-map))
337 (oref semantic-debug-current-interface source-buffer))
339 (oref semantic-debug-current-interface source-local-map))
341 (run-hooks 'semantic-debug-exit-hooks)
345 (defun semantic-debug ()
346 "Parse the current buffer and run in debug mode."
348 (if semantic-debug-current-interface
349 (error "You are already in a debug session"))
350 (if (not semantic-debug-parser-class)
351 (error "This major mode does not support parser debugging"))
352 ;; Clear the cache to force a full reparse.
353 (semantic-clear-toplevel-cache)
355 (let ((semantic-debug-enabled t)
356 ;; Create an interface
357 (semantic-debug-current-interface
358 (let ((parserb (semantic-debug-find-parser-source)))
359 (semantic-debug-interface
361 :parser-buffer parserb
362 :parser-local-map (save-excursion
365 :source-buffer (current-buffer)
366 :source-local-map (current-local-map)
368 ;; Create a parser debug interface
369 (semantic-debug-current-parser
370 (funcall semantic-debug-parser-class "parser"))
372 ;; We could recurse into a parser while debugging.
373 ;; Is that a problem?
374 (semantic-fetch-tags)
375 ;; We should turn the auto-parser back on, but don't do it for
376 ;; now until the debugger is working well.
379 (defun semantic-debug-find-parser-source ()
380 "Return a buffer containing the parser source file for the current buffer.
381 The parser needs to be on the load path, or this routine returns nil."
382 (if (not semantic-debug-parser-source)
383 (error "No parser is associated with this buffer"))
384 (let ((parser (locate-library semantic-debug-parser-source t)))
386 (find-file-noselect parser)
387 (error "Cannot find parser source. It should be on the load-path"))))
389 ;;; Debugger commands
391 (defun semantic-debug-next ()
392 "Perform one parser operation.
393 In the recursive parser, this steps past one match rule.
394 In other parsers, this may be just like `semantic-debug-step'."
396 (let ((parser semantic-debug-current-parser))
397 (semantic-debug-parser-next parser)
398 (exit-recursive-edit)
402 (defun semantic-debug-step ()
403 "Perform one parser operation."
405 (let ((parser semantic-debug-current-parser))
406 (semantic-debug-parser-step parser)
407 (exit-recursive-edit)
411 (defun semantic-debug-up ()
412 "Move highlighting representation up one level."
414 (message "Not implemented yet.")
417 (defun semantic-debug-down ()
418 "Move highlighting representation down one level."
420 (message "Not implemented yet.")
423 (defun semantic-debug-fail-match ()
424 "Artificially fail the current match."
426 (let ((parser semantic-debug-current-parser))
427 (semantic-debug-parser-fail parser)
428 (exit-recursive-edit)
432 (defun semantic-debug-print-state ()
433 "Show interesting parser state."
435 (let ((parser semantic-debug-current-parser))
436 (semantic-debug-parser-print-state parser)
440 (defun semantic-debug-jump-to-source ()
441 "Move cursor to the source code being parsed at the current lexical token."
443 (let* ((interface semantic-debug-current-interface)
444 (buf (oref interface source-buffer)))
445 (if (get-buffer-window buf)
447 (select-frame (window-frame (get-buffer-window buf)))
448 (select-window (get-buffer-window buf)))
449 ;; Technically, this should do a window layout operation
450 (switch-to-buffer buf))
454 (defun semantic-debug-jump-to-parser ()
455 "Move cursor to the parser being debugged."
457 (let* ((interface semantic-debug-current-interface)
458 (buf (oref interface parser-buffer)))
459 (if (get-buffer-window buf)
461 (select-frame (window-frame (get-buffer-window buf)))
462 (select-window (get-buffer-window buf)))
463 ;; Technically, this should do a window layout operation
464 (switch-to-buffer buf))
468 (defun semantic-debug-quit ()
469 "Exit debug mode, blowing all stack, and leaving the parse incomplete.
470 Do not update any tokens already parsed."
472 (let ((parser semantic-debug-current-parser))
473 (semantic-debug-parser-quit parser)
474 (exit-recursive-edit)
478 (defun semantic-debug-abort ()
479 "Abort one level of debug mode, blowing all stack."
481 (let ((parser semantic-debug-current-parser))
482 (semantic-debug-parser-abort parser)
483 (exit-recursive-edit)
487 (defun semantic-debug-go ()
488 "Continue parsing till finish or breakpoint."
490 (let ((parser semantic-debug-current-parser))
491 (semantic-debug-parser-go parser)
492 (exit-recursive-edit)
496 (defun semantic-debug-set-breakpoint ()
497 "Set a breakpoint at the current rule location."
499 (let ((parser semantic-debug-current-parser)
500 ;; Get the location as semantic tokens.
501 (location (semantic-current-tag))
504 (semantic-debug-parser-break parser location)
505 (error "Not on a rule"))
510 ;;; Debugger superclass
512 (defclass semantic-debug-parser ()
515 "Represents a parser and its state.
516 When implementing the debug parser you can add extra functionality
517 by overriding one of the command methods. Be sure to use
518 `call-next-method' so that the debug command is saved, and passed
519 down to your parser later."
522 (defmethod semantic-debug-parser-next ((parser semantic-debug-parser))
523 "Execute next for this PARSER."
524 (setq semantic-debug-user-command 'next)
527 (defmethod semantic-debug-parser-step ((parser semantic-debug-parser))
528 "Execute a step for this PARSER."
529 (setq semantic-debug-user-command 'step)
532 (defmethod semantic-debug-parser-go ((parser semantic-debug-parser))
533 "Continue executiong in this PARSER until the next breakpoint."
534 (setq semantic-debug-user-command 'go)
537 (defmethod semantic-debug-parser-fail ((parser semantic-debug-parser))
538 "Continue executiong in this PARSER until the next breakpoint."
539 (setq semantic-debug-user-command 'fail)
542 (defmethod semantic-debug-parser-quit ((parser semantic-debug-parser))
543 "Continue executiong in this PARSER until the next breakpoint."
544 (setq semantic-debug-user-command 'quit)
547 (defmethod semantic-debug-parser-abort ((parser semantic-debug-parser))
548 "Continue executiong in this PARSER until the next breakpoint."
549 (setq semantic-debug-user-command 'abort)
552 (defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser))
553 "Print state for this PARSER at the current breakpoint."
554 (with-slots (current-frame) semantic-debug-current-interface
556 (semantic-debug-frame-info current-frame)
559 (defmethod semantic-debug-parser-break ((parser semantic-debug-parser))
560 "Set a breakpoint for this PARSER."
564 (defmethod semantic-debug-parser-fames ((parser semantic-debug-parser))
565 "Return a list of frames for the current parser.
566 A frame is of the form:
569 (error "Parser has not implemented frame values")
573 (provide 'semantic-debug)
575 ;;; semantic-debug.el ends here