;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Fonts:(CPTFONT HL10B HL12BI HL12B CPTFONTB)Ï1; Ï*Patch-File:T -*-

;Ï1;;                     RESTRICTED RIGHTS LEGEND          Ï*
;Ï1;; Use, duplication, or disclosure by the Government is subject toÏ*
;Ï1;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights inÏ*
;Ï1;; Technical Data and Computer Software clause at 52.227-7013.Ï*
;Ï1;;                   TEXAS INSTRUMENTS INCORPORATED.Ï*
;Ï1;;                            P.O. BOX 149149Ï*
;Ï1;;                         AUSTIN, TEXAS 78714-9149Ï*
;Ï1;;                             MS 2151Ï*
;Ï1;; Copyright (C) 1986,1987 Texas Instruments Incorporated. All rights reserved.Ï*
;Ï1;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved.Ï*
;Ï1;; Copyright (c) 1980 Massachusetts Institute of Technology Ï*


;; Trace package
;Ï1---------------------------------------------------------------------------------Ï*
;;	"There is always a place for debugging.  No matter how
;;	 hard you try to think of everything in advance, you
;;	 will always find that there is something else that you
;;	 hadn't thought of."
;;			- My Life as a Mathematician
;;			  by Hfpsh Dboups
;;; Items in this menu are lists of the form:
;;;  ("name" :VALUE (S-expr-arg-p . what-to-append-into-trace-options))
;;;			^-- if this is UNTRACE, QUIT, or DO-IT, that
;;;                         special function.
;;;			if NIL, nothing special.
;;;			otherwise is prompt for reading what goes into
;;;                         trace options.
;;; Try to keep this so it comes out in 3 columns.
;Ï1---------------------------------------------------------------------------------Ï*

tv:
(DEFVAR Ï4trace-item-listÏ*
   '(("Ï3Break beforeÏ*" :value (nil :break t) 
      :documentation "Ï3Call BREAK before entering the function, binding ARGLIST.Ï*")
     ("Ï3Break afterÏ*" :value (nil :exitbreak t) 
      :documentation "Ï3Call BREAK after leaving the function, binding VALUES.Ï*")
     ("Ï3StepÏ*" :value (nil :step) 
      :documentation "Ï3Single-step through the body of the (interpreted) function.Ï*")
     ("Ï3Cond StepÏ*" :value ("Ï3Predicate for stepping callsÏ*" :stepcond) 
      :documentation "Ï3Asks for a predicate which controls whether stepping happens.Ï*")
     ("Ï3ErrorÏ*" :value (nil :error) 
      :documentation "Ï3Enter the error handler's debugger when the function is called.Ï*")
     ("Ï3PrintÏ*" :value ("Ï3Form to evaluate and print in trace messagesÏ*" :print) 
      :documentation "Ï3Asks for a form to be evaluated and printed in trace messages.Ï*")
     ("Ï3Print beforeÏ*" :value ("Ï3Form to evaluate and print before callingÏ*" :entryprint)
      :documentation "Ï3Asks for a form to be evaluated and printed upon function entry.Ï*")
     ("Ï3Print afterÏ*" :value ("Ï3Form to evaluate and print after returningÏ*" :exitprint)
      :documentation "Ï3Asks for a form to be evaluated and printed upon function exit.Ï*")
     ("Ï3ConditionalÏ*" :value ("Ï3Predicate for tracingÏ*" :cond) 
      :documentation "Ï3Asks for a predicate which controls whether tracing happens.Ï*")
     ("Ï3Cond beforeÏ*" :value ("Ï3Predicate for tracing callsÏ*" :entrycond) 
      :documentation "Ï3Asks for a predicate which controls tracing of function entry.Ï*")
     ("Ï3Cond afterÏ*" :value ("Ï3Predicate for tracing returnsÏ*" :exitcond) 
      :documentation "Ï3Asks for a predicate which controls tracing of function exit.Ï*")
     ("Ï3Cond break beforeÏ*" :value ("Ï3Predicate for breaking beforeÏ*" :break) 
      :documentation "Ï3Asks for a predicate which controls BREAKing on function entry.Ï*")
     ("Ï3Cond break afterÏ*" :value ("Ï3Predicate for breaking afterÏ*" :exitbreak) 
      :documentation "Ï3Asks for a predicate which controls BREAKing on function exit.Ï*")
     ("Ï3ARGPDLÏ*" :value ("Ï3Arg pdl variableÏ*" :argpdl) 
      :documentation "Ï3Asks for a variable which gets list of recursive argument lists.Ï*")
     ("Ï3WhereinÏ*" :value ("Ï3Function within which to traceÏ*" :wherein) 
      :documentation "Ï3Asks for a function, within which tracing will be active.Ï*")
     ("Ï3UntraceÏ*" :value (UNTRACE) :font :menu-standout 
      :documentation "Ï3Instead of tracing this function, stop tracing it.Ï*")
     ("Ï3AbortÏ*" :value (quit) :font :menu-standout 
      :documentation "Ï3Click here to get out of this without doing anything.Ï*")
     ("Ï3Do ItÏ*" :value (do-it) :font :menu-standout 
      :documentation "Ï3Click here to do the tracing with the selected options.Ï*"))) 

