cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-debug.el

   1 ;;; semantic-debug.el --- Language Debugger framework
   2
   3 ;;; Copyright (C) 2003, 2004, 2005 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; X-RCS: $Id: semantic-debug.el,v 1.1 2007-11-26 15:10:34 michaels Exp $
   7
   8 ;; This file is not part of GNU Emacs.
   9
  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)
  13 ;; any later version.
  14
  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.
  19
  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.
  24 ;;
  25 ;;; Commentary:
  26 ;;
  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
  30 ;; by the parser.
  31 ;;
  32 ;; Fortunatly, the nature of language support files means that the parser
  33 ;; may not need to be instrumented first.
  34 ;;
  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.
  40 ;;
  41
  42 (require 'semantic)
  43 (require 'inversion)
  44 (inversion-require 'eieio "0.18beta1")
  45
  46 ;;; Code:
  47 ;;;###autoload
  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.")
  52 ;;;###autoload
  53 (make-variable-buffer-local 'semantic-debug-parser-source)
  54
  55 ;;;###autoload
  56 (defvar semantic-debug-parser-class nil
  57   "Class to create when building a debug parser object.")
  58 ;;;###autoload
  59 (make-variable-buffer-local 'semantic-debug-parser-class)
  60
  61 ;;;###autoload
  62 (defvar semantic-debug-enabled nil
  63   "Non-nil when debugging a parser.")
  64
  65 ;;; Variables used during a debug session.
  66 (defvar semantic-debug-current-interface nil
  67   "The debugger interface currently active for this buffer.")
  68
  69 (defvar semantic-debug-current-parser nil
  70   "The parser current active for this buffer.")
  71
  72 ;;; User Interface Portion
  73 ;;
  74 (defclass semantic-debug-interface ()
  75   ((parser-buffer :initarg :parser-buffer
  76                   :type buffer
  77                   :documentation
  78                   "The buffer containing the parser we are debugging.")
  79    (parser-local-map :initarg :parser-local-map
  80                      :type keymap
  81                      :documentation
  82                      "The local keymap originally in the PARSER buffer.")
  83    (parser-location :type marker
  84                     :documentation
  85                     "A marker representing where we are in the parser buffer.")
  86    (source-buffer :initarg :source-buffer
  87                   :type buffer
  88                   :documentation
  89                   "The buffer containing the source we are parsing.
  90 The :parser-buffer defines a parser that can parse the text in the
  91 :source-buffer.")
  92    (source-local-map :initarg :source-local-map
  93                      :type keymap
  94                      :documentation
  95                      "The local keymap originally in the SOURCE buffer.")
  96    (source-location :type marker
  97                     :documentation
  98                     "A marker representing where we are in the parser buffer.")
  99    (data-buffer :initarg :data-buffer
 100                 :type buffer
 101                 :documentation
 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
 105                   :documentation
 106                   "The currently displayed frame.")
 107    (overlays :type list
 108              :initarg nil
 109              :documentation
 110              "Any active overlays being used to show the debug position.")
 111    )
 112   "Controls action when in `semantic-debug-mode'")
 113
 114 ;; Methods
 115 (defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame)
 116   "Set the current frame on IFACE to FRAME."
 117   (if frame
 118       (oset iface current-frame frame)
 119     (slot-makeunbound iface 'current-frame)))
 120
 121 (defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface) point)
 122   "Set the parser location in IFACE to POINT."
 123   (save-excursion
 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))
 128   )
 129
 130 (defmethod semantic-debug-set-source-location ((iface semantic-debug-interface) point)
 131   "Set the source location in IFACE to POINT."
 132   (save-excursion
 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))
 137   )
 138
 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))
 145           (cnt (save-excursion
 146                  (set-buffer (oref iface data-buffer))
 147                  (count-lines (point-min) (point-max))))
 148           )
 149       ;; Set the number of lines to 1/3, or the size of the data buffer.
 150       (if (< cnt lines) (setq cnt lines))
 151
 152       (split-window-vertically cnt)
 153       (switch-to-buffer (oref iface data-buffer))
 154       )
 155     (other-window 1))
 156   ;; Parser
 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)
 161   (other-window 1)
 162   ;; Source
 163   (switch-to-buffer (oref iface source-buffer))
 164   (when (slot-boundp iface 'source-location)
 165     (goto-char (oref iface source-location)))
 166   )
 167
 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))
 172
 173   (object-add-to-list iface 'overlays
 174                       (semantic-lex-highlight-token token))
 175
 176   (semantic-debug-set-source-location iface (semantic-lex-token-start token))
 177   )
 178
 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))
 185
 186   (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer)))
 187          (nt (semantic-find-first-tag-by-name nonterm rules))
 188          (o nil)
 189          )
 190     (when nt
 191       ;; I know it is the first symbol appearing in the body of this token.
 192       (goto-char (semantic-tag-start nt))
 193
 194       (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point))))
 195       (semantic-overlay-put o 'face 'highlight)
 196
 197       (object-add-to-list iface 'overlays o)
 198
 199       (semantic-debug-set-parser-location iface (semantic-overlay-start o))
 200
 201       (when (and rule match)
 202
 203         ;; Rule, an int, is the rule inside the nonterminal we are following.
 204         (re-search-forward ":\\s-*")
 205         (while (/= 0 rule)
 206           (re-search-forward "^\\s-*|\\s-*")
 207           (setq rule (1- rule)))
 208
 209         ;; Now find the match inside the rule
 210         (while (/= 0 match)
 211           (forward-sexp 1)
 212           (skip-chars-forward " \t")
 213           (setq match (1- match)))
 214
 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)
 218
 219         (object-add-to-list iface 'overlays o)
 220
 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))
 224
 225         ))))
 226
 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))
 231
 232 ;; Call from the parser at a breakpoint
 233 (defvar semantic-debug-user-command nil
 234   "The command the user is requesting.")
 235
 236 ;;;###autoload
 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)
 249     (unwind-protect
 250         (progn
 251           (semantic-debug-frame-highlight frame)
 252           (semantic-debug-interface-layout semantic-debug-current-interface)
 253           (condition-case nil
 254               ;; Enter recursive edit... wait for user command.
 255               (recursive-edit)
 256             (error nil)))
 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)
 262       returnstate)
 263     ))
 264
 265 ;;; Frame
 266 ;;
 267 ;; A frame can represent the state at a break point.
 268 (defclass semantic-debug-frame ()
 269   (
 270    )
 271   "One frame representation.")
 272
 273 (defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame))
 274   "Highlight one parser frame."
 275
 276   )
 277
 278 (defmethod semantic-debug-frame-info ((frame semantic-debug-frame))
 279   "Display info about this one parser frame."
 280
 281   )
 282
 283 ;;; Major Mode
 284 ;;
 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)
 302
 303     km)
 304   "Keymap used when in semantic-debug-node.")
 305
 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))
 311     (if onoff
 312         ;; Turn it on
 313         (save-excursion
 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
 318           (toggle-read-only 1)
 319
 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
 324           (toggle-read-only 1)
 325           ;; Hooks
 326           (run-hooks 'semantic-debug-mode-hooks)
 327           )
 328       ;; Restore old mode information
 329       (save-excursion
 330         (set-buffer
 331          (oref semantic-debug-current-interface parser-buffer))
 332         (use-local-map
 333          (oref semantic-debug-current-interface parser-local-map))
 334         )
 335       (save-excursion
 336         (set-buffer
 337          (oref semantic-debug-current-interface source-buffer))
 338         (use-local-map
 339          (oref semantic-debug-current-interface source-local-map))
 340         )
 341       (run-hooks 'semantic-debug-exit-hooks)
 342       )))
 343
 344 ;;;###autoload
 345 (defun semantic-debug ()
 346   "Parse the current buffer and run in debug mode."
 347   (interactive)
 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)
 354   ;; Do the parse
 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
 360             "Debug Interface"
 361             :parser-buffer parserb
 362             :parser-local-map (save-excursion
 363                                 (set-buffer parserb)
 364                                 (current-local-map))
 365             :source-buffer (current-buffer)
 366             :source-local-map (current-local-map)
 367             )))
 368         ;; Create a parser debug interface
 369         (semantic-debug-current-parser
 370          (funcall semantic-debug-parser-class "parser"))
 371         )
 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.
 377     ))
 378
 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)))
 385     (if parser
 386         (find-file-noselect parser)
 387       (error "Cannot find parser source.  It should be on the load-path"))))
 388
 389 ;;; Debugger commands
 390 ;;
 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'."
 395   (interactive)
 396   (let ((parser semantic-debug-current-parser))
 397     (semantic-debug-parser-next parser)
 398     (exit-recursive-edit)
 399     )
 400   )
 401
 402 (defun semantic-debug-step ()
 403   "Perform one parser operation."
 404   (interactive)
 405   (let ((parser semantic-debug-current-parser))
 406     (semantic-debug-parser-step parser)
 407     (exit-recursive-edit)
 408     )
 409   )
 410
 411 (defun semantic-debug-up ()
 412   "Move highlighting representation up one level."
 413   (interactive)
 414   (message "Not implemented yet.")
 415   )
 416
 417 (defun semantic-debug-down ()
 418   "Move highlighting representation down one level."
 419   (interactive)
 420   (message "Not implemented yet.")
 421   )
 422
 423 (defun semantic-debug-fail-match ()
 424   "Artificially fail the current match."
 425   (interactive)
 426   (let ((parser semantic-debug-current-parser))
 427     (semantic-debug-parser-fail parser)
 428     (exit-recursive-edit)
 429     )
 430   )
 431
 432 (defun semantic-debug-print-state ()
 433   "Show interesting parser state."
 434   (interactive)
 435   (let ((parser semantic-debug-current-parser))
 436     (semantic-debug-parser-print-state parser)
 437     )
 438   )
 439
 440 (defun semantic-debug-jump-to-source ()
 441   "Move cursor to the source code being parsed at the current lexical token."
 442   (interactive)
 443   (let* ((interface semantic-debug-current-interface)
 444          (buf (oref interface source-buffer)))
 445     (if (get-buffer-window buf)
 446         (progn
 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))
 451     )
 452   )
 453
 454 (defun semantic-debug-jump-to-parser ()
 455   "Move cursor to the parser being debugged."
 456   (interactive)
 457   (let* ((interface semantic-debug-current-interface)
 458          (buf (oref interface parser-buffer)))
 459     (if (get-buffer-window buf)
 460         (progn
 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))
 465     )
 466   )
 467
 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."
 471   (interactive)
 472   (let ((parser semantic-debug-current-parser))
 473     (semantic-debug-parser-quit parser)
 474     (exit-recursive-edit)
 475     )
 476   )
 477
 478 (defun semantic-debug-abort ()
 479   "Abort one level of debug mode, blowing all stack."
 480   (interactive)
 481   (let ((parser semantic-debug-current-parser))
 482     (semantic-debug-parser-abort parser)
 483     (exit-recursive-edit)
 484     )
 485   )
 486
 487 (defun semantic-debug-go ()
 488   "Continue parsing till finish or breakpoint."
 489   (interactive)
 490   (let ((parser semantic-debug-current-parser))
 491     (semantic-debug-parser-go parser)
 492     (exit-recursive-edit)
 493     )
 494   )
 495
 496 (defun semantic-debug-set-breakpoint ()
 497   "Set a breakpoint at the current rule location."
 498   (interactive)
 499   (let ((parser semantic-debug-current-parser)
 500         ;; Get the location as semantic tokens.
 501         (location (semantic-current-tag))
 502         )
 503     (if location
 504         (semantic-debug-parser-break parser location)
 505       (error "Not on a rule"))
 506     )
 507   )
 508
 509
 510 ;;; Debugger superclass
 511 ;;
 512 (defclass semantic-debug-parser ()
 513   (
 514    )
 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."
 520   :abstract t)
 521
 522 (defmethod semantic-debug-parser-next ((parser semantic-debug-parser))
 523   "Execute next for this PARSER."
 524   (setq semantic-debug-user-command 'next)
 525   )
 526
 527 (defmethod semantic-debug-parser-step ((parser semantic-debug-parser))
 528   "Execute a step for this PARSER."
 529   (setq semantic-debug-user-command 'step)
 530   )
 531
 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)
 535   )
 536
 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)
 540   )
 541
 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)
 545   )
 546
 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)
 550   )
 551
 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
 555     (when current-frame
 556       (semantic-debug-frame-info current-frame)
 557       )))
 558
 559 (defmethod semantic-debug-parser-break ((parser semantic-debug-parser))
 560   "Set a breakpoint for this PARSER."
 561   )
 562
 563 ;; Stack stuff
 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:
 567   ( .. .what ? .. )
 568 "
 569   (error "Parser has not implemented frame values")
 570   )
 571
 572
 573 (provide 'semantic-debug)
 574
 575 ;;; semantic-debug.el ends here