From 97fa6b64e1c9adc136ae922dfd7fb39946331c3b Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Mon, 23 Apr 1990 16:24:12 +0000
Subject: [PATCH] Merged in stuff from Bill: New functionality DEBUG:ARG and
 DEBUG:VAR, vsource command. Fixes to frame printing and stuff.

---
 code/debug.lisp | 254 +++++++++++++++++++++++++++++++++++-------------
 1 file changed, 187 insertions(+), 67 deletions(-)

diff --git a/code/debug.lisp b/code/debug.lisp
index 6ee94d950..02309b252 100644
--- a/code/debug.lisp
+++ b/code/debug.lisp
@@ -16,7 +16,9 @@
 (in-package "DEBUG")
 
 (export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
-	  *debug-print-level* *debug-print-length* *debug-prompt*))
+	  *debug-print-level* *debug-print-length* *debug-prompt*
+
+	  var arg))
 
 
 (in-package "LISP")
@@ -110,6 +112,30 @@ Functions/macros for your enjoyment:
 	       (bp (di:make-breakpoint #'main-hook-function debug-function
       (print-frame-call frame))))
 	  (di:activate-breakpoint bp)
+	  (push (create-breakpoint-info debug-function bp 0)
+		*step-breakpoints*))))))))
+
+
+
+;;;; Backtrace:
+
+;;; BACKTRACE -- Public.
+;;;
+(defun backtrace (&optional (count most-positive-fixnum)
+			    (*standard-output* *debug-io*))
+  "Show a listing of the call stack going down from the current frame.  In the
+   debugger, the current frame is indicated by the prompt.  Count is how many
+   frames to show."
+  (let ((*print-length* (or *debug-print-length* *print-length*))
+	(*print-level* (or *debug-print-level* *print-level*)))
+    (fresh-line *standard-output*)
+    (do ((frame (if *in-the-debugger* *current-frame* (di:top-frame))
+		(di:frame-down frame))
+	 (count count (1- count)))
+	((or (null frame) (zerop count))
+
+;;; LAMBDA-LIST-ELEMENT-DISPATCH -- Internal.
+
 ;;;
 ;;; This is a convenient way to express what to do for each type of lambda-list
 ;;; element.
@@ -132,18 +158,13 @@ Functions/macros for your enjoyment:
 	     (prin1 (di:debug-function-name d-fun))
 	     (dolist (ele args)
 	       (write-char #\space)
-	       (etypecase ele
-		 (di:debug-variable
-		  (print-frame-call-arg ele loc frame))
-		 (cons
-		  (ecase (car ele)
-		    (:optional
-		     (print-frame-call-arg (second ele) loc frame))
-		    (:rest)
-		    (:keyword
-		     (prin1 (second ele))
-		     (write-char #\space)
-		     (print-frame-call-arg (third ele) loc frame))))))
+	       (lambda-list-element-dispatch ele
+		 :required ((print-frame-call-arg ele loc frame))
+		 :optional ((print-frame-call-arg (second ele) loc frame))
+		 :keyword ((prin1 (second ele))
+			   (write-char #\space)
+			   (print-frame-call-arg (third ele) loc frame))
+		 :deleted ((print-frame-call-arg ele loc frame))))
 	     (write-char #\))
 	     (when (di:debug-function-kind d-fun)
 	       (write-string " [")
@@ -159,7 +180,7 @@ Functions/macros for your enjoyment:
 (defun print-frame-call-arg (var location frame)
   (cond ((eq var :deleted)
 	 (write-string "<unused-arg>"))
-	((di:debug-variable-validity var location)
+	((eq (di:debug-variable-validity var location) :valid)
 	 (prin1 (di:debug-variable-value var frame)))
 	(t (write-string "<unavailable-arg>"))))
 
@@ -222,7 +243,7 @@ Functions/macros for your enjoyment:
     (make-unprintable-object "unused-arg")
     (di:debug-variable-value var frame)
     (make-unprintable-object "unavailable-arg")))
-;;;; DEBUG
+;;;; INVOKE-DEBUGGER.
 ;;; PRINT-FRAME-CALL -- Interface
 ;;;
 ;;; This prints a representation of the function call causing frame to exist.
@@ -282,6 +303,148 @@ Functions/macros for your enjoyment:
 	  (names-used '(nil))
 	  (max-name-len 0))
       (dolist (restart restarts)
+;;;; DEBUG-LOOP.
+	  (when name
+	(incf max-name-len 3))
+  (let ((*debug-command-level* (1+ *debug-command-level*))
+	(*current-frame* (di:top-frame)))
+			 count (- max-name-len 3) name restart)
+		 (push name names-used))))
+	(incf count)))))
+
+;;; INTERNAL-DEBUG -- Internal Interface.
+;;;
+;;; This calls DEBUG-LOOP, performing some simple initializations before doing
+;;; so.  INVOKE-DEBUGGER calls this to actually get into the debugger.
+;;; CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
+;;; prompt as quickly as possible with as little risk as possible for stepping
+;;; on whatever is causing recursive errors.
+				      (throw 'debug-loop-catcher nil))
+				    (invoke-debugger condition))))
+	    (funcall *debug-prompt*)
+	    (let* ((exp (read))
+		   (cmd-fun (debug-command-p exp))
+		   ;; Must bind level for restart function created by
+		   ;; WITH-SIMPLE-RESTART.
+		   (level *debug-command-level*))
+      (clear-input *debug-io*)
+		(if cmd-fun
+		    (funcall cmd-fun)
+		    (debug-eval-print exp))))))))))
+				    (when *flush-debug-errors*
+	    ;; WITH-SIMPLE-RESTART.
+	    (let ((level *debug-command-level*)
+  (let* ((values (multiple-value-list (eval -)))
+		  (cond (input
+			 (let ((cmd-fun (debug-command-p
+					 (ext:stream-command-name input)
+					 restart-commands)))
+			   (cond
+			    ((not cmd-fun)
+			     (error "Unknown stream-command -- ~S." input))
+			    ((consp cmd-fun)
+			     (error "Ambiguous debugger command: ~S." cmd-fun))
+			    (t
+			     (apply cmd-fun (ext:stream-command-args input))))))
+			(t
+			 (let* ((exp (read))
+				(cmd-fun (debug-command-p exp restart-commands)))
+			   (cond ((not cmd-fun)
+				  (debug-eval-print exp))
+				 ((consp cmd-fun)
+				  (format t "~&Your command, ~S, is ambiguous:~%"
+					  exp)
+				  (dolist (ele cmd-fun)
+				    (format t "   ~A~%" ele)))
+				 (t
+
+;;; VARS -- Public.
+		   (:set
+		    `(setf (di:debug-variable-value (car vars) *current-frame*)
+			   ,value-var))))
+	       ;; If there weren't any exact matches, flame about ambiguity
+	       ;; unless all the variables have the same name.
+	       ((and (not exact)
+		     (find-if-not
+		      #'(lambda (v)
+			  (string= (di:debug-variable-name v)
+				   (di:debug-variable-name (car vars))))
+		      (cdr vars)))
+		(error "Specification ambiguous:~%~{   ~A~%~}"
+		       (mapcar #'di:debug-variable-name
+			       (delete-duplicates
+				vars :test #'string=
+				:key #'di:debug-variable-name))))
+   information."
+  (let* ((vars (etypecase name
+		 (symbol (di:debug-function-symbol-variables
+			  (di:frame-debug-function *current-frame*)
+			  name))
+		 (simple-string (di:ambiguous-debug-variables
+				 (di:frame-debug-function *current-frame*)
+				 name))))
+	 (location (di:frame-code-location *current-frame*)))
+    (declare (list vars))
+    (setf vars
+	  (remove-if-not #'(lambda (v)
+			     (eq (di:debug-variable-validity v location) :valid))
+			 vars))
+    (cond ((null vars)
+	   (error "No known valid variables match ~S." name))
+	  ((= (length vars) 1)
+	   (di:debug-variable-value (car vars) *current-frame*))
+	  ((find-if-not #'(lambda (v)
+			    (string= (di:debug-variable-name v)
+				     (di:debug-variable-name (car vars))))
+			vars)
+	   (error "Specification ambiguous:~%~{   ~A~%~}"
+		  (mapcar #'di:debug-variable-name
+			  (delete-duplicates vars
+					     :test #'string=
+					     :key #'di:debug-variable-name))))
+	  (id-supplied
+	   (let ((v (find id vars :key #'di:debug-variable-id)))
+	     (unless v
+	       (error "Invalid variable ID, ~D, should have been one of ~S."
+		      id (mapcar #'di:debug-variable-id vars)))
+	     (di:debug-variable-value v *current-frame*)))
+	  (t
+	   (error "Specify variable id to disambiguate ~S.  Use one of ~S."
+		   name (mapcar #'di:debug-variable-id vars))))))
+			   id (mapcar #'di:debug-variable-id vars)))
+		      '(di:debug-variable-value v *current-frame*))
+		     (:set
+		      `(setf (di:debug-variable-value v *current-frame*)
+			     ,value-var)))))
+   argument in a frame's default printed representation.  Keyword/value pairs
+   count as one."
+  (let* ((lambda-list (handler-case (di:debug-function-lambda-list
+				     (di:frame-debug-function *current-frame*))
+			(di:lambda-list-unavailable ()
+			  (error "No argument values are available."))))
+	 (rest-pos (position-if #'(lambda (x)
+				    (and (consp x) (eq (car x) :rest)))
+				lambda-list))
+	 (arg (car (nthcdr (if (and rest-pos (<= rest-pos n))
+			       (1+ n)
+			       n)
+			   lambda-list))))
+    (flet ((variable-value-if-valid (var frame)
+	     (cond ((eq var :deleted)
+		    (error "Unused arguments have no values."))
+		   ((eq (di:debug-variable-validity
+			 var (di:frame-code-location frame))
+			:valid)
+		    (di:debug-variable-value var frame))
+		   (t (error "Invalid argument value.")))))
+      (lambda-list-element-dispatch arg
+	:required ((variable-value-if-valid arg *current-frame*))
+	:optional ((variable-value-if-valid (second arg) *current-frame*))
+	:keyword ((variable-value-if-valid (third arg) *current-frame*))
+	:deleted ((variable-value-if-valid arg *current-frame*))))))
+
+	  (di:debug-variable-value var *current-frame*)
+	var)))
 
 ;;; NTH-ARG -- Internal.
 ;;;
@@ -394,6 +557,12 @@ Functions/macros for your enjoyment:
     (unless any-p (write-line "No variable information available."))))
 (def-debug-command-alias "PP" "VPRINT")
 (def-debug-command "SOURCE"
+  (print-frame-source-form *current-frame* (read-if-available 0)))
+	      (*print-length* (or *debug-print-length* *print-level*))
+(def-debug-command "VSOURCE"
+  (print-frame-source-form *current-frame* (read-if-available 0) t))
+			d-fun
+(defun print-frame-source-form (frame context &optional verbose)
   (let* ((location (di:frame-code-location *current-frame*))
 	      (format t "~A~:[#~D~;~*~]  =  ~S~%"
 		      (di:debug-variable-name v)
@@ -408,15 +577,14 @@ Functions/macros for your enjoyment:
 			       location))
 		  (char-offset (aref (di:debug-source-start-positions
 				      d-source)
-				     tlf-offset))
-		  (context (read-if-available 0)))
+				     tlf-offset)))
 	     (with-open-file (f name)
 	       (file-position f char-offset)
 	       (let* ((tlf (read f))
 		      (translations (di:form-number-translations
 				     tlf tlf-offset))
-		      (*print-level* *debug-print-level*)
-		      (*print-length* *debug-print-length*))
+		      (*print-level* (if verbose nil *debug-print-level*))
+		      (*print-length* (if verbose nil *debug-print-length*)))
 		 (print (di:source-path-context
 			 tlf
 			 (svref translations
@@ -450,54 +618,6 @@ Functions/macros for your enjoyment:
   (setf *breakpoints*
 	(sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
   (dolist (info *breakpoints*)
-
-
-
-;;;; DEBUG-LOOP.
-
-(defun debug-loop ()
-  (let ((*debug-command-level* (1+ *debug-command-level*))
-	(*current-frame* (di:top-frame)))
-    (handler-bind ((di:debug-condition #'(lambda (condition)
-					   (princ condition *debug-io*)
-					   (throw 'debug-loop-catcher nil))))
-      (print-frame-call *current-frame*)
-      (loop
-	(catch 'debug-loop-catcher
-	  (handler-bind ((error #'(lambda (condition)
-				    (when *flush-debug-errors*
-				      (clear-input *debug-io*)
-				      (princ condition)
-				      (format t "~&Error flushed ...")
-				      (throw 'debug-loop-catcher nil))
-				    (invoke-debugger condition))))
-	    (funcall *debug-prompt*)
-	    (let* ((exp (read))
-		   (cmd-fun (debug-command-p exp))
-		   ;; Must bind level for restart function created by
-		   ;; WITH-SIMPLE-RESTART.
-		   (level *debug-command-level*))
-	      (with-simple-restart (abort "Return to debug level ~D." level)
-		(if cmd-fun
-		    (funcall cmd-fun)
-		    (debug-eval-print exp))))))))))
-
-(defun debug-eval-print (exp)
-  (setq +++ ++ ++ + + - - exp)
-  (let* ((values (multiple-value-list (eval -)))
-	 (*standard-output* *debug-io*))
-    (fresh-line)
-    (if values (prin1 (car values)))
-    (dolist (x (cdr values))
-      (fresh-line)
-      (prin1 x))
-    (setq /// // // / / values)
-    (setq *** ** ** * * (car values))
-    ;; Make sure nobody passes back an unbound marker.
-    (unless (boundp '*)
-      (setq * nil)
-      (fresh-line)
-      (princ "Setting * to NIL -- was unbound marker."))))
     (print-breakpoint-info info)))
 
 (def-debug-command-alias "LB" "LIST-BREAKPOINTS")
-- 
GitLab