;;; -*- Mode:Common-Lisp; Package:EH; Base:8; Fonts:(TVFONT TR10 TR10I) -*-

;;; This software developed by:
;;;	James Rice
;;; at the Stanford University Knowledge Systems Lab in 1986, 1987.
;;;
;;; This work was supported in part by:
;;;	DARPA Grant F30602-85-C-0012

;;;----------------------------------------------------------------------
;;;  Much of this file is derived from code licensed from Texas Instruments
;;;  Inc.  Since we'd like them to adopt these changes, we're claiming
;;;  no rights to them, however, the following restrictions apply to the
;;;  TI code:

;;; Your rights to use and copy Explorer System Software must be obtained
;;; directly by license from Texas Instruments Incorporated.  Unauthorized
;;; use is prohibited.

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986,1987 Texas Instruments Incorporated. All rights reserved.
;;;----------------------------------------------------------------------

(load-tools '(:window-debugger-enhancements))

(1defflavor* 2L2-Debugger-Who-Line-Mixin* ()
	   (debugger-who-line-mixin)
  (:Documentation :Combination
     "A version of DEBUGGER-WHO-LINE-MIXIN, which supports L2 protocols.")
)

(1defmethod* (2L2-Debugger-Who-Line-Mixin* :After :Init) (1ignore*)
  (1setq* normal-mouse-doc
	'(:Mouse-L-1 "Inspect selected object."
	  :Mouse-M-1 "Set * to object; Echo object in interaction pane.")))

