home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / lisp / debug.jl < prev    next >
Lisp/Scheme  |  1994-10-01  |  4KB  |  124 lines
  1. ;;;; debug.jl -- Lisp debugger (well, single-stepper anyway)
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (provide 'debug)
  21.  
  22. (defvar debug-buffer (make-buffer "*debugger*")
  23.   "Buffer to use for the Lisp debugger.")
  24. (set-buffer-special debug-buffer t)
  25. (add-buffer debug-buffer)
  26.  
  27. (defvar debug-ctrl-c-keymap (make-keylist)
  28.   "Keymap for debugger's ctrl-c prefix.")
  29.  
  30. (bind-keys debug-ctrl-c-keymap
  31.   "Ctrl-s" 'debug-step
  32.   "Ctrl-i" '(debug-set-result nil)
  33.   "Ctrl-n" 'debug-next
  34.   "Ctrl-c" 'debug-continue
  35.   "Ctrl-r" 'debug-continue
  36.   "Ctrl-b" '(debug-backtrace 2)
  37.   "Ctrl-x" 'debug-set-result)
  38.  
  39. (defun debug-mode ()
  40.   "Debug Mode:\n
  41. The major mode controlling the Lisp debugger. Commands available within
  42. the debugger are,\n
  43.   `Ctrl-c Ctrl-s'        Step into this form.
  44.   `Ctrl-c Ctrl-i'        Ignore this form.
  45.   `Ctrl-c Ctrl-n'        Continue until the next form.
  46.   `Ctrl-c Ctrl-r'        Continue execution.
  47.   `Ctrl-c Ctrl-b'        Print a backtrace of the Lisp call stack.
  48.   `Ctrl-c Ctrl-x'        Set the value which this form will return."
  49.   (setq ctrl-c-keymap debug-ctrl-c-keymap
  50.     major-mode 'debug-mode
  51.     mode-name "Debug"))
  52.  
  53. (with-buffer debug-buffer
  54.   (debug-mode)
  55.   (split-line)
  56.   (insert "::Lisp Debugger::\n
  57. Ctrl-c Ctrl-s    : Step into form
  58. Ctrl-c Ctrl-i    : Ignore form
  59. Ctrl-c Ctrl-n    : Continue until next form
  60. Ctrl-c Ctrl-r    : Continue
  61. Ctrl-c Ctrl-b    : Print backtrace
  62. Ctrl-c Ctrl-x    : Set value of form\n\n"))
  63.  
  64.  
  65. ;;;###autoload
  66. (defun debug-entry (debug-obj debug-depth)
  67.   (with-buffer debug-buffer
  68.     (goto-char (line-start (buffer-end)))
  69.     (format debug-buffer "%s%S\n" (make-string (* 2 debug-depth)) debug-obj)
  70.     (goto-glyph (next-line 1 (indent-pos (prev-line))))
  71.     (catch 'debug
  72.       (recursive-edit))))
  73.  
  74. (defun debug-exit (debug-val debug-depth)
  75.   (with-buffer debug-buffer
  76.     (goto-char (line-start (buffer-end)))
  77.     (format debug-buffer "%s=> %S\n" (make-string (* 2 debug-depth)) debug-val)))
  78.  
  79. ;;;###autoload
  80. (defun debug-error-entry (error-list)
  81.   (with-buffer debug-buffer
  82.     (goto-char (line-start (buffer-end)))
  83.     (format debug-buffer "*** Error: %s: %S\n" (unless (get (car error-list) 'error-message) (car error-list)) (cdr error-list))
  84.     (catch 'debug
  85.       (recursive-edit)
  86.       nil)))
  87.  
  88. (defun debug-step ()
  89.   (interactive)
  90.   (if (boundp 'debug-obj)
  91.       (throw 'debug (cons 1 debug-obj))
  92.     (beep)))
  93.  
  94. (defun debug-set-result (value)
  95.   (interactive "XEval:")
  96.   (if (boundp 'debug-obj)
  97.       (throw 'debug (cons 4 value))
  98.     (beep)))
  99.  
  100. (defun debug-next ()
  101.   (interactive)
  102.   (if (boundp 'debug-obj)
  103.       (throw 'debug (cons 2 debug-obj))
  104.     (beep)))
  105.  
  106. (defun debug-continue ()
  107.   (interactive)
  108.   (cond
  109.    ((boundp 'debug-obj)
  110.     (throw 'debug (cons 3 debug-obj)))
  111.    ((boundp 'error-list)
  112.     (throw 'debug))
  113.    (t
  114.     (beep))))
  115.  
  116. ;; DEPTH is the number of stack frames to discard
  117. (defun debug-backtrace (depth)
  118.   (goto-char (line-start (buffer-end)))
  119.   (let
  120.       ((old-pos (cursor-pos)))
  121.     (backtrace debug-buffer)
  122.     (delete-area old-pos (next-line (1+ depth) (copy-pos old-pos)))
  123.     (split-line)))
  124.