;;; -*- 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*Ï*)))