anchor.diff:    ;; the prototype clss of FROB-S-1 w/ FROB-S-1 as a superclass
   
   )
  +
  +#+TBD
  +(eval-when ()
  +
  +(defsingleton* singleton-1-1 ()
  +  ((sl-1)
  +   (sl-b)))
  +
  +(typep (find-class 'singleton-1-1) 'singleton)
  +;; => T
  +
  +(subtypep (find-class 'singleton-1-1) 'singleton)
  +;; => T, T
  +
  +;; alternately ...
  +(let ((c (find-class 'singleton-1-1)))
  +  (multiple-value-bind (st-1 st-2)
  +      (subtypep c 'singleton)
  +    (multiple-value-bind (mt-1 mt-2)
  +        (subtypep (class-of c) 'singleton)
  +      (values st-1 st-2
  +              mt-1 mt-2))))
  +
  +;; => T, T, T, T
  +
  +
  +(class-slots (find-class 'singleton-1-1))q
  +
  +(class-direct-slots (find-class 'singleton-1-1))
  +
  +
  +(defsingleton* singleton-2-2 (singleton-1-1)
  +  ((sl-c)))
  +
  +
  +(class-slots (find-class 'singleton-1-2))
  +
  +(class-direct-slots (find-class 'singleton-1-2))
  +
  +(typep (find-class 'singleton-1-1) 'singleton-1-1)
  +;; => NIL ; which still is not good for this design
  +
  +(typep (find-class 'singleton-2-2) 'singleton-1-1)
  +;; => T ;; NB "OK" (this differs from the original DEFSINGLETON)
  +;;
  +(subtypep (class-of (find-class 'singleton-2-2)) 'singleton-1-1)
  +;; => T, T
  +
  +
  +
  +(typep (make-instance 'singleton-1-1) 'singleton-1-1)
  +;; => T ;; which is passable,
  +;;         but really no different than  STANDARD-OBJECT semiotics
  +
  +
  +(subtypep (make-instance 'singleton-1-1) 'singleton-1-1)
  +;; => NIL, T ;; not OK
  +
  +(subtypep (make-instance 'singleton-2-2) 'singleton-1-1)
  +;; => NIL, T ;; not OK
  +
  +
  +;; to make a suclass C2 of a class C1 both an instance and subtype of C1 ...
  +;;
  +;; define MAKE-INSTANCE => CREATE-SUBTYPE
  +
  +;; NB: However approached - whether by prepending a singleton S to the
  +;; list of direct superclasses specified originally to MAKE-INSTANCE, or
  +;; if otherwise - this change will also affect the outcomes of the
  +;; original DEFSINGLETON (no prototype-class) macro definition.
  +
  +
  +
  +)
  +
  +;; #+TESTING
  +(eval-when ()
  +(defmethod shared-initialize ((instance singleton) slots
  +                              &rest initargs &key
  +                                               direct-superclasses
  +                                               &allow-other-keys)
  +  ;; ensure that any call to MAKE-INSTANCE of a SINGLETON will produce
  +  ;; an object that is a subtype of the original SINGLETON [FIXME DNW]
  +  (let (initargs-updated)
  +    (macrolet ((dispatch ()
  +                 `(cond
  +                    (initargs-updated
  +                     (apply #'call-next-method instance slots initargs))
  +                    (t (call-next-metod)))))
  +      (labels ((ensure-superclass (c)
  +                 (cond
  +                   (direct-superclasses
  +                    (unless (some (lambda (c)
  +                                    (find-class-in-precedence instance c nil))
  +                                  direct-superclasses)
  +                      (prog1 (setf (getf initargs :direct-superclasses)
  +                                   (cons instance direct-superclasses))
  +                        (setq initargs-updated t))))
  +                   (t (prog1 (setf (getf initargs :direct-superclasses)
  +                                   (cons instance direct-superclasses))
  +                        (setq initargs-updated t))))))
  +        (ensure-superclass instance)
  +        (dispatch)))))
  +
  +)
  +
  +(eval-when ()
  +  (defsingleton* x-a ()
  +    ())
  +
  +  (typep (make-instance 'x-a) 'x-a)
  +  ;; => T ;; consistent onto CLOS
  +
  +  (subtypep (make-instance 'x-a) 'x-a)
  +  ;; FIXME while => NIL, T
  +
  +  ;; NB/ORTHOGONAL - CLOS and MOP
  +  (values (find-class nil nil)
  +          (let* ((nm (gentemp "singleton-"))
  +                 (c (make-instance 'x-a :name nm)))
  +            (find-class nm nil)))
  +  ;; => NIL, NIL
  +  ;;
  +  ;; THUS: While MAKE-INSTANCE of a STANDARD-CLASS does result in an
  +  ;; object that is (TYPEP object 'STANDARD-CLASS) but it may not
  +  ;; result in the compiler type system recognizing the instance as
  +  ;; representing a defined class. In that regard, it would seem as
  +  ;; though the class-name has no consistent effect, until the class is
  +  ;; registered -- via non-portable code -- in the implementation type
  +  ;; system.
  +  ;;
  +  ;; FIXME - VULN ANALYSIS: Theoretically, it may be possible to use
  +  ;; MAKE-INSTANCE to create a STANDARD-CLASS that has a name EQ to any
  +  ;; defined system class, while that named but "Unknown" class would
  +  ;; not be EQ to the corresponding system class, in the
  +  ;; implementation.
  +
  +
  +;; ...
  +
  +  (defsingleton* x-b (x-a)
  +    ;; FIXME: New DEFSINGLETON* DNW for any forward-referenced superclass
  +    ())
  +
  +  (typep (make-instance 'x-b) 'x-b)
  +  ;; => T ;; consistent onto CLOS
  +
  +  (typep (make-instance 'x-b) 'x-a)
  +  ;; => T ;; consistent onto CLOS
  +
  +  (subtypep (make-instance 'x-b) 'x-a)
  +  ;; FIXME while => NIL, T
  +
  +  (subtypep (find-class 'x-b) 'x-a)
  +  ;; => T, T
  +  ;; should be same, with or without the added SHARED-INITIALIZE
  +  ;; as it's consistent onto CLOS
  +
  +
  +;; -- test the new SHARED-INITIALIZE method with the original DEFSINGLETON macro
  +  (defsingleton x-c ()
  +    ())
  +  (typep (make-instance 'x-c) 'x-c)
  +  ;; => T ;; consistent onto CLOS
  +
  +
  +  (class-direct-superclasses (find-class 'x-c))
  +
  +  ;; -
  +
  +  (defsingleton x-d (x-c)
  +    ())
  +  (typep (make-instance 'x-d) 'x-d)
  +  ;; => T ;; consistent onto CLOS
  +
  +  (subtypep (make-instance 'x-d) 'x-c)
  +  ;; FIXME while => NIL, T
  +  ;; same behavior as with new DEFSINGLETON* [FIXME there too]
  +
  +
  +  (class-direct-superclasses (find-class 'x-d))
  +
  +  (subtypep 'x-d 'x-c)
  +  ;; => T, T ;; consistent onto CLOS
  +
  +
  +)
  +
  +
  +;; --
  +
  +
  +;; T.D: Also test this type/instance/subtype semantics for CHANGE-CLASS
  +;; from a FORWARD-REFERENCED-CLASS to SINGLETON
  
positive.code: (add-direct-subclass (find-class 'singleton) *c2*)
  
  (class-direct-superclasses *c2*)
  
  ;; ...
  
  #+DNW
  (setf (class-direct-superclasses *c2*)
        ;; DNW - there is no standard SETF method corresponding to this
        ;; reader function.
  
negative.code: 
  
    (defsingleton* frob-s-1 (frob-c)
      ;; FIXME May err if evaluated twice - see above remarks
      ())
  
    (typep (find-class 'frob-s-1) 'frob-c)
  