;;; -*- Mode:Common-Lisp; Package:TV; Base:10; Fonts:(TVFONT) -*-

;;; ***** Copyright (c) 1987 Texas Instruments.  All rights reserved.
;;; ***** Portions of this file contain code belonging to TI.

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

(eval-when (compile load)
  (let ((si:inhibit-fdefine-warnings t))
       (if (find-package 'ticlos)
	   nil
	   (defpackage ticl (:use lisp ticl))
       )
       (if (not (sys:find-system-named 'pcl t t))
	   (defpackage pcl (:use lisp))
	   nil
       )
  )
)

;-------------------------------------------------------------------------------


(defflavor basic-flavor-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
    ;;; 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)
    ;;; Modded here by JPR.
    :prompt (if (clos-p) "Flavor\/Class\/Method: " "Flavor\/Method: ")
    ;;Activate the special handling of instances of TV:INSPECTION-DATA.
    ;;This hack keeps the inspector code from treating mouse-sensitive blips
    ;;containing TV:INSPECTION-DATA instances as normal Lisp objects to inspect
    ;;and lets the instances dictate most inspector actions, such as
    ;;who-line-documentation when mouse is over the printed representation
    ;;of the instance, mouse button operations when it is clicked upon, and
    ;;item generation when the blip is inspected.
    :inspection-data-active? t))


(defflavor flavor-inspector ()
	   (basic-flavor-inspector Inspector-Framifying-Mixin)
)

;-------------------------------------------------------------------------------


(defvar *dont-have-initial-space* nil
"When 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 show-a-class-named (data)
"Allocates 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 show-a-class (data)
"Allocates data to show a clos class."
  (allocate-data 'show-clos-class data)
)


(defun coerce-class-to-name (class)
"Given 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 "Cannot coerce ~S into a class name." class))
  )
)

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

;-------------------------------------------------------------------------------

(defflavor generic-middle-button-mixin () ()
  (:documentation :mixin "Used to add generic middle button and l-2 behaviour to
 show-x flavors.
"
  )
)

(defmethod (generic-middle-button-mixin :middle-button-result) ()
"A generic method for this flavor."
  (send self :Data)
)

(defmethod (generic-middle-button-mixin :handle-mouse-click)
	   (blip flavor-inspector)
"A 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))
  )
)

;-------------------------------------------------------------------------------


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

(defmethod (class-operation-mixin :aux-data) ()
"This 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 (class-operation-mixin :handle-mouse-click) (blip flavor-inspector)
"A 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 "Operations on ~S"
				    (flavor-or-class-name data))
		     :scrolling-p nil)
		   (if call-edit
		       (ed (flavor-or-class-name *flavor-data*)))
		   ))
    (t
     (beep))))

;-------------------------------------------------------------------------------

(defflavor show-undefined-clos-class ()
	   (generic-middle-button-mixin inspection-data)
  (:documentation
"A 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 (show-undefined-clos-class :format-concisely) (stream)
"A simple print method for undefined classes."
  (format stream "Undefined Class ~S" data)
)

(defmethod (show-undefined-clos-class :middle-button-result) ()
"When you middle on an undefined class you just get its name back."
  data
)

(defmethod (show-undefined-clos-class :generate-item) ()
"Undefined classes don't have anything special about them so the item list
 generated is pretty vestigial.
"
  (values
     `()
     ;;Make the label display the class name.
     `(:font fonts:hl12bi :string ,(format nil "Undefined Class ~s" data))
  )
)

(defmethod (show-undefined-clos-class :help) ()
"We can't help much here."
 (format nil "
The 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))
;-------------------------------------------------------------------------------

(defflavor show-clos-class-details () (class-operation-mixin)
  (:documentation
"A 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.
"
  )
)

(defmethod (show-clos-class-details :format-concisely) (stream)
"When the data is a PCL class we should say so.  Otherwise we just say what
 we are.
"
  (if (iwmc-class-p-safe data)
      (format stream "PCL ")
  )
  (format stream "Class ~'s details"
	  (list (allocate-data 'show-clos-class data) nil
		(Class-Pretty-Name data (in-history-window-p stream))
	  )
  )
)

(defmethod (show-clos-class-details :middle-button-result) ()
"Just returns the class itself."
  data
)

(defmethod (show-clos-class-details :help) ()
"Simple help for the details of clos classes."
  (let ((class-name (class-name-safe data)))
    (format nil "
The 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 itemise-precedence-list (class)
"Given 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 ", ") (:item1 instance ,cl))
	 )
  )
)

(defun itemise-default-initargs (class)
"Itemises 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 (show-clos-class-details :generate-item) ()
"Makes the inspector mouse-sensitive items for show-clos-class-details show-xs."
  (values
     `(,*blank-line-item*
       ((:font 1 ,(if (iwmc-class-p-safe data) "PCL Class " "Class "))
        (:item1 instance ,(allocate-data 'show-clos-class data))
	(:font 1 "'s details.")
       )
       ,*blank-line-item*
       ((:font 1 "Metaclass:                 ")
        (:item1 instance ,(allocate-data 'show-clos-class (class-of-safe data)))
       )
       ,*blank-line-item*
       ((:font 1 "Source File:               ")
	,(if (and (get (class-name-safe data) :source-file-name)
		  (class-name-safe data)
	     )
	     (path-string-safe data)
	     (format nil "Not Defined")))
       ,*blank-line-item*
       ((:font 1 "Precedence List:           ")
	,@(itemise-precedence-list data)
       )
       ,*blank-line-item*
       ((:font 1 "Default Initargs:"))
       ,@(itemise-default-initargs data)
       ,*blank-line-item*
       ((:font 1 "Documentation:"))
       ,@(let ((doc (catch-error (documentation data) nil)))
	   (if (and doc (not (equal "" doc)))
	       (break-string-into-lines doc)
	       *no-items*))
      )
     ;;Make the label display the class name.
     `(:font fonts:hl12bi :string ,(format nil "~A" (class-pretty-name data))))
)

;-------------------------------------------------------------------------------

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

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

(defun in-history-window-p (stream)
"Is true if we're trying to write into the inspect history window."
  (typep stream 'inspect-history-window)
)

(defun class-pretty-name (class &optional (history-window-p nil))
  (with-output-to-string (stream)
    (if (class-name-safe class)
	(if history-window-p
	    (format stream "~AClass ~s" (if (iwmc-class-p-safe class) "PCL " "")
		    (class-name-safe class)
	    )
	    (format stream "~s" (class-name-safe class))
	)
	(progn (if history-window-p
		   (format stream "Anonymous ~AClass "
			   (if (iwmc-class-p-safe class) "PCL " "")
		   )
		   (format stream "Anonymous ")
	       )
	       (print-pointer class stream)
	)
    )
  )
)

(defmethod (show-clos-class :format-concisely) (stream)
"When 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)
)

;(defmethod (show-clos-class :who-line-doc)
;	   (inspection-pane? &optional no-sensitive-item?)
;  (cond
;    (no-sensitive-item?
;     `(:mouse-l-1 "Choose an item to inspect"
;       :mouse-m-2 "Lock/Unlock inspector pane"
;       :mouse-r-1 ,(format nil "Menu of operations on ~A"
;			   (Class-Pretty-Name data))))
;    (inspection-pane?
;      '(:mouse-l-1 "Inspect this CLOS class"
;        :mouse-m-1 "Inspect this CLOS class and display this pane's contents in middle pane"
;        :mouse-m-2 "Lock/Unlock inspector pane"
;	:mouse-r-1 "Menu of other operations"))
;    (t
;     '(:mouse-l-1 "Inspect this CLOS Class"
;       :mouse-m-1 "Inspect this CLOS Class"
;       :mouse-m-2 "Lock/Unlock inspector pane"
;       :mouse-r-1 "Menu of other operations"))))


(defun class-components (class-name)
"Returns 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 (show-clos-class :generate-item) ()
"Displays 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*
       ((:font 1 ,(if (iwmc-class-p-safe data) "PCL Class " "Class "))
        (:item1 instance ,(allocate-data 'show-clos-class data))
	(:font 1 "'s superclasses.  (Metaclass is ")
        (:item1 instance ,(allocate-data 'show-clos-class (class-of-safe data)))
	(:font 1 ")")
       )
       ,*blank-line-item*
	;;For each component method, a mouse sensitive method name (METHOD-NAME)
       ,@(or text-items *no-items*))
     ;;Make the label display the class name.
     `(:font fonts:hl12bi :String
	     ,(format nil "~A" (Class-Pretty-Name data))))))


(defun collect-dependent-classes (class-name print-level all-components pointer)
"Takes 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
	;;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 (show-clos-class :help) ()
"Gives a modicum of understanding to people seeing a normal class components
 display.
"
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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 (flavor-inspector :inspect-class) (object)
"A 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))))
    ;; first flush item we will be inspecting
    (inspect-flush-from-history thing history)
    (send history :append-item thing)
    (update-panes)))

;-------------------------------------------------------------------------------

;;; Typein mode definitions for the class inspector.
;;; ================================================

;-------------------------------------------------------------------------------

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

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

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

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

(defmethod (class-names :complete-p) (syntax)
"Complete the class-names typein mode thenever you've got an atom to deal with."
  (when (member syntax '(:first-atom :function) :test #'eq)
    "Class Names"
  )
) 


(defun names-a-generic-function (x)
"Is true if x is the name of a generic function."
  (and (symbolp x) (fboundp x) (generic-function-p-safe (symbol-function x)))
)

(defun get-recognition (word type all-class-names)
"Gets 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*))))
	     ;;; 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)
	     )
	)
      )
      ;;; Prefer classes over generic-functions (is this a good idea?)
      ;;; Look for class name completions.
      (w:get-word-completions word all-class-names)
      (if (and (ticlos-p)
		(not *cached-ticlos-class-names*)
	   )
           ;;; 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))
	       )
	   )
	   ;;; If all else fails just look for functions.
	   (w:get-symbol-completions
	     word type 'names-a-generic-function
	   )
       )
  )
)

(defun get-apropos (word type all-class-names)
"Gets 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
	      ;;; 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*)
		       )
		       ;;; We didn't have any cached class names so look for
		       ;;; 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
		   ;;; Look for symbol completions that name generic
		   ;;; functions in this package.
		   (w:get-symbol-completions
		     word type 'names-a-generic-function
		   )
	   )
      )
    )
  )
)

(defun class-complete (word type)
"Completes 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 t)))
       (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 (class-names :complete) (word type)
"Completes a class name in the appropriate way for a typein mode."
  (class-complete word type)
)


(defmethod (class-names :handle-typein-p) (expression type)
"A 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 "~s is not a defined class " expression)))
  )
)


(defmethod (class-names :execute) (class-inspector)
"When 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)))))
	 ;;might not work since not eq
    (inspect-flush-from-history class history)
    (send history :append-item class)
    (update-panes)
    ;;we don't want our result to be printed.
    (setq ucl::inhibit-results-print? t)))

(defmethod (class-names :arglist) (symbol)
"The 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 "~S" (arglist symbol))
      (if (and (symbolp symbol) (class-named-safe symbol t))
	  (format nil "Class ~S" symbol)
	  (values nil (format nil "~S is not a defined class" symbol))
      )
  )
)


