Skip to content
Snippets Groups Projects
debug.lisp 60.2 KiB
Newer Older
   id values.

   The result of this function is limited to the availability of variable
   information.  This is SETF'able."
  (define-var-operation :ref))
;;;
(defun (setf var) (value name &optional (id 0 id-supplied))
  (define-var-operation :set value))


ram's avatar
ram committed

;;; ARG -- Public.
;;;
(defun arg (n)
  "Returns the n'th argument's value if possible.  Argument zero is the first
   argument in a frame's default printed representation.  Count keyword/value
   pairs as separate arguments."
  (multiple-value-bind
      (var lambda-var-p)
      (nth-arg n (handler-case (di:debug-function-lambda-list
				(di:frame-debug-function *current-frame*))
		   (di:lambda-list-unavailable ()
		     (error "No argument values are available."))))
    (if lambda-var-p
	(lambda-var-dispatch var (di:frame-code-location *current-frame*)
	  (error "Unused arguments have no values.")
ram's avatar
ram committed
	  (di:debug-variable-value var *current-frame*)
	  (error "Invalid argument value."))
ram's avatar
ram committed
	var)))
ram's avatar
ram committed

;;; NTH-ARG -- Internal.
;;;
;;; This returns the n'th arg as the user sees it from args, the result of
chiles's avatar
 
chiles committed
;;; DI:DEBUG-FUNCTION-LAMBDA-LIST.  If this returns a potential debug-variable
;;; from the lambda-list, then the second value is t.  If this returns a
;;; keyword symbol or a value from a rest arg, then the second value is nil.
;;;
(defun nth-arg (count args)
  (let ((n count))
ram's avatar
ram committed
    (dolist (ele args (error "Argument specification out of range -- ~S." n))
      (lambda-list-element-dispatch ele
chiles's avatar
 
chiles committed
	:required ((if (zerop n) (return (values ele t))))
	:optional ((if (zerop n) (return (values (second ele) t))))
	:keyword ((cond ((zerop n)
			 (return (values (second ele) nil)))
chiles's avatar
 
chiles committed
			((zerop (decf n))
			 (return (values (third ele) t)))))
	:deleted ((if (zerop n) (return (values ele t))))
	:rest ((let ((var (second ele)))
		 (lambda-var-dispatch var
ram's avatar
ram committed
				      (di:frame-code-location *current-frame*)
		   (error "Unused rest-arg before n'th argument.")
chiles's avatar
 
chiles committed
		   (dolist (value
			    (di:debug-variable-value var *current-frame*)
			    (error "Argument specification out of range -- ~S."
				   n))
		     (if (zerop n)
			 (return-from nth-arg (values value nil))
			 (decf n)))
		   (error "Invalid rest-arg before n'th argument.")))))
      (decf n))))



;;;; Debug loop command definition:

(defvar *debug-commands* nil)

