From 10528e9ca5a43245f6a5f1f74648711942b8d959 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Tue, 10 Mar 1992 15:30:04 +0000 Subject: [PATCH] Merged Miles' changes that allow the use of restart names as debugger commands. --- code/debug.lisp | 77 +++++++++++++++++++++++++++++++++---------------- 1 file changed, 52 insertions(+), 25 deletions(-) diff --git a/code/debug.lisp b/code/debug.lisp index 28e8172d0..750031222 100644 --- a/code/debug.lisp +++ b/code/debug.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.27 1992/03/10 15:21:11 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug.lisp,v 1.28 1992/03/10 15:30:04 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -76,15 +76,18 @@ (declaim (type list *possible-breakpoints*)) ;;; A list of the made and active breakpoints, each is a breakpoint-info +;;; structure. ;;; (defvar *breakpoints* nil) (declaim (type list *breakpoints*)) ;;; A list of breakpoint-info structures of the made and active step ;;; breakpoints. - ABORT returns to the previous abort restart case. ;;; (defvar *step-breakpoints* nil) +(declaim (type list *step-breakpoints*)) + +;;; Number of times left to step. ;;; (defvar *number-of-steps* 1) (declaim (type integer *number-of-steps*)) @@ -249,7 +252,6 @@ (verbosity 1) (number nil)) (let ((*print-length* (or *debug-print-length* print-length)) -(defvar *debug-abort*) (*print-level* (or *debug-print-level* print-level))) (cond ((zerop verbosity) @@ -262,7 +264,6 @@ (print-frame-call-1 frame))) (when (>= verbosity 2) (let ((loc (di:frame-code-location frame))) - (*debug-abort* (find-restart 'abort)) (handler-case (progn (di:code-location-debug-block loc) @@ -342,13 +343,15 @@ (invoke-debugger condition)))) (defun internal-debug () (let ((*in-the-debugger* t) - (let ((level *debug-command-level*)) + (*read-suppress* nil)) + (unless (typep *debug-condition* 'step-condition) (clear-input *debug-io*) (format *debug-io* "~2&Debug (type H for help)~2%")) (debug-loop))) - (ext:stream-command-name input)))) + +;;;; Debug-loop. (defvar *flush-debug-errors* t "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while @@ -358,7 +361,7 @@ (let* ((*debug-command-level* (1+ *debug-command-level*)) (*real-stack-top* (di:top-frame)) (*stack-top* (or *stack-top-hint* *real-stack-top*)) - (cmd-fun (debug-command-p exp))) + (*stack-top-hint* nil) (*current-frame* *stack-top*)) (handler-bind ((di:debug-condition #'(lambda (condition) (princ condition *debug-io*) @@ -597,9 +600,12 @@ (defvar *debug-commands* nil) ;;; DEF-DEBUG-COMMAND -- Internal. -(defun debug-command-p (form) - (if (symbolp form) - (let* ((name (symbol-name form)) +;;; +;;; 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")))) `(progn (when (assoc ,name *debug-commands* :test #'string=) (warn "Redefining ~S debugger command." ,name) @@ -607,17 +613,19 @@ (remove ,name *debug-commands* :key #'car :test #'string=))) (defun ,fun-name ,args (unless *in-the-debugger* - (dolist (ele *debug-commands*) - (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))))) + (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) + ;;; DEBUG-COMMAND-P -- Internal. ;;; ;;; This takes a symbol and uses its name to find a debugger command, using @@ -628,7 +636,30 @@ ;;; match, we return that command function immediately. ;;; (defun debug-command-p (form &optional other-commands) + (if (or (symbolp form) (integerp form)) (let* ((name + (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)) ;; ;; Return the right value. @@ -712,10 +743,6 @@ (print-frame-call (setf *current-frame* (do ((prev *current-frame* lead) - -(def-debug-command "ABORT" () - ;; There's always at least one abort restart due to the top-level one. - (invoke-restart *debug-abort*)) (lead (di:frame-down *current-frame*) (di:frame-down lead))) ((null lead) -- GitLab