tv:
(DEFWINDOW-RESOURCE Ï4trace-pop-up-menuÏ* () :make-window
   (dynamic-temporary-menu
     :name "Ï3Trace OptionsÏ*"
     :item-list-pointer 'trace-item-list)
   :reusable-when :deexposed) 

tv:
(DEFUN Ï4trace-via-menusÏ* (&optional fcn)
  "Ï2This function is invoked in the momentary menu process when the
user clicks TRACE and in the editor process by the editor's Trace
command.  If the function isn't supplied as an argument the user is
asked for it.Ï*"
  (USING-RESOURCE (trace-pop-up-window pop-up-text-window)
     (USING-RESOURCE (trace-pop-up-menu trace-pop-up-menu)
	(FUNCALL trace-pop-up-window :set-label "Ï3TraceÏ*")
	(FUNCALL trace-pop-up-window :set-size
		 (MIN 1000			;Ï1Accomadate small mac screens  PMH 3/11Ï*
		      (tv:sheet-width (tv:sheet-superior trace-pop-up-window))) 
		 (MIN 300			;Ï1Accomadate small mac screens  PMH 3/11Ï*
		      (FLOOR (tv:sheet-height (tv:sheet-superior trace-pop-up-window)) 2)))
	(FUNCALL trace-pop-up-window :center-around mouse-x mouse-y)
	(window-call (trace-pop-up-window :deactivate)
	 (UNWIND-PROTECT (LET
			  ((blinker (CAR (sheet-blinker-list trace-pop-up-window))))
			  (COND
			    ((NULL fcn)
			     ;Ï1; Make sure blinker is blinking.Ï*
			     (blinker-set-visibility blinker :blink)
			     (FORMAT trace-pop-up-window
				     "Ï3Type in name of function to be traced or untraced.
  Abort quits.~%Ï*")
			     (DO ((*terminal-io* trace-pop-up-window)
				  (*standard-input* trace-pop-up-window)
				  (*standard-output* trace-pop-up-window))
				 (nil)
			       (SETQ fcn (READ))
                               (SETQ fcn (dwimify-arg-package fcn 'function-spec))     ;Ï1!Ï*
			       (IF (FDEFINEDP fcn)
				 (RETURN ())
				 (FORMAT t "Ï3 ;not a defined function, try again~%Ï*")))))
			  (FUNCALL trace-pop-up-menu :move-near-window trace-pop-up-window)
			  (DO ((form (IF (ATOM fcn)
				       `(TRACE (,fcn))
				       `(TRACE (:function ,fcn))))
			       (choice)
			       (option)
			       (arg))
			      (nil)
			       ;Ï1; Put the current status on the text window.Ï*
			    (FUNCALL trace-pop-up-window :clear-screen)
			    ;Ï1; 76 is width in characters.Ï*
			    (GRIND-TOP-LEVEL form 76 trace-pop-up-window)
			    ;Ï1; Not listening to the keyboard any more, shut off blinker.Ï*
			    (blinker-set-visibility blinker nil)
			    ;Ï1; Get input from the menu.Ï*
			    (SETQ choice (FUNCALL trace-pop-up-menu :choose)
				  option (FIRST choice))
			    (COND
			      ((NULL choice))            ;Ï1Try again if outside menuÏ*
			      ((EQ option 'UNTRACE) (EVAL `(UNTRACE ,fcn)) (RETURN ()))
			      ((EQ option 'quit) (RETURN ()))
			      ((EQ option 'do-it) (EVAL form) (RETURN ()))
			      (t
			       ;Ï1; let's make it smarter so that we can undo choices.Ï*
			       (LET ((previous-entry-position
				      (POSITION (SECOND choice) (THE list (SECOND form)) :test
						#'EQ)))
				 (COND
				   ((AND previous-entry-position
				       (OR (EQ (SECOND choice) :break)
					  (EQ (SECOND choice) :exitbreak))
				       (CDDR choice))
				    ;Ï1; Then we should either remove it fromÏ*
				    ;Ï1; the list if it is the same or justÏ*
				    ;Ï1; change the argument.Ï*
				    (IF (EQ (THIRD choice)
					 (NTH (1+ previous-entry-position) (SECOND form)))
				     ;Ï1; Remove the choiceÏ*
				      (IF (EQ previous-entry-position 0)
					(SETF (SECOND form) (CDDR (SECOND form)))
					;Ï1; ELSEÏ*
					(SETF (NTHCDR previous-entry-position (SECOND form))
					      (NTHCDR (+ 2 previous-entry-position)
						      (SECOND form))))
				      ;Ï1; ELSEÏ*
				      ;Ï1; Fix the choiceÏ*
				      (SETF (NTH (1+ previous-entry-position) (SECOND form))
					    (THIRD choice))))
				   ((AND previous-entry-position (NULL option))
				    ;Ï1; Delete the choice.Ï*
				    (IF (EQ previous-entry-position 0)
				      (SETF (SECOND form) (CDR (SECOND form)))
				      (SETF (NTHCDR previous-entry-position (SECOND form))
					    (NTHCDR (1+ previous-entry-position) (SECOND form)))))
				   ((NULL option)
				    ;Ï1; Just add the object.Ï*
				    (SETF (SECOND form) (APPEND (SECOND form) (CDR choice))))
				   (t
				    ;Ï1; Needs an arg, get it.Ï*
				    (FORMAT trace-pop-up-window "Ï3~2%~A:~%Ï*" option)
				    ;Ï1; Turn on blinker.Ï*
				    (blinker-set-visibility blinker :blink)
				    (LET ((*terminal-io* trace-pop-up-window)
					  (*standard-input* trace-pop-up-window)
					  (*standard-output* trace-pop-up-window)
					  (flag))
				      (MULTIPLE-VALUE-SETQ (arg flag)
					(FUNCALL *terminal-io* :rubout-handler
						 '((:full-rubout :full-rubout))
						 #'READ-FOR-TOP-LEVEL))
				      (UNLESS flag
				       ;Ï1; If previous entry replace the argumentÏ*
				       ;Ï1; otherwise add on new argument.Ï*
					(IF (NULL previous-entry-position)
					  (SETF (SECOND form)
						(APPEND (SECOND form) (CDR choice) (CONS arg ())))
					  (SETF (NTH (1+ previous-entry-position) (SECOND form))
						arg)))))))))))
	   (FUNCALL trace-pop-up-menu :deactivate)))))) 


;Ï1tv:Ï*
;Ï1(ADD-TO-SYSTEM-MENU-COLUMN :DEBUG "Trace" '(TRACE-VIA-MENUS)Ï*
;			Ï1   "Trace a function.  Options selected from menu."Ï*
;			Ï1   :SORTED)