;;; DEF-DEBUG-COMMAND -- Internal.
;;;
;;; Interface to *debug-commands*.  No required arguments in args are
;;; permitted.
;;;
(defmacro def-debug-command (name args &rest body)
  (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
chiles's avatar
 
chiles committed
    `(progn
       (when (assoc ,name *debug-commands* :test #'string=)
	 (setf *debug-commands*
	       (remove ,name *debug-commands* :key #'car :test #'string=)))
       (defun ,fun-name ,args
	 (unless *in-the-debugger*
	   (error "Invoking debugger command while outside the debugger."))
	 ,@body)
       (push (cons ,name #',fun-name) *debug-commands*)
       ',fun-name)))

;;; DEF-DEBUG-COMMAND-ALIAS -- Internal.
;;;
(defun def-debug-command-alias (new-name existing-name)
  (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
    (unless pair (error "Unknown debug command name -- ~S" existing-name))
    (push (cons new-name (cdr pair)) *debug-commands*))
  new-name)

chiles's avatar
 
chiles committed
;;; DEBUG-COMMAND-P -- Internal.
;;;
;;; This takes a symbol and uses its name to find a debugger command, using
;;; initial substring matching.  It returns the command function if form
;;; identifies only one command, but if form is ambiguous, this returns a list
;;; of the command names.  If there are no matches, this returns nil.  Whenever
;;; the loop that looks for a set of possibilities encounters an exact name
;;; match, we return that command function immediately.
;;;
ram's avatar
ram committed
(defun debug-command-p (form &optional other-commands)
  (if (or (symbolp form) (integerp form))
	      (if (symbolp form)
		  (symbol-name form)
		  (format nil "~d" form)))
	     (len (length name))
	     (res nil))
	(declare (simple-string name)
		 (fixnum len)
		 (list res))
	;;
	;; Find matching commands, punting if exact match.
	(flet ((match-command (ele)
	         (let* ((str (car ele))
			(str-len (length str)))
		   (declare (simple-string str)
			    (fixnum str-len))
		   (cond ((< str-len len))
			 ((= str-len len)
			  (when (string= name str :end1 len :end2 len)
			    (return-from debug-command-p (cdr ele))))
			 ((string= name str :end1 len :end2 len)
			  (push ele res))))))
	  (mapc #'match-command *debug-commands*)
	  (mapc #'match-command other-commands))
	;;
ram's avatar
ram committed
	;; Return the right value.
chiles's avatar
 
chiles committed
	(cond ((not res) nil)
	       (cdar res))
	      (t ;Just return the names.
	       (do ((cmds res (cdr cmds)))
		   ((not cmds) res)
		 (setf (car cmds) (caar cmds))))))))

chiles's avatar
 
chiles committed
;;;
;;; Returns a list of debug commands (in the same format as *debug-commands*)
;;; that invoke each active restart.
;;;
;;; Two commands are made for each restart: one for the number, and one for
;;; the restart name (unless it's been shadowed by an earlier restart of the
ram's avatar
ram committed
(defun make-restart-commands (&optional (restarts *debug-restarts*))
  (let ((commands)
	(num 0))			; better be the same as show-restarts!
chiles's avatar
 
chiles committed
    (dolist (restart restarts)
      (let ((name (string (restart-name restart))))
	;;
	;; Use %Invoke-Restart-Interactively because the dynamic
	;; environment when the debugger invokes the restart can be
	;; different from the dynamic environment when the debugger
	;; computes active restarts.  If this is the case,
	;; Invoke-Restart-Interactively might find that the restart
	;; being invoked is not currently active and signal a
	;; Control-Error.
	       (lambda ()
		 (conditions::%invoke-restart-interactively restart))))
	  (push (cons (format nil "~d" num) restart-fun) commands)
	  (unless (or (null (restart-name restart)) 
	              (find name commands :key #'car :test #'string=))
	    (push (cons name restart-fun) commands))))
chiles's avatar
 
chiles committed
      (incf num))

;;;
;;; Frame changing commands.
;;;

(def-debug-command "UP" ()
chiles's avatar
 
chiles committed
  (let ((next (di:frame-up *current-frame*)))
    (cond (next
	   (setf *current-frame* next)
	   (print-frame-call next))
	  (t
	   (format t "~&Top of stack.")))))
  
(def-debug-command "DOWN" ()
  (let ((next (di:frame-down *current-frame*)))
    (cond (next
	   (setf *current-frame* next)
	   (print-frame-call next))
	  (t
	   (format t "~&Bottom of stack.")))))

(def-debug-command-alias "D" "DOWN")

(def-debug-command "TOP" ()
  (do ((prev *current-frame* lead)
       (lead (di:frame-up *current-frame*) (di:frame-up lead)))
      ((null lead)
       (setf *current-frame* prev)
       (print-frame-call prev))))

(def-debug-command "BOTTOM" ()
  (do ((prev *current-frame* lead)
       (lead (di:frame-down *current-frame*) (di:frame-down lead)))
      ((null lead)
       (setf *current-frame* prev)
       (print-frame-call prev))))

chiles's avatar
 
chiles committed
(def-debug-command-alias "B" "BOTTOM")

ram's avatar
ram committed
(def-debug-command "FRAME" (&optional
			    (n (read-prompting-maybe "Frame number: ")))
  (let ((current (di:frame-number *current-frame*)))
chiles's avatar
 
chiles committed
    (cond ((= n current)
ram's avatar
ram committed
	   (princ "You are here."))
	  ((> n current)
chiles's avatar
 
chiles committed
	   (print-frame-call
ram's avatar
ram committed
	    (setf *current-frame*
		  (do ((prev *current-frame* lead)
		       (lead (di:frame-down *current-frame*)
chiles's avatar
 
chiles committed
			     (di:frame-down lead)))
ram's avatar
ram committed
		      ((null lead)
		       (princ "Bottom of stack encountered.")
		       prev)
		    (when (= n (di:frame-number prev))
ram's avatar
ram committed
	  (t
	   (print-frame-call
	    (setf *current-frame*
		  (do ((prev *current-frame* lead)
		       (lead (di:frame-up *current-frame*)
			     (di:frame-up lead)))
		      ((null lead)
		       (princ "Top of stack encountered.")
		       prev)
		    (when (= n (di:frame-number prev))
		      (return prev)))))))))

(def-debug-command-alias "F" "FRAME")


ram's avatar
ram committed
;;;
ram's avatar
ram committed
;;;
chiles's avatar
 
chiles committed
  (throw 'lisp::top-level-catcher nil))

(def-debug-command "GO" ()
  (continue *debug-condition*)
chiles's avatar
 
chiles committed
  (error "No restart named continue."))

(def-debug-command "RESTART" ()
  (let ((num (read-if-available :prompt)))
    (when (eq num :prompt)
      (show-restarts *debug-restarts*)
      (write-string "Restart: ")
      (force-output)
      (setf num (read *standard-input*)))
    (let ((restart (typecase num
		     (unsigned-byte
		      (nth num *debug-restarts*))
		     (symbol
		      (find num *debug-restarts* :key #'restart-name
			    :test #'(lambda (sym1 sym2)
				      (string= (symbol-name sym1)
					       (symbol-name sym2)))))
chiles's avatar
 
chiles committed
		     (t
		      (format t "~S is invalid as a restart name.~%" num)
		      (return-from restart-debug-command nil)))))
      (if restart
	  (invoke-restart-interactively restart)
ram's avatar
ram committed
	  (princ "No such restart.")))))
chiles's avatar
 
chiles committed


;;;
ram's avatar
ram committed
;;; Information commands.
;;;
 
chiles's avatar
 
chiles committed
(defvar *help-line-scroll-count* 20
  "This controls how many lines the debugger's help command prints before
ram's avatar
ram committed
   printing a prompting line to continue with output.")
chiles's avatar
 
chiles committed

(def-debug-command "HELP" ()
ram's avatar
ram committed
  (let* ((end -1)
chiles's avatar
 
chiles committed
	 (len (length debug-help-string))
	 (len-1 (1- len)))
    (loop
	    (count *help-line-scroll-count*))
chiles's avatar
 
chiles committed
	(loop
	  (setf end (position #\newline debug-help-string :start (1+ end)))
	  (cond ((or (not end) (= end len-1))
		((or (zerop (decf count)) (= end len))
		 (return))))
	(write-string debug-help-string *standard-output*
		      :start start :end end))
      (when (= end len) (return))
      (format t "~%[RETURN FOR MORE, Q TO QUIT HELP TEXT]: ")
      (force-output)
      (let ((res (read-line)))
	(when (or (string= res "q") (string= res "Q"))
	  (return))))))

(def-debug-command-alias "?" "HELP")

(def-debug-command "ERROR" ()
  (format t "~A~%" (safe-condition-message *debug-condition*))
  (show-restarts *debug-restarts*))

(def-debug-command "BACKTRACE" ()
  (backtrace (read-if-available most-positive-fixnum)))

(def-debug-command "PRINT" ()
  (print-frame-call *current-frame*))

(def-debug-command-alias "P" "PRINT")

chiles's avatar
 
chiles committed
(def-debug-command "VPRINT" ()
  (print-frame-call *current-frame* :print-level nil :print-length nil
		    :verbosity (read-if-available 2)))
(def-debug-command-alias "PP" "VPRINT")
chiles's avatar
 
chiles committed

(def-debug-command "LIST-LOCALS" ()
  (let ((d-fun (di:frame-debug-function *current-frame*)))
    (if (di:debug-variable-info-available d-fun)
	(let ((*print-level* (or *debug-print-level* *print-level*))
	      (*print-length* (or *debug-print-length* *print-length*))
chiles's avatar
 
chiles committed
	      (*standard-output* *debug-io*)
	      (location (di:frame-code-location *current-frame*))
	      (prefix (read-if-available nil))
	      (any-p nil)
	      (any-valid-p nil))
	  (dolist (v (di:ambiguous-debug-variables
ram's avatar
ram committed
			d-fun
			(if prefix (string prefix) "")))
	    (when (eq (di:debug-variable-validity v location) :valid)
	      (setf any-valid-p t)
	      (format t "~S~:[#~D~;~*~]  =  ~S~%"
		      (di:debug-variable-symbol v)
		      (zerop (di:debug-variable-id v))
		      (di:debug-variable-id v)
		      (di:debug-variable-value v *current-frame*))))

	  (cond
	   ((not any-p)
	    (format t "No local variables ~@[starting with ~A ~]~
	               in function."
		    prefix))
	    (format t "All variables ~@[starting with ~A ~]currently ~
	               have invalid values."
		    prefix))))
	(write-line "No variable information available."))))

(def-debug-command-alias "L" "LIST-LOCALS")

(def-debug-command "SOURCE" ()
  (fresh-line)
  (print-code-location-source-form (di:frame-code-location *current-frame*)
				   (read-if-available 0)))

(def-debug-command "VSOURCE" ()
  (fresh-line)
  (print-code-location-source-form (di:frame-code-location *current-frame*)
				   (read-if-available 0)
				   t))


;;;; Source location printing:

;;; We cache a stream to the last valid file debug source so that we won't have
;;; to repeatedly open the file.
;;;
(defvar *cached-debug-source* nil)
(declaim (type (or di:debug-source null) *cached-debug-source*))
(defvar *cached-source-stream* nil)
(declaim (type (or stream null) *cached-source-stream*))

;;; To suppress the read-time evaluation #. macro during source read
;;; the *readtable* is modified. The *readtable* is cached to avoid
;;; copying it each time, and invalidated when the
;;; *cached-debug-source* has changed.
(defvar *cached-readtable* nil)
(declaim (type (or readtable null) *cached-readtable*))

	     (setq *cached-debug-source* nil *cached-source-stream* nil
		   *cached-readtable* nil))
chiles's avatar
 
chiles committed
	 ext:*before-save-initializations*)

chiles's avatar
 
chiles committed

;;; We also cache the last top-level form that we printed a source for so that
chiles's avatar
 
chiles committed
;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
;;;
(defvar *cached-top-level-form-offset* nil)
(declaim (type (or kernel:index null) *cached-top-level-form-offset*))
(defvar *cached-top-level-form*)
(defvar *cached-form-number-translations*)


;;; GET-TOP-LEVEL-FORM  --  Internal
;;;
;;;    Given a code location, return the associated form-number translations
;;; and the actual top-level form.  We check our cache --- if there is a miss,
;;; we dispatch on the kind of the debug source.
;;;
(defun get-top-level-form (location)
  (let ((d-source (di:code-location-debug-source location)))
    (if (and (eq d-source *cached-debug-source*)
	     (eql (di:code-location-top-level-form-offset location)
		  *cached-top-level-form-offset*))
	(values *cached-form-number-translations* *cached-top-level-form*)
chiles's avatar
 
chiles committed
	(let* ((offset (di:code-location-top-level-form-offset location))
	       (res
		(ecase (di:debug-source-from d-source)
		  (:file (get-file-top-level-form location))
		  ((:lisp :stream)
		   (svref (di:debug-source-name d-source) offset)))))
	  (setq *cached-top-level-form-offset* offset)
	  (values (setq *cached-form-number-translations*
chiles's avatar
 
chiles committed
			(di:form-number-translations res offset))
		  (setq *cached-top-level-form* res))))))


;;; GET-FILE-TOP-LEVEL-FORM -- Internal.
;;;
;;; Locates the source file (if it still exists) and grabs the top-level form.
;;; If the file is modified, we use the top-level-form offset instead of the
;;; recorded character offset.
;;;
(defun get-file-top-level-form (location)
  (let* ((d-source (di:code-location-debug-source location))
	 (tlf-offset (di:code-location-top-level-form-offset location))
	 (local-tlf-offset (- tlf-offset
			      (di:debug-source-root-number d-source)))
	 (char-offset
	  (aref (or (di:debug-source-start-positions d-source)
		    (error "No start positions map."))
		local-tlf-offset))
	 (name (di:debug-source-name d-source)))
    (unless (eq d-source *cached-debug-source*)
      (unless (and *cached-source-stream*
		   (equal (pathname *cached-source-stream*)
			  (pathname name)))
	(setq *cached-readtable* nil)
	(when *cached-source-stream* (close *cached-source-stream*))
	(setq *cached-source-stream* (open name :if-does-not-exist nil))
	(unless *cached-source-stream*
	  (error "Source file no longer exists:~%  ~A." (namestring name)))
	(format t "~%; File: ~A~%" (namestring name)))

	(setq *cached-debug-source*
	      (if (= (di:debug-source-created d-source) (file-write-date name))
		  d-source nil)))

    (cond
     ((eq *cached-debug-source* d-source)
      (file-position *cached-source-stream* char-offset))
     (t
      (format t "~%; File has been modified since compilation:~%;   ~A~@
		 ; Using form offset instead of character position.~%"
	      (namestring name))
      (file-position *cached-source-stream* 0)
      (let ((*read-suppress* t))
	(dotimes (i local-tlf-offset)
	  (read *cached-source-stream*)))))
    (unless *cached-readtable*
      (setq *cached-readtable* (copy-readtable))
      (set-dispatch-macro-character
       #\# #\.
       #'(lambda (stream sub-char &rest rest)
	   (declare (ignore rest sub-char))
	   (let ((token (read stream t nil t)))
	     (format nil "#.~s" token)))
       *cached-readtable*))
    (let ((*readtable* *cached-readtable*))
      (read *cached-source-stream*))))


;;; PRINT-CODE-LOCATION-SOURCE-FORM -- Internal.
;;;
(defun print-code-location-source-form (location context &optional verbose)
  (let* ((location (maybe-block-start-location location))
	 (*print-level* (if verbose
			    nil
			    (or *debug-print-level* *print-level*)))
	 (*print-length* (if verbose
			     nil
			     (or *debug-print-length* *print-length*)))
	 (form-num (di:code-location-form-number location)))
    (multiple-value-bind (translations form)
			 (get-top-level-form location)
      (unless (< form-num (length translations))
	(error "Source path no longer exists."))
      (prin1 (di:source-path-context form
				     (svref translations form-num)
				     context)))))


;;;
;;; Breakpoint and step commands.
;;;

;;; Steps to the next code-location
(def-debug-command "STEP" ()
  (setf *number-of-steps* (read-if-available 1))
  (set-step-breakpoint *current-frame*)
  (continue *debug-condition*)
  (error "Couldn't continue."))
  
;;; Lists possible breakpoint locations, which are active, and where go will
;;; continue.  Sets *possible-breakpoints* to the code-locations which can then
;;; be used by sbreakpoint.  Takes a function as an optional argument.
(def-debug-command "LIST-LOCATIONS" ()
  (let ((df (read-if-available *default-breakpoint-debug-function*)))
    (cond ((consp df)
	   (setf df (di:function-debug-function (eval df)))
	   (setf *default-breakpoint-debug-function* df))	  
	  ((or (eq ':c df)
	       (not *default-breakpoint-debug-function*))
	   (setf df (di:frame-debug-function *current-frame*))
	   (setf *default-breakpoint-debug-function* df)))
    (setf *possible-breakpoints* (possible-breakpoints df)))
  (let ((continue-at (di:frame-code-location *current-frame*)))
    (let ((active (location-in-list *default-breakpoint-debug-function*
				    *breakpoints* :function-start))
	  (here (di:code-location=
		 (di:debug-function-start-location
		  *default-breakpoint-debug-function*) continue-at)))
      (when (or active here)
	(format t "::FUNCTION-START ")
	(when active (format t " *Active*"))
	(when here (format t " *Continue here*"))))
    
    (let ((prev-location nil)
	  (prev-num 0)
	  (this-num 0))
      (flet ((flush ()
	       (when prev-location
		 (let ((this-num (1- this-num)))
		   (if (= prev-num this-num)
		       (format t "~&~D: " prev-num)
		       (format t "~&~D-~D: " prev-num this-num)))
		 (print-code-location-source-form prev-location 0)
		 (when *print-location-kind*
		   (format t "~S " (di:code-location-kind prev-location)))
		 (when (location-in-list prev-location *breakpoints*)
		   (format t " *Active*"))
		 (when (di:code-location= prev-location continue-at)
		   (format t " *Continue here*")))))
	
	(dolist (code-location *possible-breakpoints*)
	  (when (or *print-location-kind*
		    (location-in-list code-location *breakpoints*)
		    (di:code-location= code-location continue-at)
		    (not prev-location)
		    (not (eq (di:code-location-debug-source code-location)
			     (di:code-location-debug-source prev-location)))
		    (not (eq (di:code-location-top-level-form-offset
			      code-location)
			     (di:code-location-top-level-form-offset
			      prev-location)))
		    (not (eq (di:code-location-form-number code-location)
			     (di:code-location-form-number prev-location))))
	    (flush)
	    (setq prev-location code-location  prev-num this-num))
	  
	  (incf this-num))))

    (when (location-in-list *default-breakpoint-debug-function* *breakpoints*
			    :function-end)
      (format t "~&::FUNCTION-END *Active* "))))

(def-debug-command-alias "LL" "LIST-LOCATIONS")
    
;;; set breakpoint at # given
(def-debug-command "BREAKPOINT" ()
  (let ((index (read-prompting-maybe "Location number, :start, or :end: "))
	(break t)
	(condition t)
	(print nil)
	(print-functions nil)
	(function nil)
	(bp)
	(place *default-breakpoint-debug-function*))
    (flet ((get-command-line ()
	     (let ((command-line nil)
		   (unique '(nil)))
	       (loop
		 (let ((next-input (read-if-available unique)))
		   (when (eq next-input unique) (return))
		   (push next-input command-line)))
	       (nreverse command-line)))
	   (set-vars-from-command-line (command-line)
	     (do ((arg (pop command-line) (pop command-line)))
		 ((not arg))
	       (ecase arg
		 (:condition (setf condition (pop command-line)))
		 (:print (push (pop command-line) print))
		 (:break (setf break (pop command-line)))
		 (:function
		  (setf function (eval (pop command-line)))
		  (setf *default-breakpoint-debug-function*
			(di:function-debug-function function))
dtc's avatar
dtc committed
                  (setf place *default-breakpoint-debug-function*)
		  (setf *possible-breakpoints*
			(possible-breakpoints
			 *default-breakpoint-debug-function*))))))
	   (setup-function-start ()
ram's avatar
ram committed
	     (let ((code-loc (di:debug-function-start-location place)))
chiles's avatar
 
chiles committed
	       (setf bp (di:make-breakpoint #'main-hook-function place
					    :kind :function-start))
	       (setf break (di:preprocess-for-eval break code-loc))
chiles's avatar
 
chiles committed
	       (setf condition (di:preprocess-for-eval condition code-loc))
chiles's avatar
 
chiles committed
	       (dolist (form print)
		 (push (cons (di:preprocess-for-eval form code-loc) form)
		       print-functions))))
	   (setup-function-end ()
	     (setf bp
		   (di:make-breakpoint #'main-hook-function place
					  :kind :function-end))
	     (setf break
		   (coerce `(lambda (dummy)
				    (declare (ignore dummy)) ,break)
				 'function))
	     (setf condition (coerce `(lambda (dummy)
chiles's avatar
 
chiles committed
					(declare (ignore dummy)) ,condition)
				     'function))
	     (dolist (form print)
	       (push (cons
		      (coerce `(lambda (dummy)
				 (declare (ignore dummy)) ,form) 'function)
		      form)
		     print-functions)))
	   (setup-code-location ()
	     (setf place (nth index *possible-breakpoints*))
	     (setf bp (di:make-breakpoint #'main-hook-function place
					  :kind :code-location))
chiles's avatar
 
chiles committed
	     (dolist (form print)
	       (push (cons
		      (di:preprocess-for-eval form place)
		      form)
		     print-functions))
	     (setf break (di:preprocess-for-eval break place))
	     (setf condition (di:preprocess-for-eval condition place))))
      (set-vars-from-command-line (get-command-line))
      (cond
       ((or (eq index :start) (eq index :s))
	(setup-function-start))
       ((or (eq index :end) (eq index :e))
	(setup-function-end))
       (t
	(setup-code-location)))
      (di:activate-breakpoint bp)
      (let* ((new-bp-info (create-breakpoint-info place bp index
						  :break break
						  :print print-functions
						  :condition condition))
chiles's avatar
 
chiles committed
	     (old-bp-info (location-in-list new-bp-info *breakpoints*)))
ram's avatar
ram committed
	(when old-bp-info
	  (di:deactivate-breakpoint (breakpoint-info-breakpoint old-bp-info))
	  (setf *breakpoints* (remove old-bp-info *breakpoints*))
	  (format t "Note: previous breakpoint removed.~%"))
	(push new-bp-info *breakpoints*))
      (print-breakpoint-info (first *breakpoints*))
      (format t "~&Added."))))

