- (setf *number-of-steps* (read-if-available 1))
- (set-step-breakpoint *current-frame*)
- (continue *debug-condition*)
- (error "couldn't continue"))
-
-;;; List possible breakpoint locations, which ones are active, and
-;;; where the CONTINUE restart will transfer control. Set
-;;; *POSSIBLE-BREAKPOINTS* to the code-locations which can then be
-;;; used by sbreakpoint.
-(!def-debug-command "LIST-LOCATIONS" ()
- (let ((df (read-if-available *default-breakpoint-debug-fun*)))
- (cond ((consp df)
- (setf df (sb!di:fun-debug-fun (eval df)))
- (setf *default-breakpoint-debug-fun* df))
- ((or (eq ':c df)
- (not *default-breakpoint-debug-fun*))
- (setf df (sb!di:frame-debug-fun *current-frame*))
- (setf *default-breakpoint-debug-fun* df)))
- (setf *possible-breakpoints* (possible-breakpoints df)))
- (let ((continue-at (sb!di:frame-code-location *current-frame*)))
- (let ((active (location-in-list *default-breakpoint-debug-fun*
- *breakpoints* :fun-start))
- (here (sb!di:code-location=
- (sb!di:debug-fun-start-location
- *default-breakpoint-debug-fun*) continue-at)))
- (when (or active here)
- (format t "::FUN-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 "~&~W: " prev-num)
- (format t "~&~W-~W: " prev-num this-num)))
- (print-code-location-source-form prev-location 0)
- (when *print-location-kind*
- (format t "~S " (sb!di:code-location-kind prev-location)))
- (when (location-in-list prev-location *breakpoints*)
- (format t " *Active*"))
- (when (sb!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*)
- (sb!di:code-location= code-location continue-at)
- (not prev-location)
- (not (eq (sb!di:code-location-debug-source code-location)
- (sb!di:code-location-debug-source prev-location)))
- (not (eq (sb!di:code-location-toplevel-form-offset
- code-location)
- (sb!di:code-location-toplevel-form-offset
- prev-location)))
- (not (eq (sb!di:code-location-form-number code-location)
- (sb!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-fun*
- *breakpoints*
- :fun-end)
- (format t "~&::FUN-END *Active* "))))
-
-(!def-debug-command-alias "LL" "LIST-LOCATIONS")
-
-;;; Set breakpoint at the given number.
-(!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-fun*))
- (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-fun*
- (sb!di:fun-debug-fun function))
- (setf place *default-breakpoint-debug-fun*)
- (setf *possible-breakpoints*
- (possible-breakpoints
- *default-breakpoint-debug-fun*))))))
- (setup-fun-start ()
- (let ((code-loc (sb!di:debug-fun-start-location place)))
- (setf bp (sb!di:make-breakpoint #'main-hook-fun
- place
- :kind :fun-start))
- (setf break (sb!di:preprocess-for-eval break code-loc))
- (setf condition (sb!di:preprocess-for-eval condition code-loc))
- (dolist (form print)
- (push (cons (sb!di:preprocess-for-eval form code-loc) form)
- print-functions))))
- (setup-fun-end ()
- (setf bp
- (sb!di:make-breakpoint #'main-hook-fun
- place
- :kind :fun-end))
- (setf break
- ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
- ;; forms should be converted to shiny new (LAMBDA ..) forms.
- ;; (Search the sources for "coerce.*\(lambda".)
- (coerce `(lambda (dummy)
- (declare (ignore dummy)) ,break)
- 'function))
- (setf condition (coerce `(lambda (dummy)
- (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 (sb!di:make-breakpoint #'main-hook-fun place
- :kind :code-location))
- (dolist (form print)
- (push (cons
- (sb!di:preprocess-for-eval form place)
- form)
- print-functions))
- (setf break (sb!di:preprocess-for-eval break place))
- (setf condition (sb!di:preprocess-for-eval condition place))))
- (set-vars-from-command-line (get-command-line))
- (cond
- ((or (eq index :start) (eq index :s))
- (setup-fun-start))
- ((or (eq index :end) (eq index :e))
- (setup-fun-end))
- (t
- (setup-code-location)))
- (sb!di:activate-breakpoint bp)
- (let* ((new-bp-info (create-breakpoint-info place bp index
- :break break
- :print print-functions
- :condition condition))
- (old-bp-info (location-in-list new-bp-info *breakpoints*)))
- (when old-bp-info
- (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
- old-bp-info))
- (setf *breakpoints* (remove old-bp-info *breakpoints*))
- (format t "previous breakpoint removed~%"))
- (push new-bp-info *breakpoints*))
- (print-breakpoint-info (first *breakpoints*))
- (format t "~&added"))))
-
-(!def-debug-command-alias "BP" "BREAKPOINT")
-
-;;; List all breakpoints which are set.
-(!def-debug-command "LIST-BREAKPOINTS" ()
- (setf *breakpoints*
- (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 remove all breakpoints if no N 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
- (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
- (setf *breakpoints* (remove bp-info *breakpoints*))
- (format t "breakpoint ~S removed~%" index))
- (index (format t "The breakpoint doesn't exist."))
projects / sbcl.git / blobdiff