(defparameter class-names (make-instance 'class-names)
"The actual class-names typein mode instance."
)

;-------------------------------------------------------------------------------

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

(defmethod (class-instance :handle-typein-p) (expression type)
"I don't think that this is used."
  (if (and (not (consp expression)) expression)
	   (if (not (and (symbolp expression) (boundp expression)))
	       (values () (format nil "~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 "~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 "~s is not a defined class"
					   expression)))))  
	   (values () (format nil "~s is not a defined class" expression))))


(defmethod (class-instance :execute) (class-inspector)
"I 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))))
	 ;;Might not work since not EQ
    (inspect-flush-from-history class history)
    (send history :append-item class)
    (update-panes)
    ;;we don't want our result to be printed.
    (setq ucl::inhibit-results-print? t)))

(defparameter class-instance (make-instance 'class-instance))

;-------------------------------------------------------------------------------


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

(defmethod (clos-method-specs :complete-p) (syntax)
  "We want to complete pretty well anything."
  (when (eq syntax :atom) "CLOS Methods")
)

(defvar *clos-method-types*
   '(:after :before :around) ;; Should we really have :around???
"These 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 read-list-from-string (string)
"We'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 "(" string ")") nil nil)
)

(defun-rh get-clos-method-expression ()
"I 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 (clos-method-specs :complete-for-gf-name)
	   (word type class-name second-word more-than-two-words?)
"Completes 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 (clos-method-specs :complete) (word type)
"Completes 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 "~S is neither a class name or a generic function."
		    class-name
	    )
	)
    )
  )
)

(defun get-method-matches (specialisations combination)
"Is 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 maybe-find-clos-method (methods combination class failure-string)
"Given 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 "~&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 (clos-method-specs :handle-typein-p) (expression type)
"Should we handle typein for this method spec?.  Try to read it as a method
 name.
"
  (send self :read-a-method-name expression type)
)

(defmethod (clos-method-specs :read-a-method-name) (expression type)
"Tries 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 ()
		 "No 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 (clos-method-specs :execute) (flavor-inspector)
"Having 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)
    ;;We don't want our result to be printed.
    (setq ucl::inhibit-results-print? t)
  )
) 

(defmethod (clos-method-specs :arglist) (symbol)
"Gets 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 "~S ~S  ~S" name args ret)
			 (format nil "~S ~S" name args)
		     )
		     nil
		   )
	      )
	    )
	    (values () "Not a defined method")
	)
      )
    )
  )
)

(defparameter clos-method-specs (make-instance 'clos-method-specs)
"This is the actual variable to hold the clos-method-specs typein-mode
 instance.
"
)

(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :help-on-syntax) ()
  '(:names ("Syntax Help")
    :KEYS #\META-HELP
    :DESCRIPTION "Prints help on the processing of typed expressions.")
  (SEND SELF :FORMAT-MESSAGE
	(format nil "
You may type any of the following expressions:
~A~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"
		(if (clos-p)
		    "For 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:"
		    ""
                )
		(if (clos-p) "class," "")
	  )
  )
)

;-------------------------------------------------------------------------------

(defun flavor-or-class-name (something)
"Returns 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 "~S is not a flavor or a class.")
      )
  )
)

;-------------------------------------------------------------------------------

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

