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


;-------------------------------------------------------------------------------
;;; This file written by James Rice of the Stanford University
;;; Knowledge Systems Laboratory (Rice@Sumex-Aim.Stanford.Edu)
;;; The majority of this code was written by modifying existing
;;; code belonging to TI.

;;; February 89.
;-------------------------------------------------------------------------------
;;; Just define a dummy package if CLOS is not loaded.  This should mean
;;; That these patches can be loaded onto a system which does not have CLOS
;;; loaded.

;Ï1 TAC 08-17-89 - removing pcl supportÏ*
;Ï1(EVAL-WHEN (COMPILE load)Ï*
;Ï1  (LET ((si:inhibit-fdefine-warnings t))Ï*
;Ï1       (IF (FIND-PACKAGE 'ticlos)Ï*
;	Ï1   nilÏ*
;	Ï1   (DEFPACKAGE ticl (:use lisp ticl)))Ï*
;Ï1       (IF (NOT (sys:find-system-named 'pcl t t))Ï*
;	Ï1   (DEFPACKAGE pcl (:use lisp))Ï*
;	Ï1   nil)))Ï*

(EVAL-WHEN (COMPILE load)
  (LET ((si::inhibit-fdefine-warnings t))
       (IF (FIND-PACKAGE 'ticlos)
	   nil
	   (DEFPACKAGE ticlos (:use lisp ticl)))
       ))
;Ï1-------------------------------------------------------------------------------Ï*

(DEFVAR Ï4*dont-have-initial-space*Ï* nil
"Ï2When this is bound to true, printing functions will not throw an initial space
 for the show-x at the beginning.  This is used because the format-concisely
 methods for some show-x things have a space at the begining so as to make them
 easier to read when they are on their own on a line, since they would
 otherwise be butted up against the scroll bar.Ï*")


(DEFUN Ï4show-a-class-namedÏ* (data)
"Ï2Allocates data for a class named Data.  If there isn't such a class then
 an undefined class show-x is allocated.Ï*"
  (LET ((class (class-named-safe data t)))
       (IF class
	   (allocate-data 'show-clos-class class)
	   (allocate-data 'show-undefined-clos-class data))))

(DEFUN Ï4show-a-classÏ* (data)
"Ï2Allocates data to show a clos class.Ï*"
  (allocate-data 'show-clos-class data))

(DEFUN Ï4coerce-class-to-nameÏ* (class)
"Ï2Given a class or class name, coerces it into the name of the class.  Class
 make be a flavor (because of flavor classes).  The righ thing happens for
 this, as it does in the event of it being a show-x.Ï*"
  (TYPECASE class
    (symbol class)
    (any-sort-of-clos-instance (class-name-safe class))
    (si::flavor (si::flavor-name class))
    (inspection-data (coerce-class-to-name (SEND class :data)))
    (otherwise (FERROR nil "Ï3Cannot coerce ~S into a class name.Ï*" class))))

(DEFVAR Ï4*class-options-menu*Ï*
   '(("Ï3SlotsÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-clos-instance-variables *flavor-data*)
      :documentation "Ï3Inspect all slots defined by this classÏ*")
     ("" :no-select t)
     ("Ï3DetailsÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-clos-class-details *flavor-data*)
      :documentation "Ï3Show more detail about this classÏ*")
     ("" :no-select t)
     ("Ï3Local methodsÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-local-clos-methods *flavor-data*)
      :documentation "Ï3Inspect methods defined locally for this classÏ*")
     ("Ï3All MethodsÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-all-clos-methods *flavor-data*)
      :documentation "Ï3Inspect methods defined for and inherited by this classÏ*")
     ("Ï3All Methods, SortedÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-all-clos-methods-sorted *flavor-data*)
      :documentation "Ï3Sorted version of the \" ALL METHODS\" optionÏ*")
     ("" :no-select t)
     ("Ï3Local Generic FunctionsÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-local-clos-generic-functions *flavor-data*)
      :documentation "Ï3Inspect generic functions defined locally for this classÏ*")
     ("Ï3All Generic functionsÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-all-clos-generic-functions *flavor-data*)
      :documentation "Ï3Inspect generic functions defined for and inherited by this classÏ*")
     ("Ï3All Generic functions, SortedÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-all-clos-generic-functions-sorted *flavor-data*)
      :documentation "Ï3Sorted version of the \" ALL GENERIC FUNCTIONS\" optionÏ*")
     ("" :no-select t)
     ;Ï1; This needs better who-line doc.  How it differs from Show Class.Ï*
     ("Ï3SuperClassesÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-component-classes *flavor-data*)
      :documentation "Ï3Inspect classes which make up this class (non-heirarchical display).Ï*")
     ("Ï3SubClassesÏ*"
      :eval (SEND ucl::this-application :inspect-thing 'show-dependent-classes *flavor-data*)
      :documentation "Ï3Inspect classes which directly or indirectly depend on this classÏ*")
     ("" :no-select t)
     ("Ï3DebugÏ*"
      :eval (SEND ucl:this-application :inspect-thing 'debug-class
		  *flavor-data*)
      :documentation "Ï3Find inconsistencies and dangerous characteristics of this class (can be slow)Ï*")
     ("" :no-select t)
     ("Ï3EditÏ*"
      :eval (SETQ call-edit t)
      :documentation "Ï3Edit this class in a Zmacs buffer.Ï*"))
"Ï2The item list for the class options right button menu.Ï*")

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

(DEFFLAVOR Ï4generic-middle-button-mixinÏ* () ()
  (:documentation :mixin "Ï3Used to add generic middle button and l-2 behaviour to
 show-x flavors.Ï*"))

(DEFMETHOD Ï4(generic-middle-button-mixin :middle-button-resultÏ*) ()
"Ï2A generic method for this flavor.Ï*"
  (SEND self :data))

(DEFMETHOD Ï4(generic-middle-button-mixin :handle-mouse-clickÏ*)
	   (blip flavor-inspector)
"Ï2A simple mouse click handler for show-x things.  It invokes the normal handlers
 for the l, l2 and m clicks..Ï*"
  (SELECTOR (FOURTH blip) =
    (#\mouse-l-1 (SEND flavor-inspector :inspect-info-left-click))
    (#\mouse-l-2 (SEND flavor-inspector :inspect-info-left-2-click))
    (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
    (otherwise (BEEP))))

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

(DEFFLAVOR Ï4class-operation-mixinÏ* () (flavor-operation-mixin)
  (:documentation :mixin "Ï3Like flavor-operation-mixin, but for classes.
 Knows about how to put up a class options right button menu.Ï*"))

(DEFMETHOD Ï4(class-operation-mixin :aux-dataÏ*) ()
"Ï2This is defined just in case we get asked what our aux data it.  It helps
 to give reasonable behaviour in the event of being meddle buttoned on.Ï*"
  (class-name-safe data))

(DEFMETHOD Ï4(class-operation-mixin :handle-mouse-clickÏ*) (blip flavor-inspector)
"Ï2A mouse click handler that allows this mixin to pop up the class options
 menu for r-1 clicks.  L and M clicks are handled in the normal ways.Ï*"
  (SELECTOR (FOURTH blip) =
    (#\mouse-l-1 (SEND flavor-inspector :inspect-info-left-click))
    (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
    (#\mouse-r-1 (LET ((*flavor-data* data) (call-edit nil))
                   (DECLARE (SPECIAL *flavor-data* call-edit))
                   (w:menu-choose
		     *class-options-menu*
		     :label (FORMAT nil "Ï3Operations on ~SÏ*"
				    (flavor-or-class-name data))
		     :scrolling-p nil)
		   (IF call-edit
		       (ED (flavor-or-class-name *flavor-data*)))
		   ))
    (t
     (BEEP))))

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

(DEFFLAVOR Ï4show-undefined-clos-classÏ* ()
	   (generic-middle-button-mixin inspection-data)
  (:documentation
"Ï3A class of show-x that knows how to display undefined classes.  This is
 important because we don't want lossage if the user opts to flavex a
 flavor/class that has not had all of its components defined yet.  None of
 the code in the class inspector (except for the stuff about method combination)
 should rely in any way on the class being fully defined/finalized/able.Ï*"))

(DEFMETHOD Ï4(show-undefined-clos-class :format-conciselyÏ*) (STREAM)
"Ï2A simple print method for undefined classes.Ï*"
  (FORMAT stream "Ï3Undefined Class ~SÏ*" data))

(DEFMETHOD Ï4(show-undefined-clos-class :middle-button-resultÏ*) ()
"Ï2When you middle on an undefined class you just get its name back.Ï*"
  data)

(DEFMETHOD Ï4(show-undefined-clos-class :generate-itemÏ*) ()
"Ï2Undefined classes don't have anything special about them so the item list
 generated is pretty vestigial.Ï*"
  (VALUES
     `()
     ;Ï1;Make the label display the class name.Ï*
     `(:font fonts:hl12bi :string ,(FORMAT nil "Ï3Undefined Class ~sÏ*" data))))

(DEFMETHOD Ï4(show-undefined-clos-class :helpÏ*) ()
"Ï2We can't help much here.Ï*"
 (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying an undefined
class ~S.  To get any more information you'll have to defclass it.  Failure to
do so will signal an error when you try to instantiate any class that refers to
this one.Ï*"
	 data))
;Ï1-------------------------------------------------------------------------------Ï*

(DEFFLAVOR Ï4show-clos-class-detailsÏ* () (class-operation-mixin)
  (:documentation
"Ï3A show-x class that shows details about its Data, which is a class.  This is
 different from the normal show-clos-class, since that just shows you its
 inheritance tree.  This tells you about the options that were used when it
 was defclassed.Ï*"))

;Ï1 TAC 08-17-89 - removing pcl supportÏ*
;(DEFMETHOD Ï4(show-clos-class-details :format-conciselyÏ*) (STREAM)
;"Ï2When the data is a PCL class we should say so.  Otherwise we just say whatÏ*
;Ï2 we are.Ï*"
;  (IF (iwmc-class-p-safe data)
;      (FORMAT stream "Ï3PCL Ï*"))
;  (FORMAT stream "Ï3Class ~ý's detailsÏ*"
;	  (LIST (allocate-data 'show-clos-class data) nil
;		(class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-clos-class-details :format-conciselyÏ*) (STREAM)
"Ï2Report what class we are along with details.Ï*"
  (FORMAT stream "Ï3Class ~ý's detailsÏ*"
	  (LIST (allocate-data 'show-clos-class data) nil
		(class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-clos-class-details :middle-button-resultÏ*) ()
"Ï2Just returns the class itself.Ï*"
  data)

(DEFMETHOD Ï4(show-clos-class-details :helpÏ*) ()
"Ï2Simple help for the details of clos classes.Ï*"
  (LET ((class-name (class-name-safe data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying sundry details
about the class ~S.  The right button menu will let you find out other
things about this class or related classes.Ï*"
	    class-name)))

(DEFUN Ï4itemise-precedence-listÏ* (class)
"Ï2Given a class, turns its class-precedence-list into a collection of comma
 separated items that point to show-clos-classes.Ï*"
  (APPLY #'APPEND
        `((:item1 instance
		  ,(allocate-data 'show-clos-class
				  (FIRST (class-precedence-list-safe class)))))
	 (LOOP for cl
	       in (MAPCAR #'(lambda (x) (allocate-data 'show-clos-class x))
			  (REST (class-precedence-list-safe class)))
	       collect `((:font 1 "Ï3, Ï*") (:item1 instance ,cl)))))

(DEFUN Ï4itemise-default-initargsÏ* (class)
"Ï2Itemises the default-initargs of a class.  They get returned as a load of
 items that will end up on separate lines with a space at the beginning.Ï*"
  (LET ((args (class-default-initargs-safe class)))
       (IF args
	   (LET ((MAX (APPLY #'MAX 0 (LOOP for (x y) in args collect
					   (LENGTH (SYMBOL-NAME x))))))
		(LOOP for (init value) in args
		      collect `(,*one-space-item*
				(:item1 named-structure-value ,init)
				(:colon ,(+ 2 max))
				(:item1 named-structure-value ,value))))
	   *no-items*)))

(DEFMETHOD Ï4(show-clos-class-details :generate-itemÏ*) ()
"Ï2Makes the inspector mouse-sensitive items for show-clos-class-details show-xs.Ï*"
  (VALUES
     `(,*blank-line-item*
       ;Ï1 TAC 08-17-89 - removing pcl supportÏ*
       (;Ï1; Ï*(:font 1 ,(IF (iwmc-class-p-safe data) "Ï3PCL Class Ï*" "Ï3Class Ï*"))
	(:font 1 "Ï3Class Ï*")
        (:item1 instance ,(allocate-data 'show-clos-class data))
	(:font 1 "Ï3's details.Ï*"))
       ,*blank-line-item*
       ((:font 1 "Ï3Metaclass:                 Ï*")
        (:item1 instance ,(allocate-data 'show-clos-class (class-of-safe data))))
       ,*blank-line-item*
       ((:font 1 "Ï3Source File:               Ï*")
	,(IF (AND (GET (class-name-safe data) :source-file-name)
		  (class-name-safe data))
	     (path-string-safe data)
	     (FORMAT nil "Ï3Not DefinedÏ*")))
       ,*blank-line-item*
       ((:font 1 "Ï3Precedence List:           Ï*")
	,@(itemise-precedence-list data))
       ,*blank-line-item*
       ((:font 1 "Ï3Default Initargs:Ï*"))
       ,@(itemise-default-initargs data)
       ,*blank-line-item*
       ((:font 1 "Ï3Documentation:Ï*"))
       ,@(LET ((doc (CATCH-ERROR (DOCUMENTATION data) nil)))
	   (IF (AND doc (NOT (EQUAL "" doc)))
	       (break-string-into-lines doc)
	       *no-items*)))
     ;Ï1;Make the label display the class name.Ï*
     `(:font fonts:hl12bi :string ,(FORMAT nil "Ï3~AÏ*" (class-pretty-name data)))))

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

;Ï1*************Ï*
;Ï1 TAC 07-26-89 - moved from GENERAL-INSPECTOR Ï*
(DEFVAR Ï4*general-inspector-enabled*Ï* t
  "Ï2When true the general inspector is enabled.Ï*")

(DEFFLAVOR Ï4show-clos-classÏ* () (class-operation-mixin)
  (:documentation
"Ï3This is the most commonly used show-x flavor in the class inspector. 
 It shows CLOS classes as an indented collection of components.Ï*"))

(DEFMETHOD Ï4(show-clos-class :middle-button-resultÏ*) ()
"Ï2Show-CLOS-Classes just return the class itsle when they get middle buttoned.Ï*"
  data)

(DEFUN Ï4in-history-window-pÏ* (STREAM)
"Ï2Is true if we're trying to write into the inspect history window.Ï*"
  (AND (BOUNDP '*general-inspector-enabled*)
       *general-inspector-enabled*
       (TYPEP stream 'inspect-history-window)))

(DEFUN Ï4class-pretty-nameÏ* (class &optional (history-window-p nil))
  (WITH-OUTPUT-TO-STRING (STREAM)
    (IF (class-name-safe class)
	(IF history-window-p
	    (FORMAT stream "Ï3~AClass ~sÏ*"
		    ;Ï1; TAC 08-17-89 - removing pcl supportÏ*
		    ;Ï1; Ï*(IF (iwmc-class-p-safe class) "Ï3PCL Ï*" "")
		    "" (class-name-safe class))
	    (FORMAT stream "Ï3~sÏ*" (class-name-safe class)))
	(PROGN (IF history-window-p
		   (FORMAT stream "Ï3Anonymous ~AClass Ï*"
			   ;Ï1; TAC 08-17-89 - removing pcl supportÏ*
			   ;Ï1;Ï*(IF (iwmc-class-p-safe class) "Ï3PCL Ï*" "")
			   "")
		   (FORMAT stream "Ï3Anonymous Ï*"))
	       (print-pointer class stream)))))

(DEFMETHOD Ï4(show-clos-class :format-conciselyÏ*) (STREAM)
  "Ï2When this flavor is printed in the history window we say CLASS before it so
 that we know its a class, since symbols are also just printed using their
 names.  When we aren't in the history window we don't have to worry about this.Ï*"
  (PRINC (class-pretty-name data (in-history-window-p stream)) stream))

;Ï1*************Ï*
;Ï1 TAC 08-04-89 - better version of this in GENERAL-INSPECTORÏ*
;Ï1(defmethod (show-clos-class :who-line-doc)Ï*

(DEFUN Ï4class-componentsÏ* (class-name)
"Ï2Returns a structure of the components of class-name.  This can later be turned
 into an item-list that is suitably indented for the inspector to show the
 class precedence/inheritance heirarchy.  The structure of the result of this
 function is, therefore, important.Ï*"
  (LET ((class (IF (class-p-safe class-name)
		   class-name
		   (class-named-safe class-name t))))
       (IF class
	   (LET ((result
		   (IF class
		      `(,class-name
			,(LOOP for component in
			       (class-local-supers-safe class)
			       collect
				(IF (class-p-safe component)
				    (class-components
				      (class-name-safe component))
				    (LIST component))))
		       nil)))
		result)
	   (LIST class-name nil))))

(DEFMETHOD Ï4(show-clos-class :generate-itemÏ*) ()
  "Ï2Displays a class as an indented selection of component classes.  The amount of
 indentation is used to show which class a component is actually derived from.Ï*"
  (LET* ((class-name (class-name-safe data))
	 (all-components (class-components data))
	 text-items)
    (SETQ text-items
	  (collect-dependent-classes
	    class-name 1 all-components all-components))
    (VALUES
      `(,*blank-line-item*
	;Ï1; TAC 08-17-89 - removing pcl supportÏ*
	(;Ï1;Ï*(:font 1 ,(IF (iwmc-class-p-safe data) "Ï3PCL Class Ï*" "Ï3Class Ï*"))
	 (:font 1 "Ï3Class Ï*")
	 (:item1 instance ,(allocate-data 'show-clos-class data))
	 (:font 1 "Ï3's superclasses.  (Metaclass is Ï*")
	 (:item1 instance ,(allocate-data 'show-clos-class (class-of-safe data)))
	 (:font 1 "Ï3)Ï*")
	 )
	,*blank-line-item*
	;Ï1; For each component method, a mouse sensitive method name (METHOD-NAME)Ï*
	,@(OR text-items *no-items*))
      ;Ï1; Make the label display the class name.Ï*
      `(:font fonts:hl12bi :string
	      ,(FORMAT nil "Ï3~AÏ*" (class-pretty-name data))))))

(DEFUN Ï4collect-dependent-classesÏ* (class-name print-level all-components pointer)
"Ï2Takes a list of components of class-name and turns it into a set of display
 items for the inspector.  The structure of the list All-Components is used
 to compute the indentation required in the eventual display.  This code was
 cribbed from the flavor inspector so it's a bit obscure to me.  I never write
 loops as complicated as this.Ï*"
  (IGNORE class-name)
 `(,@(LOOP for mixin-entry in (SECOND pointer)
	   for mixin = (CAR mixin-entry)
	collect
	;Ï1; If this entry is the first mixin...Ï*
	`((,*space-format* ,print-level)
	  (:item1 instance
		  ,(show-a-class-named mixin)))
	append (collect-dependent-classes
		 mixin (+ 2 print-level) all-components mixin-entry))))

(DEFMETHOD Ï4(show-clos-class :helpÏ*) ()
"Ï2Gives a modicum of understanding to people seeing a normal class components
 display.Ï*"
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying a heirarchy of
CLOS classes which make up the class ~A.  Indentation is used to show the
origin of each component class.  Classes displayed along the left margin are
\"direct superclasses\" of class ~A.  Classes indented further from the left
margin are \"indirect superclasses\" of ~A, inherited from its direct
superclasses.

Special case:
     Often a class will have two or more components which all supply some
     class as an inherited superclass.  In these cases, the redundant
     superclasses are flagged in the displayed heirarchy with an asterisk
     (*) next to the class name.Ï*"
	    class-name class-name class-name)))

(DEFMETHOD Ï4(flavor-inspector :inspect-classÏ*) (object)
"Ï2A hook used by the inspect-flavor function to inspect a class rather than
 a flavor.Ï*"
  (LET ((thing (inspect-real-value
                 `(:value ,(allocate-data 'show-clos-class object) ,history))))
    ;Ï1; first flush item we will be inspectingÏ*
    (inspect-flush-from-history thing history)
    (SEND history :append-item thing)
    (update-panes)))

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

;Ï1;; Typein mode definitions for the class inspector.Ï*
;Ï1;; ================================================Ï*

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

;Ï1; In this section we define two main typein modes "Class-Names" andÏ*
;Ï1; "CLOS-Method-Specs".  These are a little confusing because, unlikeÏ*
;Ï1; flavors, we get multimethods and other things that are likely to confuse what Ï*
;Ï1; the user types.  This means that I've done some rather strange things here.Ï*
;Ï1; For instance, the Class-Names typein mode actually works for GFs as well.Ï*

;Ï1; What I wanted was to allow th user to type any of the following:Ï*

#||
     (class-name generic-function-name)
   or
     (class-name method-type generic-function-name)
   or
     (generic-function-name class-name)
   or
     (generic-function-name method-type class-name)
   or
     class-name generic-function-name
   or    
     class-name method-type generic-function-name
   or
     generic-function-name class-name
   or    
     generic-function-name method-type class-name

   the last four types of expressions are terminated by pressing the return key.
   method-type is one of the following:
     :after :before :case
||#

;Ï1; and then for the right thing to happen.  (I cribbed the above from the helpÏ*
;Ï1; on syntax string.  Hopefully this will explain some of the strangenessesÏ*
;Ï1; in the code below.Ï*

(DEFFLAVOR Ï4class-namesÏ* () (ucl:typein-mode)
  (:default-init-plist
   :auto-complete-p t)
  (:documentation
"Ï3A typein mode for class names.  Actually this works for generic function names as well.Ï*"))

(DEFMETHOD Ï4(class-names :complete-pÏ*) (syntax)
"Ï2Complete the class-names typein mode whenever you've got an atom to deal with.Ï*"
  (WHEN (MEMBER syntax '(:first-atom :function) :test #'EQ)
    "Ï3Class NamesÏ*"))

(DEFUN Ï4names-a-generic-functionÏ* (x)
"Ï2Is true if x is the name of a generic function.Ï*"
  (AND (SYMBOLP x) (FBOUNDP x) (generic-function-p-safe (SYMBOL-FUNCTION x))))

(DEFUN Ï4get-recognitionÏ* (word type all-class-names)
"Ï2Gets the recognition completion for a class.Ï*"
  (OR (MULTIPLE-VALUE-BIND (name pkg)
	  (w::separate-name-from-package word)
	(LET ((sym (FIND-SYMBOL (STRING-UPCASE name) (OR pkg *package*))))
	     ;Ï1;; We'll accept it if it's either a class name of a GF name.Ï*
	     (AND sym
		  (OR (class-named-safe sym t)
		      (names-a-generic-function sym))
		  (LIST sym))))
      ;Ï1; Prefer classes over generic-functions (is this a good idea?)Ï*
      ;Ï1; Look for class name completions.Ï*
      (w::get-word-completions word all-class-names)
      (IF (AND (ticlos-p)
		(NOT *cached-ticlos-class-names*))
           ;Ï1; We haven't got any all-class-names so try symbol completions for either a class or a GF name.Ï*
	   (w::get-symbol-completions
	     word type
	     #'(lambda (x)
		 (OR (class-named-safe x t) (names-a-generic-function x))))
	   ;Ï1; If all else fails just look for functions.Ï*
	   (w::get-symbol-completions
	     word type 'names-a-generic-function))))

(DEFUN Ï4get-aproposÏ* (word type all-class-names)
"Ï2Gets the apropos part of the class names completion.Ï*"
  (MULTIPLE-VALUE-BIND (name pkg)
    (w::separate-name-from-package word)
    (WHEN (PLUSP (LENGTH name))
      (UNLESS pkg
	(SETQ pkg *package*))
      (LET ((from-all-class-names
	      ;Ï1; Search through all known class names (usually nil) just to see if we can match.Ï*
	      (LOOP for class-name in all-class-names
		    when (AND (LET ((fnpkg (SYMBOL-PACKAGE class-name)))
				   (OR (EQ fnpkg pkg)
				       (MEMBER fnpkg (PACKAGE-USE-LIST pkg)
					       :test #'EQ)))
			      (SEARCH (THE string (STRING name))
				      (THE string (STRING class-name))
				      :test #'CHAR-EQUAL))
		    collect class-name)))
	   (APPEND (IF (AND (ticlos-p)
			    (NOT *cached-ticlos-class-names*))
		       ;Ï1; We didn't have any cached class names so look forÏ*
		       ;Ï1; symbol completions that name classes in this package.Ï*
		       (w::get-symbol-completions
			 word type #'(lambda (x) (class-named-safe x t)))
		       nil)
		   from-all-class-names
		   ;Ï1;; Look for symbol completions that name genericÏ*
		   ;Ï1;; functions in this package.Ï*
		   (w::get-symbol-completions
		     word type 'names-a-generic-function))))))

(DEFUN Ï4class-completeÏ* (word type)
"Ï2Completes a class spec.  This is a function, not a method so that it can be
 called from methods other than those built on class-names.  In all other
 respects it has the same contract as a normal :complete method for a
 typein mode.Ï*"
  (LET ((all-class-names (all-class-names)))
       (CASE type
	 (:recognition (get-recognition word type all-class-names))
	 (:apropos (get-apropos word type all-class-names))
	 (:spelling-corrected
	  (MULTIPLE-VALUE-BIND (name pkg)
	      (w::separate-name-from-package word)
	    (w::spell (INTERN name pkg) all-class-names))))))

(DEFMETHOD Ï4(class-names :completeÏ*) (word type)
"Ï2Completes a class name in the appropriate way for a typein mode.Ï*"
  (class-complete word type))

(DEFMETHOD Ï4(class-names :handle-typein-pÏ*) (expression type)
"Ï2A handle-typein-p method for class-names.  We want to handle typein if it looks
 like it might name a class or a GF.Ï*"
  (DECLARE (VALUES self=foundp not-found-message))
  (COND ((AND (MEMBER type '(first-atom atom symbol) :test #'EQ)
	      (SYMBOLP expression)
	      (OR (AND (class-named-safe expression t)
		       (is-a-class-name-not-flavor-class expression))
		  (names-a-generic-function expression)))
	 (VALUES self ()))
	((AND (SYMBOLP expression) (BOUNDP expression) expression)
	 (SEND self :handle-typein-p (SYMBOL-VALUE expression)
	       (TYPE-OF (SYMBOL-VALUE expression))))
	(t (VALUES () (FORMAT nil "Ï3~s is not a defined class Ï*" expression)))))

(DEFMETHOD Ï4(class-names :executeÏ*) (class-inspector)
"Ï2When we've successfully found a class (or GF) we want to inspect it.  The
 class has already been stashed in \"-\", so all we have to do is inspect the
 righ thing depending on whether it's a class or a GF.Ï*"
  (DECLARE (SPECIAL ucl::inhibit-results-print?))
  (IF (AND (SYMBOLP -) (BOUNDP -) - (SYMBOL-VALUE -))
      (SETQ - (SYMBOL-VALUE -)))
  (LET* ((history (SEND class-inspector :history))
	 (class
	  (inspect-real-value
	    (IF (class-named-safe - t)
	       `(:value ,(show-a-class-named -) ,history)
	       `(:value ,(allocate-data 'show-clos-generic-function-details
					(function-generic-function-safe
					  (SYMBOL-FUNCTION -))
					(function-generic-function-safe
					  (SYMBOL-FUNCTION -)))
			,history)))))
	 ;Ï1; might not work since not eqÏ*
    (inspect-flush-from-history class history)
    (SEND history :append-item class)
    (update-panes)
    ;Ï1; we don't want our result to be printed.Ï*
    (SETQ ucl::inhibit-results-print? t)))

(DEFMETHOD Ï4(class-names :arglistÏ*) (symbol)
"Ï2The arglist method for the class-names typein-mode.  Symbol might name either
 a class or a GF.  If it's a GF then we want the arglist, otherwise just say
 it's a class.Ï*"
  (IF (AND (SYMBOLP symbol) (names-a-generic-function symbol))
      (FORMAT nil "Ï3~SÏ*" (ARGLIST symbol))
      (IF (AND (SYMBOLP symbol) (class-named-safe symbol t))
	  (FORMAT nil "Ï3Class ~SÏ*" symbol)
	  (VALUES nil (FORMAT nil "Ï3~S is not a defined classÏ*" symbol)))))

(DEFPARAMETER Ï4class-namesÏ* (MAKE-INSTANCE 'class-names)
"Ï2The actual class-names typein mode instance.Ï*")

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

(DEFFLAVOR Ï4class-instanceÏ* () (ucl:typein-mode)
  (:default-init-plist
    :auto-complete-p t)
  (:documentation
"Ï3A typein mode for class instances.  I put this in because the flavex had one.
 I've never done anything with it.Ï*"))

(DEFMETHOD Ï4(class-instance :handle-typein-pÏ*) (expression type)
"Ï2I don't think that this is used.Ï*"
  (IF (AND (NOT (CONSP expression)) expression)
	   (IF (NOT (AND (SYMBOLP expression) (BOUNDP expression)))
	       (VALUES () (FORMAT nil "Ï3~s is not a defined classÏ*" expression))
	       (COND ((TYPEP (EVAL expression) 'any-sort-of-clos-instance)
		      (IF (AND (MEMBER type '(first-atom atom symbol)
				       :test #'EQ) (SYMBOLP expression)
			       (class-named-safe (TYPE-OF (EVAL expression)) t))
			  (VALUES self ())
			  (VALUES () (FORMAT nil "Ï3~s is not a defined class Ï*"
					     expression))))
		     ((AND (SYMBOLP expression) (BOUNDP expression) expression
			   (NOT (EQUAL expression (SYMBOL-VALUE expression)))
			   expression
		      )
		      (SEND self :handle-typein-p (SYMBOL-VALUE expression)
			    (TYPE-OF (SYMBOL-VALUE expression))))
		     (t (VALUES () (FORMAT nil "Ï3~s is not a defined classÏ*"
					   expression)))))  
	   (VALUES () (FORMAT nil "Ï3~s is not a defined classÏ*" expression))))

(DEFMETHOD Ï4(class-instance :executeÏ*) (class-inspector)
"Ï2I don't think that this is used.Ï*"
  (DECLARE (SPECIAL ucl::inhibit-results-print?))
  (IF (AND (SYMBOLP -) (BOUNDP -) - (SYMBOL-VALUE -))
      (SETQ - (SYMBOL-VALUE -)))
  (LET* ((history (SEND class-inspector :history)) 
	 (class
	  (inspect-real-value
		`(:value ,(show-a-class-named (TYPE-OF (EVAL -))) ,history))))
	 ;Ï1; Might not work since not EQÏ*
    (inspect-flush-from-history class history)
    (SEND history :append-item class)
    (update-panes)
    ;Ï1; we don't want our result to be printed.Ï*
    (SETQ ucl::inhibit-results-print? t)))

(DEFPARAMETER Ï4class-instanceÏ* (MAKE-INSTANCE 'class-instance))

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

(DEFFLAVOR Ï4clos-method-specsÏ* () (ucl:typein-mode)
  (:default-init-plist
    :auto-complete-p t)
  (:documentation "Ï3The typein mode that knows how to deal with clos methods.Ï*"))

(DEFMETHOD Ï4(clos-method-specs :complete-pÏ*) (syntax)
  "Ï2We want to complete pretty well anything.Ï*"
  (WHEN (EQ syntax :atom) "Ï3CLOS MethodsÏ*"))

(DEFVAR Ï4*clos-method-types*Ï*
   '(:after :before :around) ;Ï1; Should we really have :around???Ï*
"Ï2These are the types of method combination types that we're allowing in typein.
There may be others, but we don't know how to do them here.Ï*")

(DEFUN Ï4read-list-from-stringÏ* (STRING)
"Ï2We've got a string, which we'd like to read as the contents of a list, so
we just tack a pair of parens onto either end and read-from-string it.Ï*"
  (READ-FROM-STRING (STRING-APPEND "Ï3(Ï*" string "Ï3)Ï*") nil nil))

(defun-rh Ï4get-clos-method-expressionÏ* ()
"Ï2I cribbed this from the flavex.  God only knows what it's up to.  This rubout
 handler stuff is too much for me.Ï*"
  (LET* ((first-word-start (rh-word-start 1))
	 (first-word-end (rh-word-end first-word-start))
	 (second-word-start (rh-word-start (1+ first-word-end)))
	 (second-word-end
	   (MIN (rh-word-end second-word-start) (1- (rh-typein-pointer)))))
    (VALUES
      (READ-FROM-STRING
	(rh-substring-of-buffer first-word-start first-word-end))
      (READ-FROM-STRING
	(rh-substring-of-buffer second-word-start second-word-end))
      (UNLESS (= second-word-end (1- (rh-typein-pointer)))
	(rh-word-start (1+ second-word-end) t)))))

(DEFMETHOD Ï4(clos-method-specs :complete-for-gf-nameÏ*)
	   (word type class-name second-word more-than-two-words?)
"Ï2Completes Word as if it's a generic function defined on class Class-Name.
 If more-than-two-words? is specified then the user must have put in a
 :after specifier or some such.  Anyway, we try to complete the gf as being
 one of all of the gfs defined on the class.Ï*"
  (LET* ((class (class-named-safe class-name))
	 (gfs (AND class (all-clos-generic-function-names-for-class class)))
	 (all
	  (IF class
	      (IF more-than-two-words?
		  (IF (MEMBER second-word *clos-method-types* :test #'EQ)
		      gfs
		      nil)
		  (APPEND *clos-method-types* gfs))
	      nil)))
        (WHEN class
	  (LOOP for completion in
	     (CASE type
	       (:recognition (w::get-word-completions word all))
	       (:apropos (w::list-apropos (SUBSEQ word 1) all :dont-print t))
	       (:spelling-corrected (w::spell word all)))
	     collect (ucl::first-if-list completion)))))

(DEFMETHOD Ï4(clos-method-specs :completeÏ*) (word type)
"Ï2Completes a clso-method-spec typein.  The user is allowed to type the class
 name at the beginning or the end, so we complete for a GF if we've already
 got a class, otherwise we complete for a class.Ï*"
  (MULTIPLE-VALUE-BIND (class-name second-word more-than-two-words?)
    (SEND *standard-input* :funcall-inside-yourself
	  (FUNCTION get-clos-method-expression))
    (IF (class-named-safe class-name t)
	(SEND self :complete-for-gf-name word type
	      class-name second-word more-than-two-words?)
	(IF (names-a-generic-function class-name)
	    (class-complete
	      (IF more-than-two-words? more-than-two-words? second-word) type)
	    (FERROR nil "Ï3~S is neither a class name or a generic function.Ï*"
		    class-name)))))

(DEFUN Ï4get-method-matchesÏ* (specialisations combination)
"Ï2Is passed the list of methods for a particular GF that are specialised by the
 class in question.  If Combination is specified, then this must match with
 the method, otherwise the method is OK.Ï*"
  (REMOVE-IF
    #'(lambda (meth)
	(AND combination
	     (NOT (MEMBER
		   combination
		   (FUNCTION-NAME (method-function-safe meth))))))
      (REMOVE nil specialisations)))

(DEFUN Ï4maybe-find-clos-methodÏ* (methods combination class failure-string)
"Ï2Given a list of methods, a combination arg (:after eg, but can be nil), a class
 and a string to return if it fails to find a match, looks at the methods for
 matches with the class as a specialiser.  If it finds multiple matches then
 it loops through asking the user which one to use.Ï*"
  (LET ((specialisations
	 (MAPCAR #'(lambda (method) (is-specialised-by-components method class))
		 methods)))
       (LET ((matches (get-method-matches specialisations combination)))
	    (IF (REST matches)
		(LET ((meth (FIND-IF
			      #'(lambda (x)
				  (Y-OR-N-P "Ï3~&Do you mean ~S?Ï*"
				    (FUNCTION-NAME (method-function-safe x))))
				matches)))
		     (IF meth
			 (VALUES self nil meth)
			 (VALUES nil failure-string)))
		(IF matches
		    (VALUES self nil (FIRST matches))
		    (VALUES nil failure-string))))))

(DEFMETHOD Ï4(clos-method-specs :handle-typein-pÏ*) (expression type)
"Ï2Should we handle typein for this method spec?.  Try to read it as a method
 name.Ï*"
  (SEND self :read-a-method-name expression type))

(DEFMETHOD Ï4(clos-method-specs :read-a-method-nameÏ*) (expression type)
"Ï2Tries to read expression as a method spec.  Expression could be of the form
 (class :comb GF), (class GF), (GF :comb class) or (GF class), so we have to
 jiggle around a bit figuring out which one it is.  If we know we've got both
 a class and a GF name we can go ahead and look for a method match.Ï*"
  (IF (NOT (CONSP expression))
      (IF (AND (SYMBOLP expression) (BOUNDP expression))
	  (IF (CONSP (SYMBOL-VALUE expression))
	      (SETQ expression
		    (CDR (SYMBOL-VALUE expression)) type ':implicit-list)
	      (SETQ expression (SYMBOL-VALUE expression)))))
  (WHEN (MEMBER type '(:implicit-list cons) :test #'EQ)
    (LET ((combination (AND (THIRD expression) (SECOND expression)))
	  (fname (IF (class-named-safe (FIRST expression) t)
		     (OR (THIRD expression) (SECOND expression))
		     (FIRST expression)))
	  (class (IF (class-named-safe (FIRST expression) t)
		     (FIRST expression)
		     (class-named-safe
		       (OR (THIRD expression) (SECOND expression)) t)))
	  (str (FORMAT ()
		 "Ï3No method supplied.  Press META- for correct syntax.Ï*")))
         (LET ((methods
		 (IF (AND (names-a-generic-function fname))
		     (generic-function-methods-safe
			(function-generic-function-safe (SYMBOL-FUNCTION fname)))
		     nil)))
	      (IF (AND class methods)
		  (MULTIPLE-VALUE-BIND (val ok-p meth)
		      (maybe-find-clos-method
			methods combination
			(class-named-safe class t) str)
		    (IF (NOT ok-p) (SETQ - (LIST class meth)) nil)
		    (VALUES val ok-p (IF ok-p (LIST class meth) nil)))
		  (VALUES () str))))))

(DEFMETHOD Ï4(clos-method-specs :executeÏ*) (flavor-inspector)
"Ï2Having got a method spec read in we want to inspect the method for it.  We
 previously stashed the method that we found in \"-\", so we can simply go ahead
 and inspect the method as a show-clos-method-details.Ï*"
  (DECLARE (SPECIAL ucl::inhibit-results-print?))
  (IF (AND (SYMBOLP -) (BOUNDP -))
      (SETQ - (CDR (SYMBOL-VALUE -))))
  (LET* ((history (SEND flavor-inspector :history))
	 (method
	  (inspect-real-value
	   `(:value
	     ,(allocate-data 'show-clos-method-details (FIRST -) (SECOND -))
	     ,history))))
    (inspect-flush-from-history method history)
    (SEND history :append-item method)
    (update-panes)
    ;Ï1; We don't want our result to be printed.Ï*
    (SETQ ucl::inhibit-results-print? t)))

(DEFMETHOD Ï4(clos-method-specs :arglistÏ*) (symbol)
"Ï2Gets the arglist for a clos method that has been typed in.  This is just like
 reading one in for completion/execution, only once we've read it in we print
 out the arglist.Ï*"
  (IGNORE symbol)
  (WHEN (VARIABLE-BOUNDP ucl::command-loop-typein?)
    (MULTIPLE-VALUE-BIND (class-name second-word more-than-two-words?)
	(SEND (SEND ucl::command-loop-typein? :user) :funcall-inside-yourself
	      (FUNCTION get-clos-method-expression))
      (MULTIPLE-VALUE-BIND (IGNORE ok-p meth)
	  (SEND self :read-a-method-name
		`(,class-name ,second-word
		  ,@(IF more-than-two-words? (LIST more-than-two-words?) nil))
		:implicit-list)
	(IF (AND ok-p meth)
	    (MULTIPLE-VALUE-BIND (args ret) (method-arglist-safe meth)
	      (LET ((name (FUNCTION-NAME (method-function-safe meth))))
		   (VALUES
		     (IF ret
			 (FORMAT nil "Ï3~S ~S Ý ~SÏ*" name args ret)
			 (FORMAT nil "Ï3~S ~SÏ*" name args))
		     nil)))
	    (VALUES () "Ï3Not a defined methodÏ*"))))))

(DEFPARAMETER Ï4clos-method-specsÏ* (MAKE-INSTANCE 'clos-method-specs)
"Ï2This is the actual variable to hold the clos-method-specs typein-mode
 instance.Ï*")

(DEFCOMMAND Ï4(flavor-inspector :help-on-syntaxÏ*) ()
  '(:names ("Ï3Syntax HelpÏ*")
    :keys #\Meta-help
    :description "Ï3Prints help on the processing of typed expressions.Ï*")
  (DECLARE (SPECIAL frame))
  (LET ((window (assure-is-a-frame frame)))
  (si:with-help-stream
    (window :label "Ï3DocumentationÏ*" :superior window)
  ;Ï1; Ï*(SEND self :format-message
	(FORMAT window "
Ï3You may type any of the following expressions:
~A
-- a flavor name to inspect, terminated by pressing the RETURN key
-- a method specification to inspect.  The syntax is
     (Flavor-Name Method-Name)
   or
     (Flavor-Name Method-Type Method-Name)
   or
     Flavor-Name Method-Name
   or    
     Flavor-Name Method-Type Method-Name

   The last two types of expressions are terminated by pressing the RETURN key.
   Method-Type is one of the following:
     :AFTER :AND :AROUND :BEFORE :CASE :DEFAULT :OR :OVERRIDE :WRAPPER

While typing these expressions, you may press the SPACE Bar to complete a ~A
flavor or method name.  You may also use the Input Editor completion commands
summarized below:

   CTRL-ESCAPE  -- Recognition Completion (same as the SPACE Bar)
   CTRL-\/       -- List Recognition Completions
   SUPER-ESCAPE -- Apropos Completions (complete word as an inner substring)
   SUPER-\/      -- List Apropos Completions
   HYPER-ESCAPE -- Spelling Corrected Completion (corrects minor typos)
   HYPER-\/      -- List Spelling Corrected CompletionsÏ*"

;Ï1; value for ~A follows Ï*
		(IF (clos-p)
		    "Ï3For CLOS input:

-- a class name to inspect, terminated by pressing the RETURN key
-- a method specification to inspect.  The syntax is
     (Class-Name Generic-Function-Name)
   or
     (Class-Name Method-Type Generic-Function-Name)
   or
     (Generic-Function-Name Class-Name)
   or
     (Generic-Function-Name Method-Type Class-Name)
   or
     Class-Name Generic-Function-Name
   or    
     Class-Name Method-Type Generic-Function-Name
   or
     Generic-Function-Name Class-Name
   or    
     Generic-Function-Name Method-Type Class-Name

   The last four types of expressions are terminated by pressing the RETURN key.
   Method-Type is one of the following:
     :AFTER :BEFORE :CASE

For Flavors input: Ï*
"
		    "")
		))) )

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

(DEFUN Ï4flavor-or-class-nameÏ* (something)
"Ï2Returns the flavor name of a flavor or the class name of a class.Ï*"
  (IF (TYPEP something 'si::flavor)
      (si::flavor-name something)
      (IF (AND (clos-p) (TYPEP something 'any-sort-of-clos-instance))
	  (class-name-safe something)
	  (FERROR nil "Ï3~S is not a flavor or a class.Ï*"))))

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

(DEFFLAVOR Ï4show-component-classesÏ* () (class-operation-mixin)
  (:documentation "Ï3A show-x flavor that shows the superclasses of a class in
 a flat manner.Ï*"))

(DEFMETHOD Ï4(show-component-classes :format-conciselyÏ*) (STREAM)
"Ï2Just print it out simply.Ï*"
  (FORMAT stream "Ï3~ý's superclassesÏ*"
	(LIST (allocate-data 'show-clos-class data)
	      nil (class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-component-classes :middle-button-resultÏ*) ()
"Ï2When we get middle buttoned on we should return the class itself.Ï*"
  data)

(DEFMETHOD Ï4(show-component-classes :generate-itemÏ*) ()
  (LET* ((component-classes (CDR (class-precedence-list-safe data))))
    (VALUES
     `(,*blank-line-item*
       ("Ï3Superclasses of class Ï*"
        (:item1 instance ,(allocate-data 'show-clos-class data))
        "Ï3:Ï*")
       ,*blank-line-item*
       ,@(OR
	  (LOOP for component in component-classes
                collect
		`(,*one-space-item*
		  (:item1 instance
			  ,(allocate-data 'show-clos-class component))))
	  *no-items*))
     `(:font fonts:hl12bi :string
	     ,(FORMAT nil "Ï3~A's superclassesÏ*" (class-pretty-name data))))))  

(DEFMETHOD Ï4(show-component-classes :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying the superclasses
which make up the class ~A.  The display does not show the class heirarchy;
for a look at the class heirarchy, type ~A followed by RETURN to the
Flavor/Class/Method prompt, or click L on any mouse sensitive display of ~A
in the Inspector.

This display is useful when you are not interested in examining the class
heirarchy but are instead interested in seeing the resultant superclasses
of a class.Ï*"
	    class-name class-name class-name)))

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

(DEFFLAVOR Ï4show-dependent-classesÏ* () (class-operation-mixin)
  (:documentation "Ï3A show-x flavor that shows the subclasses of a class in
 a flat manner.Ï*"))

(DEFMETHOD Ï4(show-dependent-classes :middle-button-resultÏ*) ()
"Ï2When we get middle buttoned on we should return the class itself.Ï*"
  data)

(DEFMETHOD Ï4(show-dependent-classes :format-conciselyÏ*) (STREAM)
"Ï2Just print it out simply.Ï*"
 (FORMAT stream "Ï3~ý's subclassesÏ*"
	 (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-dependent-classes :generate-itemÏ*) ()
"Ï2I cribbed this method from the flavor inspector.  I seems to work but it's full
 of all this with-recursion stuff which seems hairy to me.  Anyway, if it works,
 don't touch it - right?...Ï*"
  (LET* ((class-name (class-pretty-name data)))
    (VALUES
     `(,*blank-line-item*
       ((:font 1
	  "Ï3Heirarchy of classes directly or indirectly dependent on class Ï*")
	(:item1 instance ,(allocate-data 'show-clos-class data))
        "Ï3:Ï*")
       ,*blank-line-item*
       ,@(LET (items
	       classes)
	   (with-recursion
	     ((dependent-classes indentation)
	      (class-direct-subclasses-safe data) 0)
	    (DOLIST (dependent-class dependent-classes)
	      ;Ï1;; Commented out by JPR on 3/30/89.  This doesn'tÏ*
	      ;Ï1;; seem right.Ï*
	      (UNLESS nil;Ï1(member dependent-class classes :test #'eq)Ï*
		(PUSH dependent-class classes)
		(PUSH-END
		 `((,*space-format* ,(1+ (* 2 indentation)))
		   (:item1 instance
			   ,(allocate-data 'show-clos-class dependent-class)))
		 items))
	      (recurse (class-direct-subclasses-safe dependent-class)
		       (1+ indentation))))
	   items))
     `(:font fonts:hl12bi :string
	     ,(FORMAT nil "Ï3~A's subclassesÏ*" class-name)))))

(DEFMETHOD Ï4(show-dependent-classes :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying a heirarchy
of classes which depend on class ~A (i.e. they have ~A as a superclass).
Indentation is used to show the origin of each dependency.  Classes displayed
along the left margin are \"direct subclasses\" of class ~A.
Classes indented further from the left margin are \"indirect subclasses\" of
~A, inheriting it from the classes displayed above and to the left of them.Ï*"
	    class-name class-name class-name class-name)))

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

(DEFFLAVOR Ï4show-local-clos-methodsÏ* () (class-operation-mixin)
  (:documentation "Ï3Shows the methods defined locally on a class, i.e. the
 methods that use the class specifically as a specializer.Ï*"))

(DEFMETHOD Ï4(show-local-clos-methods :format-conciselyÏ*) (STREAM)
"Ï2Just print it out simply.Ï*"
 (FORMAT stream "Ï3~ý's local methodsÏ*"
	 (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-local-clos-methods :middle-button-resultÏ*) ()
"Ï2When we get middle buttoned on we should return the class itself.Ï*"
  data)

(DEFUN Ï4collect-clos-method-itemsÏ*
       (method-table
	&optional (predicate #'(lambda (element) (IGNORE element) t)))
"Ï2Collects a list of inspect items for the methods in method-table.  Predicate
 is used to filter the list.  This was sort of abstracted out of an extremely
 magic macro in the flavex, which I didn't understand, so I made a (simple?)
 function to do what I wanted.Ï*"
  (LOOP for method in method-table
	when (FUNCALL predicate method)
	collect `((:item1 instance ,(allocate-data 'show-clos-method method)))
	into .collection.
	finally (RETURN .collection. nil)))

(DEFVAR Ï4*clos-method-display-columns*Ï*
   `((:font 2 ,(FORMAT nil "Ï3~40A~15A~15AÏ*" "Ï3MethodÏ*" "Ï3CombinationÏ*" "Ï3ArglistÏ*")))
"Ï2The column headers for displaying clos methods.Ï*") 


(DEFUN Ï4sort-clos-methodsÏ* (methods)
"Ï2Sorts the list of method items for the inspector into (sort of) alpha order.Ï*"
  (SORT (COPY-LIST methods)
	#'(lambda (x y)
	    (STRING-LESSP (princ-method x nil) (princ-method y nil)))))

(DEFMETHOD Ï4(show-local-clos-methods :generate-itemÏ*) ()
  (LET* (;Ï1; Sort for readability.  There might be a better place to do the sort,Ï*
	 ;Ï1; for instance, always maintain a sorted entry for SHOW-METHOD in *INSPECTION-DATA*.Ï*
	 (method-table (sort-clos-methods (class-direct-methods-safe data))))
    (MULTIPLE-VALUE-BIND (items special-comb?)
	  (collect-clos-method-items method-table)
      (VALUES
       `(,*blank-line-item*
	 ((:font 1 "Ï3Methods defined for class Ï*")
	  (:item1 instance ,(allocate-data 'show-clos-class data))
	  (:font 1 ,(IF special-comb?
		      "Ï3.  * = special method combination typeÏ*"
		      "Ï3:Ï*")))
	  ;Ï1;Collect the methods, excluding any GET and SET methods, which weÏ*
	  ;Ï1;want to list separately (for readability).Ï*
	 ,@(IF items
	     (CONS *clos-method-display-columns* items)
	     *no-items*))
       `(:font fonts:hl12bi :string
	       ,(FORMAT () "Ï3~A's local methodsÏ*" (class-pretty-name data)))))))

(DEFMETHOD Ï4(show-local-clos-methods :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying all of the methods
local to ~A.  Local methods are methods that are defined ,which have the class
~A as one of their specializers.Ï*"
	    class-name class-name)))

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

(DEFFLAVOR Ï4show-local-clos-generic-functionsÏ*
	   ()
	   (class-operation-mixin)
  (:documentation "Ï3Shows the generic functions that name the local methods for
 the data class.Ï*"))

(DEFMETHOD Ï4(show-local-clos-generic-functions :middle-button-resultÏ*) ()
"Ï2Just returns the class when we get middle buttoned on.Ï*"
  data)

(DEFMETHOD Ï4(show-local-clos-generic-functions :format-conciselyÏ*) (STREAM)
"Ï2A simple concise format method.  Nothing special here.Ï*"
 (FORMAT stream "Ï3~ý's local generic functionsÏ*"
	 (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFUN Ï4collect-clos-generic-function-itemsÏ*
       (function-table
	&optional (predicate #'(lambda (element) (IGNORE element) t)))
"Ï2Builds up an item list for the generic functions of a clos class, given a
 list of the generic functions.  Predicate is used to filter out the ones that
 we don't need.Ï*"
  (LOOP for generic-function in function-table
	when (FUNCALL predicate function-table)
	collect `((:item1 instance
		   ,(allocate-data 'show-clos-generic-function
				   generic-function)))
	into .collection.
	finally (RETURN .collection. nil)))

(DEFVAR Ï4*clos-generic-function-display-columns*Ï*
	`((:font 2 ,(FORMAT nil "Ï3~58A~15AÏ*" "Ï3FunctionÏ*" "Ï3ArglistÏ*")))
"Ï2An item used as a header for lists of generic functions.  The magic numbers
 are the tab positions of headings.  These are somewhat sensitive to the)
 fonts being used.Ï*") 

(DEFUN Ï4sort-clos-generic-functionsÏ* (generic-functions)
"Ï2Sorts a list of generic functions so that they are in sort of alpha order.Ï*"
  (SORT (COPY-LIST generic-functions)
	#'(lambda (x y)
	    (STRING-LESSP (princ-generic-function x nil)
			  (princ-generic-function y nil)))))

(DEFMETHOD Ï4(show-local-clos-generic-functions :generate-itemÏ*) ()
"Ï2Generates the inspector item list for the display of local generic fucntions.Ï*"
  (LET* ((class-name (class-pretty-name data))
	 ;Ï1;Sort for readability.  There might be a better place to do theÏ*
	 ;Ï1;sort; for instance, always maintain a sorted entry for SHOW-METHODÏ*
	 ;Ï1;in *INSPECTION-DATA*.Ï*
	 (function-table
	   (sort-clos-generic-functions
	     (class-direct-generic-functions-safe data))))
    (MULTIPLE-VALUE-BIND (items special-comb?)
      (collect-clos-generic-function-items function-table)
      (VALUES
       `(,*blank-line-item*
	 ((:font 1 "Ï3Generic-functions defined for class Ï*")
	  (:item1 instance ,(allocate-data 'show-clos-class data))
	  (:font 1 ,(IF special-comb?
		      "Ï3.  * = special method combination typeÏ*"
		      "Ï3:Ï*")))
	 ,@(IF items
	     (CONS *clos-generic-function-display-columns* items)
	     *no-items*))
       `(:font fonts:hl12bi :string
	       ,(FORMAT () "Ï3~A's local generic-functionsÏ*" class-name))))))

(DEFMETHOD Ï4(show-local-clos-generic-functions :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying all of the generic
functions local to ~A.  Local generic functions are the generic functions that
are associated with the class's local methods; methods ,which have the class
~A as one of their specializers.Ï*"
	    class-name class-name)))

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

(DEFFLAVOR Ï4show-all-clos-methodsÏ* () (class-operation-mixin)
  (:documentation
"Ï3Shows all of the CLOS methods associated with a class.  The display is
 separated to show the different methods provided by the different
 superclasses of Data.Ï*"))

(DEFMETHOD Ï4(show-all-clos-methods :format-conciselyÏ*) (STREAM)
"Ï2Just a simple print method.  Nothing special here.Ï*"
 (FORMAT stream "Ï3~ý's methods (all)Ï*"
         (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-all-clos-methods :middle-button-resultÏ*) ()
"Ï2Returns the class itself when we get middle buttoned on.Ï*"
  data)

(DEFMETHOD Ï4(show-all-clos-methods :generate-itemÏ*) ()
"Ï2Builds the item list for the display of all of the methods for a given class.
 The display is split up so that the methods contributed by each component
 superclass are shown in separate groups.  This is done in a magic loop that
 I cribbed from the flavor inspector.Ï*"
  (VALUES
    (APPEND
      (COPY-LIST (SEND (allocate-data 'show-local-clos-methods data)
		       :generate-item))
      (LOOP with top-class-method-table
	    = (sort-clos-methods (class-direct-methods-safe data))
	    for class in (REST (class-precedence-list-safe data))
	    for class-name = (class-name-safe class)
	    for method-table
	        = (COPY-LIST (class-direct-methods-safe class data))
	    when method-table
	    append (MULTIPLE-VALUE-BIND (items special-com?)
		      (collect-clos-method-items method-table
			 #'(lambda (element)
			     (IF (MEMBER element top-class-method-table
					 :test #'EQ)
				 nil
				 (PROGN (PUSH element top-class-method-table)
					t))))
		     (IF items
		    `(,*blank-line-item*
		      ,*blank-line-item*
		      ((:font 1 "Ï3Methods inherited from class Ï*")
		       (:item1 instance ,(allocate-data 'show-clos-class class))
		       (:font 1 ,(IF special-com?
				     "Ï3.  * = special method combination typeÏ*"
				     "Ï3:Ï*")))
		      ,@(IF items
			    (CONS *clos-method-display-columns* items)
			    *no-items*))
		    nil))))
      `(:font fonts:hl12bi :string
	      ,(FORMAT nil "Ï3~A's methods (all)Ï*" (class-pretty-name data)))))


(DEFMETHOD Ï4(show-all-clos-methods :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying all methods
defined for or inherited by class ~A.  The methods are presented under section
headers which indicate which component class of ~A provides them.  ~A's local
methods are displayed in the first section; subsequent sections are ordered
according to precedence in ~A's class heirarchy.Ï*"
	    class-name class-name class-name class-name)))


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

(DEFFLAVOR Ï4show-all-clos-methods-sortedÏ* () (class-operation-mixin)
  (:documentation
"Ï3Shows all of the CLOS methods defined for a given class all lumped together
 in one, sorted bunch.  This is different from the show-all-clos-methods, in
 which the methods for each superclass are shown separately
 (though also sorted).Ï*"))

(DEFMETHOD Ï4(show-all-clos-methods-sorted :middle-button-resultÏ*) ()
"Ï2Just returns the class itself.Ï*"
  data)

(DEFMETHOD Ï4(show-all-clos-methods-sorted :format-conciselyÏ*) (STREAM)
"Ï2Nothing magical here.  Just prints the class name out a little cleverly.Ï*"
 (FORMAT stream "Ï3~ý's methods (sorted)Ï*"
         (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFVAR Ï4*clos-method-display-columns-2*Ï*
  `((:font 2 ,(FORMAT nil "Ï3~40A~15A~15AÏ*" "Ï3MethodÏ*" "Ï3CombinationÏ*" "Ï3ArglistÏ*")))
"Ï2This is the item that puts a heading on the display of clos methods for a
 class.  The magic numbers tab the headings appropriately.  They are a bit
 sensitive to the fonts being used.  Maybe I should rewrite these to do some
 fancy sheet-compute-motion calculations.  Groan.  Life is too short.Ï*")

(DEFUN Ï4all-clos-method-items-for-classÏ* (the-class)
"Ï2Given a class returns the item list for all of the clos methods associated
 with it.  It does this for all of the classes in the class precedence list.Ï*"
  (LET ((special-comb? nil)
	(so-far nil))
       (VALUES
	  (LOOP for class in (class-precedence-list-safe the-class)
		for class-name = (class-name-safe class)
		for method-table
		    = (SET-DIFFERENCE
			(class-direct-methods-safe class the-class)
			so-far)
		do (SETQ so-far (APPEND method-table so-far))
		append (MULTIPLE-VALUE-BIND (items comb?)
			   (collect-clos-method-items method-table)
			 (WHEN comb?
			   (SETQ special-comb? t))
			 items))
	  special-comb?)))

(DEFUN Ï4princ-methodÏ* (method stream)
"Ï2Prints Method to Stream.  It does so in a manner different from the method's
 normal printed representation.  It shows the class of the method too.Ï*"
  (LET ((generic-function (method-generic-function-safe method))
	(class-name (STRING-CAPITALIZE (class-name-safe (class-of-safe method)))))
       (FORMAT stream "Ï3~A ~S ~:SÏ*"
	       class-name
	       (AND generic-function (fast-gf-name method))
	       (unparse-specializers-safe method))))

(DEFUN Ï4fast-gf-nameÏ* (method)
  (SECOND (FUNCTION-NAME (method-function-safe method))))

(DEFUN Ï4method-lessp-1Ï* (x y)
"Ï2Is true if the printed representation of x is string-lessp than y.Ï*"
  (LET ((gfx (FORMAT nil "Ï3~SÏ*" (fast-gf-name x)))
	(gfy (FORMAT nil "Ï3~SÏ*" (fast-gf-name y))))
       (OR (STRING-LESSP gfx gfy)
	   (AND (STRING-EQUAL gfx gfy)
		(MULTIPLE-VALUE-BIND (specx combx) (unparse-specializers-safe x)
		  (MULTIPLE-VALUE-BIND (specy comby)
		      (unparse-specializers-safe y)
		    (LET ((namex (FORMAT nil "Ï3~SÏ*" specx))
			  (namey (FORMAT nil "Ï3~SÏ*" specy)))
		         (OR (STRING-LESSP namex namey)
			     (AND (STRING-EQUAL namex namey)
				  (STRING-LESSP (FORMAT nil "Ï3~SÏ*" combx)
						(FORMAT nil "Ï3~SÏ*" comby)))))))))))
(DEFUN Ï4method-lesspÏ* (x y)
"Ï2Is true if the printed representation of x is string-lessp than y.Ï*"
  (STRING-LESSP (princ-method (SEND (THIRD (FIRST x)) :data) nil)
		(princ-method (SEND (THIRD (FIRST y)) :data) nil)))

(DEFUN Ï4princ-generic-functionÏ* (generic-function stream)
"Ï2Prints Generic function to Stream.  It does so in a manner different from
 the generic function's normal printed representation.  It shows the class
 of the generic function too.Ï*"
  (FORMAT stream "Ï3~SÏ*"
	  (LET ((name
		  (SECOND (FUNCTION-NAME
			    (method-function-safe
			      (FIRST (generic-function-methods-safe
				       generic-function)))))))
	       (IF (AND (CONSP name) (EQUAL :internal (FIRST name)))
		   ;Ï1;; Special case for PCL. Ï* 
		   ;Ï1; TAC 08-17-89 - removing pcl support, not sure which part the comment aboveÏ*
                   ;Ï1; is for,  but neither should hurt usÏ*
		   (generic-function-name-safe generic-function)
		   name))))

(DEFUN Ï4gf-lesspÏ* (x y)
"Ï2Is true if the printed representation of x is string-lessp than y.Ï*"
  (STRING-LESSP (princ-generic-function (SEND (THIRD (FIRST x)) :data) nil)
		(princ-generic-function (SEND (THIRD (FIRST y)) :data) nil)))

(DEFMETHOD Ï4(show-all-clos-methods-sorted :generate-itemÏ*) ()
"Ï2Generates the inspector item list for the display of all of the methods for
 a class all grouped together and sorted.Ï*"
  (VALUES
    (MULTIPLE-VALUE-BIND
      (items special-comb?) (all-clos-method-items-for-class data)
      `(,*blank-line-item*
	((:font 1 "Ï3All Methods of class Ï*")
	 (:item1 instance ,(allocate-data 'show-clos-class data))
	 (:font 1
	     ,(IF special-comb? "Ï3.  * = special method combination typeÏ*" "Ï3:Ï*")))
	,*blank-line-item*
	,*clos-method-display-columns-2*
	,@(SORT items #'method-lessp)))
    `(:font fonts:hl12bi :string ,(FORMAT nil "Ï3~A's methods (sorted)Ï*"
					  (class-pretty-name data))))) 

(DEFMETHOD Ï4(show-all-clos-methods-sorted :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying all methods
defined for or inherited by class ~A.  The methods are sorted alphabetically
by generic function name and method type.  (The \"All Methods\" option provides
a more organized display of the methods.)Ï*"
	    class-name)))

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

(DEFFLAVOR Ï4show-all-clos-generic-functionsÏ* () (class-operation-mixin)
  (:documentation
"Ï3Shows all of the generic functions associated with a class.  These are the GFs
 that name the methods defined on the class and its superclasses.  The display
 is separated to show the different GFs provided by the different
 superclasses of Data.Ï*"))

(DEFMETHOD Ï4(show-all-clos-generic-functions :middle-button-resultÏ*) ()
"Ï2Returns the class itself when we get middle buttoned on.Ï*"
  data)

(DEFMETHOD Ï4(show-all-clos-generic-functions :format-conciselyÏ*) (STREAM)
"Ï2Just a simple print method.  Nothing special here.Ï*"
 (FORMAT stream "Ï3~ý's generic functions (all)Ï*"
	 (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-all-clos-generic-functions :generate-itemÏ*) ()
"Ï2Builds the item list for the display of all of the generic functions for
 a given class.  The display is split up so that the GFs contributed by
 each component superclass are shown in separate groups.  This is done
 in a magic loop that I cribbed from the flavor inspector.Ï*"
  (VALUES
    (APPEND
      (COPY-LIST (SEND (allocate-data 'show-local-clos-generic-functions data)
		       :generate-item))
      (LOOP with top-class-generic-function-table
	    = (COPY-LIST (class-direct-generic-functions-safe data))
	    ;Ï1;Modded here by JPR.Ï*
	    for class in (REST (class-precedence-list-safe data))
	    for class-name = (class-name-safe class)
	    for generic-function-table =
	        (sort-clos-generic-functions
		  (class-direct-generic-functions-safe class))
	    when generic-function-table
	    append (MULTIPLE-VALUE-BIND (items special-com?)
		      (collect-clos-generic-function-items
			generic-function-table
			 #'(lambda (element)
			     (IF (MEMBER element
					 top-class-generic-function-table
					 :test #'EQ)
				 nil
				 (PROGN (PUSH element
					      top-class-generic-function-table)
					t))))
		     (IF items
		    `(,*blank-line-item*
		      ,*blank-line-item*
		      ((:font 1 "Ï3Generic functions inherited from class Ï*")
		       (:item1 instance ,(allocate-data 'show-clos-class class))
		       (:font 1 ,(IF special-com?
			     "Ï3.  * = special generic function combination typeÏ*"
				     "Ï3:Ï*")))
		      ,@(IF items
			    (CONS *clos-generic-function-display-columns* items)
			    *no-items*))
		    nil))))
      `(:font fonts:hl12bi :string
	      ,(FORMAT nil "Ï3~A's generic functions (all)Ï*"
		       (class-pretty-name data)))))

(DEFMETHOD Ï4(show-all-clos-generic-functions :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying all generic
functions associated with methods defined for or inherited by class ~A.  
The generic-functions are presented under section headers which indicate which
component class of ~A provides them.  ~A's local generic functions are displayed
in the first section; subsequent sections are ordered according to precedence
in ~A's class heirarchy.Ï*"
	    class-name class-name class-name class-name)))

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

(DEFFLAVOR Ï4show-all-clos-generic-functions-sortedÏ* () (class-operation-mixin)
  (:documentation
"Ï3Shows all of the Generic Functions defined for a given class all
 lumped together in one, sorted bunch.  This is different from the
 show-all-clos-generic-functions, in which the GFs for each superclass
 are shown separately (though also sorted).Ï*"))

(DEFMETHOD Ï4(show-all-clos-generic-functions-sorted :middle-button-resultÏ*) ()
"Ï2Just returns the class itself.Ï*"
  data)

(DEFMETHOD Ï4(show-all-clos-generic-functions-sorted :format-conciselyÏ*) (STREAM)
"Ï2Nothing magical here.  Just prints the class name out a little cleverly.Ï*"
 (FORMAT stream "Ï3~ý's generic functions (sorted)Ï*"
         (LIST (allocate-data 'show-clos-class data) nil
	       (class-pretty-name data (in-history-window-p stream)))))

(DEFVAR Ï4*clos-generic-function-display-columns-2*Ï*
	`((:font 2 ,(FORMAT nil "Ï3~58A~15AÏ*" "Ï3FunctionÏ*" "Ï3ArglistÏ*")))
"Ï2This is the item that puts a heading on the display of Generic Functions for a
 class.  The magic numbers tab the headings appropriately.  They are a bit
 sensitive to the fonts being used.  Maybe I should rewrite these to do some
 fancy sheet-compute-motion calculations.  Groan.  Life is too short.Ï*") 

(DEFUN Ï4all-clos-generic-functions-for-classÏ* (the-class)
"Ï2Given a class returns all of the generic functions associated with it.
 It does this for all of the classes in the class precedence list.Ï*"
  (LET ((so-far nil))
       (LOOP for class in (class-precedence-list-safe the-class)
	     for class-name = (class-name-safe class)
	     for generic-function-table
		 = (SET-DIFFERENCE (class-direct-generic-functions-safe class)
				   so-far)
	     do (SETQ so-far (APPEND generic-function-table so-far)))
       so-far))

(DEFUN Ï4all-clos-generic-function-names-for-classÏ* (the-class)
"Ï2Returns a list of the names of all of the GFs fot The-Class.Ï*"
  (MAPCAR #'generic-function-name-safe
	  (all-clos-generic-functions-for-class the-class)))

(DEFUN Ï4all-clos-generic-function-items-for-classÏ* (the-class)
"Ï2Given a class returns the item list for all of the generic functions associated
 with it.  It does this for all of the classes in the class precedence list.Ï*"
  (LET ((special-comb? nil)
	(so-far nil))
       (VALUES
	 (LOOP for class in (class-precedence-list-safe the-class)
	       for class-name = (class-name-safe class)
	       for generic-function-table
	           = (SET-DIFFERENCE (class-direct-generic-functions-safe class)
				     so-far)
	       do (SETQ so-far (APPEND generic-function-table so-far))
	       append (MULTIPLE-VALUE-BIND (items comb?)
			  (collect-clos-generic-function-items
			    generic-function-table)
			(WHEN comb?
			  (SETQ special-comb? t))
			items))
	 special-comb?)))

(DEFMETHOD Ï4(show-all-clos-generic-functions-sorted :generate-itemÏ*) ()
"Ï2Generates the inspector item list for the display of all of the generic
 functions for a class all grouped together and sorted.Ï*"
  (VALUES
    (MULTIPLE-VALUE-BIND (items special-comb?)
	(all-clos-generic-function-items-for-class data)
      `(,*blank-line-item*
	((:font 1 "Ï3All Generic-functions of class Ï*")
	 (:item1 instance ,(allocate-data 'show-clos-class data))
	 (:font 1 ,(IF special-comb?
		       "Ï3.  * = special generic-function combination typeÏ*" "Ï3:Ï*")))
	,*blank-line-item*
	,*clos-generic-function-display-columns-2*
	;Ï1; This sorts the generic-functions alphabetically by message, then byÏ*
	;Ï1; generic-function type (if any), then by submessage (if any).Ï*
	,@(SORT items #'gf-lessp)))
    `(:font fonts:hl12bi :string
	    ,(FORMAT nil "Ï3~A's generic-functions (sorted)Ï*"
		     (class-pretty-name data))))) 

(DEFMETHOD Ï4(show-all-clos-generic-functions-sorted :helpÏ*) ()
  (LET ((class-name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying all
generic-functions associated with all methods defined for or inherited by class
~A.  The generic-functions are sorted alphabetically by function name and
generic-function type.  (The \"All Generic-functions\" option provides a more
organized display of the generic-functions.)Ï*"
	    class-name)))

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

(DEFVAR Ï4*clos-method-operations-menu*Ï*
 '(("Ï3InspectÏ*" :value :inspect-clos-method
    :documentation "Ï3Show information about this method:
slots and methods referenced, arglist, documentation, source fileÏ*")
   ("Ï3DisassembleÏ*" :value :disassemble-clos-method
    :documentation "Ï3Use a standard Inspect window to show disassembled code.Ï*")
   ("Ï3Edit SourceÏ*" :value :edit-clos-method
    :documentation "Ï3Edit this method in a Zmacs buffer.Ï*")
   ("Ï3TraceÏ*" :value :trace-clos-method
    :documentation "Ï3Invoke a trace window to trace this methodÏ*")
   ("Ï3CombinationÏ*" :value :clos-method-combination
    :documentation "Ï3Shows the method combination for this method.Ï*")
   ("Ï3Related MethodsÏ*" :value :related-clos-methods
    :documentation "Ï3Show methods with the same name as this.Ï*"))
"Ï2The menu item list for the menu that's put up by right buttoning on a method.
 The :Value of each item in the list must be the name of a method on
 Flavor-Inspector, which takes a method as its arg.Ï*")

(DEFFLAVOR Ï4show-clos-methodÏ* () (inspection-data)
  (:documentation
"Ï3Displays a clos method.  Actually this flavor is never inspected directly,
 since whenever you click on one a show-clos-method-details is inspected.Ï*"))

(DEFMETHOD Ï4(show-clos-method :aux-dataÏ*) ()
"Ï2Just to make sure that the class gets returned rather than some strange
 method table entry.Ï*"
  data)

(DEFMETHOD Ï4(show-clos-method :middle-button-resultÏ*) ()
"Ï2Returns the class, not the method.Ï*"  ;Ï1; Is this right?Ï*
  data)

(DEFUN Ï4merge-args-and-specialisationsÏ* (args specialisations)
"Ï2Given a list of arg names, such as (me with) and a list of specialisations
 such as (bottle t) returns a merged version of them like ((me bottle) with).
 We don't want to show T specialisations and have to allow for the lists being
 of different lengths (though they shouldn't be.Ï*"
  (IF specialisations
      (IF (CONSP specialisations)
	  (CONS (IF (EQUAL t (FIRST specialisations))
		    (FIRST args)
		    (LIST (FIRST args)
			  (IF (OR (SYMBOLP (FIRST specialisations))
				  (AND (CONSP (FIRST specialisations))
				       (EQUAL 'EQL
					      (FIRST (FIRST specialisations)))))
			      (FIRST specialisations)
			      (class-name-safe (FIRST specialisations)))))
		(merge-args-and-specialisations
		  (REST args) (REST specialisations)))
	  (CONS specialisations args))
      args))

(DEFVAR Ï4*indent1*Ï* 35
"Ï2The number of spaces to indent between the display of a method's class
 and its generic function name.Ï*")

(DEFVAR Ï4*indent2*Ï* (+ *indent1* 15)
"Ï2The number of spaces to indent between the display of a method's generic function 
 name and its specialisers.Ï*")

(DEFUN Ï4format-a-method-conciselyÏ*
       (data stream &optional (indent1 *indent1*) (indent2 *indent2*))
"Ï2This is a slightly hairy print method for clos methods.  The reason that it's
 hairy is that we want it to be sensitive to whether the method class is
 standard-method or not and whether it's a combined method or not.Ï*"
  (LET ((generic-function (method-generic-function-safe data))
	(class-name (STRING-CAPITALIZE
		      (class-name-safe (class-of-safe data)))))
       (LET ((gf (LIST (allocate-data 'show-clos-generic-function
				      generic-function)
		       t
		       (OR (AND generic-function
				(generic-function-name-safe generic-function))))))
	    (MULTIPLE-VALUE-BIND (specs comb) (unparse-specializers-safe data)
	     (LET ((args (merge-args-and-specialisations
			   (method-arglist-safe data) specs)))
	          (IF specs
		      (IF (standard-method-p-safe data)
			  (FORMAT stream "Ï3~ý~VT~A~VT~SÏ*"
				  gf indent1
				  (IF comb
				      (FORMAT nil "Ï3~S~{ ~S~}Ï*"
					      (FIRST comb) (REST comb))
				      "")
				  indent2 args)
			  (FORMAT stream "Ï3~ý ~ý~VT~A~VT~SÏ*"
			       (LIST (allocate-data
				       'show-clos-class (class-of-safe data))
				     t class-name)
			       gf indent1
			       (IF comb
				   (FORMAT nil "Ï3~S~{ ~S~}Ï*"
					   (FIRST comb) (REST comb))
				   "")
			       indent2 args))
		      (IF (standard-method-p-safe data)
			  (FORMAT stream "Ï3~ý~VT~SÏ*" gf indent1 args)
			  (FORMAT stream "Ï3~ý ~ý~VT~SÏ*"
			       (LIST (allocate-data
				       'show-clos-class (class-of-safe data))
				     t class-name)
			       gf indent1 args))))))))

(DEFMETHOD Ï4(show-clos-method :format-conciselyÏ*) (STREAM)
"Ï2Prints out the method simply.  If it's being printed into the history window
 then we don't want to have any tabbing between the method class, GF and
 specialisers, otherwise we'll take the dynamically inherited tabbing.Ï*"
  (IF (in-history-window-p stream)
      (PROGN (FORMAT stream "Ï3CLOS Method Ï*")
	     (format-a-method-concisely data stream 0 0))
      (PROGN (IF *dont-have-initial-space*
		 nil
		 (FORMAT stream "Ï3 Ï*"))
	     (format-a-method-concisely data stream))))

;Ï1 TAC 08-04-89 - better version of this in GENERAL-INSPECTORÏ*
;Ï1(defmethod (show-clos-method :who-line-doc) (ignore &optional ignore)Ï*

(DEFMETHOD Ï4(flavor-inspector :inspect-clos-methodÏ*) (method)
"Ï2Given a method, inspects its details.Ï*"
  (SEND self :inspect-thing 'show-clos-method-details
     (FIRST (method-type-specifiers-safe method))
     method))

;Ï1 TAC 08-04-89 - better version is in GENERAL-INSPECTORÏ*
;Ï1(defmethod (flavor-inspector :disassemble-clos-method) (method)Ï*

(DEFMETHOD Ï4(flavor-inspector :trace-clos-methodÏ*) (method)
"Ï2Given a method, traces it.Ï*"
  (trace-via-menus (FUNCTION-NAME (method-function-safe method))))

(DEFMETHOD Ï4(flavor-inspector :edit-clos-methodÏ*) (method)
"Ï2Given a method, edits its source definition.Ï*"
  (ED (FUNCTION-NAME (method-function-safe method))))

(DEFMETHOD Ï4(flavor-inspector :clos-method-combinationÏ*) (method)
"Ï2Given a method, inspects its method combination representation.Ï*"
  (SEND self :inspect-thing 'show-clos-method-combination method))

(DEFMETHOD Ï4(flavor-inspector :related-clos-methodsÏ*) (method)
"Ï2Given a method, inspects the methods that are related to it.Ï*"
  (SEND self :inspect-thing 'show-clos-related-methods method))

(DEFUN Ï4select-clos-method-operationsÏ*
       (method flavor-inspector current-flavor &optional selection)
"Ï2This is the function that gets called when the user right buttons on a clos
 method.  It pops up a menu and, if the user clicks on something, invokes
 a method on the flavor inspector to process the menu selection.Ï*"
  (IGNORE current-flavor)
  (LET ((choice
	 (OR selection
	     (ucl::smart-menu-choose
	       *clos-method-operations-menu* :label
	       (FORMAT () "Ï3~sÏ*"
		       (FUNCTION-NAME (method-function-safe method)))))))
       (IF choice
	   (SEND flavor-inspector choice method)
	   nil)))

(DEFMETHOD Ï4(show-clos-method :handle-mouse-clickÏ*) (blip flavor-inspector)
"Ï2Handles mouse clicks for clos methods.Ï*"
  (LET ((current-flavor (SEND (SEND (THIRD blip) :current-object) :data)))
    (SELECTOR (FOURTH blip) =
      (#\mouse-l-1
       (select-clos-method-operations
	 data flavor-inspector current-flavor :inspect-clos-method))
      (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
      (#\mouse-r-1
       (select-clos-method-operations data flavor-inspector current-flavor))
      (t (BEEP)))))

(DEFMETHOD Ï4(show-clos-method :generate-itemÏ*) ()
"Ï2This isn't actually invoked (or it shouldn't be).  It's here just in case.Ï*"
  (VALUES `(,*blank-line-item*
	    ((:font 1 "Ï3Details of Ï*")
	     (:item1 instance ,(allocate-data 'show-clos-method data)))
	    ,*blank-line-item*
	    ((:font 1 "Ï3Data:      Ï*")
	     (:item1 instance ,data)))
	  `(:font fonts:hl12bi :string
		  ,(FORMAT nil "Ï3CLOS~{ ~s~}Ï*" (clos-method-name data)))))

(DEFMETHOD Ï4(show-clos-method :helpÏ*) ()
  (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying the method ~SÏ*"
	  data))

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

(DEFFLAVOR Ï4show-clos-related-methodsÏ* () (inspection-data)
  (:documentation "Ï3Shows the methods related to the methods Data.Ï*"))

(DEFMETHOD Ï4(show-clos-related-methods :middle-button-resultÏ*) ()
"Ï2Just returns the method itself.Ï*"
  data)

(DEFMETHOD Ï4(show-clos-related-methods :aux-dataÏ*) ()
"Ï2Just returns the method itself.Ï*"
  data)

(DEFMETHOD Ï4(show-clos-related-methods :format-conciselyÏ*) (STREAM)
"Ï2Nothing special here.  Just prints out its name a little cleverly.Ï*"
  (FORMAT stream "Ï3Methods related to Ï*")
  (format-a-method-concisely data stream 0 0))

(DEFMETHOD Ï4(show-clos-related-methods :handle-mouse-clickÏ*)
  (blip flavor-inspector)
"Ï2Handles mouse clicks for related methods.  Knows how to do l, l2 and M clicks.Ï*"
  (SELECTOR (FOURTH blip) =
    (#\mouse-l-1 (SEND flavor-inspector :inspect-info-left-click))
    (#\mouse-l-2 (SEND flavor-inspector :inspect-info-left-2-click))
    (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
    (otherwise (BEEP))))

(DEFMETHOD Ï4(show-clos-related-methods :generate-itemÏ*) ()
"Ï2Makes an inspector item list for the methods related to Data.  This is all
 pretty simple, the methods are just displayed one on a line.Ï*"
  (LET ((method-table
	  (sort-clos-methods
	    (generic-function-methods-safe
	      (method-generic-function-safe data)))))
       (MULTIPLE-VALUE-BIND (items ignore)
	     (collect-clos-method-items method-table)
	 (VALUES
	  `(,*blank-line-item*
	    ((:font 1 "Ï3Methods Related to Ï*")
	     (:item1 instance ,(allocate-data 'show-clos-method data)
		     print-unpadded-method))
	 ,*blank-line-item*
	    ,@(IF items
		(CONS *clos-method-display-columns* items)
		*no-items*))
	  `(:font fonts:hl12bi :string
		  ,(FORMAT nil "Ï3Methods Related to CLOS~{ ~s~}Ï*"
			(clos-method-name data)))))))

(DEFMETHOD Ï4(show-clos-related-methods :helpÏ*) ()
  (LET ((method-name (FUNCTION-NAME (method-function-safe data))))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying methods
related to ~S.  This is all of the methods that share the same generic
function name.Ï*"
	    method-name)))

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

(DEFUN Ï4print-unpadded-methodÏ* (instance stream &optional (level 0))
"Ï2Prints a method on stream without any tabbing either before the method
 or between the GF name, the method class or the specialisers.Ï*"
  (LET ((*indent1* 0)
        (*indent2* 0)
	(*dont-have-initial-space* t))
       (inspection-data-print-item-concisely instance stream level)))

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

;Ï1;; Warning....  This is probably the most magical part of the CLOS inspector.Ï*

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

(DEFFLAVOR Ï4show-clos-method-combinationÏ* () (inspection-data)
  (:documentation
"Ï3Displays the methods combination call seqyuence for a given method.
 This means that the methods combination code is computed for the generic
 function named by Data (a method).  The computation of the method invokation
 sequence is extremely grungy and system dependent.Ï*"))

(DEFMETHOD Ï4(show-clos-method-combination :middle-button-resultÏ*) ()
"Ï2Just returns the method itself.Ï*"
  data)

(DEFMETHOD Ï4(show-clos-method-combination :aux-dataÏ*) ()
"Ï2Just returns the method itself.Ï*"
  data)

(DEFMETHOD Ï4(show-clos-method-combination :format-conciselyÏ*) (STREAM)
"Ï2Prints the method name out simply.  No padding is given.Ï*"
  (FORMAT stream "Ï3Method Combination of Ï*")
  (format-a-method-concisely data stream 0 0))

(DEFMETHOD Ï4(show-clos-method-combination :handle-mouse-clickÏ*)
	   (blip flavor-inspector)
"Ï2Handles mouse clicks for related methods.  Knows how to do l, l2 and M clicks.Ï*"
  (SELECTOR (FOURTH blip) =
    (#\mouse-l-1 (SEND flavor-inspector :inspect-info-left-click))
    (#\mouse-l-2 (SEND flavor-inspector :inspect-info-left-2-click))
    (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
    (otherwise (BEEP))))

(DEFMETHOD Ï4(show-clos-method-combination :generate-itemÏ*) ()
"Ï2Generates the mouse-sensitive inspector items for the method combination
 display.  The actual computation of the call sequence and the itemisation of
 it is done in the function method-combination-of-method-safe, which is in a
 different file.  There's lots of docs on this particular function.  After that
 itemisation has happened, this method is very simple.Ï*"
  (VALUES
    `(,*blank-line-item*
      ((:font 1 "Ï3Method Combination of Ï*")
       (:item1 instance ,(allocate-data 'show-clos-method data)
	       print-unpadded-method))
      ,*blank-line-item*
      ,@(method-combination-of-method-safe data))
    `(:font fonts:hl12bi :string
	    ,(FORMAT nil "Ï3Method call sequence of Generic Function ~S,~%~
                          when called with args of class: ~SÏ*"
		     (generic-function-name-safe
		       (method-generic-function-safe data))
		     (unparse-specializers-safe data)))))

(DEFMETHOD Ï4(show-clos-method-combination :helpÏ*) ()
  (LET ((method-name (FUNCTION-NAME (method-function-safe data))))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying method combination
information for ~S.  This shows as a sort of
pseudo code the way in which the overall generic function's value will be
computed it you were to call ~S with args whose types are those specified
in the specializations for ~S, i.e. ~S.Ï*"
	    method-name (SECOND method-name) method-name
	    (unparse-specializers-safe data))))

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

(DEFFLAVOR Ï4show-clos-method-detailsÏ*
	   () (auxiliary-data-mixin class-operation-mixin)
  (:documentation
"Ï3Shows sundry details about clos methods, such as source file, combination and
 things like that.  Aux-data contains the method.  Data should have the class
 that caused this to be inspected, e.g. a specializer that specialises for this
 method.Ï*"))

(DEFMETHOD Ï4(show-clos-method-details :middle-button-resultÏ*) ()
"Ï2Just returns the method itself.Ï*"
  aux-data)

(DEFMETHOD Ï4(show-clos-method-details :format-conciselyÏ*) (STREAM)
"Ï2Prints the method out differently for different types of window.  If we're in
 a history window then we get the whole lot telling us that it's a CLOS method,
 otherwise we just get the method class - GF name - specializers list type of
 print out.Ï*"
  (IF (in-history-window-p stream)
      (PROGN (FORMAT stream "Ï3CLOS Method Ï*")
	     (format-a-method-concisely aux-data stream 0 0))
      (PROGN (IF (NOT *dont-have-initial-space*)
		 nil
		 (FORMAT stream "Ï3 Ï*"))
	     (format-a-method-concisely aux-data stream))))

(DEFWRAPPER Ï4(show-clos-method-details :handle-mouse-clickÏ*)
	    ((blip flavor-inspector) &body body)
"Ï2Makes sure that show clos method details things can have a right button menu.Ï*"
  `(IF (= (FOURTH blip) #\Mouse-r-1)
       (select-clos-method-operations
	 aux-data flavor-inspector
	 (CATCH-ERROR (SEND (SEND (THIRD blip) :current-object) :data) nil))
       . ,body))

(DEFUN Ï4coerce-to-disassemblable-functionÏ* (something)
"Ï2Can be passed a closure or a fef.  If it's a closure, then we want to get the
 fef for the function that defined the closure.Ï*"
  (IF (CLOSUREP something)
      ;Ï1; TAC 09-05-89 - substituted (si::closure-function something) for (FIRST (si:convert-closure-to-list something))Ï*
      ;Ï1;                      David Gray's preferred way to handle closuresÏ*
      ;Ï1; Ï*(FIRST (si:convert-closure-to-list something))
      (si::closure-function something)
      something))

(DEFUN Ï4ivars-and-messages-in-methodÏ* (FUNCTION)
"Ï2This is a modified version of the original TI version that was in the
 flavor inspector.  The original used to return three values; the ivars
 referenced, any message keywords used and a flag that said whether there
 was a problem in computing the result.  This function now returns the
 following values:
  ivars - a list containing either symbols for the names of the flavors slots
          referenced or slot-descriptor objects for the CLOS slots referenced.
  message-keywords - as in the flavors case.
  problem - error-p as in the flavors case.
  functions-called - a list of all of the (non-generic) functions called.
  generic-functions-called - a list of all of the generic functions called.
  args - the arglist.
  returned-values - the returned values (if declared).
  locals - a list of the names of all of the locals used in the function.
  specials-read - a list of all of the specials read in the function.
  specials-bound - a list of all of the specials bound by the function,
                   including by the arglist.

 The long and the short of this is that this function is now rather misnamed,
 since it can be called with any function as its arg, be it a simple function,
 a GF, a flavors method or a CLOS method.Ï*"
  (LET ((fef (IF (TYPEP function 'CONS) ;Ï1; flavor methodÏ*
		 (FDEFINITION function)
		 (get-fef-from-object
		   (coerce-to-disassemblable-function function))))
	lim-pc
	ilen
	*collected-ivars*
	*collected-messages*
	*collected-functions*
	*collected-generic-functions*
	*collected-bound-specials*)
    (DECLARE
      (SPECIAL *collected-ivars* *collected-messages* *previous-op*
	       *previous-previous-op* *collected-functions*
	       *collected-generic-functions* *collected-bound-specials*))
    (DECLARE (VALUES ivars message-keywords problem functions-called
		     generic-functions-called args returned-values
		     locals specials-read specials-bound))
    (WHEN (SYMBOLP fef)	;Ï1; Obsolete syntax for method definitions mayÏ*
      (SETF fef (SYMBOL-FUNCTION fef)))	;Ï1; return symbols here.  PMH SPR#6810Ï*
    (IF (CONSP fef)
	(VALUES () () (IF (EQ (CAR fef) 'MACRO) :wrapper :interpreted) nil)
	(MULTIPLE-VALUE-BIND (args returned-values) (ARGLIST fef)
	  (SETQ lim-pc (compiler:disassemble-lim-pc fef))
	  ;Ï1; Loop through the instructions of FEF, searching for ivars and messages.Ï*
	  (DO ((pc (fef-initial-pc fef) (+ pc ilen)))
	      ((>= pc lim-pc))
	    (SETQ ilen (search-instruction fef pc)))
	  (VALUES *collected-ivars* *collected-messages*
		  nil *collected-functions* *collected-generic-functions*
		  args returned-values
		  (SET-DIFFERENCE
		    (REMOVE nil
			    (sys::dbis-local-map (sys:get-debug-info-struct fef)))
		    args)
		  (eh::specials-used-by-fef fef)
		  *collected-bound-specials*)))))

;Ï1; TI code, modified by JPR.Ï*
(DEFUN Ï4my-decode-clos-self-ref-pointerÏ* (fef pointer-number)
  "Ï2Decode the pointer field of a DTP-SELF-REF-POINTER. Values are an instance variable name
 and NIL, or a component class name and T.Ï*"
  ;Ï1;  5/09/88 DNG - Original (adapted from FLAVOR-DECODE-SELF-REF-POINTER).Ï*
  (DECLARE (VALUES instance-var-or-component-class t-if-component-class class slot-object))
  ;Ï1 TAC 07-25-89 - added declare sys vars below special - compiler complains otherwiseÏ*
  (DECLARE (SPECIAL sys::local-for-first-mapping-table sys::locals-for-mapping-table-base))
  (LET* ((local-slot (LDB sys:%%clos-self-ref-mapping-table-local-index pointer-number))
	 (arg-slot (IF (= local-slot sys::local-for-first-mapping-table)
		       0
		     (- local-slot (- sys::locals-for-mapping-table-base 1))))
	 (class-name (AND (>= arg-slot 0)
			  (NTH arg-slot (compiler::function-specializers fef)))))
    (UNLESS (OR (NULL class-name)
		(NOT (FBOUNDP 'ticlos::class-named)))
      (LET ((class-object (ticlos::class-named class-name t))
	    (offset (LDB sys:%%clos-self-ref-slot-offset pointer-number)))
	(COND
	  ((NULL class-object) nil)
	  ((LDB-TEST sys:%%clos-self-ref-map-leader-flag pointer-number)
	   (VALUES (ticlos:class-name
		     (NTH offset (ticlos::class-mapped-supers class-object)))
		   t
		   (NTH offset (ticlos::class-mapped-supers class-object))
		   nil))
	  ((LDB-TEST sys:%%clos-self-ref-relocate-flag pointer-number)
	   (LET ((slot-name
		   (NTH offset (ticlos::class-mapped-slot-names class-object))))
	        (VALUES-LIST
		  (APPEND (LIST slot-name nil)
			  (REVERSE (MULTIPLE-VALUE-LIST
				     (find-slot-in-classes
				       slot-name
				       (class-precedence-list-safe class-object)
				       )))))))
	  (t nil))))))

(DEFUN Ï4ivar-and-classÏ* (fef index)
"Ï2Is passed a fef and an index into the fef.  It returns values for the name
 of the slot and the name of the arg that it was in, i.e. if the instruction,
 when disassembled would have said something like \"Slot-name in Arg-name\",
 the it returns these two names.Ï*"
  (DECLARE (VALUES slot-name method-arg-name))
  (MULTIPLE-VALUE-BIND (slot-name ignore class slotd)
      (my-decode-clos-self-ref-pointer fef index)
    (LET ((arg-name
	    (IF (ZEROP (LDB sys:%%clos-self-ref-instance-ref-addressing-mode
			    index))
		(compiler:disassemble-arg-name
		  fef (LDB sys:%%clos-self-ref-instance-ref-index index))
		(compiler:disassemble-local-name
		  fef (LDB sys:%%clos-self-ref-instance-ref-index index)))))
      (VALUES slot-name arg-name class slotd))))

(DEFUN Ï4find-slot-in-classesÏ* (name classes)
"Ï2Given the name of a slot and a list of classes it searches the classes until it
 finds a slot of that name and then returns a slot descriptor for that slot and
 the class that defined it..Ï*"
  (DECLARE (VALUES slotd class-defining-slot))
  (IF classes
      (LET ((entry (FIND-IF
		     #'(lambda (x)
			 (EQUAL name (slotd-name-safe x)))
		       (class-local-slots-safe (FIRST classes)))))
	   (IF entry
	       (VALUES entry (FIRST classes))
	       (find-slot-in-classes name (REST classes))))
      nil))

;Ï1; This should no longer be used.  We've found a better way.Ï*
(DEFUN Ï4find-slotd-from-fefÏ* (slot-name fef arg-name)
"Ï2Given the name of a slot (Slot-name) that's referenced in Fef and the name
 of the specialised arg that the slot can be found in (arg-name) it returns
 a list containing the slot-descriptor for the slot named slot-name
 (if it finds it) and the class object to which the arg-name belongs.Ï*"
  (LET ((method
	  (OR (GETF (sys:dbis-plist (sys:get-debug-info-struct fef)) :method)
	      (LET ((methods
		      (CATCH-ERROR
			(generic-function-methods-safe
			  (function-generic-function-safe
			    (fdefinition-safe (SECOND (FUNCTION-NAME fef)))))
			nil)))
		   (FIND-IF #'(lambda (x) (EQUAL (method-function-safe x) fef))
			    methods)))))
       (IF method
	   (LET ((index
		   (POSITION arg-name (method-lambda-list-safe method))))
		(IF index
		    (LET ((class
			    (NTH index
				 (method-specializers-safe method))))
			 (LET ((match (find-slot-in-classes
					slot-name
					(class-precedence-list-safe class))))
			      (IF match (LIST match class) nil)))
		    nil))
	   nil)))

(DEFUN Ï4find-generic-functionÏ* (name)
"Ï2Given the name of a GF it returns the actual generic function object named
 by Name.Ï*"
  (GETF (sys:dbis-plist (sys:get-debug-info-struct name)) :generic-function))

;Ï1; A couple of tests.Ï*
;Ï1(find-generic-function 'user:is-empty)Ï*
;Ï1(find-slotd-from-fef 'user:the-contents #'(ticlos:method user:fill-it2 (user:bottle t user:can)) 'user:myself)Ï*

(DEFUN Ï4search-instructionÏ* (fef pc)
"Ï2Searches an instruction indexed by PC in the function Fef.  This is used during
 the dummy disassembling of Fef, whilst looking for interesting things about
 the function.  Particularly, it notes if the instruction is a bind type of
 instruction, since this will affect our noting of specials bound.Ï*"
  (LET (wd op name no-reg ilen subop op-other-way)
    (SETQ ilen (compiler:disassemble-instruction-length fef pc))
    (BLOCK ()
      (SETQ wd (compiler::disassemble-fetch fef pc)
	    op (LDB si:%%qmi-full-opcode wd)
	    op-other-way (LDB (BYTE 4  9) wd)
	    subop (LDB (BYTE 3 13) wd)
	    name (AREF (compiler:instruction-decode-table) op)
	    no-reg (GET name 'compiler::no-reg))
      (LET ((*binding*
	      (OR (AND (EQUAL op-other-way 11) (< subop 3))
		  (AND (SYMBOLP name)
		       (SEARCH "Ï3BINDÏ*" (SYMBOL-NAME name) :test #'STRING-EQUAL)))))
	   (DECLARE (SPECIAL *binding*))
      (COND
	((EQ no-reg 'nil) ;Ï1; does use registerÏ*
	 (search-address
	   fef (LDB si:%%qmi-register wd) (LDB si:%%qmi-offset wd) nil pc))
	((EQ name 'compiler::push-long-fef)
	 (search-address fef 0 (LDB si:%%qmi-fef-offset wd) nil pc))
	;Ï1; Commented out by JPR on 3/02/89.  This causes occasional barfage.Ï*
	((EQ no-reg 'CALL)
	 (CATCH-ERROR  ;Ï1; Sometimes this doesn't work.Ï*
	   (search-address fef (LDB (BYTE 3 6) wd) (LDB (BYTE 9 0) wd) nil)
	   nil))
	(t nil))
      ilen))))

;Ï1 TAC 08-29-89 -  message from JPR 8/29 indicating bug in this routine. Added new condition.Ï*
(DEFUN Ï4search-pointerÏ* (fef disp pc)
"Ï2This is called during the pseudo disassembling of Fef in order to find out
 interesting things about it.  Disp and PC are the instruction displacement
 and the pc into the Fef.  It looks for interesting things in the instruction
 and notes them by pushing the interesting thing (e.g. a special bound or a
 function called) onto a list held in a special.  There's lots of horrible
 stuff in here with lots of %%s and such.  I cribbed all of the code
 fragments from places like the disassembler so I don't understand how they
 work, but they seem to anyway.  This is a modified version of the flavor
 inspector version with extra whizz bangs added.Ï*"
  (IGNORE pc)
  (LET (tem)
    (DECLARE
      (SPECIAL *collected-ivars* *collected-messages* *collected-functions*
	       *collected-generic-functions* *collected-bound-specials* *binding*))
    ;Ï1; Make sure DISP argument is reasonable.Ï*
    (UNLESS (< disp (si:%structure-boxed-size fef))
      (FERROR nil "Ï3Offset ~d. into function is not in function ~s's boxed-Q areaÏ*" disp fef))
    (COND ((= (si:%p-data-type-offset fef disp) dtp-self-ref-pointer)
	   (IF (OR ;Ï1; This may be a (defun foo () (declare (self-flavor bar))..Ï*
		   ;Ï1; fix put in by JPR on 08/29/89 11:33:46Ï*
		   (NOT (CONSP (FUNCTION-NAME fef)))
		   (EQUAL :method (FIRST (FUNCTION-NAME fef))))
	       (MULTIPLE-VALUE-BIND (ptr component-flavor-flag)
		   (si::flavor-decode-self-ref-pointer 
		     (si::fef-flavor-name fef)
		     (si:%p-pointer-offset fef disp))
		 (WHEN ptr
		   (UNLESS component-flavor-flag
		     ;Ï1; Collect the instance variable!!Ï*
		     (PUSHNEW ptr *collected-ivars*))))
	       ;Ï1; This is a CLOS instance.Ï*
	       (MULTIPLE-VALUE-BIND (name arg-name class slotd)
		   (ivar-and-class fef (si:%p-pointer-offset fef disp))
		 (IGNORE arg-name)
		 (WHEN name
		   ;Ï1; Collect the instance variable!!Ï*
		   (PUSHNEW (LIST slotd class) *collected-ivars* :test #'EQUAL)))))
          ;Ï1; Don't think this ever refers to ivars or keywords.Ï*
          ((= (si:%p-data-type-offset fef disp) dtp-external-value-cell-pointer)
	   (LET ((tem (%p-contents-as-locative-offset fef disp)))
	        (LET ((ptr (%find-structure-header tem)))
		     (LET ((offset (%pointer-difference tem ptr)))
			      ;Ï1; Should be %% something???Ï*
		          (IF (AND (SYMBOLP ptr) (EQUAL offset 2))
			      (IF (generic-function-p-safe ptr)
				  (PUSHNEW (find-generic-function ptr)
					   *collected-generic-functions*)
				  (PUSHNEW ptr *collected-functions*))
			      (IF (AND (SYMBOLP ptr) (EQUAL offset 1) *binding*)
				  (PUSH ptr *collected-bound-specials*)
				  nil))))))
          (t
           (SETQ tem (%p-contents-offset fef disp))
           ;Ï1; When argument is a keyword and the operation is a call (FUNCALL or SEND),Ï*
	   ;Ï1; assume it is a message.  There's also a special case caused by the popularÏ*
	   ;Ï1; (SEND <foo> :SEND-IF-HANDLES :bar) feature which is covered here.  Ï*
           ;Ï1; :BAR is included as a referenced message, even though it is technically Ï*
	   ;Ï1; just a keyword.Ï*
           (WHEN (AND (SYMBOLP tem) (KEYWORDP tem))
             (PUSHNEW tem *collected-messages*))))))

(DEFUN Ï4referenced-symbol-detailsÏ* (referenced-symbols)
"Ï2Given a list of the symbols referenced in a fef, returns a list of items for
 the inspector, which puts a different symbol on each line with a space at
 the beginning.Ï*"
  (CATCH-ERROR
    (IF referenced-symbols
	(LOOP for symbol in referenced-symbols
	      collect
	      `(,*one-space-item* (:item1 named-structure-value ,symbol)))
       *no-items*)
    nil))

(DEFUN Ï4locals-detailsÏ* (locals)
"Ï2Makes an inspector item list for the list of locals referenced in a fef.Ï*"
  (referenced-symbol-details locals))

(DEFUN Ï4referenced-keywords-detailsÏ* (referenced-keywords)
"Ï2Makes an inspector item list for the list of message keywords referenced
 in a fef.Ï*"
  (referenced-symbol-details referenced-keywords))

(DEFUN Ï4referenced-specials-detailsÏ* (referenced-specials)
"Ï2Makes an inspector item list for the list of specials referenced in a fef.Ï*"
  (referenced-symbol-details referenced-specials))

(DEFUN Ï4bound-specials-detailsÏ* (bound-specials)
"Ï2Makes an inspector item list for the list of specials bound in a fef.Ï*"
  (referenced-symbol-details bound-specials))

(DEFUN Ï4referenced-instance-variables-detailsÏ* (data referenced-ivars)
"Ï2Makes an inspector item list for the list of instance variables referenced
 in a fef.  An item in this list might be either a symbol, in which case it is
 a flavors IV name and a suitable item is made, or a list with a slot
 descriptor and class, which is the case for a clos slot reference.  In
 this case an item is made for this clos slot.Ï*"
  data ;Ï1; to keep compiler from complainingÏ*
  (IF (NOT referenced-ivars)
      ;Ï1;Ï* TAC 08-18-89Ï1 - removing PCL supportÏ*
      ;Ï1; Ï*(OR (AND (iwmc-class-p-safe data) (LIST nil)) (NOT referenced-ivars))
      *no-items*
      (CATCH-ERROR
        (LOOP for entry in referenced-ivars
	      collect
	      (IF (CONSP entry)
		 `(,*one-space-item*
		   (:item1 instance
			   ,(allocate-data 'show-clos-instance-variable
					   (SECOND entry) (FIRST entry)))
		   (:font 1 "Ï3 defined by Ï*")
		   (:item1 instance
			   ,(allocate-data 'show-clos-class (SECOND entry))))
		 `(,*one-space-item* (:item1 named-structure-value ,entry))))
	nil)))

(DEFUN Ï4referenced-generic-functions-detailsÏ* (referenced-generic-functions)
"Ï2Makes an inspector item list for the list of generic functions referenced
 in a fef.Ï*"
  (IF referenced-generic-functions
      (CATCH-ERROR
        (LOOP for function in referenced-generic-functions
	      collect `(,*one-space-item*
			(:item1
			  instance
			  ,(allocate-data 'show-clos-generic-function function))))
	nil)
      *no-items*))

(DEFUN Ï4referenced-functions-detailsÏ* (referenced-functions)
"Ï2Makes an inspector item list for the list of (non-generic) functions referenced
 in a fef.Ï*"
  (IF referenced-functions
      (CATCH-ERROR
        (LOOP for function in referenced-functions
	      collect `(,*one-space-item*
			(:item1
			  instance
			  ,(allocate-data 'show-function function))))
	nil)
      *no-items*))

(DEFUN Ï4macros-expanded-detailsÏ* (data)
"Ï2Makes an inspector item list for the list of macros expanded by a fef.Ï*"
  (CATCH-ERROR
    (LET ((macros
	    (MAPCAR #'ucl::first-if-list
		    (GETF (sys:dbis-plist (sys:get-debug-info-struct data))
			  :macros-expanded))))
	 (IF macros
	     (LOOP for macro in macros
		   collect
		   `(,*one-space-item* (:item1 named-structure-value ,macro)))
	     *no-items*))
    nil))

(DEFUN Ï4interpreted-definition-detailsÏ* (fef)
"Ï2Makes an inspector item for the interpretted definition of a fef if it can
 find one.Ï*"
 (CATCH-ERROR
   (LET ((int (IF (CONSP fef)
		  fef
		  (IF (CONSP (sys::dbis-interpreted-definition
			       (sys:get-debug-info-struct fef)))
		      (sys::dbis-interpreted-definition
			(sys:get-debug-info-struct fef))
		      nil))))
	(IF int
	    `(((:item1 named-structure-value ,int)))
	    *no-items*))
   nil))

(DEFMETHOD Ï4(show-clos-method-details :generate-itemÏ*) ()
"Ï2Makes the inspector item list for the details of a clos method.  This involves
 grovling over the diassembled code for the fef of the method and deducing
 sundry things about it, such as the specials bound or the slots accessed.
 These are all displayed in sections devoted to a particular topic, usually
 with one item on a line, e.g. on local var per line.Ï*"
  (VALUES
    (MULTIPLE-VALUE-BIND
      (referenced-ivars referenced-keywords problem
       referenced-functions referenced-generic-functions args returned-values
       locals specials-referenced specials-bound)
	(ivars-and-messages-in-method aux-data)
      (IGNORE problem)
     `(,*blank-line-item*
       ((:font 1 "Ï3Details of Ï*")
	(:item1 instance
		,(allocate-data 'show-clos-method-details data aux-data)
		print-unpadded-method)
	(:font 1 "Ï3 Class Ï*")
	(:item1 instance
		,(allocate-data 'show-clos-class (class-of-safe aux-data))))
       ,*blank-line-item*
       ((:font 1 "Ï3Generic FunctionÏ*")
	(:colon 30)
	(:item1 instance
		,(allocate-data 'show-clos-generic-function
				(method-generic-function-safe aux-data))
		print-unpadded-method))
       ,*blank-line-item*
       ((:font 1 "Ï3Source FileÏ*")
	(:colon 30)
	,(method-path-string-safe aux-data))
       ,*blank-line-item*
       (,(IF returned-values
	     '(:font 1 "Ï3Arglist Ý Returned ValuesÏ*")
	     '(:font 1 "Ï3ArglistÏ*"))
	(:colon 30)
	("Ï3~:[~*()~;~S~]Ï*" ,args ,args)
	,@(WHEN returned-values
	    `(("Ï3 Ý ~SÏ*" ,returned-values))))
       ,*blank-line-item*
       ((:font 1 "Ï3Documentation:Ï*"))
       ,@(LET ((doc (method-docs-safe aux-data)))
	   (IF (AND doc (NOT (EQUAL "" doc)))
	       (break-string-into-lines doc)
	       *no-items*))
       ,*blank-line-item*
       ((:font 1 "Ï3Classes Specialized:Ï*"))
       ,@(LOOP for class in (method-parameter-specializers-safe aux-data)
	     when (class-p-safe class)
	     collect `(,*one-space-item*
		       (:item1
			 instance
			 ,(allocate-data 'show-clos-class class))))
       ,*blank-line-item*
       ;Ï1;  TAC 08-18-89 - remove PCL support Ï*
       ;Ï1; ((:font 1 ,(IF (iwmc-class-p-safe aux-data)Ï*
       ;Ï1;Ï*		Ï1      ""Ï*
       ;Ï1;Ï*		Ï1      "Referenced Slots:")))Ï*
       ((:font 1 "Ï3Referenced Slots:Ï*"))
       ;Ï1;  TAC 08-18-89 - remove PCL support Ï*
       ;Ï1; ,@(IF (iwmc-class-p-safe aux-data)Ï*
       ;Ï1;Ï*	Ï1     nilÏ*
       ;Ï1;Ï*	Ï1     (referenced-instance-variables-details aux-data referenced-ivars))Ï*
       ,@(referenced-instance-variables-details aux-data referenced-ivars)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Keywords (possibly messages passed):Ï*"))
       ,@(referenced-keywords-details referenced-keywords)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Generic Functions:Ï*"))
       ,@(referenced-generic-functions-details
	    referenced-generic-functions)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Functions:Ï*"))
       ,@(referenced-functions-details referenced-functions)
       ,*blank-line-item*
       ((:font 1 "Ï3Locals:Ï*"))
       ,@(locals-details locals)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Specials:Ï*"))
       ,@(referenced-specials-details specials-referenced)
       ,*blank-line-item*
       ((:font 1 "Ï3Specials Bound:Ï*"))
       ,@(bound-specials-details specials-bound)
       ,*blank-line-item*
       ((:font 1 "Ï3Macros Expanded:Ï*"))
       ,@(macros-expanded-details (method-function-safe aux-data))
       ,*blank-line-item*
       ((:font 1 "Ï3Method Combination:Ï*"))
       ,@(method-combination-of-method-safe aux-data)
       ,*blank-line-item*
       ((:font 1 "Ï3Interpreted Definition:Ï*"))
       ,@(interpreted-definition-details (method-function-safe aux-data))
       ))
    `(:font fonts:hl12bi :string ,(FORMAT nil "Ï3CLOS~{ ~s~}Ï*"
					  (clos-method-name aux-data)))))

(DEFMETHOD Ï4(show-clos-method-details :helpÏ*) ()
  (LET ((method-name (FUNCTION-NAME (method-function-safe aux-data))))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying sundry details
about the method ~S.Ï*"
	    method-name)))

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

(DEFFLAVOR Ï4show-clos-generic-function-detailsÏ* ()
   (generic-middle-button-mixin auxiliary-data-mixin class-operation-mixin)
  (:documentation
"Ï3Shows sundry details about generic functions, such as source file, methods and
 things like that.  Aux-data contains the GF.  Data should have the class
 that caused this to be inspected, e.g. a specializer that specialises a method
 for this GF.Ï*"))

(DEFMETHOD Ï4(show-clos-generic-function-details :middle-button-resultÏ*) ()
"Ï2Just returns the method itself.Ï*"
  aux-data)

;Ï1; TAC 08-17-89 - removing pcl supportÏ*
;(DEFMETHOD Ï4(show-clos-generic-function-details :format-conciselyÏ*) (STREAM)
;"Ï2Nothing special here.  Just prints out the generic function name, noting ifÏ*
;Ï2 it's a PCL one.Ï*"
;  (IF (iwmc-class-p-safe data) (FORMAT stream "Ï3PCL Ï*") nil)
;  (FORMAT stream "Ï3Generic function ~sÏ*"
;	  (generic-function-name-safe aux-data)))

(DEFMETHOD Ï4(show-clos-generic-function-details :format-conciselyÏ*) (STREAM)
"Ï2Nothing special here.  Just prints out the generic function name.Ï*"
  (FORMAT stream "Ï3Generic function ~sÏ*"
	  (generic-function-name-safe aux-data)))

(DEFWRAPPER Ï4(show-clos-generic-function-details :handle-mouse-clickÏ*)
	    ((blip flavor-inspector) &body body)
"Ï2Makes sure that show generic function details things can have a right button
 menu.Ï*"
  `(IF (= (FOURTH blip) #\Mouse-r-1)
       (select-clos-generic-function-operations aux-data flavor-inspector
	     (CATCH-ERROR (SEND (SEND (THIRD blip) :current-object) :data) nil))
       . ,body))

;Ï1; *** from Rice message Mods to TI-ENV-FL.-INSP.-INTERF. 8 Jun 1989 13:52:16 PDTÏ*
(DEFUN Ï4compact-arglistsÏ* (arglists result)
"Ï2Given a list of (arglist method) pairs, it accumulates into Result the
 compacted method list, which collects up all methods that share the same
 arglist.  (#<meth1> #<meth2> #<meth3>)
 -> (((args1 values1) (#<meth1>)) ((args2 values2) (#<meth2> #<meth3>))
 for methods meth2 and meth3, which share the same arglists.Ï*"
  (IF arglists
      (LET ((match (FIND-IF #'(lambda (x)
				(EQUALP (FIRST x) (FIRST (FIRST arglists))))
			      result)))
	   (IF match
	       (compact-arglists
		 (REST arglists)
		 (CONS (LIST (FIRST match)
			     (CONS (SECOND (FIRST arglists)) (SECOND match)))
		       (REMOVE match result)))
	       (compact-arglists
		 (REST arglists)
		 (CONS (LIST (FIRST (FIRST arglists))
			     (LIST (SECOND (FIRST arglists))))
		       result))))
      result))

(DEFUN Ï4get-compact-arglistsÏ* (methods)
"Ï2Returns a list of the methods Methods that have been compacted into groups
 which share the same arglists.  Thus a list of the form
 (#<meth1> #<meth2> #<meth3>)
 -> (((args1 values1) (#<meth1>)) ((args2 values2) (#<meth2> #<meth3>))
 for methods meth2 and meth3, which share the same arglists.Ï*"
  (IF methods
      (compact-arglists
	(MAPCAR
	  #'(lambda (x)
	      (LIST (MULTIPLE-VALUE-LIST (method-arglist-safe x)) x))
	    methods)
	nil)
      nil))

(DEFUN Ï4generic-function-arglist-itemsÏ* (gf args returned-values)
"Ï2Returns the items for a generic funtion, whose args are Args and returned
 values are Returned values.  If the GF has any methods then the arglists of
 these are shown too, since these are usually more intelligible then that of
 the GF.Ï*"
  (LET ((methods (generic-function-methods-safe gf)))
       (LET ((method-arglists (get-compact-arglists methods)))
	   `((,(IF returned-values
		    '(:font 1 "Ï3Arglist Ý Returned ValuesÏ*")
		    '(:font 1 "Ï3ArglistÏ*"))
	       (:colon 40)
	       ("Ï3~:[~*()~;~S~]Ï*" ,args ,args)
	       ,@(WHEN returned-values
		   `(("Ï3 Ý ~SÏ*" ,returned-values))))
	     ,@(IF methods
		  `(,*blank-line-item*
		    ((:font 1 "Ï3  Arglists for Methods:Ï*"))
		    ,@(APPLY #'APPEND
			     (MAPCAR #'(lambda (x)
				  `(("Ï3    Ï*"
				     (:item1 t ,(FIRST (FIRST x)))
				     ,@(IF (SECOND (FIRST x))
					  `((:font 1 "Ï3 Ý Ï*")
					    (:item1 t ,(SECOND (FIRST x))))
					   nil)
				     (:font 1 ,(IF (REST (SECOND x))
						   "Ï3 for MethodsÏ*"
						   "Ï3 for MethodÏ*")))
				    ,@(MAPCAR
					#'(lambda (meth)
					    `("	"
					      (:item1 instance
					      ,(allocate-data
						 'show-clos-method-details
						 meth meth))))
					  (SECOND x))))
			        method-arglists)))
		  nil)))))

(DEFMETHOD Ï4(show-clos-generic-function-details :generate-itemÏ*) ()
"Ï2Makes the inspector item list for the details of a Generic function. 
 This involves grovling over the diassembled code for the fef of the GF
 and deducing sundry things about it, such as the specials bound or the
 slots accessed.  These are all displayed in sections devoted to a particular
 topic, usually with one item on a line, e.g. on local var per line.Ï*"
  (VALUES
    (MULTIPLE-VALUE-BIND
      (referenced-ivars referenced-keywords problem
       referenced-functions referenced-generic-functions args returned-values
       locals specials-referenced specials-bound)
	(ivars-and-messages-in-method aux-data)
      (IGNORE problem)
     `(,*blank-line-item*
       ((:font 1 "Ï3Details of Ï*")
	(:item1 instance
	    ,(allocate-data 'show-clos-generic-function-details data aux-data))
	(:font 1 "Ï3 (Class of function object Ï*")
	(:item1 instance
		,(allocate-data 'show-clos-class (class-of-gf-safe aux-data)))
	(:font 1 "Ï3)Ï*"))
       ,*blank-line-item*
       ((:font 1 "Ï3Source FileÏ*")
	(:colon 40)
       ,(path-string-1
	  (si:function-spec-get (generic-function-name-safe aux-data)
				:source-file-name)
	  'DEFUN))
       ,*blank-line-item*
       ,@(generic-function-arglist-items aux-data args returned-values)
       ,*blank-line-item*
       ((:font 1 "Ï3Documentation:Ï*"))
       ,@(LET ((doc (DOCUMENTATION aux-data)))
	   (IF (AND doc (NOT (EQUAL "" doc)))
	       (break-string-into-lines doc)
	       *no-items*))
       ,*blank-line-item*
       ((:font 1 "Ï3Method CombinationÏ*")
	(:colon 40)
	("Ï3~SÏ*" ,(generic-function-method-combination-safe aux-data)))
       ,*blank-line-item*
       ((:font 1 "Ï3Method ClassÏ*")
	(:colon 40)
	(:item1 instance ,(allocate-data 'show-clos-class
			      (generic-function-method-class-safe aux-data))))
       ,*blank-line-item*
       ((:font 1 "Ï3Associated Methods:Ï*"))
       ,@(LET ((methods (generic-function-methods-safe aux-data)))
	      (IF methods
		  (CONS *clos-method-display-columns*
			(LOOP for meth in methods collect
			      `((:item1 instance
					,(allocate-data
					   'show-clos-method-details
							data meth)))))
		  *no-items*))
       ,*blank-line-item*
       ((:font 1 "Ï3Argument Precedence OrderÏ*")
	(:colon 40)
	("Ï3~SÏ*" ,(argument-precedence-order-safe aux-data)))
       ,*blank-line-item*
       ((:font 1 "Ï3DeclarationsÏ*")
	(:colon 40)
	,(IF (generic-function-declarations-safe aux-data)
	     `("Ï3~SÏ*" ,(generic-function-declarations-safe aux-data))
	     '(:font 2 "Ï3 noneÏ*")))
       ,*blank-line-item*
       ;Ï1;Ï* TAC 08-18-89Ï1 - removing PCL support Ï*
       ;Ï1; Ï*((:font 1 ,(IF (iwmc-class-p-safe aux-data)
       ;Ï1;Ï*		      ""
       ;Ï1;Ï*		      "Ï3Referenced Slots:Ï*")))
       ((:font 1 "Ï3Referenced Slots:Ï*"))
       ,@(referenced-instance-variables-details aux-data referenced-ivars)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Keywords (possibly messages passed):Ï*"))
       ,@(referenced-keywords-details referenced-keywords)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Generic Functions:Ï*"))
       ,@(referenced-generic-functions-details
	    referenced-generic-functions)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Functions:Ï*"))
       ,@(referenced-functions-details referenced-functions)
       ,*blank-line-item*
       ((:font 1 "Ï3Locals:Ï*"))
       ,@(locals-details locals)
       ,*blank-line-item*
       ((:font 1 "Ï3Referenced Specials:Ï*"))
       ,@(referenced-specials-details specials-referenced)
       ,*blank-line-item*
       ((:font 1 "Ï3Specials Bound:Ï*"))
       ,@(bound-specials-details specials-bound)
       ,*blank-line-item*
       ((:font 1 "Ï3Macros Expanded:Ï*"))
       ,@(macros-expanded-details (get-fef-from-object aux-data))
       ,*blank-line-item*
       ((:font 1 "Ï3Interpreted Definition:Ï*"))
       ,@(interpreted-definition-details (get-fef-from-object aux-data))
       ))
    `(:font fonts:hl12bi :string
	    ,(FORMAT nil "Ï3~AGeneric-function ~sÏ*"
		     ;Ï1; TAC 08-17-89 - removing pcl supportÏ*
		     ;Ï1; Ï*(IF (iwmc-class-p-safe aux-data) "Ï3PCL Ï*" "")
		     ""
		     (generic-function-name-safe aux-data)))))

(DEFMETHOD Ï4(show-clos-generic-function-details :helpÏ*) ()
  (LET ((name (generic-function-name-safe aux-data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying sundry details
about the generic function ~S.Ï*"
	    name)))

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

(DEFVAR Ï4*clos-generic-function-operations-menu*Ï*
	'(("Ï3InspectÏ*" :value :inspect-generic-function
	   :documentation "Ï3Show information about this generic-function:
slots and methods referenced, arglist, documentation, source fileÏ*"
	  )
	  ("Ï3DisassembleÏ*" :value :disassemble-generic-function
	   :documentation
	   "Ï3Use a standard Inspect window to show disassembled code.Ï*"
	  )
	  ("Ï3Edit SourceÏ*" :value :edit-generic-function
	   :documentation "Ï3Edit this generic-function in a Zmacs buffer.Ï*")
	  ("Ï3TraceÏ*" :value :trace-generic-function
	   :documentation "Ï3Invoke a trace window to trace this generic functionÏ*"
	  ))
"Ï2The menu item list for the menu that's put up by right buttoning on a generic
 function.  The :Value of each item in the list must be the name of a method on
 Flavor-Inspector, which takes a generic function as its first arg and the
 associated class as its second (usually ignored).Ï*")

(DEFFLAVOR Ï4show-clos-generic-functionÏ* () (inspection-data)
  (:documentation
"Ï3Displays a generic function.  Actually this flavor is never inspected directly,
 since whenever you click on one a show-clos-generic-function-details is
 inspected.Ï*"))

(DEFMETHOD Ï4(show-clos-generic-function :middle-button-resultÏ*) ()
"Ï2Returns the class, not the GF.Ï*"  ;Ï1; Is this right?Ï*
  data)

(DEFMETHOD Ï4(show-clos-generic-function :aux-dataÏ*) ()
"Ï2Just to make sure that the class gets returned rather than some strange
 method table entry.Ï*"
  data)

(DEFUN Ï4format-a-generic-function-conciselyÏ*
       (gf stream &optional (indent1 *indent1*) (indent2 *indent2*))
"Ï2This is a slightly hairy print method for generic functions.  The reason that
 it's hairy is that we want it to be sensitive to whether the generic function
 class is standard-generic-function or not and whether it's a combined method
 or not.Ï*"
  (IGNORE indent1)
  (CATCH-ERROR
    (LET ((class-name
	    (CATCH-ERROR
	      (STRING-CAPITALIZE (class-name-safe (class-of-safe gf)))
	      nil)))
         (LET ((gf-name (LIST gf t (generic-function-name-safe gf))))
	      (IF (OR (NOT class-name)
		      (directly-standard-generic-function-p-safe gf))
		  (FORMAT stream "Ï3~ý~VT~SÏ*"
			  gf-name indent2 (ARGLIST gf))
		  (FORMAT stream "Ï3~ý ~ý~VT~SÏ*"
			  (LIST (class-of-safe gf) t class-name)
			  gf-name indent2 (ARGLIST gf)))))
    nil))

(DEFMETHOD Ï4(show-clos-generic-function :format-conciselyÏ*) (STREAM)
"Ï2Prints out the generic function simply.  If it's being printed into the
 history window then we don't want to have any tabbing between the GF class,
 the GF name and the arglist, otherwise we'll take the dynamically inherited
 tabbing.Ï*"
  (IF (in-history-window-p stream)
      (PROGN (FORMAT stream "Ï3~AGeneric Function Ï*"
		     ;Ï1; TAC 08-17-89 - removing pcl supportÏ*
		     ;Ï1; Ï*(IF (iwmc-class-p-safe data) "Ï3PCL Ï*" ""))
		     "")
	     (format-a-generic-function-concisely data stream 0 0))
      (PROGN (IF *dont-have-initial-space*
		 nil
		 (FORMAT stream "Ï3 Ï*"))
	     (format-a-generic-function-concisely data stream))))

;Ï1*************Ï*
;Ï1 TAC 08-04-89 - better version of this in GENERAL-INSPECTORÏ*
;Ï1(defmethod (show-clos-generic-function :who-line-doc) (ignore &optional ignore)Ï*

(DEFMETHOD Ï4(flavor-inspector :inspect-generic-functionÏ*) (generic-function class)
"Ï2Given a generic function inspects its details.Ï*"
  (SEND self :inspect-thing 'show-clos-generic-function-details
	class generic-function))

;Ï1*************Ï*
;Ï1 TAC 08-04-89 - better version is in GENERAL-INSPECTORÏ*
;Ï1(defmethod (flavor-inspector :disassemble-generic-function)Ï*

(DEFMETHOD Ï4(flavor-inspector :edit-generic-functionÏ*) (generic-function class)
"Ï2Given a generic function edits its source it.Ï*"
  (IGNORE class)
  (ED (generic-function-name-safe generic-function)))

(DEFMETHOD Ï4(flavor-inspector :trace-generic-functionÏ*) (generic-function class)
"Ï2Given a generic function traces it.Ï*"
  (IGNORE class)
  (trace-via-menus (generic-function-name-safe generic-function)))

(DEFUN Ï4select-clos-generic-function-operationsÏ*
       (generic-function flavor-inspector current-class
	&optional selection)
"Ï2This is the function that gets called when the user right buttons on a generic
 function.  It pops up a menu and, if the user clicks on something, invokes
 a method on the flavor inspector to process the menu selection.Ï*"
  (LET ((choice
	  (OR selection
	      (ucl::smart-menu-choose
		*clos-generic-function-operations-menu* :label
		(FORMAT () "Ï3~sÏ*"
			(FUNCTION-NAME
			 (generic-function-name-safe generic-function)))))))
       (IF choice
	   (SEND flavor-inspector choice generic-function current-class)
	   nil)))

(DEFMETHOD Ï4(show-clos-generic-function :handle-mouse-clickÏ*)
	   (blip flavor-inspector)
"Ï2Handles mouse clicks for generic functions.Ï*"
  (LET ((current-flavor
	  (CATCH-ERROR (SEND (SEND (THIRD blip) :current-object) :data) nil)))
    (SELECTOR (FOURTH blip) =
      (#\Mouse-l-1
       (select-clos-generic-function-operations
	 data flavor-inspector
	 current-flavor :inspect-generic-function))
      (#\mouse-l-2 (SEND flavor-inspector :inspect-info-left-2-click))
      (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
       (#\Mouse-r-1
       (select-clos-generic-function-operations
	 data flavor-inspector current-flavor))
      (t (BEEP)))))

(DEFMETHOD Ï4(show-clos-generic-function :generate-itemÏ*) ()
"Ï2This isn't actually invoked (or it shouldn't be).  It's here just in case.Ï*"
  (VALUES `(,*blank-line-item*
	    ((:font 1 "Ï3Details of Ï*")
	     (:item1 instance
		     ,(allocate-data 'show-clos-generic-function data)))
	    ,*blank-line-item*
	    ((:font 1 "Ï3Data:      Ï*")
	     (:item1 instance ,data)))
	  `(:font fonts:hl12bi :string
		  ,(FORMAT nil "Ï3CLOS~{ ~s~}Ï*"
			   (generic-function-name-safe data)))))

(DEFMETHOD Ï4(show-clos-generic-function :helpÏ*) ()
  (LET ((name (generic-function-name-safe data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying the
generic function ~S.Ï*"
	    name)))

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

(DEFFLAVOR Ï4show-clos-instance-variableÏ*
	   () (auxiliary-data-mixin class-operation-mixin)
  (:documentation
"Ï3Shows interesting things about a clos instance variable.  Aux-data holds
 the slot descriptor.  Data holds the class that defined it.Ï*"))

(DEFMETHOD Ï4(show-clos-instance-variable :format-conciselyÏ*) (STREAM)
"Ï2Prints out differently if we're in a history window.  The it says \"Slot\"
 before the slot name, otherwise it just prints out the slot name.Ï*"
  (IF (in-history-window-p stream)
      (FORMAT stream "Ï3Slot ~sÏ*" (slotd-name-safe aux-data))
      (FORMAT stream "Ï3~sÏ*" (slotd-name-safe aux-data))))

(DEFMETHOD Ï4(show-clos-instance-variable :middle-button-resultÏ*) ()
"Ï2Returns the slot descriptor.Ï*"
  aux-data)

(DEFMETHOD Ï4(show-clos-instance-variable :handle-mouse-clickÏ*)
	   (blip flavor-inspector)
"Ï2Handles L, M and L2 clicks on slots.Ï*"
  (SELECTOR (FOURTH blip) =
    (#\mouse-l-1 (SEND flavor-inspector :inspect-info-left-click))
    (#\mouse-l-2 (SEND flavor-inspector :inspect-info-left-2-click))
    (#\mouse-m-1 (SEND flavor-inspector :inspect-info-middle-click))
    (otherwise (BEEP))))

(DEFUN Ï4comma-separateÏ* (LIST)
"Ï2Given a list of inspector items, it returns a list of similar items only
 when the items are printed out they will apear as a comma separated list
 of mouse-sensitive items.Ï*"
  (IF (REST list)
      (CONS (FIRST list)
	    (CONS '(:font 2 "Ï3, Ï*") (comma-separate (REST list))))
      (IF list
	  list
	 `((:font 2 "Ï3noneÏ*")))))

(DEFUN Ï4slot-function-itemsÏ* (FUNCTION slot)
"Ï2Given a function to read something from a slot description, it turns the
 list derived from applying that function to Slot into a list of sensitive items
 that will be comma separated when they appear.Ï*"
  (comma-separate (MAPCAR #'make-slot-function-item (FUNCALL function slot))))

(DEFMETHOD Ï4(show-clos-instance-variable :generate-itemÏ*) ()
"Ï2Displays all sorts of interesting things about slots.Ï*"
  (VALUES
   (MULTIPLE-VALUE-BIND (items special-comb?)
     (collect-clos-method-items
       (sort-clos-methods (class-direct-methods-safe data))
       #'(lambda (method) (method-references-slot method aux-data)))
     `(,*blank-line-item*
       ((:font 1 "Ï3Defining ClassÏ*") (:colon 20)
	(:item1 instance ,(allocate-data 'show-clos-class data)))
       ,*blank-line-item*
       ((:font 1 "Ï3TypeÏ*") (:colon 20)
	(:item1 named-structure-value ,(slotd-type-safe aux-data)))
       ,*blank-line-item*
       ((:font 1 "Ï3AllocationÏ*") (:colon 20)
	,@(LET ((alloc (slotd-allocation-safe aux-data)))
	       (IF (CONSP alloc)
		   `((:font 2 ,(FORMAT nil "Ï3~A Ï*" (FIRST alloc)))
		     (:item1 instance
			     ,(allocate-data 'show-clos-class (SECOND alloc))))
		   `((:font 2 ,(FORMAT nil "Ï3~AÏ*" alloc))))))
       ,*blank-line-item*
       ((:font 1 "Ï3Documentation:Ï*"))
       ,@(LET ((doc (DOCUMENTATION aux-data)))
	   (IF (AND doc (NOT (EQUAL "" doc)))
	       (break-string-into-lines doc)
	       *no-items*))
       ,*blank-line-item*
       ((:font 1 "Ï3ReadersÏ*") (:colon 20)
	,@(slot-function-items 'slotd-readers-safe aux-data))
       ,*blank-line-item*
       ((:font 1 "Ï3WritersÏ*") (:colon 20)
	,@(slot-function-items 'slotd-accessors-safe aux-data))
       ,*blank-line-item*
       ((:font 1 "Ï3InitformÏ*") (:colon 20)
	(:item1 named-structure-value ,(slotd-initform-safe aux-data)))
       ,*blank-line-item*
       ((:font 1 "Ï3InitargsÏ*") (:colon 20)
	,@(comma-separate
	    (MAPCAR #'(lambda (x) `(:item1 named-structure-value ,x))
		    (slotd-initargs-safe aux-data))))
       ,*blank-line-item*
       ((:font 1 "Ï3Methods of Ï*")
	(:item1 instance ,(allocate-data 'show-clos-class data))
	(:font 1 "Ï3 referencing slot Ï*")
	(:item1 instance
		,(allocate-data 'show-clos-instance-variable data aux-data))
	(:font 1 ,(IF special-comb? "Ï3.Ï*" "Ï3:Ï*")))
       ,@(WHEN special-comb?
	   '(((:font 1 "Ï3 * = special method combination typeÏ*"))))
       ,*blank-line-item* . ,(IF items
			       (CONS *clos-method-display-columns-2* items)
			       *no-items*)))
   `(:font fonts:hl12bi :string
	   ,(FORMAT () "Ï3Slot ~S's detailsÏ*" (slotd-name-safe aux-data)))))

(DEFUN Ï4method-references-slotÏ* (method slotd)
"Ï2Is true if the method Method in some way references the slot named by the
 slot descriptor Slotd.Ï*"
  (MULTIPLE-VALUE-BIND (ivars) (ivars-and-messages-in-method method)
    (ASSOC slotd ivars)))

(DEFMETHOD Ï4(show-clos-instance-variable :helpÏ*) ()
  (LET ((name (slotd-name-safe data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying sundry details
about the slot ~S.Ï*"
	    name)))

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

(DEFFLAVOR Ï4show-clos-instance-variablesÏ* () (class-operation-mixin)
  (:documentation
"Ï3Shows all of the slots for a clos class, separated by the class
 that defined them.Ï*"))

(DEFMETHOD Ï4(show-clos-instance-variables :format-conciselyÏ*) (STREAM)
"Ï2Says \"Foo's slots\" for a class named Foo.Ï*"
  (FORMAT stream "Ï3~ý's slotsÏ*"
	  (LIST data nil (class-pretty-name data (in-history-window-p stream)))))

(DEFMETHOD Ï4(show-clos-instance-variables :middle-button-resultÏ*) ()
"Ï2Returns the class itself.Ï*"
  data)

(DEFVAR Ï4*clos-ivar-column-headers*Ï*
	`(:font 3 ,(FORMAT nil "Ï3 SlotÏ*"))
"Ï2The heading for the display of slot names in the inspector.  Actually this is
 a bit redundant, since it doesn't do much.Ï*")

(DEFUN Ï4print-object-just-as-nameÏ* (instance stream &optional (level 0))
"Ï2If instance has a name slot then it prints that name, otherwise it prints
 the whole thing.  This allows the decoupling of the printed representation
 of something from its mouse-sensitive behaviour.  For instance, a slot accessor
 might really have the full printed preresentation \"Standard-Generic-Function
 FOO ((Self Bar))\" or some such.  This function would make it appear simply as
 FOO, only you'd get the whole thing if you moused on it.  It's rather like
 the ~ý format directive.Ï*"
  (LET ((thing (OR (name-safe (SEND instance :data)) instance)))
       (inspection-data-print-item-concisely thing stream level)))

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

(DEFUN Ï4make-slot-function-itemÏ* (fn)
"Ï2Makes an inspector item for a slot reader/writer/accessor function, Fn.
 Fn can be either a symbol that names a function or a cons that names a setf
 method.Ï*"
  `(:item1 instance
	  ,(allocate-data 'show-clos-generic-function
			  (get-gf-for-slot-function fn))
	   print-object-just-as-name))

(DEFUN Ï4item-for-slot-functionÏ* (slot key name)
"Ï2For a slot descriptor Slot, and a key function, which can extract, e.g., the
 reader functions from the SlotD using the key function Key, returns the
 inspector item for the functions extracted.  It there aren't any then it
 generates an item that says that there aren't any.Ï*"
  (IF (FUNCALL key slot)
     `(,*blank-line-item*
       (:font 2 ,(STRING-APPEND "Ï3        Ï*" (STRING-CAPITALIZE name) "Ï3s: Ï*"))
       ,*blank-line-item*
       ,@(comma-separate (MAPCAR #'make-slot-function-item (FUNCALL key slot))))
     `((:font 2 ,(STRING-APPEND "Ï3 no Ï*" name "Ï3s Ï*")))))

(DEFUN Ï4clos-local-instance-variable-itemÏ* (slotd inherited-class)
"Ï2Generates a big long item for a slot descriptor SlotD, which was inherited
 from the class Inherited-Class.  The item shows all of the readers, writers,
 accessors and the initform.  (They might not fit on a line, though but the
 user can always inspect the details.Ï*"
 `(,*one-space-item*
   (:item1 instance
	   ,(allocate-data 'show-clos-instance-variable
			   inherited-class slotd))
   (:colon 30)
   ,@(item-for-slot-function slotd #'slotd-accessors-safe "Ï3writerÏ*")
   ,@(item-for-slot-function slotd #'slotd-readers-safe "Ï3readerÏ*")
   ,@(IF (EQUAL (slotd-initform-safe slotd) '(nil))
	 `((:font 2 "Ï3 no initform Ï*"))
	 `((:font 2 "Ï3 Initform: Ï*")
	   (:item1 instance
		   ,(allocate-data 'show-value (slotd-initform-safe slotd) nil))))))

(DEFUN Ï4flavors-local-instance-variable-itemÏ*
       (var inherited-flavor of-flavor)
"Ï2Generates an item for instance variables inherited from a flavor.  Var is a 
 symbol that names the ivar, Inherited-Flavor is the flavor that defined the
 ivar and Of-Flavor is the flavor that is built on Inherited-Flavor.
 This was cribbed from the flavor inspector.Ï*"
  (DECLARE (SPECIAL *init-options?*))
  (LET ((entry (FIND-IF #'(lambda (x)
			    (OR (AND (SYMBOLP x) (EQUAL x var))
				(AND (CONSP x) (EQUAL var (FIRST x)))))
			(si::flavor-local-instance-variables inherited-flavor))))
 `(,*one-space-item*
   (:item1 instance
	   ,(allocate-data 'show-instance-variable var))
   (,*space-format* ,(- 36 (symbol-string-length var)))
   ,*one-space-item*
   ,(FORMAT ()
      "Ï3 ~:[   ~; G ~]     ~:[   ~; S ~]    ~:[   ~; I ~]    ~:[    ~; Sp ~]   Ï*"
      (MEMBER var (si::flavor-gettable-instance-variables inherited-flavor)
	      :test #'EQ)
      (MEMBER var (si::flavor-settable-instance-variables inherited-flavor)
	      :test #'EQ)
      (MEMBER var (MAPCAR #'CDR
			  (si::flavor-inittable-instance-variables
			    inherited-flavor)) :test #'EQ)
      (MEMBER var (si::flavor-special-instance-variables inherited-flavor)
	      :test #'EQ))
   ,(IF (SYMBOLP entry)
	'(:font 2 "Ï3unbound        Ï*")
	`(:item1 instance ,(allocate-data 'show-value (CADR entry) 24)))
   ,*one-space-item*
   ,@(LET* ((init (INTERN var 'keyword))
	    (f-plist (si::flavor-plist of-flavor))
	    (init-plist (GETF f-plist :default-init-plist))
	    (value (GETF init-plist init)))
       (WHEN (AND value
		  (MEMBER init
			  (GETF f-plist 'si::all-inittable-instance-variables)
			  :test #'EQ))
	 (SETQ *init-options?* t)
	 `((:item1 instance ,(allocate-data 'show-value value nil))))))))

(DEFUN Ï4clos-local-instance-var-item-listÏ*
       (inherited-variables inherited-class of-class)
"Ï2Generates an item list for slots inherited from a class.  Inherited-Variables
 are slot descriptors that name the slots, Inherited-Class is the class that
 defined the slots and Of-Class is the class that is built on Inherited-Class.
 If Inherited-Class is a flavor, then the right thing happens and the slots
 are inspected as Flavors slots.Ï*"
  (LET ((*init-options?* nil)
	(flavor-p nil)
       )
       (DECLARE (SPECIAL *init-options?*))
       (LET ((items
	       (LOOP for entry in inherited-variables
		     collect
		     (IF (slotd-p-safe entry)
			 (clos-local-instance-variable-item
			   entry inherited-class
			 )
			 (PROGN (SETQ flavor-p t)
				(flavors-local-instance-variable-item
				  (ucl::first-if-list entry)
				  (GET (class-name-safe inherited-class)
				       'si::flavor)
				  (GET (class-name-safe of-class) 'si::flavor)))))))
	    (IF flavor-p
		(IF *init-options?*
		    `((,*ivar-column-headers*
		       (:font 3 ,(FORMAT () "Ï3~s's InitializationsÏ*"
					 (flavor-or-class-name of-class))))
		      ,@items)
		    `((,*ivar-column-headers*) ,@items))
		`((,*clos-ivar-column-headers*) ,@items)))))

(DEFMETHOD Ï4(show-clos-instance-variables :generate-itemÏ*) ()
"Ï2Makes an item list for instance variables of a clos class.  The right
 thing happens if it inherits from a flavor.Ï*"
  (LET* ((class-name (class-pretty-name data)))
    (VALUES
     `(,*blank-line-item*
       ((:font 1 "Ï3Local to class Ï*")
        (:item1 instance ,(allocate-data 'show-clos-class data))
	(:font 1 "Ï3:Ï*"))
       ,@(IF (class-local-slots-safe data)
	   (clos-local-instance-var-item-list
	     (class-local-slots-safe data) data data)
	   *no-items*)
       ,@(LOOP for cl in (REST (class-precedence-list-safe data))
               for local-vars = (class-local-slots-safe cl)
	    append
	    (WHEN local-vars
	      `(,*blank-line-item*
		((:font 1 "Ï3Inherited from Ï*")
                 (:item1 instance ,(allocate-data 'show-clos-class cl))
		 (:font 1 "Ï3:Ï*"))
		,@(clos-local-instance-var-item-list local-vars cl data)))))
     `(:font fonts:hl12bi :string
       ,(FORMAT () "Ï3~A's slotsÏ*" class-name)))))

(DEFMETHOD Ï4(show-clos-instance-variables :helpÏ*) ()
  (LET ((name (class-pretty-name data)))
    (FORMAT nil "
Ï3The inspection pane you just selected is currently displaying information
about all the slots of ~A.  This shows the names of all of the readers and
writers and shows the initform if any for the slot.  Clicking left on a slot
will show more information about that slot.  Clicking on a reader or writer
will show the generic function associated with that operation.Ï*"
	    name)))

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

(DEFFLAVOR Ï4show-all-flavors-and-classesÏ* () (inspection-data)
  ;Ï1; Used just to make allocate-data work on it.  See reference to 'IGNORE below.Ï*
  (:default-init-plist :data 'IGNORE)
  (:documentation
"Ï3This is the class inspector equivalent of the show-all-flavors option in the
 flavor inspector.Ï*"))

(DEFMETHOD Ï4(show-all-flavors-and-classes :middle-button-resultÏ*) ()
"Ï2Nothing to return, so return nil.  Data isn't used i nthis flavor.Ï*"
  nil)

(DEFMETHOD Ï4(show-all-flavors-and-classes :format-conciselyÏ*) (STREAM)
"Ï2Just prints out \"All flavors and classes\" or \"All flavors\" if, for
 some reason clos isn't loaded.  The latter should never be the case in future.Ï*"
  (FORMAT stream (IF (clos-p) "Ï3All flavors and classesÏ*" "Ï3All flavorsÏ*")))

(DEFMETHOD Ï4(show-all-flavors-and-classes :who-line-docÏ*)
	   (IGNORE &optional ignore)
"Ï2A who line doc string returning method for the display of all flavors
 and classes.Ï*"
  (IF (clos-p)
      '(:any "Ï3Inspect this flavor or class informationÏ*")
      '(:any "Ï3Inspect this flavor informationÏ*")))

(DEFMETHOD Ï4(show-all-flavors-and-classes :handle-mouse-clickÏ*)
	   (blip flavor-inspector)
"Ï2A very generic seeming mouse click method for this flavor.Ï*"
  (SELECTOR (FOURTH blip) =
    (#\Mouse-l-1
     (SEND flavor-inspector :inspect-info-left-click))
    (#\Mouse-m-1
     (SEND flavor-inspector :inspect-info-middle-click))
    ;Ï1; Could we put anything interesting on right click?  MaybeÏ*
    ;Ï1; Flavor-name apropos, or some complex query for locating sets ofÏ*
    ;Ï1; flavors with common characteristics?Ï*
    (t (BEEP))))

(DEFMETHOD Ï4(show-all-flavors-and-classes :generate-itemÏ*) ()
"Ï2Generates the items for the display of flavors and classes. 
 The flavors are shown separatemy from the classes.  This whole diaplay
 could be very large.Ï*"
  (VALUES
   `(,*blank-line-item*
     ((:font 1 "Ï3Currently defined flavors: Ï*"))
     ,*blank-line-item*
     ;Ï1; Sort flavors by package, then alphabeticallyÏ*
     ,@(LOOP for flavor in
	  (SORT (COPY-LIST *all-flavor-names*)
		#'(lambda (f1 f2)
		    (LET ((p1 (PACKAGE-NAME (SYMBOL-PACKAGE f1)))
			  (p2 (PACKAGE-NAME (SYMBOL-PACKAGE f2))))
		      (OR (STRING< p1 p2)
			  (AND (STRING= p1 p2) (STRING< f1 f2))))))
	  collect
	  `((:item1 instance
		    ,(allocate-data 'show-flavor (GET flavor 'si::flavor)))))
    ,@`(,*blank-line-item*
	,(IF (clos-p)
	    '((:font 1 "Ï3Currently defined classes: Ï*"))
	    '((:font 1 "")))
	,*blank-line-item*
	;Ï1; Sort classes by package, then alphabeticallyÏ*
	,@(LOOP for class in
		(SORT (all-class-names)
		      #'(lambda (f1 f2)
			  (LET ((p1 (PACKAGE-NAME (SYMBOL-PACKAGE f1)))
				(p2 (PACKAGE-NAME (SYMBOL-PACKAGE f2))))
			    (OR (STRING< p1 p2)
				(AND (STRING= p1 p2) (STRING< f1 f2))))))
		collect
		`((:item1 instance
			  ,(show-a-class-named class))))))
   `(:font fonts:hl12bi :string
	   ,(IF (clos-p) "Ï3All flavors and classesÏ*" "Ï3All flavorsÏ*"))))

(DEFMETHOD Ï4(show-all-flavors-and-classes :helpÏ*) ()
  (FORMAT nil (IF (clos-p)
		  "
Ï3The inspection pane you just selected is currently displaying all defined
flavors and CLOS classes.  The flavors and classes are sorted alphabetically,
first by symbol package, then by symbol name.  This makes it easier for you to
inspect related flavors and classes, since most related flavors and classes
share the same symbol package.Ï*"
		  "
Ï3The inspection pane you just selected is currently displaying all defined
flavors.  The flavors are sorted alphabetically, first by symbol package,
then by symbol name.  This makes it easier for you to inspect related flavors,
since most related flavors share the same symbol package.Ï*")))

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

(DEFFLAVOR Ï4debug-classÏ* ()
  (flavor-operation-mixin)
  (:documentation :special-purpose
"Ï3A flavor used by the flavor inspector in order to represent a request be
 the user to execute the debug class command for a given class.  It is
 somewhat like Show-clos-class-details only it shows useful things that might
 cause the user problems like shadowed methods.Ï*"))

(DEFMETHOD Ï4(debug-class :middle-button-resultÏ*) ()
  data)

(DEFMETHOD Ï4(debug-class :format-conciselyÏ*) (STREAM)
"Ï2Prints the instance of Debug-Class in a simple manner.  This is used
to display the class in the inspector's history window and such like.Ï*"
  (FORMAT stream "Ï3~ý's debug dataÏ*"
          (LIST (allocate-data 'show-clos-class data) nil
		(class-pretty-name data (in-history-window-p stream)))))

(DEFUN Ï4get-class-ivsÏ* (class)
"Ï2If passed a class this function returns values which are:
   The superclasses of the class, excluding itself
   A list of all of the slots for all of the components.Ï*"
  (DECLARE (VALUES superclasses all-slots))
  (LET ((components (class-precedence-list-safe class)))
       (VALUES components (MAPCAR #'class-local-slots-safe components))))

(DEFUN Ï4get-flavor-and-class-ivsÏ* (class)
"Ï2Given a flavor or a class, returns two values:
   The components of the class/flavor, excluding itself
   A list of all of the instance variables/slots for all of the components.Ï*"
  (DECLARE (VALUES superclassesor-component-flavors all-slots-or-ivs))
  (IF (GET (class-name-safe class) 'si::flavor)
      (get-ivs (GET (class-name-safe class) 'si::flavor))
      (IF (class-p-safe class) (get-class-ivs class) nil)))

(DEFUN Ï4find-slotdÏ* (name class)
"Ï2Given the name of a slot and a class, finds a slot descriptor for that class
 that has Name as its name.Ï*"
  (FIND-IF #'(lambda (x) (EQUAL (slotd-name-safe x) name))
	   (class-local-slots-safe class)))

(DEFUN Ï4reslotd-ifyÏ* (clash)
"Ï2Is passed a clashing slot specification, which is a list of the form:
  a) (slot-name clashing-with-slot-name)
  b) class that owned slot-name
  c) class that owned clashing-with-slot-name
 It returns a list just like the first, only the slots have been substitituted
 for the slot descriptors that describe them.Ï*"
  (LIST (LIST (IF (class-p-safe (SECOND clash))
		  (find-slotd (FIRST (FIRST clash)) (SECOND clash))
		  (FIRST (FIRST clash)))
	      (IF (class-p-safe (THIRD clash))
		  (find-slotd (SECOND (FIRST clash)) (THIRD clash))
		  (SECOND (FIRST clash))))
	(SECOND clash)
	(THIRD clash)))

(DEFUN Ï4find-multiple-slot-definitionsÏ* (components iv-lists &rest args)
"Ï2Given a list of the component classes/flavors and a list of the iv lists of
 these components it returns a list of the slots that clashed with one another.
 Args are extra args that get passed to find-multiple-definitions, namely
 DePackage-p.  What gets returned is a list, eahc of whose elements has the
 following structure.
  a) (slot-name clashing-with-slot-name)
  b) class that owned slot-name
  c) class that owned clashing-with-slot-name
 If the slots are slots from CLOS classes then they are represented as slot
 descriptors, otherwise as the symbols that name the ivars.Ï*"
  (LET ((clashes
	  (APPLY #'find-multiple-definitions
	    components
	    (MAPCAR
	      #'(lambda (ivs)
		  (MAPCAR #'(lambda (x)
			      (IF (slotd-p-safe x) (slotd-name-safe x) x))
			    ivs))
		iv-lists)
	    args)))
       (MAPCAR #'reslotd-ify clashes)))

(DEFUN Ï4show-an-ivÏ* (ivar-or-slotd class)
"Ï2Given either the name of an ivar or a slot descriptor and the flavor/class
 respectively that defined the ivar or slot, it returns an allocated data
 item for that thing of the right flavor.Ï*"
  (IF (slotd-p-safe ivar-or-slotd)
      (allocate-data 'show-clos-instance-variable class ivar-or-slotd)
      (allocate-data 'show-instance-variable
		     (IF (class-p-safe ivar-or-slotd)
			 (GET (class-name-safe ivar-or-slotd) 'si::flavor)
			 ivar-or-slotd))))

(DEFUN Ï4show-a-fl-or-clÏ* (data)
"Ï2Allocates data to show either a flavor or a class, depending on what's needed.Ï*"
  (IF (class-p-safe data)
      (allocate-data 'show-clos-class data)
      (allocate-data 'show-flavor data)))

(DEFUN Ï4in-stringÏ* (data)
"Ï2If data is a class then it returns \" in class \", otherwise \" in flavor \".Ï*"
  (IF (class-p-safe data)
      "Ï3 in class Ï*"
      "Ï3 in flavor Ï*"))

(DEFUN Ï4get-local-undefined-class-componentsÏ* (class)
"Ï2Given a class, it returns a list of all of the declared superclasses
 of the class that have not been defined.Ï*"
  (LET ((LIST (class-precedence-list-safe class t)))
       (REMOVE-IF #'(lambda (x) (class-p-safe x)) list)))

(DEFUN Ï4collect-undefined-class-componentsÏ* (class)
"Ï2Given a class this function returns a list of all of the
 components of that class, which have not yet been defined, including any that
 have not been defined for superclasses of Class.Ï*"
  (LET ((undefined-components (get-local-undefined-class-components class)))
       (LET ((result-from-components
	       (REMOVE nil (MAPCAR #'collect-undefined-class-components
				   (REMOVE class
					   (class-precedence-list-safe class))))))
            (uniqueise (APPEND (map-with-args #'LIST
				  undefined-components class)
			       (APPLY #'APPEND result-from-components))))))

(DEFUN Ï4primary-methodsÏ* (class)
"Ï2Given a class returns a list of all of the primary methods defined directly
 by that class.  This helps us to find which ones have been shadowed.Ï*"
  (LET ((all (class-direct-methods-safe class)))
       (REMOVE-IF-NOT 'method-primary-p-safe all)))

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

(DEFUN Ï4shadows-pÏ* (specs1 specs2 so-far)
"Ï2Is true if the method spec spec1 for a primary method shadows the method
 defined by spec2.  So-far accumulates whether we currently think that
 they shadow.Ï*"
  (IF specs1
      (IF specs2
	  (LET ((shadows (class-shadows (FIRST specs1) (FIRST specs2))))
	       (IF (EQUAL :disjoint shadows)
		   nil
		   (shadows-p (REST specs1) (REST specs2) (OR shadows so-far))))
	  so-far)
      so-far))

(DEFUN Ï4is-shadowed-by-anyÏ* (meth methods)
"Ï2Is true if the primary method Meth is shadowed by any of the methods in
 Methods.  Returns the sublist of Methods that actually do shadow Meth.Ï*"
  (LET ((meth-specs (unparse-specializers-safe meth))
	(gen (method-generic-function-safe meth)))
       (REMOVE-IF-NOT
	 #'(lambda (x)
	     (AND (EQUAL (method-generic-function-safe x) gen)
		  (shadows-p (unparse-specializers-safe x) meth-specs nil)))
	   methods)))
		 
(DEFUN Ï4get-shadowed-clos-methods-1Ï* (class)
"Ï2Gets a list of all of the methods of superclasses of Class
 that are shadowed by any class's methods.  It returns a list
 of lists, each element of which is of the form:
  a) shadowed method
  b) shadowing method
  c) shadowed superclass
  d) shadowing class.Ï*"
  (LET ((local-primaries (primary-methods class))
	(components (REMOVE class (class-precedence-list-safe class))))
       (LET ((sub-methods
	       (MAPCAR #'(lambda (x)
			   (map-with-args 'LIST (primary-methods x) x))
		         components)))
	    (APPLY #'APPEND
		   (LOOP for (meth superclass) in (APPLY #'APPEND sub-methods)
			 when (is-shadowed-by-any meth local-primaries)
			 collect (map-with-args #'LIST
				   (is-shadowed-by-any meth local-primaries)
				   meth superclass class))))))

(DEFUN Ï4get-shadowed-clos-methodsÏ* (class)
"Ï2Gets a list of all of the methods of superclasses of Class
 that are shadowed by any class's methods.  It returns a list
 of lists, each element of which is of the form:
  a) shadowed method
  b) shadowing method
  c) shadowed superclass
  d) shadowing class.Ï*"
  (APPLY
    #'APPEND
    (MAPCAR 'get-shadowed-clos-methods-1 (class-precedence-list-safe class))))

(DEFMETHOD Ï4(debug-class :generate-itemÏ*) ()
"Ï2This method generates a window item for displaying in the flavor inspector
which shows debug information associated with the class in question.
This window item is made up of a number of window items describing the state
of affairs in detail.Ï*"
  (LET* ((class-name (class-pretty-name data))
	 (flavor (GET (class-name-safe data) 'si::flavor))
	 (class data)
         (clashes (MULTIPLE-VALUE-BIND (components ivs)
		      (get-flavor-and-class-ivs class)
		    (find-multiple-slot-definitions components ivs nil)))
	 (package-clashes (MULTIPLE-VALUE-BIND (components ivs)
			      (get-flavor-and-class-ivs class)
			    (find-multiple-slot-definitions components ivs t)))
	 (shadowed-methods (AND flavor (get-shadowed-methods flavor)))
	 (shadowed-clos-methods (get-shadowed-clos-methods class))
	 (undefined-class-components
	   (collect-undefined-class-components class))
	 (unsatisfied-flavors
	   (AND flavor (list-of-unsatisfied-required-flavors flavor)))
	 (unsatisfied-methods
	   (AND flavor (list-of-unsatisfied-required-methods flavor)))
	 (unsatisfied-ivs
	   (AND flavor (list-of-unsatisfied-required-ivs flavor))))
    (VALUES
      `(,*blank-line-item*
;Ï1; ------------------------------Ï*
	,@(IF clashes
	      `(((:font 1 "Ï3Multiple declarations of the same slots for class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for clash in clashes
	        append `(((:font 3 "Ï3  Ï*")
			  (:item1 instance
			      ,(show-an-iv (FIRST (FIRST clash)) (THIRD clash)))
			  (:font 3 ,(in-string (SECOND clash)))
			  (:item1 instance ,(show-a-fl-or-cl (SECOND clash)))
			  (:font 3 ,(in-string (THIRD clash)))
			  (:item1 instance ,(show-a-fl-or-cl (THIRD clash))))))
;Ï1; ------------------------------Ï*
	,@(IF package-clashes *blank-line-item*)
	,@(IF package-clashes *blank-line-item*)
	,@(IF package-clashes
	      `(((:font 1 "Ï3Declarations of slots with the same PName but are in different packages for class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for clash in package-clashes
	        append `(((:font 3 "Ï3  Ï*")
			  (:item1 instance
			    ,(show-an-iv (FIRST (FIRST clash)) (SECOND clash)))
			  (:font 3 ,(in-string (SECOND clash)))
			  (:item1 instance ,(show-a-fl-or-cl (SECOND clash)))
			  (:font 3 "Ï3 and Ï*")
			  (:item1 instance
			    ,(show-an-iv (SECOND (FIRST clash)) (THIRD clash)))
			  (:font 3 ,(in-string (THIRD clash)))
			  (:item1 instance ,(show-a-fl-or-cl (THIRD clash))))))
;Ï1; ------------------------------Ï*
	,@(IF undefined-class-components *blank-line-item*)
	,@(IF undefined-class-components *blank-line-item*)
	,@(IF undefined-class-components
	      `(((:font 1 "Ï3Undefined components of class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for undefined in undefined-class-components
	        append `(((:item1 instance
			    ,(allocate-data 'show-undefined-clos-class
					    (FIRST undefined)))
			  (:font 3 "Ï3 of class Ï*")
			  (:item1 instance
				  ,(show-a-fl-or-cl (SECOND undefined))))))
;Ï1; ------------------------------Ï*
	,@(IF unsatisfied-flavors *blank-line-item*)
	,@(IF unsatisfied-flavors *blank-line-item*)
	,@(IF unsatisfied-flavors
	      `(((:font 1 "Ï3Unsatisfied required flavors of class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for unsatisfied in unsatisfied-flavors
	        append `(((:item1 instance
			   ,(IF (GET (FIRST unsatisfied) 'si::flavor)
				(allocate-data
				  'show-flavor
				  (GET (FIRST unsatisfied) 'si::flavor))
				(allocate-data
				  'show-undefined-flavor (FIRST unsatisfied))))
			  (:font 3 "Ï3 for flavor Ï*")
			  (:item1 instance
			   ,(allocate-data 'show-flavor (SECOND unsatisfied))))))
;Ï1; ------------------------------Ï*
	,@(IF unsatisfied-methods *blank-line-item*)
	,@(IF unsatisfied-methods *blank-line-item*)
	,@(IF unsatisfied-methods
	      `(((:font 1 "Ï3Unsatisfied required methods of class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for unsatisfied in unsatisfied-methods
	        append `(((:font 1 ,(FORMAT nil "Ï3~SÏ*" (FIRST unsatisfied)))
			  (:font 3 "Ï3 for flavor Ï*")
			  (:item1 instance
			   ,(allocate-data 'show-flavor (SECOND unsatisfied))))))
;Ï1; ------------------------------Ï*
	,@(IF unsatisfied-ivs *blank-line-item*)
	,@(IF unsatisfied-ivs *blank-line-item*)
	,@(IF unsatisfied-ivs
	      `(((:font 1 "Ï3Unsatisfied required instance variables of class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for unsatisfied in unsatisfied-ivs
	        append `(((:font 1 ,(FORMAT nil "Ï3~SÏ*" (FIRST unsatisfied)))
			  (:font 3 "Ï3 for flavor Ï*")
			  (:item1 instance
			   ,(allocate-data 'show-flavor (SECOND unsatisfied))))))
;Ï1; ------------------------------Ï*
        ,@(IF shadowed-clos-methods *blank-line-item*)
	,@(IF shadowed-clos-methods *blank-line-item*)
	,@(IF shadowed-clos-methods
	      `(((:font 1
		 "Ï3Primary CLOS methods of component classes shadowed by class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for shadow in shadowed-clos-methods
	        append `(((:item1 instance
			   ,(allocate-data 'show-clos-method (SECOND shadow))
			   print-unpadded-method)
			  (:font 3 "Ï3 shadowed by  Ï*")
			  (:item1 instance
			   ,(allocate-data 'show-clos-method (FIRST shadow))
			   print-unpadded-method))))
        ,@(IF shadowed-methods *blank-line-item*)
	,@(IF shadowed-methods *blank-line-item*)
	,@(IF shadowed-methods
	      `(((:font 1
	      "Ï3Primary Flavors methods of component flavors shadowed by class Ï*")
		 (:item1 instance ,(allocate-data 'show-clos-class class))
		 (:font 1 "Ï3:Ï*")))
	      nil)
	,@(LOOP for shadow in shadowed-methods
	        append `(((:item1 instance
				  ,(allocate-data 'show-method
						  (FOURTH (SECOND shadow))))
			  (:font 3 "Ï3 of flavor Ï*")
			  (:item1 instance
				  ,(allocate-data 'show-flavor (THIRD shadow)))
			  (:font 3 "Ï3 shadowed by flavor Ï*")
			  (:item1 instance
				 ,(allocate-data 'show-flavor (FIRST shadow))))))
;Ï1; ---------------------------------Ï*
       )
      `(:font fonts:hl12bi :string ,(FORMAT nil "Ï3~A's Debug dataÏ*" class-name)))))

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

;Ï1;; Patches Ï*
;Ï1;; =======Ï*

;Ï1; Stick the class inspector ion the flavor inspector system key.Ï*
(IF (clos-p)
    (add-system-key #\o 'flavor-inspector
     "Ï3Flavor/Class Inspector -- A utility for examining the structure of flavors and CLOS classes.Ï*")
    (add-system-key #\o 'flavor-inspector
     "Ï3Flavor Inspector -- A utility for examining the structure of flavors.Ï*"))

(DEFMETHOD Ï4(flavor-inspector :inspect-objectÏ*) (object)
"Ï2Is passed a symbol that names something that we want to inspect.  This is
 inspected as a flavor or as a class as appropriate.Ï*"
  (CHECK-TYPE object symbol)
  (LET ((thing (inspect-real-value
		 (IF (GET object 'si::flavor)
		     `(:value ,(allocate-data 'show-flavor
					      (GET object 'si::flavor)) ,history)
		     (IF (class-named-safe object t)
			 `(:value ,(allocate-data
				     'show-clos-class
				     (class-named-safe object)) ,history)
			 (FERROR nil (IF (clos-p)
					 "Ï3~S is not a flavor or class.Ï*"
					 "Ï3~S is not a flavor.Ï*")))))))
    ;Ï1; First flush item we will be inspectingÏ*
    (inspect-flush-from-history thing history)
    (SEND history :append-item thing)
    (update-panes)))

;Ï1*************Ï*
;Ï1 TAC 08-04-89 - better version of this GENERAL-INSPECTORÏ*
;Ï1(defun inspect-flavor (&optional (object nil objp))Ï*

(DEFUN Ï4read-flavor-nameÏ* ()
"Ï2Reads a flavor or class name from the user.Ï*"
  (DECLARE (:self-flavor ucl::basic-command-loop))
  (LET ((ucl::typein-modes '(flavor-names class-names))
	(ucl::command-loop-typein? self)
	flavor-name)
    (DECLARE (SPECIAL ucl::typein-modes ucl::command-loop-typein?))
    (SEND self :handle-prompt t (IF (clos-p)
				    "Ï3Flavor\/Class name: Ï*"
				    "Ï3Flavor name: Ï*"))
    (SETQ flavor-name (sys::internal-read-form-or-implicit-list))
    (COND
      ((AND (SYMBOLP flavor-name)
            (OR (GET flavor-name 'si::flavor)
		(class-named-safe flavor-name)))
       (SEND self :handle-prompt)
       flavor-name)
      (t
       (FORMAT t "Ï3** ~s is not a defined flavor or classÏ*" flavor-name)
       (SEND self :handle-prompt)
       (THROW 'ucl::command-abort nil)))))

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

(DEFFLAVOR Ï4flavor-inspectorÏ* () (basic-inspect-frame)
  (:default-init-plist
    :active-command-tables '(flavor-inspector-cmd-table)
    :all-command-tables '(flavor-inspector-cmd-table)
    :menu-panes '((menu flavor-inspector-menu))
    :typein-modes 
    ;Ï1; Modded here by JPR. Ï*
    (IF (clos-p)
	'(method-specs class-instance class-names clos-method-specs
          flavor-instance flavor-names ucl::command-names)
	'(method-specs flavor-instance flavor-names ucl::command-names))
    :basic-help '(fi-doc-cmd)
    ;Ï1; Modded here by JPR.Ï*
    :prompt (IF (clos-p) "Ï3Flavor\/Class\/Method: Ï*" "Ï3Flavor\/Method: Ï*")
    ;Ï1; Activate the special handling of instances of TV:INSPECTION-DATA.Ï*
    ;Ï1; This hack keeps the inspector code from treating mouse-sensitive blipsÏ*
    ;Ï1; containing TV:INSPECTION-DATA instances as normal Lisp objects to inspectÏ*
    ;Ï1; and lets the instances dictate most inspector actions, such asÏ*
    ;Ï1; who-line-documentation when mouse is over the printed representationÏ*
    ;Ï1; of the instance, mouse button operations when it is clicked upon, andÏ*
    ;Ï1; item generation when the blip is inspected.Ï*
    :inspection-data-active? t))

(DEFUN Ï4flavor-inspector-panesÏ* ()
"Ï2Pulled out of the :before :init method to make it a little more modular.Ï*"
  (LIST `(interactor
	   inspector-interaction-pane
	   :label nil
	   :more-p nil
	   ;Ï1:IO-BUFFER ,IOBUFFÏ*
	   :font-map  ,(LIST (FIRST *inspector-font-map*)
			     (SECOND *inspector-font-map*))
	   :who-line-message
 "Ï3To inspect a flavoror class, type its name.  To inspect a method, type <flavor name>
<method name>
Press HELP for a help menu, META-HELP for help on typed expressions.  R2: System Menu.Ï*")
	`(history inspect-history-window  ;Ï1-WITH-MARGIN-SCROLLINGÏ*
		  :line-area-mouse-doc
		  (:mouse-l-1 "Ï3Inspect the indicated dataÏ*"
			      :mouse-m-1 "Ï3Remove it from the Flavor InspectorÏ*")
		  :normal-mouse-documentation
		  (:mouse-l-1 "Ï3Select data to inspectÏ*"
			      :mouse-m-2 "Ï3Lock/Unlock inspector paneÏ*"
			      :mouse-r-2 "Ï3System MenuÏ*"))
	`(menu inspector-menu-pane)))

(DEFUN Ï4flavor-inspector-constraintsÏ* (inspectors noi)
"Ï2Pulled out of the :before :init method to make it a little more modular.Ï*"
  `((:three-panes ,(REVERSE `(interactor menu-history ,@inspectors))
		  ((interactor 4 :lines))
		  ((menu-history
		     :horizontal (3 :lines history)
		     (menu history)
		     ((menu :ask :pane-size))
		     ((history :even))))
		  ,(MAPCAR #'(lambda (name1)
			       `(,name1 :limit (1 36 :lines)
				 ,(/ 0.3s0 (1- noi)) :lines))
			   (CDR inspectors))
		  ((,(CAR inspectors) :even)))
    (:one-pane (,(CAR inspectors) menu-history interactor)
	       ((interactor 4 :lines))
	       ((menu-history
		  :horizontal (3 :lines history)
		  (menu history)
		  ((menu :ask :pane-size))
		  ((history :even))))
	       ((,(CAR inspectors) :even)))
    (:two-horizontal-panes
      ,(REVERSE `(interactor menu-history inspector-2 inspector-1))
      ((interactor 4 :lines))
      ((menu-history :horizontal (3 :lines history) (menu history)
		     ((menu :ask :pane-size))
		     ((history :even))))
      ((inspector-1 0.5))
      ((inspector-2 :even)))
    (:two-vertical-panes
      ,(REVERSE `(interactor menu-history side-by-side))
      ((interactor 4 :lines))
      ((menu-history :horizontal (3 :lines history)
		     (menu history)
		     ((menu :ask :pane-size))
		     ((history :even))))
      ((side-by-side :horizontal (:even)
		     (inspector-2 inspector-1)
		     ((inspector-1 0.5))
		     ((inspector-2 :even)))))
    (:debug (,(CAR inspectors) menu-history interactor)
	    ((interactor 45 :lines))
	    ((menu-history
	       :horizontal (3 :lines history)
	       (menu history)
	       ((menu :ask :pane-size))
	       ((history :even))))
	    ((,(CAR inspectors) :even)))))

(DEFMETHOD Ï4(flavor-inspector :before :initÏ*) (plist)
 ;Ï1; Specify our panes and constraints.  This differs fromÏ*
 ;Ï1; (TV:INSPECT-FRAME :BEFORE :INIT) only in some of the who-line messages weÏ*
 ;Ï1; provide, which are specific to flavor inspectors.Ï*
  (UNLESS inspectors ;Ï1; It didn't use to have this test. JPRÏ*
  (LET ((noi (OR (GET plist :number-of-inspectors) 3)))
    (SETQ panes (flavor-inspector-panes))
    ;Ï1; Add an inspector to PANES, taking into account the number of inspectorÏ*
    ;Ï1; panes requested.  The first inspector is given a typeout pane.Ï*
    ;Ï1; Also initialize INSPECTORS.Ï*
    (DOTIMES (i noi)
      (LET ((name1 (INTERN (FORMAT () "Ï3INSPECTOR-~DÏ*" i) "Ï3TVÏ*")))
	(PUSH `(,name1 ,(IF (= i (1- noi))
			    'inspect-window-with-typeout
			    'inspect-window)
                ;Ï1; Otherwise we get "More Object Above", etc.Ï*
                :current-object-who-line-message
		,(FUNCTION (lambda (current-object)
			     (COND
			       ((EQUAL current-object '(nil))
 "Ï3Flavor/Class Inspection Pane.  To inspect a flavor, type its name.  To inspect a method, type <flavor name> <method name>
Press HELP for a help menu, META-HELP for help on typed expressions.  R2: System Menu.Ï*")
			       ((TYPEP current-object 'flavor-operation-mixin)
				`(:mouse-l-1
				   "Ï3Select data to inspectÏ*"
				   :mouse-m-1 "Ï3Help on currently displayed dataÏ*"
				   :mouse-m-2 "Ï3Lock/Unlock inspector paneÏ*"
				   :mouse-r-1
				    ,(FORMAT
				       ()
				       (IF (clos-p)
					"Ï3Menu of operations on flavor\/class ~sÏ*"
					   "Ï3Menu of operations on flavor ~sÏ*")
				       (flavor-or-class-name
					 (SEND current-object :data)))))
			       (t '(:mouse-l-1 "Ï3Choose an item to inspectÏ*"))))))
              panes)
	(PUSH name1 inspectors)))
    (SETQ constraints (flavor-inspector-constraints inspectors noi)))))

(DEFCOMMAND Ï4(flavor-inspector :options-menuÏ*) ()  
   '(:keys #\Mouse-r 
     :description
     "Ï3A menu of options for the selected (moused) inspection pane.Ï*")
   (IF (MEMBER (THIRD ucl::kbd-input) inspectors :test #'EQ)
     (LET ((inspection-data (SEND (THIRD ucl::kbd-input) :current-object))
	   *flavor-data*)
       (DECLARE (SPECIAL *flavor-data*))
       (COND
	 ((EQUAL inspection-data '(nil))
	  (SEND self :format-message "Ï3MOUSE R is inactive when the inspection pane is empty.Ï*"))
	 ;Ï1; JPR.Ï*
	 ((AND (TYPEP inspection-data 'class-operation-mixin)
	       (class-p-safe (SEND inspection-data :data)))
	  (SETQ *flavor-data* (SEND inspection-data :data))
	  (LET ((call-edit nil))
                   (DECLARE (SPECIAL *flavor-data* call-edit))
                   (w:menu-choose
		     *class-options-menu*
		     :label (FORMAT nil "Ï3Operations on ~SÏ*"
				    (class-name-safe *flavor-data*))
		     :scrolling-p nil)
		   (IF call-edit
		       (ED (class-name-safe *flavor-data*)))))
	 ((AND (TYPEP inspection-data 'flavor-operation-mixin)
	       (TYPEP (SEND inspection-data :data) 'si::flavor))
	  (SETQ *flavor-data* (SEND inspection-data :data))
	  (LET ((call-edit nil))
                   (DECLARE (SPECIAL *flavor-data* call-edit))
                   (w:menu-choose
		     *flavor-options-menu*
		     :label (FORMAT nil "Ï3Operations on ~SÏ*"
				    (si::flavor-name *flavor-data*))
		     :scrolling-p nil)
		   (IF call-edit
		       (ED (si::flavor-name *flavor-data*)))
		   ))))
     (BEEP)))

;Ï1; This is rather like the All-Flavors command.  It has a short name because of the menu.Ï*
(DEFCOMMAND Ï4(flavor-inspector :all-fl&clÏ*) ()
  '(:description "Ï3Display all flavor or class names in an inspection frameÏ*"
    :documentation "Ï3...permits user to select a flavor to inspect...Ï*"
    :keys #\Super-a)
  (LET ((flavors (inspect-real-value
		   `(:value ,(allocate-data 'show-all-flavors-and-classes
					    'IGNORE) ,history))))
    ;Ï1; Might not work since not EQÏ*
    (inspect-flush-from-history flavors history)
    (SEND history :append-item flavors)
    (update-panes)
    ;Ï1; We don't want our result to be printed.Ï*
    (SETQ ucl:inhibit-results-print? t)))


;Ï1; Now we can build the command tables.Ï*
(BUILD-COMMAND-TABLE 'flavor-inspector-cmd-table 'flavor-inspector
  '(:all-fl&cl
     :help-on-syntax
     :help-on-inspected-data
     :end-cmd
     :options-menu
     :trace-method
     :fi-doc-cmd
     config-toggle-cmd
     mode
     ;Ï1; These are Inspector commands we are able to borrow.Ï*
     delete-all-cmd
     refresh-cmd
     page-up-cmd
     page-down-cmd
     page-to-top
     page-to-bottom
     break-cmd)
  :init-options '(:name "Ï3Flavor Inspector CommandsÏ*"))

(BUILD-MENU 'flavor-inspector-menu 'flavor-inspector
  :item-list-order
  '(:help-on-syntax
    :all-fl&cl
    :trace-method
    :end-cmd
    :fi-doc-cmd
    delete-all-cmd
    refresh-cmd
    page-up-cmd
    page-down-cmd
    break-cmd
    mode
    config-toggle-cmd))

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

(DEFMETHOD Ï4(show-method-details :middle-button-resultÏ*) ()
"Ï2Return the method itself.Ï*"
  (SECOND aux-data))

(DEFMETHOD Ï4(show-method-details :generate-itemÏ*) ()
"Ï2This is a redefined version of the origonal method which takes advantage of the
 extensions to ivars-and-messages-in-method that JPR made.Ï*" 
 (LET (not-available)
   (VALUES
     (MULTIPLE-VALUE-BIND
       (referenced-ivars referenced-keywords problem
	referenced-functions referenced-generic-functions ignore ignore
	locals specials-referenced specials-bound)
         (ivars-and-messages-in-method (CAR aux-data))
       (WHEN problem
         (SETQ not-available (IF (EQ problem :wrapper)
                                 '(((:font 2 "Ï3 not available for wrappersÏ*")))
                                 '(((:font 2 "Ï3 not available for interpreted methodsÏ*"))))))
       (MULTIPLE-VALUE-BIND (args returned-values)
           ;Ï1; Wrappers and interpreted methods have a method table entry format different from the norm.Ï*
           ;Ï1; Wrappers' entries are (<spec> (MACRO . <fef>)...).  Interpreted methods are (<spec> (NAME-LAMBA <spec> <arglist> ...))Ï*
           (COND ((EQ problem :wrapper) (ARGLIST (CDADR aux-data)))
                 ((EQ problem :interpreted) (CDR (THIRD (CADR aux-data)))) ;Ï1;Take CDR to get rid of SI:.OPERATION. arg.Ï*
                 (t (CDR (ARGLIST (CADR aux-data))))) ;Ï1; Take CDR to get rid of SI:.OPERATION. arg.Ï*
         `(,*blank-line-item*
           ((:font 1 "Ï3Details of Ï*")
            (:item1 instance ,(allocate-data 'show-method-details data aux-data)))
           ,*blank-line-item*
           ((:font 1 "Ï3Source File:               Ï*")
	   ;Ï1; Changed by DAN to check for a null source-file property (Third aux-data) for the method,Ï*
	   ;Ï1; since the method may have been typed in interactively or generated automatically.Ï*
	   ,(IF (GETF (THIRD aux-data) :source-file-name)
		(LET ((sf (GETF (THIRD aux-data) :source-file-name)))
		     (FORMAT nil "Ï3~aÏ*" (SEND (IF (CONSP sf) (CADR (ASSOC 'DEFUN sf :test #'EQ)) sf) :string-for-printing)))
		(FORMAT nil "Ï3Not DefinedÏ*")))
           ((:font 1 "Ï3Method combination type:   Ï*")
            ,(LET ((method-entry (ASSOC (OR (FOURTH (CAR aux-data)) (THIRD (CAR aux-data)))
                                        (si::flavor-method-table data) :test #'EQ)))
               (IF (CADR method-entry)
                   `("Ï3~S~@[ ~S~]Ï*" ,(CADR method-entry) ,(CADDR method-entry))
                   "Ï3:DAEMON (the default)Ï*")))
           (,(IF returned-values
                 '(:font 1 "Ï3Arglist Ý Returned Values: Ï*")
                 '(:font 1 "Ï3Arglist:                   Ï*"))
            ("Ï3~:[~*()~;~S~]Ï*" ,args ,args)
            ,@(WHEN returned-values
                `(("Ï3 Ý ~SÏ*" ,returned-values))))
           ,*blank-line-item*
           ((:font 1 "Ï3Documentation:Ï*"))
           ,@(LET ((doc (DOCUMENTATION (CADR aux-data))))
               (IF (AND doc (NOT (EQUAL "" doc)))
                   (break-string-into-lines doc)
                   *no-items*))
           ,*blank-line-item*
           ((:font 1 "Ï3Referenced Instance Variables:Ï*"))
	   ,@(referenced-instance-variables-details
	       (SECOND aux-data) referenced-ivars)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Referenced Keywords (possibly messages passed):Ï*"))
	   ,@(referenced-keywords-details referenced-keywords)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Referenced Generic Functions:Ï*"))
	   ,@(referenced-generic-functions-details
		referenced-generic-functions)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Referenced Functions:Ï*"))
	   ,@(referenced-functions-details referenced-functions)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Locals:Ï*"))
	   ,@(locals-details locals)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Referenced Specials:Ï*"))
	   ,@(referenced-specials-details specials-referenced)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Specials Bound:Ï*"))
	   ,@(bound-specials-details specials-bound)
	   ,*blank-line-item*
	   ((:font 1 "Ï3Macros Expanded:Ï*"))
	   ,@(macros-expanded-details (FIRST aux-data))
	   ,*blank-line-item*
	   ((:font 1 "Ï3Interpreted Definition:Ï*"))
	   ,@(interpreted-definition-details (SECOND aux-data))
	)))
     `(:font fonts:hl12bi :string ,(FORMAT nil "Ï3Method~{ ~s~}Ï*" (CDAR aux-data))))))

(DEFUN Ï4coerce-to-flavorÏ* (x)
"Ï2If we've got a class then make it into a flavor for flavor inspection purposes.Ï*"
  (IF (class-p-safe x)
      (GET (class-name-safe x) 'si::flavor)
      x))

(DEFMETHOD Ï4(show-instance-variable :handle-mouse-clickÏ*) (blip flavor-inspector)
  (IF (NOT (MEMBER (FOURTH blip) '(#\Mouse-l #\Mouse-m) :test #'EQ))
    (BEEP)
    (SEND flavor-inspector :inspect-thing
	  'show-methods-referencing-instance-variable
       (IF (EQL (FOURTH blip) #\Mouse-l)
	   ;Ï1; Make sure that this is a flavor.  It could be a class too.Ï*
	   (coerce-to-flavor (SEND (SEND (THIRD blip) :current-object) :data))
	   (GET (SEND flavor-inspector :funcall-inside-yourself
		      (FUNCTION read-flavor-name))
		'si::flavor))
       data)))

(DEFMETHOD Ï4(show-instance-variable :middle-button-resultÏ*) ()
  "Ï2Just return the symbol that names the slot.Ï*"
  data)
