;;; -*- Mode: Lisp; Package: Debug; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; CMU Common Lisp Debugger.  This is a very basic command-line oriented
;;; debugger.
;;;
;;; Written by Bill Chiles.
;;;

(in-package "DEBUG")

(export '(internal-debug *in-the-debugger* backtrace *flush-debug-errors*
	  *debug-print-level* *debug-print-length* *debug-prompt*))


(in-package "LISP")
(export '(invoke-debugger *debugger-hook*))

(in-package "DEBUG")

;;;
;;; Used to communicate to debug-loop that we are at a step breakpoint.
;;;
(define-condition step-condition (simple-condition))
  "*Print-level* is bound to this value when debug prints a function call.")
;;;; Variables, parameters, and constants.

  "*Print-length* is bound to this value when debug prints a function call.")
  null, use *PRINT-LEVEL*")

(defparameter *debug-print-length* 5
  "*PRINT-LENGTH* is bound to this value when debug prints a function call.  If
  null, use *PRINT-LENGTH*.")

(defvar *in-the-debugger* nil
  "If this is bound before the debugger is invoked, it is used as the stack
(defvar *stack-top* nil)

;;;; Breakpoint state:

(defvar *only-block-start-locations* nil
  "When true, the LIST-LOCATIONS command only displays block start locations.
   Otherwise, all locations are displayed.")

(defvar *print-location-kind* nil
  "If true, list the code location type in the LIST-LOCATIONS command.")

;;; A list of the types of code-locations that should not be stepped to and
;;; should not be listed when listing breakpoints.
;;;
(defvar *bad-code-location-types* '(:call-site :internal-error))
(declaim (type list *bad-code-location-types*))

;;; Code locations of the possible breakpoints
;;;
(defvar *possible-breakpoints*)
(declaim (type list *possible-breakpoints*))

;;; A list of the made and active breakpoints, each is a breakpoint-info
;;;
(defvar *breakpoints* nil)
(declaim (type list *breakpoints*))

;;; A list of breakpoint-info structures of the made and active step
;;; breakpoints.
  PUSH     rebinds things in another command level.  Good for hide/show.
  ABORT    returns to the previous abort restart case.
;;;
(defvar *step-breakpoints* nil)  
;;;
(defvar *number-of-steps* 1)
(declaim (type integer *number-of-steps*))
;;;
(defvar *default-breakpoint-debug-function* nil)
  L              lists locals in current function.
  P, PP          displays current function call.  

Functions/macros for your enjoyment:
 (DEBUG:DEBUG-RETURN expression [frame])  returns with values from an active frame.
 (DEBUG:ARGUMENT n [frame])              shows the nth  supplied argument.
 (DEBUG:PC [frame])                 shows the next pc to be executed.
;;; Returns a list of the next code-locations following the one passed.  One of
;;; the *bad-code-location-types* will not be returned.
;;;
(defun next-code-locations (code-location)
    (di:do-debug-block-locations (block-code-location debug-block)
    (setf kind (di:breakpoint-kind (breakpoint-info-breakpoint place)))
    (format t "Cannot step, in elsewhere code~%"))
   (t
    (let* ((code-location (di:frame-code-location frame))
	   (next-code-locations (next-code-locations code-location)))
      (cond
       (next-code-locations
	(dolist (code-location next-code-locations)
	  (let ((bp-info (location-in-list code-location *breakpoints*)))
	      (di:deactivate-breakpoint (breakpoint-info-breakpoint bp-info))))
  (let ((*print-length* *debug-print-length*)
	(*print-level* *debug-print-level*))
	    (di:activate-breakpoint bp)
	    (push (create-breakpoint-info code-location bp 0)
		  *step-breakpoints*))))
       (t
	(let* ((debug-function (di:frame-debug-function *current-frame*))
	       (bp (di:make-breakpoint #'main-hook-function debug-function
      (print-frame-call frame))))
	  (di:activate-breakpoint bp)
;;;
;;; This is a convenient way to express what to do for each type of lambda-list
;;; element.
;;;
(defmacro lambda-list-element-dispatch (element &key required optional rest
						keyword deleted)
  `(etypecase ,element
(defun print-frame-call (frame &optional
			       (*print-length* *debug-print-length*)
			       (*print-level* *debug-print-level*)
			       (verbosity 1))
  (ecase verbosity
    (0 (print frame))
    (1 (handler-case
	   (let* ((d-fun (di:frame-debug-function frame))
		  (loc (di:frame-code-location frame))
		  (args (di:debug-function-lambda-list d-fun)))
	     (terpri)
	     (write-char #\()
	     (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))))))
	     (write-char #\))
	     (when (di:debug-function-kind d-fun)
	       (write-string " [")
	       (prin1 (di:debug-function-kind d-fun))
	       (write-char #\])))
	 (di:lambda-list-unavailable ()
	  (let ((d-fun (di:frame-debug-function frame)))
	    (format t "(~S <lambda-list-unavailable>)) ~S)"
		    (di:debug-function-name d-fun)
		    (di:debug-function-kind d-fun))))))
    ((2 3 4 5))))
	     (t ,other)))))
(defun print-frame-call-arg (var location frame)
  (cond ((eq var :deleted)
	 (write-string "<unused-arg>"))
	((di:debug-variable-validity var location)
	 (prin1 (di:debug-variable-value var frame)))
	(t (write-string "<unavailable-arg>"))))



;;;; ROBS-BACKTRACE.

(defun robs-backtrace (&optional (frames most-positive-fixnum)
			    (*standard-output* *debug-io*))
  "Show a listing of the call stack going down from the current frame.  Frames
  is how many frames to show."
  (do ((callee (system:%primitive current-fp)
	       (di::stack-ref callee c::old-fp-save-offset))
       (n 0 (1+ n)))
      ((or (not (di::cstack-pointer-valid-p callee))
	   (>= n frames))
       (values))
    (let* ((caller (di::stack-ref callee c::old-fp-save-offset))
	   (pc (di::stack-ref callee c::return-pc-save-offset)))
      (unless (di::cstack-pointer-valid-p caller)
	(return (values)))
      (let ((env (di::stack-ref caller c::env-save-offset)))
	(cond 
	 ((eql env 0)
	  (let ((env (di::escape-register caller c::env-offset)))
	    (cond ((eql (system:%primitive get-type env) system:%trap-type)
		   (format t "~%<undefined> ~S"
			   (di::escape-register caller c::call-name-offset))
		   (setq callee
			 (check-valid
			  (di::escape-register caller c::old-fp-offset))))
		  ((di::env-valid-p env)
		   (format t "~%<escape frame> ")
		   (print-code-and-stuff
		    env
		    (di::escape-register caller c::return-pc-offset))
		   (setq callee
			 (check-valid
			  (di::stack-ref callee c::old-fp-save-offset))))
		  (t
		   (error "Escaping frame ENV invalid?")))))
	 ((di::env-valid-p env)
	  (terpri)
	  (print-code-and-stuff env pc))
	 (t
	  (format t "~%<invalid frame>")))))))

(defun print-code-and-stuff (env pc)
  (let* ((code (system:%primitive header-ref env system:%function-code-slot))
	 (code-int (system:%primitive make-fixnum code)))
    (format t "~A, Code = #x~X, PC = ~D"
	    (system:%primitive header-ref env system:%function-name-slot)
	    (logior code-int (ash system:%code-type 27))
	    (- (system:%primitive make-fixnum pc) code-int))))

(defun check-valid (x)
  (unless (di::cstack-pointer-valid-p x)
    (error "Invalid control stack pointer."))
  x)
    (make-unprintable-object "unused-arg")
    (di:debug-variable-value var frame)
    (make-unprintable-object "unavailable-arg")))
;;;; DEBUG
;;; PRINT-FRAME-CALL -- Interface
;;;
;;; This prints a representation of the function call causing frame to exist.
;;; Verbosity indicates the level of information to output; zero indicates just
;;; printing the debug-function's name, and one indicates displaying call-like,
;;; one-liner format with argument values.
;;;
(defun print-frame-call (frame &key (print-length *print-length*)
			       (print-level *print-level*)
			       (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)
      (when number
	(format t "~&~S: " (di:frame-number frame)))
      (format t "~S" frame))
     (t
      (when number
	(format t "~&~S: " (di:frame-number frame)))
    (when (>= verbosity 2)
      (let ((loc (di:frame-code-location frame)))
	 (*debug-abort* (find-restart 'abort))
	(handler-case
	    (progn
	 (*error-output* *debug-io*))

;;;; Invoke-debugger.

(defvar *debugger-hook* nil
  "This is either nil or a function of two arguments, a condition and the value
   of *debugger-hook*.  This function can either handle the condition or return
   which causes the standard debugger to execute.  The system passes the value
   of this variable to the function because it binds *debugger-hook* to nil
   around the invocation.")
    (do ((p restarts (cdr p))
	 (i 0 (1+ i)))
	((endp p))
      (format s "~&  ~D: ~A~%" i (car p)))))
	 ;; Rebind some printer control variables.
	 (kernel:*current-level* 0)
	 (*print-readably* nil)
	 (*read-eval* t))
    (format *error-output* "~2&~A~2&" *debug-condition*)
    (unless (typep condition 'step-condition)
      (show-restarts *debug-restarts* *error-output*))
    (internal-debug)))

;;; SHOW-RESTARTS -- Internal.
;;;
(defun show-restarts (restarts &optional (s *error-output*))
  (when restarts
    (format s "~&Restarts:~%")
    (let ((count 0)
	  (names-used '(nil))
	  (max-name-len 0))
      (dolist (restart restarts)

;;; NTH-ARG -- Internal.
;;;
;;; This returns the n'th arg as the user sees it from args, the result of
;;; Interface to *debug-commands*.
;;; 
(defmacro def-debug-command (name &rest body)
    (dolist (ele args (error "Argument specification out of range -- ~S." n))
      (lambda-list-element-dispatch ele
      (defun ,fun-name () ,@body)
      (push (cons ,name #',fun-name) *debug-commands*)
				      (di:frame-code-location *current-frame*)
		   (error "Unused rest-arg before n'th argument.")
(defun debug-command-p (form)
  (and (symbolp form)
       (cdr (assoc (symbol-name form) *debug-commands* :test #'string=))))
(defun debug-command-p (form &optional other-commands)
      (let* ((name
	  (mapc #'match-command other-commands))
	;;
	;; Return the right value.
(def-debug-command "U"
	      ((= (length res) 1)
    (if next
	(print-frame-call (setf *current-frame* next))
	(princ "Top of stack."))))

(def-debug-command "D"
;;; Returns a list of debug commands (in the same format as *debug-commands*)
    (if next
	(print-frame-call (setf *current-frame* next))
	(princ "Bottom of stack."))))
(defun make-restart-commands (&optional (restarts *debug-restarts*))
(def-debug-command "T"
  (print-frame-call
   (setf *current-frame*
	 (do ((prev *current-frame* lead)
	      (lead (di:frame-up *current-frame*) (di:frame-up lead)))
	     ((null lead) prev)))))
	    (push (cons (format nil "~d" num) restart-fun) commands))))
(def-debug-command "B"
  (print-frame-call
   (setf *current-frame*
	 (do ((prev *current-frame* lead)
	      (lead (di:frame-down *current-frame*) (di:frame-down lead)))
	     ((null lead) prev)))))


(def-debug-command "FRAME" (&optional
			    (n (read-prompting-maybe "Frame number: ")))
  (let ((current (di:frame-number *current-frame*)))
(def-debug-command "Q"
	   (princ "You are here."))
	  ((> n current)
(def-debug-command "GO"
	    (setf *current-frame*
		  (do ((prev *current-frame* lead)

(def-debug-command "PUSH"
  (invoke-debugger *debug-condition*))

(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*)
(def-debug-command "RESTART"
		      ((null lead)
		       (princ "Bottom of stack encountered.")
		       prev)
      (write-string "Restart number: ")
	  (t
    (invoke-restart-interactively (nth num *debug-restarts*))))
;;;
;;; In and Out commands.
;;;

(def-debug-command "QUIT" ()
(def-debug-command "H"
  (princ debug-help-string))
	  (princ "No such restart.")))))
(def-debug-command "ERROR"
;;; Information commands.
;;;
 
(def-debug-command "BACKTRACE"
  "This controls how many lines the debugger's help command prints before
   printing a prompting line to continue with output.")
(def-debug-command "P"
(def-debug-command "HELP" ()
  (let* ((end -1)
(def-debug-command "PP"
  (print-frame-call *current-frame* nil nil))
	    (count *help-line-scroll-count*))
(def-debug-command "L"
  (let ((*print-level* *debug-print-level*)
	(*print-length* *debug-print-length*)
	(*standard-output* *debug-io*)
	(location (di:frame-code-location *current-frame*))
	(any-p nil))
    (di:do-debug-function-variables (v (di:frame-debug-function *current-frame*))
      (setf any-p t)
      (if (eq (di:debug-variable-validity v location) :valid)
	  (format t "~A~:[#~D~;~*~]  =  ~S~%"
		  (di:debug-variable-name v)
		  (zerop (di:debug-variable-id v))
		  (di:debug-variable-id v)
		  (di:debug-variable-value v *current-frame*))
	  #|(format t "~A has an invalid value currently.~%"
		  (di:debug-variable-name v))|#))
    (unless any-p (write-line "No variable information available."))))
(def-debug-command-alias "PP" "VPRINT")
(def-debug-command "SOURCE"
  (let* ((location (di:frame-code-location *current-frame*))
	      (format t "~A~:[#~D~;~*~]  =  ~S~%"
		      (di:debug-variable-name v)
    (cond ((not (eq :file (di:debug-source-from d-source)))
	   (format t "~%Source did not come from a file."))
	  ((not (probe-file name))
	   (format t "~%Source file no longer exists -- ~A."
		   (namestring name)))
	  ((<= (di:debug-source-created d-source)
	       (file-write-date name))
	   (let* ((tlf-offset (di:code-location-top-level-form-offset
			       location))
		  (char-offset (aref (di:debug-source-start-positions
				      d-source)
				     tlf-offset))
		  (context (read-if-available 0)))
	     (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 (di:source-path-context
			 tlf
			 (svref translations
				(di:code-location-form-number location))
			 context))))))
	    (t
	     (format t "~%File has been modified since compilation -- ~A."
		     (namestring name))))))
		  (setf *possible-breakpoints*
			(possible-breakpoints
			 *default-breakpoint-debug-function*))))))
	   (setup-function-start ()

(defvar *flush-debug-errors* t
  "Don't recursively call DEBUG on errors while within the debugger if non-nil.")
	     (let ((code-loc (di:debug-function-start-location place)))
(def-debug-command "FLUSH"
  (setf *flush-debug-errors* (not *flush-debug-errors*)))

	(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*))
  (if (not (ext:listen-skip-whitespace in))
      (princ prompt out))

;;; list all breakpoints set
(def-debug-command "LIST-BREAKPOINTS" ()
  (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")
(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 (typep *terminal-io* 'ed::ts-stream)
    (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))