(def-debug-command-alias "BP" "BREAKPOINT")
ram's avatar
ram committed

;;; list all breakpoints set
(def-debug-command "LIST-BREAKPOINTS" ()
ram's avatar
ram committed
	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
  (dolist (info *breakpoints*)
    (print-breakpoint-info info)))

(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")

;;; remove breakpoint n or all if none given
(def-debug-command "DELETE-BREAKPOINT" ()
  (let* ((index (read-if-available nil))
	 (bp-info
	  (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
    (cond (bp-info
	   (di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
	   (setf *breakpoints* (remove bp-info *breakpoints*))
	   (format t "Breakpoint ~S removed.~%" index))
	  (index (format t "Breakpoint doesn't exist."))
	  (t
	   (dolist (ele *breakpoints*)
	     (di:delete-breakpoint (breakpoint-info-breakpoint ele)))
	   (setf *breakpoints* nil)
	   (format t "All breakpoints deleted.~%")))))

(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")


;;;
;;; Miscellaneous commands.
;;;

(def-debug-command "FLUSH-ERRORS" ()
  (if (setf *flush-debug-errors* (not *flush-debug-errors*))
      (write-line "Errors now flushed.")
      (write-line "Errors now create nested debug levels.")))


(def-debug-command "DESCRIBE" ()
  (let* ((curloc (di:frame-code-location *current-frame*))
	 (debug-fun (di:code-location-debug-function curloc))
	 (function (di:debug-function-function debug-fun)))
    (if function
	(describe function)
	(format t "Can't figure out the function for this frame."))))


;;;
;;; Editor commands.
;;;

(def-debug-command "EDIT-SOURCE" ()
  (unless (ed::ts-stream-p *terminal-io*)
ram's avatar
ram committed
    (error "The debugger's EDIT-SOURCE command only works in slave Lisps ~
	    connected to a Hemlock editor."))
  (let* ((wire (ed::ts-stream-wire *terminal-io*))
	 (location (maybe-block-start-location
		    (di:frame-code-location *current-frame*)))
	 (d-source (di:code-location-debug-source location))
	 (name (di:debug-source-name d-source)))
    (ecase (di:debug-source-from d-source)
      (:file
       (let* ((tlf-offset (di:code-location-top-level-form-offset location))
	      (local-tlf-offset (- tlf-offset
				   (di:debug-source-root-number d-source)))
	      (char-offset (aref (or (di:debug-source-start-positions d-source)
				     (error "No start positions map."))
				 local-tlf-offset)))
	 (wire:remote wire
	   (ed::edit-source-location (namestring name)
				     (di:debug-source-created d-source)
				     tlf-offset local-tlf-offset char-offset
				     (di:code-location-form-number location)))
	 (wire:wire-force-output wire)))
      ((:lisp :stream)
       (wire:remote wire
	 (ed::cannot-edit-source-location))
       (wire:wire-force-output wire)))))



;;;; Debug loop command utilities.

(defun read-prompting-maybe (prompt &optional (in *standard-input*)
				    (out *standard-output*))
  (unless (ext:listen-skip-whitespace in)
    (princ prompt out)
    (force-output out))
  (read in))

(defun read-if-available (default &optional (stream *standard-input*))
  (if (ext:listen-skip-whitespace stream)
      (read stream)
      default))