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

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

;Ï1;; This software developed by:Ï*
;Ï1;;Ï*	Ï1James RiceÏ*
;Ï1;; at the Stanford University Knowledge Systems Lab in 1986 and 1987.Ï*
;Ï1;;Ï*
;Ï1;; This work was supported in part by:Ï*
;Ï1;;Ï*	Ï1DARPA Grant F30602-85-C-0012Ï*
;Ï1;;----------------------------------------------------------------------Ï*
;Ï1;;  Most of this file derived from code licensed from Texas InstrumentsÏ*
;Ï1;;  Inc.  Since we'd like them to adopt these changes, we're claimingÏ*
;Ï1;;  no rights to them, however, the following restrictions apply to theÏ*
;Ï1;;  TI code:Ï*

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

;Ï1;; This file implements a set of commands which add consistency between theÏ*
;Ï1;; tools already provided oon the Lispm.  For instance and inspect commandÏ*
;Ï1;; is added to Zmacs, just there is one in the other tools.Ï*

;Ï1;; Also defined is a facility whereby edit buffer streams appear in the whoÏ*
;Ï1;; line.Ï*

;Ï1 TAC 07-25-89 commented out edit buffer streams appearing in who line - problems.Ï*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1zwei:Ï*
;Ï1(defvar zwei:*Zmacs-Buffer-Streams-Displayed-In-Who-Line-P* nilÏ*
;Ï1"When true any open Zmacs buffer streams wil be displayed in the who lineÏ*
;Ï1 along with ordinary files.Ï*
;Ï1"Ï*
;Ï1)Ï*

;Ï1(defvar *background-process-display-font* fonts:tinyÏ*
;Ï1"The font in which to display background processes."Ï*
;Ï1)Ï*

;Ï1(defvar *who-line-run-state-toggle-time* 0.5Ï*
;Ï1"The time after which the run state sheet toggles into showingÏ*
;Ï1 background processes.Ï*
;Ï1"Ï*
;Ï1)Ï*

;Ï1(defvar *show-background-processes-in-who-line* nilÏ*
;Ï1"When true background processes that are interesting are shown in the who-lineÏ*
;Ï1 run-state part of the who line.Ï*
;Ï1"Ï*
;Ï1)Ï*

;Ï1;(setq *show-background-processes-in-who-line* t)Ï*

;Ï1(defvar *Chars-for-who-line-package* 7.Ï*
;Ï1  "The number of chars in the who-line for the package name."Ï*
;Ï1)Ï*
;Ï1(export '*Chars-for-who-line-package* 'tv)Ï*

;Ï1(defvar *Chars-for-who-line-process-state* 20.Ï*
;Ï1  "The number of chars in the who-line for the process-state."Ï*
;Ï1)Ï*
;Ï1(export '*Chars-for-who-line-process-state* 'tv)Ï*

;Ï1(defvar *Show-Two-Files-In-Who-Line* nilÏ*
;Ï1  "When non-nil, two files will be shown in the who line when appropriate."Ï*
;Ï1)Ï*
;Ï1(export '*Show-Two-Files-In-Who-Line* 'tv)Ï*

;Ï1 ;; End of microExplorer conditionalizationÏ*

;Ï1-----------------------------------------------------------------------------------------------------------Ï*
;Ï1;; Support for fat strings.Ï*

