;;; -*- Mode:Common-Lisp; Package:System; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

2;;;*		2TI Scheme debugging utility functions

1;;; Copyright (C) 1988 Texas Instruments Incorporated. All rights reserved.

;; Revised:
;;  4/18/88 DNG - Original.**

(export 'scheme:( advise-entry advise-exit
		 break break-both break-entry break-exit
		 trace trace-both trace-entry trace-exit
		 unadvise unadvise-entry unadvise-exit
		 unbreak unbreak-entry unbreak-exit
		 untrace untrace-entry untrace-exit
		 *args* *proc* *result*
		 pcs-debug-mode
		 ) scheme-package)

(defvar advised-entry nil)
(defvar advised-exit nil)

(defun scheme:3advise-entry* (proc advice-in)
  1"When PROC is entered, call ADVICE-IN, passing PROC, argument list, and environment."*
  (let ((fspec (function-name proc)))
    (when (advise-1 fspec :before 'scheme:advise-entry nil
		    `((funcall ',advice-in ',proc arglist nil)))
      (pushnew fspec advised-entry :test #'equal)
      fspec)))
(defun scheme:3advise-exit* (proc advice-out)
1  "When PROC returns, call ADVICE-OUT, passing PROC, argument list, result value, and environment.
The value returned by ADVICE-OUT is returned from PROC."*
  (let ((fspec (function-name proc)))
    (unadvise-1 fspec :around nil)
    (when (advise-1 fspec :around 'scheme:advise-exit nil
		    `((let ((values (multiple-value-list :do-it)))
			(declare (special values))
			(funcall ',advice-out ',proc arglist (first values) nil)
			)))
      (pushnew fspec advised-exit :test #'equal)
      fspec)))

(defun scheme:3unadvise-entry* (&optional (proc nil pp))
  (declare (arglist &optional proc))
  (if pp
      (let ((fspec (function-name proc)))
	(prog1 (unadvise-1 fspec :before nil)
	       (setq advised-entry (delete fspec (the list advised-entry) :test #'equal))))
    (let ((result nil))
      (dolist (fn (copy-list advised-entry))
	(when (unadvise-1 fn :before nil)
	  (setq advised-entry (delete fn (the list advised-entry) :test #'equal))
	  (push fn result)))
      result)))
(defun scheme:3unadvise-exit* (&optional (proc nil pp))
  (declare (arglist &optional proc))
  (if pp
      (let ((fspec (function-name proc)))
	 (prog1 (unadvise-1 fspec :around nil)
		(setq advised-exit (delete fspec (the list advised-exit) :test #'equal))))
    (let ((result nil))
      (dolist (fn (copy-list advised-exit))
	(when (unadvise-1 fn :around nil)
	  (setq advised-exit (delete fn (the list advised-exit) :test #'equal))
	  (push fn result)))
      result)) )
(defun scheme:3unadvise* (&optional (proc nil pp))
  (declare (arglist &optional proc))
  (if pp
      (or (scheme:unadvise-entry proc)
	  (scheme:unadvise-exit proc))
    (nunion (scheme:unadvise-entry)
	    (scheme:unadvise-exit))))

(defun scheme:3break-both* (proc)
  (breakon (function-name proc)))
(defun scheme:3break-entry* (proc) 2; Doesn't quite match PC Scheme*
  (trace-1 `(:function ,(function-name proc) :break t)))
(defun scheme:3break-exit* (proc) 2; Doesn't quite match PC Scheme*
  (trace-1 `(:function ,(function-name proc) :exitbreak t)))
(deff scheme:3break* 'scheme:3break-entry*)
(defun scheme:3unbreak* (proc)
  (unbreakon (function-name proc)))
(deff scheme:3unbreak-entry* 'scheme:untrace) 2; Doesn't quite match PC Scheme*
(deff scheme:3unbreak-exit* 'scheme:untrace) 2; Doesn't quite match PC Scheme*

(defun scheme:3trace-both* (proc)
  (trace-1 (function-name proc)))
(defun scheme:3trace-entry* (proc) 2; Doesn't quite match PC Scheme*
  (trace-1 `(:function ,(function-name proc) :entrycond t :exitcond nil)))
(defun scheme:3trace-exit* (proc) 2; Doesn't quite match PC Scheme*
  (trace-1 `(:function ,(function-name proc) :value )))
(deff scheme:3trace* 'scheme:trace-entry)

(defun scheme:3untrace* (proc)
  (untrace-1 (function-name proc)))
(deff scheme:3untrace-entry* 'scheme:untrace) 2; Doesn't quite match PC Scheme*
(deff scheme:3untrace-exit* 'scheme:untrace)  2; Doesn't quite match PC Scheme*

(defvar scheme:3pcs-debug-mode* t) 1; this is not currently used for anything.*

(defun scheme:3*args** ()
  1"Return a list of the arguments to the current function while in the debugger."*
  (ignore-errors (return-from scheme:3*args** (eh-arg nil)))
  1;; This case for when at a breakpoint.*
  (if (boundp 'arglist)
      (symbol-value 'arglist)
    (error "~S called in invalid context." 'scheme:3*args**)))

(defun scheme:3*proc** ()
  1"Pretty-print the source of the current procedure in the debugger."*
  (let* ((fn (eh-fun))
	 (def (compiledp fn)))
    (if (consp def)
	(if (and (eq (first def) 'named-lambda)
		 (eq (car-safe (fourth def)) 'with-scheme-semantics))
	    (pprint `(scheme:lambda ,(third def)
		       . ,(rest (fourth def))))
	  (let ((*print-length* nil) (*print-level* nil))
	    (pprint def *debug-io*)))
      (format *debug-io* "~&Source code for ~S is not available."
	      (or (function-name fn) fn))))
  (values))

(defun scheme:3*result** ()
  1"Return the result about to be returned from the current procedure at an exit breakpoint."*
  (ignore-errors (return-from scheme:3*result** (eh-val)))
  (if (boundp 'values)
      (first (symbol-value 'values))
    (error "~S called in invalid context." 'scheme:3*result**)))