(1defmethod* (2L2-Debugger-Who-Line-Mixin* :Get-Normal-Mouse-Doc) ()
  (1let* ((item (1if* (1or* (1send* self :Send-If-Handles :Sensitive-Inspect-Item)
		      (1send* self :Send-If-Handles :Sensitive-History-Item)
		      (1send* self :Send-If-Handles :Current-Item)
		  )
		  (tv:get-mouse-sensitive-item)
		  nil
	      )
	)
       )
       (1multiple-value-bind* (perspectives thing)
	   (1if* (1and* (1consp* item) (1third* item)
		    (1equal* :Item1 (1first* item))
	       )
	       (1if* (tv:allocated-Perspectives (1third* item))
		   (1values* (tv:allocated-Perspectives
			      (1third* item)) (1third* item))
		   (1values* nil (1third* item))
	       )
	       (1if* (1and* item (tv:allocated-Perspectives item))
		   (1values* (tv:allocated-Perspectives item) item)
		   (1if* (1and* (1equal*
			      (1send* self :Send-If-Handles :Print-Function-Arg)
			      :List-Structure
			    )
			    (1locativep* item)
			    (%p-contents-safe-p item)
			    (tv:allocated-Perspectives (1first* item))
		       )
		       (1values* (tv:allocated-Perspectives
				  (1first* item)) (1first* item))
		   )
	       )
	    )
           (1ignore* perspectives)
	   (1append* (1send* (1if* (1typep* thing 'tv:inspection-data)
                             thing
                             (tv:map-into-show-x thing t)
                         )
                         :Who-Line-Doc
                         t (1not* thing)
                   )
		   '(:Allow-Override "")
                   normal-mouse-doc
           )
       )
  )
)

(1defmethod* (2L2-Debugger-Who-Line-Mixin* :Who-Line-Documentation-String) ()
2"Who line documentation for the stack, args, locals, history and inspection panes."*
  (1let**
    ((FRAME (1send* SELF :Superior))
     (INTERACTOR (1send* FRAME :Get-Pane 'LISP-WINDOW)))
    (1or* (1send* FRAME :Who-Line-Doc-String-Overide)
	(1if* (1send* FRAME :Doing-Typein-P)
	    (1send* INTERACTOR :Who-Line-Documentation-String)
	    (1multiple-value-bind* (X Y) ;get mouse position
		(TV:SHEET-CALCULATE-OFFSETS SELF TV:MOUSE-SHEET)
	      (1setq* X (1-* SYSTEM:MOUSE-X X)
		    Y (1-* SYSTEM:MOUSE-Y Y))
	      (1multiple-value-bind* (ITEM ITEM-TYPE)
		  (1send* SELF :Mouse-Sensitive-Item X Y)
		(1cond* ((1not* (1or* ITEM ITEM-TYPE))
		       '(:Mouse-R-1
			  "Menu of all window-based debugger commands"))
		      (t
		       ;;; Change here by JPR.
                       (1or* (1catch-error* (1send* self :Get-Normal-Mouse-Doc) nil)
			   "Error getting doc string.")))))))))

(1defflavor* 2L2-Gray-Debugger-Text-Scroll-Pane*
           NIL
           (2L2-Debugger-Who-Line-Mixin* gray-debugger-text-scroll-pane)
  (:Documentation :Combination "Args window in window-based debugger"))

(1defflavor* 2L2-Gray-Debugger-Thermometer-Text-Scroll-Pane*
           NIL
           (2L2-Debugger-Who-Line-Mixin*
	    gray-debugger-thermometer-text-scroll-pane)
  (:Documentation :Combination "Locals window in window-based debugger"))

(1defflavor* 2L2-Stack-Scroll-Pane*
           ()
           (2L2-Debugger-Who-Line-Mixin* stack-scroll-pane)
  (:Documentation :Combination "Stack window in the window-based debugger"))

(1defflavor* 2Debugger-History-Pane*
           nil
           (debugger-who-line-mixin tv::general-inspector-history-window))

(1defflavor* 2L2-Debugger-History-Pane*
           NIL
           (2L2-Debugger-Who-Line-Mixin* 2Debugger-History-Pane*))

(1defflavor* 2New-Debugger-Inspect-Pane* NIL
	   (2L2-Debugger-Who-Line-Mixin* tv:general-inspect-window))

(1defflavor* 2New-Debugger-Frame* () (debugger-frame))

(1defvar* 2*Args-Window-Font-Map** (1List* :Default))
(1defvar* 2*Locals-Window-Font-Map** (1List* :Default))
(1defvar* 2*Stack-Window-Font-Map** (1List* :Default))
(1defvar* 2*Lisp-Window-Font-Map** (1List* :Default))
(1defvar* 2*Command-Menu-Font-Map** (1List* :Default FONTS:HL10B))
(1defvar* 2*Resume-Menu-Font-Map** (1List* :Default FONTS:HL10B))

(1defmethod* (debugger-frame :history) ()
  inspect-history-window
)

(defmethod (debugger-frame :after :expose) (&rest ignore)
"Put in a hook so that non in-constraint inferiors are exposed as appropriate
 when we are.
"
  (tv:Make-Sure-Right-Windows-Are-Exposed self)
)

(1defmethod* (debugger-frame :panes-list) (io-buf)
  (list 
    `(lisp-window debugger-lisp-listener-pane :label nil
		  :font-map ,2*lisp-window-font-map**
		  :io-buffer ,io-buf)
    `(args-window gray-debugger-text-scroll-pane :label nil
		  :font-map ,2*args-window-font-map**
      :io-buffer ,io-buf)
    `(locals-window gray-debugger-thermometer-text-scroll-pane :label nil
		    :font-map ,2*locals-window-font-map**
      :io-buffer ,io-buf)
    `(stack-window stack-scroll-pane :label nil
		   :font-map ,2*stack-window-font-map**
		   :io-buffer ,io-buf)
    `(command-menu-window debugger-menu-pane :io-buffer ,io-buf :font-map 
			  ,2*command-menu-font-map**)
    `(resume-menu-window debugger-menu-pane :io-buffer ,io-buf :font-map 
			 ,2*resume-menu-font-map**)
    `(inspect-window debugger-inspect-pane :io-buffer ,io-buf
		     :font-map ,tv:*inspector-font-map* 
		     :label fonts:hl10b)
    `(inspect-history-window
       2debugger-history-pane*
       :font-map ,(list (first tv:*inspector-font-map*))
       :io-buffer ,io-buf)
  )
)

(1defvar* 2*All-Window-Debugger-Constraints**
       `(,#'(Lambda (window)
	      (1ignore* window)
	      (tv:Make-Inspector-Constraint
		:Menu-String "Normal"
	        :Menu-Doc-String "Normal Configuration."
	        :Number-Of-Inspectors 1
		:Constraint
	       `(debugger-configuration
		 (inspect-window args-locals stack-window menu-history
				 lisp-window
		 )
		 ((menu-history :horizontal (5 :lines command-menu-window)
		   (command-menu-window resume-menu-window
		    inspect-history-window
		   )
		   ((command-menu-window :ask :pane-size))
		   ((resume-menu-window :ask :pane-size))
		   ((inspect-history-window :even)))
		  )
		  ((args-locals :Horizontal (6 :lines args-window)
		    (args-window locals-window)
		    ((args-window :even) (locals-window :even)))
		  )
		  ((lisp-window 7 :lines))
		  ((inspect-window 0.45s0) (stack-window 0.55s0)))
	       )
	     )
	  ,#'(lambda (window)
	      (1ignore* window)
	      (tv:Make-Inspector-Constraint
		:Menu-String "Stepper"
	        :Menu-Doc-String "Configuration for using the stepper."
	        :Number-Of-Inspectors 1
		:Constraint
		`(step-configuration
		  (stack-window menu-args-locals lisp-window)
		   ((menu-args-locals :horizontal
		     (11 :lines command-menu-window)
		     (command-menus args-window locals-window)
		     ((command-menus :vertical
		       (17 :characters command-menu-window)
		       (command-menu-window resume-menu-window)
		       ((command-menu-window :even) (resume-menu-window :even))
		      )
		     )
		     ((args-window :even) (locals-window :even))
		    )
		   )
		   ((lisp-window 7 :lines))
		   ((stack-window :even))
		  )
	      )
	    )
	 )
)

(defmethod (debugger-frame :get-constraints) ()
"Gets the constraints for the window-debugger.
 This was abstracted from the :before :init method.
"
  (mapcar #'(lambda (item)
	      (tv:Inspector-Constraint-Constraint (funcall item self))
	    )
	    2*All-Window-Debugger-Constraints**
  )
)

(defmethod (debugger-frame :before :init) (ignore)
  (unless (and (boundp-in-instance self 'tv:panes) tv:panes)
    (let ((io-buf (tv:make-default-io-buffer)))
      (setq tv:panes (1send* self :panes-list io-buf))
      (setq tv:constraints (send self :get-constraints))
    )
  )
)

;;;RDA: 1-May-89: Add this
(defvar *debugger-frame-default-edges* nil
  "If non-NIL, edges used by default when creating NEW-DEBUGGER-FRAMEs."
)

(1defmethod* (2New-Debugger-Frame* :Panes-List) (io-buf)
  (1list* 
    `(lisp-window debugger-lisp-listener-pane :Label nil
		  :Font-Map ,2*Lisp-Window-Font-Map** :Io-Buffer ,io-buf)
    `(args-window 2L2-Gray-Debugger-Text-Scroll-Pane* :Label nil
		  :Font-Map ,2*Args-Window-Font-Map**
		  :Io-Buffer ,io-buf)
    `(locals-window 2L2-Gray-Debugger-Thermometer-Text-Scroll-Pane* :Label nil
		    :Font-Map ,2*Locals-Window-Font-Map**
		    :Io-Buffer ,io-buf)
    `(stack-window 2L2-Stack-Scroll-Pane*
		   :Font-Map ,2*Stack-Window-Font-Map**
		   :Label nil :Io-Buffer ,io-buf)
    `(command-menu-window debugger-menu-pane :Io-Buffer ,io-buf :Font-Map 
			  ,2*Command-Menu-Font-Map**)
    `(Resume-menu-window debugger-menu-pane :Io-Buffer ,io-buf :Font-Map 
			 ,2*Resume-Menu-Font-Map**)
    `(Inspect-window 2New-Debugger-Inspect-Pane* :Io-Buffer ,io-buf
		     :Font-Map ,tv:*inspector-font-map* 
		     :Label fonts:hl10b)
    `(inspect-history-window
       2L2-Debugger-History-Pane*
       :Font-Map ,(1list* (1first* tv:*inspector-font-map*))
       :Io-Buffer ,io-buf)
  )
)

(1defmethod* (2New-Debugger-Frame* :Before :Init) (init-plist-pointer)
  ;;RDA: 1-May-89: Add this and change from IGNORE in arglist
  (1when* (1and* 2*Debugger-Frame-Default-Edges**
	     (1not* (1member* :Edges (1contents* init-plist-pointer) :Test #'1eq*))
	)
    (1nconc* (1contents* init-plist-pointer)
	   `(:Edges ,2*Debugger-Frame-Default-Edges**)
    )
  )
  (1unless* (1and* (1boundp-in-instance* self 'tv:panes) tv:panes)
    (1let* ((io-buf (tv:make-default-io-buffer)))
         (1setq* tv:panes (1send* self :Panes-List io-buf))
	 (1setq* tv:constraints (1send* self :Get-Constraints))
    )
  )
)


(1defmethod* (new-DEBUGGER-FRAME :AROUND :HANDLE-UNKNOWN-INPUT) (cont mt IGNORE)
  (LET (operation value window list (sg *error-sg*))
    (WHEN (LISTP ucl:kbd-input)
      (SETQ list ucl:kbd-input
            OPERATION (FIRST list)
            VALUE (SECOND list)
            WINDOW (THIRD list))
      (WHEN (NOT (MEMBER OPERATION '(:LINE-AREA :MOUSE-BUTTON)
			 :TEST (FUNCTION EQ)))
        (IF (eql (int-char (FOURTH LIST)) #\MOUSE-L)
            (SETQ OPERATION :INSPECT)
            (IF (SEND *WINDOW-DEBUGGER* :INSPECT-WINDOW-P WINDOW)
                (SETQ OPERATION :VALUE
                      VALUE (TV::INSPECT-REAL-VALUE LIST))))))
    (IF (NOT (MEMBER OPERATION
		'(:LINE-AREA :INSPECT :VALUE :FUNCTION STACK-FRAME SPECIAL ARG 
			     LOCAL special-local special-arg) :TEST (FUNCTION EQ)))
        (FUNCALL-WITH-MAPPING-TABLE cont mt :handle-unknown-input)
        (CASE operation
	  (:LINE-AREA
	   (UNLESS (SEND *window-debugger* :inspect-window-p window)
	     ;1see above comments!*
	     (SETQ *CURRENT-FRAME* VALUE)
	     (SEND *WINDOW-DEBUGGER* :SETUP-FRAME SG *CURRENT-FRAME*)))
	  (:INSPECT
	   (IF (SEND *WINDOW-DEBUGGER* :INSPECT-WINDOW-P window)
	       (case (FOURTH UCL::KBD-INPUT)
		 (#\MOUSE-L-2 (SEND SELF :INSPECT-INFO-LEFT-2-CLICK))
		 (otherwise (let ((ivalue (TV::INSPECT-REAL-VALUE LIST)))
			      (if (and (not tv:*debugging?*)
				       (typep ivalue 'tv:inspection-data)
				       (operation-handled-p ivalue
							    :handle-mouse-click)
				       (1catch-error*
					 (progn (send ivalue
						      :Handle-Mouse-Click
						      ucl:kbd-input
						      *WINDOW-DEBUGGER*) t) nil)
				       )
				  nil
				  (SEND *WINDOW-DEBUGGER* :Inspect-Object
					ivalue)))))
	       (SEND *window-debugger* :inspect-object
		     (CASE (FIRST list)
		       (:Menu
			(EQ (SEND (FOURTH list) :EXECUTE (SECOND list)) T))
		       (STACK-FRAME
			(LIST-STACK-FRAME-FUNCTION-AND-ARGS *ERROR-SG*
							    (SECOND list)))
		       (:LINE-AREA
			(LIST-STACK-FRAME-FUNCTION-AND-ARGS *ERROR-SG*
							    (SECOND list)))
		       ((SPECIAL ARG LOCAL)  (FIRST (SECOND list)))
		       ((:VALUE :Function special-local) (SECOND list))
		       ((special-arg) (1first* (SECOND list)))
		       (otherwise nil))))) ;;; Be safe.
	  ((LIST :VALUE :FUNCTION STACK-FRAME SPECIAL ARG LOCAL special-arg special-local)
	   (Setq +++ ++
		 ++  +)
	   (COND
	     ((MEMBER OPERATION '(SPECIAL ARG LOCAL) :TEST (FUNCTION EQ))
	      (COND
		((MEMBER OPERATION '(ARG LOCAL) :TEST (FUNCTION EQ))
		 (PRIN1 (FIRST VALUE))
		 (LET ((IDX (SECOND VALUE)))
		   (IF (NOT (NUMBERP IDX))
		       (AND (EQUALP IDX "Rest arg")
			    (SETQ VALUE (SG-REST-ARG-VALUE SG *CURRENT-FRAME*)))
		       (PROGN
			 (LET ((RP (SG-REGULAR-PDL SG)))
			   (SETQ +
				 (aloc rp
				       (+ idx
					  (if (eq operation 'arg) 
					      (sys:rp-argument-offset
						sg rp *current-frame*)
					      (sys:rp-local-offset
						sg rp *current-frame*))))))
			 (SETQ VALUE (CAR +))))))
		(T (SETQ + (PRIN1 VALUE))
		   (SETQ VALUE (SYMBOL-VALUE VALUE))))
	      (TERPRI))
	     ((EQ OPERATION 'STACK-FRAME)
	      (SETQ VALUE (STACK-FRAME-INTO-LIST VALUE SG)))
	     ((eql (FOURTH UCL::KBD-INPUT) #\MOUSE-L-2)
	      (SEND SELF :INSPECT-INFO-LEFT-2-CLICK))
	     ((let ((ivalue (TV::INSPECT-REAL-VALUE LIST)))
		(and (typep ivalue 'tv:inspection-data)
		     (operation-handled-p ivalue :handle-mouse-click)
		     (1catch-error*
		       (progn (send ivalue :handle-mouse-click ucl:kbd-input
				    *WINDOW-DEBUGGER*) t) nil)
		     )
		)
	      )
	     )
	   (SEND *terminal-io* :fresh-line)
	   (SETQ *** **
		 **  *
		 *   (if (typep value 'tv:inspection-data)
			 (send value :Send-If-Handles :middle-button-result)
			 value))
	   (if (not (equal #\mouse-l-2 (fourth ucl:kbd-input))) (print *))
	   (SEND SELF :handle-prompt))))))

(putprop :function 'second 'tv:value-function)

(DEFMETHOD 4(*new-DEBUGGER-FRAME4 :INSPECT-THING*)
           (TYPE THING &OPTIONAL (AUX-DATA NIL AUX-SUPPLIED?))
  (LET ((INSPECTED-THING
	 (tv:INSPECT-REAL-VALUE
	  `(:VALUE
	    ,(IF AUX-SUPPLIED?
	       (tv:ALLOCATE-DATA TYPE THING AUX-DATA)
	       (tv:ALLOCATE-DATA TYPE THING))
	    ,inspect-history-window))))
    (SEND *WINDOW-DEBUGGER* :INSPECT-OBJECT inspected-thing)))

(defmethod (new-DEBUGGER-FRAME :inspect-info-left-2-click)
	   (&optional something)
  (let ((thing (if something
		   something
		   (tv:inspect-real-value ucl:kbd-input)
	       )
	)
       )
       (multiple-value-bind (real-thing inspect-p)
	   (tv:map-into-show-x thing)
	 (1if* inspect-p
	     (SEND *WINDOW-DEBUGGER* :INSPECT-OBJECT real-thing)
	     nil
	 )
       )
  )
)

(defmethod (new-DEBUGGER-FRAME :inspection-data-active?) ()
  t
)

(install-window-debugger-commands)

;(compile-flavor-methods l2-debugger-who-line-mixin
;			l2-gray-debugger-text-scroll-pane
;			l2-gray-debugger-thermometer-text-scroll-pane
;			l2-stack-scroll-pane
;			l2-debugger-history-pane
;			new-debugger-inspect-pane
;			new-debugger-frame
;)