;;; -*- Mode:Common-Lisp; Package:EH; Base:8; 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;; ** (c) Copyright 1980 Massachusetts Institute of Technology **Ï*

;;;Record of changes
;;;Ï1-----------------------------------------------------------------------------------------------Ï*
;;;     WHEN   WHO Ï1   Ï*PATCH   Ï1     Ï*WHAT
;;;  11-15-88   LG    5-03	:KILL a window debugger when ENDed rather than :DEACTIVATE.
;;;  07-11-88 Ï1  Ï*clm for may  	Modified COMW-ARGLIST to look at BOTH values catch-error returns.
;;; Ï1  Ï*4/6/89    jlm   	Ï1             Ï*changed reference to PACKAGE to *PACKAGE* in 
;;;      Ï1                                      Ï*(DEFMETHOD (DEBUGGER-FRAME :AROUND :FETCH-AND-EXECUTE)
;Ï1--------------------------------------------------------------------------------------------------Ï*

(DEFVAR Ï4*numeric-arg*Ï* 1 
  "Ï2The numeric argument passed to the commandsÏ*")

(DEFFLAVOR Ï4debugger-who-line-mixinÏ* 
           ((normal-mouse-doc '(:mouse-l-1 "Ï3Inspect selected object.Ï*"
                                :mouse-m-1 "Ï3Set * to object; Echo object in interaction pane.Ï*")))
           ()
  (:documentation :combination "Ï3A flavor to mix into debugger panes to get who line documentation.Ï*"))

