anchor.diff:        ;; as may extend SINGLETON. In a future revision, this concern may
         ;; be addressed with a manner of initialization argument mangling
         ;; onto SHARED-INITIALIZE (SINGLETON T)
  +      ;;
  +      ;; NB: This should be considered again, in light of the
  +      ;; PROTOTYPE-CLASS proposal, as described -- in something of a
  +      ;; rough sketch reagard -- at the end of this source file.
  +      ;;
  +      ;; This macro may subsequently be updated to not use DEFCLASS at
  +      ;; all.
  +      ;;
  +      ;; It should provide an analogous behvior to DEFCLASS, in every
  +      ;; portable regard. Note e.g during SB-PCL DEFCLASS
  +      ;; - SB-KERNEL::%COMPILER-DEFCLASS in the compiler environment
  +      ;;   - Can this be approximated with a compile-time DEFTYPE ?
  +      ;; - SB-PCL::LOAD-DEFCLASS in normal top-level evaluation
         (multiple-value-bind (%metaclass %params)
  +          ;; NB: This does not check to ensure that any specified
  +          ;; metaclass is a subtype of SINGLETON
  +          ;;
  +          ;; NB: This metaclass support might be summarily removed, in
  +          ;; lieu of a SINGLETON-PROTOTYPE semntics - if not supplanted
  +          ;; with a :PROTOTYPE-METACLASS semantics
             (compute-metaclass params)
  +
  +        ;; FIXME: Prepend the singleton prototype class to %SUPERCLASSES
  +        ;; ... in effect, as this may have to abandon DEFCLASS
           `(defclass ,name ,%superclasses
              ,slots
              ,%metaclass
  
positive.code:   ((sl-1)
     (sl-b)))
  
  (let ((c (find-class 'singleton-1)))
    ;;   (finalize-inheritance c)
    (multiple-value-bind (st-1 st-2)
        (subtypep c 'singleton)
      (multiple-value-bind (mt-1 mt-2)
  
negative.code: 
  (class-direct-slots (find-class 'singleton-2))
  
  ;; -- Towards defining a subclass of SINGLETON as an instance of its own class
  
  ;; FIXME - DESIGN ISSUE
  
  (typep (find-class 'singleton-1) 'singleton-1)
  ;; => NIL ; which is not good for this design
  
  
  (defparameter *c1*
    (make-instance 'forward-referenced-class
                   :name (gentemp "C1-")))
  
  (change-class *c1* (find-class 'singleton)
                :direct-superclasses (list *c1* (find-class 'singleton)))
  ;; ^ fails during SHARED-INITIALIZE :AFTER (SB-PCL::STD-CLASS T)
  ;;   ... more specifically, in SB-PCL::UPDATE-CLASS
  ;;       ... with a generic SIMPLE-ERROR
  
  ;; ADD-DIRECT-SUBCLASS - needed for class-system mangement, but
  ;; insufficent for updating the class itself
  
  (defparameter *c2*
    (make-instance 'singleton
                   :name (gentemp "C2-")))
  
  (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.
        ;;
        ;; PCL also does not define any setter for the metaclass slot that
        ;; CLASS-DIRECT-SUBCLASSES accesses.
        ;;
        ;; Many of those metaclass slots may be defined, in effect,
        ;; "Read-only." However, this does not in itself serve to prove as
        ;; if those slots' values cannot be usefully modified -- if
        ;; corresponding to an appropriate modification of class layout
        ;; information, in an implementation-specific regard.
        (cons *c2* (class-direct-superclasses *c2*)))
  
  ;; No way to work around that pedagogic quirk in UPDATE-CLASS ?
  ;;
  ;; Even if the DIRECT-SUPERCLASSES list is destructively modified
  ;; for the class, PCL might still cause it to fail during SHARED-INITIALIZE
  
  
  
  (defparameter *c3*
    (make-instance 'singleton
                   :direct-superclasses  (list (find-class 'singleton))
                   :name (gentemp "C3-")))
  
  ;; (typep *c3* 'singleton)
  
  ;; (subtypep *c3* 'singleton)
  ;;  => T, T
  
  ;; -- [!!] --
  
  ;; There may be a way to work around that pedagogic quirk in PCL,
  ;; by using an anonymouns intermediary class representative of
  ;; the user-specified superclass information - such that the
  ;; user-named class will be a subclass and an instance of that
  ;; class (but not a subclss of itself)
  ;;
  ;; Such as class may be denoted as the PROTOTYPE-CLASS of a SINGLETON
  ;;
  ;; This bit of indirection will require an update onto DEFSINGLETON
  
  
  )
  
  
  (defun* find-superclass (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)
             (values &optional class))
    (labels ((handle-fail ()
               (cond
                 (errorp
                  (error "No superclss ~S found for ~S"
                         super class))
                 (t (values)))))
      (let ((%super (compute-class super errorp))
            (%class (compute-class class errorp)))
        (cond
          ((eq %class %super) (values %class))
          ((eq %class (load-time-value (find-class 't)
                                       t))
           (handle-fail))
          (t
           (dolist (c (class-direct-superclasses %class)
                    (handle-fail))
             (cond
               ((eq c %super) (return %class))
               (t (let ((found
                         (find-superclass %super c nil)))
                    (when found
                      (return c)))))))))))
  #+NIL
  (eval-when () ;; instance tests - FIND-SUPERCLASS
  
    (defclass f-1 ()
      ())
  
    (defclass f-2 (f-1)
      ())
  
    (defclass f-3 (f-2)
      ())
  
    (find-superclass 'f-1 'f-3)
    => #.(find-class 'f-2)
  
    (find-superclass 'g-1 'f-3 nil)
    => no value returned
  
    (defclass g-2 () ())
  
    (find-superclass 'g-2 'f-3 nil)
    => no value returned
  )
  
  ;; FIXME: use (FIND-SUPERCLASS 'singleton ...) in DEFSINGLETON*
  
  
  (defmacro defsingleton* (name (&rest superclasses)
                                  slots
                           &rest params)
    (labels ((compute-metaclass (params)
               (let ((meta-n (position :metaclass
                                       (the list params)
                                       :test #'eq
                                       :key #'car)))
                 (cond
                   (meta-n
                    (let* ((meta-prop
                            (nth meta-n params))
                           (params-adj
                            (remove meta-prop params
                                    :test #'eq)))
                      (values (cadr meta-prop) params-adj)))
                   (t
                    (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)))))
        (with-symbols (%proto %superclasses %supers
                              %fwd %c %cdef %fwdc
                              %singleton )
          (multiple-value-bind (%metaclass %params)
              (compute-metaclass params) ;; NB: May be unused here
  
            ;; NB: This mayx fail if any of the superclasses is a
            ;; forward-referenced class - that can be worked around, locally.
  
            ;; NB: Using an implcit PROTOTYPE-METACLASS := SINGLETON here.
            ;;     This may be updated, in a later revision.
            `(let* ((,%fwd nil)
                    (,%superclasses (quote ,superclasses))
                    (,%supers
                     (mapcar #'(lambda (,%c)
                                 (let ((,%cdef (find-class ,%c nil)))
                                   (cond
                                     (,%cdef (values ,%cdef))
                                     (t
                                      ;; FIXME: Consider using
                                      ;; ENSURE-CLASS here
                                      (let ((,%fwdc (make-instance
                                                     'forward-referenced-class
                                                     :name ,%c)))
                                        (setf ,%fwd
                                              (nconc ,%fwd (list ,%fwdc)))
                                        (values ,%fwdc))))))
                             ,%superclasses)))
  
               ;; T.D: Emit a style-warning about each class in %FWD
               ;;
               ;; TBD: Also define a rudimentary DEFTYPE ... CLASS
               ;; within the compiler environment, for each class in %FWD
  
               (let ((,%singleton (load-time-value (find-class 'singleton)
                                                   t)))
                 (unless (some (lambda (c)
                                 (find-superclass ,%singleton c nil))
                               ,%supers)
                   (setf ,%supers (nconc ,%supers (list ,%singleton)))))
  
               (let ((,%proto (ensure-class (quote ,%proto-name)
                                            :metaclass (quote ,%metaclass)
                                            :direct-superclasses ,%supers)))
                 ;; NB: ^ This may not be sufficent as to be able to
                 ;; locate the class during evaluation of the following
                 (values
                  (defclass ,name ,(cons %proto-name superclasses)
                    ,slots
                    (:metaclass ,%proto-name)
                    ,@%params)
                  ,%proto
                  ,%fwd))))))))
  
  (eval-when ()
  
    (defclass frob-c ()
      ())
  
  
    (defsingleton* frob-s-1 (frob-c)
      ())
  
    (typep (find-class 'frob-s-1) 'frob-c)
    ;; => T
  
    (subtypep (find-class 'frob-s-1) 'frob-c)
    ;; => T, T
  
    (typep (make-instance (find-class 'frob-s-1)) 'frob-c)
    ;; => T
  
    ;; So, THIS WORKS
  
    ;; though it's indecorus as for the default prototype class naming a.t.m
  
    (subtypep (make-instance (find-class 'frob-s-1)) 'frob-c)
    ;; FIXME => NIL, T
    ;; ^ dispatch in INITIALIE-INSTANCE such as to create an instance of
    ;; the prototype clss of FROB-S-1 w/ FROB-S-1 as a superclass
  
  )
  