(DEFUN Ï4format-fat-string-streamÏ* (op &rest args)
  (CASE op
    (:tyo
     (OR format::format-string (SETQ format::format-string (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.)))
      (VECTOR-PUSH-EXTEND (FIRST args) format::format-string))
    (:string-out
     (LET ((STRING (FIRST args))
	   (FIRST (OR (SECOND args) 0.))
	   (LAST (THIRD args))
	   new-length)
       (OR format::format-string (SETQ format::format-string (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.)))
       (SETQ last (OR last (LENGTH string)))
       (SETQ new-length (+ (ARRAY-LEADER format::format-string 0.) (- last first)))
       (AND (< (ARRAY-TOTAL-SIZE format::format-string) new-length)
	  (ADJUST-ARRAY format::format-string (+ (ARRAY-TOTAL-SIZE format::format-string) new-length)))
       (COPY-ARRAY-PORTION string first last format::format-string (ARRAY-LEADER format::format-string 0.)
			   new-length)
       (STORE-ARRAY-LEADER new-length format::format-string 0.)))
    (:read-cursorpos
     (LET ((mode (OR (FIRST args) :character))
	   pos)
       (OR format::format-string (SETQ format::format-string (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.)))
       (OR (EQ mode :character) (FERROR () "Ï3String cannot have :PIXELÏ*"))
       (SETQ pos
	     (POSITION #\Newline (THE string (STRING format::format-string)) :from-end t :test
		       #'CHAR-EQUAL))
       (VALUES (- (LENGTH format::format-string) (IF pos
					   (+ pos 1.)
					   0.)) 0.)))
    (:increment-cursorpos
     (LET ((dx (FIRST args))
	   (dy (SECOND args))
	   (mode (OR (THIRD args) :character))
	   newlen)
       (OR format::format-string (SETQ format::format-string (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.)))
       (OR (EQ mode :character) (FERROR () "Ï3String cannot have :PIXELÏ*"))
       (OR (AND (ZEROP dy) (NOT (MINUSP dx))) (FERROR () "Ï3Cannot do this :INCREMENT-CURSORPOSÏ*"))
       (SETQ newlen (+ (LENGTH format::format-string) dx))
       (AND (< (ARRAY-TOTAL-SIZE format::format-string) newlen)
	  (ADJUST-ARRAY format::format-string (+ (ARRAY-TOTAL-SIZE format::format-string) newlen)))
       (DO ((i (LENGTH format::format-string) (1+ i)))
	   ((>= i newlen))
	 (SETF (AREF format::format-string i) #\Space))
       (STORE-ARRAY-LEADER newlen format::format-string 0.)))
    (:set-cursorpos
     (LET ((x (FIRST args))
	   (y (SECOND args))
	   (mode (OR (THIRD args) :character))
	   pos
	   delta
	   newlen)
       (OR format::format-string (SETQ format::format-string (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.)))
       (OR (EQ mode :character) (FERROR () "Ï3String cannot have :PIXELÏ*"))
       (SETQ pos (STRING-REVERSE-SEARCH-SET '(#\Newline #\Linefeed #\Page) format::format-string)
	     delta (- x (- (LENGTH format::format-string) (IF pos
						    (+ pos 1.)
						    0.))))
       (OR (AND (ZEROP y) (PLUSP delta)) (FERROR () "Ï3Cannot do this :SET-CURSORPOSÏ*"))
       (SETQ newlen (+ (LENGTH format::format-string) delta))
       (AND (< (ARRAY-TOTAL-SIZE format::format-string) newlen)
	  (ADJUST-ARRAY format::format-string (+ (ARRAY-TOTAL-SIZE format::format-string) newlen)))
       (DO ((i (LENGTH format::format-string) (1+ i)))
	   ((>= i newlen))
	 (SETF (AREF format::format-string i) #\Space))
       (STORE-ARRAY-LEADER newlen format::format-string 0.)))
    (:untyo-mark (FILL-POINTER format::format-string))
    (:untyo (LET ((mark (FIRST args)))
	      (SETF (FILL-POINTER format::format-string) mark)))
    (extract-string (PROG1
		      format::format-string
		      (SETQ format::format-string ())))
    (:get-string format::format-string)
    (:fresh-line
     (WHEN (NOT
       (OR (NULL format::format-string) (ZEROP (LENGTH format::format-string))
	  (= (AREF format::format-string (1- (LENGTH format::format-string))) #\Newline)))
       (VECTOR-PUSH-EXTEND #\Newline format::format-string)
       t))
    (:which-operations nil
     '(:tyo :string-out :read-cursorpos :increment-cursorpos :set-cursorpos :untyo-mark :untyo
       extract-string :fresh-line))
    (t (STREAM-DEFAULT-HANDLER 'format::format-string-stream op (CAR args) (CDR args)))))

(DEFUN Ï4make-fat-string-output-streamÏ* (&optional string start-index extra-arg)
  (IF (STRINGP start-index)
    (LET ((STRING start-index)
	  (start-index extra-arg))
      (LET-CLOSED
       ((format-string
	  (OR string
	      (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.))))
       (IF start-index
	 (SETF (FILL-POINTER format-string) start-index))
       'format-string-stream))
    (LET-CLOSED
      ((format-string
	 (OR string
	     (MAKE-ARRAY 64. :type 'art-fat-string :fill-pointer 0.))))
       (IF start-index
	 (SETF (FILL-POINTER format-string) start-index))
       'format-fat-string-stream)))

(DEFMACRO Ï4with-output-to-fat-stringÏ*
	  ((STREAM string index) &body body &aux (string-symbol string))
  (MULTIPLE-VALUE-BIND (realbody decls)
      (PARSE-BODY body nil nil)
    (LET ((doc (AND  decls `((DECLARE . ,(sys::flatten-declarations decls))))))
      (IF index
	  `(LET* (,@(AND (NOT (SYMBOLP string))
			 `((,(SETF string-symbol (GENSYM))  ,string)))
		  (,stream
		   (make-fat-string-output-stream ,string-symbol ,index)))
	     ,@doc 
	     (UNWIND-PROTECT
		     (PROGN
		       ,@realbody)
		   (SETF ,index (LENGTH ,string-symbol))))
	      `(LET ((,stream (make-fat-string-output-stream
				,@(IF string `(,string)))))
		 ,@doc
		 ,@realbody
		 ,@(IF (NULL string )
		       `((GET-OUTPUT-STREAM-STRING ,stream))))))))

sys:
(DEFUN Ï4sys::make-string-input-streamÏ* (STRING &optional (start 0) end)
  "Ï2Return a stream from which one can read the characters of STRING, or some substring of it.
 START and END are indices specifying a substring of STRING;
 they default to 0 and NIL (NIL for END means the end of STRING).Ï*"
  (SETQ string (IF (TYPEP string 'VECTOR) string (STRING string)))
  (LET-CLOSED ((*ioch start) (*ioend (OR end (LENGTH string))) (*iolst string))
     'read-from-string-stream))

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

;Ï1;; Support for searching and grovling over items in inspectors and such-like.Ï*

;Ï1*************Ï*
;Ï1 TAC 07-26-89 - defstruct was defined in Structure-Enhancements whichÏ*
;Ï1                redefines 2 kernel functions radically enough that a decisionÏ*
;Ï1                NOT to use it was made. Instead, map defstruct back to Ï*
;Ï1                original DEFSTRUCT with (DEFF defstruct 'DEFSTRUCT) in theÏ*
;Ï1                TI-ENV-INSPECTOR-INTERFACE file .Ï*

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

;Ï1;; A defstruct with which to remember the saved points in the searches.Ï*
(defstruct Ï4(saved-posÏ* :named) line char printed string failed-p)

(DEFUN Ï4(:property saved-pos named-structure-invokeÏ*)
       (message-name pos &rest arguments)
  (CASE message-name
    (:print-self
      (LET ((STREAM   (FIRST arguments)))
	   (FORMAT stream "Ï3#<Saved Pos: ~A, ~A>Ï*" (saved-pos-line pos)
		   (saved-pos-char pos))))
    (:which-operations '(:which-operations :print-self))
    (otherwise (FERROR "Ï3Illegal message ~A sent to a saved pos.Ï*"))))

(DEFPARAMETER Ï4*last-search-string*Ï* ""
"Ï2The last string used by the user in searching.Ï*")

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

;Ï1 TAC 08-09-89 - not doing source code debuggingÏ*
;Ï1(defparameter *fontify-this-region* nilÏ*		
;Ï1"When true tells the pretty printer to fontify the region.  If it is not sourceÏ*
;Ï1 code debugging then its value is the font number to fontify to.Ï*
;Ï1"Ï*
;Ï1)Ï*

;Ï1(defparameter *font-for-selected-region* 1Ï*
;Ï1"The font number to use for the selected region in source code debugging."Ï*
;Ï1)Ï*

;Ï1(defun shifted-font ()Ï*
;Ï1"Returns the font number to which to shift."Ï*
;Ï1  (declare (special eh::*grinding-debugged-source-code* eh::*current-pc*))Ï*
;Ï1  (if (and (boundp 'eh::*grinding-debugged-source-code*)Ï*
;	Ï1   eh::*grinding-debugged-source-code*Ï*
;Ï1      )Ï*
;Ï1      ;;; Hook for Source code debugger.Ï*
;Ï1      (if (equal (first (funcall 'eh::numbered-component-numbersÏ*
;			Ï1  (first eh::*grinding-debugged-source-code*)))Ï*
;		Ï1 eh::*current-pc* )Ï*
;	Ï1  *font-for-selected-region*Ï*
;	Ï1  (+ 1 *font-for-selected-region*))Ï*
;Ï1      (if (numberp *fontify-this-region*)Ï*
;	Ï1  *fontify-this-region*Ï*
;	Ï1  0)))Ï*

(DEFPARAMETER Ï4*fontify-this-region*Ï* nil		
  "Ï2When true tells the pretty printer to fontify the region.Ï*")

(DEFUN Ï4shifted-fontÏ* ()
  "Ï2Returns the font number to which to shift.Ï*"
  (IF (NUMBERP *fontify-this-region*)
      *fontify-this-region*
      0))

(DEFUN Ï4fontify-charÏ* (CHAR)
"Ï2Given a char returns the char fontified to the (shifted-font).Ï*"
  (CODE-CHAR (TYPECASE char
	       (integer (CODE-CHAR char))
	       (CHARACTER (CODE-CHAR (CHAR-CODE char)))
	       (otherwise (BEEP) char))
	     0 (OR (shifted-font) 0)))

(DEFFLAVOR Ï4pseudo-itemising-streamÏ*
	   (STREAM           ;Ï1; Actual stream to print to.Ï*
	    (current-font 0) ;Ï1; Printing in this font.Ï*
	    superior         ;Ï1; The superior of the current window, which created me.Ï*
	    (width 0)        ;Ï1; The current printed width in pixels.Ï*
	    max-width        ;Ï1; The max width of the window.Ï*
	    font-map         ;Ï1; The font map of the window.Ï*
	   )
	   (si:output-stream)
  :initable-instance-variables
  :settable-instance-variables
  :gettable-instance-variables
  (:documentation "Ï3A stream which font-shifts all of its characters if necessary.Ï*"))

(DEFMETHOD Ï4(pseudo-itemising-stream :tyoÏ*) (CHAR &rest args)
"Ï2Prints char to the stream, fontifying it to the stream's current font.Ï*"
  (LET ((the-char (CODE-CHAR (CHAR-CODE (fontify-char char)) 0 current-font)))
       ;Ï1; Record the width of the char.Ï*
       (SETQ width (+ (font-char-width (AREF font-map current-font)) width))
       ;Ï1; Throw if we've written too much, otherwise print it.Ï*
       (IF (>= width max-width)
	   (THROW 'TRUNCATE nil)
	   (LEXPR-SEND stream :tyo the-char args))))

(DEFMETHOD Ï4(pseudo-itemising-stream :item1Ï*)
    (item type &optional (FUNCTION #'PRIN1) &rest print-args)
"Ï2A dummy version of the :item1 method.Ï*"
  (IGNORE type)
  (APPLY function item self print-args))

(DEFMETHOD Ï4(pseudo-itemising-stream :compoundÏ*) (some-items)
  (LOOP for item in some-items do
	(IF (CONSP item)
	    (LEXPR-SEND self item)
	    (FORMAT self "Ï3~AÏ*" item))))

(DEFMETHOD Ï4(pseudo-itemising-stream :read-cursorposÏ*) (&rest args)
"Ï2Passes this message on so that tabbing works ok.Ï*"
  (LEXPR-SEND stream :read-cursorpos args))

(DEFMETHOD Ï4(pseudo-itemising-stream :increment-cursorposÏ*)
	   (x-increment y-increment &optional (mode :pixel))
"Ï2Passes this message on so that tabbing works ok.Ï*"
  ;Ï1; Increment width as approriate.Ï*
  (SETQ width (+ (IF (EQUAL mode :pixel)
		     x-increment
		     (* (font-char-width (AREF font-map 0)) x-increment))
		 width))
  ;Ï1; Do this because sometimes we get negative increments on 0 length strings.Ï*
  (CATCH-ERROR (SEND stream :increment-cursorpos x-increment y-increment mode)
	       nil))

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

(DEFUN Ï4print-out-itemÏ*
       (print-function print-function-arg item item-number width)
"Ï2Prints out a window item for an inspect window into a fat string.Ï*"
  (LET ((result
	  (IF (EQUAL (SEND self :print-function-arg)
		     :list-structure)
	      (LET ((item (AREF (SEND self :items) item-number)))
		   (IF (AND (CONSP item) (STRINGP (SECOND item)))
		       (SECOND item)
		       ""))
	      (with-output-to-fat-string (string-stream)
		(LET ((*standard-output*
			(MAKE-INSTANCE
			  'pseudo-itemising-stream
			  :stream    string-stream
			  :superior  (SEND self :superior)
			  :max-width (OR width (SEND self :width))
			  :font-map  (SEND self :font-map))))
		     (CATCH 'TRUNCATE
			    (FUNCALL print-function item print-function-arg
				     *standard-output* item-number)))))))
       (IF result result "")))

(DEFMETHOD Ï4(function-text-scroll-window :stringise-itemÏ*)
	   (item-number cache &optional (max-width (SEND self :width)))
"Ï2Given an item number from self's items, finds a fat-string printed
 representation of it in the cache or prints it to a fat string and caches it
 as needed.  Returns the string.Ï*"
  (OR (AREF cache item-number)
      (LET ((str (print-out-item print-function print-function-arg
				 (SEND self :item-of-number item-number)
				 item-number max-width)))
	   (SETF (AREF cache item-number) str)
	   str)))

(DEFUN Ï4search-for-itemÏ*
    (cache string item-number from-line from-char reverse-p)
"Ï2Searches forwards or backwards, according to reverse-p for String in the item
 of self, whose index is Item-Number.  It starts looking from the beginning or
 end of the item as approriate, using from-line and from-char to tell it where
 to start from if the search is on the line that we're already on - we have to
 make sure that we don't find the same match again unless we want to.Ï*"
  (LET ((printed
	  (SEND self :stringise-item item-number cache most-positive-fixnum)))
       (LET ((index
	        (IF (EQUAL from-line item-number)
		    (SEARCH string printed :test #'CHAR-EQUAL
			    :start2 (IF reverse-p nil from-char)
			    :end2   (IF reverse-p
					(+ (LENGTH string) from-char)
					nil)
			    :from-end reverse-p)
		    (SEARCH string printed :test #'CHAR-EQUAL
			    :from-end reverse-p))))
	    (IF index
		(VALUES index printed)
		(VALUES nil nil)))))

(DEFMETHOD Ï4(function-text-scroll-window :searchÏ*)
	   (cache for &optional (from-line 0) (from-char 0) (printed-line "")
	    (reverse-p nil))
"Ï2Searches for the string For in the window items self either forwarrds or
 backwards, as defined by reverse-p, starting from From-line, From-Char.Ï*"
  (IGNORE printed-line)
  (IF reverse-p
      (LOOP for item downfrom from-line to 0
	    do (MULTIPLE-VALUE-BIND (CHAR line)
		   (search-for-item cache for item from-line from-char t)
		 (IF char (RETURN item char line) nil))
	    finally (RETURN nil nil nil))
      (LOOP for item from from-line to (- (SEND self :number-of-items) 1)
	    do (MULTIPLE-VALUE-BIND (CHAR line)
		   (search-for-item cache for item from-line from-char nil)
		 (IF char (RETURN item char line) nil))
	    finally (RETURN nil nil nil))))

(DEFMETHOD Ï4(function-text-scroll-window :move-toÏ*) (pos reverse-p)
"Ï2Moves Self to the position described by Pos, scrolling the window so that the
 item is at the top if necessary.  The blinker is moved to point at the
 beginning of the string and sized to fit the char under it.Ï*"
  (MULTIPLE-VALUE-BIND (bottom line) (SEND self :bottom-item-no-on-screen)
    (IGNORE line)
    (IF (OR (< (saved-pos-line pos) top-item) (> (saved-pos-line pos) bottom))
	(SEND self :scroll-to (saved-pos-line pos) :absolute)
	nil)
    (IF (STRING-EQUAL "" (saved-pos-printed pos))
	nil
	(LET ((CHAR (+ (AREF (saved-pos-printed pos) (saved-pos-char pos))
		       (IF reverse-p 0 (LENGTH (saved-pos-string pos))))))
	     (SEND (FIRST blinker-list) :set-visibility :blink)
	     (LET ((font (AREF font-map (CHAR-FONT char))))
	          (LET ((bl-width (IF (AND (font-char-width-table font)
					   (> (AREF (font-char-width-table font)
						    (CHAR-CODE char))
					      0))
				      (AREF (font-char-width-table font)
					    (CHAR-CODE char))
				      (font-char-width font))))
		       (MULTIPLE-VALUE-BIND (final-x final-y)
			   (sheet-compute-motion self 0 0
			       (saved-pos-printed pos) 0
			       (+ (IF reverse-p
				      0
				      (LENGTH (saved-pos-string pos)))
				  (saved-pos-char pos)))
			 (SEND (FIRST blinker-list) :set-size-and-cursorpos
			       bl-width
			       (font-char-height font)
			       (IF (> final-y 0)
				   (- (sheet-inside-right self) bl-width)
				   final-x)
			       (* (SEND self :line-height)
				  (- (saved-pos-line pos) top-item))))))))))

(DEFMACRO Ï4with-saved-posÏ* (&body body)
"Ï2Binds the names Line, Char and Printed to position at the top of the
 saved position stack.Ï*"
  `(LET ((pos (FIRST saved-positions)))
        (DECLARE (UNSPECIAL pos))
	(CHECK-TYPE pos saved-pos)
        (LET ((line    (saved-pos-line    pos))
	      (CHAR    (saved-pos-char    pos))
	      (printed (saved-pos-printed pos))
	      (STRING  (saved-pos-string  pos))
	     )
	  (DECLARE (UNSPECIAL line char printed string))
	     (CHECK-TYPE line    integer)
	     (CHECK-TYPE char    integer)
	     (CHECK-TYPE printed string)
	     (CHECK-TYPE string  string)
	     ,@body)))

(DEFUN Ï4newÏ* (new-string line char printed failed-p)
"Ï2Create a new saved position record for new-string, line, char.  If the last one
 was a failed one then do nothing.  If this one is failed then use the line char
 etc. of the last one.  Beep if this is the first failure.Ï*"
  (DECLARE (SPECIAL saved-positions))
  (IF failed-p
      (IF (AND (saved-pos-failed-p (FIRST saved-positions))
	       (STRING-EQUAL (saved-pos-string (FIRST saved-positions))
			     new-string))
	  nil ;Ï1; We've already failed so do nothing.Ï*
	  (with-saved-pos
	    (IF (saved-pos-failed-p (FIRST saved-positions)) nil (BEEP))
	    (PUSH (make-saved-pos :line line
				  :char char
				  :printed printed
				  :string new-string
				  :failed-p failed-p)
		  saved-positions)))
      (PUSH (make-saved-pos :line line
			    :char char
			    :printed printed
			    :string new-string
			    :failed-p failed-p)
	    saved-positions)))

(DEFMETHOD Ï4(function-text-scroll-window :process-other-charÏ*)
	   (cache char reverse-p)
"Ï2Processes a typed in char which is not a special one, such as c-s.  Continues
 the search.Ï*"
  (DECLARE (SPECIAL *last-search-string* saved-positions))
  (LET ((new-string
	  (STRING-APPEND (saved-pos-string (FIRST saved-positions)) char)))
       (MULTIPLE-VALUE-BIND (line char printed)
	   (with-saved-pos (IGNORE string)
	     (SEND self :search cache new-string line char printed reverse-p))
	 (IF line
	     (PROGN (new new-string line char printed nil)
		    (SETQ *last-search-string* new-string)
		    (SEND self :move-to (FIRST saved-positions) reverse-p))
	     (with-saved-pos (IGNORE string)
	       (new new-string line char printed t))))))

(DEFMETHOD Ï4(function-text-scroll-window :process-next-searchÏ*) (cache reverse-p)
"Ï2Processes a request to continue the search, i.e. c-s or c-r.  Reverse-p defines
 whether to search forwards or backwards.Ï*"
  (DECLARE (SPECIAL saved-positions))
  (MULTIPLE-VALUE-BIND (line char printed)
      (with-saved-pos
	(LET ((STRING (IF (EQUALP string "") *last-search-string* string)))
	     (DECLARE (UNSPECIAL string))
	     (SEND self :search cache string line (+ (IF reverse-p -1 1) char)
		   printed reverse-p)))
      (LET ((STRING (IF (EQUALP (saved-pos-string (FIRST saved-positions)) "")
			*last-search-string*
			(saved-pos-string (FIRST saved-positions)))))
	   (DECLARE (UNSPECIAL string))
	   (IF line
	       (PROGN (new string line char printed nil)
		      (SEND self :move-to (FIRST saved-positions) reverse-p))
	       (new string line char printed t)))))

(DEFMETHOD Ï4(function-text-scroll-window :show-search-stringÏ*) (reverse-p)
"Ï2Print out the search string in the prompt window i nthe form \"ISearch: foo\".
 Also prints out Reverse and Failing, as appropriate.Ï*"
  (DECLARE (SPECIAL saved-positions))
  (SEND *query-io* :set-cursorpos 0
       (SECOND (MULTIPLE-VALUE-LIST (SEND *query-io* :read-cursorpos))))
  (SEND *query-io* :clear-eol)
  (IF (saved-pos-failed-p (FIRST saved-positions))
      (FORMAT *query-io* "Ï3Failing Ï*")
      nil)
  (IF reverse-p (FORMAT *query-io* "Ï3Reverse Ï*") nil)
  (FORMAT *query-io* "Ï3I-Search: ~AÏ*" (saved-pos-string (FIRST saved-positions))))

(DEFMETHOD Ï4(function-text-scroll-window :get-a-charÏ*) ()
"Ï2Reads a char from the user, coercing it into a char if it can.  It does this so
 that it can spot mouse blips and yet still get char objects.Ï*"
  (LET ((CHAR (SEND *query-io* :any-tyi)))
       (TYPECASE char
	 (CONS char)
	 (integer (INT-CHAR char))
	 (CHARACTER char)
	 (otherwise (BEEP)))))

(DEFMETHOD Ï4(function-text-scroll-window :control-s-internalÏ*) (reverse-p cache)
"Ï2Loops reading chars from the user and searches for the designated thing in the
 window, like c-s/c-r in ZMacs.Ï*"
  (DECLARE (SPECIAL saved-positions))
  (LOOP for char = (SEND self :get-a-char)
	do (CASE char
	     (#\× (FORMAT *query-io* "Ï3×~&Ï*") (RETURN nil))
	     (#\c-s
	      (SETQ reverse-p nil)
	      (SEND self :process-next-search cache reverse-p))
	     (#\c-r
	      (SETQ reverse-p :backwards)
	      (SEND self :process-next-search cache reverse-p))
	     (#\rubout
	       (IF (REST saved-positions)
		   (PROGN (POP saved-positions)
			  (SEND self :move-to (FIRST saved-positions) reverse-p))
		   (BEEP)))
	     (otherwise
	      (IF (CONSP char)
		  (PROGN (FORMAT *query-io* "Ï3×~&Ï*") (RETURN nil))
		  (SEND self :process-other-char cache char reverse-p))))
	   (SEND self :show-search-string reverse-p)))

(DEFMETHOD Ï4(function-text-scroll-window :bottom-item-no-on-screenÏ*) ()
"Ï2Returns values of the item# for the bottom item on the screen and the number
 of lines on the screen.Ï*"
  (LET ((lines-on-screen (FLOOR (/ (SEND self :inside-height)
				   (SEND self :line-height)))))
    (VALUES (+ top-item lines-on-screen) lines-on-screen)))

(DEFMETHOD Ï4(function-text-scroll-window :start-saved-positionÏ*) (reverse-p cache)
"Ï2Determines an initial position from which to start the search and makes a
 saved position do hold it.  It has to stringise a line to do this so the cache
 is passed so that it can be saved.Ï*"
  (IF reverse-p
      (LET ((line (- (MIN (SEND self :bottom-item-no-on-screen)
		          (SEND self :number-of-items))
		     1)))
	   ;Ï1; End of last line on screen.Ï*
	   (LET ((STRING (SEND self :stringise-item line cache)))
	       `(,(make-saved-pos :line line :printed string :string ""
			:char (MAX 0 (- (ARRAY-ACTIVE-LENGTH string) 1))
			:failed-p nil))))
      ;Ï1; Beginning of first line on screen.Ï*
     `(,(make-saved-pos :line (SEND self :top-item) :char 0 :string "" :printed
           (SEND self :stringise-item 0 cache) :failed-p nil))))

(DEFMETHOD Ï4(function-text-scroll-window :reset-blinkersÏ*) ()
"Ï2Cleans up blinkers.  Sometimes these can get confused.  This is bit kludgy.Ï*"
  (LET ((blinkers (BUTLAST (tv:sheet-blinker-list self) 2)))
       (MAPCAR #'(lambda (x)
		   (SEND x :set-visibility nil)
		   (SETF (tv:sheet-blinker-list self)
			 (REMOVE x (tv:sheet-blinker-list self))))
		 blinkers)))

(DEFMETHOD Ï4(function-text-scroll-window :make-a-blinkerÏ*) (reverse-p)
"Ï2Makes a blinker and sets its initial position.  The initial position is
 determined by whether we are going forwards or backwards.Ï*"
  (make-blinker self 'rectangular-blinker
		;Ï1;; These positions are a bit random.Ï*
		:x-pos (IF reverse-p (- (SEND self :inside-width)  10) 10)
		:y-pos (IF reverse-p (- (SEND self :inside-height) 10)  0)))

(DEFMETHOD Ï4(function-text-scroll-window :control-sÏ*) (reverse-p)
"Ï2Searches over the items in an inspect window (optionally backwards) in such
 a manner that it looks like I-Search in ZMacs.Ï*"
  (SEND self :reset-blinkers)
  (FORMAT *query-io* (IF reverse-p "Ï3~&Reverse I-Search: Ï*" "Ï3~&I-Search: Ï*"))
  (IF (> (SEND self :number-of-items) 0)
      (LET ((cache (MAKE-ARRAY (SEND self :number-of-items))))
	   (LET ((saved-positions
		   (SEND self :start-saved-position reverse-p cache))
		 (old-visibilities (get-visibility-of-all-sheets-blinkers self))
		 (blinker (SEND self :make-a-blinker reverse-p)))
	        (DECLARE (SPECIAL saved-positions)
			 (UNSPECIAL old-visibilities blinker))
	        ;Ï1; These functions would be IVs if this was to be a mixin.Ï*
	        ;Ï1; Mixing it in would be a good idea in principle but a drag in practice.Ï*
	        (UNWIND-PROTECT
		    (PROGN (set-visibility-of-all-sheets-blinkers
			     self
			     (CONS :blink
				   (MAKE-LIST (LENGTH old-visibilities))))
			   (SEND self :control-s-internal reverse-p cache))
		  (open-blinker blinker)
		  (set-visibility-of-all-sheets-blinkers
		    self (CONS nil old-visibilities))
		  (SETF (sheet-blinker-list self)
			(REMOVE blinker (sheet-blinker-list self))))))
      (PROGN (FORMAT *query-io* "Ï3Nothing in window.Ï*") (BEEP))))

(DEFUN Ï4get-a-paneÏ* (frame numeric-arg)
"Ï2Given a frame and the numeric arg typed by the user, if any, it selects a pane
 in the frame to use.  This should be an instance of Function-Text-Scroll-Window.
 If there is a numeric arg, then it picks the window under the mouse.  If not then 
 it picks the first Inspect-Pane-With-Typeout instance in the exposed-inferiors, 
 failing that it picks the first Basic-Inspect.Ï*"
  (IF numeric-arg
      (IF (TYPEP (window-under-mouse) 'function-text-scroll-window)
	  (window-under-mouse)
	  (PROGN (BEEP)
		 (FORMAT *query-io*
			 "Ï3~&Cannot search in window under mouse.~&Ï*")
		 nil))
      (OR (FIND-IF
	    #'(lambda (x) (TYPEP x 'inspect-pane-with-typeout))
	    (SEND frame :exposed-inferiors))
	  (FIND-IF
	    #'(lambda (x) (TYPEP x 'inspect-window-with-typeout))
	    (SEND frame :exposed-inferiors))
	  (FIND-IF
	    #'(lambda (x) (TYPEP x 'basic-inspect))
	    (SEND frame :exposed-inferiors)))))

(DEFUN Ï4process-control-sÏ* (frame reverse-p numeric-arg)
"Ï2Searches over the items in the main inspect window (optionally backwards) of
 the frame in such a manner that it looks like I-Search in ZMacs.Ï*"
  (LET ((pane (get-a-pane frame numeric-arg)))
       (IF pane (SEND pane :control-s reverse-p) nil)))

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

(DEFMETHOD Ï4(function-text-scroll-window :meta-wÏ*) ()
"Ï2Like m-w in Zmacs, copies the text in the window into the kill ring.Ï*"
  (IF (> (SEND self :number-of-items) 0)
      (LET ((cache (MAKE-ARRAY (SEND self :number-of-items))))
	   (MULTIPLE-VALUE-BIND (bottom ignore)
	       (SEND self :bottom-item-no-on-screen)
	     (LET ((result nil))
	          (LOOP for i
			from top-item
			to (- (MIN bottom (SEND self :number-of-items)) 1)
			do (PUSH (SEND self :stringise-item i cache) result)
			   (PUSH #\newline result))
		  (zwei:kill-string
		    (APPLY #'STRING-APPEND
			   (CONS (FORMAT nil "Ï3~A~&Ï*" (SIXTH (SEND self :label)))
				 (REVERSE result)))
		    nil nil))))
      (PROGN (FORMAT *query-io* "Ï3Nothing in window.Ï*") (BEEP))))

(DEFUN Ï4process-meta-wÏ* (frame numeric-arg)
"Ï2Called when the user does a m-w in the inspector/debugger.  Copies the text
 in the window into the kill ring as appropriate.Ï*"
  (LET ((pane (get-a-pane frame numeric-arg)))
       (IF pane (SEND pane :meta-w) nil)))

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

;Ï1;; The Meta-W command (save-region).Ï*

(DEFCOMMAND Ï4save-region-cmdÏ* (numeric-arg)
  '(:description
     "Ï3Puts the contents of the window into the kill ring, numeric arg for window under mouse.Ï*"
    :names ("Ï3Save RegionÏ*")
    :keys (#\m-w)
    :arguments (ucl:numeric-argument))
  (DECLARE (SPECIAL frame))
  (process-meta-w frame numeric-arg)
  (SEND frame :handle-prompt))

eh:
(DEFCOMMAND Ï4eh::comw-save-regionÏ* (numeric-arg)
  '(:description
     "Ï3Puts the contents of the window into the kill ring, numeric arg for window under mouse.Ï*"
     :names ("Ï3Save RegionÏ*")
     :keys (#\m-w)
     :arguments (ucl:numeric-argument))
  (DECLARE (SPECIAL *window-debugger*))
  (tv::process-meta-w *window-debugger* numeric-arg)
  (SEND *window-debugger* :handle-prompt))

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

;Ï1;; The ISearch Command.Ï*

(DEFCOMMAND Ï4search-cmdÏ* (numeric-arg)
  '(:description
     "Ï3I-Search for text in window, numeric arg for window under mouse.Ï*"
    :names ("Ï3SearchÏ*")
    :keys (#\c-s #\c-sh-s)
    :arguments (ucl:numeric-argument))
  (DECLARE (SPECIAL frame))
  (process-control-s frame nil numeric-arg)
  (SEND frame :handle-prompt))

eh:
(DEFCOMMAND Ï4eh::comw-isearchÏ* (numeric-arg)
  '(:description
     "Ï3I-Search for text in window, numeric arg for window under mouse.Ï*"
     :names ("Ï3SearchÏ*")
     :keys (#\c-sh-s)
     :arguments (ucl:numeric-argument))
  (DECLARE (SPECIAL *window-debugger*))
  (tv::process-control-s *window-debugger* nil numeric-arg)
  (SEND *window-debugger* :handle-prompt))

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

;Ï1;; The Reverse ISearch command.Ï*

;Ï1*************Ï*
;Ï1 TAC 08-01-89 - moved into INSPECT.LISP where it belongsÏ*
;Ï1(defcommand refresh-cmd nilÏ*
;Ï1  '(:description Ï*
;Ï1"Redisplay the inspected objects, updating any fields that have changed values."Ï*
;Ï1;;; Changed from Control r by JPR.Ï*
;Ï1    :names ("Refresh" "Decache") :keys (#\m-R))Ï*
;Ï1  (declare (special history frame))Ï*
;Ï1  (send history :set-cache nil)Ï*
;Ï1  (update-panes)Ï*
;Ï1)Ï*

(DEFCOMMAND Ï4reverse-search-cmdÏ* (numeric-arg)
  '(:description
     "Ï3Reverse I-Search for text in window, numeric arg for window under mouse.Ï*"
    :names ("Ï3Reverse SearchÏ*")
    :keys (#\c-r #\c-sh-r)
    :arguments (ucl:numeric-argument))
  (DECLARE (SPECIAL frame))
  (process-control-s frame :backwards numeric-arg)
  (SEND frame :handle-prompt))

eh:
(DEFCOMMAND Ï4eh::comw-reverse-isearchÏ* (numeric-arg)
  '(:description
     "Ï3Reverse-I-Search for text in window, numeric arg for window under mouse.Ï*"
     :names ("Ï3Reverse SearchÏ*")
     :keys (#\c-sh-r)
     :arguments (ucl:numeric-argument))
  (DECLARE (SPECIAL *window-debugger*))
  (tv::process-control-s *window-debugger* :backwards numeric-arg)
  (SEND *window-debugger* :handle-prompt))

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

;Ï1;; The Inspect commandÏ*

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


;Ï1;; Code for the implementation of an Inspect Region command in Zmacs.Ï*

zwei:
(DEFUN Ï4zwei::read-until-eofÏ* (STREAM)
"Ï2Given a stream this function returns a list of all of the forms that it reads
from the stream until it gets to the end of file.Ï*"
  (LET ((sexpr (READ stream nil :eof)))
       (IF (EQUAL sexpr :eof) nil (CONS sexpr (read-until-eof stream)))))

zwei:
(DEFUN Ï4zwei::read-form-or-forms-from-bufferÏ* (&optional (section-p nil))
"Ï2This function reads either a form or a collection of forms from the current
buffer.  If a section has been marked out then forms are read from this,
otherwise a form is read from after the cursor.  If only one form is found
then this is returned.  If more than one form is found then a list containing
these forms is returned.Ï*"
  (IF (OR (window-mark-p *window*) section-p)
      (LET ((bp1 (mark))
	    (bp2 (point))
	    (defun-name nil)	   )
	   (OR (bp-< bp1 bp2) (PSETQ bp1 bp2 bp2 bp1))
	   (IF (bp-= (forward-over *whitespace-chars* (mark))
		     (forward-over *whitespace-chars* (point)) )
	       (SETQ *mark-stays* nil)
	       (SETQ defun-name "Ï3RegionÏ*"))
	   (COND (defun-name)
		 ((SETQ bp1 (defun-interval (beg-line (point)) 1 () ()))
		  (SETQ bp2 (interval-last-bp bp1) bp1 (interval-first-bp bp1))
		  ;;(SETQ si:*force-defvar-init* t)
		  )
		 (t (barf "Ï3Unbalanced parenthesesÏ*")))
	   (LET ((STREAM (interval-stream bp1 bp2 t)))
	        (UNWIND-PROTECT
		  (LET ((all-sexprs (read-until-eof stream)))
		       (VALUES (IF (EQUAL (LENGTH all-sexprs) 1)
				   (FIRST all-sexprs)
				   all-sexprs)
			       (IF defun-name
				   defun-name
				   (SEND (ARRAY-LEADER (bp-line bp1) 5) :name))))
		  (CLOSE stream))))
      (LET ((STREAM (rest-of-interval-stream (point))))
	   (UNWIND-PROTECT
	     (LET ((sexpr (READ stream nil :eof)))
	          (VALUES (IF (EQUAL :eof sexpr) :nothing-found sexpr)
			  "Ï3ExpressionÏ*"))
	     (CLOSE stream)))))

zwei:
(defcom Ï4zwei::com-inspect-regionÏ* "Ï3Call the inspector on a region.Ï*" ()
  (LET ((sexprs (read-form-or-forms-from-buffer)))
       (IF (EQUAL :nothing-found sexprs)
	   (BEEP)
	   (INSPECT sexprs)))
  dis-none)

;Ï1 TAC 08-01-89 - moved code below to WINDOW-DEBUG.LISPÏ*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; Add key assignments to the inspect command in the debugger.Ï*

;Ï1eh:Ï*
;Ï1(DEFCOMMAND eh:COMW-INSPECT-CMD NILÏ*
;Ï1 '(:DESCRIPTION  "Inspect an object specified with keyboard or mouse."Ï*
;Ï1   :NAMES "Inspect" Ï*
;Ï1   :KEYS (#\c-sh-I #\M-sh-I #\c-I))Ï*
;Ï1 (SEND *WINDOW-DEBUGGER* :SET-WHO-LINE-DOC-STRING-OVERIDE "Select an object to inspect.")Ï*
;Ï1 (UNWIND-PROTECTÏ*
;Ï1  (PROGNÏ*
;Ï1   (COMW-INSPECT *ERROR-SG* *ERROR-OBJECT*)Ï*
;Ï1   (TV:DELAYING-SCREEN-MANAGEMENTÏ*
;Ï1    (WHEN (EQUAL (SEND *WINDOW-DEBUGGER* :CONFIGURATION) 'STEP-CONFIGURATION)Ï*
;Ï1      (SEND *WINDOW-DEBUGGER* :SET-CONFIGURATION 'DEBUGGER-CONFIGURATION))))Ï*
;Ï1  (PROGN (SEND *WINDOW-DEBUGGER* :SET-WHO-LINE-DOC-STRING-OVERIDE NIL)Ï*
;Ï1         (SEND *WINDOW-DEBUGGER* :HANDLE-PROMPT))))Ï*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; Modifications to the macroexpand command and additions of macroexpandÏ*
;Ï1;; to tools.Ï*

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

;Ï1;; Code for the modification of the macro-expand-expression (c-sh-m) commandÏ*
;Ï1;; in ZMacs.Ï*

;Ï1; functionality is probably already in si pkg - it belongs there anyway.Ï*
zwei:
(DEFUN Ï4zwei::map-with-argsÏ* (a-function over-a-list &rest other-arguments)
"Ï2This function is much like mapcar only more useful.  It takes a function and a
 list to map the function over and an &Rest arguments feature.  It applies the
 function to each element in the list, with the element being the first argument 
 and any subsequent arguments being taken from the &Rest parameter. The value of 
 a call to this function is a list of values from this function call, one element 
 for each element in the source list.Ï*"
  (LOOP for element in over-a-list
        collect (APPLY a-function element other-arguments)))

zwei:
(DEFUN Ï4zwei::expand-n-timesÏ* (form n)
"Ï2Takes a form and a depth count.  It returns a new form, which has macros in
 form expanded to a depth of n.Ï*"
  (IF (< n 1)
      form
      (IF (CONSP form)
	  (LET ((expanded-form (macroexpand-1 form)))
	       (IF (CONSP expanded-form)
		   (IF (EQUAL form expanded-form)
		       (map-with-args 'expand-n-times form n)
		       (map-with-args 'expand-n-times expanded-form (- n 1)))
		   form))
          form)))

zwei:
(defcom Ï4zwei::com-macro-expand-expressionÏ* 
"Ï3Print macroexpansion of next s-expression or marked s-expression(s).
The result is printed on the screen with PPrint.
If a numeric arg is supplied then that number of macroexpansions is applied.Ï*" ()
  (LET ((form (read-form-or-forms-from-buffer)))
    (AND (EQ form :nothing-found) (barf))
    (IF *numeric-arg-p*
	(PPRINT
	    (expand-n-times (macroexpand-1 form) (- *numeric-arg* 1)))
	(PPRINT (macroexpand-1 form))))
  dis-none)


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

;Ï1;; Code for the implementation of a MacroExpand command in the Inspector.Ï*

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

(DEFUN Ï4macroexpand-and-inspect-expressionÏ* (expr)
"Ï2Is passed an expression which it macroexpands and then inspects.Ï*"
  (DECLARE (SPECIAL frame))
  (UNWIND-PROTECT
      (LET ((value (macroexpand-1 expr)))
	   (SEND frame :look-at-this-object value))
    nil))

;Ï1*************Ï*
;Ï1 TAC 08-01-89 - moved these three to INSPECT.LISPÏ*
;Ï1(defun data-from-inspection-data (thing)Ï*
;Ï1  (or (send thing :Send-If-Handles :Middle-Button-Result)Ï*
;Ï1      (send thing :Send-If-Handles :Aux-Data)Ï*
;Ï1      (send thing :Data)Ï*
;Ï1  )Ï*
;Ï1)Ï*

;Ï1(defun maybe-data-from-inspection-data (thing)Ï*
;Ï1  (if (typep thing 'tv:inspection-data)Ï*
;Ï1      (data-from-inspection-data thing)Ï*
;Ï1      thingÏ*
;Ï1  )Ï*
;Ï1)Ï*

;Ï1(defun do-something-and-inspect (string action)Ï*
;Ï1"Takes a prompt string and a function argument.  It prompts the user with theÏ*
;Ï1 string, rewads in a value, perhaps with the mouse, and calls the functionÏ*
;Ï1 with the value returned.Ï*
;Ï1"Ï*
;Ï1   (declare (special user history = inspectors frame))Ï*
;Ï1;   (send user :clear-screen)Ï*
;Ï1   (format user string)Ï*
;Ï1   (multiple-value-bind (value punt-p)Ï*
;Ï1       (inspect-get-value-from-user user history inspectors)Ï*
;Ï1     (or punt-p (funcall action value))Ï*
;Ï1   )Ï*
;Ï1   (send frame :handle-prompt)Ï*
;Ï1)Ï*
;Ï1-------------Ï*

(DEFCOMMAND Ï4inspect-macroexpand-cmdÏ* nil			
  '(:description "Ï3MacroExpand and inspect something.Ï*"
    :names ("Ï3MacExpÏ*")
    :keys (#\c-sh-m))
   (do-something-and-inspect "Ï3~&Expression to macroexpand:Ï*"
			     'macroexpand-and-inspect-expression))

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

;Ï1;; Code for the Trace command in ZMacs.Ï*

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

zwei:
(DEFUN Ï4zwei::just-trace-nameÏ* (name)
"Ï2Given a name traces it without a menu.Ï*"
  (si:eval-abort-trivial-errors
    (IF (ATOM name) `(TRACE (,name)) `(TRACE (:function ,name)))))

zwei:
(defcom Ï4zwei::com-just-traceÏ* "Ï3Trace a function without any menu.
Reads the name of the function from the mini-buffer (the top of the kill
ring has the 'current' function from the buffer) and then traces it.Ï*" ()
  (LET ((fcn (read-function-name 
	       "Ï3TraceÏ*"
	       (relevant-function-name (point) nil t t t) t))
	(*print-case* :capitalize))
       (just-trace-name fcn)
       (FORMAT *query-io* "Ï3Traced ~A.Ï*" fcn))
  dis-none)

zwei:
(set-comtab *standard-comtab* nil
	    (make-command-alist '(com-just-trace)))

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

zwei:
(DEFUN Ï4zwei::untrace-nameÏ* (name)
"Ï2Given a name untraces it without a menu.Ï*"
  (si:eval-abort-trivial-errors
    (IF (ATOM name) `(UNTRACE ,name) `(UNTRACE ,name))))

zwei:
(defcom Ï4zwei::com-untraceÏ* "Ï3Untrace a function without any menu.
Reads the name of the function from the mini-buffer (the top of the kill
ring has the 'current' function from the buffer) and then untraces it.Ï*" ()
  (LET ((fcn (read-function-name 
	       "Ï3UntraceÏ*"
	       (relevant-function-name (point) nil t t t) t))
	(*print-case* :capitalize))
       (untrace-name fcn)
       (FORMAT *query-io* "Ï3Untraced ~A.Ï*" fcn))
  dis-none)

zwei:
(set-comtab *standard-comtab* nil
	    (make-command-alist '(com-untrace)))

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

;Ï1;; Code required to implement a Trace command in the Inspector.Ï*

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

(DEFUN Ï4function-if-definedÏ* (spec)
"Ï2Nil if it is passed an invalid function spec or a spec for an undefined
 function, otherwise the function object for the spec.Ï*"
  (IF (function-spec-p spec)
      (LET ((FUNCTION (IF (CONSP spec)
			  (FUNCALL (GET (FIRST spec) 'function-spec-handler)
			           'ticl:fdefinedp spec)
			  (IF (FBOUNDP spec) (SYMBOL-FUNCTION spec) nil))))
	   (COND ((EQUAL t function) (FDEFINITION spec))
		 ((AND (SYMBOLP function) (FBOUNDP function))
		  (SYMBOL-FUNCTION function))
		 ((OR (FUNCTIONP function) (CONSP function)) function)
		 (t nil)))
      (IF (FUNCTIONP spec)
	  spec
	  (IF (AND (FBOUNDP 'any-sort-of-clos-method-p)
		   (any-sort-of-clos-method-p spec))
	      (method-function-safe spec)
	      nil))))

(DEFUN Ï4get-real-inspect-thingÏ* (thing)
  (IF (FBOUNDP 'map-into-show-x)
      (LET ((MAP (FUNCALL 'map-into-show-x thing)))
	   (IF map
	       map
	       (IF (TYPEP thing 'inspection-data)
		    (IF (NOT (SYMBOLP (SEND thing :send-if-handles :aux-data)))
			(SEND thing :aux-data)
			(SEND thing :data))
		    thing)))
      thing))


(DEFUN Ï4get-method-spec-if-instanceÏ* (FUNCTION prompter &aux message)
"Ï2If it is passed an instance then it prompts for a message name to be clicked
 on and then returns a method spec for that method, otherwise it returns the
 function that it was passed.Ï*"
  (AND (CLOSUREP function)
       (SETQ function (CAR (%make-pointer dtp-list function))))
  (COND ((AND (MEMBER (DATA-TYPE function)
		      '(dtp-entity dtp-instance dtp-select-method))
	      (TYPEP function 'inspection-data))
	 (get-real-inspect-thing function))
	((AND (FBOUNDP 'any-sort-of-clos-method-p)
	      (any-sort-of-clos-method-p function))
	 (method-function-safe function))
	((MEMBER (DATA-TYPE function)
		 '(dtp-entity dtp-instance dtp-select-method))
	 (SETQ message
	       (FUNCALL prompter
			"Ï3~&Type or mouse a message name for ~S:~%Ï*" function))
	 (LET ((handler (GET-HANDLER-FOR function message)))
	      (OR handler
		  (FORMAT t "Ï3~&~S does not handle the ~S message.~%Ï*"
			  function message))
	      (SETQ function handler)))
	(t function)))

(DEFUN Ï4trace-somethingÏ* (thing prompter action)
"Ï2Prompts the user for something to trace and traces it with a menu, just traces
 it or untraces it according to Action, which can be :Menu, :Just-Trace,
 :Untrace.Ï*"
  (LET ((thing-to-trace
	    (get-method-spec-if-instance thing prompter)))
       (LET ((FUNCTION (IF (FUNCTIONP thing-to-trace)
			   thing-to-trace
			   (function-if-defined thing-to-trace))))
	    (IF function
		(LET ((name (FUNCTION-NAME function)))
		     (CASE action
		       (:menu
			(EVAL (trace-via-menus (FUNCTION-NAME function))))
		       (:just-trace (zwei::just-trace-name name))
		       (:untrace (zwei::untrace-name name))))
		(PROGN (BEEP)
		       (FORMAT t "Ï3~S cannot be traced.Ï*" thing))))))

(DEFUN Ï4read-value-from-userÏ* (&rest format-args)
"Ï2Is passed a set of format args.  It prompts the user in the Inspector user
interaction pane for something, using the format args as the prompt.Ï*"
  (DECLARE (SPECIAL user history inspectors frame))
  (SEND user :clear-screen)
  (APPLY #'FORMAT user format-args)
  (inspect-get-value-from-user user history inspectors))

(DEFUN Ï4trace-command-bodyÏ* (action string)
"Ï2The body of all trace related commands for the inspector.Ï*"
   (DECLARE (SPECIAL user history = inspectors frame))
   (SEND user :clear-screen)
   (FORMAT user "Ï3~&Function to ~A:Ï*" string)
   (MULTIPLE-VALUE-BIND (value punt-p)
       (inspect-get-value-from-user user history inspectors)
     (OR punt-p (trace-something value 'read-value-from-user action)))
   (SEND frame :handle-prompt))

(DEFCOMMAND Ï4trace-cmdÏ* nil			
  '(:description "Ï3Trace a function using trace menu.Ï*"
    :names ("Ï3TraceÏ*")
    :keys (#\c-sh-t))
   (trace-command-body :menu "Ï3trace with menusÏ*"))



(DEFCOMMAND Ï4just-trace-cmdÏ* nil			
  '(:description "Ï3Trace a function without using trace menu.Ï*"
    :names ("Ï3Just TraceÏ*")
    :keys (#\m-sh-t))
   (trace-command-body :just-trace "Ï3traceÏ*"))



(DEFCOMMAND Ï4untrace-cmdÏ* nil			
  '(:description "Ï3Untrace a function without using trace menu.Ï*"
    :names ("Ï3UntraceÏ*")
    :keys (#\s-sh-t))
   (trace-command-body :untrace "Ï3untraceÏ*"))

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

;Ï1;; Trace command in the window debugger.Ï*

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

eh:
(DEFUN Ï4eh::window-read-thing-dont-evalÏ* (prompt &rest format-args)
  (LETF ((#'eh::sg-eval-in-frame
	  #'(lambda (IGNORE thing &rest ignore) (LIST thing))))
	(APPLY 'eh::window-read-thing prompt format-args)))

eh:
(DEFUN Ï4eh::get-something-and-trace-itÏ* (action string)
"Ï2Gets something to trace from the user.Ï*"
  (tv::trace-something
      (eh::window-read-function string)
      #'eh::window-read-thing
      action))

eh:
(DEFCOMMAND Ï4eh::comw-traceÏ* ()
            '(:description "Ï3Trace a function using trace menu.Ï*"
              :names "Ï3TraceÏ*"
	      :keys (#\c-sh-t)) 
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select something to trace using the trace menu.Ï*")
   (UNWIND-PROTECT
       (get-something-and-trace-it :menu "Ï3to trace using the trace menuÏ*")
      (SEND *window-debugger* :set-who-line-doc-string-overide nil)
      (SEND *window-debugger* :handle-prompt)))

eh:
(DEFCOMMAND Ï4eh::comw-just-traceÏ* ()
            '(:description "Ï3Trace a function without using the trace menu.Ï*"
              :names "Ï3Just TraceÏ*"
	      :keys (#\m-sh-t)) 
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select something to trace without using the trace menu.Ï*")
   (UNWIND-PROTECT (get-something-and-trace-it :just-trace "Ï3to traceÏ*")
      (SEND *window-debugger* :set-who-line-doc-string-overide nil)
      (SEND *window-debugger* :handle-prompt)))

eh:
(DEFCOMMAND Ï4eh::comw-untraceÏ* ()
            '(:description "Ï3Untrace a function without using the trace menu.Ï*"
              :names "Ï3UntraceÏ*"
	      :keys (#\s-sh-t)) 
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select something to untrace without using the trace menu.Ï*")
   (UNWIND-PROTECT (get-something-and-trace-it :untrace "Ï3to untraceÏ*")
      (SEND *window-debugger* :set-who-line-doc-string-overide nil)
      (SEND *window-debugger* :handle-prompt)))

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

;Ï1;; The Eval command.Ï*

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

;Ï1;; Code for the implementation of an Eval command in the Inspector.Ï*

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

(DEFMETHOD Ï4(basic-inspect-frame :look-at-this-objectÏ*) (object)
"Ï2Is passed something to inspect.  It puts it into the history window and
inspects it.Ï*"
  (SEND self :inspect-object object))

(DEFUN Ï4eval-and-inspect-expressionÏ* (expr)
"Ï2Is passed an expression which it Evals and then inspects.Ï*"
  (DECLARE (SPECIAL frame))
  (UNWIND-PROTECT
      (LET ((value (EVAL expr)))
	   (SEND frame :look-at-this-object value))
    nil))

(DEFCOMMAND Ï4inspect-eval-cmdÏ* nil			
  '(:description "Ï3Eval and inspect something.Ï*"
    :names ("Ï3EvalÏ*")
    :keys (#\c-sh-e))
   (do-something-and-inspect "Ï3~&Expression to eval:Ï*"
			     'eval-and-inspect-expression))

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

;Ï1;; The compile command.Ï*

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

;Ï1;; Code for the implementation of a Compile command in the Inspector.Ï*

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

(DEFUN Ï4inspect-compileÏ* (something)
  (IF (FUNCTIONP something)
      (compile (FUNCTION-NAME something))
      (compiler:compile-form something)))

(DEFCOMMAND Ï4inspect-compile-cmdÏ* nil			
  '(:description "Ï3Compile something.Ï*"
    :names ("Ï3CompileÏ*")
    :keys (#\c-sh-c))
   (do-something-and-inspect "Ï3~&Expression to compile:Ï*" 'inspect-compile))

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

;Ï1;; The compile command in the window debugger.Ï*

eh:
(DEFCOMMAND Ï4eh::comw-compile-cmdÏ* nil
  '(:description "Ï3Compile something.Ï*"
    :names "Ï3CompileÏ*"
    :keys (#\c-sh-c))
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select a something to compile.Ï*")
   (UNWIND-PROTECT
       (tv::inspect-compile (eh::window-read-thing
			     "Ï3~&Type or mouse something to compile.~%Ï*"))
     (PROGN (SEND *window-debugger* :set-who-line-doc-string-overide nil)
	    (SEND *window-debugger* :handle-prompt))))

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

;Ï1;; The arglist command.Ï*

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

;Ï1;; Code required to implement an Arglist command in the inspector.Ï*

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

(DEFUN Ï4inspect-arglistÏ* (something)
"Ï2Is passed something that the user wants the arglist for.  If it is a function
name or function object then it prints the arglist.Ï*"
  (LET ((FUNCTION (function-if-defined something)))
       (IF (EQUAL nil function)
	   (PROGN (BEEP) (FORMAT t "Ï3~S is not a function.Ï*" something))
	   (zwei::print-arglist (FUNCTION-NAME function)))))

(DEFCOMMAND Ï4arglist-cmdÏ* nil			
  '(:description "Ï3Display arglist of a function.Ï*"
    :names ("Ï3ArglistÏ*")
    :keys (#\c-sh-a))
   (do-something-and-inspect "Ï3~&Function whose arglist is to be printed:Ï*"
			     'inspect-arglist))

;Ï1*************Ï*
;Ï1 TAC 08-01-89 - moved arglist command code commented below to WINDOW-DEBUG.LISPÏ*
;Ï1;-------------------------------------------------------------------------------Ï*

;Ï1;;; The Arglist command in the window debugger.Ï*

;Ï1;;; Redefine the arglist command so that it will take c-sh-a as a keyÏ*
;Ï1;;; assignment for compatibility with ZMacs.Ï*

;Ï1eh:Ï*
;Ï1(defcommand eh:Comw-Arglist-Cmd nilÏ*
;Ï1  '(:description "Display the argument list of a specified function."Ï*
;Ï1    :names "Arglist"Ï*
;Ï1    :keys (#\c-A #\c-sh-A)Ï*
;Ï1   )Ï*
;Ï1   (send *window-debugger* :set-who-line-doc-string-overideÏ*
;	Ï1 "Select a function to apply Arglist to."Ï*
;Ï1   )Ï*
;Ï1   (unwind-protect (comw-arglist *error-sg* *error-object*)Ï*
;Ï1     (progn (send *window-debugger* :set-who-line-doc-string-overide nil)Ï*
;	Ï1    (send *window-debugger* :handle-prompt)Ï*
;Ï1     )Ï*
;Ï1   )Ï*
;Ï1)Ï*
;Ï1-------------------------------------------------------------------------------Ï*


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

;Ï1;; The document command.Ï*

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

;Ï1(defparameter *documentors*Ï*
;Ï1  (listÏ*
;Ï1    (listÏ*
;Ï1      #'(lambda (name) (or (functionp name t) (fdefinedp name)))Ï*
;Ï1      #'(lambda (name &aux doc)Ï*
;	Ï1  (multiple-value-bind (args return macro-p) (arglist name)Ï*
;	Ï1    (if (get name 'si::defstruct-slot)Ï*
;		Ï1(format t "~%~S is a defstruct accessor macro for ~s" nameÏ*
;			Ï1(car (get name 'si::defstruct-slot)))Ï*
;		Ï1(format t "~%~s is a ~:[function~;macro~]" name macro-p))Ï*
;	Ï1    (format t "~%arguments Ý ~A~%" args)Ï*
;	Ï1    (when returnÏ*
;	Ï1      (format t "returns Ý ~{~A  ~}~%" return)))Ï*
;	Ï1  (when (setq doc (documentation name))Ï*
;	Ï1    (format t "~A~%" doc))))Ï*
;Ï1    (listÏ*
;Ï1      #'(lambda (name) (get name 'si:flavor))Ï*
;Ï1      #'(lambda (name &aux doc)Ï*
;	Ï1  (let ((temp (get name 'si:flavor)))Ï*
;	Ï1    (format t "~%~s is a flavor~%" name)Ï*
;	Ï1    (when (and (setq temp (si:flavor-plist temp))Ï*
;		Ï1       (setq docÏ*
;			Ï1     (second (member :documentation temp :test #'eq))))Ï*
;	Ï1      (format t "~a~%" doc)))))Ï*
;Ï1    (listÏ*
;Ï1      #'(lambda (name) (get name 'defresource))Ï*
;Ï1      #'(lambda (name) (format t "~%~s is the name of a resource." name))Ï*
;Ï1    )Ï*
;Ï1    (listÏ*
;Ï1      #'(lambda (name) (get name 'si::defstruct-description))Ï*
;Ï1      #'(lambda (name &aux doc)Ï*
;	Ï1  (let ((temp (get name 'si::defstruct-description)))Ï*
;	Ï1    (format t "~%~s is a structure~%" name)Ï*
;	Ï1    (whenÏ*
;	Ï1      (and (setq temp (si::defstruct-description-property-alist temp))Ï*
;		Ï1   (setq doc (rest (assoc :documentation temp :test #'eq))))Ï*
;	Ï1      (format t "~a~%" doc)))))Ï*
;Ï1    (listÏ*
;Ï1      #'(lambda (name) (and (symbolp name) (boundp name)))Ï*
;Ï1      #'(lambda (name &aux temp)Ï*
;	Ï1  (if (get name 'compiler:system-constant) ;; may 7-11-88Ï*
;	Ï1      (format t "~%~s is a constant~%" name);; may 7-11-88Ï*
;	Ï1      (format t "~%~s is a variable~%" name))Ï*
;	Ï1  (if (consp (setq temp (symbol-value name)))Ï*
;	Ï1      (format t "Value is a ~A~%" (type-of temp))Ï*
;	Ï1      (format t "Value is ~s~%" temp))Ï*
;	Ï1  (format t "~@[~a~%~]"Ï*
;		Ï1  (getf (get name 'sys:documentation-property) 'variable))))Ï*
;Ï1    (listÏ*
;Ï1      #'(lambda (name) (get name 'eh::make-condition-function))Ï*
;Ï1      #'(lambda (name &aux doc)Ï*
;	Ï1  (let ((temp (get name 'eh::make-condition-function)))Ï*
;	Ï1    (format t "~%~S is an ~:[undocumented ~]error condition~%" nameÏ*
;		Ï1    (setq doc (documentation temp)))Ï*
;	Ï1    (when docÏ*
;	Ï1      (format t "~a~%" doc)))))Ï*
;Ï1    (listÏ*
;Ï1      #'(lambda (name)Ï*
;	Ï1  (and (find-package 'ticlos)Ï*
;	Ï1       (funcall (read-from-string "ticlos:class-named") name t)Ï*
;	Ï1       (documentationÏ*
;		Ï1 (funcall (read-from-string "ticlos:class-named") name)Ï*
;	Ï1       )Ï*
;	Ï1  )Ï*
;	Ï1)Ï*
;Ï1      #'(lambda (name)Ï*
;	Ï1  (format t "~&~S is the name of a CLOS class.~&~A"Ï*
;		Ï1  nameÏ*
;		Ï1  (documentationÏ*
;		Ï1    (funcall (read-from-string "ticlos:class-named") name)Ï*
;		Ï1  ))))Ï*
;Ï1   )Ï*
;Ï1)Ï*

;Ï1(defun long-document (name stream)Ï*
;Ï1  (let ((*package* nil)Ï*
;	Ï1(docs nil))Ï*
;Ï1     (loop for (pred doc-fn) in *documentors*Ï*
;	Ï1   when (funcall pred name)Ï*
;	Ï1   do (let ((str (with-output-to-string (*standard-output*)Ï*
;			Ï1   (funcall doc-fn name))))Ï*
;		Ï1   (push str docs)Ï*
;		Ï1   (princ str stream)))Ï*
;Ï1     (let ((temp (get name :documentation)))Ï*
;Ï1          (if (and temp (not (member temp docs :test #'equal)))Ï*
;	Ï1      (progn (format stream "~%~s is a ~a~%" name (type-of name))Ï*
;		Ï1     (format stream "~a~%" temp)))Ï*
;	Ï1  (if (and (not temp) (not docs))Ï*
;	Ï1      (format *query-io* "~&~s was not found." name)))))Ï*

;Ï1(Defun Long-Documentation (name)Ï*
;Ï1 (with-output-to-string (output-string)Ï*
;Ï1  (long-document name output-string)))Ï*

;Ï1zwei:Ï*
;Ï1(DEFCOM zwei:COM-LONG-DOCUMENTATIONÏ*
;Ï1   "Print long documentation for the specified function.Ï*
;Ï1Reads the name of the function from the mini-buffer (the default isÏ*
;Ï1the \"current\" function from the buffer) and displays theÏ*
;Ï1function's arguments and documentation" () ;;by OREN/STENGER. Patched in by gslÏ*
;Ï1   (LET ((NAME (READ-FUNCTION-NAME "Document" (RELEVANT-FUNCTION-NAME (POINT)) 'AARRAY-OK)))Ï*
;Ï1        ;;; JPR.Ï*
;Ï1        (princ (tv:long-documentation name))Ï*
;	Ï1dis-none))Ï*

;Ï1**************Ï*
;Ï1 TAC 08-09-89 - MAY provided preferred implementation below.Ï*
;Ï1; COM-LONG-DOCUMENTATION redefined by patch 94.215.Ï*
;Ï1; may 01/20/89 Changed documentation string and 'structure test.Ï*
;Ï1; may 04/20/89 Allowed meta-sh-d to get at special compiler arglist/function documentation.Ï*
zwei:
(defcom Ï4zwei::com-long-documentation Ï* 
  "Ï3Reads the nameÏ2 Ï*from the mini-buffer or mouse (the default is the \"current\" function from the buffer) 
and displays the function's arguments,Ï2 Ï*whether it is a function, variable, flavor, structure, or condition, 
and its documentationÏ2.Ï*Ï*"  ;Ï1; by OREN/STENGER. Patched in by gslÏ*
  ()
  (LET ((name (read-function-name "Ï3DocumentÏ*" (relevant-function-name (point)) 'aarray-ok))
        ;Ï1; Bind package to nil to force it to print outÏ*
        (*package* nil))
    (long-documentation name))
  dis-none) 

zwei:
(DEFUN Ï4zwei::long-documentationÏ* (name &optional (STREAM t))
  "Ï3Print long documentation for almost anything.Ï*"
  (LET (doc temp)
    (COND-EVERY
      (;Ï1; functionÏ*
       ;Ï1; (fdefinedp '(:method tv:sheet :init)) => t Ï*
       ;Ï1; (functionp '(:method tv:sheet :init)) => nilÏ*
       (OR (FUNCTIONP name t) (FDEFINEDP name) 	                ;Ï1; may 7-11-88 added (fdefinedp name)Ï*
	   ;Ï1; for special compiler functions like: (ticlos:call-next-method) Ï*	Ï1;; may 04/20/89 Ï*
	   (AND (SYMBOLP name) (DOCUMENTATION name))) 		;Ï1; may 04/20/89 Ï*
       (MULTIPLE-VALUE-BIND (args return macro-p) (ARGLIST name)
	 (IF ;Ï1; (SETQ TEMP (GET NAME 'SI::DEFSTRUCT-SLOT)) Ï*				Ï1;; may 01/25/89 obsoleteÏ*
	   ;Ï1; (FORMAT STREAM "~%~S is a defstruct accessor macro for ~s" NAME (CAR TEMP))   ;; may 01/25/89 sort of ...Ï*
	   (AND (SETQ temp (si:function-parent name))				;Ï1; may 01/25/89 Ï*
		(GET temp 'si::defstruct-description)) 				;Ï1; may 01/25/89 Ï*
	   (FORMAT stream "Ï3~%~S is a defstruct accessor function for ~sÏ*" name temp) 	;Ï1; may 01/25/89 Ï*
	   (FORMAT stream "Ï3~%~s is a ~:[function~;~:*~a~]Ï*" name				;Ï1; may 01/25/89 Ï*
		   (AND macro-p (STRING-DOWNCASE macro-p)))) 				;Ï1; may 01/25/89 macro/subst Ï*
	 (FORMAT stream "Ï3~%arguments Ý ~A~%Ï*" args)
	 (WHEN return
	   (FORMAT stream "Ï3returns Ý ~{~A  ~}~%Ï*" return)))
       (WHEN (SETQ doc (DOCUMENTATION name))
	 (FORMAT stream "Ï3~A~%Ï*" doc)))
      (;Ï1; flavorÏ*
       (SETQ temp (GET name 'si::flavor))
       (FORMAT stream "Ï3~%~s is a flavor~%Ï*" name)
       (WHEN (AND (SETQ temp (si::flavor-plist temp))
		  (SETQ doc (SECOND (MEMBER :documentation temp :test #'EQ))))
	 (FORMAT stream "Ï3~a~%Ï*" doc)))
      (;Ï1; class  - added class documentation - TAC 08-30-89Ï*
       (SETQ temp (ticlos::class-named name))
       (FORMAT stream "Ï3~%~s is a class~%Ï*" name)
       (WHEN
	 (SETQ doc (DOCUMENTATION temp)) 				
	 (FORMAT stream "Ï3~a~%Ï*" doc)))
      (;Ï1; structureÏ*
       (SETQ temp (GET name 'si::defstruct-description))
       (FORMAT stream "Ï3~%~s is a structure~%Ï*" name)
       (WHEN
	 (SETQ doc (DOCUMENTATION name 'structure)) 				;Ï1; may 01/25/89 Ï*
	 (FORMAT stream "Ï3~a~%Ï*" doc)))
      (;Ï1; other ...Ï*
       (AND (SETQ temp (GET name :documentation)) (NEQ doc temp))
       (FORMAT stream "Ï3~%~s is a ~a~%Ï*" name (TYPE-OF name))
       (FORMAT stream "Ï3~a~%Ï*" temp))
      (;Ï1; variableÏ*
       (AND (SYMBOLP name) (BOUNDP name))
       (IF (GET name 'compiler:system-constant) ;Ï1; may 7-11-88Ï*
	   (FORMAT stream "Ï3~%~s is a constant~%Ï*" name);Ï1; may 7-11-88Ï*
	   (FORMAT stream "Ï3~%~s is a variable~%Ï*" name))
       (IF (CONSP (SETQ temp (SYMBOL-VALUE name)))
	   (FORMAT stream "Ï3Value is a ~A~%Ï*" (TYPE-OF temp))
	   (FORMAT stream "Ï3Value is ~s~%Ï*" temp))
       (FORMAT stream "Ï3~@[~a~%~]Ï*" (GETF (GET name 'sys::documentation-property) 'variable))) ;Ï1; may 7-11-88Ï*
      (;Ï1; conditionÏ*
       (SETQ temp (GET name 'eh::make-condition-function))
       (FORMAT stream "Ï3~%~S is an ~:[undocumented ~]error condition~%Ï*" name
	       (SETQ doc (DOCUMENTATION temp)))
       (WHEN doc
	 (FORMAT stream "Ï3~a~%Ï*" doc)))
      (otherwise				;Ï1(FORMAT *QUERY-IO* "~&~S was not found." NAME)Ï*
       (FORMAT stream "Ï3~&~S has no documentation.Ï*" name)
       ))))

(DEFUN Ï4document-an-objectÏ* (thing window)
"Ï2Given something it displays the documentation for it.Ï*"
  (LET ((thing-to-document
	   (COND ((OR (SYMBOLP thing)
		      (AND (CONSP thing) (function-spec-p thing)))
		  thing)
		 ((FUNCTIONP thing) (FUNCTION-NAME thing))
		 ;Ï1; TAC 08-30-89 - added recognition of flavorsÏ*
		 ((AND (NAMED-STRUCTURE-P thing) (TYPEP thing 'si::flavor))
		  (si::flavor-name thing))
		 ((ticlos::classp thing) ;Ï1; TAC 08-30-89 - added class recognitionÏ*
		  (ticlos:class-name thing))
		 ((AND (OR (NAMED-STRUCTURE-P thing) (TYPEP thing 'instance))
		       (NOT (DOCUMENTATION thing))) ;Ï1; TAC 08-30-89 rearranged order of 2 conditions of ANDÏ*
		  (TYPE-OF thing))
		 (t nil))))
	(IF thing-to-document
;Ï1;  TAC 08-18-89 - zwei:long-documentation allows a stream to passed in. Use it in that manner.Ï*
;	Ï1    ;(LET ((docs (zwei:long-documentation thing-to-document)))Ï*	Ï1;; may 08/08/89 Ï*
;		Ï1 ;(IF (EQUAL docs "")Ï*
;		Ï1     ;(FORMAT t "has no documentation.")Ï*
		     (si:with-help-stream
		       (window :label "Ï3DocumentationÏ*" :superior window)
		       (zwei::long-documentation thing-to-document window)	;Ï1))Ï*
		       )
	    (PROGN (BEEP)
		   (FORMAT t "Ï3is not documentable.Ï*")))))

(DEFCOMMAND Ï4document-something-cmdÏ* nil			
  '(:description "Ï3Document something.Ï*"
    :names ("Ï3DocmntÏ*")
    :keys (#\m-sh-d #\c-sh-d))
   (DECLARE (SPECIAL frame))
   (do-something-and-inspect "Ï3~&Object to show documentation for:Ï*"
     #'(lambda (value) (document-an-object value frame))))


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

;Ï1;; The Document command in the window debugger.Ï*

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

eh:
(DEFUN Ï4eh::find-and-document-somethingÏ* ()
"Ï2Prompts the user for something to document and displays its doc string if it
 can.Ï*"
  (tv::document-an-object
      (window-read-thing "Ï3~&Type or mouse something to document:~%Ï*")
      *window-debugger*))

eh:
(DEFCOMMAND Ï4eh::comw-debug-document-somethingÏ* ()
  '(:description  "Ï3Show documentation for something.Ï*"
    :names "Ï3DocmntÏ*"
    :keys (#\c-sh-d #\m-sh-d))
   (SEND *window-debugger* :set-who-line-doc-string-overide
	 "Ï3Select something to document.Ï*")
   (UNWIND-PROTECT (find-and-document-something)
      (SEND *window-debugger* :set-who-line-doc-string-overide nil)
      (SEND *window-debugger* :handle-prompt)))

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

;Ï1 TAC 08-01-89 - moved all Help command code into INSPECT.LISPÏ*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; The Help command.Ï*

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

;Ï1(defun uniquise-commands (commands)Ï*
;Ï1  (if (and commands (rest commands))Ï*
;Ï1      (if (and (equalp (first  (first commands)) (first  (second commands)))Ï*
;	Ï1       (equalp (second (first commands)) (second (second commands)))Ï*
;	Ï1  )Ï*
;	Ï1  (uniquise-commands (rest commands))Ï*
;	Ï1  (cons (first commands) (uniquise-commands (rest commands)))Ï*
;Ï1      )Ï*
;Ï1      commandsÏ*
;Ï1  )Ï*
;Ï1)Ï*

;Ï1(defun show-all-commands-for-frame (frame on-window)Ï*
;Ï1  (format on-window "~&The following commands are supported on top of the normal input editor commands.~%")Ï*
;Ï1  (let ((all-commandsÏ*
;	Ï1  (mapcar #'(lambda (table)Ï*
;		Ï1      (mapcar #'(lambda (command)Ï*
;				Ï1  (appendÏ*
;				Ï1    (firstn 2 (send command :parsed-edit-form))Ï*
;				Ï1    (list (send command :description)Ï*
;					Ï1  (if (string-equalÏ*
;						Ï1(send command :description)Ï*
;						Ï1(send command :documentation)Ï*
;					Ï1      )Ï*
;					Ï1      ""Ï*
;					Ï1      (send command :documentation)Ï*
;					Ï1  )Ï*
;				Ï1    )Ï*
;				Ï1  )Ï*
;				Ï1)Ï*
;			Ï1        (listarrayÏ*
;				Ï1  (send (symbol-value table) :commands)Ï*
;				Ï1)Ï*
;		Ï1      )Ï*
;		Ï1    )Ï*
;		Ï1    (uniqueise (send frame :all-command-tables))Ï*
;	Ï1  )Ï*
;	Ï1)Ï*
;Ï1       )Ï*
;Ï1       (let ((sorted (sortcar (apply #'append all-commands) #'string-lessp)))Ï*
;	Ï1    (mapcar #'(lambda (list)Ï*
;			Ï1(apply #'format on-window "~&~A~25T~A~48T~A ~A" list))Ï*
;		Ï1    (uniquise-commands sorted)Ï*
;	Ï1    )Ï*
;Ï1       )Ï*
;Ï1  )Ï*
;Ï1)Ï*


;Ï1(Defcommand Documentation-Cmd nilÏ*		
;Ï1  '(:description Ï*
;Ï1    "Display some brief documentation about each of the Inspector's panes."Ï*
;Ï1    :names ("Help")Ï*
;Ï1    :keys (#\c-HELP #\m-HELP)Ï*
;Ï1   )Ï*
;Ï1   (declare (special frame))Ï*
;Ï1   (si:with-help-stream (window :label "Documentation for Inspector"Ï*
;				Ï1:superior frameÏ*
;			Ï1)Ï*
;Ï1     (format windowÏ*
;Ï1"Ï*
;Ï1  -----------------------------------------------------------------------------------Ï*
;Ï1                    *** Optional Third Inspection Pane ***Ï*

;Ï1    Displays previously inspected item.Ï*

;Ï1 ------------------------------------------------------------------------------------Ï*
;Ï1                    *** Optional Second Inspection Pane ***Ï*

;Ï1    Displays previously inspected item.Ï*

;Ï1 ------------------------------------------------------------------------------------ Ï*
;Ï1                        *** Main Inspection Pane ***Ï*

;Ï1    This pane displays the structure of the most recently inspected item.Ï*
;Ï1    Specify objects to inspect byÏ*

;Ï1      1) Entering them into the Interaction Pane or,Ï*
;Ï1      2) Clicking left on the mouse sensitive elements of previously inspected items.Ï*

;Ï1    Right click on items here tries to inspect the item's function definition.Ï*


;Ï1 ------------------------------------------------------------------------------------Ï*
;Ï1   * Command * |                  *** History Pane ***Ï*
;Ï1   *  Menu   * |Ï*
;Ï1               |    This pane displays a list of the objects that have beenÏ*
;Ï1     For UCL   |  inspected.  To bring an object back into the Main InspectionÏ*
;Ï1     command   |  pane click left on it in this pane.Ï*
;Ï1     display   |Ï*
;Ï1      press    |    To remove an item from the history, click middle in the item'sÏ*
;Ï1      HYPER-   |  line area (the area just left of the item where the mouse cursorÏ*
;Ï1     CONTROL-  |  becomes a right pointing arrow).Ï*
;Ï1      HELP.    |Ï*
;Ï1 ------------------------------------------------------------------------------------Ï*
;Ï1                           *** Interaction Pane *** Ï*

;Ï1      Enter items to inspect in this pane.  This pane may also be used for commandÏ*
;Ï1    name typein and for Lisp typein.  For Lisp typein use the Mode command.Ï*

;Ï1      The last three inspected objects are stored in *, ** and ***.Ï*
 
;Ï1 ------------------------------------------------------------------------------------Ï*
;Ï1  ")Ï*
;Ï1     (show-all-commands-for-frame frame window)))Ï*

;Ï1 (reinstall-inspector-commands)  ; TAC 08-01-89 dont need this since code above moved Ï*

;Ï1*************Ï*
;Ï1 TAC 08-01-89 - moved window-debugger-help and window-debugger-help-cmd to WINDOW-DEBUG.LISPÏ*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1;; The window debugger Help command.  This used to be the document command.Ï*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1eh:Ï*
;Ï1(DEFUN WINDOW-DEBUGGER-HELP (&OPTIONAL IGNORE IGNORE)Ï*
;Ï1  (declare (special *window-debugger*))Ï*
;Ï1  (SI:WITH-HELP-STREAM (WINDOW :LABELÏ*
;Ï1                               "Help for Window-based debugger"Ï*
;Ï1                               :SUPERIORÏ*
;Ï1                               tv:default-screen)          ;!Ï*
;Ï1    (FORMAT WINDOW "Ï*
;Ï1                                 WINDOW-BASED DEBUGGER HELPÏ*

;Ï1----------------------------------------------------------------------------------------------Ï*
;Ï1                                   *** INSPECTION PANE ***Ï*

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

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

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

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

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

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

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



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


;Ï1eh:Ï*
;Ï1(defcommand eh:Window-Debugger-Help-Cmd ()Ï*
;Ï1            '(:description "Show documentation for each of the panes."Ï*
;			Ï1    :names "Help"Ï*
;			Ï1    :keys (#\c-help #\m-help)Ï*
;	Ï1     )Ï*
;Ï1             (window-debugger-help *error-sg* *error-object*)Ï*
;Ï1)Ï*
;Ï1-------------------------------------------------------------------------------Ï*


;Ï1*******************************************************************************Ï*
;Ï1 TAC 08-01-89 - moved code delimited by **** into INSPECT.LISPÏ*


;Ï1-------------------------------------------------------------------------------Ï*
;Ï1;; The flavor inspect command.Ï*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; For ZmacsÏ*

;Ï1zwei:Ï*
;Ï1(defun zwei:safe-inspect-flavor (object)Ï*
;Ï1"Inspects an object but just beeps if it is not inspectable."Ï*
;Ï1  (let ((flavor (cond ((or (instancep object) (typep object 'si:flavor))Ï*
;		Ï1       objectÏ*
;		Ï1      )Ï*
;		Ï1      ((symbolp object)Ï*
;		Ï1       (get object 'si:flavor)Ï*
;		Ï1      )Ï*
;		Ï1      (t nil)Ï*
;		Ï1)Ï*
;	Ï1)Ï*
;Ï1       )Ï*
;Ï1       (if flavorÏ*
;	Ï1   (Process-Run-Function "Flavor Inspector" 'inspect-flavor flavor)Ï*
;Ï1           (progn (beep)Ï*
;		Ï1  (format *query-io* "~S is not a flavor." object)Ï*
;	Ï1   )Ï*
;Ï1       )Ï*
;Ï1  )Ï*
;Ï1)Ï*

;Ï1zwei:Ï*
;Ï1(defcom zwei:com-flavor-inspect "Call the flavor inspector on something." ()Ï*
;Ï1  (let ((flavor (read-function-name "Flavor Inspect"Ï*
;				Ï1    (relevant-function-name (point) nil t t t) tÏ*
;	Ï1        )Ï*
;	Ï1)Ï*
;	Ï1(*print-case* :Capitalize)Ï*
;Ï1       )Ï*
;Ï1       (safe-inspect-flavor flavor)Ï*
;Ï1  )Ï*
;Ï1  dis-noneÏ*
;Ï1)Ï*

;Ï1zwei:Ï*
;Ï1(set-comtab *standard-comtab* nilÏ*
;	Ï1    (make-command-alist '(com-flavor-inspect))Ï*
;Ï1)Ï*
;Ï1;-------------------------------------------------------------------------------Ï*

;Ï1;;; For the inspector.Ï*

;Ï1(defcommand Flavor-Inspect-Cmd nilÏ*			
;Ï1  '(:description "Flavor Inspect a Flavor or Method."Ï*
;Ï1    :names ("FlavIns")Ï*
;Ï1    :keys (#\c-sh-f #\m-sh-f #\h-F)Ï*
;Ï1   )Ï*
;Ï1   (declare (special user history = inspectors frame))Ï*
;Ï1   (send user :clear-screen)Ï*
;Ï1   (if (fboundp 'inspect-flavor) Ï*
;Ï1       (prognÏ*
;	Ï1 (format user "~&Object to Flavor Inspect:")Ï*
;	Ï1 (multiple-value-bind (value punt-p)Ï*
;	Ï1     (inspect-get-value-from-user user history inspectors)Ï*
;	Ï1   (or punt-pÏ*
;	Ï1       (zwei:safe-inspect-flavor value)))Ï*
;	Ï1 (send frame :handle-prompt))Ï*
;Ï1       (prognÏ*
;	Ï1 (if (y-or-n-p "The Flavor Inspector is not currently loaded. Do you wish to load it?")Ï*
;	Ï1     (prognÏ*
;	Ï1       (load "sys:debug-tools;flavor-inspector")   Ï*
;	Ï1       (send user :clear-screen)Ï*
;	Ï1       (format user "~&Object to Flavor Inspect:")Ï*
;	Ï1       (multiple-value-bind (value punt-p)Ï*
;		Ï1   (inspect-get-value-from-user user history inspectors)Ï*
;		Ï1 (OR PUNT-PÏ*
;		Ï1     (zwei:safe-inspect-flavor value)))Ï*
;	Ï1       (send frame :handle-prompt))))))Ï*

;	Ï1     )Ï*
;	Ï1 )Ï*
;Ï1       )Ï*
;Ï1   )Ï*
;Ï1)Ï*

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

;Ï1;;; For the window debugger.Ï*

;Ï1eh:Ï*
;Ï1(Defcommand eh:Flavor-Inspect-Cmd nilÏ*			
;Ï1  '(:description "Flavor Inspect a Flavor or Method."Ï*
;Ï1    :names ("FlavIns")Ï*
;Ï1    :keys (#\c-sh-f #\m-sh-f #\h-F)Ï*
;Ï1   )Ï*
;Ï1   (zwei:safe-inspect-flavor (window-read-thing "~&Object to Flavor Inspect:"))Ï*
;Ï1)Ï*
;Ï1;-------------------------------------------------------------------------------Ï*
;Ï1*******************************************************************************Ï*


;Ï1^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^Ï*
;Ï1 TAC 08-01-89 - this section of code used to define edit command that isÏ*
;Ï1                consistent in editor, inspector, and debugger.Ï*
;Ï1                code is delimited by ^^^^^^^^^^^Ï*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1;; The edit command.Ï*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1 For Zmacs - Just add a new key assignment.Ï*

zwei:
(set-comtab *standard-comtab* '(#\h-e com-edit-definition)
	                       (make-command-alist '(com-edit-definition)))

;Ï1-------------------------------------------------------------------------------Ï*
;Ï1 For the inspector - adds new edit capability, including CLOS objectsÏ*

(DEFUN Ï4make-ununspecificÏ* (path)
"Ï2Takes a path and makes sure that it has an specific type.Ï*"
  (OR (AND (NOT (EQUAL :unspecific (SEND path :type)))
	   path)
      (LET ((new-path (MAKE-PATHNAME :defaults path
				     :type :lisp
				     :version :newest)))
	   new-path)))

(DEFUN Ï4pathname-could-be-edittedÏ* (path)
"Ï2Is true if the pathname represents something that could reasonably be editted.
 This means that it has a name and type.Ï*"
  (LET ((name (SEND path :name))
        (type (SEND path :type)))
       (AND name
	    type
	    (OR (AND (NOT (EQUAL :unspecific type))
		     (PROBE-FILE path))
		(LET ((new-path (MAKE-PATHNAME :defaults path
					       :type :lisp
					       :version :newest)))
		     (AND (PROBE-FILE new-path)
			  (Y-OR-N-P "Ï3Try and edit Lisp file: \"~A\"Ï*"
				    (SEND new-path :string-for-printing))))))))

(DEFUN Ï4edit-a-pathÏ* (path)
"Ï2Given a pathname edits the file for it.  If the version of the path is
 :UnSpecific then it edits the :NewestÏ*"
  (ED (IF (EQUAL :unspecific (SEND path :version))
	  (SEND path :new-version :newest)
	  path)))

(DEFUN Ï4try-and-edit-flavor-of-objectÏ* (object)
"Ï2Given an instance it tries to edit the source file of the type of the instance.Ï*"
  (COND ((AND (FBOUNDP 'class-p-safe) (class-p-safe object))
	 (try-and-edit (class-name-safe object)))
	((AND (FBOUNDP 'any-sort-of-clos-method-p)
	      (any-sort-of-clos-method-p object))
	 (try-and-edit (method-function-safe object)))
	(t (TYPECASE object
	     (si::flavor  (try-and-edit (si::flavor-name  object)))
	     (otherwise
	       (IF (GET (TYPE-OF object) :source-file-name)
		   (ED (TYPE-OF object))
		   (PROGN (BEEP)
			  (FORMAT *query-io*
				  "Ï3~&No source file can be found for ~SÏ*"
				  object))))))))

(DEFUN Ï4try-and-edit-objectÏ* (object)
"Ï2Is passed an instance or a defstruct instance and tries to edit it in the most
 intelligent way possible.  If the thing responds to the :Pathname message then
 it tries to edit the file defined by the path.  If it fails to do this then
 it tries to edit the source file of the type of the thing.Ï*"
  (IF (IF (TYPEP object 'instance)
	  (SEND object :operation-handled-p :pathname)
	  (MEMBER 'PATHNAME (SEND object :which-operations) :test #'EQ)
          ;Ï1;; Can't use :Operation-Handled-P because most defstructs do not support itÏ*
      )
      (LET ((path (SEND object :pathname)))
	   (IF (AND (TYPEP path 'PATHNAME)
		    (pathname-could-be-editted path)
		    (PROBE-FILE path))
	       (edit-a-path path)
	       (try-and-edit-flavor-of-object object)))
      (try-and-edit-flavor-of-object object)))

(DEFUN Ï4try-and-edit-stringÏ* (STRING)
"Ï2Given a string it tries to edit a file which the string denotes.  If it fails
 to find such a file then it beeps and tells you why it failed to edit it.Ï*"
  (LET ((path (fs:parse-pathname string nil nil 0 nil t)))
       (IF path
	   (IF (pathname-could-be-editted path)
	       (IF (PROBE-FILE path)
		   (edit-a-path path)
		   (PROGN (BEEP)
			  (FORMAT *query-io* "Ï3~&File not found for ~SÏ*" string)))
	       (PROGN (BEEP)
		      (FORMAT *query-io*
			     "Ï3~&~S cannot be coerced into an edittable pathnameÏ*"
			     string)))
	   (PROGN (BEEP)
		  (FORMAT *query-io* "Ï3~&~S cannot be coerced into a pathnameÏ*"
			  string)))))

(DEFUN Ï4remove-internalsÏ* (name)
"Ï2Extracts a function name from any closure specs.
 Thus (:internal (:internal foo 0) 123) -> foo.Ï*"
  (IF (AND (CONSP name) (EQUAL (FIRST name) :internal))
      (remove-internals (SECOND name))
      name))

#-clos
(DEFUN Ï4try-and-editÏ* (object)
"Ï2Takes any object and edits its definition if it can find a meaningful definition  
to edit.  For instance if it is passed a named structure then it edits the defstruct 
definition for that type.  If it fails to edit the object it beeps and tells you what 
it was that it failed to edit a definition of.Ï*"
  (COND ((AND (TYPEP object 'symbol)
	      (OR (GET object :source-file-name)
		  (GET object 'zwei:zmacs-buffers)))
	 (ED object))
	((AND (TYPEP object 'PATHNAME)
	      (pathname-could-be-editted object))
	 (edit-a-path (make-ununspecific object)))
	((AND (FUNCTIONP object)
	      (OR (si:function-spec-get
		    (remove-internals (FUNCTION-NAME object))
		    :source-file-name)
		  (si:function-spec-get
		    (remove-internals (FUNCTION-NAME object))
		    'zwei:zmacs-buffers)))
	 (ED (FUNCTION-NAME object)))
	((AND (OR (NAMED-STRUCTURE-P object) (TYPEP object 'instance)))
	 (try-and-edit-object object))
	((AND (CONSP object) (function-spec-p object)
	      (OR (si:function-spec-get object :source-file-name)
		  (si:function-spec-get object 'zwei:zmacs-buffers)))
	 (ED object))
	((AND (CONSP object) (MEMBER (FIRST object) '(FUNCTION quote)))
	 (try-and-edit (SECOND object)))
        ((TYPEP object 'STRING) (try-and-edit-string object))
	(t (BEEP)
	   (FORMAT *query-io* "Ï3~&Cannot find a definition to edit for ~SÏ*"
		   object))))

#+clos
ticlos:
(defgeneric Ï4tv::editÏ* (something)
  (:documentation "Ï3Takes any object and edits its definition if it can find a
meaningful definition to edit.  For instance, if it is passed a named structure 
then it edits the defstruct definition for that type.  If it fails to edit the 
object it beeps and tells you what it was that it failed to edit a definition of.Ï*"))

#+clos
(DEFMETHOD Ï4editÏ* ((me t))
  (IF (NAMED-STRUCTURE-P me)
      (try-and-edit-object me)
      (PROGN (BEEP)
	     (FORMAT *query-io* "Ï3~&Cannot find a definition to edit for ~SÏ*"
		     me))))

#+clos
(DEFMETHOD Ï4editÏ* ((me symbol))
  (IF (OR (GET me :source-file-name)
	  (GET me 'zwei::zmacs-buffers))
      (ED me)
      (ticlos:call-next-method)))

#+clos
(DEFMETHOD Ï4editÏ* ((me pathname))
  (IF (pathname-could-be-editted me)
      (edit-a-path (make-ununspecific me))
      (ticlos:call-next-method)))

#+clos
(DEFMETHOD Ï4editÏ* ((me compiled-function))
  (IF (OR (si:function-spec-get
	     (remove-internals (FUNCTION-NAME me))
	     :source-file-name)
	   (si:function-spec-get
	     (remove-internals (FUNCTION-NAME me))
	     'zwei::zmacs-buffers))
      (ED (FUNCTION-NAME me))
      (ticlos:call-next-method)))

#+clos
(DEFMETHOD Ï4editÏ* ((me ticlos:generic-function))
  (edit (clos:generic-function-name me)))

(DEFUN Ï4menu-of-methodsÏ* (object)
  (w:menu-choose (MAPCAR #'(lambda (method)
			     (LET ((method-spec 
				     (FUNCTION-NAME
				       (method-function-safe
					 method))))
				  (LIST (FORMAT nil "Ï3~sÏ*" method-spec)
					:value
					method-spec)))
			   (generic-function-methods-safe
			     (function-generic-function-safe
			       (SYMBOL-FUNCTION object))))
		 :label
		 (FORMAT nil "Ï3~s is a generic function.  Edit which method?Ï*"
			 object)))

#+clos
;Ï1 TAC 08-17-89 - removing PCL supportÏ*
;Ï1(DEFMETHOD edit ((me lexical-closure))Ï*
;Ï1  (LET ((fef (FIRST (si:convert-closure-to-list me))))Ï*
;Ï1       (IF (AND (FBOUNDP 'pcl-p) (pcl-p) (fef-of-gf-p me)) ;;; Allow for PCL.Ï*
;	Ï1   (LET ((choice (menu-of-methods (generic-function-name-safe me))))Ï*
;		Ï1(IF choiceÏ*
;		Ï1    (edit choice)Ï*
;		Ï1    (BEEP)))Ï*
;	Ï1   (edit fef))))Ï*

;Ï1 TAC 09-04-89 - substituting (si::closure-function me) for (FIRST (si:convert-closure-to-list me))Ï*
;Ï1                      David Gray's preferred way to handle closureÏ*
;Ï1(DEFMETHOD edit ((me lexical-closure))Ï*
;Ï1  (LET ((fef (FIRST (si:convert-closure-to-list me))))Ï*
;Ï1    (edit fef)))Ï*

(DEFMETHOD Ï4editÏ* ((me lexical-closure))
  (LET ((fef (si::closure-function me)))
    (edit fef)))

#+clos
(DEFMETHOD Ï4editÏ* ((me cons))
  (IF (AND (function-spec-p me)
	   (OR (si:function-spec-get me :source-file-name)
	       (si:function-spec-get me 'zwei::zmacs-buffers)))
      (ED me)
      (IF (MEMBER (FIRST me) '(FUNCTION quote))
	  (edit (SECOND me))
	  (ticlos:call-next-method))))

#+clos
(DEFMETHOD Ï4editÏ* ((me string))
  (try-and-edit-string me))

#+clos
(DEFMETHOD Ï4editÏ* ((me array))
  (IF (NAMED-STRUCTURE-P me)
      (try-and-edit-object me)
      (ticlos:call-next-method)))

#+clos
(DEFMETHOD Ï4editÏ* ((me si:vanilla-flavor))
  (try-and-edit-object me))

#+clos
(DEFMETHOD Ï4editÏ* ((me clos:standard-class))
  (try-and-edit-object me))

#+clos
(DEFMETHOD Ï4editÏ* ((me ticlos:flavor-class))
  (try-and-edit-object me))

#+clos
(DEFMETHOD Ï4editÏ* ((me ticlos:method))
  (edit (ticlos:method-function me)))

#+clos
(DEFMETHOD Ï4editÏ* ((me inspection-data))
  (try-and-edit-object (SEND me :middle-button-result)))

#+clos
(DEFUN Ï4try-and-editÏ* (object)
"Ï2Takes any object and edits its definition if it can find a meaningful definition 
to edit.  For instance, if it is passed a named structure then it edits the defstruct 
definition for that type.  If it fails to edit the object it beeps and tells you what 
it was that it failed to edit a definition of.Ï*"
  (edit object))

;Ï1;; Just compile this so that M-. works ok.Ï*
#+clos
(ticlos:prepare-generic-function #'edit)
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; Extensions for reading in things to edit.Ï*

(DEFUN Ï4try-in-all-packagesÏ* (action symbols &rest args)
"Ï2Performs Action to all of the symbols in Symbols &rest args, within a
 catch error.  If there is no error and a non null result from the action then
 this is returned.Ï*"
  (IF symbols
      (LET ((result (CATCH-ERROR (APPLY action (FIRST symbols) args) nil)))
	   (IF result
	       result
	       (try-in-all-packages action (REST symbols))))
      nil))

(DEFUN Ï4try-to-find-function-spec-for-typeÏ* (spec type)
"Ï2Given a spec of the form [eg] (foo :after :bar) and a type of the form [eg]
 :Method or :Property, try to find a function spec of the form
 (:method foo :after :bar), where foo is tried in all reasonable packages.Ï*"
  (IF (SYMBOLP (FIRST spec))
      (APPLY 'try-in-all-packages
	#'(lambda (symbol &rest args)
	    (LET ((fspec (CONS type (CONS symbol args))))
	         (IF (FDEFINITION-LOCATION fspec)
		     fspec
		     nil)))
	(zwei::package-lookalike-symbols (SYMBOL-NAME (FIRST spec)))
	(REST spec))
      nil))

(DEFPARAMETER Ï4*function-spec-first-symbols*Ï* '(:method :property)
"Ï2A list of all of the keywords which can start a function spec.Ï*")

(DEFUN Ï4try-to-find-function-specÏ* (spec symbols)
"Ï2Given a function spec of the form [eg] (foo :after :bar) and a list of type
 symbols of the form (:Method or :Property), try to find a function spec of
 the form (:method foo :after :bar), where foo is tried in all reasonable
 packages.Ï*"
  (IF (EQUAL nil symbols)
      nil
      (LET ((result (try-to-find-function-spec-for-type spec (FIRST symbols))))
	   (IF result
	       result
	       (try-to-find-function-spec-for-type spec (REST symbols))))))

(DEFUN Ï4something-to-edit-error-handlerÏ* (condition)
"Ï2An error handler for the try to edit operation.  If it finds an unbound symbol
 then this is returned, since it might be the name of a function.  If it finds
 a (:method... type spec then it returns this (this would have resulted in an
 undefined function error for :Method.  If it finds a list of the form
 (foo bar baz) then it tries to dwimify a bit looking for a method of plist
 function of that name.Ï*"
  (DECLARE (SPECIAL *form-read*))
  (COND ((AND (CONDITION-TYPEP condition 'sys:unbound-variable)
	      (SYMBOLP *form-read*))
	 (THROW :error? :proceed-with-this))
	((CONDITION-TYPEP condition 'sys:undefined-function)
	 (IF (MEMBER (FIRST *form-read*) '(:method :property))
	     (THROW :error? :proceed-with-this)
	     (THROW :error? :try-dwimifying)))
	(t (BEEP) nil))
  (VALUES))
  
(DEFUN Ï4read-and-record-a-formÏ* (FUNCTION)
"Ï2Reads a form using function, which may prompt, and setqs the form to a special
 which is read outside the function.  The form is then evaled.  Errors which
 happen during the read or the eval will be caught.Ï*"
  (DECLARE (SPECIAL *form-read*))
  (SETQ *form-read* (FUNCALL function))
  (EVAL *form-read*))

(DEFUN Ï4try-to-read-something-to-editÏ* (FUNCTION)
"Ï2Is passed a function, such as #'read (which may prompt the user) and reads
 in something which might be interpretable as something to edit.  It catches
 sundry errors in order to try to do the Right Thing.  Thus if you type
 (foo :bar) then it will try to look for functions and methods of this name,
 and if it finds one will return it.Ï*"
  (LET ((*form-read* nil))
       (DECLARE (SPECIAL *form-read* *function-spec-first-symbols*))
       (LET ((result
	       (CATCH :error?
		 (CONDITION-BIND-IF t
		   (((sys:unbound-variable sys:undefined-function)
		     'something-to-edit-error-handler))
		   (read-and-record-a-form function)))))
	    (CASE result
	      (:proceed-with-this *form-read*)
	      (:try-dwimifying
	       (IF (CONSP *form-read*)
		   (IF (EQUAL (FIRST *form-read*) 'FUNCTION)
		       *form-read*
		       ;Ï1;; Could be a method/prop spec.Ï*
		       (try-to-find-function-spec
			 *form-read* *function-spec-first-symbols*))
		   nil))
	      (otherwise *form-read*)))))

(DEFUN Ï4abort-handlerÏ* (&rest ignore)
  (THROW :abort-tag nil))

(DEFUN Ï4read-something-to-editÏ* (FUNCTION message-function)
  (LET ((result (try-to-read-something-to-edit function)))
       (IF (AND (TYPEP result 'si:vanilla-flavor)
	        (OR (NOT (FBOUNDP 'any-sort-of-clos-instance-p))
		    (NOT (any-sort-of-clos-instance-p result))))
	   (LET ((message
		   (CATCH :abort-tag
		     (CONDITION-BIND
		       (((sys:abort) #'abort-handler))
		       (try-to-read-something-to-edit message-function)))))
	        (IF message
		    (LET ((handler (GET-HANDLER-FOR result message)))
			 (IF handler
			     handler
			     (PROGN
			      (BEEP)
			      (FORMAT t "Ï3~&~S does not handle the ~S message.~%Ï*"
				      result message)
			      result)))
		    result))
	   result)))

;Ï1---------------------------------------------------------------------------------Ï*
;Ï1 TAC 08-15-89 - advice moved to WINDOW-DEBUG.LISPÏ*
;Ï1eh:Ï*
;Ï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----------------------------------------------------------------------------------Ï*

;Ï1---------------------------------------------------------------------------------Ï*
;Ï1 TAC 08-15-89 - incorporated into function below Ï*
;Ï1eh:Ï*
;Ï1(LET ((compiler:compile-encapsulations-flag t))Ï*
;Ï1     (ADVISE tv:my-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 Ï4my-window-read-thingÏ* (prompt &rest format-args)
  "Ï2A modified version of eh:window-read-thing.  This allows the reading of things
 for editting.Ï*"
  (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) (eh::window-command-loop-read))
	      (SETQ thing (IF special
			      (IF (SEND eh::*window-debugger* :inspect-window-p (THIRD special))
				  (inspect-real-value special)
				  (CASE (FIRST special)
				    (:menu  (EQ (SEND (FOURTH special) :execute (SECOND special)) t))
				    (stack-frame  (eh::list-stack-frame-function-and-args eh:*error-sg*
										      (SECOND special)))
				    (:line-area  (eh::list-stack-frame-function-and-args eh:*error-sg*
										     (SECOND special)))
				    ((SPECIAL arg local)  (FIRST (SECOND special)))
				    ((:value :function special)  (SECOND special))))
			      thing))		;Ï1.. take frame into considerationÏ*
	      (IF (NULL thing) (FORMAT t "Ï3~&Aborted.~%Ï*"))
	      thing))))
              ;Ï1; ---------------------------------------------------------------------Ï*
    (IF (TYPEP (FIRST results) '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 Ï4inspect-get-value-from-userÏ* (*terminal-io* history inspectors)	
  "Ï2Get a value either by the mouse pointing at it or by read and eval on *TERMINAL-IO*.Ï*"
  (DECLARE (SPECIAL frame))
  (UNWIND-PROTECT (BLOCK 
                   nil
                   (DOLIST (i inspectors)
                     (SEND i :set-setting-mode t))
                   (SEND history :set-setting-mode t)
                   (FORMAT *terminal-io* "Ï3~%(type a form to be evaled or select with mouse)~%Ï*")
                   (LET ((thing (w:read-any *terminal-io*))
                         error)
                     (COND
                       ((CONSP thing);Ï1; Choose somthing with the mouse -- display it truncated and proceedÏ*
                        
                        (COND
                          ((EQ (FIRST thing) :menu) (BEEP)
                           (FORMAT *terminal-io* "Ï3~&Cannot select a menu item.~%Aborted.~%Ï*")
                           (RETURN nil t))
                          ((EQ (FIRST thing) :mouse-button) (BEEP)
                           (FORMAT *terminal-io* "Ï3~&Did not select anything.~%Aborted.~%Ï*")
                           (RETURN nil t))
                          ((CHAR-EQUAL (FOURTH thing) #\Mouse-3-1)
			    (FORMAT *terminal-io* "Ï3~&Aborted.~%Ï*")
			    (RETURN nil t)))
                        (LET ((*print-level* 3)
                              (*print-length* 5))
			  ;Ï1; JPR. - new functionalityÏ*
			  (SETQ thing (inspect-real-value thing))
			  (SETQ thing (maybe-data-from-inspection-data thing))
                          (PRIN1 thing *terminal-io*)))
                       (t (w:unread-any thing *terminal-io*)
                        (MULTIPLE-VALUE-SETQ (thing error)
                          (CATCH-ERROR
                           (EVAL (LET ((*standard-input* *terminal-io*))
                                   (READ-FOR-TOP-LEVEL)))))
                        (WHEN error;Ï1; Failed to eval, puntÏ*
                          (BEEP)
                          (FORMAT *terminal-io* "Ï3~&Aborted.~%Ï*")
                          (RETURN nil t))))
                     (TERPRI *terminal-io*)
                     (RETURN thing)) nil)
                  (DOLIST (i inspectors)
     (SEND i :set-setting-mode nil))
    (SEND history :set-setting-mode nil)))


(DEFUN Ï4my-inspect-get-value-from-userÏ* (*terminal-io* history inspectors)	
  "Ï2Get a value either by the mouse pointing at it or by read and eval on *TERMINAL-IO*.  
   Modified from Inspect-Get-Value-from-User, so as to read things for editting.Ï*"
  (DECLARE (SPECIAL frame))
  (UNWIND-PROTECT (BLOCK 
                   nil
                   (DOLIST (i inspectors)
                     (SEND i :set-setting-mode t))
                   (SEND history :set-setting-mode t)
                   (FORMAT *terminal-io* "Ï3~%(type a form to be evaled or select with mouse)~%Ï*")
                   (LET ((thing (w:read-any *terminal-io*))
                         error)
                     (COND
                       ((CONSP thing);Ï1; Choose somthing with the mouse -- display it truncated and proceedÏ*
                        
                        (COND
                          ((EQ (FIRST thing) :menu) (BEEP)
                           (FORMAT *terminal-io* "Ï3~&Cannot select a menu item.~%Aborted.~%Ï*")
                           (RETURN nil t))
                          ((EQ (FIRST thing) :mouse-button) (BEEP)
                           (FORMAT *terminal-io* "Ï3~&Did not select anything.~%Aborted.~%Ï*")
                           (RETURN nil t))
                          ((CHAR-EQUAL (FOURTH thing) #\Mouse-3-1)
			    (FORMAT *terminal-io* "Ï3~&Aborted.~%Ï*")
			    (RETURN nil t)))
                        (LET ((*print-level* 3)
                              (*print-length* 5))
			  ;Ï1; JPR - new functionality Ï*
			  (SETQ thing (inspect-real-value thing))
			  (SETQ thing (maybe-data-from-inspection-data thing))
                          (PRIN1 thing *terminal-io*)))
                       (t (w:unread-any thing *terminal-io*)
                        (MULTIPLE-VALUE-SETQ (thing error)
                          (CATCH-ERROR
                           (LET ((*standard-input* *terminal-io*))
			            ;Ï1; JPR - new functionality Ï*
                                   (try-to-read-something-to-edit
				     'READ-FOR-TOP-LEVEL))))
                        (WHEN error ;Ï1; Failed to eval, puntÏ*
                          (BEEP)
                          (FORMAT *terminal-io* "Ï3~&Aborted.~%Ï*")
                          (RETURN nil t))))
                     (TERPRI *terminal-io*)
                     (RETURN thing)) nil)
                  (DOLIST (i inspectors)
     (SEND i :set-setting-mode nil))
    (SEND history :set-setting-mode nil)))

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

(DEFUN Ï4inspect-try-and-editÏ* (something)
  (DECLARE (SPECIAL user history = inspectors frame))
  (IF (AND (TYPEP something 'si:vanilla-flavor)
	   (OR (NOT (FBOUNDP 'any-sort-of-clos-instance-p))
	       (NOT (any-sort-of-clos-instance-p something))))
      (IF (AND (BOUNDP '*general-inspector-enabled*)
	       (SYMBOL-VALUE '*general-inspector-enabled*)
	       (TYPEP something 'inspection-data))
	  ;Ï1; Hook for general inspector.Ï*
	  (IF (FUNCALL 'map-into-show-x something)
	      (try-and-edit (FUNCALL 'map-into-show-x something))
	      (try-and-edit (SEND something :send-if-handles :data)))
	  (LET ((message
		  (CATCH :abort-tag
		    (CONDITION-BIND
		      (((sys:abort) #'abort-handler))
		      (FORMAT user 
	     "Ï3~&Select a method name [Ï*Ï3] for flavor definition:Ï*")
		      (MULTIPLE-VALUE-BIND (value punt-p)
			  (inspect-get-value-from-user user history inspectors)
			(IF punt-p
			    (THROW :abort-tag nil)
			    value))))))
	       (IF message
		   (LET ((handler (GET-HANDLER-FOR something message)))
			(IF handler
			    (try-and-edit handler)
			    (PROGN
			      (BEEP)
			      (FORMAT t "Ï3~&~S does not handle the ~S message.~%Ï*"
				      something message)
			      (try-and-edit something))))
		   (try-and-edit something))))
      (try-and-edit something)))

(DEFCOMMAND Ï4inspect-edit-cmdÏ* nil			
  '(:description "Ï3Edit the definition of something.Ï*"
    :names ("Ï3EditÏ*")
    :keys (#\m-. #\c-e #\h-e))
   (LETF ((#'inspect-get-value-from-user #'my-inspect-get-value-from-user))
	 (do-something-and-inspect "Ï3~&Object to edit definition of:Ï*"
				   'inspect-try-and-edit)))
;Ï1^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^Ï*


;Ï1***************Ï*
;Ï1 TAC 08-01-89 - redefines code originally in window-debugÏ*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1 For the window debugger.Ï*
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1;; Redefine the edit command so that it will take m-. as a key assignment for Ï*
;Ï1;; compatibility with ZMacs. Just add new key assignments.Ï*

eh:
(DEFUN Ï4eh::comw-editÏ* (IGNORE ignore)
"Ï2This is a redefined version of the debugger's edit command.  It uses the
 consistency enhancements mechanism for finding the source file to edit.Ï*"
  (LET ((thing (tv::read-something-to-edit
		 #'(lambda ()
		     (tv::my-window-read-thing
		       "Ï3~%Type or mouse on something to edit: Ï*" t))
		 #'(lambda ()
		     (tv::my-window-read-thing
      "Ï3~%Type or mouse on a message name [Ï*Ï3] for flavor definition : Ï*" t)))))
     (tv::try-and-edit thing)))

eh:
(DEFCOMMAND Ï4eh::comw-edit-cmdÏ* nil
  '(:description  "Ï3Invoke the Editor on a specified function.Ï*"
    :names "Ï3EditÏ*" 
    :keys (#\m-. #\c-e #\h-e))
  (SEND *window-debugger* :set-who-line-doc-string-overide
	"Ï3Select a function to edit.Ï*")
  (UNWIND-PROTECT (comw-edit *error-sg* *error-object*)
    (PROGN (SEND *window-debugger* :set-who-line-doc-string-overide nil)
	   (SEND *window-debugger* :handle-prompt))))
;Ï1----------------------------------------------------------------------Ï*


;Ï1-------------------------------------------------------------------------------Ï*
;Ï1; TAC 07-25-89 - I commented this out - it is not clear how the user supplies Ï*
;Ï1; any of the options (:never :query t nil) for documenting standard generic functions.Ï*
;Ï1; Casey worked with me on this and the normal documenting of standard generic functionsÏ*
;Ï1; will work with the general inspector.  Ï*

;Ï1#+CLOSÏ*
;Ï1(defvar ticlos:*display-method-docs-for-generic-functions-p* nilÏ*
;Ï1"When t, causes the doc strings for methods of a generic function to beÏ*
;Ï1 printed when (documentation is called on a GF.  If this is :query thenÏ*
;Ï1 the user is asked before the method docs are shown.  If it is :never, thenÏ*
;Ï1 the method docs are never shown, even when the GF has no docs.Ï*
;Ï1"Ï*
;Ï1)Ï*

;Ï1#+CLOSÏ*
;Ï1ticlos:Ï*
;Ï1(defmethod ticlos:documentation ((dobj ticlos:standard-generic-function) &optional doc-type)Ï*
;Ï1  (when doc-typeÏ*
;Ï1    (error "~%A second argument, ~s, was supplied in a call to DOCUMENTATION Ï*
;Ï1of a generic function object.~%" doc-type))Ï*
;Ï1  (let ((doc-string (if (compiled-function-p dobj)Ï*
;			Ï1(let ((dbi (si:get-debug-info-struct dobj)))Ï*
;			Ï1  (si:get-debug-info-field dbi :documentation))Ï*
;			Ï1(ticlos:generic-function-documentation dobj))))Ï*
;Ï1    (case *display-method-docs-for-generic-functions-p*Ï*
;Ï1      (nil (or doc-stringÏ*
;	Ï1       (apply #'string-appendÏ*
;		Ï1      (mapcar 'get-method-doc (generic-function-methods dobj))Ï*
;	Ï1       )Ï*
;	Ï1   )Ï*
;Ï1      )Ï*
;Ï1      (:never doc-string)Ï*
;Ï1      (:query (if (y-or-n-p "~&Show doc strings for methods of ~S?" dobj)Ï*
;		Ï1  (apply #'string-appendÏ*
;			Ï1 doc-stringÏ*
;			Ï1 (mapcar 'get-method-docÏ*
;				Ï1 (generic-function-methods dobj)Ï*
;			Ï1 )Ï*
;		Ï1  )Ï*
;		Ï1  doc-stringÏ*
;	Ï1      )Ï*
;Ï1      )Ï*
;Ï1      (t (apply #'string-appendÏ*
;		Ï1doc-stringÏ*
;		Ï1(mapcar 'get-method-doc (generic-function-methods dobj))Ï*
;	Ï1 )Ï*
;Ï1      )Ï*
;Ï1    )Ï*
;Ï1  )Ï*
;Ï1)Ï*

;Ï1#+CLOSÏ*
;Ï1ticlos:Ï*
;Ï1(defun ticlos:get-method-doc (method)Ï*
;Ï1  (let ((doc (documentation method)))Ï*
;Ï1       (if docÏ*
;	Ï1   (format nil "~%From ~A:~%~A~%"Ï*
;		Ï1   (function-name (method-function method)) docÏ*
;	Ï1   )Ï*
;	Ï1   ""Ï*
;Ï1       )Ï*
;Ï1  )Ï*
;Ï1)Ï*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1;; W A R N I N G.....Ï*
;Ï1;; The following puts a pathname dependency into this file.Ï*
;Ï1;; This should really be done by a conditional load in the defsystem,Ï*
;Ï1;; but Defsystem doesn't have such things....   JPR. 28 Feb 89.Ï*

;Ï1 TAC 07-25-89 - this causes problems so I removed itÏ*
;Ï1(if (eq sys:(processor-type microcode-type-code) :micro-Explorer)Ï*
;Ï1    (si:load-if "TOOLS:TOOLS;DTCE-MICROEXPLORER-SPECIFIC" :verbose nil)Ï*
;Ï1    (si:load-if "TOOLS:TOOLS;DTCE-EXPLORER-SPECIFIC" :verbose nil)Ï*
;Ï1)Ï*

;Ï1(provide 'Development-Tool-Consistency-Enhancements)Ï*


;Ï1;; Code to install the commands...Ï*

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

;Ï1;; Commands to add, Command Menus, and Command InstallationÏ*

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

;Ï1*************Ï*
;Ï1 TAC 08-08-89 - changing constant to a parameter because later on grapher setqs it.Ï*
;Ï1(defconstant *all-consistancy-commands*Ï*

(DEFPARAMETER Ï4*all-consistancy-commands*Ï*
	      '(("Ï3InspectÏ*" :value
		 (((#\c-sh-i zwei::com-inspect-region)
		   (#\m-sh-i zwei::com-inspect-region))
		  nil
		  nil))
		("Ï3EvalÏ*" :value
		 (nil
		   ((inspect-eval-cmd t))
		   nil))
		("Ï3MacroExpandÏ*" :value
		 (nil
		   ((inspect-macroexpand-cmd t))
		   nil))
		("Ï3CompileÏ*" :value
		 (nil
		   ((inspect-compile-cmd t))
		   ((eh::comw-compile-cmd t))))
		("Ï3Save RegionÏ*" :value
		 (nil
		   ((save-region-cmd nil))
		   ((eh::comw-save-region nil))))
		("Ï3ISearchÏ*" :value
		 (nil
		   ((search-cmd nil))
		   ((eh::comw-isearch nil))))
		("Ï3Reverse ISearchÏ*" :value
		 (nil
		   ((reverse-search-cmd nil))
		   ((eh::comw-reverse-isearch nil))))
		("Ï3ArglistÏ*" :value
		 (nil
		   ((arglist-cmd t))
		   ((eh::comw-arglist-cmd t))))
		("Ï3TraceÏ*" :value
		 (((#\s-sh-t zwei::com-untrace)
		   (#\m-sh-t zwei::com-just-trace)
		   (#\c-sh-t zwei::com-trace))
		  ((trace-cmd t)
		   (just-trace-cmd nil)
		   (untrace-cmd nil))
		  ((eh::comw-trace t)
		   (eh::comw-just-trace nil)
		   (eh::comw-untrace nil))))
		("Ï3DocumentÏ*" :value
		 (nil
		   ((document-something-cmd t)
		    (documentation-cmd t))
		   ((eh::comw-debug-document-something t)
		    (eh::window-debugger-help-cmd t))))
		("Ï3Flavor InspectÏ*" :value
		 (((#\c-sh-f zwei::com-flavor-inspect)
		   (#\m-sh-f zwei::com-flavor-inspect)
		   (#\h-f    zwei::com-flavor-inspect))
		  nil
		  ((eh::flavor-inspect-cmd t)))))
  
  "Ï2This is a list of the commands which can be added to the system.  
 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 (zmacs-commands inspector-commands debugger-commands)
 Each element of zmacs-commands has the form (key command-name).  Each element of
 inspector-commands and debugger-commands has the form (command-name put-in-frames-menu-p).Ï*")

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

(DEFUN Ï4install-consistency-commandsÏ* ()
"Ï2Installs all of the commands necessary to induce consistency in the system
 that the user wants.Ï*"
  (select-and-install-commands *all-consistancy-commands*
			       *selected-consistancy-commands*))

(DEFUN Ï4convert-to-non-menu-itemÏ* (item)
"Ï2Given a menu item which might generate a menuable command, this one returns
 a command which will certainly not appear in the frame's command menu.Ï*"
  (APPEND (LIST (FIRST item) (SECOND item))
	  (LIST
	  (CONS (FIRST (THIRD item))
		(MAPCAR #'(lambda (component)
			    (MAPCAR #'(lambda (element)
					(LIST (FIRST element) nil))
				      component))
			  (REST (THIRD item)))))))

(DEFUN Ï4convert-to-column-listÏ* (LIST)
"Ï2Given a list of items to put in the menu of commands, this turns it into
 a list of menu items suitable to be in two columns, one for commands to go
 into the frame's command menu and one which is not.Ï*"
  (APPEND '(("Ï3Put in MenuÏ*" :noselect nil :font fonts:hl12b))
	  '(("Ï3Don't put in MenuÏ*" :noselect nil :font fonts:hl12b))
	  (APPLY #'APPEND
		 (MAPCAR #'LIST list (MAPCAR 'convert-to-non-menu-item list)))))

(DEFUN Ï4install-zmacs-commmandÏ* (command)
"Ï2Installs a zmacs command.Ï*"
  (zwei::set-comtab zwei::*standard-comtab* command
		   (zwei::make-command-alist (REST command))))

(DEFUN Ï4reinstall-inspector-commandsÏ* ()
"Ï2Reinstalls all inspector commands just in case they have changed.Ï*"
  (BUILD-COMMAND-TABLE
    'inspector-menu-cmd-table
    'inspect-frame inspector-menu-cmds :init-options	
    '(:name "Ï3Inspector menu commandsÏ*"))
  (BUILD-COMMAND-TABLE
    'inspector-other-cmd-table
    'inspect-frame inspector-non-menu-cmds :init-options	
    '(:name "Ï3Other Inspector commandsÏ*"))
  (BUILD-MENU 'ucl-inspector-menu 'inspect-frame
    :default-item-options `(:font ,inspect-standard-font)	
    :item-list-order inspector-menu-cmds))

(DEFUN Ï4install-inspector-commandÏ* (command)
"Ï2Installs an inspector command.Ï*"
  (LET ((command-name (FIRST command))
	(menu-p (SECOND command)))
       (IF menu-p
	   (IF (MEMBER command-name inspector-menu-cmds)
	       nil
	       (PROGN (SETQ inspector-menu-cmds
			    (CONS command-name inspector-menu-cmds))
		      (reinstall-inspector-commands)))
	   (IF (MEMBER command-name inspector-non-menu-cmds)
	       nil
	       (PROGN (SETQ inspector-non-menu-cmds
			    (CONS command-name inspector-non-menu-cmds))
		      (reinstall-inspector-commands))))))

eh:
(DEFPARAMETER Ï4eh::*debugger-examine-menu-commands*Ï*
  '(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
   )
"Ï2The commands for the window debugger extracted from the source code where they
 are a literal constant (groan).Ï*")


eh:
(DEFPARAMETER Ï4eh::*debugger-general-commands*Ï*
  '(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
   )
"Ï2The commands for the window debugger extracted from the source code where they
 are a literal constant (groan).Ï*")

eh:
(DEFPARAMETER Ï4eh::*window-debugger-all-commands-menu-commands*Ï*
   '((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Ï*"))
"Ï2The commands for the window debugger extracted from the source code where they
 are a literal constant (groan).Ï*")

(DEFUN Ï4reinstall-debugger-commandsÏ* ()
"Ï2Reinstalls all debugger commands just in case they have changed.Ï*"
  (BUILD-COMMAND-TABLE 'window-debugger-general-cmd-table
		       'debugger-frame
    eh::*debugger-general-commands*
    :init-options
    '(:name "Ï3General window-based debugger commandsÏ*"))
  (BUILD-MENU 'ucl-window-debugger-examine-menu
	      'debugger-frame
    :default-item-options '(:font fonts:cptfont)
    :item-list-order
    (CONS '("Ï3ExamineÏ*" :font fonts:hl10b)
	  eh::*debugger-examine-menu-commands*))
  (BUILD-MENU '*window-debugger-all-commands-menu*
	      'debugger-frame
    :item-list-order eh::*window-debugger-all-commands-menu-commands*
    :column-list-order
    '(("Ï3GeneralÏ*" :font fonts:hl12b)
      ("Ï3StackÏ*" :font fonts:hl12b) 
      ("Ï3StepÏ*" :font fonts:hl12b)
      ("Ï3ResumeÏ*" :font fonts:hl12b))))

(DEFUN Ï4install-debugger-commandÏ* (command)
"Ï2Installs a new debugger command.Ï*"
  (LET ((command-name (FIRST command))
	(menu-p (SECOND command)))
       (IF menu-p
	   (IF (MEMBER command-name eh::*debugger-examine-menu-commands*)
	       nil
	       (PROGN (SETQ eh::*debugger-examine-menu-commands*
			    (CONS command-name
				  eh::*debugger-examine-menu-commands*))
		      (reinstall-debugger-commands))))
       (IF (MEMBER command-name eh::*debugger-general-commands*)
	   nil
	   (PROGN (SETQ eh::*debugger-general-commands*
			(CONS command-name eh::*debugger-general-commands*))
		  (reinstall-debugger-commands)))
       (LET ((general-command-spec (LIST command-name :column "Ï3GeneralÏ*")))
	    (IF (MEMBER general-command-spec
			eh::*window-debugger-all-commands-menu-commands*)
		nil
		(PROGN (SETQ eh::*window-debugger-all-commands-menu-commands*
			 (APPEND eh::*window-debugger-all-commands-menu-commands*
				 (LIST general-command-spec)))
		       (reinstall-debugger-commands))))))

(DEFUN Ï4install-commandÏ* (command-spec)
"Ï2Given a command spec from the menu of commands to install, install the commands
 in all of the tools that are interested in them.Ï*"
  (LET ((zmacs-component     (FIRST  command-spec))
	(inspector-component (SECOND command-spec))
	(debugger-component  (THIRD  command-spec))
       )
       (MAPCAR 'install-zmacs-commmand    zmacs-component)
       (MAPCAR 'install-inspector-command inspector-component)
       (MAPCAR 'install-debugger-command  debugger-component)))

(DEFUN Ï4select-and-install-commandsÏ* (commands switch)
"Ï2Is passed a list of all of the commands that can be added and a switch
 which tells the system what commands to add.  This switch can have the values
 :Menu, :All or it can be a list of items.  Each item can be an element from
 Commands, a subitem from Commands (the bit following the :Value) or a string
 denoting the name of one of the menu items.Ï*" 
  (LET ((selected-items
	  (IF (EQUAL switch :menu)
	      (w:menu-choose (convert-to-column-list commands)
			     :highlighting t
			     :highlighted-items nil
			     :near-mode '(:mouse)
			     :label "Ï3Select commandsÏ*"
			     :menu-margin-choices '(:doit)
			     :geometry '(2)
			     :superior mouse-sheet)
	      (IF (EQUAL switch :all)
		  (MAPCAR #'THIRD commands)
		  (MAPCAR #'(lambda (command)
			      (IF (CONSP command)
				  (IF (STRINGP (FIRST command))
				      (THIRD command)
				      command)
				  (IF (STRINGP command)
				      (LET ((entry (ASSOC command commands
							  :test #'STRING-EQUAL)))
					   (IF entry
					       (THIRD entry)
					       (FERROR nil
						       "Ï3~S is not a defined command to add.Ï*" command)))
				      (FERROR nil "Ï3~S is not a valid command specifier.Ï*" command))))
			    (IF (CONSP switch)
				switch
				(FERROR nil "Ï3~S is not :Menu :All or a list of commandsÏ*" switch))))))
	) ;Ï1; all of the code above determines the value of selected-itemsÏ*
       (MAPCAR 'install-command selected-items)))
;Ï1-------------------------------------------------------------------------------Ï*

(reinstall-inspector-commands) 

(install-consistency-commands)  



