home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / lisp / debug.jl < prev    next >
Lisp/Scheme  |  1994-04-16  |  3KB  |  105 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. (setq
  23.   debug-buffer (make-buffer "*debugger*")
  24.   debug-keymap (make-keylist))
  25. (set-buffer-special debug-buffer t)
  26. (add-buffer debug-buffer)
  27.  
  28. (bind-keys debug-keymap
  29.   "z" 'debug-step-into
  30.   "s" '(debug-set-result nil)
  31.   "t" 'debug-step-over
  32.   "r" 'debug-full-speed
  33.   "b" '(debug-backtrace 2)
  34.   "esc" '(debug-set-result (eval (read (prompt "Eval: "))))
  35.   "c" '(debug-continue nil)
  36.   "d" '(debug-continue t))
  37.  
  38. (with-buffer debug-buffer
  39.   (setq ctrl-c-keymap debug-keymap)
  40.   (split-line)
  41.   (insert "::Lisp Debugger::\n
  42. ctrl-c z   : step into form
  43. ctrl-c s   : skip form
  44. ctrl-c t   : step over form
  45. ctrl-c r   : run full speed
  46. ctrl-c b   : print backtrace
  47. ctrl-c esc : set value of form
  48. ctrl-c c   : continue after error
  49. ctrl-c d   : break after error\n\n"))
  50.  
  51. (defun debug-entry (debug-obj debug-depth)
  52.   (with-buffer debug-buffer
  53.     (goto (line-start (file-end)))
  54.     (format debug-buffer "%s%S\n" (make-string (* 2 debug-depth)) debug-obj)
  55.     (goto (next-line 1 (indent-pos (prev-line))))
  56.     (catch 'debug-entry
  57.       (recursive-edit))))
  58.  
  59. (defun debug-exit (debug-val debug-depth)
  60.   (with-buffer debug-buffer
  61.     (goto (line-start (file-end)))
  62.     (format debug-buffer "%s=> %S\n" (make-string (* 2 debug-depth)) debug-val)))
  63.  
  64. (defun debug-error-entry (error-list)
  65.   (with-buffer debug-buffer
  66.     (goto (line-start (file-end)))
  67.     (format debug-buffer "*** Error: %s: %S\n" (unless (get (car error-list) 'error-message) (car error-list)) (cdr error-list))
  68.     (catch 'debug-error-entry
  69.       (recursive-edit)
  70.       nil)))
  71.  
  72. (defun debug-step-into ()
  73.   (if (boundp 'debug-obj)
  74.       (throw 'debug-entry (cons 1 debug-obj))
  75.     (beep)))
  76.  
  77. (defun debug-set-result (value)
  78.   (if (boundp 'debug-obj)
  79.       (throw 'debug-entry (cons 4 value))
  80.     (beep)))
  81.  
  82. (defun debug-step-over ()
  83.   (if (boundp 'debug-obj)
  84.       (throw 'debug-entry (cons 2 debug-obj))
  85.     (beep)))
  86.  
  87. (defun debug-full-speed ()
  88.   (if (boundp 'debug-obj)
  89.       (throw 'debug-entry (cons 3 debug-obj))
  90.     (beep)))
  91.  
  92. (defun debug-continue (&optional break-p)
  93.   (if (boundp 'error-list)
  94.       (throw 'debug-error-entry break-p)
  95.     (beep)))
  96.  
  97. ;; DEPTH is the number of stack frames to discard
  98. (defun debug-backtrace (depth)
  99.   (goto (line-start (file-end)))
  100.   (let
  101.       ((old-pos (cursor-pos)))
  102.     (backtrace debug-buffer)
  103.     (delete-area old-pos (next-line (1+ depth) (dup-pos old-pos)))
  104.     (split-line)))
  105.