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

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

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

;;; In this file there are a lot of functions called foo-Safe.  This is
;;; a bit of a strange name, that exists for historical reasons.  Maybe I'll
;;; change them all sometime.  Anyway the reason that they are "SAFE" is not
;;; that they won't barf horribly if you give them the wrong args or something
;;; goes wrong, but rather that foo-safe should work and do the right thing
;;; whether it is given a TICLOS thing or a PCL thing.  This is crucial to
;;; my intent of supporting both TICLOS and PCL in the Inspector.

;Ï1;;   NOT SUPPORTING PCL, but need the safety checks that these macros provide. TAC 08-17-89Ï*
;-------------------------------------------------------------------------------

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

(DEFF Ï4defstruct-safeÏ* 'DEFSTRUCT)

;Ï1***************Ï*
;Ï1 TAC 08-16-89 - this is from Structure-Enhancements - it gives an error message forÏ*
;Ï1                        structures instead of returning nil.Ï*

(DEFUN Ï4general-structure-message-handlerÏ* (message-name thing-to-deal-with &Rest other-arguments)
  "Ï2This is a general message handler for named structures.  It handles two
 messages: The first of these is :Which-Operations, which takes takes no
 arguments.  This message handler replies '(:Which-Operations :Print-Self) to
 this.  The second message that it responds to is :Print-Self.  This message
 takes three arguments; the stream to which the object is to be printed, the
 indentation depth and a slashification flag.  It uses the system's default
 named structure printer called si:print-named-structure to do this.  If it is
 sent a message other than these then an error is caused.  this is unlike the
 default behaviour, which causes nil to be returned.Ï*"
  (IF (EQUAL message-name :Print-Self)
      (LET ((STREAM (FIRST other-arguments))
	    (print-depth (SECOND other-arguments))
	    (slashify (THIRD other-arguments)))
	(IGNORE slashify print-depth)
	(si::print-named-structure (NAMED-STRUCTURE-P thing-to-deal-with)
				  thing-to-deal-with
				  print-depth
				  stream
				  (si::which-operations-for-print stream)))
      (IF (EQUAL message-name :Which-Operations)
	  '(:Which-Operations :Print-Self)
	  (FERROR "Ï3Illegal message sent to structure.Ï*"))))

(IMPORT 'General-Structure-Message-Handler 'TICL)
(EXPORT 'General-Structure-Message-Handler 'TICL)

;Ï1-------------------------------------------------------------------------------Ï*
;Ï1;; Just define a dummy package if CLOS is not loaded.  This should meanÏ*
;Ï1;; that these patches can be loaded onto a system which does not have CLOS loaded.Ï*

;Ï1;;  *** from Rice message Mods to TI-ENV-INSP.-INTERF. 8 Jun 1989 13:56:40 PDTÏ*
;Ï1;; !!!!!!!!!!!!!!! Note that the following three forms should be in this order.Ï*

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

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

;Ï1; Ï* TAC 08-28-89Ï1 - as per David Gray, better definition for ticlos-p, considering our environment Ï*
;(DEFUN Ï4ticlos-pÏ* ()
;"Ï2True if TICLOS is loaded.Ï*"
;  (MEMBER :clos *features*))

(DEFF-MACRO TICLOS-P #'TRUE)

;Ï1 TAC 08-17-89 - removing PCL support Ï*
;Ï1(DEFUN pcl-p ()Ï*
;Ï1"True if PCL is loaded."Ï*
;Ï1  ;;; Both of these are kludges.Ï*
;Ï1  (OR (MEMBER :portable-commonloops *features*)Ï*
;Ï1      (FBOUNDP 'pcl:defmethod)))Ï*

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

;Ï1 TAC 08-17-89 - removing PCL support Ï*
;Ï1(DEFUN clos-p ()Ï*
;Ï1"True if some sort of CLOS is loaded."Ï*
;Ï1  (OR (ticlos-p) (pcl-p)))Ï*

(DEFUN Ï4clos-pÏ* ()
"Ï2True if TICLOS is loaded.Ï*"
  (ticlos-p))

;Ï1; Warning this is very system dependent !!!!!!!! JPR.Ï*
(DEFUN Ï4ticlos-instance-pÏ* (instance)
"Ï2This should return T if Instance is an instance of a TICLOS class.
 Whenever a TICLOS class is instantiated it has a cdr code bit set, which
 distinguishes it from flavors instances.  This is sometimes not the case,
 however, for standard methods and such like, which are flavor class instances
 for some reason.Ï*"
  (AND (INSTANCEP instance)
           ;Ï1; definitely.Ï*
       (OR (TICLOS:CLOS-INSTANCE-P instance)
	   ;Ï1; Somewhat kludgy, but standard classes seem not to have the above property.Ï*
	   (AND (SYMBOLP (TYPE-OF instance))
		(OR (MEMBER (TYPE-OF instance)
			    '(ticlos:standard-writer-method
			      ticlos:standard-reader-method
			      ticlos::combined-method))
		    (NOT (TYPEP (CLOS:CLASS-OF instance) 'ticlos:flavor-class)))))))

;Ï1 TAC 08-17-89 - removing PCL support and redefining defsafe macro Ï*
;Ï1(DEFMACRO defsafeÏ*
;Ï1      (fname (discriminator &rest args) &key (DOCUMENTATION nil)Ï*
;Ï1       (pcl nil) (ticlos nil) (error-p t) (declarations nil))Ï*
;Ï1"Defines a function called FName, which should execute PCL if DiscriminatorÏ*
;Ï1 is a PCL thing or TICLOS if it is a TICLOS instance.  If Error-p is trueÏ*
;Ï1 and Discriminator is neither a PCL or TICLOS thing then it generates an errorÏ*
;Ï1 otherwise it returns nil."Ï*
;Ï1  `(DEFUN ,fname (,discriminator ,@args)Ï*
;Ï1     ,documentationÏ*
;Ï1     ,declarationsÏ*
;Ï1     (IF (AND (pcl-p) (iwmc-class-p-safe ,discriminator))Ï*
;	Ï1,(IF pclÏ*
;	Ï1     pclÏ*
;	Ï1     (IF error-p '(FERROR nil "Don't know how to do this.") nil))Ï*
;	Ï1 (IF (AND (ticlos-p) (ticlos-instance-p ,discriminator))Ï*
;	Ï1    ,(IF ticlosÏ*
;		Ï1 ticlosÏ*
;		Ï1 (IF error-p '(FERROR nil "Don't know how to do this.") nil))Ï*
;	Ï1    ,(IF error-pÏ*
;		Ï1`(FERROR nil "Something wrong with ~S." ,discriminator)Ï*
;		Ï1 nil)))))Ï*

(DEFMACRO Ï4defsafeÏ*
      (fname (discriminator &rest args) &key (DOCUMENTATION nil)
        (ticlos nil) (error-p t) (declarations nil))
"Ï2Defines a function called FName, which should execute TICLOS if it is a TICLOS instance.  
 If Error-p is true and Discriminator is not TICLOS thing then it generates an error
 otherwise it returns nil.Ï*"
  `(DEFUN ,fname (,discriminator ,@args)
     ,documentation
     ,declarations
	 (IF (AND (ticlos-p) (ticlos-instance-p ,discriminator))
	    ,(IF ticlos
		 ticlos
		 (IF error-p '(FERROR nil "Ï3Don't know how to do this.Ï*") nil))
	    ,(IF error-p
		`(FERROR nil "Ï3Something wrong with ~S.Ï*" ,discriminator)
		 nil))))

;Ï1 TAC 08-17-89 - removing PCL support and redefining defsafe-gf macro Ï*
;Ï1(DEFMACRO defsafe-gfÏ*
;Ï1      (fname (discriminator &rest args) &key (DOCUMENTATION nil)Ï*
;Ï1       (pcl nil) (ticlos nil) (error-p t) (declarations nil))Ï*
;Ï1"Defines a function called FName, which should execute PCL if DiscriminatorÏ*
;Ï1 is a PCL GF or TICLOS if it is a TICLOS GF.  If Error-p is trueÏ*
;Ï1 and Discriminator is neither a PCL or TICLOS thing then it generates an errorÏ*
;Ï1 otherwise it returns nil."Ï*
;Ï1  `(DEFUN ,fname (,discriminator ,@args)Ï*
;Ï1     ,documentationÏ*
;Ï1     ,declarationsÏ*
;Ï1     (IF (AND (pcl-p) (pcl:generic-function-p ,discriminator))Ï*
;	Ï1,(IF pclÏ*
;	Ï1     pclÏ*
;	Ï1     (IF error-p '(FERROR nil "Don't know how to do this.") nil))Ï*
;	Ï1 (IF (AND (ticlos-p) (ticlos:generic-function-p ,discriminator))Ï*
;	Ï1    ,(IF ticlosÏ*
;		Ï1 ticlosÏ*
;		Ï1 (IF error-p '(FERROR nil "Don't know how to do this.") nil))Ï*
;	Ï1    ,(IF error-pÏ*
;		Ï1`(FERROR nil "Something wrong with ~S." ,discriminator)Ï*
;		Ï1 nil)))))Ï*

(DEFMACRO Ï4defsafe-gfÏ*
	  (fname (discriminator &rest args) &key (DOCUMENTATION nil)
	   (ticlos nil) (error-p t) (declarations nil))
  "Ï2Defines a function called FName, which should execute TICLOS if it is a TICLOS GF.  
 If Error-p is true and Discriminator is not a TICLOS thing then it generates an error
 otherwise it returns nil.Ï*"
  `(DEFUN ,fname (,discriminator ,@args)
     ,documentation
     ,declarations
     (IF (AND (ticlos-p) (ticlos::generic-function-p ,discriminator))
	 ,(IF ticlos
	      ticlos
	      (IF error-p '(FERROR nil "Ï3Don't know how to do this.Ï*") nil))
	 ,(IF error-p
	      `(FERROR nil "Ï3Something wrong with ~S.Ï*" ,discriminator)
	      nil))))