(defmethod (show-component-classes :format-concisely) (stream)
"Just print it out simply."
  (format stream "~'s superclasses"
	(list (allocate-data 'show-clos-class data)
	      nil (Class-Pretty-Name data (in-history-window-p stream))
	)
  )
)

(defmethod (show-component-classes :middle-button-result) ()
"When we get middle buttoned on we should return the class itself."
  data
)

(defmethod (show-component-classes :generate-item) ()
  (let* ((component-classes (cdr (class-precedence-list-safe data))))
    (values
     `(,*blank-line-item*
       ("Superclasses of class "
        (:item1 instance ,(allocate-data 'show-clos-class data))
        ":")
       ,*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 "~A's superclasses" (Class-Pretty-Name data))))))  


(defmethod (show-component-classes :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))


;-------------------------------------------------------------------------------

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

(defmethod (show-dependent-classes :middle-button-result) ()
"When we get middle buttoned on we should return the class itself."
  data
)

(defmethod (show-dependent-classes :format-concisely) (stream)
"Just print it out simply."
 (format stream "~'s subclasses"
	 (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)

(defmethod (show-dependent-classes :generate-item) ()
"I 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
	  "Heirarchy of classes directly or indirectly dependent on class ")
	(:item1 instance ,(allocate-data 'show-clos-class data))
        ":")
       ,*blank-line-item*
       ,@(let (items
	       classes)
	   (with-recursion
	     ((dependent-classes indentation)
	      (class-direct-subclasses-safe data) 0)
	    (dolist (dependent-class dependent-classes)
	      ;;; Commented out by JPR on 3/30/89.  This doesn't
	      ;;; seem right.
	      (unless nil;(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 "~A's subclasses" class-name)))))

(defmethod (show-dependent-classes :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))



;-------------------------------------------------------------------------------

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

(defmethod (show-local-clos-methods :format-concisely) (stream)
"Just print it out simply."
 (format stream "~'s local methods"
	 (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)

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

(defun collect-clos-method-items
       (method-table
	&optional (predicate #'(lambda (element) (ignore element) t))
       )
"Collects 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 *clos-method-display-columns*
   `((:font 2 ,(format nil "~40A~15A~15A" "Method" "Combination" "Arglist")))
"The column headers for displaying clos methods."
) 


(defun sort-clos-methods (methods)
"Sorts 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 (show-local-clos-methods :generate-item) ()
  (let* (
	 ;;Sort for readability.  There might be a better place to do the
	 ;;sort; 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 "Methods defined for class ")
	  (:item1 instance ,(allocate-data 'show-clos-class data))
	  (:font 1 ,(if special-comb?
		      ".  * = special method combination type"
		      ":")))
	  ;;Collect the methods, excluding any GET and SET methods, which we
	  ;;want to list separately (for readability).
	 ,@(if items
	     (cons *clos-method-display-columns* items)
	     *no-items*))
       `(:font fonts:hl12bi :string
	       ,(format () "~A's local methods" (Class-Pretty-Name data)))))))

(defmethod (show-local-clos-methods :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))

;-------------------------------------------------------------------------------

(defflavor show-local-clos-generic-functions
	   ()
	   (class-operation-mixin)
  (:documentation "Shows the generic functions that name the local methods for
 the data class."
  )
)

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

(defmethod (show-local-clos-generic-functions :format-concisely) (stream)
"A simple concise format method.  Nothing special here."
 (format stream "~'s local generic functions"
	 (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)

(defun collect-clos-generic-function-items
       (function-table
	&optional (predicate #'(lambda (element) (ignore element) t))
       )
"Builds 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 *clos-generic-function-display-columns*
	`((:font 2 ,(format nil "~58A~15A" "Function" "Arglist")))
"An 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 sort-clos-generic-functions (generic-functions)
"Sorts 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 (show-local-clos-generic-functions :generate-item) ()
"Generates the inspector item list for the display of local generic fucntions."
  (let* ((class-name (Class-Pretty-Name data))
	 ;;Sort for readability.  There might be a better place to do the
	 ;;sort; for instance, always maintain a sorted entry for SHOW-METHOD
	 ;;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 "Generic-functions defined for class ")
	  (:item1 instance ,(allocate-data 'show-clos-class data))
	  (:font 1 ,(if special-comb?
		      ".  * = special method combination type"
		      ":")))
	 ,@(if items
	     (cons *clos-generic-function-display-columns* items)
	     *no-items*))
       `(:font fonts:hl12bi :string
	       ,(format () "~A's local generic-functions" class-name))))))

(defmethod (show-local-clos-generic-functions :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))

;-------------------------------------------------------------------------------

(defflavor show-all-clos-methods () (class-operation-mixin)
  (:documentation
"Shows 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 (show-all-clos-methods :format-concisely) (stream)
"Just a simple print method.  Nothing special here."
 (format stream "~'s methods (all)"
         (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)

(defmethod (show-all-clos-methods :middle-button-result) ()
"Returns the class itself when we get middle buttoned on."
  data
)

(defmethod (show-all-clos-methods :generate-item) ()
"Builds 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 "Methods inherited from class ")
		       (:item1 instance ,(allocate-data 'show-clos-class class))
		       (:font 1 ,(if special-com?
				     ".  * = special method combination type"
				     ":")))
		      ,@(if items
			    (cons *clos-method-display-columns* items)
			    *no-items*)
		      )
		    nil))))
      `(:font fonts:hl12bi :string
	      ,(format nil "~A's methods (all)" (Class-Pretty-Name data)))))


(defmethod (show-all-clos-methods :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))


;-------------------------------------------------------------------------------

(defflavor show-all-clos-methods-sorted () (class-operation-mixin)
  (:documentation
"Shows 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 (show-all-clos-methods-sorted :middle-button-result) ()
"Just returns the class itself."
  data
)

(defmethod (show-all-clos-methods-sorted :format-concisely) (stream)
"Nothing magical here.  Just prints the class name out a little cleverly."
 (format stream "~'s methods (sorted)"
         (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)


(defvar *clos-method-display-columns-2*
  `((:font 2 ,(format nil "~40A~15A~15A" "Method" "Combination" "Arglist")))
"This 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 uniquify (list result &key (test #'eql))
"Given a list collects the elements of list into result and returns them.
 Result is a Set at the end (unless it was non-nil and not a set at the start).
 Test is the membership test function.
"
  (if list
      (uniquify (rest list) (fs:cons-new (first list) result :test test)
		:test test
      )
      (nreverse result)
  )
)

(defun all-clos-method-items-for-class (the-class)
"Given 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 princ-method (method stream)
"Prints 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 "~A ~S ~:S"
	       class-name
	       (and generic-function (fast-gf-name method))
	       (unparse-specializers-safe method)
       )
  )
)

(defun fast-gf-name (method)
  (second (function-name (method-function-safe method)))
)

(defun method-lessp-1 (x y)
"Is true if the printed representation of x is string-lessp than y."
  (let ((gfx (format nil "~S" (fast-gf-name x)))
	(gfy (format nil "~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 "~S" specx))
			  (namey (format nil "~S" specy))
			 )
		         (or (string-lessp namex namey)
			     (and (string-equal namex namey)
				  (string-lessp (format nil "~S" combx)
						(format nil "~S" comby)
				  )
			     )
			 )
		    )
		  )
		)
	   )
       )
  )
)

(defun method-lessp (x y)
"Is 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 princ-generic-function (generic-function stream)
"Prints 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 "~S"
	  (let ((name
		  (second (function-name
			    (method-function-safe
			      (first (generic-function-methods-safe
				       generic-function
				     )
			      )
			    )
			  )
		  )
		)
	       )
	       (if (and (consp name) (equal :internal (first name)))
		   ;;; Special case for PCL.
		   (generic-function-name-safe generic-function)
		   name
	       )
	  )
  )
)


(defun gf-lessp (x y)
"Is 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 (show-all-clos-methods-sorted :generate-item) ()
"Generates 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 "All Methods of class ")
	 (:item1 instance ,(allocate-data 'show-clos-class data))
	 (:font 1
	     ,(if special-comb? ".  * = special method combination type" ":")))
	,*blank-line-item*
	,*clos-method-display-columns-2*
	,@(sort items #'method-lessp)))
    `(:font fonts:hl12bi :string ,(format nil "~A's methods (sorted)"
					  (Class-Pretty-Name data))))) 


(defmethod (show-all-clos-methods-sorted :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))


;-------------------------------------------------------------------------------

(defflavor show-all-clos-generic-functions () (class-operation-mixin)
  (:documentation
"Shows 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 (show-all-clos-generic-functions :middle-button-result) ()
"Returns the class itself when we get middle buttoned on."
  data
)

(defmethod (show-all-clos-generic-functions :format-concisely) (stream)
"Just a simple print method.  Nothing special here."
 (format stream "~'s generic functions (all)"
	 (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)


(defmethod (show-all-clos-generic-functions :generate-item) ()
"Builds 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))
	    ;;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 "Generic functions inherited from class ")
		       (:item1 instance ,(allocate-data 'show-clos-class class))
		       (:font 1 ,(if special-com?
			     ".  * = special generic function combination type"
				     ":")))
		      ,@(if items
			    (cons *clos-generic-function-display-columns* items)
			    *no-items*)
		      )
		    nil))))
      `(:font fonts:hl12bi :string
	      ,(format nil "~A's generic functions (all)"
		       (Class-Pretty-Name data)))))


(defmethod (show-all-clos-generic-functions :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))


;-------------------------------------------------------------------------------

(defflavor show-all-clos-generic-functions-sorted () (class-operation-mixin)
  (:documentation
"Shows 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 (show-all-clos-generic-functions-sorted :middle-button-result) ()
"Just returns the class itself."
  data
)

(defmethod (show-all-clos-generic-functions-sorted :format-concisely) (stream)
"Nothing magical here.  Just prints the class name out a little cleverly."
 (format stream "~'s generic functions (sorted)"
         (list (allocate-data 'show-clos-class data) nil
	       (Class-Pretty-Name data (in-history-window-p stream))
	 )
 )
)


(defvar *clos-generic-function-display-columns-2*
	`((:font 2 ,(format nil "~58A~15A" "Function" "Arglist")))
"This 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 all-clos-generic-functions-for-class (the-class)
"Given 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 all-clos-generic-function-names-for-class (the-class)
"Returns 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 all-clos-generic-function-items-for-class (the-class)
"Given 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 (show-all-clos-generic-functions-sorted :generate-item) ()
"Generates 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 "All Generic-functions of class ")
	 (:item1 instance ,(allocate-data 'show-clos-class data))
	 (:font 1 ,(if special-comb?
		       ".  * = special generic-function combination type" ":")))
	,*blank-line-item*
	,*clos-generic-function-display-columns-2*
	;;This sorts the generic-functions alphabetically by message, then by
	;;generic-function type (if any), then by submessage (if any).
	,@(sort items #'gf-lessp)))
    `(:font fonts:hl12bi :string
	    ,(format nil "~A's generic-functions (sorted)"
		     (Class-Pretty-Name data))))) 


(defmethod (show-all-clos-generic-functions-sorted :help) ()
  (let ((class-name (Class-Pretty-Name data)))
    (format nil "
The 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)))


;-------------------------------------------------------------------------------

(defvar *clos-method-operations-menu*
 '(("Inspect" :value :inspect-clos-method
    :documentation "Show information about this method:
slots and methods referenced, arglist, documentation, source file")
   ("Disassemble" :value :disassemble-clos-method
    :documentation "Use a standard Inspect window to show disassembled code.")
   ("Edit Source" :value :edit-clos-method
    :documentation "Edit this method in a Zmacs buffer.")
   ("Trace" :value :trace-clos-method
    :documentation "Invoke a trace window to trace this method")
   ("Combination" :value :clos-method-combination
    :documentation "Shows the method combination for this method.")
   ("Related Methods" :value :related-clos-methods
    :documentation "Show methods with the same name as this.")
  )
"The 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 show-clos-method () (inspection-data)
  (:documentation
"Displays a clos method.  Actually this flavor is never inspected directly,
 since whenever you click on one a show-clos-method-details is inspected.
"
  )
)

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

(defmethod (show-clos-method :middle-button-result) ()
"Returns the class, not the method."  ;;; Is this right?
  data
)

(defun merge-args-and-specialisations (args specialisations)
"Given 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 *indent1* 35
"The number of spaces to indent between the display of a method's class
 and its generic function name.
"
)

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

(defun format-a-method-concisely
       (data stream &optional (indent1 *indent1*) (indent2 *indent2*))
"This 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 "~~VT~A~VT~S"
				  gf indent1
				  (if comb
				      (format nil "~S~{ ~S~}"
					      (first comb) (rest comb)
				      )
				      ""
				  )
				  indent2 args
			  )
			  (format stream "~ ~~VT~A~VT~S"
			       (list (allocate-data
				       'show-clos-class (class-of-safe data)
				     )
				     t class-name
			       )
			       gf indent1
			       (if comb
				   (format nil "~S~{ ~S~}"
					   (first comb) (rest comb)
				   )
				   ""
			       )
			       indent2 args
			  )
		      )
		      (if (standard-method-p-safe data)
			  (format stream "~~VT~S" gf indent1 args)
			  (format stream "~ ~~VT~S"
			       (list (allocate-data
				       'show-clos-class (class-of-safe data)
				     )
				     t class-name
			       )
			       gf indent1 args
			  )
		      )
		  )
	     )
	   )
       )
  )
)

(defmethod (show-clos-method :format-concisely) (stream)
"Prints 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 "CLOS Method ")
	     (format-a-method-concisely data stream 0 0)
      )
      (progn (if *dont-have-initial-space*
		 nil
		 (format stream " ")
	     )
	     (format-a-method-concisely data stream)
      )
  )
)

;(defmethod (show-clos-method :who-line-doc) (ignore &optional ignore)
;"Returns a who-line doc string for show-clos-methods."
;  '(:mouse-l-1 "Inspect method details"
;    :mouse-m-1 ""
;    :mouse-r-1 "Menu of method operations"
;   )
;)

(defmethod (flavor-inspector :inspect-clos-method) (method)
"Given a method, inspects its details."
  (send self :inspect-thing 'show-clos-method-details
     (first (method-type-specifiers-safe method))
     method
  )
)

;(defmethod (flavor-inspector :disassemble-clos-method) (method)
;"Given a method, inspects its disassembled code."
;  (inspect (method-function-safe method))
;)

(defmethod (flavor-inspector :trace-clos-method) (method)
"Given a method, traces it."
  (trace-via-menus (function-name (method-function-safe method)))
)

(defmethod (flavor-inspector :edit-clos-method) (method)
"Given a method, edits its source definition."
  (ed (function-name (method-function-safe method)))
)

(defmethod (flavor-inspector :clos-method-combination) (method)
"Given a method, inspects its method combination representation."
  (send self :inspect-thing 'show-clos-method-combination method)
)

(defmethod (flavor-inspector :related-clos-methods) (method)
"Given a method, inspects the methods that are related to it."
  (send self :inspect-thing 'show-clos-related-methods method)
)

(defun select-clos-method-operations
       (method flavor-inspector current-flavor &optional selection)
"This 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 () "~s"
		       (function-name (method-function-safe method))
	       )
	     )
	 )
	)
       )
       (if choice
	   (send flavor-inspector choice method)
	   nil
       )
  )
)


(defmethod (show-clos-method :handle-mouse-click) (blip flavor-inspector)
"Handles 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 (show-clos-method :generate-item) ()
"This isn't actually invoked (or it shouldn't be).  It's here just in case."
  (values `(,*blank-line-item*
	    ((:font 1 "Details of ")
	     (:item1 instance ,(allocate-data 'show-clos-method data)))
	    ,*blank-line-item*
	    ((:font 1 "Data:      ")
	     (:item1 instance ,data)))
	  `(:font fonts:hl12bi :string
		  ,(format nil "CLOS~{ ~s~}" (clos-method-name data)))))

(defmethod (show-clos-method :help) ()
  (format nil "
The inspection pane you just selected is currently displaying the method ~S"
	  data))

;-------------------------------------------------------------------------------

(defflavor show-clos-related-methods () (inspection-data)
  (:documentation "Shows the methods related to the methods Data.")
)

(defmethod (show-clos-related-methods :middle-button-result) ()
"Just returns the method itself."
  data
)

(defmethod (show-clos-related-methods :aux-data) ()
"Just returns the method itself."
  data
)

(defmethod (show-clos-related-methods :format-concisely) (stream)
"Nothing special here.  Just prints out its name a little cleverly."
  (format stream "Methods related to ")
  (format-a-method-concisely data stream 0 0)
)

(defmethod (show-clos-related-methods :handle-mouse-click)
  (blip flavor-inspector)
"Handles 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 (show-clos-related-methods :generate-item) ()
"Makes 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 "Methods 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 "Methods Related to CLOS~{ ~s~}"
			(clos-method-name data)))))))

(defmethod (show-clos-related-methods :help) ()
  (let ((method-name (function-name (method-function-safe data))))
    (format nil "
The 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)))


;-------------------------------------------------------------------------------

(defun print-unpadded-method (instance stream &optional (level 0))
"Prints 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)
  )
)

;-------------------------------------------------------------------------------

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

;-------------------------------------------------------------------------------


(defflavor show-clos-method-combination () (inspection-data)
  (:documentation
"Displays 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 (show-clos-method-combination :middle-button-result) ()
"Just returns the method itself."
  data
)

(defmethod (show-clos-method-combination :aux-data) ()
"Just returns the method itself."
  data
)

(defmethod (show-clos-method-combination :format-concisely) (stream)
"Prints the method name out simply.  No padding is given."
  (format stream "Method Combination of ")
  (format-a-method-concisely data stream 0 0)
)

(defmethod (show-clos-method-combination :handle-mouse-click)
	   (blip flavor-inspector)
"Handles 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 (show-clos-method-combination :generate-item) ()
"Generates 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 "Method 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 "Method 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 (show-clos-method-combination :help) ()
  (let ((method-name (function-name (method-function-safe data))))
    (format nil "
The 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))))

;-------------------------------------------------------------------------------

(defflavor show-clos-method-details
	   () (auxiliary-data-mixin class-operation-mixin)
  (:documentation
"Shows 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 (show-clos-method-details :middle-button-result) ()
"Just returns the method itself."
  aux-data
)

(defmethod (show-clos-method-details :format-concisely) (stream)
"Prints 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 "CLOS Method ")
	     (format-a-method-concisely aux-data stream 0 0)
      )
      (progn (if (not *dont-have-initial-space*)
		 nil
		 (format stream " ")
	     )
	     (format-a-method-concisely aux-data stream)
      )
  )
)

(defwrapper (show-clos-method-details :handle-mouse-click)
	    ((blip flavor-inspector) &body body)
"Makes 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 coerce-to-disassemblable-function (something)
"Can 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)
      (first (si:convert-closure-to-list something))
      something
  )
)

(defun ivars-and-messages-in-method (function &optional (no-error-p t))
"This 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) ;;; flavor method
		 (sys:fdefinition-safe 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 (equal '(nil) fef) (setq fef function))
    (when (and fef (symbolp fef)) ;Obsolete syntax for method definitions may
      (setf fef (symbol-function fef)))	;return symbols here.  PMH SPR#6810
    (cond ((consp fef)
	   (values () () (if (eq (car fef) 'macro) :wrapper :interpreted) nil)
	  )
	  ((compiled-function-p fef)
	   (multiple-value-bind (args returned-values) (arglist fef)
	     (setq lim-pc (compiler:disassemble-lim-pc fef))
	     ;;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
		       (flatten
			 (remove nil
			  (sys:dbis-local-map (sys:get-debug-info-struct fef))
			 )
		       )
		       (flatten args)
		     )
		     (set-difference
		       (set-difference (eh:specials-used-by-fef fef)
				       *collected-bound-specials*
		       )
		       *collected-messages*
		     )
		     (set-difference *collected-bound-specials*
				     *collected-messages*
		     )
	     )
	   )
	  )
	  ((typep fef 'microcode-function)
	   (multiple-value-bind (args returned-values) (arglist fef)
	     (values nil nil nil nil nil args returned-values nil nil nil)
	   )
	  )
	  (no-error-p (values nil nil nil nil nil nil nil nil nil nil))
	  (t (ferror nil "Cannot understand function ~S"))
    )
  )
)

(defun flatten (list)
  (if list
      (let ((all nil))
	   (labels ((flatten-1 (x)
		      (if (consp x)
			  (progn (flatten-1 (first x))
				 (if (rest x) (flatten-1 (rest x)) nil)
			  )
			  (push x all)
		      )
		    )
		   )
	     (flatten-1 list)
	     (nreverse all)
	   )
      )
      nil
  )
)

;;; TI code, modified by JPR.
(defun my-decode-clos-self-ref-pointer (FEF pointer-number)
  "Decode the pointer field of a DTP-SELF-REF-POINTER.
Values are an instance variable name and NIL,
or a component class name and T."
  ;;  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))
  (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
				       (clos:class-precedence-list class-object)
				       )))))))
	  (t NIL))))))


(defun ivar-and-class (fef index)
"Is 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 find-slot-in-classes (name classes)
"Given 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
  )
)

;;; This should no longer be used.  We've found a better way.
(defun find-slotd-from-fef (slot-name fef arg-name)
"Given 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 find-generic-function (name)
"Given 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)
)

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


(defun search-instruction (fef pc)
"Searches 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 "BIND" (the string (symbol-name name))
			       :test #'char-equal
		       )
		  )
	      )
	    )
	   )
	   (declare (special *binding*))
      (cond
	((eq no-reg 'nil) ;; 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))
	;;; Commented out by JPR on 3/02/89.  This causes occasional
	;;; barfage.
	((eq no-reg 'call)
	 (catch-error  ;;; Sometimes this doesn't work.
	   (search-address fef (ldb (byte 3 6) wd) (ldb (byte 9 0) wd) nil)
	   nil
	 )
	)
	(t nil))
      ilen))))

(defun search-pointer (fef disp pc)
"This is called during the pseudo disassembling of Fef in order to find out
 interesting things about it.  Disp and PC anre 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 @i[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*
      )
    )
    ;; Make sure DISP argument is reasonable.
    (unless (< disp (si:%structure-boxed-size fef))
      (ferror
	nil "Offset ~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 ;;; This may be a (defun foo () (declare (self-flavor bar))..
		   ;;; 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
		     ;;Collect the instance variable!!
		     (pushnew ptr *collected-ivars*))))
	       ;;; 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
		   ;;Collect the instance variable!!
		   (pushnew (list slotd class) *collected-ivars* :test #'equal)
		 )
	       )
	   )
	  )
          ;;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)))
			      ;;; 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*
				  )
				  (pushnew ptr *collected-bound-specials*)
				  nil
			      )
			  )
		     )
		)
	   )
	  )
          (t
           (setq tem (%p-contents-offset fef disp))
           ;;When argument is a keyword and the operation is a call
	   ;;(FUNCALL or SEND), assume it is a message.  There's also
	   ;;a special case caused by the popular
	   ;;(SEND <foo> :SEND-IF-HANDLES :bar) feature
           ;;which is covered here.  :BAR is included as a referenced
	   ;;message, even though it is technically just a keyword.
           (when (and (symbolp tem) (keywordp tem))
             (pushnew tem *collected-messages*))))))


(defun referenced-symbol-details (referenced-symbols)
"Given 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 locals-details (locals)
"Makes an inspector item list for the list of locals referenced in a fef."
  (referenced-symbol-details locals)
)

(defun referenced-keywords-details (referenced-keywords)
"Makes an inspector item list for the list of message keywords referenced
 in a fef.
"
  (referenced-symbol-details referenced-keywords)
)

(defun referenced-specials-details (referenced-specials)
"Makes an inspector item list for the list of specials referenced in a fef."
  (referenced-symbol-details referenced-specials)
)

(defun bound-specials-details (bound-specials)
"Makes an inspector item list for the list of specials bound in a fef."
  (referenced-symbol-details bound-specials)
)

(defun referenced-instance-variables-details (data referenced-ivars)
"Makes 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.
"
  (if (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 " defined by ")
		   (:item1 instance
			   ,(allocate-data 'show-clos-class (second entry))
		   )
		  )
		 `(,*one-space-item* (:item1 named-structure-value ,entry))
	      )
	)
	nil
      )
  )
)

(defun referenced-generic-functions-details (referenced-generic-functions)
"Makes 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 referenced-functions-details (referenced-functions)
"Makes 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 macros-expanded-details (data)
"Makes 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 interpreted-definition-details (fef)
"Makes 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 (show-clos-method-details :generate-item) ()
"Makes 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 "Details of ")
	(:item1 instance
		,(allocate-data 'show-clos-method-details data aux-data)
		print-unpadded-method)
	(:font 1 " Class ")
	(:item1 instance
		,(allocate-data 'show-clos-class (class-of-safe aux-data))))
       ,*blank-line-item*
       ((:font 1 "Generic 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 "Source File")
	(:colon 30)
	,(method-path-string-safe aux-data)
       )
       ,*blank-line-item*
       (,(if returned-values
	     '(:font 1 "Arglist  Returned Values")
	     '(:font 1 "Arglist"))
	(:colon 30)
	("~:[~*()~;~S~]" ,args ,args)
	,@(when returned-values
	    `(("  ~S" ,returned-values))))
       ,*blank-line-item*
       ((:font 1 "Documentation:"))
       ,@(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 "Classes 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*
       ((:font 1 ,(if (iwmc-class-p-safe aux-data)
		      ""
		      "Referenced Slots:")))
       ,@(if (iwmc-class-p-safe aux-data)
	     nil
	     (referenced-instance-variables-details aux-data referenced-ivars)
	 )
       ,*blank-line-item*
       ((:font 1 "Referenced Keywords (possibly messages passed):"))
       ,@(referenced-keywords-details referenced-keywords)
       ,*blank-line-item*
       ((:font 1 "Referenced Generic Functions:"))
       ,@(referenced-generic-functions-details
	    referenced-generic-functions
	 )
       ,*blank-line-item*
       ((:font 1 "Referenced Functions:"))
       ,@(referenced-functions-details referenced-functions)
       ,*blank-line-item*
       ((:font 1 "Locals:"))
       ,@(locals-details locals)
       ,*blank-line-item*
       ((:font 1 "Referenced Specials:"))
       ,@(referenced-specials-details specials-referenced)
       ,*blank-line-item*
       ((:font 1 "Specials Bound:"))
       ,@(bound-specials-details specials-bound)
       ,*blank-line-item*
       ((:font 1 "Macros Expanded:"))
       ,@(macros-expanded-details (method-function-safe aux-data))
       ,*blank-line-item*
       ((:font 1 "Method Combination:"))
       ,@(method-combination-of-method-safe aux-data)
       ,*blank-line-item*
       ((:font 1 "Interpreted Definition:"))
       ,@(interpreted-definition-details (method-function-safe aux-data))
       ))
    `(:font fonts:hl12bi :string ,(format nil "CLOS~{ ~s~}"
					  (clos-method-name aux-data)))))

(defmethod (show-clos-method-details :help) ()
  (let ((method-name (function-name (method-function-safe aux-data))))
    (format nil "
The inspection pane you just selected is currently displaying sundry details
about the method ~S.
"
	    method-name)))

;-------------------------------------------------------------------------------

(defflavor show-clos-generic-function-details ()
   (generic-middle-button-mixin auxiliary-data-mixin class-operation-mixin)
  (:documentation
"Shows 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 (show-clos-generic-function-details :After :init) (ignore)
  (if (compiled-function-p data)
      (setq data (ticlos:get-generic-function-object data))
      nil
  )
  (if (compiled-function-p aux-data)
      (setq aux-data (ticlos:get-generic-function-object aux-data))
      nil
  )
)

(defmethod (show-clos-generic-function-details :middle-button-result) ()
"Just returns the method itself."
  aux-data
)

(defmethod (show-clos-generic-function-details :format-concisely) (stream)
"Nothing special here.  Just prints out the generic function name, noting if
 it's a PCL one.
"
  (if (iwmc-class-p-safe data) (format stream "PCL ") nil)
  (format stream "Generic function ~s"
	  (generic-function-name-safe aux-data)
  )
)

(defwrapper (show-clos-generic-function-details :handle-mouse-click)
	    ((blip flavor-inspector) &body body)
"Makes 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))


(defun compact-arglists (arglists result)
"Given 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 get-compact-arglists (methods)
"Returns 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 (tv:method-arglist-safe x)) x)
	    )
	    methods
	)
	nil
      )
      nil
  )
)


(defun generic-function-arglist-items (gf args returned-values)
"Returns 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 (tv:generic-function-methods-safe gf)))
       (let ((method-arglists (get-compact-arglists methods)))
	   `((,(if returned-values
		    '(:font 1 "Arglist  Returned Values")
		    '(:font 1 "Arglist"))
	       (:colon 40)
	       ("~:[~*()~;~S~]" ,args ,args)
	       ,@(when returned-values
		   `(("  ~S" ,returned-values))))
	     ,@(if methods
		  `(,*blank-line-item*
		    ((:Font 1 "  Arglists for Methods:"))
		    ,@(apply #'append
			     (mapcar #'(lambda (x)
				  `(("    "
				     (:Item1 t ,(first (first x)))
				     ,@(if (second (first x))
					  `((:font 1 "  ")
					    (:Item1 t ,(second (first x)))
					   )
					   nil
				       )
				     (:Font 1 ,(if (rest (second x))
						   " for Methods"
						   " for Method"
					       )
				     )
				    )
				    ,@(mapcar
					#'(lambda (meth)
					    `("	"
					      (:Item1 instance
					      ,(allocate-data
						 'show-clos-method-details
						 meth meth
					       )
					      )
					     )
					  )
					  (second x)
				      )
				   )
				)
			        method-arglists
		          )
		    )
		  )
		  nil
	      )
	    )
       )
  )
)


(defmethod (show-clos-generic-function-details :generate-item) ()
"Makes 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 "Details of ")
	(:item1 instance
	    ,(allocate-data 'show-clos-generic-function-details data aux-data))
	(:font 1 " (Class of function object ")
	(:item1 instance
		,(allocate-data 'show-clos-class (class-of-gf-safe aux-data)))
	(:font 1 ")"))
       ,*blank-line-item*
       ((:font 1 "Source 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 "Documentation:"))
       ,@(let ((doc (documentation aux-data)))
	   (if (and doc (not (equal "" doc)))
	       (break-string-into-lines doc)
	       *no-items*))
       ,*blank-line-item*
       ((:font 1 "Method Combination")
	(:colon 40)
	("~S" ,(generic-function-method-combination-safe aux-data)))
       ,*blank-line-item*
       ((:font 1 "Method Class")
	(:colon 40)
	(:item1 instance ,(allocate-data 'show-clos-class
			      (generic-function-method-class-safe aux-data)
			  )
	)
       )
       ,*blank-line-item*
       ((:font 1 "Associated 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 "Argument Precedence Order")
	(:colon 40)
	("~S" ,(argument-precedence-order-safe aux-data)))
       ,*blank-line-item*
       ((:font 1 "Declarations")
	(:colon 40)
	,(if (generic-function-declarations-safe aux-data)
	     `("~S" ,(generic-function-declarations-safe aux-data))
	     '(:font 2 " none")
	 )
       )
       ,*blank-line-item*
       ((:font 1 ,(if (iwmc-class-p-safe aux-data)
		      ""
		      "Referenced Slots:")))
       ,@(referenced-instance-variables-details aux-data referenced-ivars)
       ,*blank-line-item*
       ((:font 1 "Referenced Keywords (possibly messages passed):"))
       ,@(referenced-keywords-details referenced-keywords)
       ,*blank-line-item*
       ((:font 1 "Referenced Generic Functions:"))
       ,@(referenced-generic-functions-details
	    referenced-generic-functions
	 )
       ,*blank-line-item*
       ((:font 1 "Referenced Functions:"))
       ,@(referenced-functions-details referenced-functions)
       ,*blank-line-item*
       ((:font 1 "Locals:"))
       ,@(locals-details locals)
       ,*blank-line-item*
       ((:font 1 "Referenced Specials:"))
       ,@(referenced-specials-details specials-referenced)
       ,*blank-line-item*
       ((:font 1 "Specials Bound:"))
       ,@(bound-specials-details specials-bound)
       ,*blank-line-item*
       ((:font 1 "Macros Expanded:"))
       ,@(macros-expanded-details (get-fef-from-object aux-data))
       ,*blank-line-item*
       ((:font 1 "Interpreted Definition:"))
       ,@(interpreted-definition-details (get-fef-from-object aux-data))
       ))
    `(:font fonts:hl12bi :string
	    ,(format nil "~AGeneric-function ~s"
		     (if (iwmc-class-p-safe aux-data) "PCL " "")
		     (generic-function-name-safe aux-data)))))

(defmethod (show-clos-generic-function-details :help) ()
  (let ((name (generic-function-name-safe aux-data)))
    (format nil "
The inspection pane you just selected is currently displaying sundry details
about the generic function ~S.
"
	    name)))

;-------------------------------------------------------------------------------

(defvar *clos-generic-function-operations-menu*
	'(("Inspect" :value :inspect-generic-function
	   :documentation "Show information about this generic-function:
slots and methods referenced, arglist, documentation, source file"
	  )
	  ("Disassemble" :value :disassemble-generic-function
	   :documentation
	   "Use a standard Inspect window to show disassembled code."
	  )
	  ("Edit Source" :value :edit-generic-function
	   :documentation "Edit this generic-function in a Zmacs buffer.")
	  ("Trace" :value :trace-generic-function
	   :documentation "Invoke a trace window to trace this generic function"
	  )
	 )
"The 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 show-clos-generic-function () (inspection-data)
  (:documentation
"Displays 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 (show-clos-generic-function :After :init) (ignore)
  (if (compiled-function-p data)
      (setq data (ticlos:get-generic-function-object data))
      nil
  )
)

(defmethod (show-clos-generic-function :middle-button-result) ()
"Returns the class, not the GF."  ;;; Is this right?
  data
)

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

(defun format-a-generic-function-concisely
       (gf stream &optional (indent1 *indent1*) (indent2 *indent2*))
"This 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 "~~VT~S"
			  gf-name indent2 (arglist gf)
		  )
		  (format stream "~ ~~VT~S"
			  (list (class-of-safe gf) t class-name)
			  gf-name indent2 (arglist gf)
		  )
	      )
	 )
    )
    nil
  )
)

(defmethod (show-clos-generic-function :format-concisely) (stream)
"Prints 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 "~AGeneric Function "
		     (if (iwmc-class-p-safe data) "PCL " "")
	     )
	     (format-a-generic-function-concisely data stream 0 0)
      )
      (progn (if *dont-have-initial-space*
		 nil
		 (format stream " ")
	     )
	     (format-a-generic-function-concisely data stream)
      )
  )
)

