anchor.diff:  )
   
   
  -(defun* find-superclass (super class &optional (errorp t))
  +(defun* find-class-in-precedence (super class &optional (errorp t))
     ;; return the first class found, of which SUPER it is a direct superclass
     ;; or the class itself if SUPER is equivalent to CLASS
     (declare (type class-designator super class)
  
positive.code:                   (values 'singleton params))))))
      (let ((%proto-name
             ;; FIXME: Allow this to be specified in PARAMS (??)
             (make-symbol (concatenate 'simple-string
                                      (symbol-name name)
                                      (symbol-name '#:-prototype)))))
  
negative.code:   ;; 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
  