;;; -*- Mode:Common-Lisp; Package:EH; Fonts:(CPTFONT HL10B HL12BI HL12B CPTFONTB); Base:10Ï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, 1988, 1989 Texas Instruments Incorporated. All rights reserved.Ï*

;;;----------------------------------------------------------------------
;;; 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.
;;;----------------------------------------------------------------------

;Ï1;; This file contains the definition of a number of new commands for the window debugger.Ï*

(DEFVAR Ï4*window-debugger-enhancements-to-add*Ï* :all
"Ï2Can have the value :All, in which case all commands are loaded,
 :Menu in which case the user is prompted, or a list of commands to load.Ï*")

(DEFPARAMETER Ï4*window-debugger-enhancements-commands*Ï*
  '(("Ï3Debug Stack GroupÏ*" :value (nil nil ((comw-debug-stack-group-cmd t))))
    ("Ï3Modify InspectÏ*" :value (nil nil ((comw-modify-inspect t)))))
"Ï2This is a list of the commands which can be added to the Window-debugger.  The
 structure of this list is as follows :-
 It is made of items.  Each item is a list of the form (Menustring :Value spec)
 the spec is used to determine which commands for which tools is represented
 by the menu item.  The spec is a list of the form
 (nil nil window-debugger-commands)
 Each element of window-debugger-commands has the form
 (command-name put-in-frames-menu-p).Ï*")

(DEFUN Ï4install-window-debugger-commandsÏ* ()
"Ï2Installs all of the commands that the user wants.Ï*"
  (tv::select-and-install-commands *window-debugger-enhancements-commands*
				   *window-debugger-enhancements-to-add*))

;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; The Debug Stack Group Command.Ï*

;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; The following are property assignments, which specify properties for typesÏ*
;Ï1;; which contain stack groups which can be debugged.  A property is added toÏ*
;Ï1;; the name of the type under the Key :Stack-Group-Accessor, whose value isÏ*
;Ï1;; either a function object or a symbol, whose functional value is an accessÏ*
;Ï1;; function.Ï*

(PUTPROP 'si:process 'PROCESS-STACK-GROUP :stack-group-accessor)
(PUTPROP 'STACK-GROUP 'IDENTITY :stack-group-accessor)

(DEFUN Ï4extract-a-stack-groupÏ* (something)
"Ï2This function is passed something, which contains a stack group.  It extracts
 the stack group and returns it.  The way that it does it is to look on the
 property list of the type of the argument.  If there is a property called
 :Stack-Group-Accessor then this is used as an access function, by which the
 stack group can be extracted.  The value of this property can be either a
 symbol or a function.Ï*"
  (LET ((the-accessor (GET (TYPE-OF something) :stack-group-accessor)))
       (IF (EQUAL nil the-accessor)
	   :error
	   (FUNCALL (IF (SYMBOLP the-accessor)
			(SYMBOL-FUNCTION the-accessor)
			the-accessor)
		    something))))

(DEFUN Ï4redefined-sg-funcall-in-frameÏ* (sg frame function &rest args)
"Ï2This function is a redefined version of sg-funcall-in-frame.  For some reason
 that I don't understand something goes wrong with evaluating expressions in the
 lisp listener pane and nasty things happen.  This change makes sure that things
 are evaluated in the context of the stack group as a whole but not in the
 context of the current frame - a bit of a restriction, I know but not that bad
 really and still worth it to have this feature.Ï*"
  (IGNORE frame)
  (sg-apply sg function args))

;Ï1 TAC 09-04-89 - commented this one out because a different version of same function immediately follows Ï*
;Ï1(DEFUN debug-a-stack-group (something)Ï*
;Ï1"This procedure is passed something that contains a stack group.  It extactsÏ*
;Ï1 the stack group and calls the window debugger to debug it.  In order to do thisÏ*
;Ï1 it binds the special variables error-sg and current-frame, which are known toÏ*
;Ï1 the debugger.  Error-Sg is the stack group which is to be debugged andÏ*
;Ï1 current-frame is the stack frame pointer.  This is set to function at theÏ*
;Ï1 bottom of the stack."Ï*
;Ï1  (LET ((*error-sg* (extract-a-stack-group something)))Ï*
;Ï1       (IF (EQUAL *error-sg* :error)Ï*
;	Ï1   (PROGN (BEEP)Ï*
;		Ï1  (FORMAT tv:selected-window "~&~S cannot be debugged.~%"Ï*
;			Ï1  something))Ï*
;	Ï1   (LET ((*current-frame* (sg-initial-function-index error-sg))Ï*
;		Ï1 (* nil)Ï*
;		Ï1 (** nil)Ï*
;		Ï1 (*** nil))        Ï*
;		Ï1(DECLARE (SPECIAL *error-sg* *current-frame* * ** ***))Ï*
;		Ï1(letf ((#'sg-funcall-in-frame #'redefined-sg-funcall-in-frame))Ï*
;		Ï1      (com-window-debugger *error-sg*Ï*
;			Ï1  (MAKE-INSTANCE 'FERROR :condition-names nilÏ*
;					Ï1  :format-string "Debug a Stack Group"Ï*
;					Ï1  :format-args nilÏ*
;					Ï1  :initial-error-message-printed-p t)))))))Ï*

(DEFUN Ï4debug-a-stack-groupÏ* (something)
"Ï2This procedure is passed something that contains a stack group.  It extacts
 the stack group and calls the window debugger to debug it.  In order to do this
 it binds the special variables error-sg and current-frame, which are known to
 the debugger.  Error-Sg is the stack group which is to be debugged and
 current-frame is the stack frame pointer.  This is set to function at the
 bottom of the stack.Ï*"
  (LET ((sg (extract-a-stack-group something)))
       (IF (EQUAL *error-sg* :error)
	   (PROGN (BEEP)
		  (FORMAT tv:selected-window "Ï3~&~S cannot be debugged.~%Ï*"
			  something))
	   (USING-RESOURCE (STREAM tv::background-lisp-interactors)
	     (LET ((*terminal-io* stream)
		   (*debug-io* stream)
		   (*error-output* stream)
		   (*trace-output* stream)
		   (action (SEND stream :deexposed-typeout-action)))
	          (DECLARE (SPECIAL *terminal-io* *debug-io*
				    *error-output* *trace-output*))
		  (UNWIND-PROTECT
		      (PROGN (SEND stream :set-deexposed-typeout-action :expose)
			     (EH sg))
		    (SEND stream :set-deexposed-typeout-action action)
		    (SEND stream :deactivate)))))))

(DEFUN Ï4comw-debug-stack-groupÏ* (IGNORE ignore &aux thing)
"Ï2This is the command procedure for the window debugger, which causes the user to
 be prompted to point at a stack group or stack group containing data structure.Ï*"
  (AND (SETQ thing (window-read-thing
			"Ï3~&Type or mouse a process or stack group to debug:~%Ï*"))
       (PROCESS-RUN-FUNCTION "Ï3Window Debugger from Window DebuggerÏ*"
			     #'debug-a-stack-group thing)))

;Ï1; This window debugger command was copied and modified from the command, which controls theÏ*
;Ï1; inspect option.  It defines a command called Comw-Debug-Stack-Group-Cmd, which is activatedÏ*
;Ï1; either from a menu or by the keystroke h-S.  It causes the user to be prompted for a stack Ï*
;Ï1; group containing data structure and starts off a new debugger frame, which debugs that stack group.Ï*

(DEFCOMMAND Ï4comw-debug-stack-group-cmdÏ* nil
  '(:description
     "Ï3Run a new debugger in a selected stack groupÏ*" :names "Ï3Dbg SGÏ*" 
    :keys (#\h-s))
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select a stack group, or something containing one, to debug.Ï*")
   (UNWIND-PROTECT
      (PROGN
	(comw-debug-stack-group *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-------------------------------------------------------------------------------Ï*

;Ï1;; The Modify Inspect command.Ï*

;Ï1-------------------------------------------------------------------------------Ï*

(DEFMETHOD Ï4(debugger-frame :inspect-history-windowÏ*) ()
"Ï2Makes the inspect-history-window instance variable visible.Ï*"
  inspect-history-window)

(DEFMETHOD Ï4(debugger-frame :inspect-windowÏ*) ()
"Ï2Makes the inspect-window instance variable visible.Ï*"
  inspect-window)

(DEFMETHOD Ï4(debugger-frame :update-*Ï*)  ()
"Ï2A dummy method, because * is updated by explicit typein or by the middle
 button.Ï*"
  nil)

(DEFCOMMAND Ï4comw-modify-inspectÏ* ()
            '(:description "Ï3Modify something in the inspect pane.Ï*"
              :names "Ï3ModInspÏ*" :keys (#\c-sh-m))
  (LET ((tv::history (SEND *window-debugger* :inspect-history-window))
	(tv::inspectors (LIST (SEND *window-debugger* :inspect-window)))
	(tv::frame *window-debugger*))
       (DECLARE (SPECIAL tv::top-item tv::history tv::inspectors tv::frame))
       (SETQ tv:top-item
	     (tv::inspect-modify-object *terminal-io* tv::history tv::inspectors))
       (tv::update-panes)))
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1; The following fix lets the value of Self be printed in the locals windowÏ*
;Ï1; for methods which would not otherwise have this happen.Ï*

;Ï1; This facility is switched on by the variableÏ*
;Ï1; eh:*show-self-in-locals-window-anyway* .  Set it to non-nil toÏ*
;Ï1; enable it.  If it is set to :Always then Self is printed even forÏ*
;Ï1; non-methods.Ï*

;Ï1;; Code by JPR.Ï*
(DEFVAR Ï4*show-self-in-locals-window-anyway*Ï* nil
"Ï2Controls how Self is displayed in the window debugger.  Can have the values;
 Nil (default), which causes the default behaviour, :Always, which causes
 Self to be displayed in the Locals window for all functions, and any other
 non-nil value, which causes Self to be displayed in the locals window for
 all method functions.Ï*")

;Ï1;; Code by JPR.Ï*
(DEFUN Ï4is-a-methodÏ* (FUNCTION)
  (AND (CONSP (FUNCTION-NAME function))
       (EQUAL :method (FIRST (FUNCTION-NAME function)))))

(DEFUN Ï4has-a-special-valueÏ* (symbol sg frame)
  (LET ((sp (sg-special-pdl sg)))
       (MULTIPLE-VALUE-BIND (start end)
	   (sg-frame-special-pdl-range sg frame)
	 (IGNORE end)
	 (IF (AND start end)
;	Ï1 (if startÏ*
;	Ï1     (do ((i start (- i 2)))Ï*
;		Ï1 ((<= i 0)Ï*
;		Ï1  nilÏ*
	     (DO ((i start (+ i 2)))
		 ((>= i end)
		  nil)
	       (IF (EQ symbol
		       (symbol-from-value-cell-location (AREF sp (1+ i))))
		   (MULTIPLE-VALUE-BIND (val error)
		       (CATCH-ERROR (AREF sp i) nil)
		     (IF error
			 (RETURN nil)
			 (RETURN (LIST symbol val))))
		   nil))
	     nil))))

(DEFUN Ï4specials-used-by-fefÏ* (fef &optional (sg nil) (frame nil))
  (LET ((specials nil)
	(old-disassemble-pointer #'compiler:disassemble-pointer))
       (letf ((#'compiler:disassemble-pointer
	       #'(lambda (&rest args)
		   (LET ((result (APPLY old-disassemble-pointer args)))
		        (IF (AND result
				 (SYMBOLP result))
			    (PUSHNEW result specials)
			    nil)
			result))))
	     (DO ((i 0 (1+ i))
		  (pc (fef-initial-pc fef)
		      (+ pc (compiler:disassemble-instruction-length fef pc)))
		  (lim-pc (compiler:disassemble-lim-pc fef)))
		 ((>= pc lim-pc))
	       (LET ((*standard-output* 'si:null-stream))
		    (compiler:disassemble-instruction fef pc))))
       (REMOVE nil (MAPCAR #'(lambda (x)
			       (IF sg
				   (has-a-special-value x sg frame)
				   (IF (GET x 'SPECIAL) x nil)))
			     specials))))

(DEFVAR Ï4*show-referenced-specials-in-locals-window*Ï* t
"Ï2When true specials that are read are shown in the debugger's locals window as
 well as those that are bound.Ï*")

(DEFUN Ï4setup-locals-windowÏ* (window sg frame rest-arg-p)
  (LET* (LIST
         (rp (sg-regular-pdl sg))
         (FUNCTION (rp-function-word rp frame))
         (sp (sg-special-pdl sg))
         start end self-value 
	 ;Ï1; Added by JPR.Ï*
	 local-specials self-mapping-table-value)
    ;Ï1; Print the locals if this is a fefÏ*
    (IF (TYPEP function 'compiled-function)
        (DO ((n-locals (fef-number-of-locals function))
             (local-idx (sys:rp-local-offset sg rp frame))
             (i 0 (1+ i)))
;Ï1;Ï*	Ï1   (J (+ FRAME (RP-LOCAL-BLOCK-ORIGIN RP FRAME)) (1+ J)))  ;; * old way to find locals *Ï*
            ((>= i n-locals))
          (COND ((NOT (AND rest-arg-p (ZEROP i)))     ;Ï1; Don't show rest arg (local 0) twiceÏ*
                 (PUSH (LIST (local-name function i)  ;Ï1; Local NameÏ*
;Ï1;Ï*			Ï1   (AREF RP J)Ï*
                             (AREF rp (+ i local-idx))        ;Ï1 Local ValueÏ*
                             i)                       ;Ï1 Local NumberÏ*
                       list)))))
    ;Ï1; Print the specials if anyÏ*
    (MULTIPLE-VALUE-SETQ (start end)
                         (sg-frame-special-pdl-range sg frame))
    (WHEN start
      (PUSH "" list)
      (PUSH "Ï3Specials:Ï*" list)
      (DO ((i start (+ i 2)))
          ((>= i end))
        (IF (EQ 'self (symbol-from-value-cell-location (AREF sp (1+ i))))
            (SETQ self-value (AREF sp i)))

	;Ï1; This code by JPR.Ï*
	(IF (EQ 'sys:self-mapping-table
		(symbol-from-value-cell-location (AREF sp (1+ i))))
            (SETQ self-mapping-table-value (AREF sp i)))
	(PUSH (symbol-from-value-cell-location (AREF sp (1+ i))) local-specials)

        (PUSH (LIST (symbol-from-value-cell-location (AREF sp (1+ i)))  ;Ï1; NameÏ*
                    (MULTIPLE-VALUE-BIND (val error)  ;Ï1; ValueÏ*
                        (CATCH-ERROR (AREF sp i) nil)
                      (IF error "Ï3unboundÏ*" val)))
              list)))
    ;Ï1; This code by JPR.Ï*
    (LET ((specials (IF (AND *show-referenced-specials-in-locals-window*
			     (TYPEP function 'compiled-function))
			(REMOVE-IF
			  #'(lambda (x) (MEMBER (FIRST x) local-specials))
			  (specials-used-by-fef function sg frame))
			nil)))
      (IF (AND specials (NOT  start))
	     (PROGN (PUSH "" list) (PUSH "Ï3Specials:Ï*" list)))
	 (LOOP for (name value) in specials
	       do (PUSH (LIST name value) list)))
    ;Ï1; This code by JPR.Ï*
    (IF (AND *show-self-in-locals-window-anyway*
	     (NOT self-value)
	     (OR (EQUAL :always *show-self-in-locals-window-anyway*)
		 (is-a-method function)))
	(PROGN (IF (NOT start)
		   (PROGN (PUSH "" list)
			  (PUSH "Ï3Specials:Ï*" list)))
	       (PUSH (LIST 'self
			   (CATCH-ERROR
			     (SYMEVAL-IN-STACK-GROUP 'self sg frame) nil))
		     list)
	       (IF (NOT self-mapping-table-value)
		   (PUSH (LIST 'sys:self-mapping-table
			       (CATCH-ERROR
				 (SYMEVAL-IN-STACK-GROUP
				   'sys:self-mapping-table sg frame) nil))
			 list))))
    ;Ï1; if SELF is mentioned in this frame, include its instance variables:Ï*
    (IF (AND self-value
             (TYPEP self-value 'instance))
        (LET* ((self-flavor 
                 (si:instance-flavor self-value))
               (self-vars (si::flavor-all-instance-variables-slow self-flavor)))
          (PUSH "" list)
          (PUSH "Ï3Non-special instance variables of SELF:Ï*" list)
          (DO ((sv self-vars (CDR sv))
               (i 1 (1+ i)))
              ((NULL sv))
            (COND ((NOT (si::assq-careful (CAR sv) list))
                   (PUSH (LIST (CAR sv)
                               (MULTIPLE-VALUE-BIND (val error)       ;Ï1ValueÏ*
                                   (CATCH-ERROR (%instance-ref self-value i) nil)
                                 (IF error "Ï3unboundÏ*" val)))
                         list))))))
    (SEND window :setup (LIST 'print-arg-or-local '(local "Ï3LocalÏ*") (NREVERSE list)))))

;Ï1-------------------------------------------------------------------------------Ï*
;Ï1;; Special searching...Ï*
;Ï1 TAC 08-08-89 - bug in here somewhere that blows the machine away if you do Ï*
;Ï1                the searching for specials bound-by or bound-in frame.Ï*

(DEFUN Ï4specials-bound-by-frameÏ* (sg frame)
  (LET ((result nil))
       (MULTIPLE-VALUE-BIND (start end) (sg-frame-special-pdl-range sg frame)
	 (IF start
	     (DO ((i start (+ i 2))) ((>= i end))
	       (PUSH (symbol-from-value-cell-location
		       (AREF (sg-special-pdl sg) (1+ i)))
		     result))
	     nil))
      result))

(DEFUN Ï4special-bound-in-frameÏ* (symbol sg frame)
  (LET ((syms (specials-bound-by-frame sg frame)))
    (MEMBER symbol syms :test
	    #'(lambda (a b)
		(SEARCH (SYMBOL-NAME a) (SYMBOL-NAME b)
			:test #'STRING-EQUAL)))))

(DEFUN Ï4special-used-in-frameÏ* (symbol sg frame)
  (LET ((syms (specials-used-by-fef
		(rp-function-word (sg-regular-pdl sg) frame) sg frame)))
       (MEMBER symbol syms :test
	 #'(lambda (a b)
	     (SEARCH (SYMBOL-NAME a) (SYMBOL-NAME (ucl::first-if-list b))
		     :test #'STRING-EQUAL)))))

(DEFUN Ï4get-something-and-search-for-itÏ* (sg from-frame)
  (LET ((thing (window-read-thing-dont-eval
		 "Ï3Type or mouse on a special to search for: Ï*")))
       (LET ((frame (DO ((frame from-frame (sg-next-frame sg frame)))
			((NULL frame) nil)
		      (IF (IF (EQUAL 2 *numeric-arg*)
			      (special-used-in-frame  thing sg frame)
			      (special-bound-in-frame thing sg frame))
			  (RETURN frame)
			  nil))))
	    frame)))

(DEFUN Ï4search-for-specialÏ* (sg frame)
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select a special to search for.Ï*")
   (UNWIND-PROTECT (get-something-and-search-for-it sg frame)
      (SEND *window-debugger* :set-who-line-doc-string-overide nil)
      (SEND *window-debugger* :handle-prompt)))

(DEFCOMMAND Ï4comw-search-cmdÏ* (*numeric-arg*)
            '(:description  
              "Ï3Search stack for a frame whose function's name contains a specified string.  
With numeric arg, search stack for frame that binds [arg = 2 -> uses] a special.Ï*"  
              :names "Ï3SearchÏ*"
	      :arguments (ucl:numeric-argument)
              :keys (#\c-s))
            (UNWIND-PROTECT (comw-search *error-sg* *error-object*)
                            (SEND *window-debugger* :handle-prompt)))

(DEFUN Ï4comw-searchÏ* (sg ignore)
  (IF (AND *numeric-arg* (PLUSP *numeric-arg*))
      (LET ((frame (get-something-and-search-for-it sg *current-frame*)))
	(COND ((NULL frame)
	       (FORMAT t "Ï3Search failed.~%Ï*"))
	      (t
	       (SETQ *current-frame* frame)
;	Ï1       (SETF ucl:top-level-selfÏ*
;		Ï1     (SYMEVAL-IN-STACK-GROUPÏ*
;		Ï1       'self ucl:*stack-group* *current-frame*))Ï*
;Ï1 TAC 09-04-89Ï*
	       (SETF ucl::top-level-self		
		     (SYMEVAL-IN-STACK-GROUP
		       'self *error-sg* *current-frame*))
	       (SEND *window-debugger* :setup-frame sg *current-frame*))))
	(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 (SETF ucl:top-level-selfÏ*
;		Ï1       (SYMEVAL-IN-STACK-GROUPÏ*
;			Ï1 'self ucl:*stack-group* *current-frame*))Ï*
;Ï1 TAC 09-04-89Ï*
		 (SETF ucl::top-level-self
		       (SYMEVAL-IN-STACK-GROUP
			 'self *error-sg* *current-frame*))
		 (SEND *window-debugger* :setup-frame sg *current-frame*))))))

;Ï1^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^Ï*

;Ï1 tac 08-08-89 - bug in here somewhere that blows the machine away if you do Ï*
;Ï1                the searching for specials bound-by or bound-in frame.Ï*

(DEFUN Ï4com-searchÏ* (sg error-object &optional numeric-arg flag)
  "Ï2Searches down the stack for a frame whose function name contains a specified string.  With numeric arg, 
search stack for frame that binds [arg = 2 -> uses] a special.Ï*"
  (DECLARE (SPECIAL *current-frame*)
	   (IGNORE error-object))
  (IF numeric-arg
      (LET ((frame (get-something-and-search-for-it sg *current-frame*)))
	(COND ((NULL frame)
	       (FORMAT t "Ï3Search failed.~%Ï*"))
	      (t
	       (SETQ *current-frame* frame)
	       (IF flag
		   (show-all sg)
		   (show-function-and-args sg)))))
      (PROGN
	(FORMAT t "Ï3~%String to search for (end with RETURN):~%Ï*")
	(LET* ((key (READ-LINE))
	       ;Ï1; Look for frame whose function name contains KEY.Ï*
	       ;Ï1; If found print function and its args.Ï*
	       (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))))
			(IF (SEARCH key (THE string name) :test #'CHAR-EQUAL) 
			    (RETURN frame)))))
	  (COND ((NULL frame)
		 (FORMAT t "Ï3Search failed.~%Ï*"))
		(t
		 (SETQ *current-frame* frame)
		 (IF flag
		     (show-all sg)
		     (show-function-and-args sg))))))))

;Ï1-------------------------------------------------------------------------------

Ï*(install-window-debugger-commands)