;(defmethod (show-clos-generic-function :who-line-doc) (ignore &optional ignore)
;"Returns a who-line doc string for show-clos-generic-functions."
;  '(:mouse-l-1 "Inspect generic function details"
;    :mouse-m-1 ""
;    :mouse-r-1 "Menu of generic function operations"
;   )
;)

(defmethod (flavor-inspector :inspect-generic-function) (generic-function class)
"Given a generic function inspects its details."
  (send self :inspect-thing 'show-clos-generic-function-details
	class generic-function
  )
)

;(defmethod (flavor-inspector :disassemble-generic-function)
;	   (generic-function  class)
;"Given a generic function disassembles it."
;  (ignore class)
;  (inspect (get-fef-from-object generic-function))
;)

(defmethod (flavor-inspector :edit-generic-function) (generic-function class)
"Given a generic function edits its source it."
  (ignore class)
  (ed (generic-function-name-safe generic-function))
)

(defmethod (flavor-inspector :trace-generic-function) (generic-function class)
"Given a generic function traces it."
  (ignore class)
  (trace-via-menus (generic-function-name-safe generic-function))
)


(defun select-clos-generic-function-operations
       (generic-function flavor-inspector current-class
	&optional selection
       )
"This 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 () "~s"
			(function-name
			 (generic-function-name-safe generic-function)
			)
		)
	      )
	  )
	)
       )
       (if choice
	   (send flavor-inspector choice generic-function current-class)
	   nil
       )
  )
)