;Ï1 TAC 08-17-89 - removing PCL support and redefining defsafe-simple macro Ï*
;Ï1(DEFMACRO defsafe-simpleÏ*
;Ï1     (fname (discriminator &rest args)Ï*
;Ï1      &key (DOCUMENTATION nil) (both nil) (pcl nil) (ticlos nil) (error-p t)Ï*
;Ï1      (declarations nil))Ï*
;Ï1"Defines a function called FName, which should executeÏ*
;Ï1 (PCL:PCL discriminator ,@args) if DiscriminatorÏ*
;Ï1 is a PCL thing or (TICLOS:TICLOS discriminator ,@args)Ï*
;Ï1 if it is a TICLOS instance.  If Both is specified insteadÏ*
;Ï1 of either of the above, then both functions will have theÏ*
;Ï1 same name, though different packages.  If Error-p is trueÏ*
;Ï1 and Discriminator is neither a PCL or TICLOS thing thenÏ*
;Ï1 it generates an error otherwise it returns nil.Ï*
;Ï1 (defsafe-simple class-named-safe (x) :both class-named)Ï*
;Ï1 ~=Ï*
;Ï1 (defsafe class-named-safe (x)Ï*
;Ï1   :pcl (pcl:class-named x) Ï*
;Ï1   :ticlos (ticlos:class-named x))"Ï*
;Ï1  (LET ((real-pcl (INTERN (SYMBOL-NAMEÏ*
;			Ï1    (OR both pcl (AND (NOT error-p) 'IDENTITY)))Ï*
;			Ï1  'pcl))Ï*
;	Ï1(real-ti  (INTERN (SYMBOL-NAMEÏ*
;			Ï1    (OR both ticlos (AND (NOT error-p) 'IDENTITY)))Ï*
;			Ï1  'ticlos)))Ï*
;Ï1      `(DEFUN ,fname (,discriminator ,@args)Ï*
;	Ï1 ,documentationÏ*
;	Ï1 ,declarationsÏ*
;	Ï1  (IF ,(IF (OR pcl both (NOT error-p))Ï*
;		Ï1  `(AND (pcl-p) (iwmc-class-p-safe ,discriminator))Ï*
;		Ï1   nil)Ï*
;	Ï1       (,real-pcl ,discriminator ,@args)Ï*
;	Ï1       (IF ,(IF (OR ticlos both (NOT error-p))Ï*
;		Ï1       `(AND (ticlos-p) (ticlos-instance-p ,discriminator))Ï*
;		Ï1        nil)Ï*
;		Ï1    (,real-ti ,discriminator ,@args)Ï*
;		Ï1   ,(IF error-pÏ*
;		Ï1       `(FERROR nil "Something wrong with ~S." ,discriminator)Ï*
;			Ï1nil))))))Ï*

(DEFMACRO Ï4defsafe-simpleÏ*
     (fname (discriminator &rest args)
      &key (DOCUMENTATION nil) (ticlos nil) (error-p t)
      (declarations nil))
"Ï2Defines a function called FName, which should execute
 (TICLOS:TICLOS discriminator ,@args) if it is a TICLOS instance. 
 If Error-p is true and Discriminator is not a TICLOS thing then
 it generates an error otherwise it returns nil.
 (defsafe-simple class-named-safe (x) :ticlos class-named)
 ~=
 (defsafe class-named-safe (x)
   :ticlos (ticlos:class-named x))Ï*"
  (LET ((real-ti  (INTERN (SYMBOL-NAME
			    (OR ticlos (AND (NOT error-p) 'IDENTITY)))
			  'ticlos)))
      `(DEFUN ,fname (,discriminator ,@args)
	 ,documentation
	 ,declarations
	       (IF ,(IF (OR ticlos (NOT error-p))
		       `(AND (ticlos-p) (ticlos-instance-p ,discriminator))
		        nil)
		    (,real-ti ,discriminator ,@args)
		   ,(IF error-p
		       `(FERROR nil "Ï3Something wrong with ~S.Ï*" ,discriminator)
			nil)))))

;Ï1 TAC 08-17-89 - removing PCL support and redefining defsafe-gf-simple macro Ï*
;Ï1(DEFMACRO defsafe-gf-simpleÏ*
;Ï1     (fname (discriminator &rest args)Ï*
;Ï1      &key (DOCUMENTATION nil) (both nil) (pcl nil) (ticlos nil) (error-p t)Ï*
;Ï1      (declarations nil))Ï*
;Ï1"Defines a function called FName, which should executeÏ*
;Ï1 (PCL:PCL discriminator ,@args) if DiscriminatorÏ*
;Ï1 is a PCL GF or (TICLOS:TICLOS discriminator ,@args)Ï*
;Ï1 if it is a TICLOS GF.  If Both is specified insteadÏ*
;Ï1 of either of the above, then both functions will have theÏ*
;Ï1 same name, though different packages.  If Error-p is trueÏ*
;Ï1 and Discriminator is neither a PCL or TICLOS thing thenÏ*
;Ï1 it generates an error otherwise it returns nil.Ï*
;Ï1 (defsafe-gf-simple class-named-safe (x) :both class-named)Ï*
;Ï1 ~=Ï*
;Ï1 (defsafe-gf generic-function-name-safe (x)Ï*
;Ï1   :pcl (pcl:generic-function-name x) Ï*
;Ï1   :ticlos (ticlos:generic-function-name x))"Ï*
;Ï1  (LET ((real-pcl (INTERN (SYMBOL-NAMEÏ*
;			Ï1    (OR both pcl (AND (NOT error-p) 'IDENTITY)))Ï*
;			Ï1  'pcl))Ï*
;	Ï1(real-ti  (INTERN (SYMBOL-NAMEÏ*
;			Ï1    (OR both ticlos (AND (NOT error-p) 'IDENTITY)))Ï*
;			Ï1  'ticlos)))Ï*
;Ï1      `(DEFUN ,fname (,discriminator ,@args)Ï*
;	Ï1 ,documentationÏ*
;	Ï1 ,declarationsÏ*
;	Ï1  (IF ,(IF (OR pcl both (NOT error-p))Ï*
;		Ï1  `(AND (pcl-p) (pcl:generic-function-p ,discriminator))Ï*
;		Ï1   nil)Ï*
;	Ï1       (,real-pcl ,discriminator ,@args)Ï*
;	Ï1       (IF ,(IF (OR ticlos both (NOT error-p))Ï*
;		Ï1       `(AND (ticlos-p)Ï*
;			Ï1     (ticlos:generic-function-p ,discriminator))Ï*
;		Ï1        nil)Ï*
;		Ï1    (,real-ti ,discriminator ,@args)Ï*
;		Ï1   ,(IF error-pÏ*
;		Ï1       `(FERROR nil "~S is not a generic function."Ï*
;				Ï1,discriminator)Ï*
;			Ï1nil))))))Ï*


(DEFMACRO Ï4defsafe-gf-simpleÏ*
	  (fname (discriminator &rest args)
	   &key (DOCUMENTATION nil) (ticlos nil) (error-p t)
	   (declarations nil))
  "Ï2Defines a function called FName, which should execute
 (TICLOS:TICLOS discriminator ,@args) if it is a TICLOS GF.  
 If Error-p is true and Discriminator is not a TICLOS thing then
 it generates an error otherwise it returns nil.
 (defsafe-gf-simple class-named-safe (x) :ticlos class-named)
 ~=
 (defsafe-gf generic-function-name-safe (x)
   :ticlos (ticlos:generic-function-name x))Ï*"
  (LET ((real-ti  (INTERN (SYMBOL-NAME
			    (OR ticlos (AND (NOT error-p) 'IDENTITY)))
			  'ticlos)))
    `(DEFUN ,fname (,discriminator ,@args)
       ,documentation
       ,declarations
       (IF ,(IF (OR ticlos (NOT error-p))
		`(AND (ticlos-p)
		      (ticlos::generic-function-p ,discriminator))
		nil)
	   (,real-ti ,discriminator ,@args)
	   ,(IF error-p
		`(FERROR nil "Ï3~S is not a generic function.Ï*"
			 ,discriminator)
		nil)))))

;Ï1 TAC 08-17-89 - removing PCL support and redefining defsafe-slotd macro Ï*
;Ï1(DEFMACRO defsafe-slotdÏ*
;Ï1     (fname (discriminator &rest args)Ï*
;Ï1      &key (DOCUMENTATION nil) (both nil) (pcl nil) (ticlos nil) (error-p t)Ï*
;Ï1      (declarations nil))Ï*
;Ï1"Defines a function called FName, which should executeÏ*
;Ï1 (PCL:PCL discriminator ,@args) if DiscriminatorÏ*
;Ï1 is a PCL slot-descriptor or (TICLOS:TICLOS discriminator ,@args)Ï*
;Ï1 if it is a TICLOS slot-descriptor.  If Both is specified insteadÏ*
;Ï1 of either of the above, then both functions will have theÏ*
;Ï1 same name, though different packages.  If Error-p is trueÏ*
;Ï1 and Discriminator is neither a PCL or TICLOS thing thenÏ*
;Ï1 it generates an error otherwise it returns nil.Ï*
;Ï1 eg: (defsafe-slotd slotd-name-safe (x)Ï*
;Ï1       :pcl slotd-nameÏ*
;Ï1       :ticlos slot-description-name)"Ï*
;Ï1  (LET ((real-pcl (INTERN (SYMBOL-NAMEÏ*
;			Ï1    (OR both pcl (AND (NOT error-p) 'IDENTITY)))Ï*
;			Ï1  'pcl))Ï*
;	Ï1(real-ti  (INTERN (SYMBOL-NAMEÏ*
;			Ï1    (OR both ticlos (AND (NOT error-p) 'IDENTITY)))Ï*
;			Ï1  'ticlos)))Ï*
;Ï1      `(DEFUN ,fname (,discriminator ,@args)Ï*
;	Ï1 ,documentationÏ*
;	Ï1 ,declarationsÏ*
;	Ï1  (IF ,(IF (OR pcl both (NOT error-p))Ï*
;		Ï1  `(AND (pcl-p)Ï*
;			Ï1(TYPEP ,discriminator 'pcl:standard-slot-description))Ï*
;		Ï1   nil)Ï*
;	Ï1       (,real-pcl ,discriminator ,@args)Ï*
;	Ï1       (IF ,(IF (OR ticlos both (NOT error-p))Ï*
;		Ï1       `(AND (ticlos-p)Ï*
;			Ï1     (TYPEP ,discriminator 'ticlos:slot-description))Ï*
;		Ï1        nil)Ï*
;		Ï1    (,real-ti ,discriminator ,@args)Ï*
;		Ï1   ,(IF error-pÏ*
;		Ï1       `(FERROR nil "Something wrong with ~S." ,discriminator)Ï*
;			Ï1nil))))))Ï*

(DEFMACRO Ï4defsafe-slotdÏ*
	  (fname (discriminator &rest args)
	   &key (DOCUMENTATION nil) (ticlos nil) (error-p t)
	   (declarations nil))
  "Ï2Defines a function called FName, which should execute
 (TICLOS:TICLOS discriminator ,@args) if it is a TICLOS slot-definition. 
If Error-p is true and Discriminator is not a TICLOS thing then
 it generates an error otherwise it returns nil.
 eg: (defsafe-slotd slotd-name-safe (x)
       :ticlos slot-description-name)Ï*"
  (LET ((real-ti  (INTERN (SYMBOL-NAME
			    (OR ticlos (AND (NOT error-p) 'IDENTITY)))
			  'ticlos)))
    `(DEFUN ,fname (,discriminator ,@args)
       ,documentation
       ,declarations
       (IF ,(IF (OR ticlos (NOT error-p))
		`(AND (ticlos-p)
		      ;Ï1;Ï* (TYPEP ,discriminator 'ticlos:slot-description))
		      ;Ï1; Ï* TAC 08-28-89Ï1 - as per David Gray, slot-description should be slot definition  Ï*
		       (TYPEP ,discriminator 'clos:slot-definition))
		nil)
	   (,real-ti ,discriminator ,@args)
	   ,(IF error-p
		`(FERROR nil "Ï3Something wrong with ~S.Ï*" ,discriminator)
		nil)))))

;Ï1; TAC 09-04-89 - substituted (si::closure-function x) for (FIRST (si:convert-closure-to-list x))Ï*
;Ï1;                      David Gray's preferred method of handling closures.Ï*
(DEFUN Ï4get-fef-from-objectÏ* (x)
  "Ï2Tries to extract a fef from an object.  X could be a method or a
 generic function, which is not itself a fef, but points to one.
 This is used by code that grovles over the fef for one reason or other.Ï*"
  (FLET (
	 ;Ï1; TAC 08-17-89 - removing PCL supportÏ*
;	Ï1 (pcl ()Ï*
;	Ï1   (TYPECASE xÏ*
;	Ï1     (pcl:standard-methodÏ*
;	Ï1      (get-fef-from-object (method-function-safe x)))Ï*
;	Ï1     (pcl:standard-generic-functionÏ*
;	Ï1      (FIRST (si:convert-closure-to-list x)))Ï*
;	Ï1     (compiled-function x)Ï*
;	Ï1     (CLOSURE (FIRST (si:convert-closure-to-list x)))Ï*
;	Ï1     (otherwise nil)))Ï*
	 (ticlos ()
		 (TYPECASE x
		   (ticlos:standard-method (method-function-safe x))
		   (ticlos:standard-generic-function
		    (ticlos::generic-function-discriminator-code x))
		   (compiled-function x)
		   ;Ï1; Ï*(CLOSURE (FIRST (si:convert-closure-to-list x)))
		   (CLOSURE (si::closure-function x))
		   (otherwise nil))))
    ;Ï1; TAC 08-17-89 - removing PCL supportÏ*
;Ï1    (IF (pcl-p)Ï*
;	Ï1(OR (pcl) (IF (ticlos-p) (OR (ticlos) (LIST nil)) (LIST nil)))Ï*
;	Ï1(IF (ticlos-p) (OR (ticlos) (LIST nil)) (LIST nil)))Ï*
    (IF (ticlos-p) (OR (ticlos) (LIST nil)) (LIST nil))))

;Ï1; TAC 08-17-89 - removing PCL supportÏ*
;Ï1(DEFUN slotd-p-safe (slotd)Ï*
;Ï1"Is true if SlotD is a slot descriptor object."Ï*
;Ï1  (OR (AND (pcl-p)Ï*
;	Ï1   (TYPEP slotd 'pcl:standard-slot-description))Ï*
;Ï1      (AND (ticlos-p)Ï*
;	Ï1   (TYPEP slotd 'ticlos:slot-description))))Ï*

(DEFUN Ï4slotd-p-safeÏ* (slotd)
  "Ï2Is true if SlotD is a slot definition object.Ï*"
  (AND (ticlos-p)
       ;Ï1; Ï*(TYPEP slotd 'ticlos:slot-description)))
       ;Ï1; Ï*TAC 08-28-89Ï1 - as per David Gray, slot-description should be slot-definitionÏ*
       (TYPEP slotd 'clos:slot-definition)))

;Ï1(defsafe-slotd slotd-name-safe (slotd)Ï*
;Ï1  :documentation "Returns the name of the slot described by SlotD."Ï*
;Ï1  :ticlos slot-definition-nameÏ*
;Ï1  :pcl slotd-name)Ï*

(defsafe-slotd Ï4slotd-name-safeÏ* (slotd)
  :documentation "Ï3Returns the name of the slot described by SlotD.Ï*"
  :ticlos slot-definition-name)

;Ï1(defsafe-simple slot-value-safe (instance slot)Ï*
;Ï1  :documentationÏ*
;Ï1  "Returns the value of the slot named Slot in the instance Instance."Ï*
;Ï1  :both slot-value)Ï*

(defsafe-simple Ï4slot-value-safeÏ* (instance slot)
  :documentation
  "Ï3Returns the value of the slot named Slot in the instance Instance.Ï*"
  :ticlos slot-value)

;Ï1(defsafe-simple class-of-safe (thing)Ï*
;Ï1  :documentation "Returns the class of Thing."Ï*
;Ï1  :both class-of)Ï*

(defsafe-simple Ï4class-of-safeÏ* (thing)
  :documentation "Ï3Returns the class of Thing.Ï*"
  :ticlos class-of)

;Ï1(DEFUN class-of-gf-safe (thing)Ï*
;Ï1"Returns the class of Thing."Ï*
;Ï1  (IF (AND (ticlos-p) (ticlos:generic-function-p thing))Ï*
;Ï1      (ticlos:class-of thing)Ï*
;Ï1      (IF (AND (pcl-p) (pcl:generic-function-p thing))Ï*
;	Ï1  (pcl:class-of-generic-function thing)Ï*
;	Ï1  (FERROR nil "~S is not a generic function." thing))))Ï*

(DEFUN Ï4class-of-gf-safeÏ* (thing)
"Ï2Returns the class of Thing.Ï*"
  (IF (AND (ticlos-p) (ticlos::generic-function-p thing))
      (ticlos:class-of thing)
      (FERROR nil "Ï3~S is not a generic function.Ï*" thing)))

;Ï1(defsafe-simple method-function-safe (method)Ï*
;Ï1  :documentation "Returns the method function of Method."Ï*
;Ï1  :both method-function)Ï*

(defsafe-simple Ï4method-function-safeÏ* (method)
  :documentation "Ï3Returns the method function of Method.Ï*"
  :ticlos method-function)

;Ï1(defsafe-slotd slotd-initform-safe (slotd)Ï*
;Ï1  :documentation "Returns the initform of the slot descriptor SlotD."Ï*
;Ï1  :pcl slotd-initformÏ*
;Ï1  :ticlos slot-definition-initform)Ï*

(defsafe-slotd Ï4slotd-initform-safeÏ* (slotd)
  :documentation "Ï3Returns the initform of the slot descriptor SlotD.Ï*"
  :ticlos slot-definition-initform)

;Ï1(defsafe-slotd slotd-accessors-safe (slotd)Ï*
;Ï1  :documentation "Returns the accessors of the slot descriptor SlotD."Ï*
;Ï1  :pcl slotd-accessors ;;; !!!!! JPR.Ï*
;Ï1  :ticlos slot-definition-writers)Ï*

(defsafe-slotd Ï4slotd-accessors-safeÏ* (slotd)
  :documentation "Ï3Returns the accessors of the slot descriptor SlotD.Ï*"
  :ticlos slot-definition-writers)

;Ï1(defsafe-slotd slotd-readers-safe (slotd)Ï*
;Ï1  :documentation "Returns the readers of the slot descriptor SlotD."Ï*
;Ï1  :pcl slotd-readersÏ*
;Ï1  :ticlos slot-definition-readers)Ï*

(defsafe-slotd Ï4slotd-readers-safeÏ* (slotd)
  :documentation "Ï3Returns the readers of the slot descriptor SlotD.Ï*"
  :ticlos slot-definition-readers)

;Ï1(defsafe-slotd slotd-type-safe (slotd)Ï*
;Ï1  :documentation "Returns the type of the slot descriptor SlotD."Ï*
;Ï1  :pcl slotd-typeÏ*
;Ï1  :ticlos slot-definition-type)Ï*

(defsafe-slotd Ï4slotd-type-safeÏ* (slotd)
  :documentation "Ï3Returns the type of the slot descriptor SlotD.Ï*"
  :ticlos slot-definition-type)

;Ï1(defsafe-slotd slotd-allocation-safe (slotd)Ï*
;Ï1  :documentation "Returns the allocation of the slot descriptor SlotD."Ï*
;Ï1  :pcl slotd-allocationÏ*
;Ï1  :ticlos slot-definition-allocation)Ï*

(defsafe-slotd Ï4slotd-allocation-safeÏ* (slotd)
  :documentation "Ï3Returns the allocation of the slot descriptor SlotD.Ï*"
  :ticlos slot-definition-allocation)

;Ï1(defsafe-slotd slotd-initargs-safe (slotd)Ï*
;Ï1  :documentation "Returns the initargs of the slot descriptor SlotD."Ï*
;Ï1  :pcl slotd-initargsÏ*
;Ï1  :ticlos slot-definition-initargs)Ï*

(defsafe-slotd Ï4slotd-initargs-safeÏ* (slotd)
  :documentation "Ï3Returns the initargs of the slot descriptor SlotD.Ï*"
  :ticlos slot-definition-initargs)

;Ï1(defsafe class-local-slots-safe (class)Ï*
;Ï1  :documentation "Returns the local slots of the class Class."Ï*
;Ï1  :ticlos (ticlos:class-direct-slots class)Ï*
;Ï1  :pcl (LET ((others (MAPCAR #'pcl:slotd-nameÏ*
;			Ï1     (APPLY #'APPENDÏ*
;				Ï1      (MAPCAR #'pcl:class-direct-slotsÏ*
;					Ï1      (REST (class-precedence-list-safeÏ*
;						Ï1      class)))))))Ï*
;	Ï1    (REMOVE-IF #'(lambda (slotd) (MEMBER (pcl:slotd-name slotd) others))Ï*
;		Ï1       (pcl:class-direct-slots class))))Ï*

(defsafe Ï4class-local-slots-safeÏ* (class)
  :documentation "Ï3Returns the local slots of the class Class.Ï*"
  :ticlos (ticlos:class-direct-slots class))

(DEFUN Ï4all-shared-slotsÏ* (class)
  (LET ((cpl (class-precedence-list-safe class t)))
       (APPLY #'APPEND
	      (MAPCAR #'(lambda (a-class)
			  (MAPCAR #'FIRST
				  (ticlos::class-class-slot-alist (ticlos::class-description a-class))))
		        cpl))))

;Ï1(DEFUN class-instance-slots-safe (class)Ï*
;Ï1"Returns a list of the Local slots posessed by instances of the class CLASS."Ï*
;Ï1  (IF (TYPEP class 'ticlos-instance)Ï*
;Ï1      (LET ((descr (ticlos:class-description class)))Ï*
;	Ï1   (LET ((shared (all-shared-slots class)))Ï*
;	Ï1        (REMOVE-IFÏ*
;		Ï1  #'(lambda (slotd)Ï*
;		Ï1      (MEMBER (ticlos:slot-name slotd) shared))Ï*
;	Ï1            (GETF (ticlos:class-description-plist descr)Ï*
;			Ï1  'ticlos:all-slots))))Ï*
;Ï1      (LET ((slots (pcl:class-slots class)))Ï*
;	Ï1   (REMOVE-IFÏ*
;	Ï1     #'(lambda (slotd) (EQUAL (slotd-allocation-safe slotd) :class))Ï*
;	Ï1       slots))))Ï*

(DEFUN Ï4class-instance-slots-safeÏ* (class)
  "Ï2Returns a list of the Local slots posessed by instances of the class CLASS.Ï*"
  (WHEN (TYPEP class 'ticlos-instance)
    (LET ((shared (all-shared-slots class)))
      (REMOVE-IF
	#'(lambda (slotd)
	    ;Ï1; Ï*(MEMBER (ticlos:slot-name slotd) shared))
	    ;Ï1; Ï*TAC 08-28-89Ï1 - as per David Gray, slot-name should be slot-definition-nameÏ*
	    (MEMBER (clos:slot-definition-name slotd) shared))
	(CLOS:CLASS-SLOTS class)))))

;Ï1(DEFUN class-non-instance-slots-safe (class)Ï*
;Ï1"Returns a list of the Shared slots posessed by instances of the class CLASS."Ï*
;Ï1  (IF (TYPEP class 'ticlos-instance)Ï*
;Ï1      (LET ((descr (ticlos:class-description class)))Ï*
;	Ï1   (LET ((shared (all-shared-slots class)))Ï*
;	Ï1        (REMOVE-IF-NOTÏ*
;		Ï1  #'(lambda (slotd)Ï*
;		Ï1      (MEMBER (ticlos:slot-name slotd) shared))Ï*
;	Ï1            (GETF (ticlos:class-description-plist descr)Ï*
;			Ï1  'ticlos:all-slots))))Ï*
;Ï1      (LET ((slots (pcl:class-slots class)))Ï*
;	Ï1   (REMOVE-IF-NOTÏ*
;	Ï1     #'(lambda (slotd) (EQUAL (slotd-allocation-safe slotd) :class))Ï*
;	Ï1       slots))))Ï*

(DEFUN Ï4class-non-instance-slots-safeÏ* (class)
  "Ï2Returns a list of the Shared slots posessed by instances of the class CLASS.Ï*"
  (WHEN (TYPEP class 'ticlos-instance)
    (LET ((shared (all-shared-slots class)))
      (REMOVE-IF-NOT
	#'(lambda (slotd)
	    ;Ï1; Ï*(MEMBER (ticlos:slot-name slotd) shared))
	    ;Ï1; Ï*TAC 08-28-89Ï1 - as per David Gray, slot-name should be slot-definition-nameÏ*
	    (MEMBER (clos:slot-definition-name slotd) shared))
	(CLOS:CLASS-SLOTS class)))))

;Ï1(defsafe-simple class-finalized-p-safe (class)Ï*
;Ï1  :documentation "Is true if Class has been finalized."Ï*
;Ï1  :both class-finalized-p)Ï*

(defsafe-simple Ï4class-finalized-p-safeÏ* (class)
  :documentation "Ï3Is true if Class has been finalized.Ï*"
  :ticlos class-finalized-p)

;Ï1(defsafe-simple class-precedence-list-safe-1 (class)Ï*
;Ï1  :documentation "Returns the class precedence list of a finalized class."Ï*
;Ï1  :both class-precedence-list)Ï*

(defsafe-simple Ï4class-precedence-list-safe-1Ï* (class)
  :documentation "Ï3Returns the class precedence list of a finalized class.Ï*"
  :ticlos class-precedence-list)

(DEFUN Ï4class-precedence-list-safeÏ* (class &optional (undefined-ok nil))
"Ï2Returns the class precedence list of a class.  If undefined-ok is true then
 it's alright to return just the names of undefined classes, rather than the
 class objects themselves.  The class does not have to be finalized for this
 function to work.Ï*" 
  (IF (class-finalized-p-safe class)
      (class-precedence-list-safe-1 class)
      (REMOVE nil (MAPCAR #'(lambda (a-class)
			      (OR (AND (class-p-safe a-class)
				       a-class)
				  (class-named-safe a-class t)
				  (AND undefined-ok a-class)))
			    (CONS class (class-local-supers-safe class))))))

(DEFUN Ï4class-precedence-list-1Ï* (class undefined-ok)
  (CONS class 
        (APPLY #'APPEND
		(MAPCAR #'(lambda (class)
			     (IF (class-p-safe class)
				 (class-precedence-list-1
				   class undefined-ok)
				 class))
			   (MAPCAR #'(lambda (a-class)
				       (OR (AND (class-p-safe a-class)
						a-class)
					   (class-named-safe a-class t)
					   (AND undefined-ok a-class)))
				     (class-local-supers-safe class))))))

;Ï1*************Ï*
;Ï1 TAC 07-26-89 - moved from TI-ENV-FLAVOR-INSPECTOR-INTERFACE -----Ï*
;Ï1 TAC 07-25-89 - pulled from PATHNAME-EXTENSIONS file (fs package).Ï*
(DEFUN Ï4cons-newÏ* (x list &key (test #'EQL))
  (IF (MEMBER x list :test test)
      list
      (CONS x list))) 

(DEFUN Ï4uniquifyÏ* (LIST result &key (test #'EQL))
"Ï2Given 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) (cons-new (FIRST list) result :test test)
		:test test)
      (NREVERSE result)))
;Ï1-------------------------------------------------------------------Ï*

(DEFUN Ï4class-precedence-list-safeÏ* (class &optional (undefined-ok nil))
"Ï2Returns the class precedence list of a class.  If undefined-ok is true then
 it's alright to return just the names of undefined classes, rather than the
 class objects themselves.  The class does not have to be finalized for this
 function to work.Ï*" 
  (IF (class-finalized-p-safe class)
      (class-precedence-list-safe-1 class)
      (uniquify (class-precedence-list-1 class undefined-ok) nil)))

(DEFUN Ï4clos-method-nameÏ* (method)
"Ï2Returns the name of a clos method.Ï*"
  (FUNCTION-NAME (method-function-safe method)))

(DEFUN Ï4coerce-to-classÏ* (class)
"Ï2Makes sure that class is a class.Ï*"
  (IF (class-p-safe class)
      class
      (IF (CONSP class)
	  (IF (EQUAL 'EQL (FIRST class))
	      class
	      (LIST (FIRST class) (coerce-to-class (SECOND class))))
	  (coerce-to-class (class-named-safe class)))))

;Ï1(defsafe method-parameter-specializers-safe (method)Ï*
;Ï1  :documentation "Returns the parameter specializers of method Method."Ï*
;Ï1  :ticlos (MAPCAR #'coerce-to-classÏ*
;		Ï1  (ticlos:method-parameter-specializers method))Ï*
;Ï1  :pcl    (MAPCAR #'coerce-to-class (pcl:method-type-specifiers method)))Ï*

(defsafe Ï4method-parameter-specializers-safeÏ* (method)
  :documentation "Ï3Returns the parameter specializers of method Method.Ï*"
  :ticlos (MAPCAR #'coerce-to-class
		  (clos:method-specializers method)))

(DEFUN Ï4method-primary-p-safeÏ* (method)
"Ï2Is true if Method is a primary method.Ï*"
  (OR (EQUAL nil (method-qualifiers-safe method))
      ;Ï1;;; !!!! Allow for PCL reader/writer methods.  Ï*
      ;Ï1; TAC 08-17-89 not sure which part the above comment references, but neither should hurtÏ*
      (EQUAL :internal
	     (FIRST (FUNCTION-NAME (method-function-safe method))))))

(DEFUN Ï4is-specialised-byÏ* (method class looking-for-class)
"Ï2Is true if Method is specialized by Class, i.e. Class is something like
 bottle, where bottle is built on container and method has a name something like
 (method fill-me ((me container) (with t))).
 Looking for Class is the class we are really interested in.  This means that,
 although container is built on T, we are not interested in methods that have
 t as specializers.Ï*"
  (AND (MEMBER class (method-parameter-specializers-safe method))
       (REMOVE nil (MAPCAR #'(lambda (x)
			       (AND (NOT (EQUAL t (class-name-safe x)))
				    (my-subtypep looking-for-class x)))
			     (method-parameter-specializers-safe method)))))

(DEFUN Ï4is-specialised-by-componentsÏ* (method class)
"Ï2Is true if Method is specialized by Class, i.e. Class is something like
 bottle, where bottle is built on container and method has a name something like
 (method fill-me ((me container) (with t))).  If it is true then it returns
 the method, otherwise nil.Ï*"
  (LET ((matches
	  (REMOVE-IF-NOT #'(lambda (cl) (is-specialised-by method cl class))
			 (class-precedence-list-safe class))))
       (IF matches method nil)))

(DEFUN Ï4actual-method-entryÏ* (x)
"Ï2Returns the method entry we are interested in.Ï*"
  (IF (CONSP (FIRST x))
      (THIRD x)
      (actual-method-entry (SECOND x))))

;Ï1(defsafe-gf generic-function-methods-safe (generic-function)Ï*
;Ï1  :documentation "Returns the methods associated with a generic function."Ï*
;Ï1  :pcl (pcl:generic-function-methods generic-function)Ï*
;Ï1  ;; Use this for because ticlos:generic-function-methods doesn't get set methods.Ï*
;Ï1  :ticlos (LET ((LIST (ticlos:generic-function-method-list generic-function)))Ï*
;	Ï1       ;;; Put in catch error to oprotect from During TransportÏ*
;	Ï1       ;;; of Self-Ref-Pointer error.Ï*
;	Ï1       (APPLY #'APPEND (MAPCAR 'get-method-from-spec list)))Ï*
;Ï1;  :ticlos (ticlos:generic-function-methods generic-function)Ï*
;Ï1  )Ï*

(defsafe-gf Ï4generic-function-methods-safeÏ* (generic-function)
  :documentation "Ï3Returns the methods associated with a generic function.Ï*"
  :ticlos (clos:generic-function-methods generic-function)
  )

(DEFUN Ï4ticlos-class-direct-generic-functionsÏ*
       (a-class &optional (top-class a-class))
"Ï2Returns the list of generic functions that name the methods directly
 specialized by a-class.  Top-class is the class we're actually interested in
 since this might be different from a-class (see ticlos-class-direct-methods).Ï*"
  (LET ((methods (ticlos-class-direct-methods a-class top-class)))
       (uniquify (MAPCAR #'method-generic-function-safe methods) nil)))

(DEFUN Ï4get-method-from-specÏ* (spec)
"Ï2Given a method spec returns the actual method.Ï*"
  (DECLARE (optimize (safety 0)))
  (IF (AND (CONSP spec) (CONSP (FIRST spec))
	   (NOT (EQUAL 'EQL (FIRST (FIRST spec)))))
      (IF (EQUAL 'ticlos:method (FIRST (FIRST spec)))
	  (IF (EQUAL :combined (THIRD (FIRST spec)))
	      nil
	      (LIST (THIRD spec)))
	  (get-method-from-spec (REST (REST (REST spec)))))
      (IF (CONSP spec)
	  (REMOVE nil (APPLY #'APPEND (MAPCAR 'get-method-from-spec spec)))
	  nil)))

(DEFUN Ï4class-all-slots-safeÏ* (class)
"Ï2Returns a list of the slotds for all of the slots in Class.Ï*"
  (LET ((slots (MAPCAR #'class-local-slots-safe
		       (class-precedence-list-safe class))))
       (LET ((result nil))
	    (LOOP for slotd in (APPLY #'APPEND slots)
		  unless (MEMBER slotd result
				 :test #'(lambda (x y)
					   (EQ (slotd-name-safe x)
					       (slotd-name-safe y))))
		  do (PUSH slotd result))
	    result)))

(DEFUN Ï4get-gfs-for-slotÏ* (slotd)
  (APPEND (slotd-accessors-safe slotd)
	  (slotd-readers-safe slotd)))

;Ï1*************Ï*
;Ï1 TAC 07-26-89 - moved from TI-ENV-FLAVOR-INSPECTOR-INTERFACE ---------Ï*
(DEFUN Ï4get-gf-for-slot-functionÏ* (fn)
"Ï2Given a function name e.g. foo or (setf foo), returns the gf for it.Ï*"
  (function-generic-function-safe
    (fdefinition fn)))

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

(DEFUN Ï4get-gfs-for-slots-ofÏ* (class)
  (LET ((slotds (class-all-slots-safe class)))
       (MAPCAR #'get-gf-for-slot-function
	       (uniquify (APPLY #'APPEND (MAPCAR 'get-gfs-for-slot slotds)) nil))))

(DEFUN Ï4ticlos-class-direct-methodsÏ* (a-class &optional (top-class a-class))
"Ï2Returns the list of methods directly specialized by a-class.  Top-class
 is the class we're actually interested in since this might be different
 from a-class during checks of subclasses (e.g. show-all-clos-methods).
 Top-class allows is-specialised-by to know which class we are actually
 interested in.Ï*"
  (LET ((fns (APPEND (CLOS:SPECIALIZER-DIRECT-GENERIC-FUNCTIONS a-class)
		     (get-gfs-for-slots-of a-class))))
       (LET ((locals nil))
            (LOOP for fn in fns do
		  (LOOP for meth in (generic-function-methods-safe fn)
			when (AND meth
				  (is-specialised-by meth a-class top-class))
			do (PUSH meth locals)))
	    locals)))

;Ï1(defsafe method-lambda-list-safe (method)Ï*
;Ï1  :documentation "Returns the method lambda list of a method."Ï*
;Ï1  ;; Protect agains self-ref-transport bug.Ï*
;Ï1  :ticlos (CATCH-ERROR (ticlos:method-lambda-list method) nil)Ï*
;Ï1  :pcl (pcl:method-arglist method))Ï*

(defsafe Ï4method-lambda-list-safeÏ* (method)
  :documentation "Ï3Returns the method lambda list of a method.Ï*"
  ;Ï1; Protect agains self-ref-transport bug.Ï*
  :ticlos (CATCH-ERROR (ticlos:method-lambda-list method) nil))


(DEFUN Ï4method-type-specifiers-safeÏ* (method)
  "Ï2Returns the type specifiers of a method.Ï*"
  (method-lambda-list-safe method))

;Ï1(defsafe method-docs-safe (method)Ï*
;Ï1  :documentation "Returns the documentation of a method."Ï*
;Ï1  :pcl (slot-value-safe method 'DOCUMENTATION)Ï*
;Ï1  :ticlos (DOCUMENTATION method))Ï*

(defsafe Ï4method-docs-safeÏ* (method)
  :documentation "Ï3Returns the documentation of a method.Ï*"
  :ticlos (DOCUMENTATION method))

(DEFUN Ï4path-string-1Ï* (path types)
"Ï2Is given a spec that might have been got from the :source-file-name
 property of something and the type of definition path to look for (e.g. defun).
 It returns either the string-for-printing of the pathname or the string
 \"Not Defined\".Ï*"
  (IF path
      (FORMAT nil "Ï3~aÏ*"
        (SEND (IF (CONSP path)
		  (LOOP for type in (IF (LISTP types) types (LIST types))
			when (ASSOC type path :test #'EQ)
			return (SECOND (ASSOC type path :test #'EQ)))
		  path)
	      :string-for-printing))
      '(:font 2 "Ï3Not DefinedÏ*")))

(DEFUN Ï4path-stringÏ* (name type)
"Ï2Returns the string for the source file pathname of Name of type Type.  Type
 is something like Defun or Defflavor.Ï*"
  (LET ((path (si:function-spec-get name :source-file-name)))
       (path-string-1 path type)))

;Ï1(DEFUN path-string-safe (class)Ï*
;Ï1"Returns a string for the source file name of a class."Ï*
;Ï1  (path-string (class-name-safe class)Ï*
;	Ï1       (IF (iwmc-class-p-safe class)Ï*
;		Ï1   'pcl:classÏ*
;		Ï1   '(ticlos:defclass ticl:defflavor))))Ï*

(DEFUN Ï4path-string-safeÏ* (class)
  "Ï2Returns a string for the source file name of a class.Ï*"
  (path-string (class-name-safe class)
	       '(ticlos:defclass ticl:defflavor)))

(DEFUN Ï4is-forÏ* (entry method)
"Ï2Is true if the method table entry Entry is the entry for Method.Ï*"
  (IF (CONSP (FIRST entry))
      (MEMBER method entry)
      (is-for (SECOND entry) method)))

;(DEFUN Ï4ticlos-method-plistÏ* (method)
;"Ï2Gets the plist from the method table entry for Method.Ï*"
;  (LET ((gf (method-generic-function-safe method)))
;       (LET ((entry (ticlos:generic-function-method-list gf)))
;	    (LOOP for meth in entry
;		  when (is-for meth method)
;		  return (is-for meth method)))))

;Ï1(defsafe method-path-string-safe (method)Ï*
;Ï1  :documentation "Returns the pathname string for the source file of Method."Ï*
;Ï1  :ticlos (LET ((path (GETF (ticlos-method-plist method) :source-file-name)))Ï*
;	Ï1       (path-string-1 path 'DEFUN))Ï*
;Ï1  :pcl (IF (COMPILED-FUNCTION-P (method-function-safe method))Ï*
;	Ï1   (path-string-1Ï*
;	Ï1     (si:function-spec-getÏ*
;	Ï1       (FUNCTION-NAME (method-function-safe method)) :source-file-name)Ï*
;	Ï1     'DEFUN)Ï*
;	Ï1   '(:font 2 "Not Defined")))Ï*

(defsafe Ï4method-path-string-safeÏ* (method)
  :documentation "Ï3Returns the pathname string for the source file of Method.Ï*"
  :ticlos (LET ((path (ticlos:definition-generic-pathname method)))
	       (path-string-1 path 'DEFUN)))

;Ï1(defsafe class-direct-methods-safe (class &optional (top-class class))Ï*
;Ï1  :documentation Ï*
;Ï1"Returns the list of methods that have been defined to specialise ClassÏ*
;Ï1 directly."Ï*
;Ï1  :pcl (pcl:class-direct-methods class)Ï*
;Ï1  :ticlos (ticlos-class-direct-methods class top-class))Ï*

(defsafe Ï4class-direct-methods-safeÏ* (class &optional (top-class class))
  :documentation 
"Ï3Returns the list of methods that have been defined to specialise Class
 directly.Ï*"
  :ticlos (ticlos-class-direct-methods class top-class))

;Ï1(defsafe class-default-initargs-safe (class)Ï*
;Ï1  :documentation "Returns the default initargs of the class Class."Ï*
;Ï1  :pcl (pcl:class-default-initargs class)Ï*
;Ï1  :ticlosÏ*
;Ï1      (MAPCAR #'(lambda (x) (LIST (FIRST x) (THIRD x)))Ï*
;	Ï1     (GETF (ticlos:class-description-plistÏ*
;		Ï1     (ticlos:class-description class))Ï*
;		Ï1   :default-initargs)))Ï*

(defsafe Ï4class-default-initargs-safeÏ* (class)
  :documentation "Ï3Returns the default initargs of the class Class.Ï*"
  :ticlos
      (MAPCAR #'(lambda (x) (LIST (FIRST x) (SECOND x)))
	      (CLOS:CLASS-DIRECT-DEFAULT-INITARGS class)))

;Ï1(defsafe class-direct-generic-functions-safe (class &optional (top-class class))Ï*
;Ï1  :documentation Ï*
;Ï1"Gets a list of all of the generic functions that name methods, which have beenÏ*
;Ï1 defined directly on this class.  Top class is the class we are actuallyÏ*
;Ï1 interested in."Ï*
;Ï1  :pcl    (pcl:class-direct-generic-functions    class)Ï*
;Ï1  :ticlos (ticlos-class-direct-generic-functions class top-class))Ï*

(defsafe Ï4class-direct-generic-functions-safeÏ* (class &optional (top-class class))
  :documentation 
"Ï3Gets a list of all of the generic functions that name methods, which have been
 defined directly on this class.  Top class is the class we are actually
 interested in.Ï*"
  :ticlos (ticlos-class-direct-generic-functions class top-class))

;Ï1; *** from Rice message Mods to TI-ENV-INSP.-INTERF. 8 Jun 1989 13:56:40 PDTÏ*
(DEFUN Ï4method-arglist-safeÏ* (method)
"Ï2Returns the method arglist of a method.Ï*"
  (LET ((args (method-lambda-list-safe method))
       (VALUES (CATCH-ERROR
		 (SECOND (MULTIPLE-VALUE-LIST
			   (ARGLIST (method-function-safe method))))
		 nil)))
      (VALUES args values)))

;Ï1(defsafe-simple method-qualifiers-safe (method)Ï*
;Ï1  :documentation "Returns the qualifiers (e.g. :Before) of Method."Ï*
;Ï1  :both method-qualifiers)Ï*

(defsafe-simple Ï4method-qualifiers-safeÏ* (method)
  :documentation "Ï3Returns the qualifiers (e.g. :Before) of Method.Ï*"
  :ticlos method-qualifiers)

;Ï1(defsafe unparse-specializers-safe (method)Ï*
;Ï1  :documentation Ï*
;Ï1"Unparses the specializers of Method.  Returns the specializers list and TÏ*
;Ï1 if the method is combined."Ï*
;Ï1  :declarations (DECLARE (VALUES specializers combined-method-p))Ï*
;Ï1  :pcl (VALUES (pcl:unparse-specializers method)Ï*
;	Ï1       (method-qualifiers-safe method))Ï*
;Ï1  :ticlos (LET ((name (FUNCTION-NAME (ticlos:method-function method))))Ï*
;	Ï1       (VALUES (IF (FOURTH name) (FOURTH name) (THIRD name))Ï*
;		Ï1       (method-qualifiers-safe method))))Ï*

(defsafe Ï4unparse-specializers-safeÏ* (method)
  :documentation 
"Ï3Unparses the specializers of Method.  Returns the specializers list and T
 if the method is combined.Ï*"
  :declarations (DECLARE (VALUES specializers combined-method-p))
  :ticlos (LET ((name (FUNCTION-NAME (ticlos:method-function method))))
	       (VALUES (IF (FOURTH name) (FOURTH name) (THIRD name))
		       (method-qualifiers-safe method))))

;Ï1(DEFUN class-named-safe (class &optional (noerrorp nil))Ï*
;Ï1"Returns the class named by the name Class.  If noerrorp is true then no errorÏ*
;Ï1 is signaled and nil is returned if Class is does not, in fact, name a class."Ï*
;Ï1  (IF (AND (ticlos-p) (ticlos:class-named class t))Ï*
;Ï1      (ticlos:class-named class t)Ï*
;Ï1      (IF (AND (pcl-p) (pcl:find-class class nil))Ï*
;	Ï1  (pcl:find-class class nil)Ï*
;	Ï1  (OR (AND (ticlos-p) (ticlos:class-named class noerrorp))Ï*
;	Ï1      (AND (pcl-p)   (pcl:find-class class (NOT noerrorp)))Ï*
;	Ï1      (AND (NOT noerrorp)Ï*
;		Ï1    (FERROR nil "~S does not name a class." class))))))Ï*

(DEFUN Ï4class-named-safeÏ* (class &optional (noerrorp nil))
"Ï2Returns the class named by the name Class.  If noerrorp is true then no error
 is signaled and nil is returned if Class is does not, in fact, name a class.Ï*"
  (ticlos::class-named class noerrorp))

;Ï1(defsafe-simple class-name-safe (class)Ï*
;Ï1  :documentation "Returns the name of the class Class."Ï*
;Ï1  :both class-name)Ï*

(defsafe-simple Ï4class-name-safeÏ* (class)
  :documentation "Ï3Returns the name of the class Class.Ï*"
  :ticlos class-name)

;Ï1(defsafe-simple subclassp-safe (x y)Ï*
;Ï1  :documentation "Is true if x is a subclass of y"Ï*
;Ï1  :both subclasspÏ*
;Ï1  :error-p nil)Ï*

(defsafe-simple Ï4subclassp-safeÏ* (x y)
  :documentation "Ï3Is true if x is a subclass of yÏ*"
  :ticlos subclassp
  :error-p nil)

;Ï1(DEFUN pcl-class-p (x)Ï*
;Ï1"True if x is a pcl class object."Ï*
;Ï1  (OR (TYPEP x 'pcl:standard-class)Ï*
;Ï1;      (typep x 'pcl:structure-class)Ï*
;Ï1      (TYPEP x 'pcl:built-in-class)))Ï*

;Ï1(defsafe class-p-safe (x)Ï*
;Ï1  :documentationÏ*
;Ï1"Is true if x is some sort of class object.  This could be a built-in classÏ*
;Ï1 standard or structure class."Ï*
;Ï1  :pcl (pcl-class-p x)Ï*
;Ï1  :ticlos (TYPEP x 'clos:class)Ï*
;Ï1  :error-p nil)Ï*

(defsafe Ï4class-p-safeÏ* (x)
  :documentation
"Ï3Is true if x is some sort of class object.  This could be a built-in class
 standard or structure class.Ï*"
  :ticlos (TYPEP x 'clos:class)
  :error-p nil)

;Ï1(DEFUN generic-function-p-safe (x)Ï*
;Ï1"Is true if x is a generic function."Ï*
;Ï1  (OR (AND (pcl-p) (pcl:generic-function-p x))Ï*
;Ï1      (AND (ticlos-p) (ticlos:generic-function-p x))))Ï*

(DEFUN Ï4generic-function-p-safeÏ* (x)
  "Ï2Is true if x is a generic function.Ï*"
  (AND (ticlos-p) (ticlos::generic-function-p x)))

;Ï1(DEFUN function-generic-function-safe (FUNCTION)Ï*
;Ï1"Returns the generic function object for the function function, whereÏ*
;Ï1 function is a fef."Ï*
;Ï1  (IF (AND (pcl-p) (pcl::generic-function-p function))Ï*
;Ï1      functionÏ*
;Ï1      (IF (AND (ticlos-p) (ticlos:generic-function-p function))Ï*
;	Ï1  (IF (TYPEP function 'ticlos:generic-function)Ï*
;	Ï1      functionÏ*
;	Ï1      ;;; It is a fef.Ï*
;	Ï1      (ticlos:get-generic-function-object function))Ï*
;	Ï1  nil)))Ï*

(DEFUN Ï4function-generic-function-safeÏ* (FUNCTION)
  "Ï2Returns the generic function object for the function function, where
 function is a fef.Ï*"
  (IF (AND (ticlos-p) (ticlos::generic-function-p function))
      (IF (TYPEP function 'ticlos:generic-function)
	  function
	  ;Ï1;; It is a fef.Ï*
	  (ticlos::get-generic-function-object function))
      nil))

;Ï1(DEFUN name-safe (x)Ï*
;Ï1"Reads the name slot of x if it has one.  This returns nil if X either isn'tÏ*
;Ï1 an instance or doesn't have a Name slot."Ï*
;Ï1  (OR (CATCH-ERROR (slot-value-safe x 'pcl:name)    nil)Ï*
;Ï1      (CATCH-ERROR (slot-value-safe x 'ticlos:name) nil)Ï*
;Ï1      (CATCH-ERROR (generic-function-name-safe x) nil)))Ï*

(DEFUN Ï4name-safeÏ* (x)
"Ï2Reads the name slot of x if it has one.  This returns nil if X either isn't
 an instance or doesn't have a Name slot.Ï*"
  (OR (CATCH-ERROR (slot-value-safe x 'ticlos::name) nil)
      (CATCH-ERROR (generic-function-name-safe x) nil)))

;Ï1(defsafe-gf-simple argument-precedence-order-safe (gf)Ï*
;Ï1  :documentationÏ*
;Ï1    "Returns the argument precedence order of the generic-function GF."Ï*
;Ï1  :both generic-function-argument-precedence-order)Ï*

(defsafe-gf-simple Ï4argument-precedence-order-safeÏ* (gf)
  :documentation
    "Ï3Returns the argument precedence order of the generic-function GF.Ï*"
  :ticlos generic-function-argument-precedence-order)

;Ï1(defsafe-gf-simple generic-function-method-class-safe (gf)Ï*
;Ï1  :documentation "Returns the method class of a generic function."Ï*
;Ï1  :both generic-function-method-class)Ï*

(defsafe-gf-simple Ï4generic-function-method-class-safeÏ* (gf)
  :documentation "Ï3Returns the method class of a generic function.Ï*"
  :ticlos generic-function-method-class)

;Ï1(defsafe-gf-simple generic-function-method-combination-safe (gf)Ï*
;Ï1  :documentation "Returns the method combination type of a generic function."Ï*
;Ï1  :both generic-function-method-combination)Ï*

(defsafe-gf-simple Ï4generic-function-method-combination-safeÏ* (gf)
  :documentation "Ï3Returns the method combination type of a generic function.Ï*"
  :ticlos generic-function-method-combination)

;Ï1(defsafe-gf-simple generic-function-declarations-safe (gf)Ï*
;Ï1  :documentation "Returns any declarations made for the generic function GF."Ï*
;Ï1  :both generic-function-declare)Ï*

(defsafe-gf-simple Ï4generic-function-declarations-safeÏ* (gf)
  :documentation "Ï3Returns any declarations made for the generic function GF.Ï*"
  :ticlos generic-function-declare)

;Ï1(defsafe class-local-supers-safe (class)Ï*
;Ï1  :documentationÏ*
;Ï1"Returns a list of the local superclasses of the class class.  If a class isÏ*
;Ï1 undefined then it returns a symbol that names the undefined class."Ï*
;Ï1  :pcl (pcl:class-local-supers class)Ï*
;Ï1  :ticlosÏ*
;Ï1  ;; This should be fixed when Forward-Referenced-Class is impemented.Ï*
;Ï1    (MAPCAR #'(lambda (x) (OR (class-named-safe x t) x))Ï*
;	Ï1    (ticlos:class-direct-supers class))Ï*
;Ï1;    (let ((old #'ticlos:class-named))Ï*
;Ï1;Ï*	Ï1 (letf ((#'ticlos:class-namedÏ*
;Ï1;Ï*		Ï1 #'(lambda (name &optional no-error-p environment)Ï*
;Ï1;Ï*		Ï1     (ignore no-error-p)Ï*
;Ï1;Ï*		Ï1     (or (funcall old name t environment) name)Ï*
;Ï1;Ï*		Ï1   )Ï*
;Ï1;Ï*		Ï1)Ï*
;Ï1;Ï*	Ï1       )Ï*
;Ï1;Ï*	Ï1       (ticlos:class-direct-superclasses class)Ï*
;Ï1;Ï*	Ï1 )Ï*
;Ï1;    )Ï*
;Ï1    )Ï*

(defsafe Ï4class-local-supers-safeÏ* (class)
  :documentation
"Ï3Returns a list of the local superclasses of the class class.  If a class is
 undefined then it returns a symbol that names the undefined class.Ï*"
  :ticlos
  ;Ï1; This should be fixed when Forward-Referenced-Class is impemented.Ï*
    (MAPCAR #'(lambda (x) (OR (class-named-safe x t) x))
	    (ticlos::class-direct-supers class)))

;Ï1(defsafe-simple method-generic-function-safe (method)Ï*
;Ï1  :documentation "Returns the generic function that names the method Method."Ï*
;Ï1  :both method-generic-function)Ï*

(defsafe-simple Ï4method-generic-function-safeÏ* (method)
  :documentation "Ï3Returns the generic function that names the method Method.Ï*"
  :ticlos method-generic-function)

;Ï1(defsafe-simple class-direct-subclasses-safe (class)Ï*
;Ï1  :documentationÏ*
;Ï1  "Returns a list of the classes that are direct subclasses of the class Class."Ï*
;Ï1  :both class-direct-subclasses)Ï*

(defsafe-simple Ï4class-direct-subclasses-safeÏ* (class)
  :documentation
  "Ï3Returns a list of the classes that are direct subclasses of the class Class.Ï*"
  :ticlos class-direct-subclasses)

;Ï1(DEFUN iwmc-class-p-safe (something)Ï*
;Ï1"Is true if something is iwmc-class-p (instance-with-metaclass-p)."Ï*
;Ï1  (IF (FBOUNDP 'pcl:iwmc-class-p)Ï*
;Ï1      (pcl:iwmc-class-p something)Ï*
;Ï1      nil))Ï*

(DEFPARAMETER Ï4*cached-ticlos-class-names*Ï* nil
"Ï2A list of the ticlos class names of the classes that have been found.  This
 Gets set if the user opts to do an exhaustive search for all ticlos classes.Ï*")

;Ï1*************Ï*
;Ï1 TAC 07-27-89 - Rewrote all-class-names to take advantage of Ï*
;Ï1                TICLOS:*ALL-STANDARD-CLASS-NAMES*Ï*
;Ï1                which David Gray made available in patch 17.4Ï*

;Ï1(defun all-class-names (&optional (cheep-p nil))Ï*

;Ï1(DEFUN all-class-names (&optional (cheep-p nil))Ï*
;Ï1"Returns a list of all of the class names."Ï*
;Ï1  (DECLARE (SPECIAL pcl:*class-name-hash-table*))Ï*
;Ï1  cheep-p ; prevents compiler complaintÏ*
;Ï1  (APPEND (IF (BOUNDP 'pcl:*class-name-hash-table*)Ï*
;	Ï1      (MAPHASH-RETURN #'(lambda (key &rest ignore) key)Ï*
;			Ï1      pcl:*class-name-hash-table*)Ï*
;	Ï1      nil)Ï*
;	Ï1  ticlos:*all-standard-class-names*))Ï*

(DEFUN Ï4all-class-namesÏ* ()
"Ï2Returns a list of all of the class names.Ï*"
  ticlos::*all-standard-class-names*)

;Ï1(DEFUN generic-function-name-safe (gf)Ï*
;Ï1  :documentation "Returns the name of the generic function GF."Ï*
;Ï1  (OR (CATCH-ERROR (ticlos:generic-function-name gf) nil)Ï*
;Ï1      (CATCH-ERROR (pcl:generic-function-name gf) nil)Ï*
;Ï1      (ticlos:generic-function-name gf)Ï*
;Ï1      (pcl:generic-function-name gf)))Ï*

(DEFUN Ï4generic-function-name-safeÏ* (gf)
  :documentation "Ï3Returns the name of the generic function GF.Ï*"
  (OR (CATCH-ERROR (clos:generic-function-name gf) nil)
      (clos:generic-function-name gf)))

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

(DEFTYPE Ï4ticlos-instanceÏ* ()
 "Ï2The type which is true for instances of TICLOS classes.Ï*" 
 `(satisfies ticlos-instance-p))

;Ï1(DEFUN any-sort-of-clos-instance-p (x)Ï*
;Ï1"Is true if x is any sort of clos instance, be it PCL or TICLOS."Ï*
;Ï1  (OR (ticlos-instance-p x)Ï*
;Ï1      (iwmc-class-p-safe x)))Ï*

(DEFUN Ï4any-sort-of-clos-instance-pÏ* (x)
"Ï2Is true if x is any sort of clos instance.Ï*"
  (ticlos-instance-p x))

;Ï1(DEFTYPE any-sort-of-clos-instance ()Ï*
;Ï1  "The type which is true for instances of either TICLOS or PCL classes."Ï*
;Ï1 `(satisfies any-sort-of-clos-instance-p))Ï*

(DEFTYPE Ï4any-sort-of-clos-instanceÏ* ()
  "Ï2The type which is true for instances of TICLOS classes.Ï*"
 `(satisfies any-sort-of-clos-instance-p))

;Ï1(defsafe standard-method-p-safe (x)Ï*
;Ï1  :documentation "Is true if x is a standard method."Ï*
;Ï1  :pcl    (TYPEP x 'pcl:standard-method)Ï*
;Ï1  :ticlos (TYPEP x 'ticlos:standard-method))Ï*

(defsafe Ï4standard-method-p-safeÏ* (x)
  :documentation "Ï3Is true if x is a standard method.Ï*"
  :ticlos (TYPEP x 'ticlos:standard-method))

;Ï1(defsafe standard-generic-function-p-safe (x)Ï*
;Ï1  :documentation "Is true if x is a standard generic function."Ï*
;Ï1  :pcl    (TYPEP x 'pcl:standard-generic-function)Ï*
;Ï1  :ticlos (TYPEP x 'ticlos:standard-generic-function))Ï*

(defsafe Ï4standard-generic-function-p-safeÏ* (x)
  :documentation "Ï3Is true if x is a standard generic function.Ï*"
  :ticlos (TYPEP x 'ticlos:standard-generic-function))

;Ï1(defsafe directly-standard-generic-function-p-safe (x)Ï*
;Ï1  :documentationÏ*
;Ï1"Is true if x is a standard generic function and not an instance of someÏ*
;Ï1 specialisation of standard generic function."Ï*
;Ï1  :pcl    (AND (CLOSUREP x) (TYPEP x 'pcl:standard-generic-function))Ï*
;Ï1  :ticlos (EQUAL (TYPE-OF x) 'ticlos:standard-generic-function))Ï*

(defsafe Ï4directly-standard-generic-function-p-safeÏ* (x)
  :documentation
"Ï3Is true if x is a standard generic function and not an instance of some
 specialisation of standard generic function.Ï*"
  :ticlos (EQUAL (TYPE-OF x) 'ticlos:standard-generic-function))

;Ï1(DEFUN any-sort-of-clos-method-p (x)Ï*
;Ï1"Is true if x is either a PCL or a TICLOS method object."Ï*
;Ï1  (IF (iwmc-class-p-safe x)Ï*
;Ï1      (TYPEP x 'pcl:standard-method) ;;; JPR !!!Ï*
;Ï1      (IF (ticlos-p)Ï*
;	Ï1  (TYPEP x 'ticlos:method)Ï*
;	Ï1  nil)))Ï*

(DEFUN Ï4any-sort-of-clos-method-pÏ* (x)
  "Ï2Is true if x is a TICLOS method object.Ï*"
  (IF (ticlos-p)
      (TYPEP x 'ticlos:method)
      nil))

;Ï1(DEFTYPE any-type-of-clos-method ()Ï*
;Ï1"The type that defines either PCL or TICLOS method objects."Ï*
;Ï1  `(satisfies any-sort-of-clos-method-p))Ï*

(DEFTYPE Ï4any-type-of-clos-methodÏ* ()
"Ï2The type that defines TICLOS method objects.Ï*"
  `(satisfies any-sort-of-clos-method-p))

;Ï1(DEFUN any-sort-of-clos-gf-p (x)Ï*
;Ï1"Is true if x is either a PCL or a TICLOS generic function object."Ï*
;Ï1  (OR (AND (pcl-p)Ï*
;	Ï1   (TYPEP x 'pcl:standard-generic-function))Ï*
;Ï1      (AND (ticlos-p)Ï*
;	Ï1   (TYPEP x 'ticlos:generic-function))))Ï*

(DEFUN Ï4any-sort-of-clos-gf-pÏ* (x)
"Ï2Is true if x is a TICLOS generic function object.Ï*"
      (AND (ticlos-p)
	   (TYPEP x 'ticlos:generic-function)))

;Ï1(DEFTYPE any-type-of-clos-gf ()Ï*
;Ï1"The type that defines either PCL or TICLOS generic function objects."Ï*
;Ï1  `(satisfies any-sort-of-clos-gf-p))Ï*

(DEFTYPE Ï4any-type-of-clos-gfÏ* ()
"Ï2The type that defines TICLOS generic function objects.Ï*"
  `(satisfies any-sort-of-clos-gf-p))

;Ï1(DEFUN fef-of-gf-p (x)Ï*
;Ï1"Is true if x is the fef that defines a generic function."Ï*
;Ï1  (OR (AND (pcl-p) (TYPEP x 'pcl:standard-generic-function))Ï*
;Ï1      (AND (ticlos-p) (function-generic-function-safe x))))Ï*

(DEFUN Ï4fef-of-gf-pÏ* (x)
  "Ï2Is true if x is the fef that defines a generic function.Ï*"
  (AND (ticlos-p) (function-generic-function-safe x)))

(DEFTYPE Ï4fef-of-gfÏ* ()
"Ï2The type that is true for fefs that are for generic functions.Ï*"
  `(satisfies fef-of-gf-p))

(DEFUN Ï4is-a-class-name-not-flavor-classÏ* (name)
"Ï2Is true if Name is a symbol that names a class that does not have a flavor
 class declaration.  This is useful because it lets us view flavors as flavors
 even though they have flavor-class declarations.Ï*"
  (AND (TYPEP name 'symbol)
       (FBOUNDP 'class-named-safe)
       (FUNCALL 'class-named-safe name t)
       (OR (NOT (GET name 'si::flavor))
	   (NOT (TYPE-SPECIFIER-P 'ticlos:flavor-class))
	   (AND (TYPE-SPECIFIER-P 'ticlos:flavor-class)
		(NOT (TYPEP (FUNCALL 'class-named-safe
				     name t)
			    'ticlos:flavor-class))))))

;Ï1(defsafe-simple method-specializers-safe (method)Ï*
;Ï1  :documentation "Returns the list of method specializers for Method."Ï*
;Ï1  :ticlos method-specializersÏ*
;Ï1  :pcl method-type-specifiers)Ï*

(defsafe-simple Ï4method-specializers-safeÏ* (method)
  :documentation "Ï3Returns the list of method specializers for Method.Ï*"
  :ticlos method-specializers)

;Ï1(defsafe-gf-simple compute-applicable-methods-safe (gf methods)Ï*
;Ï1  :documentation "Returns a list of the applicable methods for a genericÏ*
;Ï1function GF from a list of methods Methods."Ï*
;Ï1  :both compute-applicable-methods)Ï*

(defsafe-gf-simple Ï4compute-applicable-methods-safeÏ* (gf methods)
  :documentation 
  "Ï3Returns a list of the applicable methods for a generic function GF from a list of methods Methods.Ï*"
  :ticlos compute-applicable-methods)

;Ï1(defsafe-gf compute-effective-method-safeÏ*
;	Ï1       (gf method-combination methods)Ï*
;Ï1  :documentationÏ*
;Ï1"Computes the code for the effective method of a generic function, using aÏ*
;Ï1 particular type of method combination and a list of effective methods."Ï*
;Ï1  :ticlos (ticlos:compute-effective-method gf method-combination methods)Ï*
;Ï1  :pcl (pcl:compute-effective-method-body gf methods))Ï*

(defsafe-gf Ï4compute-effective-method-safeÏ*
	       (gf method-combination methods)
  :documentation
"Ï3Computes the code for the effective method of a generic function, using a
 particular type of method combination and a list of effective methods.Ï*"
  :ticlos (ticlos:compute-effective-method gf method-combination methods))

;Ï1(defsafe-simple class-prototype-safe (class)Ï*
;Ï1  :documentation "Returns the class prototype oc a class."Ï*
;Ï1  :both class-prototype)Ï*

(defsafe-simple Ï4class-prototype-safeÏ* (class)
  :documentation "Ï3Returns the class prototype oc a class.Ï*"
  :ticlos class-prototype)

(DEFVAR Ï4*method-combination-indent-increment*Ï* 2
"Ï2The number of spaces to indent by each time the method combination display
 throws a newline and tabs for a sublist.Ï*")

(DEFUN Ï4post-process-combined-methodÏ* (form &optional (indent 0))
"Ï2Takes a form that (when ground) would appear as follows:
   (progn (sys:%apply-method before method 1)
          (sys:%apply-method before method 2)
          ...
          (sys:%apply-method before method n)
          (multiple-value-prog1
            (sys:%apply-method primary method)
            (sys:%apply-method after method 1)
            (sys:%apply-method after method 2)
            ...
            (sys:%apply-method after method n)))

 and transforms it into an inspector compatible item list that will
 look like:
   (progn <before method 1>
          <before method 2>
          ...
          <before method n>
          (multiple-value-prog1
            <primary method>
            <after method 1>
            <after method 2>
            ...
            <after method n>))

 where the things labeled <...> will appear as mouse-sensitive items of the
 type show-clos-method.m  The grindingf that this function does is very
 primitive.  Sub-lists are started on new lines indented by a few spaces
 (*method-combination-indent-increment*).Ï*"
  (DECLARE (SPECIAL *this-line* *all-lines*))
  (IF (CONSP form)
      (IF (MEMBER (FIRST form)
		  ;Ï1;Ï* TAC 08-17-89Ï1 - remove pcl references Ï*
		  ;Ï1; Ï*'(ticlos:call-method sys:%apply-method pcl:call-method))
		  '(ticlos:call-method sys::%apply-method))
	  (LET ((meth
		  (IF (EQUAL (FIRST form) 'sys::%apply-method)
		      (method-from-method-function-safe
			(FDEFINITION (SECOND (SECOND form))))
		      (SECOND form))))
	       (PUSH (REVERSE *this-line*) *all-lines*)
	       (SETQ *this-line* nil)
	       (PUSH `(,*space-format* ,indent) *this-line*)
	       (PUSH (IF meth
			 `(:item1 instance
				 ,(allocate-data
				    'show-clos-method
				    meth)
				  print-unpadded-method)
			 `(:font 1
			   ,(FORMAT nil "Ï3~SÏ*"
			     (FUNCTION-NAME
			       (FDEFINITION (SECOND (SECOND form)))))))
		     *this-line*))
	  (PROGN (PUSH (REVERSE *this-line*) *all-lines*)
		 (SETQ *this-line* nil)
		 (PUSH `(,*space-format* ,indent) *this-line*)
		 (PUSH '(:font 1 "Ï3(Ï*") *this-line*)
		 (MAPCAR #'(lambda (x)
			    (post-process-combined-method
			      x
			      (+ *method-combination-indent-increment* indent)))
			   form)
		 (PUSH '(:font 1 "Ï3)Ï*") *this-line*)))
      (IF form (PUSH `(:font 1 ,(SYMBOL-NAME form)) *this-line*) nil)))

(DEFUN Ï4clean-up-methodÏ* (method)
"Ï2Just makes sure that the method body doesn't have a boring definition for
 apply method at the front.Ï*"
  (IF (EQUAL (FIRST method) 'MACROLET)
      (clean-up-method (REST (REST method)))
      method))

(DEFUN Ï4method-combination-of-method-safeÏ* (method)
"Ï2Returns the list of method combination type for Method.Ï*"
  (CATCH-ERROR ;Ï1; This catches things like eql specializers.Ï*
    (LET ((methods (compute-applicable-methods-safe
		     (method-generic-function-safe method)
		     (MAPCAR #'(lambda (x)
				 (IF (TYPEP x 'ticlos:built-in-class)
				     t
				     (class-prototype-safe x)))
			       (method-specializers-safe method)))))
	 (LET ((code (compute-effective-method-safe
		       (method-generic-function-safe method)
		       (generic-function-method-combination-safe
			 (method-generic-function-safe method))
		       methods)))
	      (LET ((form (clean-up-method code)))
		   (LET ((*this-line* nil)
			 (*all-lines* nil))
			(DECLARE (SPECIAL *this-line* *all-lines*))
			(post-process-combined-method
			  (IF (EQUAL (LENGTH form) 1)
			      (FIRST form)
			      form))
			(PUSH (REVERSE *this-line*) *all-lines*)
			(LET ((result (REVERSE (REMOVE nil *all-lines*))))
			     result)))))
    nil))

;Ï1(defsafe-simple slot-boundp-safe (instance slot)Ï*
;Ï1  :documentation "Is true if the slot Slot is bound in the instance Instance."Ï*
;Ï1  :both slot-boundp)Ï*

(defsafe-simple Ï4slot-boundp-safeÏ* (instance slot)
  :documentation "Ï3Is true if the slot Slot is bound in the instance Instance.Ï*"
  :ticlos slot-boundp)

(DEFUN Ï4method-from-generic-function-using-method-functionÏ* (fef gf)
"Ï2Given a method function and a generic function, returns the method object that
 has the method function Fef.Ï*"
  (LET ((methods (generic-function-methods-safe gf)))
       (FIND-IF #'(lambda (method)
		    (EQUAL fef (method-function-safe method)))
		  methods)))

(DEFUN Ï4method-from-method-function-safeÏ* (fef)
"Ï2Given a method function returns the method object for it.Ï*"
  (LET ((first-try (sys:get-debug-info-field (sys:get-debug-info-struct fef)
					     :method)))
       (OR first-try
	   (method-from-generic-function-using-method-function
	     fef (function-generic-function-safe
		   (fdefinition-safe (SECOND (FUNCTION-NAME fef)))))
	   (FERROR nil "Ï3Can't get a method from ~SÏ*" fef))))
;Ï1-------------------------------------------------------------------------------Ï*
;Ï1*************Ï*
;Ï1 TAC 07-27-89 - moved to INSPECT.LISP Ï*
;Ï1;; Abstracted out of TI definition of inspect-setup-object-display-list.Ï*
;Ï1(defun generic-object-foo-method (for-object)Ï*

;Ï1;;; Abstracted out of TI definition of inspect-setup-object-display-list.Ï*
;Ï1(defun inspect-object-display-list (object window)Ï*

;Ï1(defun inspect-setup-object-display-listÏ*
;Ï1       (object window &optional top-item label &aux str)Ï*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1(DEFUN (:property clos-slot set-function)Ï*
;Ï1       (item new-value object)Ï*
;Ï1  (LET ((slot (THIRD (SECOND item))))Ï*
;Ï1       (IF (iwmc-class-p-safe object)Ï*
;	Ï1   ;; Use Eval here to make completely sure that there are noÏ*
;	Ï1   ;; macro-expansion dependencies for compilation of this file.Ï*
;	Ï1   ;; We don't want to have to load PCL just to compile this function.Ï*
;	Ï1   (EVAL `(SETF (pcl:slot-value    ,object ',slot) ,new-value))Ï*
;	Ï1   (EVAL `(SETF (ticlos:slot-value ,object ',slot) ,new-value)))))Ï*

(DEFUN Ï4(:property clos-slot set-functionÏ*)
       (item new-value object)
  (LET ((slot (THIRD (SECOND item))))
    (EVAL `(SETF (ticlos:slot-value ,object ',slot) ,new-value))))

;Ï1; Slot names are only mouse sensitive when they're being modified.Ï*
(DEFPROP Ï4clos-slotÏ* t only-when-modify)

(DEFMETHOD Ï4(basic-inspect :object-clos-instanceÏ*) (obj &aux result)
"Ï2The itemiser method for clos instances.Ï*"
  (SETQ result (display-in-inspector obj result))
  (VALUES (NREVERSE result) obj 'inspect-printer))

(DEFPARAMETER Ï4*clos-inspect-tab-width*Ï* 30.
"Ï2The default width to tab to when displaying clos instances.  This should give
 enough room for most slot names.Ï*")

(DEFUN Ï4inspect-slotsÏ* (me title slots result &aux (maxlength 0))
"Ï2Generates an item list for the Slots of the instance Me, with title Title.
 Result is the list that we'll be collecting into.  It may already have
 had stuff put into it.Ï*"
  (DOLIST (c slots)
    (SETQ maxlength (MAX (FLATSIZE c) maxlength)))
  (SETQ maxlength (MIN *clos-inspect-tab-width* maxlength))
  (PUSH `((:font 1 ,title)) result)
  (PUSH '("") result)
  (DOLIST (c slots)
    (PUSH `((:item1 clos-slot ,(slotd-name-safe c)
		    ,#'(lambda (name stream) (FORMAT stream "Ï3~SÏ*" name)))
	    (:colon ,(+ 2 maxlength))
	    ;Ï1; Try to be really careful here.  Lots of catch-errors and such.Ï*
	    ;Ï1; The last thing we want is for the Inspector to lock upÏ*
	    ;Ï1; whilst looking at/printing slots and their values.Ï*
	   ,(MULTIPLE-VALUE-BIND (BOUNDP error-p)
		(CATCH-ERROR (slot-boundp-safe me (slotd-name-safe c)) nil)
	      (IF error-p
		 '(:font 2 "Ï3Error reading slotÏ*")
		  (IF boundp
		      (MULTIPLE-VALUE-BIND (value error-p)
			  (CATCH-ERROR
			    (slot-value-safe me (slotd-name-safe c)) nil)
			(IF error-p
		           `(:font 2
			     "Ï3Some error happened whilst reading this slot.Ï*")
			   `(:item1 named-structure-value ,value)))
		     '(:font 2 "Ï3unboundÏ*")))))
	   result))
  (PUSH '("") result)
  result)

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

;Ï1(DEFUN display-in-inspector (me result)Ï*
;Ï1"Generates a complete item list for the instance Me and collects it all intoÏ*
;Ï1 Result, which is returned."Ï*
;Ï1  (LET* ((class (class-of-safe me))Ï*
;	Ï1 (instance-slots (class-instance-slots-safe class))Ï*
;	Ï1 (non-instance-slots (class-non-instance-slots-safe class)))Ï*
;Ï1    (PUSH `(,(IF (ticlos-instance-p me)Ï*
;		Ï1 "CLOS instance of "Ï*
;		Ï1 "CLOS (PCL) instance of ")Ï*
;	Ï1    (:item1 instanceÏ*
;		Ï1    ,(allocate-data 'show-clos-class (class-of-safe me))))Ï*
;	Ï1   result)Ï*
;Ï1    (PUSH '("") result)Ï*						
;Ï1    (WHEN (NOT (NULL non-instance-slots))Ï*
;Ï1      (SETQ resultÏ*
;	Ï1    (inspect-slots me "Shared Slots:"Ï*
;			Ï1   non-instance-slots result))Ï*
;Ï1      (PUSH '("") result))Ï*
;Ï1    (WHEN (NOT (NULL instance-slots))Ï*
;Ï1      (SETQ resultÏ*
;	Ï1    (inspect-slots me "Local Slots:"Ï*
;			Ï1   instance-slots result)))Ï*
;Ï1    result))Ï*

(DEFUN Ï4display-in-inspectorÏ* (me result)
"Ï2Generates a complete item list for the instance Me and collects it all into
 Result, which is returned.Ï*"
  (LET* ((class (class-of-safe me))
	 (instance-slots (class-instance-slots-safe class))
	 (non-instance-slots (class-non-instance-slots-safe class)))
    (PUSH `("Ï3CLOS instance of Ï*"
	    (:item1 instance
		    ,(allocate-data 'show-clos-class (class-of-safe me))))
	   result)
    (PUSH '("") result)						
    (WHEN (NOT (NULL non-instance-slots))
      (SETQ result
	    (inspect-slots me "Ï3Shared Slots:Ï*"
			   non-instance-slots result))
      (PUSH '("") result))
    (WHEN (NOT (NULL instance-slots))
      (SETQ result
	    (inspect-slots me "Ï3Local Slots:Ï*"
			   instance-slots result)))
    result))

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

;Ï1;; Temporary fixes?? !!!!! JPR.Ï*

;Ï1(DEFUN pcl:class-finalized-p (class)Ï*
;Ï1  (IGNORE class)Ï*
;Ï1  nil)Ï*

;Ï1(DEFUN pcl:class-direct-slots (class)Ï*
;Ï1  (pcl:class-slots class))Ï*

;Ï1(DEFUN pcl:slotd-accessors (slotd)Ï*
;Ï1  (IGNORE slotd)Ï*
;Ï1  nil)Ï*

;Ï1(DEFUN pcl:generic-function-method-combination (gf)Ï*
;Ï1  (IGNORE gf)Ï*
;Ï1  :standard)Ï*

;Ï1(DEFUN pcl:generic-function-argument-precedence-order (gf)Ï*
;Ï1  (ARGLIST (get-fef-from-object gf)))Ï*

;Ï1(DEFUN pcl:generic-function-declare (gf)Ï*
;Ï1  (IGNORE gf)Ï*
;Ï1  nil)Ï*

;Ï1(DEFUN pcl:class-of-generic-function (gf)Ï*
;Ï1  (IGNORE gf)Ï*
;Ï1  (class-named-safe 'pcl:standard-generic-function))Ï*

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

;Ï1(EVAL-WHEN (COMPILE load eval)Ï*
;Ï1  (IF (NOT (GET 'pcl:iwmc-class 'sys:defstruct-description))Ï*
;Ï1      ;; Make a dummy definition for iwmc-class so that we can defined methodsÏ*
;Ï1      ;; on it, even if we don't have PCL loaded.Ï*
;Ï1      (EVAL '(DEFSTRUCT (pcl:iwmc-class)Ï*
;	Ï1       (pcl:class-wrapper nil)Ï*
;	Ï1       (pcl:static-slots nil)))Ï*
;Ï1      nil))Ï*

;Ï1(ticlos:defmethod documentation ((thing pcl:iwmc-class) &optional doc-type)Ï*
;Ï1  (IGNORE doc-type)Ï*
;Ï1  (TYPECASE thingÏ*
;Ï1    (pcl:standard-slot-description (pcl:slotd-documentation thing))Ï*
;Ï1    (pcl:standard-classÏ*
;Ï1     (SECOND (ASSOC :documentation (pcl:class-options thing))))Ï*
;Ï1    (pcl:standard-method (pcl:method-documentation thing))Ï*
;Ï1    (otherwise nil)))Ï*

;Ï1*************Ï*
;Ï1 TAC 07-26-89 ----- moved from TI-ENV-FLAVOR-INSPECTOR-INTERFACE ---------Ï*

(DEFUN Ï4my-subtypepÏ* (a b)
"Ï2Like 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 Ï4class-shadowsÏ* (class1 class2)
"Ï2Is 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))
;Ï1 -------------------------------------------------------------------------Ï*

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

;Ï1;; Supplied by David Gray.Ï*
(DEFUN Ï4handlespÏ* (generic-function &rest arguments)
  (LET* ((defn generic-function)
	 (gfun
	   (COND
	     ((sys:typep-structure-or-flavor defn 'generic-function) defn)
	     ((ticlos::generic-function-p defn)
	      (ticlos::get-generic-function-object defn))
	     ((FUNCTIONP defn) (RETURN-FROM handlesp defn))
	     (t (ERROR "Ï3~S is not a function.Ï*" generic-function))))
	 (mloc
	   (APPLY #'ticlos::find-right-method
		  (OR (ticlos::generic-function-method-hash-table gfun)
		      (PROGN (ticlos::build-method-hash-table gfun)
			     (ticlos::generic-function-method-hash-table gfun)))
		  (ticlos::reorder-parameter-specializers gfun arguments))))
    (OR (CONTENTS mloc)
	(VALUES (ticlos::find-handler
		  gfun
		  (MAPCAR #'ticlos:class-of
			  (ticlos::reorder-parameter-specializers
			    gfun arguments))) ))))

(DEFUN Ï4handlers-forÏ* (gf &rest classes)
"Ï2Given a generic function and a list of classes it returns all of the methods
 that it thinks will handle the GF if called with those args.Ï*"
  (LET ((methods (generic-function-methods-safe
		   (function-generic-function-safe (get-fef-from-object gf)))))
       (REMOVE (sys:get-debug-info-field
		 (sys:get-debug-info-struct
		   #'(ticlos:method ticlos:print-object (t t)))
		 :method)
	       (REMOVE-IF-NOT
		#'(lambda (x)
		    (class-matches-p (unparse-specializers-safe x) classes t))
		  methods))))

;Ï1(handlers-for #'ticlos:print-object 'ticlos:standard-object)Ï*
;Ï1(handlers-for #'ticlos:print-object 'ticlos:standard-class)Ï*
;Ï1(handlers-for #'ticlos:print-object 'lexical-closure)Ï*
;Ï1(handlers-for #'ticlos:print-object 'closure)Ï*

(DEFUN Ï4print-pointerÏ* (of stream)
  (LET ((*print-base* 8.)
	(*print-radix* nil)
	(*nopoint t))
       (FORMAT stream "Ï3~AÏ*" (%pointer of))))

;Ï1(ticlos:defmethod ticlos:print-object ((thing lexical-closure) stream)Ï*
;Ï1  (IF (generic-function-p-safe thing)Ï*
;Ï1      (FORMAT stream "#<PCL Generic-function ~s ~A>"Ï*
;	Ï1      (generic-function-name-safe thing) (print-pointer thing nil))Ï*
;Ï1      (FORMAT stream "#<~A ~A>"Ï*
;	Ï1      (STRING (DATA-TYPE thing))Ï*
;	Ï1      (print-pointer thing nil))))Ï*

(ticlos:defmethod ticlos:print-object ((thing lexical-closure) stream)
  (FORMAT stream "Ï3#<~A ~A>Ï*"
	  (STRING (DATA-TYPE thing))
	  (print-pointer thing nil)))

;Ï1*************Ï*
;Ï1 TAC 08-07-89 - current kernel function is sufficient. See sys:kernel;who-calls.lisp Ï*
;Ï1                5/2/89 DNG - Updated to recognize and scan SETF and LOCF functions.Ï*
;Ï1;; Generalisation of the Who-Calls fix that I gave DG.Ï*
;Ï1sys:Ï*
;Ï1(defun sys:find-callers-of-symbols-aux (caller symbol function)Ï*
;Ï1-------------------------------------------------------------------------------Ï*

;Ï1*************Ï*
;Ï1 TAC 08-01-89 - moved this into INSPECT.LISP where it belongs.Ï*
;Ï1;; Redefine this so that we have :middle-button-result as a new required method.Ï*
;Ï1(DEFFLAVOR inspection-data (data) ()
Ï*;Ï1-------------------------------------------------------------------------------