;;; -*- Mode: LISP; Syntax: Common-lisp; Package: SMS; Base: 10 -*-

(in-package :SMS) 

;;;=============================================================================
;;; Provides a CLOS class-defining macro, and various utilities that keep
;;; track of instances based on names. 10/92-1/93 Marty Hall.
;;;
;;; A brief overview of the main user routines is given here. See the actual
;;; code for a more detailed explanation, plus functions and macros have doc
;;; strings. All of these are exported from the SMS package. SO IF YOU MAKE ANY
;;; CHANGES, BE SURE TO ALSO UPDATE /Initializations/Package-Definitions.lisp.
;;;
;;;   Define-Class: A macro that expands into defclass, allowing an abbreviated
;;;   ============  class definition whereby all slots get accessors with the
;;;                 same name and initargs with the same name except for the
;;;                 colon, and an initform if a value was supplied. It
;;;                 optionally allows the other slot-spec keywords (eg
;;;                 :documentation, :allocation, :type), plus has a special
;;;                 keyword called :Doc-String. This specifies the doc string
;;;                 for the generic function of the same name as the slot. It
;;;                 also adds the mixin "Named-Object" to the list of
;;;                 superclasses, automatically adding a unique NAME slot to
;;;                 each instance, and creating a hash table whereby instances
;;;                 can be retrieved by name. This can eliminate much of the
;;;                 bookkeeping associated with keeping track of instances in
;;;                 variables, plus allows a semantic-net like structure
;;;                 (where instances are stored as values of slots) to be
;;;                 represented in permanent code, since instances do not have
;;;                 a print representation that can be used in code. 
;;;                 See below for more details.
;;;
;;;   Def-Class: Exactly like Define-Class except that it does not add the 
;;;   =========  Named-Object mixin, making instance creation faster but
;;;              providing less utilities on the instances once they are made.
;;;              Syntax is identical to Define-Class.
;;;
;;;   Named-Object: A mixin class that gets added to the superclass list of 
;;;   ============  all classes defined with "Define-Class". It adds a slot
;;;                 and associated reader called Name. The default value of
;;;                 this slot will be :Foo-XX, where Foo is the class name of
;;;                 the instance being created, and XX is the lowest natural
;;;                 number whereby :Foo-XX doesn't already name an instance.
;;;                 All instances of Named-Objects get recorded in a hash
;;;                 table with the name as a key, and get a specialized
;;;                 print-object.
;;;
;;;   Name:         Reader method created automatically for all Named-Objects,
;;;   ====          ie everything created via Define-Class.
;;;
;;;   Get-Instance: A method that normally takes an instance name 
;;;   ============  (:Own-ship, 'Foo-2, etc) as an argument, and returns the
;;;                 instance with that name. The name can be a symbol in any
;;;                 package. Note that this disallows different objects with
;;;                 the same name in different packages, something you might
;;;                 want to do in many applications, but was deliberately left
;;;                 out for simplicity in the [D]ARPA Signature Management
;;;                 System (SMS), for which this utility was made. Returns NIL
;;;                 for a symbol that does not name an instance. If given an
;;;                 instance, it just returns it unchanged. NOTE ALSO the
;;;                 defined macro characters, such that
;;;
;;;                 {Foo} == (Get-Instance :Foo) and
;;;                 [Foo] == (Get-Instance Foo), so that for instance
;;;                 (Depth {Own-Ship}) == (Depth (Get-Instance :Own-Ship))
;;;
;;;   Copy-Instance:  Takes an instance and copies all slot values to another.
;;;   =============   Assumes BOTH instances made via Define-Class in that
;;;                   they have identical slot names, and slot names
;;;                   correspond to accessors. 
;;;
;;;   Assign-Slot-Value: Given a quoted Instance name, Slot name, and value,
;;;   =================  does (setf (Slot {Instance}) Value)
;;;
;;;   Remove-Instance: takes a name or an instance, and removes the 
;;;   ===============  corresponding entries in the hash tables.
;;;
;;;   Remove-Instances: Removes (in the sense above) all instances of a 
;;;   ================  specified class.
;;;
;;;   Direct-Instances: Takes a class name and returns all instances of 
;;;   ================  Named-Objects that are directly (no intervening
;;;                     subclasses) in that class.
;;;
;;;   Instances: Takes a class name and returns all instances of Named-Objects
;;;   =========  are directly or indirectly in that class. Unsorted.
;;;
;;;   Instance-Names: Names of all instances of Named-Objects that are 
;;;   ==============  directly or indirectly in specified class. Sorted
;;;                   alphabetically if the :Sort-p flag is set.
;;;
;;;   All-Instances: All instances of Named-Objects.
;;;   =============
;;;
;;;   All-Instance-Names: Names of all instances of Named-Objects. Sorted
;;;   ==================  alphabetically if the :Sort-p flag is set.
;;;        
;;;   Slot-Names:   Given an instance or a class name, returns a list of all 
;;;   ==========    slots. Assuming the class was defined with Define-Class,
;;;                 this means that every slot SlotJ has a reader function
;;;                 also called SlotJ, and that every slot SlotJ also has a
;;;                 (setf SlotJ) writer, EXCEPT for the "Name" slot.
;;;
;;;  Direct-Slot-Names: Given an instance or a class name, returns a list of all
;;;  =================  DIRECTLY defined slots. Ie inherited slots are not
;;;                     included.
;;;
;;;  Has-Reader-p: Given an instance and a slot name, determines if there is
;;;  ============  a reader method with the same name as the slot, as
;;;                Define-Class would make automatically.
;;;  
;;;  Instance-Class: Given an instance name or an instance object returns a 
;;;  ==============  symbol that is the immediate class name. Ie given
;;;                  'Bear-1 returns BEAR. If the argument is neither an
;;;                  instance nor an instance name, this returns NIL.
;;;
;;;  Subclasses: Given a class name returns the names of the direct subclasses.
;;;  ==========  Returns NIL if there are no subclasses OR if the supplied
;;;              symbol names no class. Sorted alphabetically if the :Sort-p
;;;              flag is set.
;;;
;;;  Internal-Address-String: A non-standard way to get the address of an 
;;;  =======================  object in Symbolics or Lucid. Returns it in a
;;;                           string for use by a specialized print-object.
;;;                           NOT portable to other implementations.
;;;
;;;=============================================================================
;;; Define-Class macro. The simplest use is that 
;;; (Define-Class Class (Superclasses) (Slot Val)* ) expands into a defclass
;;; defining the class and slots, with the addition of adding accessors and
;;; :initargs with the the same name as the slot name, and adding a Name
;;; slot/accessor by making Named-Object one of the superclasses. Instead of
;;; (Slot Val) you can specify (Slot Val <Normal Slot-Spec Keywords>).
;;; For instance:
;;;
;;; (Define-Class Foo (Bar)
;;;   (Slot-1 Val-1)               ; <== Most common case: (Slot Value) pairs
;;;   (Slot-2 Val-2 :Doc-String "Slot-2 string"
;;;                 :type fixnum
;;;                 :allocation :class)
;;;   Slot-3
;;;   ...
;;;   (Slot-N Val-N))
;;;
;;; and get
;;;
;;; (defclass Foo (Bar Named-Object)
;;;   ((Slot-1 :initform Val-1 :accessor Slot-1 :initarg :Slot-1)
;;;    (Slot-2 :initform Val-1 :accessor Slot-2 :initarg :Slot-2
;;;                            :type fixnum :allocation :class)
;;;    (Slot-3                 :accessor Slot-3 :initarg :Slot-3)
;;;    ...
;;;    (Slot-N :initform Val-N :accessor Slot-N :initarg :Slot-N)))
;;;
;;; with the side effect that "Slot-2 string" gets set as the doc string for the
;;; generic function SLOT-2.
;;;
;;; Alternatively, you can replace the class name ["Foo" here] with a list of 
;;; (class name <class option>*), where <class option> is any of the class
;;; options legal for defclass, each enclosed in parens.
;;; [Eg "(Foo (:default-initargs :x 5))"] Thus,
;;;
;;; (Define-Class (Foo (:documentation "A class called FOO")) (Bar)
;;;   (Slot-1 Val-1)
;;;   Slot-2)
;;;
;;; expands into
;;;
;;; (defclass Foo (Bar Named-Object)
;;;   ((Slot-1 :initform Val-1 :accessor Slot-1 :initarg :Slot-1)
;;;    (Slot-2                 :accessor Slot-2 :initarg :Slot-2))
;;;   (:documentation "A class called FOO"))
;;;
;;; Making Foo a Named-Object makes a Name slot with a default value of
;;; Foo-XX (for the lowest XX where Foo-XX is not already an existing
;;; instance name). If you specify a Name slot explicitly, be careful that it
;;; will give different names for each instance. But it is no problem to give
;;; a particular name to an INSTANCE when creating the object; a :Name
;;; initarg is created for that purpose. This name should be a symbol, and
;;; will be placed in the keyword package. Lookup of instances are done by
;;; first putting the requested name in the keyword package, so there is no
;;; need to lookup :Foo-XX, 'Foo-XX is sufficient. This also allows matches from
;;; various packages (eg SMS and KEE, which both used 'Own-Ship already), but
;;; has the disadvantage of not allowing two different objects with the same
;;; name in different packages.
;;;
;;; Original version 1990-1992 Marty Hall, updated to allow class options such
;;; as default-initargs at the suggestion of Bruce Israel, 10/92.

(defmacro Define-Class (Class-Name Super-Class-List &rest Slot-Entries)
  "Expands into a defclass form. Simplest format:
  
  (Define-Class Foo (Bar) 
     (Slot-1 Val-1) 
     Slot-2) 
  -->
  (defclass Foo (Bar Named-Object)
    ((Slot-1 :initform Val-1 :accessor Slot-1 :initarg :Slot-1)
     (Slot-2                 :accessor Slot-2 :initarg :Slot-2)))

  You can also add any of the normal slot-spec keywords after the slot value
  to specify the :allocation, :type, etc., plus there is an additional keyword
  called :DOC-STRING that is used to specify the doc string for the generic
  function having the same name as the slot. Finally, you can replace `Foo'
  with `(Foo (class-option)* )'. The syntax is *exactly* the same as
  Def-Class (but Named-Object is mixed in as a parent)."

  (if
    (atom Class-Name)
    `(defclass ,Class-Name (,@Super-Class-List Named-Object)
	 ,(mapcar #'Expand-Slot-Name-Value-Pair Slot-Entries))
    `(defclass ,(first Class-Name) (,@Super-Class-List Named-Object)
	 ,(mapcar #'Expand-Slot-Name-Value-Pair Slot-Entries)
       ,@(rest Class-Name)) )
)

;;;=============================================================================
;;; The Def-Class macro is JUST like Define-Class except that the class is not
;;; automatically made a subclass of Named-Object. The pro of this is instance
;;; creation speed: it is increased by more than 10 fold. The cons is that
;;; you will not get a name slot or be able to retrieve this by name, and any
;;; method (eg print-object, after methods on initialize-instance, etc,) that
;;; are defined to work on all custom objects in SMS generally specialize on
;;; Named-Object, and thus will miss this.
;;; 3/93 Marty Hall.

(defmacro Def-Class (Class-Name Super-Class-List &rest Slot-Entries)
  "Expands into a defclass form. Simplest format:
  
  (Define-Class Foo (Bar) 
     (Slot-1 Val-1) 
     Slot-2) 
  -->
  (defclass Foo (Bar)
    ((Slot-1 :initform Val-1 :accessor Slot-1 :initarg :Slot-1)
     (Slot-2                 :accessor Slot-2 :initarg :Slot-2)))

  You can also add any of the normal slot-spec keywords after the slot value
  to specify the :allocation, :type, etc., plus there is an additional keyword
  called :DOC-STRING that is used to specify the doc string for the generic
  function having the same name as the slot. Finally, you can replace `Foo'
  with `(Foo (class-option)* )'. The syntax is *exactly* the same as
  Define-Class (but Named-Object is not mixed in as a parent)."

  (if
    (atom Class-Name)
    `(defclass ,Class-Name ,Super-Class-List
	 ,(mapcar #'Expand-Slot-Name-Value-Pair Slot-Entries))
    `(defclass ,(first Class-Name) ,Super-Class-List Named-Object
	 ,(mapcar #'Expand-Slot-Name-Value-Pair Slot-Entries)
       ,@(rest Class-Name)) )
)

;;;=============================================================================
;;; A Slot entry is either a slot name, a list of (Slot-Name Slot-Value), or
;;; a list of (Slot-Name Slot-Value <Normal CLOS Slot-Spec Keywords>).
;;;
;;; This function expands a slot entry as follows:
;;;
;;; Simplest case (no keywords)
;;;
;;; Slot-Name       --> (Slot-Name :accessor Slot-Name :initarg :Slot-Name)
;;; (Name Value)    --> (Name :initform Value :accessor Name :initarg :Name)
;;;
;;; More complicated case (extra keywords):
;;;
;;; (Name Value <Extra Keywords>)
;;;   --> (Name :initform Value :accessor Name :initarg :Name <Extra Keywords>)
;;;   IF there is no :Doc-String entry in <Extra Keywords>. 
;;;
;;; (Name Value :Doc-String "Test" <Extra Keywords>)
;;;   --> (Name :initform Value :accessor Name :initarg :Name <Extra Keywords>)
;;;   *PLUS*, as a side effect, "Test" is set as the doc string for the
;;    function Name.
;;; 
;;; Also allowed but rarely used is
;;;
;;; (Name) == (Name NIL) --> (Name :initform NIL :accessor Name :initarg :Name)
;;;
;;; 1990-93 Marty Hall

(defun Expand-Slot-Name-Value-Pair (Slot-Entry)
  (let (Slot-Name Slot-Value Extra-Keywords Doc-String)
    (cond
      ((listp Slot-Entry)
       (setq Slot-Name (first Slot-Entry)
	     Slot-Value (second Slot-Entry)
	     Extra-Keywords (rest (rest Slot-Entry))
	     Doc-String (getf Extra-Keywords :Doc-String))
       (when Doc-String
	 (remf Extra-Keywords :Doc-String)
	 (setf (documentation Slot-Name 'function) Doc-String))
       (append
	 (list Slot-Name
	       :accessor Slot-Name
	       :initform Slot-Value
	       :initarg (Add-Colon Slot-Name))
	 Extra-Keywords) )
      (t
       (setq Slot-Name Slot-Entry)	; Redundant for consistency w/ above
       (list Slot-Name
	     :accessor Slot-Name
	     :initarg (Add-Colon Slot-Name)) ) )
))

;;;=============================================================================
;;; Given 'Foo or "Foo" returns :FOO. This has the same effect as 
;;; (read-from-string (concatenate 'string ":" (string Arg))), but does not
;;; have to invoke the LISP reader. 
;;;
;;; Symbolics-specific note:
;;; Be careful of calling the second one of these *interactively* from the LISP
;;; Listener on the Symbolics, as the Symbolics often puts font characters into
;;; strings. You may need to do (Add-Colon (user::string-thin "foo")). This
;;; is not a concern in *functions* that call Add-Colon, however.

(defmethod Add-Colon ((Sym symbol))
  (if (keywordp Sym)
      Sym
      (intern (symbol-name Sym) :keyword)) )

(defmethod Add-Colon ((Str string))
  (intern (string-upcase Str) :keyword) )

;;;=============================================================================
;;; Note that there is deliberately no (setf Name) operator. This can be added
;;; later if you want to allow renaming, as long as you update the hash table
;;; appropriately.

(defclass Named-Object ()
    ((Name :initform NIL :reader Name :initarg :Name))
  (:documentation
    "Class of objects to which all SMS objects belong, at least if
    they need to have name slots. Provides a name slot, a function Get-Instance
    that returns the instance object with a given name, and a print-object
    method to put the name in the printed representation. This is also the class
    to use if you want to specialize a method on all SMS objects.") )

;;;=============================================================================
;;; This records the names of ALL CLOS objects that have name slots. Since it
;;; does not use :test #'equal, it will not work for instances that have
;;; strings or lists as their names. The SMS convention is to use symbols in
;;; the keyword package, meaning that you cannot have two distinguishable
;;; instances whose names have the same symbol-name, even in different
;;; packages. This was desired in SMS so that object names can be looked up
;;; and accessed from multiple packages, but is a limitation that users should
;;; be aware of. Note that Remove-Instance needs to know how to remove
;;; entries both from this table and the following one.

(defvar *CLOS-Instance-Name-Table* (make-hash-table)
  "A hash table associating object NAMES with the objects themselves.")

;;;=============================================================================
;;; Every time a CLOS instance is created, it is added to the list of
;;; instances in this table that are associated with the class name. Note
;;; that Remove-Instance needs to know how to remove entries both from this
;;; table and the preceding one.
 
(defvar *CLOS-Class-Name-Table* (make-hash-table)
  "A hash table associating class names with the DIRECT instances of that class.
   Use ``Instances'' or ``Instance-Names'' to get ALL instances of that class.")

;;;=============================================================================
;;; Every time an instance is made that does not have an explicit name, then the
;;; counter associated with that class is used to get CLASS-N as the name, and
;;; then the counter is incremented.

(defvar *CLOS-Class-Name-Counters* (make-hash-table)
  "A hash table associating a class name with an integer. This integer is the
   next one that will be used for CLASSNAME-N when providing a name for an
   instance.")

;;;=============================================================================
;;; Any instance that is created will get a name based on its class (unless it
;;; has an explicit name), and will be recorded in the hash table.

(defmethod initialize-instance :after ((Obj Named-Object) &rest Extra-Args)
  (declare (ignore Extra-Args))
  (let ((Name (Name Obj))
	Previous-Instance)
    (cond
      ((and Name (not (keywordp Name)))
       (setf Name (Add-Colon Name)))
      ((null Name)
       (setf Name (Instance-Name (class-name (class-of Obj))))))
    (setf (slot-value Obj 'Name) Name)
    (setq Previous-Instance (Get-Instance Name))
    (when Previous-Instance
      (format t "~%Replacing ~S with ~S since they have the same name." Previous-Instance Obj)
      (Remove-Instance Previous-Instance))
    (setf (gethash (Name Obj) *CLOS-Instance-Name-Table*) Obj)
    (push Obj (gethash (Instance-Class Obj) *CLOS-Class-Name-Table*))
))

;;;=============================================================================
;;; If instance has a name slot, use it in the printed representation.
;;; If Name = Foo-3 (or :Foo-3), and class is FOO,  printed representation is
;;; #<FOO-3 (a FOO)>

(defmethod print-object ((Obj Named-Object) Stream)
  (let ((Name (symbol-name (Name Obj)))
	(Class (class-name (class-of Obj))))
    (format Stream "#<~A (~A ~S)>" Name (Indefinite-Article Class) Class) ))

(defun Indefinite-Article (String)
  "Returns \"a\" or \"an\" depending on whether or not String begins with a
   A, E, I, or O."
  (case (aref (string-capitalize String :end 1) 0)
    ((#\A #\E #\I #\O) "an")
    (otherwise          "a")) )

;;;=============================================================================
;;; If you try to call NAME on an object that is neither a Named-Object nor
;;; has an explicitly defined accessor NAME you get this warning message.

(defmethod Name ((Obj Standard-Object))
  (format t "~%~S is not a Named-Object, and has no accessor `Name'." Obj)
  (format t "~%Note that using `Define-Class' automaically makes the class~%~
               a subclass of Named-Object.")
)

;;;=============================================================================
;;; Given 'Foo returns :FOO-1 or :FOO-2, or in general :FOO-N for the smallest
;;  value of N such that :FOO-N has never been an existing instance name.
;;;
;;; This is better than using GENTEMP since GENTEMP does not necessarily number
;;; independently. Ie (gentemp "FOO-" :keyword) --> :FOO-1, but
;;; (gentemp "BAR-" :keyword) --> :BAR-2, not :BAR-1. Here, we prefer each
;;; class to have its own separate numbering. 

(defun Instance-Name (Class-Name)
  "Given a symbol such as `Sub', returns `:Sub-XX' for the next natural number
   XX for which :Sub-XX is not already an existing instance name."
  (let* ((N (incf (gethash Class-Name *CLOS-Class-Name-Counters* 0)))
	 (Name (intern (concatenate 'string
				    (symbol-name Class-Name)
				    "-"
				    (princ-to-string N))
		       :Keyword)))
    (if
      (Get-Instance Name)
      (Instance-Name Class-Name)
      Name)
))

;;;=============================================================================
;;; Given a name or an instance, returns the instance. "Name" can be a symbol
;;; in ANY package, not just in the keyword package. Thus any of the
;;; following will work:
;;;
;;; (setq test (make-instance 'Foo :Name 'Foobar))
;;;
;;; (Get-Instance 'Foobar)      --> #<Foobar (in class Foo)>
;;; (Get-Instance :Foobar)      --> #<Foobar (in class Foo)>
;;; (Get-Instance Test)         --> #<Foobar (in class Foo)>
;;; (Get-Instance 'Nonexistent) --> NIL
;;;
;;; Note also the macro characters described near the bottom of this file,
;;; whereby
;;;
;;; {Baz} == (get-instance 'Baz)      (quoted)
;;; [Baz] == (get-instance Baz)       (no quote), so
;;;
;;; {Foobar}                     --> #<Foobar (in class Foo)>
;;; (let ((Temp 'Foobar)) [Temp])--> #<Foobar (in class Foo)>

(defmethod Get-Instance ((Name symbol))
  (gethash (Add-Colon Name) *CLOS-Instance-Name-Table*) )

(defmethod Get-Instance ((Instance standard-object))
  Instance)

(defmethod Get-Instance (Bogus)
  (format t "~%[Get-Instance] Error! ~S was neither a symbol (instance name) ~
             nor an instance"
	  Bogus) )

;;;=============================================================================
;;; Takes an instance and copies all slot values to another. Assumes BOTH
;;; instances made via Define-Class in that they have identical slot names,
;;; and slot names correspond to accessors. 

(defun Copy-Instance (Copy-Source &key Copy-Destination Slot-Names-Not-to-Copy)
  "Given an instance it creates a new one of the same type with identical slot
   values. Creates the instance unless Copy-Destination is supplied in which
   case it is used. Any slot names specified in Slots-NOT-to-Copy are left
   with default values"
  (let (Slot-Value)
    (unless Copy-Destination
      (setq Copy-Destination (make-instance (class-of Copy-Source))))
    (loop for Slot-Name
	      in (set-difference (Slot-Names Copy-Source)
				 (cons 'Name Slot-Names-Not-to-Copy))
	  do
      (cond
	((not (slot-boundp Copy-Source Slot-Name))
	 (slot-makunbound Copy-Destination Slot-Name))
	(t
	 (setq Slot-Value (funcall Slot-Name Copy-Source))
	 (unless (and (slot-boundp Copy-Destination Slot-Name)
		      (equal Slot-Value (funcall Slot-Name Copy-Destination)))
	   (Assign-Slot-Value Copy-Destination Slot-Name Slot-Value)))) )
    Copy-Destination))

;;;=============================================================================
;;; Assigns VALUE to the SLOT of the instance with given name. Normally the
;;; slot name is known and (setf (accessor unit) value) can be used directly. 

(defun Assign-Slot-Value (Instance-Name Slot-Name Value)
  "Given a quoted Instance name, Slot name, and value, does
   (setf (Slot {Instance}) Value)"
  (eval `(setf (,Slot-Name (Get-Instance ',Instance-Name)) ',Value))
)

;;;=============================================================================
;;; This does not "kill" an instance; only removes the entries in the global
;;; hash tables. However, IF that was the only thing referencing the instance,
;;; removing that entry allows the instance to be reclaimed by the garbage
;;; collector.

(defmethod Remove-Instance ((Name symbol))
  (Remove-Instance-Internal Name (Get-Instance Name)) )

(defmethod Remove-Instance ((Instance Named-Object))
  (Remove-Instance-Internal (Name Instance) Instance) )

(defmethod Remove-Instance ((Instance standard-object))
  (format t "~%I only know how to remove-instances of named objects.~%~
              ~S is in class ~A, which is not a subclass of NAMED-OBJECT"
	  Instance (class-name (class-of Instance))) )

;;;=============================================================================
;;; Does the actual removing, from both relevant hash tables. Removal is
;;; deliberately destructive (DELETE instead of REMOVE) since it would be an
;;; error if someone else referenced an instance after it was supposedly
;;; deleted.

(defun Remove-Instance-Internal (Instance-Name Instance)
  "Internal routine used by Remove-Instance methods to remove instances from
   hash tables"
  (let ((Class (Instance-Class Instance)))
    (remhash (Add-Colon Instance-Name) *CLOS-Instance-Name-Table*)
    (setf (gethash Class *CLOS-Class-Name-Table*)
	  (delete Instance (gethash Class *CLOS-Class-Name-Table*))) ))

;;;=============================================================================
;;; Removes all the instances in a given class, assuming class is a subclass of
;;; NAMED-OBJECTS. "Removes" is in the sense of Remove-Instance above.

(defun Remove-Instances (Class-Name)
  "Removes all instances of specified class from the two global hash tables"
  (mapc #'Remove-Instance (Instances Class-Name)) )

;;;=============================================================================
;;; Returns a list of all the *named* CLOS instances stored in
;;; *CLOS-Class-Name-Table*, which has the class name as the key. This does
;;; *not* include instances of subclasses.

(defun Direct-Instances (Class-Name)
  "Returns a list of all named instances that are in specified class
  (withOUT inheritance)"
  (gethash Class-Name *CLOS-Class-Name-Table*))
    
;;;=============================================================================
;;; Returns a list of all the *named* CLOS instances stored in
;;; *CLOS-Instance-Name-Table* that are in specified class (either directly
;;; or via a subclass). Note that since class-direct-subclasses (used by
;;; Subclasses) is not part of the ANSI spec, this is not guaranteed to be
;;; portable, although it is in practice across most major vendors. However,
;;; the alternative was to maphash on *CLOS-Instance-Name-Table*, checking
;;; typep to see if the value belonged to Class-Name. This has the unfortunate
;;; behavior that it is linear in time wrt the total number of named CLOS
;;; instances. This list is NOT sorted (as Instance-Names is) in order to
;;; emphasize performance.

(defun Instances (Class-Name)
  "Returns a list of all the named CLOS instances stored in
   *CLOS-Instance-Name-Table* that belong to the specified class. Use
   `Instance-Names' to get the names instead of the instance objects"
  (if
    (find-class Class-Name NIL)
    (apply #'append
	   (Direct-Instances Class-Name)
	   (mapcar #'Instances (Subclasses Class-Name)))
    (values NIL
	    (format nil "~S is not a subclass of NAMED-OBJECT" Class-Name)) )
)

;;;=============================================================================
;;; Similar to the above except returns NAMES, and may be sorted
;;; alphabetically. This sorting pays a significant performance penalty, so
;;; don't use this unless necessary.

(defun Instance-Names (Class-Name &key Sort-p)
  "Returns names of all the clos instances stored in *CLOS-Instance-Name-Table*
   that belong to specified class. Use `Instances' to get instance objects
   instead of names and specify `:Sort-p t' to get names in alphabetical order"
  (if (find-class Class-Name NIL)
      (let ((Names (mapcar #'Name (Instances Class-Name))))
	(if Sort-p
	    (Sort-Names Names)
	    Names))
      (values NIL
	      (format nil "~S is not a subclass of NAMED-OBJECT" Class-Name)))
)

;;;=============================================================================
;;; Returns a list of all the NAMED clos instances stored in
;;; *CLOS-Instance-Name-Table*, unsorted. 

(defun All-Instances ()
  "Returns a list of all the clos instances stored in *CLOS-Instance-Name-Table*
   Use `All-Instance-Names' to get the names instead of the instance objects"
  (let (Instances)
    (maphash #'(lambda (Key Value)
		 (declare (ignore Key))
		 (push Value Instances))
	     *CLOS-Instance-Name-Table*)
    Instances
))

;;;=============================================================================
;;; Returns names of all the NAMED clos instances stored in
;;; *CLOS-Instance-Name-Table*, possibly in alphabetical order. 

(defun All-Instance-Names (&key Sort-p)
  "Returns names of all the clos instances stored in *CLOS-Instance-Name-Table*,
   sorted in alphabetical order if the :Sort-p flag is supplied"
  (let ((Names '()))
    (maphash #'(lambda (Key Value)
		 (declare (ignore Value))
		 (push Key Names))
	     *CLOS-Instance-Name-Table*)
    (if Sort-p
	(Sort-Names Names)
	Names)
))

;;;=============================================================================
;;; Given an instance or a class name, returns a list of the slots. Assuming
;;; the class was defined with Define-Class, this means that every slot SlotJ
;;; has a reader function also called SlotJ, and that every slot SlotJ also
;;; has a (setf SlotJ) writer, EXCEPT for the "Name" slot. 
;;;
;;; WARNING!! This is not guaranteed to be transportable; since
;;; slot-definition-name and class-slots are NOT part of the ANSI spec.
;;; But Symbolics, Lucid, Franz, Harlequin, and even PCL all have them, and
;;; they are part of the de-facto standard agreed upon by most of the major
;;; LISP vendors as the "introspective" portion of the MOP. But code that must
;;; be completely portable should not depend upon this.

(defmethod Slot-Names ((Instance Standard-Object))
  (mapcar #'slot-definition-name (class-slots (class-of Instance))) ) 

(defmethod Slot-Names ((Class-Name symbol))
  (mapcar #'slot-definition-name (class-slots (find-class Class-Name))))

;;;=============================================================================
;;; Same as above, but does not include inherited slots. Same caveats re lack of
;;; guaranteed transportability apply. 10/92 Marty Hall

(defmethod Direct-Slot-Names ((Instance Standard-Object))
  (mapcar #'slot-definition-name (class-direct-slots (class-of Instance))) ) 

(defmethod Direct-Slot-Names ((Class-Name symbol))
  (mapcar #'slot-definition-name (class-direct-slots (find-class Class-Name))))

;;;=============================================================================
;;; Checks if a slot name has a reader by the same name. In fact, it really
;;; checks to see if there is a method defined with the same name as
;;; Slot-Name (which is in fact any symbol), and that can accept that instance
;;; as its only argument. So this could in principle be fooled into saying
;;; "yes" when there is an associated method but when that method is not a
;;; slot reader. 
;;;
;;; Note also that you cannot use FIND-METHOD, since it does not get inherited
;;; methods. 10/92 Marty Hall

(defun Has-Reader-p (Instance Slot-Name)
  (and (fboundp Slot-Name)
       (compute-applicable-methods (symbol-function Slot-Name)
				   (list Instance))) )

;;;=============================================================================
;;; This creates macro characters such that {foo} == (Get-Instance :foo). These
;;; functions should never need to be called directly by the user. Doing the
;;; INTERN at compile time saves time at runtime vs just translating to
;;; (Get-Instance 'Foo). Inspired by method of Eric Muehle in the FROBS
;;; system.

(defun Bracket-Instance-Name (Stream Char)
  (declare (ignore Char))
  (let ((List (read-delimited-list #\} stream t)))
    `(Get-Instance ,(Add-Colon (first List))) ))

(set-macro-character #\{ #'Bracket-Instance-Name)

;;;----------------------------------------------------------------------------
;;; I think you should be able to just do 
;;; (set-macro-character #\} (get-macro-character #\) )), but
;;; (get-macro-character #\) ) returns NIL on Symbolics.

(defun Extra-Space (Stream Char)
  (declare (ignore Stream) (ignore Char))
  #\space)

(set-macro-character #\} #'Extra-Space)

;;;=============================================================================
;;; This creates macro characters such that [Foo] == (get-instance Foo). Ie the
;;; instance name is evaluated, unlike in the above case. Ie if the variable
;;; Name is bound to 'Own-ship, then [Name] == (Get-Instance 'Own-ship).
;;; 10/92 Marty Hall

(defun Bracket-Instance-Var (Stream Char)
  (declare (ignore Char))
  (let ((List (read-delimited-list #\] stream t)))
    `(Get-Instance ,(first List))))

(set-macro-character #\[ #'Bracket-Instance-Var)

(set-macro-character #\] #'Extra-Space)

;;;=============================================================================
;;; This (if Instance ...) test is required to avoid returning NULL (the
;;; name of the class of objects whose value is NIL) in the cases when an
;;; instance-name is supplied that names no instance. This way returns
;;; NIL instead.

(defun Instance-Class (Instance-or-Instance-Name)
  "Given an instance name or an instance object returns a symbol that is the
   immediate class name. Ie given 'Bear-1 returns BEAR. If the argument is
   neither an instance nor an instance name, this returns NIL."
  (let ((Instance (Get-Instance Instance-or-Instance-Name)))
    (if
      Instance                               
      (class-name (class-of Instance))))) 

;;;=============================================================================
;;; Given a class name returns the names of the immediate subclasses. Note
;;; that, like Slot-Names, this uses the de-facto standard part of the MOP,
;;; which is *not* in the ANSI spec and thus is not guaranteed to be
;;; completely transportable. Note also that this returns NIL either when
;;; Class-Name names a class with no subclasses OR when Class-Name names
;;; no class.

(defun Subclasses (Class-Name &key Sort-p)
  "Given a potential Class-Name returns the names of the immediate subclasses.
   Returns NIL either when Class-Name names a class with no subclasses OR when
   Class-Name names no class."
  (let ((Class (find-class Class-Name NIL)))
    (cond
      ((null Class)
       NIL)
      (Sort-p
       (Sort-Names (mapcar #'class-name (class-direct-subclasses Class))))
      (t
       (mapcar #'class-name (class-direct-subclasses Class)))) ))

;;;=============================================================================
;;; Used internally by functions that have :Sort-p keyword.

(defun Sort-Names (Symbol-List)
  (sort (copy-list Symbol-List) #'string-lessp :key #'symbol-name) )

;;;=============================================================================
;;; This is NOT transportable, although most implementations have a similar
;;; function. The idea is to be able to modify the print-object function
;;; even for CLOS instances that do not have a unique identifier (like the
;;; Name slot in Named-Objects). The default print-object, for an instance of
;;; class Foo, does something like #<Foo 12345> (on Symbolics), or
;;; #<Foo #X123AB> (on Lucid). In both cases the identifying number is the
;;; address (in octal on Symbolics, hex on Lucid). So we would like to be able
;;; to retrieve that value in order to, for instance, change the print-object
;;; to give something like #<Foo 12345 (with RANGE of 6.78)>, or whatever.
;;; This could now be done by using a print-object that makes use of the
;;; following.

(defun Internal-Address-String (Object)
  "A non-standard way to get the address of an object on Symbolics or Lucid
   Returns it in a string for use by a specialized print-object"
  #+:symbolics(format nil "~8R" (sys:%pointer Object))
  #+:lucid    (format nil "~16R" (system:%pointer Object))
  #-(or :symbolics :lucid) "1234")

;;;=============================================================================