(defmethod (show-clos-generic-function :handle-mouse-click)
	   (blip flavor-inspector)
"Handles 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 (show-clos-generic-function :generate-item) ()
"This isn't actually invoked (or it shouldn't be).  It's here just in case."
  (values `(,*blank-line-item*
	    ((:font 1 "Details of ")
	     (:item1 instance
		     ,(allocate-data 'show-clos-generic-function data)))
	    ,*blank-line-item*
	    ((:font 1 "Data:      ")
	     (:item1 instance ,data)))
	  `(:font fonts:hl12bi :string
		  ,(format nil "CLOS~{ ~s~}"
			   (generic-function-name-safe data)))))

(defmethod (show-clos-generic-function :help) ()
  (let ((name (generic-function-name-safe data)))
    (format nil "
The inspection pane you just selected is currently displaying the
generic function ~S.
"
	    name)))

;-------------------------------------------------------------------------------

(defflavor show-clos-instance-variable
	   () (auxiliary-data-mixin class-operation-mixin)
  (:documentation
"Shows interesting things about a clos instance variable.  Aux-data holds
 the slot descriptor.  Data holds the class that defined it.
 If aux-data is a list then it is the form (slot instance-containing-this-slot)
"
  )
)

(defmethod (show-clos-instance-variable :format-concisely) (stream)
"Prints 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 "Slot ~s" (slotd-name-safe (ucl:first-if-list aux-data)))
      (format stream "~s" (slotd-name-safe (ucl:first-if-list aux-data)))
  )
)

(defmethod (show-clos-instance-variable :middle-button-result) ()
"Returns the slot descriptor."
  (if (consp aux-data)
      (or (second aux-data) (first aux-data))
      aux-data
  )
)

