home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / debug.lisp < prev    next >
Encoding:
Text File  |  1992-07-28  |  33.1 KB  |  1,026 lines
  1. ;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: debug.lisp,v 1.30.1.1 92/07/28 19:51:37 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; CMU Common Lisp Debugger.  This includes a basic command-line oriented
  15. ;;; debugger interface as well as support for Hemlock to deliver debugger
  16. ;;; commands to a slave Lisp.
  17. ;;;
  18. ;;; Written by Bill Chiles.
  19. ;;;
  20.  
  21. (in-package "DEBUG")
  22.  
  23. (export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
  24.       *debug-print-level* *debug-print-length* *debug-prompt*
  25.       *help-line-scroll-count* *stack-top-hint*
  26.  
  27.       *auto-eval-in-frame* var arg
  28.  
  29.       do-debug-command))
  30.  
  31. (in-package "LISP")
  32. (export '(invoke-debugger *debugger-hook*))
  33.  
  34. (in-package "DEBUG")
  35.  
  36.  
  37.  
  38. ;;;; Variables, parameters, and constants.
  39.  
  40. (defparameter *debug-print-level* 3
  41.   "*PRINT-LEVEL* is bound to this value when debug prints a function call.  If
  42.   null, use *PRINT-LEVEL*")
  43.  
  44. (defparameter *debug-print-length* 5
  45.   "*PRINT-LENGTH* is bound to this value when debug prints a function call.  If
  46.   null, use *PRINT-LENGTH*.")
  47.  
  48. (defvar *in-the-debugger* nil
  49.   "This is T while in the debugger.")
  50.  
  51. (defvar *debug-command-level* 0
  52.   "Pushes and pops/exits inside the debugger change this.")
  53.  
  54. (defvar *stack-top-hint* nil
  55.   "If this is bound before the debugger is invoked, it is used as the stack
  56.    top by the debugger.")
  57. (defvar *stack-top* nil)
  58. (defvar *real-stack-top* nil)
  59.  
  60. (defvar *current-frame* nil)
  61. (defvar *current-code-location* nil)
  62.  
  63. ;;; DEBUG-PROMPT -- Internal.
  64. ;;;
  65. ;;; This is the default for *debug-prompt*.
  66. ;;;
  67. (defun debug-prompt ()
  68.   (let ((*standard-output* *debug-io*))
  69.     (terpri)
  70.     (prin1 (di:frame-number *current-frame*))
  71.     (dotimes (i *debug-command-level*) (princ "]"))
  72.     (princ " ")
  73.     (force-output)))
  74.  
  75. (defparameter *debug-prompt* #'debug-prompt
  76.   "This is a function of no arguments that prints the debugger prompt
  77.    on *debug-io*.")
  78.  
  79. (defconstant debug-help-string
  80. "
  81. The prompt is right square brackets, the number indicating how many
  82.   recursive command loops you are in.
  83. Debug commands do not affect * and friends, but evaluation in the debug loop
  84.   do affect these variables.
  85. Any command may be uniquely abbreviated.
  86.  
  87. Getting in and out of DEBUG:
  88.   Q        throws to top level.
  89.   GO       calls CONTINUE which tries to proceed with the restart 'continue.
  90.   RESTART  invokes restart numbered as shown (prompt if not given).
  91.   ERROR    prints the error condition and restart cases.
  92.   FLUSH    toggles *flush-debug-errors*, which is initially t.
  93.  
  94.   The name of any restart, or its number, is a valid command, and is the same
  95.     as using RESTART to invoke that restart.
  96.  
  97. Changing frames:
  98.   U  up frame        D  down frame       T  top frame       B  bottom frame
  99.  
  100.   F n   goes to frame n.
  101.  
  102. Inspecting frames:
  103.   BACKTRACE [n]  shows n frames going down the stack.
  104.   L              lists locals in current function.
  105.   P, PP          displays current function call.
  106.   SOURCE [n]     displays frame's source form with n levels of enclosing forms.
  107.   VSOURCE [n]    displays frame's source form without any ellipsis.
  108.  
  109. Function and macro commands:
  110.  (DEBUG:DEBUG-RETURN expression)
  111.     returns expression's values from the current frame, exiting the debugger.
  112.  (DEBUG:ARG n)
  113.     returns the n'th argument, remaining in the debugger.
  114.  (DEBUG:VAR string-or-symbol [id])
  115.     returns the specified variable's value, remaining in the debugger.
  116.  
  117. See the CMU Common Lisp User's Manual for more information.
  118. ")
  119.  
  120.  
  121.  
  122. ;;;; Backtrace:
  123.  
  124. ;;; BACKTRACE -- Public.
  125. ;;;
  126. (defun backtrace (&optional (count most-positive-fixnum)
  127.                 (*standard-output* *debug-io*))
  128.   "Show a listing of the call stack going down from the current frame.  In the
  129.    debugger, the current frame is indicated by the prompt.  Count is how many
  130.    frames to show."
  131.   (let ((*print-length* (or *debug-print-length* *print-length*))
  132.     (*print-level* (or *debug-print-level* *print-level*)))
  133.     (fresh-line *standard-output*)
  134.     (do ((frame (if *in-the-debugger* *current-frame* (di:top-frame))
  135.         (di:frame-down frame))
  136.      (count count (1- count)))
  137.     ((or (null frame) (zerop count))
  138.      (values))
  139.       (print-frame-call frame))))
  140.  
  141.  
  142. (eval-when (compile eval)
  143.  
  144. ;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal.
  145. ;;;
  146. ;;; This is a convenient way to express what to do for each type of lambda-list
  147. ;;; element.
  148. ;;;
  149. (defmacro lambda-list-element-dispatch (element &key required optional rest
  150.                         keyword deleted)
  151.   `(etypecase ,element
  152.      (di:debug-variable
  153.       ,@required)
  154.      (cons
  155.       (ecase (car ,element)
  156.     (:optional ,@optional)
  157.     (:rest ,@rest)
  158.     (:keyword ,@keyword)))
  159.      (symbol
  160.       (assert (eq ,element :deleted))
  161.       ,@deleted)))
  162.  
  163. (defmacro lambda-var-dispatch (variable location deleted valid other)
  164.   (let ((var (gensym)))
  165.     `(let ((,var ,variable))
  166.        (cond ((eq ,var :deleted) ,deleted)
  167.          ((eq (di:debug-variable-validity ,var ,location) :valid) ,valid)
  168.          (t ,other)))))
  169.  
  170. ) ;EVAL-WHEN
  171.  
  172. ;;; PRINT-FRAME-CALL -- Internal.
  173. ;;;
  174. ;;; This prints a representation of the function call causing frame to exist.
  175. ;;; Verbosity indicates the level of information to output; zero indicates just
  176. ;;; printing the debug-function's name, and one indicates displaying call-like,
  177. ;;; one-liner format with argument values.
  178. ;;;
  179. (defun print-frame-call (frame &optional
  180.                    (*print-length* (or *debug-print-length*
  181.                            *print-length*))
  182.                    (*print-level* (or *debug-print-level*
  183.                           *print-level*))
  184.                    (verbosity 1))
  185.   (ecase verbosity
  186.     (0 (print frame))
  187.     (1 (print-frame-call-1 frame))
  188.     ((2 3 4 5))))
  189.  
  190. ;;; This is used in constructing arg lists for debugger printing when the arg
  191. ;;; list is unavailable, some arg is unavailable or unused, etc.
  192. ;;;
  193. (defstruct (unprintable-object
  194.         (:constructor make-unprintable-object (string))
  195.         (:print-function (lambda (x s d)
  196.                    (declare (ignore d))
  197.                    (format s "#<~A>"
  198.                        (unprintable-object-string x)))))
  199.   string)
  200.  
  201. ;;; PRINT-FRAME-CALL-1 -- Internal.
  202. ;;;
  203. ;;; This prints frame with verbosity level 1.  If we hit a rest-arg, 
  204. ;;; then print as many of the values as possible,
  205. ;;; punting the loop over lambda-list variables since any other arguments
  206. ;;; will be in the rest-arg's list of values.
  207. ;;;
  208. (defun print-frame-call-1 (frame &optional (preceding-newline t))
  209.   (let* ((d-fun (di:frame-debug-function frame))
  210.      (loc (di:frame-code-location frame))
  211.      (results (list (di:debug-function-name d-fun))))
  212.     (handler-case
  213.     (dolist (ele (di:debug-function-lambda-list d-fun))
  214.       (lambda-list-element-dispatch ele
  215.         :required ((push (frame-call-arg ele loc frame) results))
  216.         :optional ((push (frame-call-arg (second ele) loc frame) results))
  217.         :keyword ((push (second ele) results)
  218.               (push (frame-call-arg (third ele) loc frame) results))
  219.         :deleted ((push (frame-call-arg ele loc frame) results))
  220.         :rest ((lambda-var-dispatch (second ele) loc
  221.              nil
  222.              (progn
  223.                (setf results
  224.                  (append (reverse (di:debug-variable-value
  225.                            (second ele) frame))
  226.                      results))
  227.                (return))
  228.              (push (make-unprintable-object "unavaliable-rest-arg")
  229.                results)))))
  230.       (di:lambda-list-unavailable
  231.        ()
  232.        (push (make-unprintable-object "lambda-list-unavailable") results)))
  233.     (when preceding-newline (terpri))
  234.     (prin1 (nreverse results))
  235.     (when (di:debug-function-kind d-fun)
  236.       (write-char #\[)
  237.       (prin1 (di:debug-function-kind d-fun))
  238.       (write-char #\]))))
  239. ;;;
  240. (defun frame-call-arg (var location frame)
  241.   (lambda-var-dispatch var location
  242.     (make-unprintable-object "unused-arg")
  243.     (di:debug-variable-value var frame)
  244.     (make-unprintable-object "unavailable-arg")))
  245.  
  246.  
  247.  
  248. ;;;; INVOKE-DEBUGGER.
  249.  
  250. (defvar *debugger-hook* nil
  251.   "This is either nil or a function of two arguments, a condition and the value
  252.    of *debugger-hook*.  This function can either handle the condition or return
  253.    which causes the standard debugger to execute.  The system passes the value
  254.    of this variable to the function because it binds *debugger-hook* to nil
  255.    around the invocation.")
  256.  
  257. ;;; These are bound on each invocation of INVOKE-DEBUGGER.
  258. ;;;
  259. (defvar *debug-restarts*)
  260. (defvar *debug-condition*)
  261.  
  262. ;;; INVOKE-DEBUGGER -- Public.
  263. ;;;
  264. (defun invoke-debugger (condition)
  265.   "The CMU Common Lisp debugger.  Type h for help."
  266.   (when *debugger-hook*
  267.     (let ((hook *debugger-hook*)
  268.       (*debugger-hook* nil))
  269.       (funcall hook condition hook)))
  270.   (unix:unix-sigsetmask 0)
  271.   (let* ((*debug-condition* condition)
  272.      (*debug-restarts* (compute-restarts))
  273.      (*standard-input* *debug-io*)        ;in case of setq
  274.      (*standard-output* *debug-io*)        ;''  ''  ''  ''
  275.      (*error-output* *debug-io*)
  276.      ;; Rebind some printer control variables.
  277.      (kernel:*current-level* 0)
  278.      (*print-readably* nil)
  279.      (*read-eval* t))
  280.     (format *error-output* "~2&~A~2&" *debug-condition*)
  281.     (show-restarts *debug-restarts* *error-output*)
  282.     (internal-debug)))
  283.  
  284. ;;; SHOW-RESTARTS -- Internal.
  285. ;;;
  286. (defun show-restarts (restarts &optional (s *error-output*))
  287.   (when restarts
  288.     (format s "~&Restarts:~%")
  289.     (let ((count 0)
  290.       (names-used '(nil))
  291.       (max-name-len 0))
  292.       (dolist (restart restarts)
  293.     (let ((name (restart-name restart)))
  294.       (when name
  295.         (let ((len (length (princ-to-string name))))
  296.           (when (> len max-name-len)
  297.         (setf max-name-len len))))))
  298.       (unless (zerop max-name-len)
  299.     (incf max-name-len 3))
  300.       (dolist (restart restarts)
  301.     (let ((name (restart-name restart)))
  302.       (cond ((member name names-used)
  303.          (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
  304.         (t
  305.          (format s "~& ~2D: [~VA] ~A~%"
  306.              count (- max-name-len 3) name restart)
  307.          (push name names-used))))
  308.     (incf count)))))
  309.  
  310. ;;; INTERNAL-DEBUG -- Internal Interface.
  311. ;;;
  312. ;;; This calls DEBUG-LOOP, performing some simple initializations before doing
  313. ;;; so.  INVOKE-DEBUGGER calls this to actually get into the debugger.
  314. ;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
  315. ;;; prompt as quickly as possible with as little risk as possible for stepping
  316. ;;; on whatever is causing recursive errors.
  317. ;;;
  318. (defun internal-debug ()
  319.   (let ((*in-the-debugger* t)
  320.     (*read-suppress* nil))
  321.     (clear-input *debug-io*)
  322.     (format *debug-io* "~2&Debug  (type H for help)~%")
  323.     (debug-loop)))
  324.  
  325.  
  326.  
  327. ;;;; DEBUG-LOOP.
  328.  
  329. (defvar *flush-debug-errors* t
  330.   "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
  331.    executing in the debugger.  The 'flush' command toggles this.")
  332.  
  333. (defun debug-loop ()
  334.   (let* ((*debug-command-level* (1+ *debug-command-level*))
  335.      (*real-stack-top* (di:top-frame))
  336.      (*stack-top* (or *stack-top-hint* *real-stack-top*))
  337.      (*stack-top-hint* nil)
  338.      (*current-frame* *stack-top*)
  339.      (*current-code-location* nil))
  340.     (handler-bind ((di:debug-condition #'(lambda (condition)
  341.                        (princ condition *debug-io*)
  342.                        (throw 'debug-loop-catcher nil))))
  343.       (print-frame-call *current-frame*)
  344.       (loop
  345.     (catch 'debug-loop-catcher
  346.       (handler-bind ((error #'(lambda (condition)
  347.                     (when *flush-debug-errors*
  348.                       (clear-input *debug-io*)
  349.                       (princ condition)
  350.                       (format t "~&Error flushed ...")
  351.                       (throw 'debug-loop-catcher nil)))))
  352.         ;; Must bind level for restart function created by
  353.         ;; WITH-SIMPLE-RESTART.
  354.         (let ((level *debug-command-level*)
  355.           (restart-commands (make-restart-commands)))
  356.           (with-simple-restart (abort "Return to debug level ~D." level)
  357.         (funcall *debug-prompt*)
  358.         (let ((input (ext:get-stream-command *debug-io*)))
  359.           (cond (input
  360.              (let ((cmd-fun (debug-command-p
  361.                      (ext:stream-command-name input)
  362.                      restart-commands)))
  363.                (cond
  364.                 ((not cmd-fun)
  365.                  (error "Unknown stream-command -- ~S." input))
  366.                 ((consp cmd-fun)
  367.                  (error "Ambiguous debugger command: ~S." cmd-fun))
  368.                 (t
  369.                  (apply cmd-fun (ext:stream-command-args input))))))
  370.             (t
  371.              (let* ((exp (read))
  372.                 (cmd-fun (debug-command-p exp restart-commands)))
  373.                (cond ((not cmd-fun)
  374.                   (debug-eval-print exp))
  375.                  ((consp cmd-fun)
  376.                   (format t "~&Your command, ~S, is ambiguous:~%"
  377.                       exp)
  378.                   (dolist (ele cmd-fun)
  379.                     (format t "   ~A~%" ele)))
  380.                  (t
  381.                   (funcall cmd-fun)))))))))))))))
  382.  
  383. (defvar *auto-eval-in-frame* t
  384.   "When set (the default), evaluations in the debugger's command loop occur
  385.    relative to the current frame's environment without the need of debugger
  386.    forms that explicitly control this kind of evaluation.")
  387.  
  388. (defun debug-eval-print (exp)
  389.   (setq +++ ++ ++ + + - - exp)
  390.   (let* ((values (multiple-value-list
  391.           (if (and (fboundp 'eval:internal-eval) *auto-eval-in-frame*)
  392.               (di:eval-in-frame *current-frame* -)
  393.               (eval -))))
  394.      (*standard-output* *debug-io*))
  395.     (fresh-line)
  396.     (if values (prin1 (car values)))
  397.     (dolist (x (cdr values))
  398.       (fresh-line)
  399.       (prin1 x))
  400.     (setq /// // // / / values)
  401.     (setq *** ** ** * * (car values))
  402.     ;; Make sure nobody passes back an unbound marker.
  403.     (unless (boundp '*)
  404.       (setq * nil)
  405.       (fresh-line)
  406.       (princ "Setting * to NIL -- was unbound marker."))))
  407.  
  408.  
  409.  
  410. ;;;; Debug loop functions.
  411.  
  412. ;;; These commands are function, not really commands, so users can get their
  413. ;;; hands on the values returned.
  414. ;;;
  415.  
  416. (eval-when (eval compile)
  417.  
  418. (defmacro define-var-operation (ref-or-set &optional value-var)
  419.   `(let* ((temp (etypecase name
  420.           (symbol (di:debug-function-symbol-variables
  421.                (di:frame-debug-function *current-frame*)
  422.                name))
  423.           (simple-string (di:ambiguous-debug-variables
  424.                   (di:frame-debug-function *current-frame*)
  425.                   name))))
  426.       (location (di:frame-code-location *current-frame*))
  427.       ;; Let's only deal with valid variables.
  428.       (vars (remove-if-not #'(lambda (v)
  429.                    (eq (di:debug-variable-validity v location)
  430.                        :valid))
  431.                    temp)))
  432.      (declare (list vars))
  433.      (cond ((null vars)
  434.         (error "No known valid variables match ~S." name))
  435.        ((= (length vars) 1)
  436.         ,(ecase ref-or-set
  437.            (:ref
  438.         '(di:debug-variable-value (car vars) *current-frame*))
  439.            (:set
  440.         `(setf (di:debug-variable-value (car vars) *current-frame*)
  441.                ,value-var))))
  442.        (t
  443.         ;; Since we have more than one, first see if we have any
  444.         ;; variables that exactly match the specification.
  445.         (let* ((name (etypecase name
  446.                (symbol (symbol-name name))
  447.                (simple-string name)))
  448.            (exact (remove-if-not #'(lambda (v)
  449.                          (string= (di:debug-variable-name v)
  450.                               name))
  451.                      vars))
  452.            (vars (or exact vars)))
  453.           (declare (simple-string name)
  454.                (list exact vars))
  455.           (cond
  456.            ;; Check now for only having one variable.
  457.            ((= (length vars) 1)
  458.         ,(ecase ref-or-set
  459.            (:ref
  460.             '(di:debug-variable-value (car vars) *current-frame*))
  461.            (:set
  462.             `(setf (di:debug-variable-value (car vars) *current-frame*)
  463.                ,value-var))))
  464.            ;; If there weren't any exact matches, flame about ambiguity
  465.            ;; unless all the variables have the same name.
  466.            ((and (not exact)
  467.              (find-if-not
  468.               #'(lambda (v)
  469.               (string= (di:debug-variable-name v)
  470.                    (di:debug-variable-name (car vars))))
  471.               (cdr vars)))
  472.         (error "Specification ambiguous:~%~{   ~A~%~}"
  473.                (mapcar #'di:debug-variable-name
  474.                    (delete-duplicates
  475.                 vars :test #'string=
  476.                 :key #'di:debug-variable-name))))
  477.            ;; All names are the same, so see if the user ID'ed one of them.
  478.            (id-supplied
  479.         (let ((v (find id vars :key #'di:debug-variable-id)))
  480.           (unless v
  481.             (error "Invalid variable ID, ~D, should have been one of ~S."
  482.                id (mapcar #'di:debug-variable-id vars)))
  483.           ,(ecase ref-or-set
  484.              (:ref
  485.               '(di:debug-variable-value v *current-frame*))
  486.              (:set
  487.               `(setf (di:debug-variable-value v *current-frame*)
  488.                  ,value-var)))))
  489.            (t
  490.         (error "Specify variable ID to disambiguate ~S.  Use one of ~S."
  491.                name (mapcar #'di:debug-variable-id vars)))))))))
  492.  
  493. ) ;EVAL-WHEN
  494.  
  495. ;;; VAR -- Public.
  496. ;;;
  497. (defun var (name &optional (id 0 id-supplied))
  498.   "Returns a variable's value if possible.  Name is a simple-string or symbol.
  499.    If it is a simple-string, it is an initial substring of the variable's name.
  500.    If name is a symbol, it has the same name and package as the variable whose
  501.    value this function returns.  If the symbol is uninterned, then the variable
  502.    has the same name as the symbol, but it has no package.
  503.  
  504.    If name is the initial substring of variables with different names, then
  505.    this return no values after displaying the ambiguous names.  If name
  506.    determines multiple variables with the same name, then you must use the
  507.    optional id argument to specify which one you want.  If you left id
  508.    unspecified, then this returns no values after displaying the distinguishing
  509.    id values.
  510.  
  511.    The result of this function is limited to the availability of variable
  512.    information.  This is SETF'able."
  513.   (define-var-operation :ref))
  514. ;;;
  515. (defun (setf var) (value name &optional (id 0 id-supplied))
  516.   (define-var-operation :set value))
  517.  
  518.  
  519.  
  520. ;;; ARG -- Public.
  521. ;;;
  522. (defun arg (n)
  523.   "Returns the n'th argument's value if possible.  Argument zero is the first
  524.    argument in a frame's default printed representation.  Count keyword/value
  525.    pairs as separate arguments."
  526.   (multiple-value-bind
  527.       (var lambda-var-p)
  528.       (nth-arg n (handler-case (di:debug-function-lambda-list
  529.                 (di:frame-debug-function *current-frame*))
  530.            (di:lambda-list-unavailable ()
  531.              (error "No argument values are available."))))
  532.     (if lambda-var-p
  533.     (lambda-var-dispatch var (di:frame-code-location *current-frame*)
  534.       (error "Unused arguments have no values.")
  535.       (di:debug-variable-value var *current-frame*)
  536.       (error "Invalid argument value."))
  537.     var)))
  538.  
  539. ;;; NTH-ARG -- Internal.
  540. ;;;
  541. ;;; This returns the n'th arg as the user sees it from args, the result of
  542. ;;; DI:DEBUG-FUNCTION-LAMBDA-LIST.  If this returns a potential debug-variable
  543. ;;; from the lambda-list, then the second value is t.  If this returns a
  544. ;;; keyword symbol or a value from a rest arg, then the second value is nil.
  545. ;;;
  546. (defun nth-arg (count args)
  547.   (let ((n count))
  548.     (dolist (ele args (error "Argument specification out of range -- ~S." n))
  549.       (lambda-list-element-dispatch ele
  550.     :required ((if (zerop n) (return (values ele t))))
  551.     :optional ((if (zerop n) (return (values (second ele) t))))
  552.     :keyword ((cond ((zerop n)
  553.              (return (values (second ele) nil)))
  554.             ((zerop (decf n))
  555.              (return (values (third ele) t)))))
  556.     :deleted ((if (zerop n) (return (values ele t))))
  557.     :rest ((let ((var (second ele)))
  558.          (lambda-var-dispatch var
  559.                       (di:frame-code-location *current-frame*)
  560.            (error "Unused rest-arg before n'th argument.")
  561.            (dolist (value
  562.                 (di:debug-variable-value var *current-frame*)
  563.                 (error "Argument specification out of range -- ~S."
  564.                    n))
  565.              (if (zerop n)
  566.              (return-from nth-arg (values value nil))
  567.              (decf n)))
  568.            (error "Invalid rest-arg before n'th argument.")))))
  569.       (decf n))))
  570.  
  571.  
  572.  
  573. ;;;; Debug loop commands.
  574.  
  575. (defvar *debug-commands* nil)
  576.  
  577. ;;; DEF-DEBUG-COMMAND -- Internal.
  578. ;;;
  579. ;;; Interface to *debug-commands*.  No required arguments in args are
  580. ;;; permitted.
  581. ;;;
  582. (defmacro def-debug-command (name args &rest body)
  583.   (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
  584.     `(progn
  585.        (when (assoc ,name *debug-commands* :test #'string=)
  586.      (warn "Redefining ~S debugger command." ,name)
  587.      (setf *debug-commands*
  588.            (remove ,name *debug-commands* :key #'car :test #'string=)))
  589.        (defun ,fun-name ,args
  590.      (unless *in-the-debugger*
  591.        (error "Invoking debugger command while outside the debugger."))
  592.      ,@body)
  593.        (push (cons ,name #',fun-name) *debug-commands*)
  594.        ',fun-name)))
  595.  
  596. ;;; DEF-DEBUG-COMMAND-ALIAS -- Internal.
  597. ;;;
  598. (defun def-debug-command-alias (new-name existing-name)
  599.   (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
  600.     (unless pair (error "Unknown debug command name -- ~S" existing-name))
  601.     (push (cons new-name (cdr pair)) *debug-commands*))
  602.   new-name)
  603.  
  604. ;;; DEBUG-COMMAND-P -- Internal.
  605. ;;;
  606. ;;; This takes a symbol and uses its name to find a debugger command, using
  607. ;;; initial substring matching.  It returns the command function if form
  608. ;;; identifies only one command, but if form is ambiguous, this returns a list
  609. ;;; of the command names.  If there are no matches, this returns nil.  Whenever
  610. ;;; the loop that looks for a set of possibilities encounters an exact name
  611. ;;; match, we return that command function immediately.
  612. ;;;
  613. (defun debug-command-p (form &optional other-commands)
  614.   (if (or (symbolp form) (integerp form))
  615.       (let* ((name
  616.           (if (symbolp form)
  617.           (symbol-name form)
  618.           (format nil "~d" form)))
  619.          (len (length name))
  620.          (res nil))
  621.     (declare (simple-string name)
  622.          (fixnum len)
  623.          (list res))
  624.     ;;
  625.     ;; Find matching commands, punting if exact match.
  626.     (flet ((match-command (ele)
  627.              (let* ((str (car ele))
  628.             (str-len (length str)))
  629.            (declare (simple-string str)
  630.                 (fixnum str-len))
  631.            (cond ((< str-len len))
  632.              ((= str-len len)
  633.               (when (string= name str :end1 len :end2 len)
  634.                 (return-from debug-command-p (cdr ele))))
  635.              ((string= name str :end1 len :end2 len)
  636.               (push ele res))))))
  637.       (mapc #'match-command *debug-commands*)
  638.       (mapc #'match-command other-commands))
  639.     ;;
  640.     ;; Return the right value.
  641.     (cond ((not res) nil)
  642.           ((= (length res) 1)
  643.            (cdar res))
  644.           (t ;Just return the names.
  645.            (do ((cmds res (cdr cmds)))
  646.            ((not cmds) res)
  647.          (setf (car cmds) (caar cmds))))))))
  648.  
  649.  
  650. ;;;
  651. ;;; Returns a list of debug commands (in the same format as *debug-commands*)
  652. ;;; that invoke each active restart.
  653. ;;;
  654. ;;; Two commands are made for each restart: one for the number, and one for
  655. ;;; the restart name (unless it's been shadowed by an earlier restart of the
  656. ;;; same name.
  657. ;;;
  658. (defun make-restart-commands (&optional (restarts *debug-restarts*))
  659.   (let ((commands)
  660.     (num 0))            ; better be the same as show-restarts!
  661.     (dolist (restart restarts)
  662.       (let ((name (string (restart-name restart))))
  663.     (unless (find name commands :key #'car :test #'string=)
  664.       (let ((restart-fun
  665.          #'(lambda ()
  666.              (invoke-restart-interactively restart))))
  667.         (push (cons name restart-fun) commands)
  668.         (push (cons (format nil "~d" num) restart-fun) commands))))
  669.       (incf num))
  670.     commands))
  671.  
  672. ;;;
  673. ;;; Frame changing commands.
  674. ;;;
  675.  
  676. (def-debug-command "UP" ()
  677.   (let ((next (di:frame-up *current-frame*)))
  678.     (cond (next
  679.        (setf *current-code-location* nil)
  680.        (setf *current-frame* next)
  681.        (print-frame-call next))
  682.       (t
  683.        (format t "~&Top of stack.")))))
  684.   
  685. (def-debug-command "DOWN" ()
  686.   (let ((next (di:frame-down *current-frame*)))
  687.     (cond (next
  688.        (setf *current-code-location* nil)
  689.        (setf *current-frame* next)
  690.        (print-frame-call next))
  691.       (t
  692.        (format t "~&Bottom of stack.")))))
  693.  
  694. (def-debug-command-alias "D" "DOWN")
  695.  
  696. (def-debug-command "TOP" ()
  697.   (do ((prev *current-frame* lead)
  698.        (lead (di:frame-up *current-frame*) (di:frame-up lead)))
  699.       ((null lead)
  700.        (setf *current-code-location* nil)
  701.        (setf *current-frame* prev)
  702.        (print-frame-call prev))))
  703.  
  704. (def-debug-command "BOTTOM" ()
  705.   (do ((prev *current-frame* lead)
  706.        (lead (di:frame-down *current-frame*) (di:frame-down lead)))
  707.       ((null lead)
  708.        (setf *current-code-location* nil)
  709.        (setf *current-frame* prev)
  710.        (print-frame-call prev))))
  711.  
  712.  
  713. (def-debug-command-alias "B" "BOTTOM")
  714.  
  715. (def-debug-command "FRAME" (&optional
  716.                 (n (read-prompting-maybe "Frame number: ")))
  717.   (let ((current (di:frame-number *current-frame*)))
  718.     (setf *current-code-location* nil)
  719.     (cond ((= n current)
  720.        (princ "You are here."))
  721.       ((> n current)
  722.        (print-frame-call
  723.         (setf *current-frame*
  724.           (do ((prev *current-frame* lead)
  725.                (lead (di:frame-down *current-frame*)
  726.                  (di:frame-down lead)))
  727.               ((null lead)
  728.                (princ "Bottom of stack encountered.")
  729.                prev)
  730.             (when (= n (di:frame-number prev))
  731.               (return prev))))))
  732.       (t
  733.        (print-frame-call
  734.         (setf *current-frame*
  735.           (do ((prev *current-frame* lead)
  736.                (lead (di:frame-up *current-frame*)
  737.                  (di:frame-up lead)))
  738.               ((null lead)
  739.                (princ "Top of stack encountered.")
  740.                prev)
  741.             (when (= n (di:frame-number prev))
  742.               (return prev)))))))))
  743.  
  744. (def-debug-command-alias "F" "FRAME")
  745.  
  746. ;;;
  747. ;;; In and Out commands.
  748. ;;;
  749.  
  750. (def-debug-command "QUIT" ()
  751.   (throw 'lisp::top-level-catcher nil))
  752.  
  753. (def-debug-command "GO" ()
  754.   (continue)
  755.   (error "No restart named continue."))
  756.  
  757. (def-debug-command "RESTART" ()
  758.   (let ((num (read-if-available :prompt)))
  759.     (when (eq num :prompt)
  760.       (show-restarts *debug-restarts*)
  761.       (write-string "Restart: ")
  762.       (force-output)
  763.       (setf num (read *standard-input*)))
  764.     (let ((restart (typecase num
  765.              (unsigned-byte
  766.               (nth num *debug-restarts*))
  767.              (symbol
  768.               (find num *debug-restarts* :key #'restart-name
  769.                 :test #'(lambda (sym1 sym2)
  770.                       (string= (symbol-name sym1)
  771.                            (symbol-name sym2)))))
  772.              (t
  773.               (format t "~S is invalid as a restart name.~%" num)
  774.               (return-from restart-debug-command nil)))))
  775.       (if restart
  776.       (invoke-restart-interactively restart)
  777.       (princ "No such restart.")))))
  778.  
  779. ;;;
  780. ;;; Information commands.
  781. ;;;
  782.  
  783. (defvar *help-line-scroll-count* 20
  784.   "This controls how many lines the debugger's help command prints before
  785.    printing a prompting line to continue with output.")
  786.  
  787. (def-debug-command "HELP" ()
  788.   (let* ((end -1)
  789.      (len (length debug-help-string))
  790.      (len-1 (1- len)))
  791.     (loop
  792.       (let ((start (1+ end))
  793.         (count *help-line-scroll-count*))
  794.     (loop
  795.       (setf end (position #\newline debug-help-string :start (1+ end)))
  796.       (cond ((or (not end) (= end len-1))
  797.          (setf end len)
  798.          (return))
  799.         ((or (zerop (decf count)) (= end len))
  800.          (return))))
  801.     (write-string debug-help-string *standard-output*
  802.               :start start :end end))
  803.       (when (= end len) (return))
  804.       (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ")
  805.       (force-output)
  806.       (let ((res (read-line)))
  807.     (when (or (string= res "q") (string= res "Q"))
  808.       (return))))))
  809.  
  810. (def-debug-command-alias "?" "HELP")
  811.  
  812. (def-debug-command "ERROR" ()
  813.   (format t "~A~%" *debug-condition*)
  814.   (show-restarts *debug-restarts*))
  815.  
  816. (def-debug-command "BACKTRACE" ()
  817.   (backtrace (read-if-available most-positive-fixnum)))
  818.  
  819. (def-debug-command "PRINT" ()
  820.   (print-frame-call *current-frame*))
  821.  
  822. (def-debug-command-alias "P" "PRINT")
  823.  
  824. (def-debug-command "VPRINT" ()
  825.   (print-frame-call *current-frame* nil nil))
  826.  
  827. (def-debug-command-alias "PP" "VPRINT")
  828.  
  829. (def-debug-command "LIST-LOCALS" ()
  830.   (let ((d-fun (di:frame-debug-function *current-frame*)))
  831.     (if (di:debug-variable-info-available d-fun)
  832.     (let ((*print-level* (or *debug-print-level* *print-level*))
  833.           (*print-length* (or *debug-print-length* *print-level*))
  834.           (*standard-output* *debug-io*)
  835.           (location (di:frame-code-location *current-frame*))
  836.           (prefix (read-if-available nil))
  837.           (any-p nil)
  838.           (any-valid-p nil))
  839.       (dolist (v (di:ambiguous-debug-variables
  840.             d-fun
  841.             (if prefix (string prefix) "")))
  842.         (setf any-p t)
  843.         (when (eq (di:debug-variable-validity v location) :valid)
  844.           (setf any-valid-p t)
  845.           (format t "~A~:[#~D~;~*~]  =  ~S~%"
  846.               (di:debug-variable-name v)
  847.               (zerop (di:debug-variable-id v))
  848.               (di:debug-variable-id v)
  849.               (di:debug-variable-value v *current-frame*))))
  850.  
  851.       (cond
  852.        ((not any-p)
  853.         (format t "No local variables ~@[starting with ~A ~]~
  854.                    in function."
  855.             prefix))
  856.        ((not any-valid-p)
  857.         (format t "All variables ~@[starting with ~A ~]currently ~
  858.                    have invalid values."
  859.             prefix))))
  860.     (write-line "No variable information available."))))
  861.  
  862. (def-debug-command "SOURCE" ()
  863.   (print-code-location-source-form (or *current-code-location*
  864.                        (di:frame-code-location
  865.                     *current-frame*))
  866.                    (read-if-available 0)))
  867.  
  868. (def-debug-command "VSOURCE" ()
  869.   (print-code-location-source-form (or *current-code-location*
  870.                        (di:frame-code-location
  871.                     *current-frame*))
  872.                    (read-if-available 0)
  873.                    t))
  874.  
  875. ;;; PRINT-CODE-LOCATION-SOURCE-FORM -- Internal.
  876. ;;;
  877. (defun print-code-location-source-form (code-loc context &optional verbose)
  878.   (let* ((location (maybe-block-start-location code-loc))
  879.      (d-source (di:code-location-debug-source location))
  880.      (name (di:debug-source-name d-source)))
  881.     (ecase (di:debug-source-from d-source)
  882.       (:file
  883.        (print-frame-source-from-file context verbose location d-source name))
  884.       ((:lisp :stream)
  885.        (let ((tlf (di:code-location-top-level-form-offset location)))
  886.      (print-frame-source
  887.       (svref name tlf)
  888.       tlf
  889.       location context verbose))))))
  890.  
  891. ;;; MAYBE-BLOCK-START-LOCATION  --  Internal.
  892. ;;;
  893. ;;; If Loc is an unknown location, then try to find the block start location.
  894. ;;; PRINT-FRAME-SOURCE-FORM uses this to show some source form; since loc
  895. ;;; is unknown, we provide some information instead of none for the user.
  896. ;;;
  897. (defun maybe-block-start-location (loc)
  898.   (if (di:code-location-unknown-p loc)
  899.       (let* ((block (di:code-location-debug-block loc))
  900.          (start (di:do-debug-block-locations (loc block)
  901.               (return loc))))
  902.     (cond ((and (not (di:debug-block-elsewhere-p block))
  903.             start)
  904.            (format t "~%Unknown location: using block start.~%")
  905.            start)
  906.           (t
  907.            loc)))
  908.       loc))
  909.  
  910. ;;; PRINT-FRAME-SOURCE-FROM-FILE -- Internal.
  911. ;;;
  912. ;;; This does the work of PRINT-FRAME-SOURCE-FORM when the source is a file.
  913. ;;; It takes care of the source no longer existing or someone having modified
  914. ;;; it since the system read the source.
  915. ;;;
  916. (defun print-frame-source-from-file (context verbose location d-source name)
  917.   (cond ((not (probe-file name))
  918.      (format t "~%Source file no longer exists:~%  ~A."
  919.          (namestring name)))
  920.     (t
  921.      (let* ((tlf-offset (di:code-location-top-level-form-offset location))
  922.         (local-tlf-offset (- tlf-offset
  923.                      (di:debug-source-root-number d-source)))
  924.         (char-offset (aref (or (di:debug-source-start-positions d-source)
  925.                        (error "No start positions map."))
  926.                    local-tlf-offset)))
  927.        (with-open-file (f name)
  928.          (cond
  929.           ((= (di:debug-source-created d-source)
  930.           (file-write-date name))
  931.            (file-position f char-offset))
  932.           (t
  933.            (format t "~%File has been modified since compilation:~%  ~A~@
  934.               Using form offset instead of character position.~%"
  935.                (namestring name))
  936.            (let ((*read-suppress* t))
  937.          (dotimes (i local-tlf-offset)
  938.            (read f)))))
  939.          (format t "~%File: ~A~%" (namestring name))
  940.          (print-frame-source (read f) tlf-offset location context
  941.                  verbose))))))
  942.  
  943. ;;; PRINT-FRAME-SOURCE -- Internal.
  944. ;;;
  945. (defun print-frame-source (tlf tlf-offset location context verbose)
  946.   (let ((*print-level* (if verbose
  947.                nil
  948.                (or *debug-print-level* *print-level*)))
  949.     (*print-length* (if verbose
  950.                 nil
  951.                 (or *debug-print-length* *print-length*))))
  952.     (print (di:source-path-context
  953.         tlf
  954.         (svref (di:form-number-translations tlf tlf-offset)
  955.            (di:code-location-form-number location))
  956.         context))))
  957.  
  958. ;;;
  959. ;;; Miscellaneous commands.
  960. ;;;
  961.  
  962. (def-debug-command "FLUSH-ERRORS" ()
  963.   (if (setf *flush-debug-errors* (not *flush-debug-errors*))
  964.       (write-line "Errors now flushed.")
  965.       (write-line "Errors now create nested debug levels.")))
  966.  
  967.  
  968. (def-debug-command "DESCRIBE" ()
  969.   (let* ((curloc (or *current-code-location*
  970.              (di:frame-code-location *current-frame*)))
  971.      (debug-fun (di:code-location-debug-function curloc))
  972.      (function (di:debug-function-function debug-fun)))
  973.     (if function
  974.     (describe function)
  975.     (format t "Can't figure out the function for this frame."))))
  976.  
  977.  
  978. ;;;
  979. ;;; Editor commands.
  980. ;;;
  981.  
  982. (def-debug-command "EDIT-SOURCE" ()
  983.   (unless (typep *terminal-io* 'ed::ts-stream)
  984.     (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~
  985.         connected to a Hemlock editor."))
  986.   (let* ((wire (ed::ts-stream-wire *terminal-io*))
  987.      (location (maybe-block-start-location
  988.             (or *current-code-location*
  989.             (di:frame-code-location *current-frame*))))
  990.      (d-source (di:code-location-debug-source location))
  991.      (name (di:debug-source-name d-source)))
  992.     (ecase (di:debug-source-from d-source)
  993.       (:file
  994.        (let* ((tlf-offset (di:code-location-top-level-form-offset location))
  995.           (local-tlf-offset (- tlf-offset
  996.                    (di:debug-source-root-number d-source)))
  997.           (char-offset (aref (or (di:debug-source-start-positions d-source)
  998.                      (error "No start positions map."))
  999.                  local-tlf-offset)))
  1000.      (wire:remote wire
  1001.        (ed::edit-source-location (namestring name)
  1002.                      (di:debug-source-created d-source)
  1003.                      tlf-offset local-tlf-offset char-offset
  1004.                      (di:code-location-form-number location)))
  1005.      (wire:wire-force-output wire)))
  1006.       ((:lisp :stream)
  1007.        (wire:remote wire
  1008.      (ed::cannot-edit-source-location))
  1009.        (wire:wire-force-output wire)))))
  1010.  
  1011.  
  1012.  
  1013. ;;;; Debug loop command utilities.
  1014.  
  1015. (defun read-prompting-maybe (prompt &optional (in *standard-input*)
  1016.                     (out *standard-output*))
  1017.   (unless (ext:listen-skip-whitespace in)
  1018.     (princ prompt out)
  1019.     (force-output out))
  1020.   (read in))
  1021.  
  1022. (defun read-if-available (default &optional (stream *standard-input*))
  1023.   (if (ext:listen-skip-whitespace stream)
  1024.       (read stream)
  1025.       default))
  1026.