(DEFMETHOD Ï4(debugger-who-line-mixin :who-line-documentation-stringÏ*) ()
  "Ï2Who line documentation for the stack, args, locals, history and inspection panes.Ï*"
  (LET*
    ((frame (SEND self :superior)) (interactor (SEND frame :get-pane 'lisp-window)))
    (OR (SEND frame :who-line-doc-string-overide)
	(IF (SEND frame :doing-typein-p)
	    (SEND interactor :who-line-documentation-string)
	    (MULTIPLE-VALUE-BIND (x y) ;Ï1; get mouse positionÏ*
		(tv:sheet-calculate-offsets self tv:mouse-sheet)
	      (SETQ x (- system:mouse-x x)
		    y (- system:mouse-y y))
	      (MULTIPLE-VALUE-BIND (item item-type)
		  (SEND self :mouse-sensitive-item x y)
		(COND ((NOT (OR item item-type))
		       '(:mouse-r-1 "Ï3Menu of all window-based debugger commandsÏ*"))
		      (t
                       normal-mouse-doc))))))))

(DEFMETHOD Ï4(debugger-who-line-mixin :line-area-mouse-documentationÏ*) ()
  "Ï2Line area documentation for the history and stack pane.Ï*"
  (OR (SEND (SEND self :superior) :who-line-doc-string-overide)
      (IF (TYPEP self 'debugger-history-pane)
          normal-mouse-doc
          '(:mouse-any "Ï3Select the stack frame the mouse is pointing at.Ï*"))))

(DEFFLAVOR Ï4debugger-lisp-listener-paneÏ*
           nil
           (ucl::command-and-lisp-typein-window tv:interaction-pane)
           (:documentation :combination
                           "Ï3The read-eval-print window in the window-based debuggerÏ*"))
 
(DEFMETHOD Ï4(debugger-lisp-listener-pane :around :who-line-documentation-stringÏ*)
 (cont mt ignore)
 "Ï2Check for who line documentation overide done by commands.Ï*"
 (OR (SEND (SEND self :superior) :who-line-doc-string-overide)
     (IF (SEND (SEND self :superior) :doing-typein-p)
         (FUNCALL-WITH-MAPPING-TABLE cont mt :who-line-documentation-string)
         '(:mouse-r-1 "Ï3Menu of all window-based debugger commandsÏ*"))))

(DEFFLAVOR Ï4debugger-text-scroll-paneÏ*
           nil
           (tv:function-text-scroll-window tv:mouse-sensitive-text-scroll-window
                                           ;Ï1TV:FLASHY-SCROLLING-MIXINÏ*
                                           tv:stream-mixin
                                           tv:select-mixin
                                           tv:borders-mixin
                                           tv:top-label-mixin
                                           w:scroll-bar-mixin
                                           ;Ï1TV:BASIC-SCROLL-BARÏ*
                                           ;Ï1TV::MARGIN-SCROLLING-WITH-FLASHY-SCROLLING-MIXINÏ*
                                           ;Ï1TV:MARGIN-SCROLL-MIXINÏ*
                                           tv:margin-region-mixin
                                           ;Ï1TV:MOUSE-SENSITIVE-TEXT-SCROLL-WINDOWÏ*
                                           tv:delay-notification-mixin
                                           w:graphics-mixin 
                                           w:minimum-window)
           (:default-init-plist
             :scroll-bar-draw-edge-p t)
           (:documentation :combination "Ï3Scroll windows for the window-based debuggerÏ*"))

(DEFFLAVOR Ï4gray-debugger-text-scroll-paneÏ*
           nil
           (debugger-who-line-mixin tv:text-scroll-window-empty-gray-hack
                                    debugger-text-scroll-pane)
           (:documentation :combination "Ï3Args window in window-based debuggerÏ*"))

(DEFFLAVOR Ï4gray-debugger-thermometer-text-scroll-paneÏ*
           nil
           (debugger-who-line-mixin
	    ;Ï1TV:BASIC-SCROLL-BAR      ;replaced by w:scroll-bar-mixin in parent flavorÏ*
	    gray-debugger-text-scroll-pane)
           (:documentation :combination "Ï3Locals window in window-based debuggerÏ*"))

(DEFFLAVOR Ï4stack-scroll-paneÏ*
           ((*print-length* *error-print-length*) (*print-level* *error-print-level*))
           (debugger-who-line-mixin tv:current-item-mixin
                                    ;Ï1TV:FLASHY-MARGIN-SCROLLING-MIXINÏ*
                                    ;Ï1TV:FUNCTION-TEXT-SCROLL-WINDOWÏ*
                                    tv:line-area-mouse-sensitive-text-scroll-mixin
                                    ;Ï1TV:MOUSE-SENSITIVE-TEXT-SCROLL-WINDOWÏ*
                                    ;Ï1TV:MARGIN-REGION-MIXINÏ*
                                    debugger-text-scroll-pane)
           :special-instance-variables
           (:documentation :combination "Ï3Stack window in the window-based debuggerÏ*"))

;Ï1 TAC 08-04-89 - this flavor is redefined later in GENERAL-INSPECT-DEBUGGER Ï*
;Ï1                  it requires some things that are not defined until GENERAL-INSPECTOR is defined.Ï*
(DEFFLAVOR Ï4debugger-history-paneÏ*
           nil
           (debugger-who-line-mixin tv::inspect-history-window))  ;Ï1-PANE-WITH-MARGIN-SCROLLING))Ï*

(DEFFLAVOR Ï4debugger-inspect-paneÏ* nil (debugger-who-line-mixin tv::inspect-pane))

(DEFFLAVOR Ï4debugger-menu-paneÏ*
           nil
           (w:menu)
           (:default-init-plist
	     :scrolling-p nil
	     :command-menu t
	     :dynamic t)
           (:documentation :combination "Ï3UCL menus need dynamic item list mixin.Ï*"))

;Ï1; This needs to go in the Error Handler so Leaving-Error-Handler can use it also.Ï*
(DEFUN Ï4more-window-debuggers-pÏ* ()
  (DOLIST (x (tv::selectable-windows tv:mouse-sheet))
    (WHEN (TYPEP (SECOND x) 'debugger-frame) (RETURN t))))

(DEFVAR Ï4*window-debugger*Ï* nil "Ï2Bound in error handler stack group to the current window-based debugger frame.Ï*")
;Ï1(DEFVAR *ERROR-SG* NIL "The erring stack group.")Ï*
;Ï1(DEFVAR *ERROR-OBJECT* NIL "The error object for this erring stack group.")Ï*

;Ï1; This function is necessary because when you abort out of the w-d, it throws out of the stack-group, whichÏ*
;Ï1; avoids doing the clean-up forms of unwind-protect and the like. Without this the selection substitutes neverÏ*
;Ï1; get reset and everything's screwed up. Also the w-d will hang around on the system menu and system keys.Ï*
(DEFUN Ï4clean-up-window-debuggerÏ* ()
  "Ï2This will clean up after the window-debugger. If it is the only existing window-debugger, it will
 remove it from the system menu and the system keys. It also resets the selection substitutes.Ï*"
  (UNLESS (more-window-debuggers-p)
    (tv:remove-system-key (CHAR-INT #\W))
    (tv::delete-from-system-menu-column :debug "Ï3DebuggerÏ*"))
  (LET ((tv-cur-win (SEND *window-debugger* :tv-current-window))
        (tv-old-sub (SEND *window-debugger* :tv-old-subst)))
  (tv:delaying-screen-management (WHEN tv-cur-win
                                       (SEND tv-cur-win :set-selection-substitute tv-old-sub))
                                     (LET ((tv::.flag. (tv:sheet-me-or-my-kid-p tv:selected-window
                                                                                *window-debugger*)))
                                       (SEND *window-debugger* :kill)
                                       (AND tv-cur-win
                                            tv::.flag.
                                            (SEND tv-cur-win :select nil))))))

;Ï1; This function is how the regular debugger enters the window-based debugger.Ï*
(DEFUN Ï4com-window-debuggerÏ* (sg ete) 
  "Ï2Use a window-based debugger to debug the stack.Ï*"
  (IF (EQ *terminal-io* sys:cold-load-stream) ;Ï1; sys: is tempÏ*
   (FORMAT t
    "Ï3~&The window-based debugger cannot be invoked since we are using the cold load stream.Ï*")
   (tv:remove-system-key (CHAR-INT #\W))
   (tv:add-system-key (CHAR-INT #\W) 'debugger-frame
                      "Ï3Window-based Debugger - debug a program with menus and mouse interaction.Ï*"
                      nil)
   (tv::delete-from-system-menu-column :debug "Ï3DebuggerÏ*")	;Ï1; In case one is already out thereÏ*
   (tv::add-to-system-menu-column :debug "Ï3DebuggerÏ*"
     '(LET ((w (tv:find-window-of-flavor 'debugger-frame)))
        (COND (w
               (SEND w :select)
               (SEND w :update-print-info))   ;Ï1!Ï*
              (t (BEEP))))
     "Ï3Select a Window-based Debugger Frame.Ï*")
;Ï1!   (tv:set-print-info)      ;Make sure *inspect-print-base*, etc. is correctÏ*
   (USING-RESOURCE (window debugger-frame tv:default-screen)
     (SEND window :set-sensitive-item-types '(:value :function stack-frame))
     (UNWIND-PROTECT 
	 (window-command-loop sg ete window)
       (UNLESS (more-window-debuggers-p)
    (tv:remove-system-key (CHAR-INT #\W))
    (tv::delete-from-system-menu-column :debug "Ï3DebuggerÏ*"))))))

;Ï1; The following code can be removed when the regular debugger's codeÏ*
;Ï1; is updated to use "*window-debugger*" instead of error-handler-window,Ï*
;Ï1; and "com-window-debugger" replaces "com-window-error-handler".Ï*
;Ï1(DEFVAR ERROR-HANDLER-WINDOW)Ï*
;Ï1(FORWARD-VALUE-CELL 'ERROR-HANDLER-WINDOW '*WINDOW-DEBUGGER*)Ï*
;Ï1(DEFF COM-WINDOW-ERROR-HANDLER 'COM-WINDOW-DEBUGGER)Ï*

;Ï1; change SYS:DEBUG-UTILITIES;WINDOW-DEBUG.LISP#205 to not use AP but FRAME Ï*
;Ï1; and to reference args and locals in reg pdl correctlyÏ*

(DEFUN Ï4window-command-loopÏ* (*error-sg* *error-object* *window-debugger*)
  "Ï2This function calls the UCL command loop.Ï*"
  (LET ((*evalhook* nil)
        (*nopoint nil)
	(*print-pretty* nil)
	(*print-array*  *print-array*)     ;Ï1!Ï*
	(*print-circle* *print-circle*)    ;Ï1!Ï*
	(*print-radix*  *print-radix*)     ;Ï1!Ï*
	(*print-base*   *print-base*)      ;Ï1!Ï*
	(*read-base*    *read-base*)       ;Ï1!Ï*
	(*print-level*  *print-level*)     ;Ï1!Ï*
	(*print-length* *print-length*)    ;Ï1!Ï*
        (*package* *package*)   
        (*window-debugger-old-window* t)
        (*terminal-io* (SEND *window-debugger* :lisp-window))
	(ucl::*default-top-level-function-execute-specials* '(*terminal-io*))
	(ucl::*default-top-level-symbols-execute-specials* '(*terminal-io*))
	(ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg*))  ;Ï1; Ï*ucl:*stack-group*))Ï1 Ï*;Ï1 TAC 09-02-89Ï*
        (tv-cur-win tv:selected-window)
        (tv-old-sub (AND tv:selected-window (SEND tv:selected-window :selection-substitute)))
        sexp pkg)
    (DECLARE (SPECIAL pkg sexp))
    (DECLARE (SPECIAL *print-array* *print-circle* *print-radix* *nopoint 
		      *print-base* *read-base* *print-level* *print-length*))
    (SEND *window-debugger* :setup-sg *error-sg* *current-frame*)     ;Ï1; this used to be inside the tv:window-call ???Ï*
    ;Ï1; We have to do our own selection substitute stuff here because <abort> throws out of the stack-group, leaving theÏ*
    ;Ï1; clean-up forms undone. CLEAN-UP-WINDOW-DEBUGGER will be called by LEAVING-ERROR-HANDLER in that case.Ï*
    (SEND *window-debugger* :set-tv-current-window tv-cur-win)
    (SEND *window-debugger* :set-tv-old-subst tv-old-sub)
    (UNWIND-PROTECT (PROGN (SEND *window-debugger* :select)
                           (WHEN tv-cur-win
                             (SEND tv-cur-win :set-selection-substitute *window-debugger*))
                           (SETQ *window-debugger-old-window* (OR tv-cur-win t))
                           (SEND *terminal-io* :clear-screen)
                           (SEND *terminal-io* :clear-input)
                           (LET ((+ (SYMEVAL-IN-STACK-GROUP '- *error-sg*))
                                 (* (SYMEVAL-IN-STACK-GROUP '* *error-sg*)))
                             (SEND *window-debugger* :command-loop)))
      (tv:delaying-screen-management (WHEN tv-cur-win
                                       (SEND tv-cur-win :set-selection-substitute tv-old-sub))
                                     (LET ((tv::.flag. (tv:sheet-me-or-my-kid-p tv:selected-window
                                                                                *window-debugger*)))
                                       (SEND *window-debugger* :kill)
                                       (AND tv-cur-win
                                            tv::.flag.
                                            (SEND tv-cur-win :select nil)))))))    

(DEFFLAVOR Ï4debugger-frameÏ*
           (inspect-window		    ;Ï1; Where the disassembled code goesÏ*
            inspect-history-window	    ;Ï1; History for the inspectorÏ*
            args-window			    ;Ï1; The argumentsÏ*
            locals-window		    ;Ï1; The localsÏ*
            stack-window		    ;Ï1; BacktraceÏ*
            lisp-window			    ;Ï1; read-eval-print loop windowÏ*
            frame-alist			    ;Ï1; Saved frame layoutÏ*
            tv-current-window              ;Ï1; window which called the w-d, for selection substitutesÏ*
            tv-old-subst                   ;Ï1; the original selection substitute of the window which called the w-dÏ*
	    resume-menu-window 
	    command-menu-window 
            (inspection-data-active? nil)
            (doing-typein-p nil)
            (who-line-doc-string-overide nil))
           (ucl::basic-command-loop tv:frame-dont-select-inferiors-with-mouse-mixin
                                    tv:bordered-constraint-frame
                                    tv:label-mixin)
  (:gettable-instance-variables lisp-window
                                         doing-typein-p
                                         who-line-doc-string-overide
                                         inspection-data-active? tv-current-window tv-old-subst)
           (:settable-instance-variables doing-typein-p who-line-doc-string-overide tv-current-window tv-old-subst
                                         inspection-data-active? tv-current-window tv-old-subst)
           (:default-init-plist :save-bits
                                t
                                :deexposed-typeout-action
                                :permit
                                :active-command-tables
                                '(window-debugger-general-cmd-table 
                                  window-debugger-stack-cmd-table 
                                  window-debugger-step-cmd-table 
                                  window-debugger-resume-cmd-table)
                                :all-command-tables
                                '(window-debugger-general-cmd-table 
                                  window-debugger-stack-cmd-table 
                                  window-debugger-step-cmd-table 
                                  window-debugger-resume-cmd-table)
                                :menu-panes
                                '((command-menu-window ucl-window-debugger-examine-menu) 
                                  (resume-menu-window ucl-window-debugger-resume-menu))
                                :typein-handler
                                :handle-typein-input
                                :basic-help
                                '(window-debugger-help-cmd))
           (:documentation :special-purpose "Ï3Controls layout of window-based debugger panesÏ*"))

;Ï1***************Ï*
;Ï1 TAC 08-04-89 - new definition of this in GENERAL-INSPECT-DEBUGGERÏ*
;Ï1(DEFMETHOD (DEBUGGER-FRAME :BEFORE :INIT) (IGNORE)Ï*

(DEFMETHOD Ï4(debugger-frame :before :exposeÏ*) (&rest ignore)
  "Ï2Necessary for the :ask :pane-size constraint for the menu.Ï*"
  (OR tv:exposed-p (SEND self :set-configuration (SEND self :configuration))))

(DEFMETHOD Ï4(debugger-frame :after :initÏ*) (IGNORE)
  "Ï2Set up pane bindings and select the interaction pane.Ï*"
  (WITH-SELF-VARIABLES-BOUND (DOLIST (pane  tv::internal-panes)
                               (SET (CAR pane) (CDR pane)))
                             (SEND self :select-pane lisp-window))
  (colorize-debugger-frame))

(DEFUN Ï4colorize-debugger-frameÏ* ()
  (DECLARE (:self-flavor debugger-frame))
  (SETF (tv::label-background tv::label) w:75%-gray-color)
  (SETF (tv:label-font tv::label) fonts:cptfontb)
  (LET ((cmd-pane (SEND self :get-pane 'command-menu-window))
	(resume-pane (SEND self :get-pane 'resume-menu-window)))
    (SETF (tv::sheet-background-color cmd-pane) w:33%-gray-color)
    (SETF (tv::sheet-background-color resume-pane) w:33%-gray-color)))

(DEFMETHOD Ï4(debugger-frame :update-print-infoÏ*) ()
  (DECLARE (SPECIAL *print-array* *print-circle* *print-radix* *nopoint 
		    *print-base* *read-base* *print-level* *print-length*))
  (SETQ *print-array*  nil)
  (SETQ *print-circle* t)      	;Ï1; default of T so recursive structures printÏ*
  (SETQ *print-level*  8.)
  (SETQ *print-length* 1000.))

(DEFMETHOD Ï4(debugger-frame :designate-io-streamsÏ*) ()
  "Ï2Redefine this UCL method so that the UCL does not rebind the IO.
   Also queue up print-error-message command.Ï*"
  (SEND *terminal-io* :force-kbd-input #\c-l)
  (SETQ *standard-output* *terminal-io*)
  (SETQ *standard-input* *terminal-io*)
  (SETQ *query-io* *terminal-io*)
  (SETQ *error-output* *terminal-io*)
  (SETQ *debug-io* *terminal-io*))

(DEFMETHOD Ï4(debugger-frame :around :handle-typein-inputÏ*) (cont mt ignore &optional 
                                                          (untyi-first-char? t))
  "Ï2Set a var to signal the who line methods we are doing typein.Ï*"
  (SEND *window-debugger* :set-doing-typein-p t)
  (UNWIND-PROTECT (FUNCALL-WITH-MAPPING-TABLE cont mt :handle-typein-input untyi-first-char?)
                  (SEND *window-debugger* :set-doing-typein-p nil)))

(DEFMETHOD Ï4(debugger-frame :around :fetch-and-executeÏ*) (cont mt ignore)
  "Ï2Set a couple of variables and check for command aborts.Ï*"
  (DECLARE (SPECIAL pkg))
  (SETQ pkg (SYMEVAL-IN-STACK-GROUP '*package* *error-sg*))		;Ï1; jlm 4/6/89Ï*
  ;Ï1(SETQ *PACKAGE* (IF (TYPEP PKG 'PACKAGE) PKG (FIND-PACKAGE "USER")))Ï*
  (SETQ *package* (IF (PACKAGEP pkg) pkg (FIND-PACKAGE "Ï3USERÏ*")))
  (CATCH 'quit (FUNCALL-WITH-MAPPING-TABLE cont mt :fetch-and-execute)))

;Ï1; line-area should delete and set to *. Need to write update-panes and replace :line-area code. also move it beforeÏ*
;Ï1; the case operation.Ï*
;Ï1              (:LINE-AREAÏ*
;Ï1                (COND ((SEND *WINDOW-DEBUGGER* :INSPECT-WINDOW-P window)Ï*
;Ï1                       (COND ((= (fourth ucl::kbd-input) #\MOUSE-M)Ï*
;Ï1                              ;; Delete from line areaÏ*
;Ï1                              (SEND inspect-HISTORY-window :FLUSH-OBJECT (tv:INSPECT-REAL-VALUE UCL::KBD-INPUT))Ï*
;Ï1                              (SEND inspect-HISTORY-window :SET-CACHE NIL)Ï*
;Ï1                              (update-panes????))Ï*
;Ï1                             ((EQ (INT-CHAR (FOURTH list)) #\MOUSE-L)Ï*
;Ï1                              (SETQ OPERATION :VALUEÏ*
;Ï1                              VALUE (TV::INSPECT-REAL-VALUE LIST))))Ï*
;Ï1                      (tÏ*
;Ï1                        (SETQ *CURRENT-FRAME* VALUE)Ï*
;Ï1                        (SEND *WINDOW-DEBUGGER* :SETUP-FRAME SG *CURRENT-FRAME*))))Ï*

;Ï1; change SYS:DEBUG-UTILITIES;WINDOW-DEBUG.LISP#205 to not use AP but FRAME Ï*
;Ï1; and to reference args and locals in reg pdl correctlyÏ*
;Ï1; Intercept blips.  May want to redo this with the UCL blip processing when it is available.Ï*
(DEFMETHOD Ï4(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)      ;Ï1.Ï*
            (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) :test (FUNCTION eq)))
        (FUNCALL-WITH-MAPPING-TABLE cont mt :handle-unknown-input)
        (CASE operation
              (:line-area
                (UNLESS (SEND *window-debugger* :inspect-window-p window)   ;Ï1; see above comments!Ï*
                        (SETQ *current-frame* value)
 ;Ï1; TAC 09-02-89Ï*	       Ï1  Ï*;Ï1; Ï*(SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
			(SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*))
                        (SEND *window-debugger* :setup-frame sg *current-frame*)))
              (:inspect
         (IF (SEND *window-debugger* :inspect-window-p window)
             (SEND *window-debugger* :inspect-object (tv::inspect-real-value list))
             (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)  (SECOND list))))))
              ((LIST :value :function stack-frame special arg 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 "Ï3Rest 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*))))))
                                                      ;Ï1  old way of looking for args and locals:Ï*
                                                      ;Ï1    Ï*			Ï1 (ALOC RPÏ*
                                                      ;			Ï1       (+ *CURRENT-FRAME* IDXÏ*
                                                      ;				Ï1  (IF (EQ OPERATION 'ARG) 1Ï*
                                                      ;				Ï1    (RP-LOCAL-BLOCK-ORIGINÏ*
                                                      ;				Ï1      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))))
               (SEND *terminal-io* :fresh-line)
               (SETQ *** **
                     **  *
                     *   (PRIN1 value))
               (SEND self :handle-prompt))))))

(DEFCOMMAND Ï4comw-what-error-cmdÏ*
            nil
            '(:description  "Ï3Re-print the error message for the current error.Ï*"
              :names "Ï3ErrorÏ*"
              :keys (#\c-l))
            (SEND *terminal-io* :clear-screen)
            (comw-what-error *error-sg* *error-object*)
            (SEND *window-debugger* :handle-prompt))

(DEFCOMMAND Ï4bug-report-cmdÏ*
            nil
            '(:description  
              "Ï3Mail a bug report containing the error message and a backtrace of the stack.Ï*" 
              :names "Ï3ReportÏ*"
              :keys (#\c-m))
            (com-bug-report *error-sg* *error-object*))

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - new definition from DEVELOPMENT-TOOLS-CONSISTENCY-ENHANCEMENTS follows.Ï*
;Ï1(DEFCOMMAND COMW-ARGLIST-CMD NILÏ*

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - keystrokes are made compatible with zmacsÏ*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1 The Arglist command in the window debugger.Ï*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1; Redefine the arglist command so that it will take c-sh-a as a keyÏ*
;Ï1; assignment for compatibility with ZMacs.Ï*

(DEFCOMMAND Ï4comw-arglist-cmdÏ* nil
  '(:description "Ï3Display the argument list of a specified function.Ï*"
    :names "Ï3ArglistÏ*"
    :keys (#\c-a #\c-sh-a))
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select a function to apply Arglist to.Ï*")
   (UNWIND-PROTECT (comw-arglist *error-sg* *error-object*)
     (PROGN (SEND *window-debugger* :set-who-line-doc-string-overide nil)
	    (SEND *window-debugger* :handle-prompt))))
;Ï1-------------------------------------------------------------------------------Ï*

(DEFCOMMAND Ï4com-return-reinvocation-cmdÏ* nil
            '(:description  
              "Ï3Retry from the beginning of the function call represented by the current frame.Ï*"
               :names "Ï3RetryÏ*"
            :keys (#\c-m-r))
            (com-return-reinvocation *error-sg* *error-object*))

(DEFCOMMAND Ï4step-cmdÏ* nil
 (QUOTE
  (:description
     "Ï3Step from the current point of execution in the current frame (Resume from the current frame, and trap on entry to the next function call).Ï*"
     :names "Ï3StepÏ*"
     :keys (#\c-d)))
 (com-proceed-trap-on-call *error-sg* *error-object*))

(DEFCOMMAND Ï4stay-cmdÏ* nil
 (QUOTE
  (:description
     "Ï3Toggle the variable eh:*enter-window-debugger* to use the regular or window-based debugger.Ï*"
    :names "Ï3StayÏ*"
   :keys (#\h-s)))
 (FORMAT t "Ï3~&Setting eh:*enter-window-debugger* to ~S~%Ï*"
         (SETQ eh::*enter-window-debugger* (IF eh::*enter-window-debugger* nil :always)))
 (SEND *window-debugger* :handle-prompt))

(DEFCOMMAND Ï4toggle-config-cmdÏ* nil
 '(:description  
   "Ï3Toggle between the stepping configuration and the default debugging configuration.Ï*"  
   :names "Ï3ConfigÏ*"
   :keys (#\h-c))
 (LET ((current-cfg (SEND *window-debugger* :configuration)))
   (tv:delaying-screen-management (IF (EQUAL current-cfg 'debugger-configuration)
                                      (SEND *window-debugger*
                                            :set-configuration
                                            'step-configuration)
                                      (SEND *window-debugger*
                                            :set-configuration
                                            'debugger-configuration)))))

(DEFCOMMAND Ï4com-toggle-trap-on-call-cmdÏ* nil
   '(:description  "Ï3Toggle the flag that causes a trap on the next function call.Ï*" 
    :names "Ï3Bk NextÏ*"
    :keys (#\m-d))
   (com-toggle-trap-on-call *error-sg* *error-object*)
   (SEND *window-debugger* :handle-prompt))


(DEFCOMMAND Ï4com-toggle-frame-trap-on-exit-cmdÏ* nil
   (QUOTE
      (:description
         "Ï3Toggle the flag in the current frame that causes a trap on exit or throw through the frame.Ï*"
       :names "Ï3Bk ExitÏ*"
       :keys (#\c-x)))
   (com-toggle-frame-trap-on-exit *error-sg* *error-object*)
   (SEND *window-debugger* :handle-prompt))

(DEFVAR Ï4toggle-all-frames-switchÏ* nil
        "Ï2Used by the com-toggle-all-frames-trap-on-exit-cmd to record its last setting.Ï*")

(DEFCOMMAND Ï4com-toggle-all-frames-trap-on-exit-cmdÏ* nil
   (QUOTE (:description
	    "Ï3Toggle the flag causing a trap on exit or throw through the frame for the current frame and all outer frames.Ï*"
	   :names "Ï3Bk AllÏ*"
	   :keys (#\s-x)))
   (IF toggle-all-frames-switch
         (com-clear-all-frames-trap-on-exit *error-sg* *error-object*)
         (com-set-all-frames-trap-on-exit *error-sg* *error-object*))
   (SETQ toggle-all-frames-switch (NOT toggle-all-frames-switch)))

(DEFCOMMAND Ï4com-set-all-frames-trap-on-exit-cmdÏ* nil
   (QUOTE (:description
	    "Ï3Set the flag causing a trap on exit or throw through the frame for the current frame and all outer frames.Ï*"
	   :names "Ï3Set AllÏ*"
	   :keys (#\m-x)))
   (com-set-all-frames-trap-on-exit *error-sg* *error-object*)
   (SEND *window-debugger* :handle-prompt))

(DEFCOMMAND Ï4com-clear-all-frames-trap-on-exit-cmdÏ* nil
 (QUOTE
  (:description
     "Ï3Clear the flag causing a trap on exit or throw through the frame for the current frame and all outer frames.Ï*"
    :names "Ï3Clear AllÏ*"
   :keys (#\c-m-x)))
 (com-clear-all-frames-trap-on-exit *error-sg* *error-object*)
 (SEND *window-debugger* :handle-prompt))

(DEFCOMMAND Ï4comw-set-arg-cmdÏ* nil
   '(:description  "Ï3Modify an argument or local in the current frame.Ï*"
    :names "Ï3ModifyÏ*"
    :keys (#\c-m-a #\c-m-l))
   (SEND *window-debugger*
	 :set-who-line-doc-string-overide
	 "Ï3Select an argument or local to modify.Ï*")
   (UNWIND-PROTECT (comw-set-arg *error-sg* *error-object*)
      (PROGN (SEND *window-debugger*
		   :set-who-line-doc-string-overide
		   nil)
	     (SEND *window-debugger* :handle-prompt))))

(DEFCOMMAND Ï4comw-exit-cmdÏ* nil			;Ï1!Ï*
  '(:description  "Ï3Return to the regular debugger, but don't leave error context.Ï*" 
		  :names "Ï3EndÏ*"
		  :keys (#\End))
  (SEND *window-debugger* :quit))

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - new definition from DEVELOPMENT-TOOLS-CONSISTENCY-ENHANCEMENTS followsÏ*
;Ï1(DEFCOMMAND COMW-INSPECT-CMD NILÏ*

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - moved this code from DEVELOPMENT-TOOLS-CONSISTENCY-ENHANCEMENTSÏ*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1; Add key assignments to the inspect command in the debugger.Ï*

(DEFCOMMAND Ï4comw-inspect-cmdÏ* nil
 '(:description  "Ï3Inspect an object specified with keyboard or mouse.Ï*"
   :names "Ï3InspectÏ*" 
   :keys (#\c-sh-i #\M-sh-i #\c-i))
 (SEND *window-debugger* :set-who-line-doc-string-overide "Ï3Select an object to inspect.Ï*")
 (UNWIND-PROTECT
  (PROGN
   (comw-inspect *error-sg* *error-object*)
   (tv:delaying-screen-management
    (WHEN (EQUAL (SEND *window-debugger* :configuration) 'step-configuration)
      (SEND *window-debugger* :set-configuration 'debugger-configuration))))
  (PROGN (SEND *window-debugger* :set-who-line-doc-string-overide nil)
         (SEND *window-debugger* :handle-prompt))))
;Ï1-------------------------------------------------------------------------------Ï*

(DEFCOMMAND Ï4com-return-a-value-cmdÏ* ()
            '(:description  "Ï3Return a value as the result from the current frame.Ï*"
              :names "Ï3ReturnÏ*"
              :keys (#\c-r))
            (SEND *window-debugger*
                  :set-who-line-doc-string-overide
                  "Ï3Select an object to evaluate and return.Ï*")
            (UNWIND-PROTECT (com-return-a-value *error-sg* *error-object*)
                            (PROGN (SEND *window-debugger*
                                         :set-who-line-doc-string-overide
                                         nil)
                                   (SEND *window-debugger* :handle-prompt))))

(DEFCOMMAND Ï4com-top-level-throw-cmdÏ* nil
            '(:description  "Ï3Leave the debugger and abort the program.Ï*"  :names "Ï3AbortÏ*" 
              :keys (#\c-m-abort #\s-end))
            (com-top-level-throw *error-sg* *error-object*))

;Ï1---------------------------------------------------------------------------Ï*
;Ï1 TAC 08-01-89 - moved comw-search up near comw-search-cmd. Ï*
(DEFUN Ï4comw-searchÏ* (sg ignore)
  (LET (key frame)
    (FORMAT t "Ï3String to search for (end with RETURN):~%Ï*")
    (SETQ key (READ-LINE))
    (SETQ frame 
          (DO ((frame *current-frame* (sg-next-frame sg frame))
               (rp (sg-regular-pdl sg))
               (name))
              ((NULL frame) nil)
            (SETQ name (FUNCTION-NAME (rp-function-word rp frame)))
            (SETQ name (COND ((STRINGP name) name)
                             ((SYMBOLP name) (STRING name))
                             (t (FORMAT nil "Ï3~SÏ*" name))))
            (AND (SEARCH key name :test #'STRING-EQUAL) (RETURN frame))))
    (COND ((NULL frame)
           (FORMAT t "Ï3Search failed.~%Ï*"))
          (t
           (SETQ *current-frame* frame)
 ;Ï1; TAC 09-02-89Ï*  (SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	   (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*))
           (SEND *window-debugger* :setup-frame sg *current-frame*)))))

(DEFCOMMAND Ï4comw-search-cmdÏ* nil
            '(:description  
              "Ï3Search stack for a frame whose function's name contains a specified string.Ï*"  
              :names "Ï3SearchÏ*"
              :keys (#\c-s))
            (UNWIND-PROTECT (comw-search *error-sg* *error-object*)
                            (SEND *window-debugger* :handle-prompt)))
;Ï1------------------------------------------------------------------------------Ï*

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - comw-edit and comw-edit-cmd redefined  in DEVELOPMENT-TOOLS-CONSISTENCY-ENHANCEMENTSÏ*

;Ï1(DEFUN COMW-EDIT (IGNORE IGNORE)Ï*

;Ï1(DEFCOMMAND COMW-EDIT-CMD NILÏ*
;Ï1----------------------------------Ï*

(DEFCOMMAND Ï4com-proceed-cmdÏ* nil
   (QUOTE
      (:description
         "Ï3Attempt to proceed from the error using default proceed type.  R: Menu of available proceed types.Ï*"
         :names "Ï3ResumeÏ*"
         :keys (#\Resume)))
   (LET ((input ucl::kbd-input))
      (DECLARE (SPECIAL *error-object* ucl::kbd-input))
      (IF (AND (CONSP input)
	        (EQ (FIRST input) :menu)
	        (EQ (THIRD input) 4))
	 (comw-proceed *error-sg* *error-object*)
	 (com-proceed *error-sg* *error-object*))))

(DEFCOMMAND Ï4com-throw-cmdÏ* nil
   '(:description  "Ï3Throw a specified value to a specified tag.Ï*"
    :names "Ï3ThrowÏ*" 
    :keys (#\c-t))
   (SEND *window-debugger*
	 :set-who-line-doc-string-overide
	 "Ï3Select objects to evaluate for tag and value to throw.Ï*")
   (UNWIND-PROTECT (com-throw *error-sg* *error-object*)	       ;
      (PROGN (SEND *window-debugger*
		   :set-who-line-doc-string-overide
		   nil)
	     (SEND *window-debugger* :handle-prompt))))

;Ï1----------------------------------------------------------------Ï*
;Ï1 TAC 08-01-89 - being redefined Ï*

;Ï1(DEFUN WINDOW-DEBUGGER-HELP (&OPTIONAL IGNORE IGNORE)Ï*

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - new code from DEVELOPMENT-TOOLS-CONSISTENCY-ENHANCEMENTSÏ*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1 The window debugger Help command.  This used to be the document command.Ï*
;Ï1-------------------------------------------------------------------------------Ï*

(DEFUN Ï4window-debugger-helpÏ* (&optional ignore ignore)
  (DECLARE (SPECIAL *window-debugger*))
  (si:with-help-stream (window :label
                               "Ï3Help for Window-based debuggerÏ*"
                               :superior
                               tv:default-screen)
    (FORMAT window "
                                 WINDOW-BASED DEBUGGER HELP

----------------------------------------------------------------------------------------------
                                   *** INSPECTION PANE ***

     This pane displays the structure of the most recently inspected item.  By default
     the item inspected here is the selected stack frame.  To inspect other items here, 
     use the Inspect command or click Mouse-Left on them in this pane or 
     in the Inspection History Pane.

----------------------------------------------------------------------------------------------
             *** ARGS PANE ***                 |             *** LOCALS PANE ***
                                               |
     This pane displays the argument           |     This pane displays the local variable
     values for the currently selected         |     values and the special variable values
     frame if there are any.  Otherwise,       |     for the currently selected frame if
     this pane is gray.                        |     there are any.  Otherwise, this pane
                                               |     is gray.
                                               |
----------------------------------------------------------------------------------------------
                                      *** STACK PANE ***

     This pane displays the execution stack that contained the error.  The contents of the 
     above three panes are determined by the frame that is selected.  The selected frame is
     the frame in this pane with the small arrow pointing to it.

     To select another frame to see its args\/locals\/specials\/code use the up\/down
     commands or move the mouse cursor to where you want the new arrow to be.  Then click 
     Mouse-Left when the cursor changes back to the small arrow.

----------------------------------------------------------------------------------------------
*** MENU PANE ***    |                   *** INSPECTION HISTORY PANE ***
                     |
Click Mouse-Left     |     This pane maintains a history of objects that have appeared 
to select a          |     in the Inspection Pane.  To see these objects in the Inspection
command.             |     Pane again, click Mouse-Left on them here.
                     |
----------------------------------------------------------------------------------------------
                                    *** INTERACTION PANE ***

This pane is used to output messages and to evaluate Lisp forms.  Clicking Mouse-Left on
mouse-sensitive items within the Args, Locals, or Stack panes will print them out here and
will set * to these items.

----------------------------------------------------------------------------------------------



 ")
    (tv::show-all-commands-for-frame *window-debugger* window)))

(DEFCOMMAND Ï4window-debugger-help-cmdÏ* ()
            '(:description "Ï3Show documentation for each of the panes.Ï*"
			    :names "Ï3HelpÏ*"
			    :keys (#\c-help #\m-help))
             (window-debugger-help *error-sg* *error-object*))
;Ï1-----------------------------------------------------------------------------------Ï*

(DEFCOMMAND Ï4clear-screen-cmdÏ* ()            
            '(:description  "Ï3Clear Lisp interactor pane.Ï*"
              :names "Ï3Clear ScreenÏ*"
              :keys (#\Page))
            (SEND *terminal-io* :clear-screen))

(DEFCOMMAND Ï4up-stack-cmdÏ* (*numeric-arg* &aux items current-item item-idx)   ;Ï1!Ï*
            '(:description  "Ï3Move up the stack one frame.Ï*"
              :names "Ï3upÏ*"
              :keys (#\c-p #\ )
              :arguments (ucl:numeric-argument))
            (SETQ items (SEND (SEND *window-debugger* :get-pane 'stack-window) :items)
                  current-item (SEND (SEND *window-debugger* :get-pane 'stack-window)
                                     :current-item)
                  item-idx (DOTIMES (i  (ARRAY-ACTIVE-LENGTH items))
                    (WHEN (EQ (AREF items i) current-item)
                      (RETURN i)))
                  *numeric-arg* (IF (NULL *numeric-arg*) 1 *numeric-arg*))
            (IF (MINUSP (- item-idx *numeric-arg*))
                (BEEP)
                (PROGN (SETQ *current-frame* (AREF items (- item-idx *numeric-arg*)))
                       (SEND *window-debugger* :setup-frame *error-sg* *current-frame*)))
 ;Ï1; TAC 09-02-89Ï* (SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	    (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*)))

(DEFCOMMAND Ï4down-stack-cmdÏ* (*numeric-arg* &aux items current-item item-idx)
            '(:description  "Ï3Move down the stack one frame.Ï*"
              :names "Ï3DownÏ*"
              :keys (#\c-n #\þ)
              :arguments (ucl:numeric-argument))
            (SETQ items (SEND (SEND *window-debugger* :get-pane 'stack-window) :items)
                  current-item (SEND (SEND *window-debugger* :get-pane 'stack-window)
                                     :current-item)
                  item-idx (DOTIMES (i  (ARRAY-ACTIVE-LENGTH items))
                    (WHEN (EQ (AREF items i) current-item)
                      (RETURN i)))
                  *numeric-arg* (IF (NULL *numeric-arg*) 1 *numeric-arg*))
            (IF (>= (+ *numeric-arg* item-idx) (ARRAY-ACTIVE-LENGTH items))
                (BEEP)
                (PROGN (SETQ *current-frame* (AREF items (+ *numeric-arg* item-idx)))
                       (SEND *window-debugger* :setup-frame *error-sg* *current-frame*)))
 ;Ï1; TAC 09-02-89Ï* (SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	    (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*)))

(DEFCOMMAND Ï4top-stack-cmdÏ* (&aux items)
            '(:description  "Ï3Move to the top of the stack.Ï*"
              :names "Ï3TopÏ*"
              :keys (#\m-< #\h- ))
            (SETQ items (SEND (SEND *window-debugger* :get-pane 'stack-window) :items))
            (SETQ *current-frame* (AREF items 0))
            (SEND *window-debugger* :setup-frame *error-sg* *current-frame*)
 ;Ï1; TAC 09-02-89 Ï*(SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	    (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self eh:*error-sg* *current-frame*)))

(DEFCOMMAND Ï4bottom-stack-cmdÏ* (&aux items)
            '(:description  "Ï3Move to the bottom of the stack.Ï*"
              :names "Ï3bottomÏ*"
              :keys (#\m-> #\h-þ))
            (SETQ items (SEND (SEND *window-debugger* :get-pane 'stack-window) :items))
            (SETQ *current-frame* (AREF items (1- (ARRAY-ACTIVE-LENGTH items))))
            (SEND *window-debugger* :setup-frame *error-sg* *current-frame*)
 ;Ï1; TAC 09-02-89Ï* (SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	    (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*)))

(DEFCOMMAND Ï4page-up-stack-cmdÏ* ()
            '(:description  "Ï3Move up a page in the stack window.Ï*"
              :names "Ï3page upÏ*"
              :keys (#\m-v #\c- ))
            (SEND (SEND *window-debugger* :get-pane 'stack-window)
                  :scroll-relative
                  :top
                  :bottom)
;Ï1; TAC 09-02-89Ï*  (SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	    (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*)))

(DEFCOMMAND Ï4page-down-stack-cmdÏ* ()
	    '(:description  "Ï3Move down a page in the stack window.Ï*"
              :names "Ï3Page DownÏ*" 
              :keys (#\c-v #\c-þ))
            (SEND (SEND *window-debugger* :get-pane 'stack-window)
                  :scroll-relative
                  :bottom
                  :top)
;Ï1; TAC 09-02-89Ï* (SETF ucl:top-level-self (SYMEVAL-IN-STACK-GROUP 'self ucl:*stack-group* *current-frame*))
	    (SETF ucl::top-level-self (SYMEVAL-IN-STACK-GROUP 'self *error-sg* *current-frame*))) 

(DEFPARAMETER Ï4*window-debugger-all-commands-menu*Ï* nil "Ï2Holds a menu item list.Ï*")

(MAKE-COMMAND all-commands-menu-cmd
  '(:names "Ï3All cmdsÏ*"
    :keys #\Mouse-r-1
    :definition ucl::pop-up-command-menu
    :arguments ('*window-debugger-all-commands-menu*)))

(BUILD-COMMAND-TABLE 'window-debugger-general-cmd-table
                     'debugger-frame
                     '(comw-what-error-cmd comw-arglist-cmd comw-exit-cmd comw-inspect-cmd 
                       com-top-level-throw-cmd comw-edit-cmd window-debugger-help-cmd 
                       clear-screen-cmd bug-report-cmd all-commands-menu-cmd)
                     :init-options
                     '(:name "Ï3General window-based debugger commandsÏ*"))

(BUILD-COMMAND-TABLE 'window-debugger-stack-cmd-table
                     'debugger-frame
                     '(comw-search-cmd up-stack-cmd down-stack-cmd page-up-stack-cmd 
                       page-down-stack-cmd top-stack-cmd bottom-stack-cmd)
                     :init-options
                     '(:name "Ï3Commands for looking at the stackÏ*"))

(BUILD-COMMAND-TABLE 'window-debugger-step-cmd-table
                     'debugger-frame
                     '(step-cmd com-toggle-trap-on-call-cmd com-toggle-frame-trap-on-exit-cmd 
                       com-set-all-frames-trap-on-exit-cmd 
                       com-clear-all-frames-trap-on-exit-cmd 
                       com-toggle-all-frames-trap-on-exit-cmd toggle-config-cmd stay-cmd)
                     :init-options
                     '(:name "Ï3Commands for stepping through program executionÏ*"))

(BUILD-COMMAND-TABLE 'window-debugger-resume-cmd-table
                     'debugger-frame
                     '(com-return-reinvocation-cmd comw-set-arg-cmd com-return-a-value-cmd 
                       com-proceed-cmd com-throw-cmd)
                     :init-options
                     '(:name "Ï3Commands for resuming program executionÏ*"))
 
(BUILD-MENU 'ucl-window-debugger-examine-menu
            'debugger-frame
            :default-item-options
            '(:font fonts:cptfont)
            :item-list-order
            '(("Ï3ExamineÏ*" :font fonts:hl10b) comw-inspect-cmd window-debugger-help-cmd 
              comw-edit-cmd  comw-search-cmd bug-report-cmd comw-what-error-cmd 
              comw-arglist-cmd stay-cmd comw-set-arg-cmd ))


(BUILD-MENU 'ucl-window-debugger-resume-menu
            'debugger-frame
            :default-item-options
            '(:font fonts:cptfont)
            :item-list-order
            '(("Ï3ResumeÏ*" :font fonts:hl10b) com-toggle-trap-on-call-cmd 
              com-return-reinvocation-cmd com-toggle-frame-trap-on-exit-cmd com-proceed-cmd 
              com-toggle-all-frames-trap-on-exit-cmd com-return-a-value-cmd step-cmd 
              com-top-level-throw-cmd comw-exit-cmd))


(BUILD-MENU '*window-debugger-all-commands-menu*
            'debugger-frame
            :item-list-order
            '((comw-what-error-cmd :column "Ï3GeneralÏ*") (comw-arglist-cmd :column "Ï3GeneralÏ*") 
              (comw-exit-cmd :column "Ï3GeneralÏ*") (comw-inspect-cmd :column "Ï3GeneralÏ*") 
              (com-top-level-throw-cmd :column "Ï3GeneralÏ*") (comw-edit-cmd :column "Ï3GeneralÏ*") 
              (window-debugger-help-cmd :column "Ï3GeneralÏ*") (clear-screen-cmd :column "Ï3GeneralÏ*")
              (bug-report-cmd :column "Ï3GeneralÏ*") (comw-search-cmd :column "Ï3StackÏ*") 
              (up-stack-cmd :column "Ï3StackÏ*") (down-stack-cmd :column "Ï3StackÏ*") 
              (page-up-stack-cmd :column "Ï3StackÏ*") (page-down-stack-cmd :column "Ï3StackÏ*") 
              (top-stack-cmd :column "Ï3StackÏ*") (bottom-stack-cmd :column "Ï3StackÏ*") 
              (step-cmd :column "Ï3StepÏ*") (com-toggle-trap-on-call-cmd :column "Ï3StepÏ*") 
              (com-toggle-frame-trap-on-exit-cmd :column "Ï3StepÏ*") 
              (com-set-all-frames-trap-on-exit-cmd :column "Ï3StepÏ*") 
              (com-clear-all-frames-trap-on-exit-cmd :column "Ï3StepÏ*") 
              (com-toggle-all-frames-trap-on-exit-cmd :column "Ï3StepÏ*") 
              (toggle-config-cmd :column "Ï3StepÏ*") (stay-cmd :column "Ï3StepÏ*") 
              (com-return-reinvocation-cmd :column "Ï3ResumeÏ*") 
              (comw-set-arg-cmd :column "Ï3ResumeÏ*") (com-return-a-value-cmd :column "Ï3ResumeÏ*") 
              (com-proceed-cmd :column "Ï3ResumeÏ*") (com-throw-cmd :column "Ï3ResumeÏ*"))
            :column-list-order
            '(("Ï3GeneralÏ*" :font fonts:hl12b) ("Ï3StackÏ*" :font fonts:hl12b) 
              ("Ï3StepÏ*" :font fonts:hl12b) ("Ï3ResumeÏ*" :font fonts:hl12b)))




(DEFMETHOD Ï4(debugger-frame :inspect-window-pÏ*) (w) 
  (OR (EQ w inspect-history-window)
      (EQ w inspect-window)))

(DEFMETHOD Ï4(debugger-frame :selectÏ*) (&rest args)
  (APPLY lisp-window :select args)
  (SEND self :expose))

(DEFMETHOD Ï4(debugger-frame :deselectÏ*) (&rest args)
  (APPLY lisp-window :deselect args))

(DEFMETHOD Ï4(debugger-frame :name-for-selectionÏ*) ()
  tv:name)

(DEFMETHOD Ï4(debugger-frame :set-sensitive-item-typesÏ*) (val)
  (SEND args-window :set-sensitive-item-types val)
  (SEND locals-window :set-sensitive-item-types val)
  (SEND stack-window :set-sensitive-item-types val))

(DEFMETHOD Ï4(debugger-frame :sensitive-item-typesÏ*) ()
  (SEND locals-window :sensitive-item-types))

(DEFMETHOD Ï4(debugger-frame :inspect-objectÏ*) (thing)	   ;Ï1.Ï*
  (SEND inspect-history-window
        :inspect-object
        thing
        inspect-window nil nil nil t)) ;Ï1; added extra arg so that same symbol in differing frames will be updated correctlyÏ*

;Ï1; change SYS:DEBUG-UTILITIES;WINDOW-DEBUG.LISP#205 to not use AP but FRAME Ï*
;Ï1; and to reference args and locals in reg pdl correctlyÏ*
(DEFMETHOD Ï4(debugger-frame :setup-sgÏ*) (sg frame)
  (SETQ frame-alist nil)
  (SEND inspect-history-window :flush-contents)
  (setup-stack-frame-window stack-window sg)
  (SEND self :setup-frame sg frame))

(DEFMETHOD Ï4(debugger-frame :setup-frameÏ*) (sg frame &optional force-p arg-changed-flag)
  (LET (code args locals tem)
    (OR tv:exposed-p
        ;Ï1; If window not exposed, get its bit array in core so setup will go fasterÏ*
        (si:page-in-array tv:screen-array))
    (SETQ tem (ASSOC frame frame-alist :test (FUNCTION eq)))
    (COND (force-p
           (SETQ frame-alist (DELETE tem (THE list frame-alist) :test #'EQ))
           (SETQ tem nil)))
    ;Ï1; Set stuff up in most interesting order: args, then locals, then codeÏ*
    (COND (tem ;Ï1; Displayed this beforeÏ*
           (SEND args-window :setup (THIRD tem))
           (SEND locals-window :setup (FOURTH tem))
           (SEND inspect-history-window :inspect-object (SECOND tem) inspect-window))
          (t
           (MULTIPLE-VALUE-SETQ (args tem) (setup-args-window args-window sg frame))
           (SETQ locals (setup-locals-window locals-window sg frame tem))
           (SETQ code (setup-inspect-window inspect-window sg frame inspect-history-window))
           (PUSH (LIST frame code args locals) frame-alist)))
    (IF arg-changed-flag
        (SEND stack-window :refresh))
    (SEND stack-window :put-item-in-window frame)
    (SEND stack-window :set-current-item frame)))


;Ï1; Support routines for the stack frame window, a stack frame entry is just an AP.Ï*
;Ï1; The common argument is the stack group.Ï*
;Ï1; Top of stack really on top - mjfÏ*

;Ï1; change SYS:DEBUG-UTILITIES;WINDOW-DEBUG.LISP#205 to not use AP but FRAME Ï*
;Ï1; and to reference args and locals in reg pdl correctlyÏ*

(DEFUN Ï4setup-stack-frame-windowÏ* (window sg )
  (LET (LIST)
    (DO ((frame (sys:sg-top-frame sg) (sg-next-frame sg frame)))
        ((NULL frame))
      (PUSH frame list))
    (SEND window :setup (LIST 'print-stack-frame sg (NREVERSE list)))))

;Ï1; Given an SG and a FRAME, return the function and first and last+1 arg index into the RP (3 values).Ï*
(DEFUN Ï4stack-frame-function-and-argsÏ* (sg frame)
  (DECLARE (VALUES function args-start args-end))
  (PROG* ((rp (sg-regular-pdl sg))
	  (FUNCTION (rp-function-word rp frame))
	  (argument-index (sys:rp-argument-offset sg rp frame)))
    ;Ï1; If SELF is bound by this frame to an object whose handler for the first argument to thisÏ*
    ;Ï1; frame is the function of this frame, print that object instead.Ï*
    (LET ((idx (sg-frame-special-pdl-range sg frame)))
      (AND idx
	   (> idx 0)
	   (LET ((sp (sg-special-pdl sg)))
	     (AND (EQ (AREF sp (1+ idx))
		      (%make-pointer dtp-locative (si:%p-pointer-offset 'self 1)))  
;Ï1; TGCÏ*		Ï1      (%MAKE-POINTER DTP-LOCATIVE (%P-LDB-OFFSET %%Q-POINTER 'SELF 1)))Ï*
		  (LET* ((object (AREF sp idx))
			 (handler (GET-HANDLER-FOR object (AREF rp argument-index))))
		    (AND (IF handler
			     (EQ function (IF (SYMBOLP handler) (SYMBOL-FUNCTION handler) handler))
			   (MEMBER (FUNCTION-NAME function)
                                   '(si::instance-hash-failure
                                     si::flavor-unclaimed-message
                                     si::report-unclaimed-message)
                                   :test
                                   (FUNCTION eq)))
			 (SETQ function object)))))))
    (RETURN (VALUES function argument-index (+ argument-index (rp-number-args-supplied rp frame))))))

;Ï1; Print a frame  (ITEM is a FRAME)Ï*
(DEFUN Ï4print-stack-frameÏ* (item sg stream ignore)
  (SEND stream :item1 item 'stack-frame #'print-stack-frame-1 sg))

(DEFUN Ï4print-stack-frame-1Ï* (frame stream sg)
  (MULTIPLE-VALUE-BIND (FUNCTION args-start args-end) (stack-frame-function-and-args sg frame)
    (SEND stream :tyo (si::pttbl-open-paren *readtable*))
    (SEND stream :item1 function :function #'(lambda (FUNCTION stream)
						    (PRIN1 (FUNCTION-NAME function) stream)))
    (DO ((arg-idx args-start (1+ arg-idx))
	 (LENGTH 1 (1+ length))
	 (rp (sg-regular-pdl sg)))
	((>= arg-idx args-end)
	 (SEND stream :tyo (si::pttbl-close-paren *readtable*)))
      (SEND stream :tyo (si::pttbl-space *readtable*))
      (SEND stream :item1 (AREF rp arg-idx) :value #'tv::print-item-concisely)
      (COND ((AND *print-length* (>= length *print-length*))
	     (SEND stream :string-out (si::pttbl-prinlength *readtable*))
	     (RETURN nil))))))


;Ï1; Support routines for the args, locals, and specials windowsÏ*
;Ï1; Entries are fixed strings, or lists of name, val, and numberÏ*
;Ï1; Common arg is the type of entries presentÏ*
(DEFUN Ï4setup-args-windowÏ* (window sg frame)
  (LET* (LIST
         (rp (sg-regular-pdl sg))
         (argument-index (sys:rp-argument-offset sg rp frame))
         (FUNCTION (rp-function-word rp frame))
         (nargs-supplied (rp-number-args-supplied rp frame))
         (nargs-to-print (sg-number-of-spread-args sg frame))
         nargs-expected nargs-required
         lexpr-call rest-arg-p rest-arg-value)
    (IF (OR (TYPEP function 'compiled-function)
            (AND (TYPEP function 'CONS) (MEMBER (FIRST function) si:function-start-symbols)))
        (MULTIPLE-VALUE-SETQ (nargs-required nargs-expected ) (si::args-desc function)))
;Ï1    (IF (TYPEP FUNCTION '(OR CONS COMPILED-FUNCTION))Ï*
;Ï1        (MULTIPLE-VALUE-SETQ (NARGS-REQUIRED NARGS-EXPECTED ) (SI::ARGS-DESC function)))Ï*
    (MULTIPLE-VALUE-SETQ (rest-arg-value rest-arg-p lexpr-call)
                         (sg-rest-arg-value sg frame))
    ;Ï1; Store the individual args.Ï*
    (DOTIMES (i nargs-to-print)
      ;Ï1; These "args" weren't suppliedÏ*
      (IF (= i nargs-supplied)
          (PUSH (IF (AND nargs-required (< i nargs-required))
                    "Ï3   --Missing args:--Ï*" "Ï3   --Defaulted args:--Ï*")
                list))
      ;Ï1; Called with too many argsÏ*
      (IF (AND nargs-expected (= i nargs-expected))
          (PUSH "Ï3   --Extraneous args:--Ï*" list))
      ;Ï1; Push arg name, value and numberÏ*
      (LET ((missing (AND nargs-required
                          (> nargs-required nargs-supplied)
                          (>= i nargs-supplied))))
        (PUSH (LIST (arg-name function i)             ;Ï1 Arg nameÏ*
;		Ï1  (OR MISSING (AREF RP (+ FRAME I 1)))Ï*
                    (OR missing (AREF rp (+ argument-index i)))       ;Ï1 Arg ValueÏ*
                    (IF (NOT missing) i (LIST :novalue i)))   ;Ï1 Arg NumberÏ*
              list)))
    ;Ï1; Print the rest arg if any.Ï*
    (IF (OR rest-arg-p lexpr-call)
        (PUSH (LIST (AND rest-arg-p (local-name function 0))  ;Ï1 Rest Arg NameÏ*
                    rest-arg-value                    ;Ï1 Rest Arg ValueÏ*
                    (IF rest-arg-p "Ï3Rest argÏ*" "Ï3Extraneous rest argÏ*"))
              list))
    (VALUES (SEND window :setup (LIST 'print-arg-or-local '(arg "Ï3ArgÏ*")
                                      (NREVERSE list)))
            rest-arg-p)))

;Ï1***************Ï*
;Ï1 TAC 08-01-89 - this function being redefined by code in WINDOW-DEBUGGER-ENHANCEMENTSÏ*
;Ï1;;REST-ARG-P means that local 0 is in the other window and should not be duplicatedÏ*
;Ï1(DEFUN SETUP-LOCALS-WINDOW (WINDOW SG FRAME REST-ARG-P)Ï*

(COMMENT (DEFUN print-special-pdl-range (sg start end &optional (STREAM *standard-output*))
           (DO ((sp (sg-special-pdl sg))
                (i start (+ i 2)))
               ((>= i end))
             (FORMAT stream
                     "Ï3~&~S: ~S~%Ï*"
                     (symbol-from-value-cell-location (AREF sp (1+ i)))
                     (AREF sp i)))))

(DEFUN Ï4print-arg-or-localÏ* (item type stream ignore)
  (LET (number name value type-name novalue error)
    (IF (STRINGP item)
        (SEND stream :string-out item)
        (PROGN
          (SETQ type-name (SECOND type)
                type (FIRST type)
                name (FIRST item)
                value (SECOND item)
                number (THIRD item))
          (AND (CONSP number)
               (SETQ novalue (FIRST number)
                     number (SECOND number)))
          (COND ((NULL number))
                ((STRINGP number)
                 (SEND stream :string-out number))
                (t (FORMAT stream "Ï3~A ~DÏ*" type-name number)))
          (AND name (COND (number
                           (SEND stream :string-out "Ï3 (Ï*")
                           (SEND stream
                                 :item1 (LIST name number) type
                                 (FUNCTION (lambda (x stream)
                                             (IF (CONSP (CAR x))
                                                 (SEND stream :string-out (FORMAT nil "Ï3~AÏ*" (CAR x)))
                                                 (SEND stream :string-out (SYMBOL-NAME (CAR x)))))))
                           (WRITE-CHAR #\) stream))   ;Ï1(SEND STREAM :TYO #\)))Ï*
                          (t (SEND stream :item1 name type))))
          (COND ((NEQ novalue :novalue)
                 (SEND stream :string-out "Ï3: Ï*")
                 (MULTIPLE-VALUE-SETQ (nil error)
                                      (CATCH-ERROR (SEND stream :item1 value
                                                         :value (FUNCTION tv::print-item-concisely))
                                                   nil))
                 (IF error (SEND stream :string-out "Ï3<<unprintable>>Ï*"))))))))


;Ï1; Support routines for the code windowÏ*
(DEFUN Ï4setup-inspect-windowÏ* (inspect-window sg frame inspect-history-window)
  (LET (FUNCTION (label "") code)
    (SETQ function (rp-function-word (sg-regular-pdl sg) frame))
    ;Ï1; Set label to function name for frameÏ*
    ;Ï1; but print nothing for interpreted codeÏ*
    (IF (NOT (LISTP function))
        (LET ((name (FUNCTION-NAME function)))
          (SETQ label (COND ((STRINGP name) name)
                            ((SYMBOLP name) (SYMBOL-NAME name))
                            (t (FORMAT nil "Ï3~SÏ*" name))))))
    (SEND inspect-history-window :inspect-object
          (SETQ code (tv::make-stack-frame :stack-group sg
                                          :frame-number frame
                                          :function-name label))
          inspect-window)
    code))




;Ï1; This reads a form or special command (a list in the input stream)Ï*
(DEFUN Ï4window-command-loop-readÏ* (&optional preemptable) ;Ï1!Ï*
  (DO ((CHAR -1)
       (sexp)
       (flag)
       (typeahead))
      (nil)
    (UNWIND-PROTECT
	(PROGN (COND ((NOT preemptable)
		      (SETQ typeahead (SEND *terminal-io* :old-typeahead))
		      (SEND *terminal-io* :set-old-typeahead nil)))
	       (OR (SEND *terminal-io* :old-typeahead)
		   (SETQ char (tv:read-any *terminal-io*)))	   
	       (COND ((CONSP char)
		      (RETURN char))
		     ((CHAR-EQUAL char #\Help)
		      (window-debugger-help))
		     ((CHAR-EQUAL char #\Page)
		      (SEND *terminal-io* :clear-screen))
		     ((CHAR-EQUAL char #\Rubout))
		     (t
		      (AND char
			   (tv:unread-any char *terminal-io*))
		      (MULTIPLE-VALUE-SETQ (sexp flag)
					   (SEND *terminal-io*
						 :preemptable-read
						 '((:full-rubout :full-rubout))
						 (FUNCTION read-for-top-level)))
		      (AND (EQ flag :mouse-char)
			   (RETURN sexp))
		      (OR (EQ flag :full-rubout)
			  (RETURN nil sexp)))))
      (OR preemptable (SEND *terminal-io* :set-old-typeahead typeahead)))))

;Ï1; This gets an object to return or somethingÏ*
(DEFUN Ï4window-read-objectÏ* (keyword &rest format-string-and-args)
  (LET (SPECIAL sexp ask-p old-si-types)
    (COND
      ((EQ keyword :eval-read)
       (SETQ old-si-types (SEND *window-debugger* :sensitive-item-types))
       (UNWIND-PROTECT
           (PROG nil
                 (SEND *window-debugger* :set-sensitive-item-types '(:value :function stack-frame))
              retry
                 (APPLY 'FORMAT t format-string-and-args)
                 (MULTIPLE-VALUE-SETQ (SPECIAL sexp) (window-command-loop-read))
                 (COND ((CONSP special)
                        (IF (SEND *window-debugger* :inspect-window-p (THIRD special))
                            (SETQ sexp (tv::inspect-real-value special)
                                  ask-p t)
                            (LET ((type (FIRST special)))
                              (COND ((EQ type :value)
                                     (SETQ sexp (SECOND special)
                                           ask-p t))
                                    ((AND (EQ type :menu)
                                          (MEMBER (SETQ sexp (SEND (FOURTH special) :execute (SECOND special)))
                                                  '(t nil-value)
                                                  :test (FUNCTION eq)))
                                     (SETQ sexp  (EQ sexp t)
                                           ask-p nil))
                                    (t (BEEP) (GO retry))))))
                       (t (SETQ ask-p (si::constantp sexp) ;Ï1; Ï*(si:trivial-form-p sexp)Ï1 Ï* ;Ï1 TAC 09-02-89Ï*
                                sexp (LET ((otoc (sg-flags-trap-on-call *error-sg*)))
                                       (SETF (sg-flags-trap-on-call *error-sg*) 0)
                                       (PROG1 (CAR (sg-eval *error-sg* sexp t))
                                              (SETF (sg-flags-trap-on-call *error-sg*) otoc))))))
                 (AND ask-p (COND ((NOT (window-y-or-n-p "Ï3The object is ~S, ok? (Y or N) Ï*" sexp))     ;Ï1.Ï*
                                   (TERPRI)
                                   (GO retry))))
                 (RETURN sexp))
         (SEND *window-debugger* :set-sensitive-item-types old-si-types)))
      ((EQUAL keyword '(:fquery)) (APPLY 'window-y-or-n-p format-string-and-args))
      (t (APPLY 'PROMPT-AND-READ keyword format-string-and-args)))))

(DEFUN Ï4window-y-or-n-pÏ* (STRING &rest format-args)
  (APPLY (FUNCTION format) t string format-args)
  (DO ((ch))
      (nil)
    (SETQ ch (tv:read-any *standard-input*))
    (AND (CONSP ch)
         (EQ (FIRST ch) :menu)
         (MEMBER (SETQ ch (SEND (FOURTH ch) :execute (SECOND ch)))
                 '(t nil-value)
                 :test
                 (FUNCTION eq))
         (SETQ ch (IF (EQ ch t) #\Y #\N)))
    (SETQ ch (INT-CHAR ch))		   ;Ï1.Ï*
    (COND ((MEMBER ch '(#\Y #\y #\Space) :test (FUNCTION eq))
           (PRINC "Ï3yesÏ*")
           (RETURN t)))
    (COND ((MEMBER ch '(#\N #\n #\Rubout) :test (FUNCTION eq))
           (PRINC "Ï3noÏ*")
           (RETURN nil)))
    (PRINC "Ï3(Y or N)Ï*")))


(DEFUN Ï4window-read-functionÏ* (action &optional allow-t return-stack-frames)
  (LET (SPECIAL function)
    (FORMAT t
            "Ï3~&Type or mouse a function ~A (NIL aborts~:[, T ~A nothing~]):~%Ï*"
            action
            (NOT allow-t)
            action)
    (MULTIPLE-VALUE-SETQ (SPECIAL function) (window-command-loop-read))
    (AND special (SETQ function (IF (SEND *window-debugger* :inspect-window-p (THIRD special))
                                    (tv::inspect-real-value special)
                                    (CASE (FIRST special)
                                      (:menu  (AND (EQ (SEND (FOURTH special)
                                                             :execute
                                                             (SECOND special))
                                                       t)
                                                   allow-t))
                                      (stack-frame  (IF
                                                      return-stack-frames
                                                      special
                                                      (stack-frame-function-and-args
                                                        *error-sg*
                                                        (SECOND special))))
                                      (:line-area  (IF
                                                     return-stack-frames
                                                     (LIST 'stack-frame (SECOND special))
                                                     (stack-frame-function-and-args
                                                       *error-sg*
                                                       (SECOND special))))
                                      ((SPECIAL arg local)  (FIRST (SECOND special)))
                                      ((:value :function special)  (SECOND special))))))
    (WHEN (CLOSUREP function)
      (SETQ function (CLOSURE-FUNCTION function)))
    (COND ((TYPEP function 'instance)
           (SETQ special (window-read-thing "Ï3~&Type or mouse a message name for ~S:~%Ï*" function))
           (LET ((handler (GET-HANDLER-FOR function special)))
             (OR handler (FORMAT t "Ï3~&~S does not handle the ~S message.~%Ï*" function special))
             (SETQ function handler)))
          ((NULL function)
           (FORMAT t "Ï3~&Aborted.~%Ï*")))
    function))

;Ï1----------------------------------------------------------------------------------------------Ï*
;Ï1(LET ((compiler:compile-encapsulations-flag t))Ï*
;Ï1     (ADVISE eh:window-read-thing :around :make-sure-not-inspection-dataÏ*
;	Ï1     nilÏ*
;Ï1       (LET ((results (MULTIPLE-VALUE-LIST :do-it)))Ï*
;	Ï1    (IF (TYPEP (FIRST results) 'tv:inspection-data)Ï*
;		Ï1(VALUES-LIST (CONS (OR (SEND (FIRST results) :send-if-handlesÏ*
;					Ï1     :middle-button-result)Ï*
;				Ï1       (SEND (FIRST results) :send-if-handlesÏ*
;					Ï1     :aux-data)Ï*
;				Ï1       (SEND (FIRST results) :data))Ï*
;				Ï1   (REST results)))Ï*
;		Ï1(VALUES-LIST results)))))Ï*
;Ï1----------------------------------------------------------------------------------------------Ï*

(DEFUN Ï4window-read-thingÏ* (prompt &rest format-args)
  (LET ((results 
	  (MULTIPLE-VALUE-LIST
	    ;Ï1; --- original body of code represented by :do-it in advice commented above ---Ï*
	    (LET (SPECIAL thing)
	      (APPLY (FUNCTION format) t prompt format-args)
	      (MULTIPLE-VALUE-SETQ (SPECIAL thing) (window-command-loop-read))
	      (SETQ thing (IF special
			      (IF (SEND *window-debugger* :inspect-window-p (THIRD special))
				  (tv::inspect-real-value special)
				  (CASE (FIRST special)
				    (:menu  (EQ (SEND (FOURTH special) :execute (SECOND special)) t))
				    (stack-frame  (list-stack-frame-function-and-args *error-sg*
										      (SECOND special)))
				    (:line-area  (list-stack-frame-function-and-args *error-sg*
										     (SECOND special)))
				    ((SPECIAL arg local)  (FIRST (SECOND special)))
				    ((:value :function special)  (SECOND special))))
			      (CAR (sg-eval-in-frame *error-sg* thing *current-frame* t)))) ;Ï1; take frame into considerationÏ*
	      (IF (NULL thing) (FORMAT t "Ï3~&Aborted.~%Ï*"))
	      thing))))
              ;Ï1; ---------------------------------------------------------------------Ï*
    (IF (TYPEP (FIRST results) 'tv::inspection-data)
	(VALUES-LIST (CONS (OR (SEND (FIRST results) :send-if-handles
				     :middle-button-result)
			       (SEND (FIRST results) :send-if-handles
				     :aux-data)
			       (SEND (FIRST results) :data))
			   (REST results)))
	(VALUES-LIST results))))

(DEFUN Ï4list-stack-frame-function-and-argsÏ* (sg frame)
  (LET (LIST)
    (MULTIPLE-VALUE-BIND (FUNCTION args-start args-end) 
        (stack-frame-function-and-args sg frame)
      (PUSH (FUNCTION-NAME function) list)
      (DO ((i args-start (1+ i))
           (l 1 (1+ l))
           (rp (sg-regular-pdl sg)))
          ((>= i args-end)
           (NREVERSE list))
        (PUSH (AREF rp i) list)))))


;Ï1--------------------------Ï*
;Ï1; The commandsÏ*
;Ï1--------------------------Ï*

(DEFUN Ï4comw-proceedÏ* (*error-sg* *error-object* &rest ignore)
   (LET (proceed-types proceed-type 
        (resume-handlers (SYMEVAL-IN-STACK-GROUP 'condition-resume-handlers
                                                 *error-sg*)))
    (error-handler-must-be-running)
    (SETQ proceed-types (SEND *error-object*
                              :user-proceed-types
                              (sg-condition-proceed-types *error-sg* *error-object*)))
    (IF
      (NOT proceed-types)
      (FORMAT t "Ï3There is no way to proceed from this error.~%Ï*")
      (WHEN
        (SETQ
          proceed-type
          (w:menu-choose 
            (APPEND (MAPCAR (FUNCTION (lambda (proceed-type)
                                        (LIST (format:output nil
                                                (SEND *error-object*
                                                      :document-proceed-type
                                                      proceed-type
                                                      *standard-output*
                                                      resume-handlers))
                                              :value
                                              proceed-type
                                              :documentation
                                              "Ï3Select this proceed type.Ï*")))
                            proceed-types)
                    (MAPCAR (FUNCTION (lambda (special-command)
                                        (LIST (format:output nil
                                                (SEND *error-object*
                                                      :document-special-command
                                                      special-command
                                                      *standard-output*))
                                              :value
                                              special-command
                                              :documentation
                                              "Ï3Select this command.Ï*")))
                            *special-commands*))
	 :label  "Ï3Which type of proceed?Ï*"))		
	(SEND *error-object*
              :proceed-asking-user
              proceed-type
              'proceed-error-sg
              'window-read-object)))
    nil))

(DEFUN Ï4comw-what-errorÏ* (sg *error-object*)
  (SEND *error-object* :print-error-message sg t *standard-output*))

(DEFUN Ï4comw-describeÏ* (IGNORE ignore)
  (LET ((thing (window-read-thing "Ï3~&Type or mouse something to describe:~%Ï*")))
    (IF thing (DESCRIBE thing))))

(DEFUN Ï4comw-inspectÏ* (IGNORE ignore)
  (LET ((thing (window-read-thing "Ï3~&Type or mouse something to inspect:~%Ï*")))
    (IF thing (SEND *window-debugger* :inspect-object thing))))

;Ï1; 7/13/88 clm for may - Must look at BOTH values catch-error returns.Ï*
(DEFUN Ï4comw-arglistÏ* (sg ignore)
  (LET ((FUNCTION (window-read-function "Ï3for arglistÏ*" nil t)))
    (IF function (COND ((AND (SYMBOLP function)
                             (NOT (FBOUNDP function)))
                        (FORMAT t "Ï3~&~S is not defined.Ï*" function))
                       ((AND (CONSP function)
                             (EQ (FIRST function) 'stack-frame))
                        (print-frame-arglist sg (SECOND function)))
                       (t
                        (SETQ function (FUNCTION-NAME function))
                        (MULTIPLE-VALUE-BIND (val error)
                            (CATCH-ERROR (ARGLIST function) nil)
                          ;Ï1;(IF ERRORÏ*
			  ;Ï1; checking second value for an error is not enough, first must be nil, too Ï*
                          (IF (AND error (NULL val)) ;Ï1; did catch-error get an error ?Ï*
                              (FORMAT t "Ï3~&~S is not a function.Ï*" function)
                              (FORMAT t "Ï3~&~S: ~:A~%Ï*" function val))))))))

(DEFUN Ï4print-frame-arglistÏ* (sg frame)
  (LET ((str1 (MAKE-ARRAY 50. :element-type 'string-char :leader-list '(0)))
        (str2 (MAKE-ARRAY 50. :element-type 'string-char :leader-list '(0)))
        function args-start args-end)
    (VECTOR-PUSH-EXTEND (si::pttbl-open-paren *readtable*) str1)
    (MULTIPLE-VALUE-SETQ (FUNCTION args-start args-end)
                         (stack-frame-function-and-args sg frame))
    (FORMAT str1 "Ï3~SÏ*" (FUNCTION-NAME function))
    (VECTOR-PUSH-EXTEND (si::pttbl-space *readtable*) str1)
    (COPY-ARRAY-CONTENTS-AND-LEADER str1 str2)
    (DO ((ARGLIST (ARGLIST function) (CDR arglist))
         (rp (sg-regular-pdl sg))
         (i args-start)
         (flag nil t))
        ((AND (NULL arglist) (>= i args-end)))
      (LET ((i1 (IF flag 1 0)) (i2 (IF flag 1 0)))
        (LET ((len1 (ARRAY-LEADER str1 0))
              (len2 (ARRAY-LEADER str2 0)))
          (COND ((> len1 len2)
                 (SETQ i2 (1+ (- len1 len2))))
                ((< len1 len2)
                 (SETQ i1 (1+ (- len2 len1))))))
        (COND (ARGLIST
               (DOTIMES (i i1) (VECTOR-PUSH-EXTEND #\Sp str1))
               (FORMAT str1 "Ï3~SÏ*" (CAR arglist))
               (AND (MEMBER (CAR arglist) '(&optional &rest) :test (FUNCTION eq))
                    (SETQ flag '&mumble))))
        (COND ((< i args-end)
               (DOTIMES (i i2) (VECTOR-PUSH-EXTEND #\Sp str2))
               (COND ((NEQ flag '&mumble)
                      (FORMAT str2 "Ï3~SÏ*" (AREF rp i))
                      (SETQ i (1+ i))))))))
    (VECTOR-PUSH-EXTEND (si::pttbl-close-paren *readtable*) str2)
    (VECTOR-PUSH-EXTEND (si::pttbl-close-paren *readtable*) str1)
    (SEND *standard-output* :fresh-line)
    (SEND *standard-output* :line-out str1)
    (SEND *standard-output* :line-out str2)))

(DEFUN Ï4stack-frame-into-listÏ* (frame sg &aux list function args-start args-end)
  (MULTIPLE-VALUE-SETQ (FUNCTION args-start args-end)
    (stack-frame-function-and-args sg frame))
  (SETQ list (CONS (FUNCTION-NAME function) nil))
  (DO ((i args-start (1+ i))
       (rp (sg-regular-pdl sg)))
      ((>= i args-end))
    (PUSH (AREF rp i) list))
  (NREVERSE list))

(DEFUN Ï4comw-set-argÏ* (sg ignore &aux char)
  (FORMAT t "Ï3~&Mouse an argument or local to modify:~%Ï*")
  (LET ((old-si-types (SEND *window-debugger* :sensitive-item-types)))
    (SEND *window-debugger* :set-sensitive-item-types '(arg local))
    (UNWIND-PROTECT
      (SETQ char (SEND *standard-input* :any-tyi))
      (SEND *window-debugger* :set-sensitive-item-types old-si-types)))
  (IF (NOT (AND (CONSP char) (MEMBER (CAR char) '(local arg) :test (FUNCTION eq)) (CONSP (SECOND char))))
      (FORMAT t "Ï3~&That is not an argument or local~%Ï*")
    (LET ((idx (CADADR char)))
      (IF (NOT (NUMBERP idx))
	  (FORMAT t "Ï3~&Cannot set rest arg.Ï*")
	(LET ((new-obj (read-object :eval-read
				    (FORMAT nil "Ï3Value to substitute for ~A: Ï*"
					    (CAADR char)))))
	  (LET ((rp (sg-regular-pdl sg)))
            (SETF (AREF rp (+ idx (IF (EQ (CAR char) 'arg) 
			     (sys:rp-argument-offset sg rp *current-frame*)
			   (sys:rp-local-offset sg rp *current-frame*)))) new-obj)))))
    (SEND *window-debugger* :setup-frame sg *current-frame* t t)))

(COMPILE-FLAVOR-METHODS debugger-who-line-mixin
                        debugger-frame
                        debugger-lisp-listener-pane
                        debugger-text-scroll-pane
                        gray-debugger-text-scroll-pane
                        gray-debugger-thermometer-text-scroll-pane
                        stack-scroll-pane
                        debugger-history-pane
                        debugger-menu-pane
                        debugger-inspect-pane)


(DEFWINDOW-RESOURCE Ï4debugger-frameÏ*
                    nil
  :make-window
  (debugger-frame)
  :reusable-when
  :deactivated)
  ;Ï1 :initial-copies 0)