(defwhopper (show-clos-instance-variable :who-line-doc) (&rest args)
  (let ((result (lexpr-continue-whopper args))
	(stringm2 (format () "Set MAR to this slot"))
       )
       (if (and (fboundp 'set-mar-for-location)
		(consp aux-data)
		(ticlos-instance-p (second aux-data))
	   )
	   (if (member :Meta-mouse-m result)
	       (setf (getf result :Meta-mouse-m) stringm2)
	       (setq result (cons :Meta-mouse-m (cons stringm2 result)))
	   )
	   nil
       )
       result
   )
)

(defmethod (show-clos-instance-variable :handle-mouse-click)
	   (blip flavor-inspector)
"Handles L, M, M-M-1 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))
    (#\Meta-mouse-m
       (if (and (fboundp 'set-mar-for-location)
		(consp aux-data)
		(ticlos-instance-p (second aux-data))
	   )
	   (funcall 'set-mar-for-location
	     (ticlos:slot-location
	       (third aux-data) (slotd-name-safe (ucl:first-if-list aux-data))
	     )
	   )
	   (beep)
       )
    )
    (otherwise (beep))
  )
)

(defun comma-separate (list)
"Given 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 ", ") (comma-separate (rest list)))
      )
      (if list
	  list
	 `((:Font 2 "none"))
      )
  )
)

(defun slot-function-items (function slot)
"Given 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 (show-clos-instance-variable :generate-item) ()
"Displays all sorts of interesting things about slots."
  (let ((slot (ucl:first-if-list aux-data)))
    (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 slot))
       )
       `(,*blank-line-item*
	 ((:font 1 "Name") (:colon 20) (:item1 t ,(slotd-name-safe slot)))
	 ,*blank-line-item*
	 ((:font 1 "Defining Class") (:colon 20)
	  (:item1 instance ,(allocate-data 'show-clos-class data))
	 )
	 ,*blank-line-item*
	 ((:font 1 "Type") (:colon 20)
	  (:item1 named-structure-value ,(slotd-type-safe slot))
	 )
	 ,*blank-line-item*
	 ((:font 1 "Allocation") (:colon 20)
	  ,@(let ((alloc (slotd-allocation-safe slot)))
		 (if (consp alloc)
		     `((:Font 2 ,(format nil "~A " (first alloc)))
		       (:item1 instance
			       ,(allocate-data 'show-clos-class (second alloc))
		       )
		      )
		     `((:Font 2 ,(format nil "~A" alloc)))
		 )
	    )
	 )
	 ,*blank-line-item*
	 ((:font 1 "Documentation:"))
	 ,@(let ((doc (documentation slot)))
	     (if (and doc (not (equal "" doc)))
		 (break-string-into-lines doc)
		 *no-items*))
	 ,*blank-line-item*
	 ((:font 1 "Readers") (:colon 20)
	  ,@(slot-function-items 'slotd-readers-safe slot)
	 )
	 ,*blank-line-item*
	 ((:font 1 "Writers") (:colon 20)
	  ,@(slot-function-items 'slotd-accessors-safe slot)
	 )
	 ,*blank-line-item*
	 ((:font 1 "Initform") (:colon 20)
	  ,(let ((form (slotd-initform-safe slot)))
		(if form
		    (if (equal `(quote nil) form)
		       `(:item1 t nil)
		       `(:item1 t ,form)
		    )
		   '(:font 2 "none")
		)
	   )
	 )
	 ,*blank-line-item*
	 ((:font 1 "Initargs") (:colon 20)
	  ,@(comma-separate
	      (mapcar #'(lambda (x) `(:item1 named-structure-value ,x))
		      (slotd-initargs-safe slot)
	      )
	    )
	 )
	 ,*blank-line-item*
	 ((:font 1 "Methods of ")
	  (:item1 instance ,(allocate-data 'show-clos-class data))
	  (:font 1 " referencing slot ")
	  (:item1 instance
		  ,(allocate-data 'show-clos-instance-variable data slot))
	  (:font 1 ,(if special-comb? "." ":")))
	 ,@(when special-comb?
	     '(((:font 1 " * = special method combination type"))))
	 ,*blank-line-item* . ,(if items
				 (cons *clos-method-display-columns-2* items)
				 *no-items*)))
     `(:font fonts:hl12bi :string
	     ,(format () "Slot ~S's details" (slotd-name-safe slot))))
  )
)


(defun method-references-slot (method slotd)
"Is 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 (show-clos-instance-variable :help) ()
  (let ((name (slotd-name-safe data)))
    (format nil "
The inspection pane you just selected is currently displaying sundry details
about the slot ~S.
"
	    name)))

;-------------------------------------------------------------------------------


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

(defmethod (show-clos-instance-variables :format-concisely) (stream)
"Says \"Foo's slots\" for a class named Foo."
  (format stream "~'s slots"
	  (list data nil (class-pretty-name data (in-history-window-p stream)))
  )
)

(defmethod (show-clos-instance-variables :middle-button-result) ()
"Returns the class itself."
  data
)

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

(defun print-object-just-as-name (instance stream &optional (level 0))
"If 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)
  )
)

(defun get-gf-for-slot-function (fn)
"Given a function name e.g. foo or (setf foo), returns the gf for it."
  (function-generic-function-safe
    (typecase fn
      (symbol (symbol-function fn))
      (cons
       (case (first fn)
	 (setf (or (catch-error (fdefinition fn) nil)
		   (get (second fn) 'sys:setf-function)
	       )
	 )
	 (otherwise (ferror nil "???"))
       )
      )
      (otherwise (ferror nil "???"))
    )
  )
)


(defun make-slot-function-item (fn)
"Makes 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 item-for-slot-function (slot key name)
"For 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 "        " (string-capitalize name) "s: "))
       ,*blank-line-item*
       ,@(comma-separate (mapcar #'make-slot-function-item (funcall key slot)))
      )
     `((:font 2 ,(string-append " no " name "s ")))
  )
)

(defun clos-local-instance-variable-item (slotd inherited-class)
"Generates 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 "writer")
   ,@(item-for-slot-function slotd #'slotd-readers-safe "reader")
   ,@(if (equal (slotd-initform-safe slotd) '(nil))
	 `((:font 2 " no initform "))
	 `((:font 2 " Initform: ")
	   (:item1 instance
		   ,(allocate-data 'show-value (slotd-initform-safe slotd) nil)
	   )
	 )
     )
  )
)

(defun flavors-local-instance-variable-item
       (var inherited-flavor of-flavor)
"Generates 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 ()
      " ~:[   ~; 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 "unbound        ")
	`(: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 clos-local-instance-var-item-list
       (inherited-variables inherited-class of-class)
"Generates 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 () "~s's Initializations"
					 (flavor-or-class-name of-class))))
		      ,@items)
		    `((,*ivar-column-headers*) ,@items))
		`((,*clos-ivar-column-headers*) ,@items)))))

(defmethod (show-clos-instance-variables :generate-item) ()
"Makes 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 "Local to class ")
        (:item1 instance ,(allocate-data 'show-clos-class data))
	(:font 1 ":"))
       ,@(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 "Inherited from ")
                 (:item1 instance ,(allocate-data 'show-clos-class cl))
		 (:font 1 ":"))
		,@(clos-local-instance-var-item-list local-vars cl data)))))
     `(:font fonts:hl12bi :string
       ,(format () "~A's slots" class-name)))))


(defmethod (show-clos-instance-variables :help) ()
  (let ((name (Class-Pretty-Name data)))
    (format nil "
The 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)))

;-------------------------------------------------------------------------------


(defflavor show-all-flavors-and-classes () (inspection-data)
  ;;Used just to make allocate-data work on it.  See reference to 'IGNORE below.
  (:default-init-plist :data 'ignore)
  (:documentation
"This is the class inspector equivalent of the show-all-flavors option in the
 flavor inspector.  It turns out that this is a pretty bad thing in TICLOS,
 though not such a bad thing in PCL.  TICLOS doesn't keep a global note of
 all named classes that are generated.  Thus if the user picks this one he
 might be stuck with quite a wait, whilst the system does a do-all-symbols....
"
  )
)

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

(defmethod (show-all-flavors-and-classes :format-concisely) (stream)
"Just 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) "All flavors and classes" "All flavors"))
)

(defmethod (show-all-flavors-and-classes :who-line-doc)
	   (ignore &optional ignore)
"A who line doc string returning method for the display of all flavors
 and classes.
"
  (if (clos-p)
      '(:any "Inspect this flavor or class information")
      '(:any "Inspect this flavor information")
  )
)

(defmethod (show-all-flavors-and-classes :handle-mouse-click)
	   (blip flavor-inspector)
"A 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))
    ;;Could we put anything interesting on right click?  Maybe
    ;;Flavor-name apropos, or some complex query for locating sets of
    ;;flavors with common characteristics?
    (t (beep))))

(defmethod (show-all-flavors-and-classes :generate-item) ()
"Generates 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 "Currently defined flavors: "))
     ,*blank-line-item*
     ;;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 "Currently defined classes: "))
	    '((:font 1 "")))
	,*blank-line-item*
	;;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) "All flavors and classes" "All flavors"))))


(defmethod (show-all-flavors-and-classes :help) ()
  (format nil (if (clos-p)
		  "
The 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."
		  "
The 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."
	      )
  )
)

;-------------------------------------------------------------------------------

(defflavor debug-class ()
  (flavor-operation-mixin)
  (:Documentation :Special-Purpose
"A 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 (debug-class :Middle-Button-Result) ()
  data
)

(defmethod (debug-class :format-concisely) (stream)
"Prints 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 "~'s debug data"
          (list (allocate-data 'show-clos-class data) nil
		(Class-Pretty-Name data (in-history-window-p stream))
	  )
  )
)

(defun get-class-ivs (class)
"If 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 get-flavor-and-class-ivs (class)
"Given 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 find-slotd (name class)
"Given 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 reslotd-ify (clash)
"Is 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 find-multiple-slot-definitions (components iv-lists &rest args)
"Given 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 show-an-iv (ivar-or-slotd class)
"Given 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 show-a-fl-or-cl (data)
"Allocates 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 in-string (data)
"If data is a class then it returns \" in class \", otherwise \" in flavor \"."
  (if (class-p-safe data)
      " in class "
      " in flavor "
  )
)


(defun get-local-undefined-class-components (class)
"Given 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 collect-undefined-class-components (class)
"Given 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 primary-methods (class)
"Given 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)
  )
)

(defun my-subtypep (a b)
"Like subtypep, only it works for classes as well as symbols."
  (let ((name-a (if (class-p-safe a) (class-name-safe a) a))
	(name-b (if (class-p-safe b) (class-name-safe b) b))
       )
      (or (subtypep name-a name-b)
	  (catch-error (subclassp-safe (coerce-to-class a) (coerce-to-class b))
		       nil
	  )
      )
  )
)

    
(defun class-shadows (class1 class2)
"Is true if Class1 shadows Class2, i.e. if class1 is not class2, but class2
 is subtypep of class1.  This allows us to compute which primary methods
 are being shadowed.  If the classes are known to be disjoint then it returns
 :disjoint.
"
  (if (and class1 class2
	   (not (equal class1 class2))
      )
      (if (my-subtypep class1 class2)
	  t
	  (if (my-subtypep class2  class1)
	      nil
	      :disjoint
	  )
      )
      nil
  )
)

(defun shadows-p (specs1 specs2 so-far)
"Is 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 is-shadowed-by-any (meth methods)
"Is 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 get-shadowed-clos-methods-1 (class)
"Gets 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 get-shadowed-clos-methods (class)
"Gets 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 (debug-class :generate-item) ()
"This 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*
;------------------------------
	,@(if clashes
	      `(((:FONT 1 "Multiple declarations of the same slots for class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for clash in clashes
	        append `(((:FONT 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)))))
	  )
;------------------------------
	,@(if package-clashes *blank-line-item*)
	,@(if package-clashes *blank-line-item*)
	,@(if package-clashes
	      `(((:FONT 1 "Declarations of slots with the same PName but are in different packages for class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for clash in package-clashes
	        append `(((:FONT 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 " 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)))))
	 )
;------------------------------
	,@(if undefined-class-components *blank-line-item*)
	,@(if undefined-class-components *blank-line-item*)
	,@(if undefined-class-components
	      `(((:FONT 1 "Undefined components of class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for undefined in undefined-class-components
	        append `(((:ITEM1 INSTANCE
			    ,(allocate-data 'show-undefined-clos-class
					    (first undefined)))
			  (:FONT 3 " of class ")
			  (:ITEM1 INSTANCE
				  ,(show-a-fl-or-cl (second undefined)))))
	 )
;------------------------------
	,@(if unsatisfied-flavors *blank-line-item*)
	,@(if unsatisfied-flavors *blank-line-item*)
	,@(if unsatisfied-flavors
	      `(((:FONT 1 "Unsatisfied required flavors of class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      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 " for flavor ")
			  (:ITEM1 INSTANCE
			   ,(allocate-data 'show-flavor (second unsatisfied)))))
	 )
;------------------------------
	,@(if unsatisfied-methods *blank-line-item*)
	,@(if unsatisfied-methods *blank-line-item*)
	,@(if unsatisfied-methods
	      `(((:FONT 1 "Unsatisfied required methods of class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for unsatisfied in unsatisfied-methods
	        append `(((:FONT 1 ,(format nil "~S" (first unsatisfied)))
			  (:FONT 3 " for flavor ")
			  (:ITEM1 INSTANCE
			   ,(allocate-data 'show-flavor (second unsatisfied)))))
	 )
;------------------------------
	,@(if unsatisfied-ivs *blank-line-item*)
	,@(if unsatisfied-ivs *blank-line-item*)
	,@(if unsatisfied-ivs
	      `(((:FONT 1 "Unsatisfied required instance variables of class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for unsatisfied in unsatisfied-ivs
	        append `(((:FONT 1 ,(format nil "~S" (first unsatisfied)))
			  (:FONT 3 " for flavor ")
			  (:ITEM1 INSTANCE
			   ,(allocate-data 'show-flavor (second unsatisfied)))))
	 )
;------------------------------
        ,@(if shadowed-clos-methods *blank-line-item*)
	,@(if shadowed-clos-methods *blank-line-item*)
	,@(if shadowed-clos-methods
	      `(((:FONT 1
		 "Primary CLOS methods of component classes shadowed by class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for shadow in shadowed-clos-methods
	        append `(((:ITEM1 INSTANCE
			   ,(allocate-data 'show-clos-method (second shadow))
			   print-unpadded-method)
			  (:FONT 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
	      "Primary Flavors methods of component flavors shadowed by class ")
		 (:ITEM1 INSTANCE ,(allocate-data 'show-clos-class class))
		 (:FONT 1 ":")))
	      nil
	 )
	,@(loop for shadow in shadowed-methods
	        append `(((:ITEM1 INSTANCE
				  ,(allocate-data 'show-method
						  (fourth (second shadow))))
			  (:FONT 3 " of flavor ")
			  (:ITEM1 INSTANCE
				  ,(allocate-data 'show-flavor (third shadow)))
			  (:FONT 3 " shadowed by flavor ")
			  (:ITEM1 INSTANCE
				 ,(allocate-data 'show-flavor (first shadow)))))
	 )
;---------------------------------
       )
      `(:FONT fonts:hl12bi :STRING ,(FORMAT NIL "~A's Debug data" class-name)))
  )
)


;-------------------------------------------------------------------------------

;;; Patches 
;;; =======

;-------------------------------------------------------------------------------


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


(defmethod (flavor-inspector :inspect-object) (object)
"Is 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)
					 "~S is not a flavor or class."
					 "~S is not a flavor.")))))))
    ;; First flush item we will be inspecting
    (inspect-flush-from-history thing history)
    (send history :append-item thing)
    (update-panes)))


;(defun inspect-flavor (&optional (object nil objp))
;"Call the Flavor Inspector to inspect OBJECT.  Selects a Flavor Inspector
; window.  The Inspector runs in its own process, so your special variable
; bindings will not be visible. If you type END or use the exit menu option
; the original object will be returned."
;  (let ((iframe (find-or-create-window 'flavor-inspector))
;        (top-item nil))
;        (declare (special top-item))
;	(if objp
;	    (cond ((instancep object)
;		   (send iframe :inspect-instance object))
;		  ((typep object 'si:flavor)
;		   (send iframe :inspect-structure object))
;		  ((iwmc-class-p-safe object)
;		   (send iframe :inspect-class object))
;		  (t (send iframe :inspect-object object)))
;	     object)))

(defun read-flavor-name ()
"Reads 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)
				    "Flavor\/Class name: "
				    "Flavor 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 "** ~s is not a defined flavor or class" flavor-name)
       (send self :handle-prompt)
       (throw 'ucl::command-abort nil)))))

;-------------------------------------------------------------------------------

;;; The following are renamed from sys:debug-tools;flavor-inspector.lisp

(defmethod (basic-flavor-inspector :after :init)(&rest ignore)
  (if label
      (progn (setf (label-font label) fonts:cptfontb)
	     (setf (label-background label) w:75%-gray-color))
      nil)
  (setf (sheet-background-color (send self :get-pane 'menu)) w:33%-gray-color))

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :before :expose) ()
  (SEND self :set-configuration *Flavor-Inspector-Configuration*))

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :around :HANDLE-PROMPT) (cont mt ignore &OPTIONAL ignore use-prompt)
  ;;Makes our prompt print in bold font.  This helps the user to see that he is in the
  ;;Flavor Inspector, instead of the normal inspector, since our prompt is different.
  ;;We also accept an optional prompt argument to use instead of the normal prompt.
  (LET ((old-prompt UCL:PROMPT))
    (UNWIND-PROTECT
        (PROGN
          (SEND user :SET-CURRENT-FONT 1)
          (WHEN use-prompt
            (SETQ UCL:PROMPT use-prompt))
          (FUNCALL-WITH-MAPPING-TABLE cont mt :handle-prompt))
          (SEND user :SET-CURRENT-FONT 0)
          (SETQ UCL:PROMPT old-prompt))))

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :AFTER :SELECT) (&rest ignore)
  ;;This is a hack to get the flavors list and the completion code paged in, so that auto-completion is fast.
  ;;Of course, if the user does enough stuff while in the window, it will get paged out.
  ;;GET-WORD-COMPLETIONS expects a string, not a symbol so quoted si:vanilla-flavor.
  (W:GET-WORD-COMPLETIONS "si:vanilla-flavor" *ALL-FLAVOR-NAMES*))

(defmethod (basic-flavor-inspector :update-*) ()
  (LET* ((ITEMS (SEND HISTORY :ITEMS))
	 (NITEMS (IF ITEMS (ARRAY-ACTIVE-LENGTH ITEMS) 0)))
    (if(>= NITEMS 1) (cond ((consp (AREF ITEMS (- NITEMS 1)))
			    (setq * (car (send (AREF iTEMS (- NITEMS 1)) :send-if-handles :aux-data))))
			   ((eq 'ignore (send (AREF ITEMS (- NITEMS 1)) :data))
			    t)
			   (t (or (setq * (send (AREF ITEMS (- NITEMS 1)) :send-if-handles :aux-data))
				  (setq * (si:flavor-name (send (AREF ITEMS (- NITEMS 1)) :data)))))))
    (if (>= NITEMS 2)(cond ((consp (AREF ITEMS (- NITEMS 2)))
			    (setq ** (car (send (AREF iTEMS (- NITEMS 2)) :send-if-handles :aux-data))))
			   ((eq 'ignore (send (AREF ITEMS (- NITEMS 2)) :data))
			    t)
			   (t (or (setq ** (send (AREF ITEMS (- NITEMS 2)) :send-if-handles :aux-data))
				  (setq ** (si:flavor-name (send (AREF ITEMS (- NITEMS 2)) :data)))))))
    (if (>= NITEMS 3)(cond ((consp (AREF ITEMS (- NITEMS 3)))
			    (setq *** (car (send (AREF iTEMS (- NITEMS 3)) :send-if-handles :aux-data))))
			   ((eq 'ignore (send (AREF ITEMS (- NITEMS 3)) :data))
			    t)
			   (t (or (setq *** (send (AREF ITEMS (- NITEMS 3)) :send-if-handles :aux-data))
				  (setq *** (si:flavor-name (send (AREF ITEMS (- NITEMS 3)) :data)))))))))


(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :NAME-FOR-SELECTION) () name)

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :inspect-object) (object)
  (LET ((thing (inspect-real-value
                 `(:VALUE ,(ALLOCATE-DATA 'SHOW-FLAVOR (GET object 'SI:FLAVOR)) ,HISTORY))))
    ;; First flush item we will be inspecting
    (inspect-flush-from-history thing history)
    (SEND history :APPEND-ITEM thing)
    (update-panes)))

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :inspect-structure) (object)
  (LET ((thing (inspect-real-value
                 `(:VALUE ,(ALLOCATE-DATA 'SHOW-FLAVOR  object) ,HISTORY))))
    ;; First flush item we will be inspecting
    (inspect-flush-from-history thing history)
    (SEND history :APPEND-ITEM thing)
    (update-panes)))

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :inspect-instance) (object)
  (LET ((thing (inspect-real-value
                 `(:VALUE ,(ALLOCATE-DATA 'SHOW-FLAVOR (GET (type-of (eval object)) 'SI:FLAVOR)) ,HISTORY))))
    ;; First flush item we will be inspecting
    (inspect-flush-from-history thing history)
    (SEND history :APPEND-ITEM thing)
    (update-panes)))

(DEFMETHOD (BASIC-FLAVOR-INSPECTOR :PREPARE-FOR-USE) (Initial-OBJECT NEW-LABEL)
"This is a modified version of the Inspect-Frame :Prepare-for-use method.
It is passed some object which should be coercable into a flavor examinable
thing, i.e. a symbol, a flavor structure, a method spec or a method.
It coerces the object suitably and puts it into the history list and
starts the window up.
Created by JPR on 21 May 86."
  (SEND SELF :SET-LABEL NEW-LABEL)
  (let ((object (find-flavor-inspectable-object initial-object)))
       (LET ((HW (SEND SELF :GET-PANE 'HISTORY)))
	 (if (and initial-object (not object))
	     ;;If the initial object is non-nil but the coerced object is nil (i.e. it can't find a flavor or a method)
	     ;;then just beep and return an error code.
	     (progn (beep) :Object-Not-Found)
	     ;;Otherwise put the object into the history list.
	     (progn (COND
		      (OBJECT
		       (WITH-SHEET-DEEXPOSED (SELF) (SEND HW :FLUSH-CONTENTS)
					     (SEND HW :APPEND-ITEM OBJECT)
					     (DOLIST (IW (SEND SELF :INSPECTORS))
					       (SEND IW :SET-CURRENT-DISPLAY
						     (SEND IW :SETUP
							   `(INSPECT-PRINTER NIL NIL NIL
									     (NIL NIL NIL NIL
										  ,(LABEL-FONT (SEND IW :LABEL))
										  "Empty"))))
					       (SEND IW :SET-CURRENT-OBJECT (LIST NIL))))))
		    (SEND (SEND SELF :TYPEOUT-WINDOW) :MAKE-COMPLETE)
		    (SEND HW :CLEAR-INPUT))))))

;-------------------------------------------------------------------------------

(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :help-on-syntax) ()
  '(:names ("Syntax Help")
    :KEYS #\META-HELP
    :DESCRIPTION "Prints help on the processing of typed expressions.")
  (SEND SELF :FORMAT-MESSAGE
	"
You may type any of the following expressions:

-- 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 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"))


(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :HELP-ON-INSPECTED-DATA) ()  
   '(:KEYS #\MOUSE-M       ;mouse-m-1 before xlate
     :DESCRIPTION "Information about the data currently displayed in an inspection pane.")
   (IF (MEMBER (THIRD UCL::KBD-INPUT) INSPECTORS :TEST #'EQ)
     (LET* ((INSPECTION-DATA (SEND (THIRD UCL::KBD-INPUT) :CURRENT-OBJECT))
	    (HELP
	     (WHEN (TYPEP INSPECTION-DATA 'INSPECTION-DATA)
	       (SEND INSPECTION-DATA :SEND-IF-HANDLES :HELP))))
       (IF (EQUAL INSPECTION-DATA '(NIL))
	 (SEND SELF :FORMAT-MESSAGE "
MOUSE M is inactive when the inspection pane is empty.")
	 (SEND SELF :FORMAT-MESSAGE (OR HELP "
No help is available on this data."))))
     (BEEP))) 


(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :OPTIONS-MENU) ()  
   '(:KEYS #\MOUSE-R 
     :DESCRIPTION "A 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 "
MOUSE R is inactive when the inspection pane is empty."))
	 ((TYPEP INSPECTION-DATA 'FLAVOR-OPERATION-MIXIN)
	  (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 "Operations on ~S" (SI:FLAVOR-NAME *FLAVOR-DATA*))
                                          :scrolling-p nil)
		   (if call-edit
		       (ed (si:flavor-name *flavor-data*)))
		   ))))
;	  (w:MENU-CHOOSE *FLAVOR-OPTIONS-MENU*	
;                         :LABEL (FORMAT () "Operations on ~S" (SI:FLAVOR-NAME *FLAVOR-DATA*))	
;                         :scrolling-p nil))))
     (BEEP))) 

(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :end-cmd) ()
  '(:DESCRIPTION "Exit the Flavor Inspector."
    :NAMES ("Exit")
    :KEYS (#\END))
  (SEND SELF :bury))    ;changed from :bury, this returns the frame to its resource

(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :all-flavors) ()
  '(:DESCRIPTION "Display all flavor names in an inspection frame"
    :DOCUMENTATION "...permits user to select a flavor to inspect..."
    :KEYS #\SUPER-A)
  (LET ((flavors (inspect-real-value `(:value ,(allocate-data 'show-all-flavors 'IGNORE) ,history))))
    ;;Might not work since not EQ
    (inspect-flush-from-history flavors history)
    (SEND history :append-item flavors)
    (update-panes)
    ;;We don't want our result to be printed.
    (SETQ UCL:INHIBIT-RESULTS-PRINT? T))) 

(DEFCOMMAND CONFIG-TOGGLE-CMD NIL
            '(:DESCRIPTION  "Select a new Flavor-Inspector pane configuration."
              :NAMES ("Config")
              :KEYS (#\s-C))
            (DECLARE (SPECIAL FRAME))
            (LET ((new-cfg (w:menu-choose '(:three-panes :one-pane :two-horizontal-panes :two-vertical-panes)
                                        :label "Choose a new flavor-inspector configuration" :scrolling-p nil)))
              (DELAYING-SCREEN-MANAGEMENT 
                (COND (new-cfg
                       (SETQ *flavor-inspector-configuration* new-cfg)
                       (SEND frame :set-configuration new-cfg))))))

(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :trace-method) ()
  '(:DESCRIPTION "Traces a specified method"
    :NAMES ("Trace")
    :KEYS (#\S-T))
  (DECLARE (SPECIAL UCL:TYPEIN-MODES UCL:PROMPT))
  (LET ((method-spec (read-method-spec)))
    (TRACE-VIA-MENUS method-spec)))


(DEFCOMMAND (BASIC-FLAVOR-INSPECTOR :fi-doc-cmd) ()
            '(:DESCRIPTION 
             "Display some brief documentation about each of the Flavor-Inspector's panes."
             :NAMES ("Help")
             :KEYS (#\c-HELP))
  (FI-DOC-CMD))


;-------------------------------------------------------------------------------


(defun flavor-inspector-panes ()
"Pulled out of the :before :init method to make it a little more modular."
  (list `(interactor
	   inspector-interaction-pane
	   :label nil
	   :more-p nil
	   ;:IO-BUFFER ,IOBUFF
	   :font-map  ,(list (first *inspector-font-map*)
			     (second *inspector-font-map*))
	   :who-line-message
 "To 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  ;-WITH-MARGIN-SCROLLING
		  :line-area-mouse-doc
		  (:mouse-l-1 "Inspect the indicated data"
			      :mouse-m-1 "Remove it from the Flavor Inspector")
		  :normal-mouse-documentation
		  (:mouse-l-1 "Select data to inspect"
			      :mouse-m-2 "Lock/Unlock inspector pane"
			      :mouse-r-2 "System Menu"))
	`(menu inspector-menu-pane))
)

(defun flavor-inspector-constraints (inspectors noi)
"Pulled 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 (basic-flavor-inspector :before :init) (plist)
 ;;Specify our panes and constraints.  This differs from
 ;;(TV:INSPECT-FRAME :BEFORE :INIT) only in some of the who-line messages we
 ;;provide, which are specific to flavor inspectors.
  (unless inspectors ;;; It didn't use to have this test. JPR
  (let ((noi (or (get plist :number-of-inspectors) 3)))
        ;(iobuf (make-default-io-buffer)))
    (send self :set-panes (flavor-inspector-panes))
    ;;Add an inspector to PANES, taking into account the number of inspector
    ;;panes requested.  The first inspector is given a typeout pane.
    ;;Also initialize INSPECTORS.
    (dotimes (i noi)
      (let ((name1 (intern (format () "INSPECTOR-~D" i) "TV")))
	(push `(,name1 ,(if (= i (1- noi))
			    'inspect-window-with-typeout
			    'inspect-window)
                ;;Otherwise we get "More Object Above", etc.
                :current-object-who-line-message
		,(function (lambda (current-object)
			     (cond
			       ((equal current-object '(nil))
 "Flavor/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
				   "Select data to inspect"
				   :mouse-m-1 "Help on currently displayed data"
				   :mouse-m-2 "Lock/Unlock inspector pane"
				   :mouse-r-1
				    ,(format
				       ()
				       (if (clos-p)
					"Menu of operations on flavor\/class ~s"
					   "Menu of operations on flavor ~s")
				       (flavor-or-class-name
					 (send current-object :data)))))
			       (t '(:mouse-l-1 "Choose an item to inspect"))))))
              (send self :panes))
	(push name1 inspectors)))
    (send self :set-constraints
	  (flavor-inspector-constraints inspectors noi)))))

(defcommand (basic-flavor-inspector :options-menu) ()  
   '(:keys #\Mouse-r 
     :description
     "A 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 "
MOUSE R is inactive when the inspection pane is empty."))
	 ;;; 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 "Operations 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 "Operations on ~S"
				    (si:flavor-name *flavor-data*))
		     :scrolling-p nil)
		   (if call-edit
		       (ed (si:flavor-name *flavor-data*)))
		   ))))
     (beep)))


;;; This is rather like the All-Flavors command.  It has a short name because
;;; of the menu.
(defcommand (basic-flavor-inspector :all-fl&cl) ()
  '(:description "Display all flavor or class names in an inspection frame"
    :documentation "...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))))
    ;;Might not work since not EQ
    (inspect-flush-from-history flavors history)
    (send history :append-item flavors)
    (update-panes)
    ;;We don't want our result to be printed.
    (setq ucl:inhibit-results-print? t)))


;;; 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
     ;;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 "Flavor 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))

;-------------------------------------------------------------------------------


;;; Just a bug fix.
(DEFMETHOD (BASIC-INSPECT-FRAME :format-message) (string &REST format-args)
  (FUNCALL #'FORMAT typeout-window string format-args)
  (FORMAT typeout-window "~2%~a" tv:*REMOVE-TYPEOUT-STANDARD-MESSAGE*)
  (LET ((char (SEND TYPEOUT-WINDOW :ANY-TYI)))
    (UNLESS (or (consp char) (equal char #\SPACE))
      ;;; changed from = by JPR.  This could be a mouse blip
      (SEND *STANDARD-INPUT* :FORCE-KBD-INPUT char))
    (SEND (CAR inspectors) :flush-typeout)))


;-------------------------------------------------------------------------------

(defmethod (show-method-details :middle-button-result) ()
"Return the method itself."
  (second aux-data)
)

(DEFMETHOD (SHOW-METHOD-DETAILS :GENERATE-ITEM) ()
"This is a redefined version of the original method which takes advantage of the
 extensions to ivars-and-messages-in-method that I made.  JPR.
" 
 (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 " not available for wrappers")))
                                 '(((:FONT 2 " not available for interpreted methods"))))))
       (MULTIPLE-VALUE-BIND (ARGS RETURNED-VALUES)
           ;;Wrappers and interpreted methods have a method table entry format different from the norm.
           ;;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)))) ;;Take CDR to get rid of SI:.OPERATION. arg.
                 (T (CDR (ARGLIST (CADR AUX-DATA))))) ;;Take CDR to get rid of SI:.OPERATION. arg.
         `(,*BLANK-LINE-ITEM*
           ((:FONT 1 "Details of ")
            (:ITEM1 INSTANCE ,(ALLOCATE-DATA 'SHOW-METHOD-DETAILS DATA AUX-DATA)))
           ,*BLANK-LINE-ITEM*
           ((:FONT 1 "Source File:               ")
	   ;;;Changed by DAN to check for a null source-file property (Third aux-data) for the method,
	   ;;;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 "~a" (SEND (IF (CONSP sf) (CADR (ASSOC 'DEFUN sf :TEST #'EQ)) sf) :STRING-FOR-PRINTING)))
		(FORMAT NIL "Not Defined")))
           ((:FONT 1 "Method 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)
                   `("~S~@[ ~S~]" ,(CADR METHOD-ENTRY) ,(CADDR METHOD-ENTRY))
                   ":DAEMON (the default)")))
           (,(IF RETURNED-VALUES
                 '(:FONT 1 "Arglist  Returned Values: ")
                 '(:FONT 1 "Arglist:                   "))
            ("~:[~*()~;~S~]" ,ARGS ,ARGS)
            ,@(WHEN RETURNED-VALUES
                `(("  ~S" ,RETURNED-VALUES))))
           ,*BLANK-LINE-ITEM*
           ((:FONT 1 "Documentation:"))
           ,@(LET ((DOC (DOCUMENTATION (CADR AUX-DATA))))
               (IF (and doc (not (equal "" doc)))
                   (BREAK-STRING-INTO-LINES DOC)
                   *NO-ITEMS*))
           ,*BLANK-LINE-ITEM*
           ((:FONT 1 "Referenced Instance Variables:"))
	   ,@(referenced-instance-variables-details
	       (second aux-data) referenced-ivars)
	   ,*blank-line-item*
	   ((:font 1 "Referenced Keywords (possibly messages passed):"))
	   ,@(referenced-keywords-details referenced-keywords)
	   ,*blank-line-item*
	   ((:font 1 "Referenced Generic Functions:"))
	   ,@(referenced-generic-functions-details
		referenced-generic-functions
	     )
	   ,*blank-line-item*
	   ((:font 1 "Referenced Functions:"))
	   ,@(referenced-functions-details referenced-functions)
	   ,*blank-line-item*
	   ((:font 1 "Locals:"))
	   ,@(locals-details locals)
	   ,*blank-line-item*
	   ((:font 1 "Referenced Specials:"))
	   ,@(referenced-specials-details specials-referenced)
	   ,*blank-line-item*
	   ((:font 1 "Specials Bound:"))
	   ,@(bound-specials-details specials-bound)
	   ,*blank-line-item*
	   ((:font 1 "Macros Expanded:"))
	   ,@(macros-expanded-details (first aux-data))
	   ,*blank-line-item*
	   ((:font 1 "Interpreted Definition:"))
	   ,@(interpreted-definition-details (second aux-data))
;           ,@(OR NOT-AVAILABLE
;                 (LOOP FOR IVAR IN REFERENCED-IVARS
;                       COLLECT `(,*ONE-SPACE-ITEM*
;                                 (:ITEM1 INSTANCE ,(ALLOCATE-DATA 'SHOW-INSTANCE-VARIABLE IVAR)))))
;           ;;Anything you try to provide other than just printing these out will
;           ;;be truely inefficient, since you will have to search *ALL-FLAVOR-NAMES* for
;           ;;all methods of KEYWORD.  So, printing is probably the right thing to do.
;           ,*BLANK-LINE-ITEM*
;           ((:FONT 1 "Referenced Keywords (possibly messages passed):"))
;           ,@(OR NOT-AVAILABLE
;                 (LOOP FOR KEYWORD IN REFERENCED-KEYWORDS
;                       COLLECT `((" ~s" ,KEYWORD))))
	)))
     `(:font fonts:hl12bi :string ,(FORMAT nil "Method~{ ~s~}" (CDAR aux-data))))))

;(DEFCOMMAND DELETE-ALL-CMD NIL			
;            '(:DESCRIPTION  "Delete all inspected objects from history and inspection panes."
;              :NAMES ("Delete") :KEYS (#\c-PAGE))
;            (DECLARE (SPECIAL HISTORY inspectors))
;            (SEND HISTORY :FLUSH-CONTENTS)
;            (LOOP for iw in inspectors
;                  do (SEND iw :set-locked-p nil))
;	    ;;; Added by JPR.
;	    (setq *INSPECTION-DATA* nil)
;            (UPDATE-PANES))

(defun coerce-to-flavor (something &optional (error-p t))
  (typecase something
    (sys:flavor something)
    (symbol (if something
		(coerce-to-flavor (get something 'sys:flavor) error-p)
		(if error-p
		    (ferror nil "~S cannot be coerced into a flavor object."
			    something
		    )
		    nil
		)
	    )
    )
    (otherwise
     (if (class-p-safe something)
	 (get (class-name-safe something) 'si:flavor)
	 (if error-p
	     (ferror nil "~S cannot be coerced into a flavor object."
		     something
	     )
	     nil
	 )
     )
    )
  )
)

;(defun coerce-to-flavor (x)
;"If 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 (SHOW-INSTANCE-VARIABLE :HANDLE-MOUSE-CLICK) (BLIP FLAVOR-INSPECTOR)
  (IF (NOT (MEMBER (FOURTH BLIP) '(#\MOUSE-L #\MOUSE-M) :TEST #'EQ))
    (BEEP)
    (let ((flav (IF (EQL (FOURTH BLIP) #\MOUSE-L)
		    ;;; 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))))
      (if flav
	  (SEND FLAVOR-INSPECTOR :INSPECT-THING
		'SHOW-METHODS-REFERENCING-INSTANCE-VARIABLE
		flav
		DATA)
	  (beep)))))

(defmethod (show-instance-variable :middle-button-result) ()
"Just return the symbol that names the slot."
  data
)

;-------------------------------------------------------------------------------